Moe-0.1: FRP/MoeExample.hs

{-# LANGUAGE NoMonomorphismRestriction, Arrows #-}
import Control.Applicative
import Control.Arrow
import Data.Monoid
import FRP.MoePure
import FRP.MoeGLUT
import Graphics.UI.GLUT

white = Color3 1 1 1 :: Color3 GLfloat

red = Color3 1 0 0

green = Color3 0 1 0

blue = Color3 0 0 1

-- Rate of acceleration.
g = 200

-- X position of the ground.
xGround = 200

-- A ball falling with gravity.
fallingBall (x0, v0) = proc () -> do v <- arr (+ v0) <<< integral -< g
                                     x <- arr (+ x0) <<< integral -< v
                                     returnA -< (x, v)

-- If the ball hits the ground, reverses the velocity to let it bounce.
hit (x, v) = (x, if x >= xGround && v > 0 then Event (x, -v) else NoEvent)

-- Example for the (dswitch) combinator.
bouncingBall xv0 = dswitch (fallingBall xv0 >>> arr hit) bouncingBall

-- Example for the (timedCycle) combinator.
coloredBouncingBall :: (Double, Double) -> SF () (Color3 GLfloat, Double)
coloredBouncingBall xv0 = timedCycle [(interval, green), (interval, red), (interval, blue)] &&&
                                     bouncingBall xv0 where
                                      interval = 0.5

-- Example for the (dkswitch) combinator.
bouncingBall2 xv0 = dkswitch (bouncingBall xv0 >>> arr (\x -> [x]))
                             (arr (\((), (x : _)) -> if x > xGround then Event () else NoEvent))
                             (\sfs _ -> mappend (bouncingBall2 xv0) sfs)

drawPoly ps = renderPrimitive Polygon $ mapM_ vertex ps 

drawBall :: GLdouble -> GLdouble -> GLdouble -> IO ()
drawBall r x0 y0 = mapM_ (\th -> drawPoly [Vertex2 x0 y0, 
                                           Vertex2 (x0 + r * cos th) (y0 + r * sin th),
                                           Vertex2 (x0 + r * cos (th + dth)) (y0 + r * sin (th + dth))]) 
                   $ [0,dth..2*pi] where dth = 0.1*pi
                   
              
output (x, (c, x'), xs) = do color white
                             drawBall 20 100 (300 - realToFrac x)
                             color c
                             drawBall 20 200 (300 - realToFrac x)
                             color white
                             mapM_ (\(i, x) -> drawBall 20 (300 + 20*i) (300 - realToFrac x)) (zip [0,1..] $ reverse xs)

example = liftA3 (,,) 
                 (bouncingBall (0, 0))
                 (coloredBouncingBall (0, 0))
                 (bouncingBall2 (0, 0))

main = start 20 (sfConst () >>> example) (0, (green, 0), [0]) output