frpball/src/Main.hs
2019-09-29 02:59:21 +02:00

223 lines
6.9 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 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 0, 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 0, 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 0, 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 0, 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 0, 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 0, V3 1 0 0)
]
uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
hexShader <- compileShader $ do
hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
toPrimitiveStream id ::
Shader
os
(PrimitiveArray Triangles AttrInput)
(PrimitiveStream Triangles (VertexFormat AttrInput))
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)
hexFragmentStream <- rasterize
(const
( FrontAndBack
, ViewPort (V2 0 0) (V2 800 600)
, DepthRange 0 1
)
)
(fmap (\(position, color) -> (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)
network <- liftIO $ compile (networkDescription listen uniVar)
forever $ do
mrot <- liftIO $ atomically $ tryReadTMVar uniVar
writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
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
-> MomentIO ()
networkDescription (listenerah, _) univar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
_ <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent mouseah
let reaction = fmap (\x -> do
let input = (\(V2 xx _) ->
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
(\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar univar)
void $ atomically $ swapTMVar univar (past + input)
print input) emouse
reactimate reaction
registerListenerEvent
:: (MonadIO m)
=> AddHandler ([SDL.Event])
-> ([SDL.Event] -> IO ())
-> m (AddHandler [SDL.Event])
registerListenerEvent listenerah mousefire = do
_ <- liftIO $ do
register listenerah $ \evs -> do
let fevs = filter (\ev -> case SDL.eventPayload ev of
SDL.MouseMotionEvent _ -> True
_ -> False
) evs
if null fevs then return () else mousefire fevs
return listenerah
registerMouseEvent
:: MonadIO m
=> AddHandler [SDL.Event]
-> m (AddHandler [SDL.Event])
registerMouseEvent mouseah = do
_ <- liftIO $ register mouseah $ \_ -> return ()
return mouseah