{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} module Main where import qualified SDL hiding (V2(..)) import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Enum as SDL import Control.Concurrent.STM import Graphics.GPipe import Control.Monad import Control.Monad.Trans import Reactive.Banana.Frameworks as RBF import Reactive.Banana.Combinators as RBC import Data.Maybe (fromMaybe) -- internal imports import Types main :: IO () main = do SDL.initializeAll -- window <- SDL.createWindow "frpball" $ SDL.defaultWindow -- { SDL.windowInitialSize = V2 800 600 -- , SDL.windowResizable = True -- , SDL.windowOpenGL = Just SDL.defaultOpenGL -- { SDL.glProfile = SDL.Core SDL.Normal 3 3 -- } -- } void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 -- context <- SDL.glCreateContext window runContextT (FRPBallCtxConfig "frpball" SDL.defaultWindow { SDL.windowInitialSize = V2 800 600 , SDL.windowResizable = True , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.glProfile = SDL.Core SDL.Normal 3 3 } }) $ do win <- newWindow (WindowFormatColor RGB8) ("frpball", SDL.defaultWindow { SDL.windowInitialSize = V2 800 600 , SDL.windowResizable = True , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.glProfile = SDL.Core SDL.Normal 3 3 } } ) vertexBuffer :: Buffer os AttrInput <- newBuffer 3 writeBuffer vertexBuffer 0 [ (V4 (-1) 1 0 1, V3 1 0 0) , (V4 0 (-1) 0 1, V3 0 1 0) , (V4 1 1 0 1, V3 0 0 1) ] hexBuffer :: Buffer os AttrInput <- newBuffer 18 writeBuffer hexBuffer 0 [ (V4 (-1/2) 1 0 1, V3 1 0 0) , (V4 (1/2) 1 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (1/2) 1 0 1, V3 1 0 0) , (V4 1 0 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 1 0 0 1, V3 1 0 0) , (V4 (1/2) (-1) 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (1/2) (-1) 0 1, V3 1 0 0) , (V4 (-1/2) (-1) 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (-1/2) (-1) 0 1, V3 1 0 0) , (V4 (-1) 0 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (-1) 0 0 1, V3 1 0 0) , (V4 (-1/2) 1 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) ] uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1 positionUniformBuffer :: Buffer os (Uniform (B2 Float)) <- newBuffer 1 hexShader <- compileShader $ do hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput)) positionUniform <- getUniform (const (positionUniformBuffer, 0)) let scaleFact = 0.05 scaleMatrix a = V4 (V4 a 0 0 0) (V4 0 a 0 0) (V4 0 0 1 0) (V4 0 0 0 1) transMatrix (V2 ax ay) = V4 (V4 1 0 0 (ax - 1)) (V4 0 1 0 ((-ay) + 1)) (V4 0 0 1 1) (V4 0 0 0 1) hexFragmentStream <- rasterize (const ( FrontAndBack , ViewPort (V2 0 0) (V2 800 600) , DepthRange 0 1 ) ) (fmap (\(position, color) -> ( (transMatrix positionUniform !*! scaleMatrix scaleFact) !* position , color )) hexPrimitiveStream) drawWindowColor (const ( win , ContextColorOption NoBlending (V3 True True True) ) ) hexFragmentStream shader <- compileShader $ do primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput)) uniform <- getUniform (const (uniformBuffer, 0)) let primitiveStream2 = fmap (\(position, color) -> (position - V4 1 1 0 0, color / 10)) primitiveStream primitiveStream3 = primitiveStream `mappend` primitiveStream2 rotationMatrix a = V4 (V4 (cos a) (-sin a) 0 0) (V4 (sin a) (cos a) 0 0) (V4 0 0 1 0) (V4 0 0 0 1) first fun (position, color) = (fun position, color) primitiveStream4 = fmap (first (rotationMatrix uniform !*)) primitiveStream3 fragmentStream <- rasterize (const ( FrontAndBack , ViewPort (V2 0 0) (V2 800 600) , DepthRange 0 1 ) ) primitiveStream4 drawWindowColor (const ( win , ContextColorOption NoBlending (V3 True True True) ) ) fragmentStream -- SDL.showWindow window listen@(_, fire) <- liftIO $ newAddHandler uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float) transUniVar <- liftIO $ newTMVarIO (V2 1 1) :: ContextT FRPBallCtx os IO (TMVar (V2 Float)) network <- liftIO $ compile (networkDescription listen uniVar transUniVar) forever $ do mrot <- liftIO $ atomically $ tryReadTMVar uniVar writeBuffer uniformBuffer 0 [fromMaybe 0 mrot] mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans] liftIO $ actuate network render $ do clearWindowColor win (V3 0 0 0) vertexArray <- newVertexArray vertexBuffer hexVertexArray <- newVertexArray hexBuffer let primitiveArray = toPrimitiveArray TriangleList vertexArray let hexPrimitiveArray = toPrimitiveArray TriangleList hexVertexArray shader primitiveArray hexShader hexPrimitiveArray swapWindowBuffers win liftIO $ do evs <- SDL.pollEvents fire evs networkDescription :: (AddHandler [SDL.Event], b) -> TMVar Float -> TMVar (V2 Float) -> MomentIO () networkDescription (listenerah, _) rotvar transvar = mdo (mouseah, mousefire) <- liftIO $ newAddHandler (passah, passfire) <- liftIO $ newAddHandler (clickholdah, clickholdfire) <- liftIO $ newAddHandler blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire clickholdfire _ <- changes blistener emouse <- fromAddHandler =<< registerMouseEvent passfire mouseah epass <- fromAddHandler =<< registerPassEvent passah eClickHold <- fromAddHandler =<< registerClickHoldEvent clickholdah clickHoldBehaviour <- RBC.stepper False eClickHold mouseMoveBehaviour <- RBC.stepper (V2 1 1) epass let moveReaction = fmap (\x -> do let input = (\(V2 xx _) -> fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload x past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar) void $ atomically $ swapTMVar rotvar (past + input) print input) emouse clickReaction = fmap (\x -> do let input = (fmap (\foo -> foo - 1) x) / V2 400 300 void $ atomically $ swapTMVar transvar input print input) mouseMoveBehaviour reactimate moveReaction reactimate' =<< (whenE clickHoldBehaviour <$> changes clickReaction) registerListenerEvent :: (MonadIO m) => AddHandler ([SDL.Event]) ->(SDL.Event -> IO ()) -> (Bool -> IO ()) -> m (AddHandler [SDL.Event]) registerListenerEvent listenerah mousefire clickholdfire = do void $ liftIO $ register listenerah $ \evs -> do let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of SDL.MouseMotionEvent _ -> True _ -> False ) evs filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ [SDL.ButtonLeft] _ _) -> True _ -> False ) evs if null filteredMoveEvents then return () else mousefire (head $ reverse $ filteredMoveEvents) if null filteredClickEvents then clickholdfire False else clickholdfire True return listenerah registerMouseEvent :: MonadIO m => (V2 Float -> IO ()) -> AddHandler SDL.Event -> m (AddHandler SDL.Event) registerMouseEvent passFire mouseah = do void $ liftIO $ register mouseah $ \(SDL.Event _ (SDL.MouseMotionEvent dat)) -> passFire (fmap fromIntegral $ (\(SDL.P a) -> a) $ SDL.mouseMotionEventPos dat) return mouseah registerPassEvent :: MonadIO m => AddHandler (V2 Float) -> m (AddHandler (V2 Float)) registerPassEvent passah = do void $ liftIO $ register passah $ \_ -> return () return passah registerClickHoldEvent :: MonadIO m => AddHandler Bool -> m (AddHandler Bool) registerClickHoldEvent clickholdah = do void $ liftIO $ register clickholdah $ \_ -> return () return clickholdah