frpball/src/Main.hs

121 lines
3.2 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
import SDL (($=))
import Graphics.GPipe
import Linear
import Control.Monad
import Control.Concurrent
import Reactive.Banana.Frameworks as RBF
import Reactive.Banana as RB
-- 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
listen@(_, fire) <- newAddHandler
network <- compile (networkDescription listen)
runContextT FRPBallCtxConfig $ do
win <- newWindow (WindowFormatColor RGB8) ("frpball", SDL.defaultWindow
{ SDL.windowInitialSize = V2 800 600
, SDL.windowResizable = True
, SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
)
vertexBuffer :: Buffer os (B4 Float, B3 Float) <- 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)
]
shader <- compileShader $ do
primitiveStream <- toPrimitiveStream id
fragmentStream <- rasterize
(const
( FrontAndBack
, ViewPort (V2 0 0) (V2 800 600)
, DepthRange 0 1
)
)
primitiveStream
drawWindowColor
(const
( win
, ContextColorOption NoBlending (V3 True True True)
)
)
fragmentStream
-- SDL.showWindow window
liftIO $ do
actuate network
forever $ do
evs <- SDL.pollEvents
fire evs
threadDelay $ 23 * 10 ^ 6
networkDescription
:: (AddHandler [SDL.Event], b)
-> MomentIO ()
networkDescription (listenerah, listenerfire) = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
eventChanged <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent mouseah
let reaction = fmap print 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, Foldable t)
=> AddHandler (t a)
-> (t a -> IO ())
-> m (AddHandler (t a))
registerListenerEvent listenerah mousefire = do
_ <- liftIO $ do
register listenerah $ \evs -> do
if null evs then return () else mousefire evs
return listenerah
registerMouseEvent
:: (MonadIO m, Show a)
=> AddHandler a
-> m (AddHandler a)
registerMouseEvent mouseah = do
_ <- liftIO $
register mouseah print
return mouseah