166 lines
5.6 KiB
Haskell
166 lines
5.6 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE RecursiveDo #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
|
|
module Main where
|
|
|
|
import qualified SDL
|
|
import qualified SDL.Raw.Video as SDL (glSetAttribute)
|
|
import qualified SDL.Raw.Enum as SDL
|
|
import SDL (($=))
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Concurrent.STM.TMVar
|
|
|
|
import Graphics.GPipe
|
|
|
|
import Linear
|
|
|
|
import Control.Monad
|
|
import Control.Monad.Trans
|
|
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
|
|
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 (\(pos,clr) -> (pos - V4 1 1 0 0, clr / 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 (pos, col) = (fun pos, col)
|
|
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
|
|
uniformBufferVar <- liftIO $ newTMVarIO uniformBuffer :: ContextT FRPBallCtx os IO (TMVar (Buffer os (Uniform (B Float))))
|
|
let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO ()
|
|
writeUniform [0]
|
|
network <- liftIO $ compile (networkDescription listen writeUniform)
|
|
forever $ do
|
|
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
|
|
-- :: (ContextHandler ctx ~ ContextHandler FRPBallCtx)
|
|
-- => (AddHandler [SDL.Event], x)
|
|
-- -> TMVar (Buffer os (Uniform (B Float)))
|
|
-- -> MomentIO ()
|
|
networkDescription (listenerah, listenerfire) uniformWrite = mdo
|
|
(mouseah, mousefire) <- liftIO $ newAddHandler
|
|
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
|
|
eventChanged <- changes blistener
|
|
emouse <- fromAddHandler =<< registerMouseEvent uniformWrite 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)
|
|
=> AddHandler ([SDL.Event])
|
|
-> ([SDL.Event] -> IO ())
|
|
-> m (AddHandler [SDL.Event])
|
|
registerListenerEvent listenerah mousefire = do
|
|
_ <- liftIO $ do
|
|
register listenerah $ \evs -> do
|
|
if null evs then return () else mousefire
|
|
(filter (\ev -> case SDL.eventPayload ev of
|
|
SDL.MouseMotionEvent _ -> True
|
|
_ -> False
|
|
) evs
|
|
)
|
|
return listenerah
|
|
|
|
-- registerMouseEvent
|
|
-- :: (MonadIO m, ContextHandler ctx ~ ContextHandler FRPBallCtx)
|
|
-- => Buffer os (Uniform (B Float))
|
|
-- -> AddHandler [SDL.Event]
|
|
-- -> m (AddHandler [SDL.Event])
|
|
registerMouseEvent uniformWrite mouseah = do
|
|
_ <- liftIO $ register mouseah ((\evs -> do
|
|
let input = [(\(V2 x y) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head evs]
|
|
return $ (uniformWrite input)
|
|
return ()
|
|
) :: [SDL.Event] -> IO ()
|
|
)
|
|
return mouseah
|