frpball/src/Main.hs
2019-08-25 14:22:02 +02:00

134 lines
3.9 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 "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)
]
shader <- compileShader $ do
primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput))
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 $ actuate network
forever $ do
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)
-> 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