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

module Test where

import Data.Monoid
import Control.Applicative

import Data.VectorSpace

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

import Graphics.FieldTrip

import FRP.Reactive.FieldTrip.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)
       -- anim3 $ (pure.pure) (move3Z (-5::R) (uscale3 (0.5::R) *% torusPair))
       -- anim3 $ drops . leftButtonPressed
       -- anim3 ldrops
       anim3 lplace
       -- anim3 motionTxt

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


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

-- Flip between 1 & -1 on left button pres
signFlip :: Anim Double
signFlip = accumLB 1 negate

-- Reverse text on left button press
revTxt :: String -> Anim2
revTxt str ui = utext <$> accumLB str reverse ui

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

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

motionTxt :: Anim3
motionTxt = (fmap.fmap) (flatG . (uscale2 (0.5::R) *%) . utext . show) mouseMotion

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

spin :: Anim3
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) -> Anim Double
reverseVel ue = uiIntegral vel
 where
    vel ui = 1 `accumB` (negate <$ ue ui)


-- Drop a ball on each event occurrence
drops :: Event () -> Behavior Geometry3
drops e = monoidB (g <$> withTimeE_ e)
 where
   g0   = uscale3 (0.3 :: R) *% torusPair
   g t0 = liftA2 (*%) (f <$> time) (pure g0)
    where
      f t = translate3 (Vector3 (t-t0) 0 (-5))

-- Drop a ball on each event occurrence
drops' :: Event (Vector3 Double) -> Event () -> Behavior Geometry3
drops' starts tick = monoidB (g <$> (starts `snapRemainderE` tick))
 where
   g0              = uscale3 (0.3 :: R) *% torusPair
   g (start,tick') = f <$> integral tick' (integral tick' acc)
     where
       f pos = translate3 (start ^+^ pos) *% g0
   acc             = pure ((-2) *^ yVector3)

-- Drop a ball from the mouse on each left button press.
ldrops :: Anim3
ldrops ui =
  drops' (leftButtonPressed ui `snapshot_` mouseMotion ui)
         (framePass ui)

-- Place a ball on each event occurrence
place :: Event (Vector3 Double) -> Behavior Geometry3
place starts = monoidB (g <$> starts)
 where
   g start = f <$> spinningG torusPair (error "blort!")
    where f = (translate3 start *%)

-- Drop a ball from the mouse on each left button press.
lplace :: Anim3
lplace ui = place (leftButtonPressed ui `snapshot_` mouseMotion ui)

-- lplace = place . liftA2 snapshot_ leftButtonPressed mouseMotion



----

mouseMotion :: Anim (Vector3 Double)
mouseMotion = (fmap.fmap) f mousePosition
 where
   f (mx,my) = vector3 mx my 0

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

spinningG :: Geometry3 -> Anim3
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` uscale3 0.2

-- Strange bug: if I increase the scale factor more than a tiny amount
-- above 0.28, I get flat white shading.