frpball/src/Main.hs

526 lines
17 KiB
Haskell
Raw Permalink Normal View History

2019-08-04 09:25:06 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-}
2019-08-29 19:29:16 +00:00
{-# LANGUAGE AllowAmbiguousTypes #-}
2019-08-04 09:25:06 +00:00
module Main where
2019-09-28 22:58:32 +00:00
import qualified SDL hiding (V2(..))
2019-08-04 09:25:06 +00:00
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
2019-08-29 19:29:16 +00:00
import Control.Concurrent.STM
2019-08-04 09:25:06 +00:00
import Graphics.GPipe
import Control.Monad
2019-08-29 19:29:16 +00:00
import Control.Monad.Trans
2019-08-04 09:25:06 +00:00
import Reactive.Banana.Frameworks as RBF
2019-09-29 16:15:04 +00:00
import Reactive.Banana.Combinators as RBC
2019-08-04 09:25:06 +00:00
2019-09-28 07:18:15 +00:00
import Data.Maybe (fromMaybe)
2019-10-12 08:34:54 +00:00
import Data.List (zip4)
import System.Random (randomRIO)
2019-09-28 07:18:15 +00:00
2019-08-04 09:25:06 +00:00
-- 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
2019-08-25 12:22:02 +00:00
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
2019-08-04 09:25:06 +00:00
win <- newWindow (WindowFormatColor RGB8) ("frpball", SDL.defaultWindow
{ SDL.windowInitialSize = V2 800 600
, SDL.windowResizable = True
2019-08-25 12:22:02 +00:00
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
2019-08-04 09:25:06 +00:00
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
)
2019-08-25 12:22:02 +00:00
vertexBuffer :: Buffer os AttrInput <- newBuffer 3
2019-08-04 09:25:06 +00:00
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)
]
2019-08-29 19:29:16 +00:00
2019-10-12 08:34:54 +00:00
let orderList = [1 .. 100]
2019-09-29 00:59:21 +00:00
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)
2019-09-29 13:01:00 +00:00
, (V4 0 0 0 1, V3 1 0 0)
2019-09-29 00:59:21 +00:00
, (V4 (1/2) 1 0 1, V3 1 0 0)
, (V4 1 0 0 1, V3 1 0 0)
2019-09-29 13:01:00 +00:00
, (V4 0 0 0 1, V3 1 0 0)
2019-09-29 00:59:21 +00:00
, (V4 1 0 0 1, V3 1 0 0)
, (V4 (1/2) (-1) 0 1, V3 1 0 0)
2019-09-29 13:01:00 +00:00
, (V4 0 0 0 1, V3 1 0 0)
2019-09-29 00:59:21 +00:00
, (V4 (1/2) (-1) 0 1, V3 1 0 0)
, (V4 (-1/2) (-1) 0 1, V3 1 0 0)
2019-09-29 13:01:00 +00:00
, (V4 0 0 0 1, V3 1 0 0)
2019-09-29 00:59:21 +00:00
, (V4 (-1/2) (-1) 0 1, V3 1 0 0)
, (V4 (-1) 0 0 1, V3 1 0 0)
2019-09-29 13:01:00 +00:00
, (V4 0 0 0 1, V3 1 0 0)
2019-09-29 00:59:21 +00:00
, (V4 (-1) 0 0 1, V3 1 0 0)
, (V4 (-1/2) 1 0 1, V3 1 0 0)
2019-09-29 13:01:00 +00:00
, (V4 0 0 0 1, V3 1 0 0)
2019-09-29 00:59:21 +00:00
]
2019-08-29 19:29:16 +00:00
uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
2019-10-12 08:34:54 +00:00
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
2019-08-29 19:29:16 +00:00
2019-10-12 08:34:54 +00:00
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
2019-09-29 00:59:21 +00:00
2019-08-04 09:25:06 +00:00
shader <- compileShader $ do
2019-09-29 00:59:21 +00:00
primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
toPrimitiveStream id ::
Shader
os
(PrimitiveArray Triangles AttrInput)
(PrimitiveStream Triangles (VertexFormat AttrInput))
2019-09-29 13:01:00 +00:00
uniform <- getUniform (const (uniformBuffer, 0))
2019-09-28 22:58:32 +00:00
let primitiveStream2 = fmap
(\(position, color) -> (position - V4 1 1 0 0, color / 10))
primitiveStream
2019-08-29 19:29:16 +00:00
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)
2019-09-28 22:58:32 +00:00
first fun (position, color) = (fun position, color)
2019-09-29 00:59:21 +00:00
primitiveStream4 = fmap
(first (rotationMatrix uniform !*))
primitiveStream3
2019-08-04 09:25:06 +00:00
fragmentStream <- rasterize
(const
( FrontAndBack
, ViewPort (V2 0 0) (V2 800 600)
, DepthRange 0 1
)
)
2019-08-29 19:29:16 +00:00
primitiveStream4
2019-08-04 09:25:06 +00:00
drawWindowColor
(const
( win
, ContextColorOption NoBlending (V3 True True True)
)
)
fragmentStream
2019-08-25 12:22:02 +00:00
2019-08-04 09:25:06 +00:00
-- SDL.showWindow window
2019-10-10 04:13:51 +00:00
listen@(_, eventFire) <- liftIO $ newAddHandler
deltaTimer@(_, deltaFire) <- liftIO $ newAddHandler
2019-09-28 07:18:15 +00:00
uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
2019-10-12 08:34:54 +00:00
transUniVars :: [TMVar (V2 Float)] <- liftIO $ mapM
(\rposition -> newTMVarIO rposition)
positions
2019-10-10 04:13:51 +00:00
deltaVar :: TMVar Float <- liftIO (newTMVarIO =<< SDL.time)
network <- liftIO $ compile
2019-10-12 08:34:54 +00:00
(networkDescription listen deltaTimer uniVar transUniVars)
2019-08-25 12:22:02 +00:00
forever $ do
2019-09-28 07:18:15 +00:00
mrot <- liftIO $ atomically $ tryReadTMVar uniVar
2019-09-29 00:59:21 +00:00
writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
2019-10-12 08:34:54 +00:00
mapM_
(\(transUniVar, positionUniformBuffer) -> do
mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar
writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans]
)
(zip transUniVars positionUniformBuffers)
2019-08-29 19:29:16 +00:00
liftIO $ actuate network
2019-08-25 12:22:02 +00:00
render $ do
clearWindowColor win (V3 0 0 0)
vertexArray <- newVertexArray vertexBuffer
2019-09-29 00:59:21 +00:00
hexVertexArray <- newVertexArray hexBuffer
2019-08-25 12:22:02 +00:00
let primitiveArray = toPrimitiveArray TriangleList vertexArray
2019-09-29 00:59:21 +00:00
let hexPrimitiveArray = toPrimitiveArray TriangleList hexVertexArray
2019-08-25 12:22:02 +00:00
shader primitiveArray
2019-10-12 08:34:54 +00:00
mapM_
(\hexShader ->
hexShader hexPrimitiveArray
)
hexShaders
2019-08-25 12:22:02 +00:00
swapWindowBuffers win
liftIO $ do
2019-08-04 09:25:06 +00:00
evs <- SDL.pollEvents
2019-10-10 04:13:51 +00:00
currentTime :: Float <- SDL.time
oldTime <- fromMaybe (currentTime - 0.1) <$>
(atomically $ tryReadTMVar deltaVar)
eventFire evs
2019-10-10 09:06:58 +00:00
deltaFire (5 * (currentTime - oldTime))
2019-10-10 04:13:51 +00:00
atomically $ swapTMVar deltaVar currentTime
2019-08-04 09:25:06 +00:00
2019-09-28 22:58:32 +00:00
networkDescription
2019-10-10 04:13:51 +00:00
:: (AddHandler [SDL.Event], ([SDL.Event] -> IO ()))
-> (AddHandler Float, (Float -> IO ()))
2019-09-28 22:58:32 +00:00
-> TMVar Float
2019-10-12 08:34:54 +00:00
-> [TMVar (V2 Float)]
2019-09-28 22:58:32 +00:00
-> MomentIO ()
2019-10-12 08:34:54 +00:00
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
2019-10-10 04:13:51 +00:00
(mousePosAH, mousePosFire) <- liftIO $ newAddHandler
(mouseMotionAH, mouseMotionFire) <- liftIO $ newAddHandler
(mouseClickAH, mouseClickFire) <- liftIO $ newAddHandler
(mouseReleaseAH, mouseReleaseFire) <- liftIO $ newAddHandler
(mouseClickPosAH, mouseClickPosFire) <- liftIO $ newAddHandler
2019-10-12 08:34:54 +00:00
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
2019-10-10 04:13:51 +00:00
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
)
2019-10-10 09:06:58 +00:00
let mouseClickPos :: Event (Maybe (V2 Float)) = apply
(pure (\click -> (\pos -> if click then Just pos else Nothing)
) <*>
mouseClickBehaviour
)
mousePos
2019-10-10 04:13:51 +00:00
2019-10-12 08:34:54 +00:00
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
2019-10-10 09:06:58 +00:00
mousePosBehaviour <- stepper (V2 400 300) mousePos
2019-10-10 04:13:51 +00:00
mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion
mouseClickBehaviour <- stepper False mouseClick
mouseReleaseBehaviour <- stepper True mouseRelease
2019-10-10 09:06:58 +00:00
mouseClickPosBehaviour <- stepper Nothing mouseClickPos
2019-10-10 04:13:51 +00:00
let triangleReaction = fmap (\x -> do
let input = (\(V2 xx _) -> xx / 100 :: Float) x
2019-09-29 13:01:00 +00:00
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
void $ atomically $ swapTMVar rotvar (past + input)
2019-10-10 04:13:51 +00:00
-- print input
)
mouseMotionBehaviour
2019-10-12 08:34:54 +00:00
ballReactions = map
(\(ballPosBehaviour, uni) ->
fmap
(\x -> do
let input = (fmap (\foo -> foo - 1) x) / V2 400 300
void $ atomically $ swapTMVar uni input
-- print input
)
2019-10-10 09:06:58 +00:00
ballPosBehaviour
2019-10-12 08:34:54 +00:00
)
(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
2019-10-10 09:06:58 +00:00
)
2019-10-12 08:34:54 +00:00
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
2019-10-10 04:13:51 +00:00
)
2019-10-12 08:34:54 +00:00
, 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)
2019-10-10 04:13:51 +00:00
reactimate' =<< changes triangleReaction
2019-10-12 08:34:54 +00:00
mapM_ (\ballReaction -> reactimate' =<< changes ballReaction) ballReactions
mapM_ (\ballVelReaction -> reactimate ballVelReaction) ballVelReactions
mapM_ (\ballAccReaction -> reactimate ballAccReaction) ballAccReactions
2019-10-10 09:06:58 +00:00
-- reactimate $ whenE mouseClickBehaviour ballMoveReaction
2019-10-12 08:34:54 +00:00
mapM_ (\ballMoveReaction -> reactimate ballMoveReaction) ballMoveReactions
2019-10-10 04:13:51 +00:00
-- reactimate' =<< changes clickReaction
-- reactimate ballReaction
-- ecPrint <- changes printReaction
-- reactimate' ecPrint
-- reactimate moveReaction
-- ecReaction <- changes clickReaction
-- reactimate' $ whenE clickHoldBehaviour ecReaction
2019-08-04 09:25:06 +00:00
registerListenerEvent
2019-10-10 04:13:51 +00:00
:: (V2 Float -> IO ())
-> (V2 Float -> IO ())
-> (Bool -> IO ())
2019-09-29 16:15:04 +00:00
-> (Bool -> IO ())
2019-10-10 04:13:51 +00:00
-> ([SDL.Event] -> IO ())
registerListenerEvent mousePosFire mouseMotionFire mouseClickFire mouseReleaseFire =
\evs -> do
2019-09-29 13:01:00 +00:00
let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of
2019-09-29 18:02:43 +00:00
SDL.MouseMotionEvent
(SDL.MouseMotionEventData _ _ _ _ _) ->
True
2019-09-29 13:01:00 +00:00
_ -> False
) evs
filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of
2019-10-10 04:13:51 +00:00
SDL.MouseMotionEvent
(SDL.MouseMotionEventData _ _ [SDL.ButtonLeft] _ _) ->
True
2019-09-29 18:02:43 +00:00
SDL.MouseButtonEvent
2019-10-10 04:13:51 +00:00
(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 _ _) ->
2019-09-29 13:01:00 +00:00
True
_ -> False
2019-09-28 07:18:15 +00:00
) evs
2019-09-29 13:01:00 +00:00
if null filteredMoveEvents
2019-10-10 04:13:51 +00:00
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 ()
2019-08-04 09:25:06 +00:00
2019-09-28 22:58:32 +00:00
registerMouseEvent
:: MonadIO m
2019-09-29 16:15:04 +00:00
=> (V2 Float -> IO ())
-> AddHandler SDL.Event
-> m (AddHandler SDL.Event)
registerMouseEvent passFire mouseah = do
2019-09-29 18:02:43 +00:00
void $ liftIO $ register mouseah $ digestEvent
return mouseah
where
digestEvent (SDL.Event _ (SDL.MouseMotionEvent dat)) =
2019-09-29 16:15:04 +00:00
passFire (fmap fromIntegral $ (\(SDL.P a) -> a) $
SDL.mouseMotionEventPos dat)
2019-09-29 18:02:43 +00:00
digestEvent (SDL.Event _ (SDL.MouseButtonEvent dat)) =
passFire (fmap fromIntegral $ (\(SDL.P a) -> a) $
SDL.mouseButtonEventPos dat)
digestEvent _ = return ()
2019-09-29 13:01:00 +00:00
2019-09-29 16:15:04 +00:00
registerPassEvent
2019-09-29 13:01:00 +00:00
:: MonadIO m
2019-09-29 16:15:04 +00:00
=> AddHandler (V2 Float)
-> m (AddHandler (V2 Float))
registerPassEvent passah = do
void $ liftIO $ register passah $ \_ -> return ()
return passah
registerClickHoldEvent
:: MonadIO m
2019-09-29 18:02:43 +00:00
=> (V2 Float -> IO ())
-> AddHandler Bool
2019-09-29 16:15:04 +00:00
-> m (AddHandler Bool)
2019-09-29 18:02:43 +00:00
registerClickHoldEvent passfire clickholdah = do
2019-09-30 01:38:20 +00:00
void $ liftIO $ register clickholdah $ \_ -> do
SDL.P vect <- SDL.getAbsoluteMouseLocation
passfire $ fmap fromIntegral vect
2019-09-29 16:15:04 +00:00
return clickholdah
2019-10-10 04:13:51 +00:00
plainChanges :: Behavior a -> MomentIO (Event a)
plainChanges b = do
(e, handle) <- newEvent
eb <- changes b
reactimate' $ (fmap handle) <$> eb
return e