frpball/src/Main.hs

292 lines
9.2 KiB
Haskell
Raw 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-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-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-09-29 13:01:00 +00:00
positionUniformBuffer :: Buffer os (Uniform (B2 Float)) <- newBuffer 1
2019-08-29 19:29:16 +00:00
2019-09-29 00:59:21 +00:00
hexShader <- compileShader $ do
hexPrimitiveStream :: 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
positionUniform <- getUniform (const (positionUniformBuffer, 0))
2019-09-29 00:59:21 +00:00
let scaleFact = 0.05
2019-09-29 13:01:00 +00:00
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
2019-09-29 16:15:04 +00:00
(V4 1 0 0 (ax - 1))
(V4 0 1 0 ((-ay) + 1))
2019-09-29 13:01:00 +00:00
(V4 0 0 1 1)
(V4 0 0 0 1)
2019-09-29 00:59:21 +00:00
hexFragmentStream <- rasterize
(const
( FrontAndBack
, ViewPort (V2 0 0) (V2 800 600)
, DepthRange 0 1
)
)
2019-09-29 13:01:00 +00:00
(fmap (\(position, color) ->
( (transMatrix positionUniform !*!
scaleMatrix scaleFact) !*
position
, color
))
2019-09-29 00:59:21 +00:00
hexPrimitiveStream)
drawWindowColor
(const
( win
, ContextColorOption NoBlending (V3 True True True)
)
)
hexFragmentStream
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-08-29 19:29:16 +00:00
listen@(_, fire) <- liftIO $ newAddHandler
2019-09-28 07:18:15 +00:00
uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
2019-09-29 16:15:04 +00:00
transUniVar <- liftIO $ newTMVarIO (V2 1 1) ::
2019-09-29 13:01:00 +00:00
ContextT FRPBallCtx os IO (TMVar (V2 Float))
network <- liftIO $ compile (networkDescription listen uniVar transUniVar)
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-09-29 13:01:00 +00:00
mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar
2019-09-29 16:15:04 +00:00
writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans]
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-09-29 00:59:21 +00:00
hexShader hexPrimitiveArray
2019-08-25 12:22:02 +00:00
swapWindowBuffers win
liftIO $ do
2019-08-04 09:25:06 +00:00
evs <- SDL.pollEvents
fire evs
2019-09-28 22:58:32 +00:00
networkDescription
:: (AddHandler [SDL.Event], b)
-> TMVar Float
2019-09-29 13:01:00 +00:00
-> TMVar (V2 Float)
2019-09-28 22:58:32 +00:00
-> MomentIO ()
2019-09-29 13:01:00 +00:00
networkDescription (listenerah, _) rotvar transvar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler
2019-09-29 16:15:04 +00:00
(passah, passfire) <- liftIO $ newAddHandler
(clickholdah, clickholdfire) <- liftIO $ newAddHandler
2019-09-29 13:01:00 +00:00
blistener <- fromChanges [] =<< registerListenerEvent
listenerah
mousefire
2019-09-29 16:15:04 +00:00
clickholdfire
2019-09-28 22:58:32 +00:00
_ <- changes blistener
2019-09-29 16:15:04 +00:00
emouse <- fromAddHandler =<< registerMouseEvent passfire mouseah
epass <- fromAddHandler =<< registerPassEvent passah
eClickHold <- fromAddHandler =<< registerClickHoldEvent clickholdah
clickHoldBehaviour <- RBC.stepper False eClickHold
mouseMoveBehaviour <- RBC.stepper (V2 1 1) epass
2019-09-29 13:01:00 +00:00
let moveReaction = fmap (\x -> do
2019-09-28 22:58:32 +00:00
let input = (\(V2 xx _) ->
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
2019-09-29 16:15:04 +00:00
(\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload x
2019-09-29 13:01:00 +00:00
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
void $ atomically $ swapTMVar rotvar (past + input)
print input)
emouse
clickReaction = fmap (\x -> do
2019-09-29 16:15:04 +00:00
let input = (fmap (\foo -> foo - 1) x) / V2 400 300
2019-09-29 13:01:00 +00:00
void $ atomically $ swapTMVar transvar input
print input)
2019-09-29 16:15:04 +00:00
mouseMoveBehaviour
2019-09-29 13:01:00 +00:00
reactimate moveReaction
2019-09-29 16:15:04 +00:00
reactimate' =<< (whenE clickHoldBehaviour <$> changes clickReaction)
2019-08-04 09:25:06 +00:00
registerListenerEvent
2019-08-29 19:29:16 +00:00
:: (MonadIO m)
=> AddHandler ([SDL.Event])
2019-09-29 16:15:04 +00:00
->(SDL.Event -> IO ())
-> (Bool -> IO ())
2019-08-29 19:29:16 +00:00
-> m (AddHandler [SDL.Event])
2019-09-29 16:15:04 +00:00
registerListenerEvent listenerah mousefire clickholdfire = do
2019-09-29 13:01:00 +00:00
void $ liftIO $
2019-08-04 09:25:06 +00:00
register listenerah $ \evs -> do
2019-09-29 13:01:00 +00:00
let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of
2019-09-28 07:18:15 +00:00
SDL.MouseMotionEvent _ -> True
2019-09-29 13:01:00 +00:00
_ -> False
) evs
filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of
2019-09-29 16:15:04 +00:00
SDL.MouseMotionEvent
(SDL.MouseMotionEventData _ _ [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
then return ()
2019-09-29 16:15:04 +00:00
else mousefire (head $ reverse $ filteredMoveEvents)
2019-09-29 13:01:00 +00:00
if null filteredClickEvents
2019-09-29 16:15:04 +00:00
then clickholdfire False
else clickholdfire True
2019-08-04 09:25:06 +00:00
return listenerah
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
void $ liftIO $ register mouseah $
\(SDL.Event _ (SDL.MouseMotionEvent dat)) ->
passFire (fmap fromIntegral $ (\(SDL.P a) -> a) $
SDL.mouseMotionEventPos dat)
2019-08-04 09:25:06 +00:00
return mouseah
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
=> AddHandler Bool
-> m (AddHandler Bool)
registerClickHoldEvent clickholdah = do
void $ liftIO $ register clickholdah $ \_ -> return ()
return clickholdah