diff --git a/reactive-fieldtrip.cabal b/reactive-fieldtrip.cabal --- a/reactive-fieldtrip.cabal +++ b/reactive-fieldtrip.cabal @@ -1,5 +1,5 @@ Name: reactive-fieldtrip -Version: 0.0.8 +Version: 0.0.9 Cabal-Version: >= 1.2 Synopsis: Connect Reactive and FieldTrip Category: Graphics, FRP @@ -23,7 +23,7 @@ Library hs-Source-Dirs: src Extensions: - Build-Depends: base, reactive >= 0.10.2, reactive-glut >= 0.0.4, FieldTrip >= 0.2.1, vector-space, InfixApplicative + Build-Depends: base, unamb, reactive >= 0.10.2, reactive-glut >= 0.0.4, FieldTrip >= 0.2.1, vector-space, InfixApplicative Exposed-Modules: FRP.Reactive.FieldTrip FRP.Reactive.FieldTrip.Adapter @@ -35,3 +35,5 @@ -- ghc-prof-options: -prof -auto-all -- vector-space only used for Test + +-- remove unamb dep later when debugging code is removed from src/Test.hs diff --git a/src/FRP/Reactive/FieldTrip.hs b/src/FRP/Reactive/FieldTrip.hs --- a/src/FRP/Reactive/FieldTrip.hs +++ b/src/FRP/Reactive/FieldTrip.hs @@ -25,7 +25,7 @@ import FRP.Reactive.FieldTrip.Adapter -instance (Ord tr, Transform xf a) => +instance (Ord tr, Bounded tr, Transform xf a) => Transform (BehaviorG tr tf xf) (BehaviorG tr tf a) where (*%) = liftA2 (*%) diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} -- remove later {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- | @@ -22,32 +23,103 @@ 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 "Let's have fun!" - -- anim3 spin + -- 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 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 ": <>". + +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 pres +-- Flip between 1 & -1 on left button press signFlip :: Anim Double signFlip = accumLB 1 negate @@ -61,14 +133,52 @@ 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 @@ -98,6 +208,17 @@ 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)) @@ -130,6 +251,54 @@ -- 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. ----