frpball/src/Main.hs
2019-09-29 20:02:43 +02:00

319 lines
10 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@(_, fire) <- liftIO $ newAddHandler
uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
transUniVar <- liftIO $ newTMVarIO (V2 1 1) ::
ContextT FRPBallCtx os IO (TMVar (V2 Float))
network <- liftIO $ compile (networkDescription listen 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
fire evs
networkDescription
:: (AddHandler [SDL.Event], b)
-> TMVar Float
-> TMVar (V2 Float)
-> MomentIO ()
networkDescription (listenerah, _) rotvar transvar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler
(passah, passfire) <- liftIO $ newAddHandler
(clickholdah, clickholdfire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent
listenerah
mousefire
clickholdfire
_ <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent passfire mouseah
epass <- fromAddHandler =<< registerPassEvent passah
eClickHold <- fromAddHandler =<< registerClickHoldEvent passfire clickholdah
clickHoldBehaviour <- RBC.stepper True eClickHold
mouseMoveBehaviour <- RBC.stepper (V2 1 1) epass
let moveReaction = fmap (\x -> do
let input = (\(V2 xx _) ->
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
(\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload x
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
void $ atomically $ swapTMVar rotvar (past + input)
print input)
emouse
clickReaction = fmap (\x -> do
let input = (fmap (\foo -> foo - 1) x) / V2 400 300
void $ atomically $ swapTMVar transvar input
-- print input)
)
mouseMoveBehaviour
printReaction = fmap print blistener
ecPrint <- changes printReaction
reactimate' ecPrint
reactimate moveReaction
ecReaction <- changes clickReaction
reactimate' $ whenE clickHoldBehaviour ecReaction
registerListenerEvent
:: (MonadIO m)
=> AddHandler ([SDL.Event])
->(SDL.Event -> IO ())
-> (Bool -> IO ())
-> m (AddHandler [SDL.Event])
registerListenerEvent listenerah mousefire clickholdfire = do
void $ liftIO $
register listenerah $ \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.ButtonLeft _ _) ->
True
_ -> False
) evs
if null filteredMoveEvents
then return ()
else mousefire (head $ filteredMoveEvents)
if null filteredClickEvents
then
return ()
-- clickholdfire False
else
clickholdfire
(any (\x -> SDL.Pressed == SDL.mouseButtonEventMotion
((\(SDL.MouseButtonEvent dat) -> dat) $
SDL.eventPayload x)) filteredClickEvents)
return listenerah
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 $ \x -> if x
then do
SDL.P vect <- SDL.getAbsoluteMouseLocation
passfire $ fmap fromIntegral vect
else
return ()
return clickholdah