start constructing a "ball"

This commit is contained in:
nek0 2019-09-29 02:59:21 +02:00
parent 6a16dcbcff
commit 84c5951625

View file

@ -63,10 +63,73 @@ main = do
, (V4 1 1 0 1, V3 0 0 1) , (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 0, 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 0, 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 0, 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 0, 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 0, 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 0, V3 1 0 0)
]
uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1 uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
hexShader <- compileShader $ do
hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
toPrimitiveStream id ::
Shader
os
(PrimitiveArray Triangles AttrInput)
(PrimitiveStream Triangles (VertexFormat AttrInput))
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)
hexFragmentStream <- rasterize
(const
( FrontAndBack
, ViewPort (V2 0 0) (V2 800 600)
, DepthRange 0 1
)
)
(fmap (\(position, color) -> (scaleMatrix scaleFact !* position, color))
hexPrimitiveStream)
drawWindowColor
(const
( win
, ContextColorOption NoBlending (V3 True True True)
)
)
hexFragmentStream
shader <- compileShader $ do shader <- compileShader $ do
primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput)) primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
toPrimitiveStream id ::
Shader
os
(PrimitiveArray Triangles AttrInput)
(PrimitiveStream Triangles (VertexFormat AttrInput))
uniform <- getUniform (const (uniformBuffer,0)) uniform <- getUniform (const (uniformBuffer,0))
let primitiveStream2 = fmap let primitiveStream2 = fmap
(\(position, color) -> (position - V4 1 1 0 0, color / 10)) (\(position, color) -> (position - V4 1 1 0 0, color / 10))
@ -77,7 +140,9 @@ main = do
(V4 0 0 1 0) (V4 0 0 1 0)
(V4 0 0 0 1) (V4 0 0 0 1)
first fun (position, color) = (fun position, color) first fun (position, color) = (fun position, color)
primitiveStream4 = fmap (first (rotationMatrix (uniform) !*)) primitiveStream3 primitiveStream4 = fmap
(first (rotationMatrix uniform !*))
primitiveStream3
fragmentStream <- rasterize fragmentStream <- rasterize
(const (const
( FrontAndBack ( FrontAndBack
@ -97,17 +162,19 @@ main = do
-- SDL.showWindow window -- SDL.showWindow window
listen@(_, fire) <- liftIO $ newAddHandler listen@(_, fire) <- liftIO $ newAddHandler
uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float) uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO ()
network <- liftIO $ compile (networkDescription listen uniVar) network <- liftIO $ compile (networkDescription listen uniVar)
forever $ do forever $ do
mrot <- liftIO $ atomically $ tryReadTMVar uniVar mrot <- liftIO $ atomically $ tryReadTMVar uniVar
writeUniform [fromMaybe 0 mrot] writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
liftIO $ actuate network liftIO $ actuate network
render $ do render $ do
clearWindowColor win (V3 0 0 0) clearWindowColor win (V3 0 0 0)
vertexArray <- newVertexArray vertexBuffer vertexArray <- newVertexArray vertexBuffer
hexVertexArray <- newVertexArray hexBuffer
let primitiveArray = toPrimitiveArray TriangleList vertexArray let primitiveArray = toPrimitiveArray TriangleList vertexArray
let hexPrimitiveArray = toPrimitiveArray TriangleList hexVertexArray
shader primitiveArray shader primitiveArray
hexShader hexPrimitiveArray
swapWindowBuffers win swapWindowBuffers win
liftIO $ do liftIO $ do
evs <- SDL.pollEvents evs <- SDL.pollEvents
@ -121,7 +188,7 @@ networkDescription (listenerah, _) univar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler (mouseah, mousefire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
_ <- changes blistener _ <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent univar mouseah emouse <- fromAddHandler =<< registerMouseEvent mouseah
let reaction = fmap (\x -> do let reaction = fmap (\x -> do
let input = (\(V2 xx _) -> let input = (\(V2 xx _) ->
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $ fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
@ -129,14 +196,7 @@ networkDescription (listenerah, _) univar = mdo
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar univar) past <- fromMaybe 0 <$> (atomically $ tryReadTMVar univar)
void $ atomically $ swapTMVar univar (past + input) void $ atomically $ swapTMVar univar (past + input)
print input) emouse print input) 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 reaction
-- reactimate' eventChanged
registerListenerEvent registerListenerEvent
:: (MonadIO m) :: (MonadIO m)
@ -155,9 +215,8 @@ registerListenerEvent listenerah mousefire = do
registerMouseEvent registerMouseEvent
:: MonadIO m :: MonadIO m
=> TMVar Float => AddHandler [SDL.Event]
-> AddHandler [SDL.Event]
-> m (AddHandler [SDL.Event]) -> m (AddHandler [SDL.Event])
registerMouseEvent univar mouseah = do registerMouseEvent mouseah = do
_ <- liftIO $ register mouseah $ \_ -> return () _ <- liftIO $ register mouseah $ \_ -> return ()
return mouseah return mouseah