reactive-fieldtrip 0.0.8 → 0.0.9
raw patch · 3 files changed
+178/−7 lines, 3 filesdep +unamb
Dependencies added: unamb
Files
- reactive-fieldtrip.cabal +4/−2
- src/FRP/Reactive/FieldTrip.hs +1/−1
- src/Test.hs +173/−4
reactive-fieldtrip.cabal view
@@ -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
src/FRP/Reactive/FieldTrip.hs view
@@ -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 (*%)
src/Test.hs view
@@ -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 "<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 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. ----