frpball/src/Main.hs
2019-09-29 00:58:32 +02:00

164 lines
5.5 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)
]
uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
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)
let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO ()
network <- liftIO $ compile (networkDescription listen uniVar)
forever $ do
mrot <- liftIO $ atomically $ tryReadTMVar uniVar
writeUniform [fromMaybe 0 mrot]
liftIO $ actuate network
render $ do
clearWindowColor win (V3 0 0 0)
vertexArray <- newVertexArray vertexBuffer
let primitiveArray = toPrimitiveArray TriangleList vertexArray
shader primitiveArray
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 univar 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
-- let eventChangedReaction :: RB.Event (Future (IO ()))
-- eventChangedReaction = fmap
-- (\(x :: Future [SDL.Event]) ->
-- fmap (\y -> if null y then return () else print y) x)
-- eventChanged
-- liftIO $ mousefire "Hello!"
reactimate reaction
-- reactimate' eventChanged
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
=> TMVar Float
-> AddHandler [SDL.Event]
-> m (AddHandler [SDL.Event])
registerMouseEvent univar mouseah = do
_ <- liftIO $ register mouseah $ \_ -> return ()
return mouseah