FieldTrip-0.2: examples/src/Test.hs

{-# LANGUAGE TypeOperators #-}
-- {-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  Test
-- Copyright   :  (c) Andy J Gill and Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Tablet shape with rounded corners
----------------------------------------------------------------------

module Main where

import Data.Monoid
import Control.Applicative

import Graphics.Rendering.OpenGL (Color)
import Graphics.FieldTrip.Glut 

import Data.VectorSpace
import Data.Derivative ((:>))

import Graphics.FieldTrip.Misc
import Graphics.FieldTrip.Geometry2
import Graphics.FieldTrip.Geometry3
import Graphics.FieldTrip.Transform
import Graphics.FieldTrip.Transform3
import Graphics.FieldTrip.Vector2
import Graphics.FieldTrip.Vector3
import Graphics.FieldTrip.Color
import Graphics.FieldTrip.Material
import Graphics.FieldTrip.Image
import Graphics.FieldTrip.Render
import qualified Graphics.FieldTrip.ParamSurf as P
import Graphics.FieldTrip.ParamSurf hiding (torus)

import Graphics.Formats

-- These next two aren't yet release openly.

-- import Graphics.Formats.Obj
-- import Codec.Image.DevIL

import System.IO.Unsafe

-- import Data.Behavior
import FRP.Reactive.Reactive

import FRP.Reactive.Internal.Misc (Sink)

-- import Tablet

main :: IO ()
main =
  do -- ilInit
     anim3 $ spinningG $
         -- flatG ubox2
         -- uscale3 (3::R) *% (sphere 0.3 `mappend` flatG ubox2)
         -- cube
         -- flatG $ uscale2 (0.5::R) *% diskWedge (1/3)
         -- flatG $ roundedRect 2 3 (1/2)
         -- pivot3 (xVector3::Vector3 R) $ cylinder (1/2) 2
         -- tablet1 2 3 (1/2) (1/4)
         -- tablet2 2 3 (1/2)
         -- cone 1 1
         -- redTorus `mappend` greenCyl
         torusPair
         -- ptor (rings . (50 *^))
         -- ptor (checker . (50 *^))
         -- ptor groovy
         -- testH' groovy eggcrateH
         -- testH rippleH
         -- when testing the next two, increase gcErr (below) to 0.05
         -- torusCrate
         -- torusCrate'
         -- loadObj "Astin DB9.obj"

-- loadObj :: String -> Geometry3
-- loadObj x =
--   renderableG obj
--   where
--      obj = unsafePerformIO
--               $ objFromFile ("examples/" ++ x) ["examples/"]

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

torusCrate, torusCrate' :: Geometry3
torusCrate = plasmat yellow $ surfG $
             displace (P.torus 1 (1/2)) (stretchH eggcrateH)

torusCrate' = flip surfG' groovy $
              displace (P.torus 1 (1/2)) (stretchH eggcrateH)

testH :: HeightField (Vector2 R :> R) -> Geometry3
testH = surfG . hfSurf . stretchH

testH' :: Color c => Image c -> HeightField (Vector2 R :> R) -> Geometry3
testH' im = flip surfG' im . hfSurf . stretchH

stretchH :: Fractional s => HeightField s -> HeightField s
stretchH hf = (/ 10) . hf . (* 10)

ptor :: Color c => Image c -> Geometry3
ptor = surfG' (P.torus 1 (1/2))

groovy :: ImageC
groovy (s,t) =
  rgba (sinU (3*s+5*t)) (cosU (5*t-3*s)) (sinU (3*s+5*t)) ((1+sinU (5*s*t) / 2))

redTorus, greenCyl :: Geometry3
redTorus = plasmat red   $ torus 1 (1/2)
greenCyl = plasmat green $ cylinder (1/3) 3

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)

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

spinning :: Anim (Transform3 Double)
spinning env = (f . (*1)) <$> timeR env
 where
   f 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

{-

-- This reads mouse clicks, and 
withClick :: GlutEvents -> Behavior Double
withClick events = timeB
{-
fmap (\ (a,b) -> b)
		 $ snapshot mouseEvents timeB
-}
  where
	mouseEvents :: Event Bool
	mouseEvents = fmap (\ (_,x,_,_) ->
				       case x of
					 Up -> False
					 Down -> True)
		   $ filterMP (\ (key,state,mods,pos) ->
				    case (key,state) of
				      (MouseButton _,Down) -> True
				      _ -> False) 
			       (keyboardMouseEvent events)

-}

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

animate :: Sink a -> Sink (Anim a)
animate f anim = runWithGlut ((fmap.fmap) f anim)

anim2 :: Sink (Anim Geometry2)
anim2 = animate render2

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


-- Later:

-- type Anim a = GlutEvents -> Behavior a