reactive-glut-0.0.1: src/FTest.hs

{-# OPTIONS -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 (Behavior,time)
import FRP.Reactive.GLUT.Adapter


main :: IO ()
main = -- anim2 $ pure.pure $ txt
       -- anim2 $ pure $ rotTxt <$> time
       -- anim2 track
       anim3 spin

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

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)

----

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 = adapt "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 }