frpball/src/Main.hs
2019-10-10 11:06:58 +02:00

455 lines
14 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)
-- 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 (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 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 (Maybe (V2 Float)) = apply
(pure (\click -> (\pos -> if click then Just pos else Nothing)
) <*>
mouseClickBehaviour
)
mousePos
ballPosBehaviour <- stepper (V2 400 300) ballPos
ballVelBehaviour <- stepper (V2 0 0) ballVel
ballAccBehaviour <- stepper (V2 0 0) ballAcc
mousePosBehaviour <- stepper (V2 400 300) mousePos
mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion
mouseClickBehaviour <- stepper False mouseClick
mouseReleaseBehaviour <- stepper True mouseRelease
mouseClickPosBehaviour <- stepper Nothing 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 -> 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
ballVelReaction = fmap (\vel ->
ballVelFire vel
) $ apply
(liftA2
(\acc vel -> (\dtime -> fmap (* dtime) acc + vel))
ballAccBehaviour
ballVelBehaviour
)
delta
ballMoveReaction = 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
reactimate' =<< changes triangleReaction
reactimate' =<< changes ballReaction
reactimate ballVelReaction
reactimate ballAccReaction
-- reactimate $ whenE mouseClickBehaviour ballMoveReaction
reactimate 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