nek0/frpball
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

beautiful rotation

Browse source
This commit is contained in:
nek0 2019-09-29 00:58:32 +02:00
parent 39da367f51
commit 6a16dcbcff
1 changed files with 28 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
src/Main.hs
View file

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