{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} module Main where import qualified SDL hiding (V2(..)) import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Enum as SDL import Control.Concurrent.STM import Graphics.GPipe import Control.Monad import Control.Monad.Trans import Reactive.Banana.Frameworks as RBF import Data.Maybe (fromMaybe) -- 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) ] hexBuffer :: Buffer os AttrInput <- newBuffer 18 writeBuffer hexBuffer 0 [ (V4 (-1/2) 1 0 1, V3 1 0 0) , (V4 (1/2) 1 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (1/2) 1 0 1, V3 1 0 0) , (V4 1 0 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 1 0 0 1, V3 1 0 0) , (V4 (1/2) (-1) 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (1/2) (-1) 0 1, V3 1 0 0) , (V4 (-1/2) (-1) 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (-1/2) (-1) 0 1, V3 1 0 0) , (V4 (-1) 0 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) , (V4 (-1) 0 0 1, V3 1 0 0) , (V4 (-1/2) 1 0 1, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0) ] uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1 positionUniformBuffer :: Buffer os (Uniform (B2 Float)) <- newBuffer 1 hexShader <- compileShader $ do hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput)) positionUniform <- getUniform (const (positionUniformBuffer, 0)) let scaleFact = 0.05 scaleMatrix a = V4 (V4 a 0 0 0) (V4 0 a 0 0) (V4 0 0 1 0) (V4 0 0 0 1) transMatrix (V2 ax ay) = V4 (V4 1 0 0 ax) (V4 0 1 0 (-ay)) (V4 0 0 1 1) (V4 0 0 0 1) hexFragmentStream <- rasterize (const ( FrontAndBack , ViewPort (V2 0 0) (V2 800 600) , DepthRange 0 1 ) ) (fmap (\(position, color) -> ( (transMatrix positionUniform !*! scaleMatrix scaleFact) !* position , color )) hexPrimitiveStream) drawWindowColor (const ( win , ContextColorOption NoBlending (V3 True True True) ) ) hexFragmentStream 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 (\(position, color) -> (position - V4 1 1 0 0, color / 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 (position, color) = (fun position, color) 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 uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float) transUniVar <- liftIO $ newTMVarIO (V2 0 0) :: ContextT FRPBallCtx os IO (TMVar (V2 Float)) network <- liftIO $ compile (networkDescription listen uniVar transUniVar) forever $ do mrot <- liftIO $ atomically $ tryReadTMVar uniVar writeBuffer uniformBuffer 0 [fromMaybe 0 mrot] mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar writeBuffer positionUniformBuffer 0 [fromMaybe (V2 0 0) mtrans] liftIO $ actuate network render $ do clearWindowColor win (V3 0 0 0) vertexArray <- newVertexArray vertexBuffer hexVertexArray <- newVertexArray hexBuffer let primitiveArray = toPrimitiveArray TriangleList vertexArray let hexPrimitiveArray = toPrimitiveArray TriangleList hexVertexArray shader primitiveArray hexShader hexPrimitiveArray swapWindowBuffers win liftIO $ do evs <- SDL.pollEvents fire evs networkDescription :: (AddHandler [SDL.Event], b) -> TMVar Float -> TMVar (V2 Float) -> MomentIO () networkDescription (listenerah, _) rotvar transvar = mdo (mouseah, mousefire) <- liftIO $ newAddHandler (clickah, clickfire) <- liftIO $ newAddHandler blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire clickfire _ <- changes blistener emouse <- fromAddHandler =<< registerMouseEvent mouseah eclick <- fromAddHandler =<< registerClickEvent clickah let moveReaction = fmap (\x -> do let input = (\(V2 xx _) -> fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar) void $ atomically $ swapTMVar rotvar (past + input) print input) emouse clickReaction = fmap (\x -> do let input = (\vect -> fmap (\foo -> foo - 1) (vect / V2 400 300)) $ (\(SDL.MouseButtonEvent (SDL.MouseButtonEventData _ _ _ _ _ (SDL.P ps))) -> fmap fromIntegral ps :: V2 Float) $ SDL.eventPayload $ head x void $ atomically $ swapTMVar transvar input print input) eclick reactimate moveReaction reactimate clickReaction registerListenerEvent :: (MonadIO m) => AddHandler ([SDL.Event]) -> ([SDL.Event] -> IO ()) -> ([SDL.Event] -> IO ()) -> m (AddHandler [SDL.Event]) registerListenerEvent listenerah mousefire clickfire = do void $ liftIO $ register listenerah $ \evs -> do let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of SDL.MouseMotionEvent _ -> True _ -> False ) evs filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft 1 _) -> True _ -> False ) evs if null filteredMoveEvents then return () else mousefire filteredMoveEvents if null filteredClickEvents then return () else clickfire filteredClickEvents return listenerah registerMouseEvent :: MonadIO m => AddHandler [SDL.Event] -> m (AddHandler [SDL.Event]) registerMouseEvent mouseah = do void $ liftIO $ register mouseah $ \_ -> return () return mouseah registerClickEvent :: MonadIO m => AddHandler [SDL.Event] -> m (AddHandler [SDL.Event]) registerClickEvent clickah = do void $ liftIO $ register clickah $ \_ -> return () return clickah