Merge pull request #190 from turion/sundry

Sundry

rhine-examples/rhine-examples.cabal

@@ -51,6 +51,24 @@ executable ADSR
   if flag(dev)
     ghc-options: -Werror
 
+executable Ball
+  hs-source-dirs:      src
+  main-is:             Ball.hs
+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base         >= 4.14 && < 4.18
+                     , rhine        == 0.8.1.1
+                     , vector-sized >= 1.4
+                     , random       >= 1.1
+  default-language:    Haskell2010
+  default-extensions:
+    Arrows
+    DataKinds
+    RankNTypes
+    TypeFamilies
+    TypeOperators
+  if flag(dev)
+    ghc-options: -Werror
+
 executable Periodic
   hs-source-dirs:      src
   main-is:             Periodic.hs

rhine-examples/src/Ball.hs

@@ -0,0 +1,87 @@
+-- base
+import Control.Monad (guard)
+import Text.Printf
+
+-- random
+import System.Random
+
+-- vector-sized
+import Data.Vector.Sized as VS
+
+-- rhine
+import FRP.Rhine
+
+type Ball    = (Double, Double, Double)
+type BallVel = (Double, Double, Double)
+
+type SimClock = Millisecond 10
+type StatusClock = Millisecond 500
+
+freeFall :: Monad m
+         => BallVel
+         -> BehaviourF m UTCTime () Ball
+freeFall v0 =
+      arr (const (0, 0, -9.81))
+  >>> integralFrom v0
+  >>> integral
+
+startVel :: ClSF IO StdinClock () BallVel
+startVel = arrMCl $ const $ do
+  velX <- randomRIO (-10, 10)
+  velY <- randomRIO (-10, 10)
+  velZ <- randomRIO (3, 10)
+  return (velX, velY, velZ)
+
+waiting :: MonadIO m => ClSF (ExceptT BallVel m)
+            SimClock (Maybe BallVel) Ball
+waiting = throwMaybe >>> arr (const zeroVector)
+
+falling :: Monad m
+        => BallVel
+        -> ClSF (ExceptT () m) SimClock
+            (Maybe BallVel) Ball
+falling v0 = proc _ -> do
+  pos <- freeFall v0 -< ()
+  let (_, _, height) = pos
+  throwMaybe -< guard $ height < 0
+  returnA    -< pos
+
+ballModes :: ClSFExcept IO SimClock (Maybe BallVel) Ball void
+ballModes = do
+  v0 <- try waiting
+  once_ $ putStrLn "Catch!"
+  try $ falling v0
+  once_ $ putStrLn "Caught!"
+  ballModes
+
+ball :: ClSF IO SimClock (Maybe BallVel) Ball
+ball = safely ballModes
+
+downsampleSimToStatus :: ResBuf IO SimClock StatusClock Ball Ball
+downsampleSimToStatus = downsampleMillisecond
+                    >>-^ arr VS.head
+
+statusMsg :: ClSF IO StatusClock Ball ()
+statusMsg = arrMCl $ \(x, y, z) ->
+  printf "%.2f %.2f %.2f\n" x y z
+
+startVelRh :: Rhine IO StdinClock () BallVel
+startVelRh = startVel @@ StdinClock
+
+ballRh :: Rhine IO SimClock (Maybe BallVel) Ball
+ballRh = ball @@ waitClock
+
+statusRh :: Rhine IO StatusClock Ball ()
+statusRh = statusMsg @@ waitClock
+
+simToStatus :: ResamplingPoint IO SimClock StatusClock Ball Ball
+simToStatus = downsampleSimToStatus -@- scheduleMillisecond
+
+ballStatusRh :: Rhine IO (SeqClock IO SimClock StatusClock) (Maybe BallVel) ()
+ballStatusRh = ballRh >-- simToStatus --> statusRh
+
+main :: IO ()
+main = flow $
+  startVelRh
+  >-- fifoUnbounded -@- concurrently -->
+  ballStatusRh

rhine-gloss/Main.hs

@@ -12,7 +12,7 @@ import FRP.Rhine.Gloss
 gears :: Float -> Picture
 gears angle = color green $ pictures
   $ circleSolid 60
