{-# 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@(_, eventFire) <- liftIO $ newAddHandler deltaTimer@(_, deltaFire) <- liftIO $ newAddHandler uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float) transUniVar :: TMVar (V2 Float) <- liftIO $ newTMVarIO (V2 1 1) deltaVar :: TMVar Float <- liftIO (newTMVarIO =<< SDL.time) network <- liftIO $ compile (networkDescription listen deltaTimer 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 currentTime :: Float <- SDL.time oldTime <- fromMaybe (currentTime - 0.1) <$> (atomically $ tryReadTMVar deltaVar) eventFire evs deltaFire (currentTime - oldTime) atomically $ swapTMVar deltaVar currentTime networkDescription :: (AddHandler [SDL.Event], ([SDL.Event] -> IO ())) -> (AddHandler Float, (Float -> IO ())) -> TMVar Float -> TMVar (V2 Float) -> MomentIO () networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo (ballPosAH, ballPosFire) <- liftIO $ newAddHandler (ballVelAH, ballVelFire) <- liftIO $ newAddHandler (ballAccAH, ballAccFire) <- liftIO $ newAddHandler (mousePosAH, mousePosFire) <- liftIO $ newAddHandler (mouseMotionAH, mouseMotionFire) <- liftIO $ newAddHandler (mouseClickAH, mouseClickFire) <- liftIO $ newAddHandler (mouseReleaseAH, mouseReleaseFire) <- liftIO $ newAddHandler (mouseClickPosAH, mouseClickPosFire) <- liftIO $ newAddHandler ballPos :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do void $ register ballPosAH (\_ -> return()) return ballPosAH ) ballVel :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do void $ register ballVelAH (\_ -> return()) return ballVelAH ) ballAcc :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do void $ register ballAccAH (\_ -> return()) return ballAccAH ) mousePos :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do void $ register mousePosAH (\_ -> return()) return mousePosAH ) mouseMotion :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do void $ register mouseMotionAH (\_ -> return()) return mouseMotionAH ) mouseClick :: Event Bool <- fromAddHandler =<< (liftIO $ do void $ register mouseClickAH (\_ -> do SDL.P vect <- SDL.getAbsoluteMouseLocation mousePosFire $ fmap fromIntegral vect ) return mouseClickAH ) mouseRelease :: Event Bool <- fromAddHandler =<< (liftIO $ do void $ register mouseReleaseAH (\_ -> do SDL.P vect <- SDL.getAbsoluteMouseLocation mousePosFire $ fmap fromIntegral vect ) return mouseReleaseAH ) listener :: Event [SDL.Event] <- fromAddHandler =<< (liftIO $ do void $ register listenerAH (registerListenerEvent mousePosFire mouseMotionFire mouseClickFire mouseReleaseFire ) return listenerAH ) delta :: Event Float <- fromAddHandler =<< (liftIO $ do void $ register deltaAH (\_ -> return ()) return deltaAH ) let mouseClickPos :: Event (V2 Float) = whenE mouseClickBehaviour mousePos ballPosBehaviour <- stepper (V2 400 300) ballPos ballVelBehaviour <- stepper (V2 0 0) ballVel ballAccBehaviour <- stepper (V2 0 0) ballAcc mousePosBehaviour <- stepper (V2 0 0) mousePos mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion mouseClickBehaviour <- stepper False mouseClick mouseReleaseBehaviour <- stepper True mouseRelease mouseClickPosBehaviour <- stepper (V2 0 0) mouseClickPos ball :: V2 Float <- valueB ballPosBehaviour let triangleReaction = fmap (\x -> do let input = (\(V2 xx _) -> xx / 100 :: Float) x past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar) void $ atomically $ swapTMVar rotvar (past + input) -- print input ) mouseMotionBehaviour ballReaction = fmap (\x -> do let input = (fmap (\foo -> foo - 1) x) / V2 400 300 void $ atomically $ swapTMVar transvar input -- print input ) ballPosBehaviour ballAccReaction = fmap (\acc -> ballAccFire acc ) (liftA2 (\mPos bPos -> mPos - bPos) mousePosBehaviour ballPosBehaviour ) ballVelReaction = fmap (\vel -> ballVelFire vel ) $ apply (pure (\acc -> (\dtime -> fmap (/ dtime) acc)) <*> ballAccBehaviour) delta ballMoveReaction = fmap (\x -> do ballPosFire x print x ) $ apply (liftA2 (\bPos bVel -> (\dtime -> bPos + (fmap (dtime *) bVel)) ) ballPosBehaviour ballVelBehaviour ) delta reactimate' =<< changes triangleReaction reactimate' =<< changes ballReaction reactimate ballVelReaction reactimate $ whenE mouseClickBehaviour ballMoveReaction -- reactimate' =<< changes clickReaction -- reactimate ballReaction -- ecPrint <- changes printReaction -- reactimate' ecPrint -- reactimate moveReaction -- ecReaction <- changes clickReaction -- reactimate' $ whenE clickHoldBehaviour ecReaction registerListenerEvent :: (V2 Float -> IO ()) -> (V2 Float -> IO ()) -> (Bool -> IO ()) -> (Bool -> IO ()) -> ([SDL.Event] -> IO ()) registerListenerEvent mousePosFire mouseMotionFire mouseClickFire mouseReleaseFire = \evs -> do let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ _ _ _) -> True _ -> False ) evs filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ [SDL.ButtonLeft] _ _) -> True SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft _ _) -> True _ -> False ) evs filteredReleaseEvents = filter (\ev -> case SDL.eventPayload ev of SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ SDL.ButtonLeft _ _) -> True _ -> False ) evs if null filteredMoveEvents then do mouseMotionFire (V2 0 0) else do mouseMotionFire $ (\(SDL.Event _ (SDL.MouseMotionEvent dat)) -> fmap fromIntegral (SDL.mouseMotionEventRelMotion dat) ) (head $ filteredMoveEvents) mousePosFire $ (\(SDL.Event _ (SDL.MouseMotionEvent dat)) -> (\(SDL.P a) -> fmap fromIntegral a) (SDL.mouseMotionEventPos dat) ) (head $ filteredMoveEvents) if not (null filteredClickEvents) then do mouseClickFire True mouseReleaseFire False else if not (null filteredReleaseEvents) then do mouseClickFire False mouseReleaseFire True else return () registerMouseEvent :: MonadIO m => (V2 Float -> IO ()) -> AddHandler SDL.Event -> m (AddHandler SDL.Event) registerMouseEvent passFire mouseah = do void $ liftIO $ register mouseah $ digestEvent return mouseah where digestEvent (SDL.Event _ (SDL.MouseMotionEvent dat)) = passFire (fmap fromIntegral $ (\(SDL.P a) -> a) $ SDL.mouseMotionEventPos dat) digestEvent (SDL.Event _ (SDL.MouseButtonEvent dat)) = passFire (fmap fromIntegral $ (\(SDL.P a) -> a) $ SDL.mouseButtonEventPos dat) digestEvent _ = return () registerPassEvent :: MonadIO m => AddHandler (V2 Float) -> m (AddHandler (V2 Float)) registerPassEvent passah = do void $ liftIO $ register passah $ \_ -> return () return passah registerClickHoldEvent :: MonadIO m => (V2 Float -> IO ()) -> AddHandler Bool -> m (AddHandler Bool) registerClickHoldEvent passfire clickholdah = do void $ liftIO $ register clickholdah $ \_ -> do SDL.P vect <- SDL.getAbsoluteMouseLocation passfire $ fmap fromIntegral vect return clickholdah plainChanges :: Behavior a -> MomentIO (Event a) plainChanges b = do (e, handle) <- newEvent eb <- changes b reactimate' $ (fmap handle) <$> eb return e