beautiful rotation

This commit is contained in:
nek0 2019-09-29 00:58:32 +02:00
parent 39da367f51
commit 6a16dcbcff

View file

@ -7,22 +7,18 @@
module Main where
import qualified SDL
import qualified SDL hiding (V2(..))
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
import SDL (($=))
import Control.Concurrent.STM
import Graphics.GPipe
import Linear
import Control.Monad
import Control.Monad.Trans
import Reactive.Banana.Frameworks as RBF
import Reactive.Banana as RB
import Data.Maybe (fromMaybe)
@ -72,13 +68,15 @@ main = do
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
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 (pos, col) = (fun pos, col)
first fun (position, color) = (fun position, color)
primitiveStream4 = fmap (first (rotationMatrix (uniform) !*)) primitiveStream3
fragmentStream <- rasterize
(const
@ -115,25 +113,27 @@ main = 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) univar = mdo
networkDescription
:: (AddHandler [SDL.Event], b)
-> TMVar Float
-> MomentIO ()
networkDescription (listenerah, _) univar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
eventChanged <- changes blistener
_ <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent univar mouseah
let reaction = fmap (\x -> do
let input = (\(V2 x _) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
void $ atomically $ swapTMVar univar input
print x) 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
let input = (\(V2 xx _) ->
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
(\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
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
@ -153,15 +153,11 @@ registerListenerEvent listenerah mousefire = do
if null fevs then return () else mousefire fevs
return listenerah
-- registerMouseEvent
-- :: (MonadIO m, ContextHandler ctx ~ ContextHandler FRPBallCtx)
-- => Buffer os (Uniform (B Float))
-- -> AddHandler [SDL.Event]
-- -> m (AddHandler [SDL.Event])
registerMouseEvent
:: MonadIO m
=> TMVar Float
-> AddHandler [SDL.Event]
-> m (AddHandler [SDL.Event])
registerMouseEvent univar 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
void $ atomically $ swapTMVar univar input
) :: [SDL.Event] -> IO ()
)
_ <- liftIO $ register mouseah $ \_ -> return ()
return mouseah