{-# LANGUAGE TypeFamilies #-} -- remove later
{-# 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
-- For Vector3 VectorSpace instance.  Why not gotten from previous import?
-- This one doesn't work either.
-- import Graphics.FieldTrip.Vector3

import FRP.Reactive.FieldTrip

-- remove the next batch (and the unamb dependency in
-- reactive-fieldtrip.cabal) when done debugging.
import FRP.Reactive.Internal.Future
import FRP.Reactive.Internal.Reactive
import Data.Unamb
import Control.Arrow (first)


main :: IO ()
main = -- anim2 $ pure.pure $ txt
       -- anim2 $ pure $ rotTxt <$> time
       -- anim2 track
       -- anim2 $ revTxt "Click me!"
       anim3 spin
       -- anim2 spin'
       -- anim2 times
       -- (anim2 . showE) (withPrevE' . snapshot_ time . framePass)
       -- 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
       -- anim2 $ (fmap.fmap) utext typing
       -- anim2 rotType

showE :: Show a => (UI -> Event a) -> Anim2
showE f u = utext <$> ("" `stepper` (show <$> f u))

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

times :: Anim2
times u = (utext.show) <$> theTime u

-- steps :: Anim TimeT
-- steps u = 1 `stepper` (20 <$ framePass u)

theTime :: Anim TimeT
-- theTime = steps
theTime = uiIntegral (const 1)
-- theTime = const time

-- Tue Dec 30 17:21:33 2008: when I use the uiIntegral definition, I don't
-- get updates past the first one.  Memory use shoots up to 1.7GB, and CPU
-- to 100% of a processor.
-- 
-- The problem seems to be from withPrevE, which uses joinMaybes.

-- Here's a version without joinMaybes.  Runs fine.

-- withPrevE' :: (Ord t, Bounded t) => EventG t a -> EventG t (Maybe (a,a))
-- withPrevE' e = ({- joinMaybes .-} fmap combineMaybes) $
--                (Nothing,Nothing) `accumE` fmap (shift.Just) e
--  where
--    -- Shift newer value into (new,old) pair if present.
--    shift :: u -> (u,u) -> (u,u)
--    shift newer (new,_) = (newer,new)
--    combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)
--    combineMaybes = uncurry (liftA2 (,))


-- Here's one that uses justE.  It's easy on memory but doesn't produce
-- any output other than two of "<interactive>: <<loop>>".

withPrevE' :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a)
withPrevE' e = (justE' . fmap combineMaybes) $
               (Nothing,Nothing) `accumE` fmap (shift.Just) e
 where
   -- Shift newer value into (new,old) pair if present.
   shift :: u -> (u,u) -> (u,u)
   shift newer (new,_) = (newer,new)
   combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)
   combineMaybes = uncurry (liftA2 (,))


