frpball/src/Main.hs

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