-  : map (rotate angle) [ rotate (45 * n) $ rectangleSolid 20 150 | n <- [0..3] ]
+  : [rotate (angle + 45 * n) $ rectangleSolid 20 150 | n <- [0 .. 3]]
 
 -- | Rotate the gear with a constant angular velocity.
 --   Disregards all events.

rhine-gloss/src/FRP/Rhine/Gloss/IO.hs

@@ -6,6 +6,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE BangPatterns #-}
 module FRP.Rhine.Gloss.IO
   ( GlossConcT
   , paintIO
@@ -42,7 +44,12 @@ import FRP.Rhine.Gloss.Common
 
 -- * Gloss effects
 
-type GlossEnv = (MVar Float, MVar Event, IORef Float, IORef Picture)
+data GlossEnv = GlossEnv
+  { timeVar :: MVar Float
+  , eventVar :: MVar Event
+  , picRef :: IORef Picture
+  , time :: Float
+  }
 
 -- | Wraps the concurrent variables needed for communication with the @gloss@ backend.
 newtype GlossConcT m a = GlossConcT
@@ -54,7 +61,7 @@ withPicRef
   => (IORef Picture -> IO a)
   -> GlossConcT m a
 withPicRef action = GlossConcT $ do
-  (_, _, _, picRef) <- ask
+  GlossEnv { picRef } <- ask
   liftIO $ action picRef
 
 -- | Add a picture to the canvas.
@@ -80,10 +87,9 @@ instance MonadIO m => Clock (GlossConcT m) GlossEventClockIO where
   initClock _ = return (constM getEvent, 0)
     where
       getEvent = do
-        (_, eventVar, timeRef, _) <- GlossConcT ask
+        GlossEnv { eventVar, time } <- GlossConcT ask
         liftIO $ do
           event <- takeMVar eventVar
-          time <- readIORef timeRef
           return (time, event)
 
 instance GetClockProxy GlossEventClockIO
@@ -94,14 +100,11 @@ data GlossSimClockIO = GlossSimClockIO
 instance MonadIO m => Clock (GlossConcT m) GlossSimClockIO where
   type Time GlossSimClockIO = Float
   type Tag  GlossSimClockIO = ()
-  initClock _ = return (constM getTime >>> sumS >>> withSideEffect writeTime &&& arr (const ()), 0)
+  initClock _ = return (constM getTime &&& arr (const ()), 0)
     where
       getTime = do
-        (timeVar, _, _, _) <- GlossConcT ask
+        GlossEnv { timeVar } <- GlossConcT ask
         liftIO $ takeMVar timeVar
-      writeTime time = do
-        (_, _, timeRef, _) <- GlossConcT ask
-        liftIO $ writeIORef timeRef time
 
 instance GetClockProxy GlossSimClockIO
 
@@ -121,16 +124,17 @@ launchGlossThread
   -> GlossConcT m a
   ->            m a
 launchGlossThread GlossSettings { .. } glossLoop = do
-  vars <- liftIO $ ( , , , ) <$> newEmptyMVar <*> newEmptyMVar <*> newIORef 0 <*> newIORef Blank
+  vars <- liftIO $ GlossEnv <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Blank <*> pure 0
   let
-      getPic               (_, _, _, picRef)   = readIORef picRef
+      getPic GlossEnv { picRef }   = readIORef picRef
       -- Only try to put so this doesn't hang in case noone is listening for events or ticks
-      handleEvent event    vars@(_, eventVar, _, _) = do
+      handleEvent event vars@GlossEnv { eventVar } = do
         void $ tryPutMVar eventVar event
         return vars
-      simStep     diffTime vars@(timeVar,  _, _, _) = do
-        void $ tryPutMVar timeVar diffTime
-        return vars
+      simStep diffTime vars@GlossEnv { timeVar, time } = do
+        let !time' = time + diffTime
+        void $ tryPutMVar timeVar time'
+        return vars { time = time' }
   void $ liftIO $ forkIO $ playIO display backgroundColor stepsPerSecond vars getPic handleEvent simStep
   runReaderT (unGlossConcT glossLoop) vars
 

rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs

@@ -14,7 +14,7 @@ import Data.Time.Clock
 import Control.Concurrent (threadDelay)
 import GHC.TypeLits
 
--- fixed-vector
+-- vector-sized
 import Data.Vector.Sized (Vector, fromList)
 
 -- rhine