justE' :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a
justE' ~(Event (Future (t, mb `Stepper` e'))) =
  assuming (t == maxBound) mempty `unamb`
  (inEvent.inFuture.first) (max t) $
    case mb of
      Nothing -> justE e'
      Just a  -> Event (Future (t, a `Stepper` justE e'))



-- 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 press
signFlip :: Anim Double
signFlip = accumLB 1 negate

-- Reverse text on left button press
revTxt :: String -> Anim2
revTxt str = (fmap.fmap) utext (accumLB str reverse)

-- revTxt str ui = utext <$> accumLB str reverse ui
-- revTxt = (fmap.fmap.fmap) utext (flip accumLB reverse)

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


rotType :: Anim2
rotType = (liftA2.liftA2) h (uiIntegral signFlip) typing
 where
   h :: Double -> String -> Geometry2
   h ang str = rotate2 ang *% utext str


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

typing :: Anim String
typing u = reverse <$> (accumB "" ((:) <$> charPressed' u))

-- This one lags a character.  Probably due to the joinMaybes
charPressed :: UI -> Event Char
charPressed u = joinMaybes (char <$> keyPressed u)
 where
   char (Char ch) = Just ch
   char _         = Nothing

-- This one has no lag.
charPressed' :: UI -> Event Char
charPressed' u = char <$> keyPressed u
 where
   char (Char ch) = ch
   char _         = '_'

-- also try monoidB



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


-- spinAng :: Anim (Transform2 TimeT)
spinI :: UI -> Behavior (Transform2 TimeT)
spinI u = rotate2 <$> uiIntegral 1 u

spin' :: Anim2
spin' u = spinI u *% (pure txt :: Behavior Geometry2)


spin :: Anim3
spin = const . 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 = materialG (plastic 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 = (f <$> time) *% pure g0
    where
      f t = translate3 (Vector3 (t-t0) 0 (-5))

-- -- Experiment.  Ought to be picked up from Vector3.
-- instance AdditiveGroup u => AdditiveGroup (Vector3 u) where
--   zeroV                   = Vector3 zeroV zeroV zeroV
--   Vector3 u v w ^+^ Vector3 u' v' w'
--                           = Vector3 (u^+^u') (v^+^v') (w^+^w')
--   negateV (Vector3 u v w) = Vector3 (negateV u) (negateV v) (negateV w)
-- instance VectorSpace u => VectorSpace (Vector3 u) where
--   type Scalar (Vector3 u) = Scalar u
--   s *^ Vector3 u v w      = Vector3 (s*^u) (s*^v) (s*^w)


-- Drop a ball on each event occurrence
drops' :: Event (Vector3 Double) -> Event () -> Behavior Geometry3
drops' starts tick = monoidB (g <$> (tick `snapRemainderE` starts))
 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 = liftA2 drops' (liftA2 snapshot_ mouseMotion leftButtonPressed)
                       framePass

-- 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 = (translate3 start *%) <$> spinningG torusPair

-- Drop a ball from the mouse on each left button press.
lplace :: Anim3
lplace = place <$> liftA2 snapshot_ mouseMotion leftButtonPressed

-- lplace ui = place (leftButtonPressed ui `snapshot_` mouseMotion ui)


spring0 :: Vector3 Double -> Anim (Vector3 Double) -> Anim (Vector3 Double)

-- spring0 _ = id

-- spring0 pos0 _ u = pos
--  where
--    pos, vel :: Behavior (Vector3 Double)
--    pos  = pure pos0 ^+^ integ vel
--    vel  = pure $ vector3 0 (-1) 0
--    integ = integral (framePass u)

spring0 pos0 target u = pos
 where
   pos, vel :: Behavior (Vector3 Double)
   pos  = pure pos0 ^+^ integ vel
   vel  = target u ^/ mass
   mass = 1
   integ = integral (framePass u)

spring1 :: Vector3 Double -> Anim (Vector3 Double) -> Anim (Vector3 Double)
spring1 pos0 target u = pos
 where
   pos, vel :: Behavior (Vector3 Double)
   pos  = pure pos0 ^+^ integ vel
   vel  = (target u ^-^ pos) ^/ mass
   mass = 1
   integ = integral (framePass u)

-- Spring pulling a 
spring :: Vector3 Double -> Anim (Vector3 Double) -> Anim (Vector3 Double)
spring pos0 target u = pos
 where
   pos, vel, acc :: Behavior (Vector3 Double)
   pos  = pure pos0 ^+^ integ vel
   vel  = pure vel0 ^+^ integ acc
   acc  = (target u ^-^ pos) ^/ mass
   mass = 1
   vel0 = zeroV :: Vector3 Double
   integ = integral (framePass u)

springy :: Anim3
springy u = (translate3 <$> spring1 zeroV target u) *% pure usphere
 where
   target = -- mouseMotion
            -- const $ liftA3 vector3Spherical 1 time (pi/2)
            const $ liftA3 vector3 1 1 0

-- All three target variations get stuck.  Hm.

----

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

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

spinning :: Behavior (Transform3 Double)
spinning = 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.