{-# 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) import Data.List (zip4) import System.Random (randomRIO) -- 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) ] let orderList = [1 .. 100] 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 positionUniformBuffers :: [Buffer os (Uniform (B2 Float))] <- mapM (\_ -> newBuffer 1) orderList positions <- liftIO $ mapM (\_ -> do x <- randomRIO (0, 800) y <- randomRIO (0, 600) return $ V2 x y ) orderList hexShaders <- mapM (\positionUniformBuffer -> 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 ) positionUniformBuffers 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) transUniVars :: [TMVar (V2 Float)] <- liftIO $ mapM (\rposition -> newTMVarIO rposition) positions deltaVar :: TMVar Float <- liftIO (newTMVarIO =<< SDL.time) network <- liftIO $ compile (networkDescription listen deltaTimer uniVar transUniVars) forever $ do mrot <- liftIO $ atomically $ tryReadTMVar uniVar writeBuffer uniformBuffer 0 [fromMaybe 0 mrot] mapM_ (\(transUniVar, positionUniformBuffer) -> do mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans] ) (zip transUniVars positionUniformBuffers) 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 mapM_ (\hexShader -> hexShader hexPrimitiveArray ) hexShaders swapWindowBuffers win liftIO $ do evs <- SDL.pollEvents currentTime :: Float <- SDL.time oldTime <- fromMaybe (currentTime - 0.1) <$> (atomically $ tryReadTMVar deltaVar) eventFire evs deltaFire (5 * (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 transvars = mdo posAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars] velAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars] accAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars] -- (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 ballPoss :: [Event (V2 Float)] <- mapM (\(ballPosAH, _) -> fromAddHandler =<< (liftIO $ do void $ register ballPosAH (\_ -> return()) return ballPosAH ) ) posAHFires ballVels :: [Event (V2 Float)] <- mapM (\(ballVelAH, _) -> fromAddHandler =<< (liftIO $ do void $ register ballVelAH (\_ -> return()) return ballVelAH ) ) velAHFires ballAccs :: [Event (V2 Float)] <- mapM (\(ballAccAH, _) -> fromAddHandler =<< (liftIO $ do void $ register ballAccAH (\_ -> return()) return ballAccAH ) ) accAHFires 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 (Maybe (V2 Float)) = apply (pure (\click -> (\pos -> if click then Just pos else Nothing) ) <*> mouseClickBehaviour ) mousePos ballPosBehaviours <- mapM (\(ballPos, uni) -> do position <- liftIO $ fromMaybe (V2 400 300) <$> (atomically $ tryReadTMVar uni) stepper position ballPos ) (zip ballPoss transvars) ballVelBehaviours <- mapM (\ballVel -> stepper (V2 0 0) ballVel) ballVels ballAccBehaviours <- mapM (\ballAcc -> stepper (V2 0 0) ballAcc) ballAccs mousePosBehaviour <- stepper (V2 400 300) mousePos mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion mouseClickBehaviour <- stepper False mouseClick mouseReleaseBehaviour <- stepper True mouseRelease mouseClickPosBehaviour <- stepper Nothing mouseClickPos 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 ballReactions = map (\(ballPosBehaviour, uni) -> fmap (\x -> do let input = (fmap (\foo -> foo - 1) x) / V2 400 300 void $ atomically $ swapTMVar uni input -- print input ) ballPosBehaviour ) (zip ballPosBehaviours transvars) ballAccReactions = map (\((_, ballAccFire), ballPosBehaviour) -> fmap (\acc -> do ballAccFire acc -- print acc ) $ apply (liftA2 (\mmPos bPos -> (\delta -> case mmPos of Just mPos -> fmap (* 0.99) (mPos - bPos) Nothing -> V2 0 0 )) mouseClickPosBehaviour ballPosBehaviour ) delta ) (zip accAHFires ballPosBehaviours) ballVelReactions = map (\((_, ballVelFire), ballAccBehaviour, ballVelBehaviour) -> fmap (\vel -> ballVelFire vel ) $ apply (liftA2 (\acc vel -> (\dtime -> fmap (* dtime) acc + vel)) ballAccBehaviour ballVelBehaviour ) delta ) (zip3 velAHFires ballAccBehaviours ballVelBehaviours) ballMoveReactions = map (\( ( _ , ballPosFire ) , ballPosBehaviour , ballVelBehaviour , ballAccBehaviour) -> fmap (\x -> do ballPosFire x -- print x ) (apply (liftA3 (\bPos bVel bAcc -> (\dtime -> (fmap (* (dtime * 0.5)) bAcc) + (fmap (* dtime) bVel) + bPos ) ) ballPosBehaviour ballVelBehaviour ballAccBehaviour ) delta) ) (zip4 posAHFires ballPosBehaviours ballVelBehaviours ballAccBehaviours) reactimate' =<< changes triangleReaction mapM_ (\ballReaction -> reactimate' =<< changes ballReaction) ballReactions mapM_ (\ballVelReaction -> reactimate ballVelReaction) ballVelReactions mapM_ (\ballAccReaction -> reactimate ballAccReaction) ballAccReactions -- reactimate $ whenE mouseClickBehaviour ballMoveReaction mapM_ (\ballMoveReaction -> reactimate ballMoveReaction) ballMoveReactions -- 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