reactive-fieldtrip-0.0: src/FTest.hs

{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  FTest
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Test Reactive + FieldTrip
----------------------------------------------------------------------

module FTest where

import Data.Monoid
import Control.Applicative

import Graphics.FieldTrip

import FRP.Reactive
import FRP.Reactive.GLUT.Adapter


main :: IO ()
main = -- anim2 $ pure.pure $ txt
       -- anim2 $ pure $ rotTxt <$> time
       -- anim2 track
       -- anim2 $ revTxt "Let's have fun!"
       -- anim3 spin
       anim2 $ (fmap.fmap) rotTxt (uiIntegral signFlip)

txt :: Geometry2
txt = utext "Reactive + FieldTrip"


-- Accumulate function applications on each left button press
accumLB :: a -> (a->a) -> (UI -> Behavior a)
accumLB a f ui = a `accumB` (f <$ leftButtonPressed ui)

-- Flip between 1 & -1 on left button pres
signFlip :: UI -> Behavior Double
signFlip = accumLB 1 negate

-- Reverse text on left button press
revTxt :: String -> (UI -> Behavior Geometry2)
revTxt str ui = utext <$> accumLB str reverse ui

-- revTxt = (fmap.fmap.fmap) utext (flip accumLB reverse)

rotTxt :: Double -> Geometry2
rotTxt t = rotate2 t *% txt

track :: Anim Geometry2
track = (fmap.fmap) (f . uncurry Vector2) mousePosition
 where
   f = (uscale2 (0.5::Float) *%) . utext . show

spin :: Anim Geometry3
spin = spinningG $
         -- usphere
         torusPair
         -- flatG txt

torusPair :: Geometry3
torusPair = f red (1/2) `mappend` pivot3X (f green (-1/2))
 where
   tor = torus 1 (2/5)
   f :: Col -> R -> Geometry3
   f col dx = plasmat col (move3X dx tor)

-- Start at zero with a velocity of one.  Negate velocity on each event occurrence.
reverseVel :: (UI -> Event a) -> (UI -> Behavior Double)
reverseVel ue = uiIntegral vel
 where
    vel ui = 1 `accumB` (negate <$ ue ui)

----

plasmat :: Col -> Filter3
plasmat col = materialG (plastic col)

spinningG :: Geometry3 -> Anim Geometry3
spinningG g env = liftA2 (*%) (spinning env) (pure g)

spinning :: Anim (Transform3 Double)
spinning = const (xf . (*2) <$> time)
 where
   xf t = translate3 (Vector3 (0::Double) 0 (3*sin (-t/5)))
            `mappend` rotate3 t (Vector3 0.1 0.2 0.3)
            `mappend` scale3 0.2 0.2 0.2

{--------------------------------------------------------------------
    Move to reactive-fieldtrip
--------------------------------------------------------------------}

view :: Filter3
view = move3Z (-3 :: R)

type Anim a = UI -> Behavior a

animate :: Sink a -> Sink (Anim a)
animate f anim = adaptSimple "Reactive + FieldTrip" ((fmap.fmap) f anim)

anim2 :: Sink (Anim Geometry2)
anim2 = anim3 . (fmap.fmap) flatG

anim3 :: Sink (Anim Geometry3)
anim3 = animate (renderWith3 gc . view)
 where
   gc = defaultGC { gcErr = 0.005 }