start constructing a "ball"
This commit is contained in:
parent
6a16dcbcff
commit
84c5951625
1 changed files with 74 additions and 15 deletions
89
src/Main.hs
89
src/Main.hs
|
|
@ -63,10 +63,73 @@ main = do
|
|||
, (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
|
||||
|
||||
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
|
||||
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))
|
||||
let primitiveStream2 = fmap
|
||||
(\(position, color) -> (position - V4 1 1 0 0, color / 10))
|
||||
|
|
@ -77,7 +140,9 @@ main = do
|
|||
(V4 0 0 1 0)
|
||||
(V4 0 0 0 1)
|
||||
first fun (position, color) = (fun position, color)
|
||||
primitiveStream4 = fmap (first (rotationMatrix (uniform) !*)) primitiveStream3
|
||||
primitiveStream4 = fmap
|
||||
(first (rotationMatrix uniform !*))
|
||||
primitiveStream3
|
||||
fragmentStream <- rasterize
|
||||
(const
|
||||
( FrontAndBack
|
||||
|
|
@ -97,17 +162,19 @@ main = do
|
|||
-- SDL.showWindow window
|
||||
listen@(_, fire) <- liftIO $ newAddHandler
|
||||
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)
|
||||
forever $ do
|
||||
mrot <- liftIO $ atomically $ tryReadTMVar uniVar
|
||||
writeUniform [fromMaybe 0 mrot]
|
||||
writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
|
||||
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
|
||||
|
|
@ -121,7 +188,7 @@ networkDescription (listenerah, _) univar = mdo
|
|||
(mouseah, mousefire) <- liftIO $ newAddHandler
|
||||
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
|
||||
_ <- changes blistener
|
||||
emouse <- fromAddHandler =<< registerMouseEvent univar mouseah
|
||||
emouse <- fromAddHandler =<< registerMouseEvent mouseah
|
||||
let reaction = fmap (\x -> do
|
||||
let input = (\(V2 xx _) ->
|
||||
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
|
||||
|
|
@ -129,14 +196,7 @@ networkDescription (listenerah, _) univar = mdo
|
|||
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar univar)
|
||||
void $ atomically $ swapTMVar univar (past + input)
|
||||
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' eventChanged
|
||||
|
||||
registerListenerEvent
|
||||
:: (MonadIO m)
|
||||
|
|
@ -155,9 +215,8 @@ registerListenerEvent listenerah mousefire = do
|
|||
|
||||
registerMouseEvent
|
||||
:: MonadIO m
|
||||
=> TMVar Float
|
||||
-> AddHandler [SDL.Event]
|
||||
=> AddHandler [SDL.Event]
|
||||
-> m (AddHandler [SDL.Event])
|
||||
registerMouseEvent univar mouseah = do
|
||||
registerMouseEvent mouseah = do
|
||||
_ <- liftIO $ register mouseah $ \_ -> return ()
|
||||
return mouseah
|
||||
|
|
|
|||
Loading…
Reference in a new issue