526 lines
17 KiB
Haskell
526 lines
17 KiB
Haskell
{-# 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
|