121 lines
3.2 KiB
Haskell
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
|