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-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
|
|
|
|
(V4 1 0 0 ax)
|
|
|
|
(V4 0 1 0 (-ay))
|
|
|
|
(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 13:01:00 +00:00
|
|
|
transUniVar <- liftIO $ newTMVarIO (V2 0 0) ::
|
|
|
|
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
|
|
|
|
writeBuffer positionUniformBuffer 0 [fromMaybe (V2 0 0) 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
|
|
|
|
(clickah, clickfire) <- liftIO $ newAddHandler
|
|
|
|
blistener <- fromChanges [] =<< registerListenerEvent
|
|
|
|
listenerah
|
|
|
|
mousefire
|
|
|
|
clickfire
|
2019-09-28 22:58:32 +00:00
|
|
|
_ <- changes blistener
|
2019-09-29 00:59:21 +00:00
|
|
|
emouse <- fromAddHandler =<< registerMouseEvent mouseah
|
2019-09-29 13:01:00 +00:00
|
|
|
eclick <- fromAddHandler =<< registerClickEvent clickah
|
|
|
|
let moveReaction = fmap (\x -> do
|
2019-09-28 22:58:32 +00:00
|
|
|
let input = (\(V2 xx _) ->
|
|
|
|
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
|
|
|
|
(\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head 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
|
|
|
|
let input =
|
|
|
|
(\vect -> fmap (\foo -> foo - 1) (vect / V2 400 300)) $
|
|
|
|
(\(SDL.MouseButtonEvent (SDL.MouseButtonEventData _ _ _ _ _ (SDL.P ps))) ->
|
|
|
|
fmap fromIntegral ps :: V2 Float) $
|
|
|
|
SDL.eventPayload $
|
|
|
|
head x
|
|
|
|
void $ atomically $ swapTMVar transvar input
|
|
|
|
print input)
|
|
|
|
eclick
|
|
|
|
reactimate moveReaction
|
|
|
|
reactimate clickReaction
|
2019-08-04 09:25:06 +00:00
|
|
|
|
|
|
|
registerListenerEvent
|
2019-08-29 19:29:16 +00:00
|
|
|
:: (MonadIO m)
|
|
|
|
=> AddHandler ([SDL.Event])
|
|
|
|
-> ([SDL.Event] -> IO ())
|
2019-09-29 13:01:00 +00:00
|
|
|
-> ([SDL.Event] -> IO ())
|
2019-08-29 19:29:16 +00:00
|
|
|
-> m (AddHandler [SDL.Event])
|
2019-09-29 13:01:00 +00:00
|
|
|
registerListenerEvent listenerah mousefire clickfire = do
|
|
|
|
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
|
|
|
|
SDL.MouseButtonEvent
|
|
|
|
(SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft 1 _) ->
|
|
|
|
True
|
|
|
|
_ -> False
|
2019-09-28 07:18:15 +00:00
|
|
|
) evs
|
2019-09-29 13:01:00 +00:00
|
|
|
if null filteredMoveEvents
|
|
|
|
then return ()
|
|
|
|
else mousefire filteredMoveEvents
|
|
|
|
if null filteredClickEvents
|
|
|
|
then return ()
|
|
|
|
else clickfire filteredClickEvents
|
2019-08-04 09:25:06 +00:00
|
|
|
return listenerah
|
|
|
|
|
2019-09-28 22:58:32 +00:00
|
|
|
registerMouseEvent
|
|
|
|
:: MonadIO m
|
2019-09-29 00:59:21 +00:00
|
|
|
=> AddHandler [SDL.Event]
|
2019-09-28 22:58:32 +00:00
|
|
|
-> m (AddHandler [SDL.Event])
|
2019-09-29 00:59:21 +00:00
|
|
|
registerMouseEvent mouseah = do
|
2019-09-29 13:01:00 +00:00
|
|
|
void $ liftIO $ register mouseah $ \_ -> return ()
|
2019-08-04 09:25:06 +00:00
|
|
|
return mouseah
|
2019-09-29 13:01:00 +00:00
|
|
|
|
|
|
|
registerClickEvent
|
|
|
|
:: MonadIO m
|
|
|
|
=> AddHandler [SDL.Event]
|
|
|
|
-> m (AddHandler [SDL.Event])
|
|
|
|
registerClickEvent clickah = do
|
|
|
|
void $ liftIO $ register clickah $ \_ -> return ()
|
|
|
|
return clickah
|