diff --git a/reactive-fieldtrip.cabal b/reactive-fieldtrip.cabal --- a/reactive-fieldtrip.cabal +++ b/reactive-fieldtrip.cabal @@ -1,11 +1,12 @@ Name: reactive-fieldtrip -Version: 0.0 +Version: 0.0.1 Cabal-Version: >= 1.2 Synopsis: Connect Reactive and FieldTrip Category: Graphics, FRP Description: - This library connects ''Reactive'' (a functional reactive - programming library) and ''FieldTrip'' (a functional 3D library). + This library supports functionally programming reactive, animated, 3D + graphics. It connects ''Reactive'' (a functional reactive programming + library) and ''FieldTrip'' (a functional 3D library). . Project wiki page: . @@ -25,10 +26,14 @@ Library hs-Source-Dirs: src Extensions: - Build-Depends: base, reactive, reactive-glut, FieldTrip + Build-Depends: base, reactive >= 0.8.7, reactive-glut >= 0.0.4, FieldTrip >= 0.2.1, vector-space Exposed-Modules: - FTest + FRP.Reactive.FieldTrip.Adapter + Other-Modules: + Test ghc-options: -Wall -- ghc-prof-options: -prof -auto-all + +-- vector-space only used for Test diff --git a/src/FRP/Reactive/FieldTrip/Adapter.hs b/src/FRP/Reactive/FieldTrip/Adapter.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/FieldTrip/Adapter.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.FieldTrip.Adapter +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Simple Reactive/FieldTrip adapter +---------------------------------------------------------------------- + +module FRP.Reactive.FieldTrip.Adapter + ( Anim, Anim2, Anim3 + , anim2, anim3 + ) where + +import Graphics.FieldTrip +import FRP.Reactive +import FRP.Reactive.GLUT.Adapter + +-- | Simple viewing transformation. Just moves geometry away from the user. +view :: Filter3 +view = move3Z (-3 :: R) + +-- | Interactive animation +type Anim a = UI -> Behavior a + +-- | Interactive 2D animation +type Anim2 = Anim Geometry2 + +-- | Interactive 3D animation +type Anim3 = Anim Geometry3 + +-- | Present an animation, given a way to render a value. +animate :: Sink a -> Sink (Anim a) +animate f anim = adaptSimple "Reactive + FieldTrip" ((fmap.fmap) f anim) + +-- | Present a 2D animation. +anim2 :: Sink Anim2 +anim2 = anim3 . (fmap.fmap) flatG + +-- | Present a 2D animation. +anim3 :: Sink Anim3 +anim3 = animate (renderWith3 gc . view) + where + gc = defaultGC { gcErr = 0.005 } diff --git a/src/FTest.hs b/src/FTest.hs deleted file mode 100644 --- a/src/FTest.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : FTest --- Copyright : (c) Conal Elliott 2008 --- License : BSD3 --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Test Reactive + FieldTrip ----------------------------------------------------------------------- - -module FTest where - -import Data.Monoid -import Control.Applicative - -import Graphics.FieldTrip - -import FRP.Reactive -import FRP.Reactive.GLUT.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) - -txt :: Geometry2 -txt = utext "Reactive + FieldTrip" - - --- Accumulate function applications on each left button press -accumLB :: a -> (a->a) -> (UI -> Behavior a) -accumLB a f ui = a `accumB` (f <$ leftButtonPressed ui) - --- Flip between 1 & -1 on left button pres -signFlip :: UI -> Behavior Double -signFlip = accumLB 1 negate - --- Reverse text on left button press -revTxt :: String -> (UI -> Behavior Geometry2) -revTxt str ui = utext <$> accumLB str reverse ui - --- revTxt = (fmap.fmap.fmap) utext (flip accumLB reverse) - -rotTxt :: Double -> Geometry2 -rotTxt t = rotate2 t *% txt - -track :: Anim Geometry2 -track = (fmap.fmap) (f . uncurry Vector2) mousePosition - where - f = (uscale2 (0.5::Float) *%) . utext . show - -spin :: Anim Geometry3 -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) -> (UI -> Behavior Double) -reverseVel ue = uiIntegral vel - where - vel ui = 1 `accumB` (negate <$ ue ui) - ----- - -plasmat :: Col -> Filter3 -plasmat col = materialG (plastic col) - -spinningG :: Geometry3 -> Anim Geometry3 -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` scale3 0.2 0.2 0.2 - -{-------------------------------------------------------------------- - Move to reactive-fieldtrip ---------------------------------------------------------------------} - -view :: Filter3 -view = move3Z (-3 :: R) - -type Anim a = UI -> Behavior a - -animate :: Sink a -> Sink (Anim a) -animate f anim = adaptSimple "Reactive + FieldTrip" ((fmap.fmap) f anim) - -anim2 :: Sink (Anim Geometry2) -anim2 = anim3 . (fmap.fmap) flatG - -anim3 :: Sink (Anim Geometry3) -anim3 = animate (renderWith3 gc . view) - where - gc = defaultGC { gcErr = 0.005 } diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,152 @@ +{-# 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. diff --git a/wikipage.tw b/wikipage.tw --- a/wikipage.tw +++ b/wikipage.tw @@ -4,7 +4,7 @@ == Abstract == -The '''reactive-fieldtrip''' library connects [[reactive]]] (a functional reactive programming library) and [[FieldTrip]]] (a functional 3D library). +'''reactive-fieldtrip''' connects the [[Reactive]] (FRP) and [[FieldTrip]] (functional 3D) libraries, for functionally programming reactive, animated, 3D graphics. Besides this wiki page, here are more ways to find out about reactive-fieldtrip: * Read [http://code.haskell.org/reactive-fieldtrip/doc/html/ the library documentation].