{-# 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