Animas (empty) → 0.1
raw patch · 19 files changed
+3348/−0 lines, 19 filesdep +basedep +randomsetup-changed
Dependencies added: base, random
Files
- Animas.cabal +36/−0
- LICENSE +29/−0
- Setup.lhs +3/−0
- src/FRP/Animas.hs +1764/−0
- src/FRP/Animas/AffineSpace.hs +35/−0
- src/FRP/Animas/Diagnostics.hs +27/−0
- src/FRP/Animas/Event.hs +178/−0
- src/FRP/Animas/Forceable.hs +76/−0
- src/FRP/Animas/Geometry.hs +29/−0
- src/FRP/Animas/Internals.hs +30/−0
- src/FRP/Animas/MergeableRecord.hs +87/−0
- src/FRP/Animas/Miscellany.hs +124/−0
- src/FRP/Animas/Point2.hs +49/−0
- src/FRP/Animas/Point3.hs +54/−0
- src/FRP/Animas/Task.hs +219/−0
- src/FRP/Animas/Utilities.hs +242/−0
- src/FRP/Animas/Vector2.hs +99/−0
- src/FRP/Animas/Vector3.hs +120/−0
- src/FRP/Animas/VectorSpace.hs +147/−0
+ Animas.cabal view
@@ -0,0 +1,36 @@+name: Animas+version: 0.1+cabal-Version: >= 1.8+license: BSD3+license-file: LICENSE+author: Edward Amsden, Henrik Nilsson, Antony Courtney+maintainer: Edward Amsden (edwardamsden@gmail.com)+homepage: http://www.edwardamsden.com/animas/+category: Reactivity, FRP+synopsis: Updated version of Yampa: a library for programming hybrid systems.+description: A library for declarative programming of reactive systems. (Currently a fork of Yampa 0.9.2.3)+build-type: Simple+Tested-With: GHC++library+ hs-source-dirs: src+ ghc-options : -O2 -Wall -fno-warn-name-shadowing+ build-Depends: base < 5, random+ exposed-modules:+ FRP.Animas+ FRP.Animas.AffineSpace+ FRP.Animas.Event+ FRP.Animas.Geometry+ FRP.Animas.MergeableRecord+ FRP.Animas.Point2+ FRP.Animas.Utilities+ FRP.Animas.Vector3+ FRP.Animas.Forceable+ FRP.Animas.Point3+ FRP.Animas.Vector2+ FRP.Animas.VectorSpace+ FRP.Animas.Miscellany+ FRP.Animas.Task+ FRP.Animas.Internals+ other-modules:+ FRP.Animas.Diagnostics
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++- Neither name of the copyright holders nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/FRP/Animas.hs view
@@ -0,0 +1,1764 @@+{-# LANGUAGE GADTs, Rank2Types, CPP #-}+-- |+-- Module : FRP.Animas+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003.+-- Modifications by Edward Amsden and Matthew Hayden+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : edwardamsden@gmail.com+-- Stability : provisional+-- Portability : non-portable (GHC extensions)++module FRP.Animas (+ -- * Re-exported modules + module Control.Arrow,+ module FRP.Animas.VectorSpace,+ -- * Random-number classes + RandomGen(..),+ Random(..),+ -- * Convenience operators+ ( # ),+ dup,+ swap,+ -- * Datatypes+ Time,+ DTime,+ SF, + Event(..),+ -- * Pure signal functions+ arrPrim, arrEPrim,+ identity,+ constant,+ -- * Time signal functions+ localTime,+ time,+ -- * Initialization+ -- | These operators provide means of specifying the initial+ -- input or output of a signal function, overriding the signal function for+ -- the first cycle of animation+ (-->),+ (>--),+ (-=>),+ (>=-),+ initially,+ -- * Accumulator-based signal functions+ sscan,+ sscanPrim,+ -- * Events+ -- ** Basic event producers + never,+ now,+ after,+ repeatedly,+ afterEach,+ afterEachCat,+ edge,+ iEdge,+ edgeTag,+ edgeJust,+ edgeBy,+ once,+ noEvent,+ noEventFst,+ noEventSnd,+ -- ** Event manipulation+ delayEvent,+ delayEventCat,+ takeEvents,+ dropEvents,+ notYet,+ -- ** Stateful event processing+ old_hold,+ hold,+ dHold,+ trackAndHold,+ old_accum,+ old_accumBy,+ old_accumFilter,+ accum,+ accumHold,+ dAccumHold,+ accumBy,+ accumHoldBy,+ dAccumHoldBy,+ accumFilter,+ -- * Unlifted event functions+ event,+ fromEvent,+ isEvent,+ isNoEvent,+ tag,+ tagWith,+ attach,+ lMerge,+ rMerge,+ merge,+ mergeBy,+ mapMerge,+ mergeEvents,+ catEvents,+ joinE,+ splitE,+ filterE,+ mapFilterE,+ gate,+ -- * Switches+ -- | Switches provide run-time modification of the signal network. + -- Most switching combinators provided two varieties: an+ -- \"instantaneous\" version and a \"decoupled version\". The difference+ -- lies in which signal function is used to produce the value at the instant+ -- of switching. For an instantaneous switch, the signal function being + -- switched in is used to produce the value. For a decoupled switch, that+ -- signal function is used to produce the value at the /next/ instant,+ -- while the signal function being switched out is still used to produce+ -- the value at the instant of switching. This is useful for (among other+ -- things) ensuring that looped signal functions are well-founded+ -- recursively. Decoupled varieties of switches are prefixed with a \"d\".+ + -- ** Event-based switches+ switch, dSwitch, + rSwitch, drSwitch, + kSwitch, dkSwitch,+ -- ** Parallel switches (collections of signal functions)+ parB, + pSwitchB,dpSwitchB, + rpSwitchB,drpSwitchB,+ par,+ pSwitch, dpSwitch,+ rpSwitch,drpSwitch, + -- * Delays+ old_pre, old_iPre,+ pre,+ iPre,+ delay,+ -- * Calculus+ integral,+ derivative,+ imIntegral,+ -- * Looping+ -- | See also the 'loop' combinator from the 'ArrowLoop' class.+ loopPre,+ loopIntegral,+ -- * Randomized signal functions+ noise,+ noiseR,+ occasionally,+ -- * Animation+ ReactHandle,+ reactimate,+ reactInit,+ react,+ embed,+ embedSynch,+ deltaEncode,+ deltaEncodeBy,+ Step,+ initStep,+ step+) where++import Control.Monad (unless)+import System.Random (RandomGen(..), Random(..))++#if __GLASGOW_HASKELL__ >= 610+import qualified Control.Category (Category(..))+#else+#endif++import Control.Arrow+import FRP.Animas.Diagnostics+import FRP.Animas.Miscellany (( # ), dup, swap)+import FRP.Animas.Event+import FRP.Animas.VectorSpace++import Data.IORef++infixr 0 -->, >--, -=>, >=-++-- Time/DTime should be parameterized with a Num class restriction+-- | Time representation for signal functions+type Time = Double++type DTime = Double++-- | A signal function+data SF a b = SF {sfTF :: a -> Transition a b}++data SF' a b where+ SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b+ SFSScan :: !(DTime -> a -> Transition a b)+ -> !(c -> a -> Maybe (c, b)) -> !c -> b + -> SF' a b+ SFEP :: !(DTime -> Event a -> Transition (Event a) b)+ -> !(c -> a -> (c, b, b)) -> !c -> b+ -> SF' (Event a) b+ SFCpAXA :: !(DTime -> a -> Transition a d)+ -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d)+ -> SF' a d+ SF' :: !(DTime -> a -> Transition a b) -> SF' a b+type Transition a b = (SF' a b, b)+++sfTF' :: SF' a b -> (DTime -> a -> Transition a b)+sfTF' (SFArr tf _) = tf+sfTF' (SFSScan tf _ _ _) = tf+sfTF' (SFEP tf _ _ _) = tf+sfTF' (SFCpAXA tf _ _ _) = tf+sfTF' (SF' tf) = tf++sfArr :: FunDesc a b -> SF' a b+sfArr FDI = sfId+sfArr (FDC b) = sfConst b+sfArr (FDE f fne) = sfArrE f fne+sfArr (FDG f) = sfArrG f++sfId :: SF' a a+sfId = sf+ where+ sf = SFArr (\_ a -> (sf, a)) FDI+++sfConst :: b -> SF' a b+sfConst b = sf+ where+ sf = SFArr (\_ _ -> (sf, b)) (FDC b)+++sfNever :: SF' a (Event b)+sfNever = sfConst NoEvent++sfArrE :: (Event a -> b) -> b -> SF' (Event a) b+sfArrE f fne = sf+ where+ sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea))+ (FDE f fne)++sfArrG :: (a -> b) -> SF' a b+sfArrG f = sf+ where+ sf = SFArr (\_ a -> (sf, f a)) (FDG f)+++sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b+sfSScan f c b = sf + where+ sf = SFSScan tf f c b+ tf _ a = case f c a of+ Nothing -> (sf, b)+ Just (c', b') -> (sfSScan f c' b', b')++sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b+sscanPrim f c_init b_init = SF {sfTF = tf0}+ where+ tf0 a0 = case f c_init a0 of+ Nothing -> (sfSScan f c_init b_init, b_init)+ Just (c', b') -> (sfSScan f c' b', b')++sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b+sfEP f c bne = sf+ where+ sf = SFEP (\_ ea -> case ea of+ NoEvent -> (sf, bne)+ Event a -> let+ (c', b, bne') = f c a+ in+ (sfEP f c' bne', b))+ f+ c+ bne++epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b+epPrim f c bne = SF {sfTF = tf0}+ where+ tf0 NoEvent = (sfEP f c bne, bne)+ tf0 (Event a) = let+ (c', b, bne') = f c a+ in+ (sfEP f c' bne', b)++data FunDesc a b where+ FDI :: FunDesc a a+ FDC :: b -> FunDesc a b+ FDE :: (Event a -> b) -> b -> FunDesc (Event a) b+ FDG :: (a -> b) -> FunDesc a b++fdFun :: FunDesc a b -> (a -> b)+fdFun FDI = id+fdFun (FDC b) = const b+fdFun (FDE f _) = f+fdFun (FDG f) = f++fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c+fdComp FDI fd2 = fd2+fdComp fd1 FDI = fd1+fdComp (FDC b) fd2 = FDC ((fdFun fd2) b)+fdComp _ (FDC c) = FDC c++fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne)+ where+ f2 = fdFun fd2+fdComp (FDG f1) (FDE f2 f2ne) = FDG f+ where+ f a = case f1 a of+ NoEvent -> f2ne+ f1a -> f2 f1a+fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1)+++fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d)+fdPar FDI FDI = FDI+fdPar FDI (FDC d) = FDG (\(~(a, _)) -> (a, d))+fdPar FDI fd2 = FDG (\(~(a, c)) -> (a, (fdFun fd2) c))+fdPar (FDC b) FDI = FDG (\(~(_, c)) -> (b, c))+fdPar (FDC b) (FDC d) = FDC (b, d)+fdPar (FDC b) fd2 = FDG (\(~(_, c)) -> (b, (fdFun fd2) c))+fdPar fd1 fd2 = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c))+++fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c)+fdFanOut FDI FDI = FDG dup+fdFanOut FDI (FDC c) = FDG (\a -> (a, c))+fdFanOut FDI fd2 = FDG (\a -> (a, (fdFun fd2) a))+fdFanOut (FDC b) FDI = FDG (\a -> (b, a))+fdFanOut (FDC b) (FDC c) = FDC (b, c)+fdFanOut (FDC b) fd2 = FDG (\a -> (b, (fdFun fd2) a))+fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne+ where+ f1f2 NoEvent = f1f2ne+ f1f2 ea@(Event _) = (f1 ea, f2 ea)++ f1f2ne = (f1ne, f2ne)+fdFanOut fd1 fd2 =+ FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a))++vfyNoEv :: Event a -> b -> b+vfyNoEv NoEvent b = b+vfyNoEv _ _ = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event."++freeze :: SF' a b -> DTime -> SF a b+freeze sf dt = SF {sfTF = (sfTF' sf) dt}++freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)+freezeCol sfs dt = fmap (flip freeze dt) sfs++#if __GLASGOW_HASKELL__ >= 610+instance Control.Category.Category SF where+ (.) = flip compPrim + id = SF $ \x -> (sfId,x)+#else+#endif++instance Arrow SF where+ arr = arrPrim+ first = firstPrim+ second = secondPrim+ (***) = parSplitPrim+ (&&&) = parFanOutPrim+#if __GLASGOW_HASKELL__ >= 610+#else+ (>>>) = compPrim+#endif++-- | Lifts a function to a pure signal function. Use 'arr' from the 'Arrow'+-- class, rather than this function.+{-# NOINLINE arrPrim #-}+arrPrim :: (a -> b) -> SF a b+arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)}+++{-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-}+-- | Lifts a function with an event input to a pure signal function+-- on events. Use 'arr' from the 'Arrow' class, rather than this function.+arrEPrim :: (Event a -> b) -> SF (Event a) b+arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)}++compPrim :: SF a b -> SF b c -> SF a c+compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+ where+ tf0 a0 = (cpXX sf1 sf2, c0)+ where+ (sf1, b0) = tf10 a0+ (sf2, c0) = tf20 b0++cpXX :: SF' a b -> SF' b c -> SF' a c+cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2+cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2+cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =+ sfSScan f (s1, b, s2, c) c+ where+ f (s1, b, s2, c) a =+ let+ (u, s1', b') = case f1 s1 a of+ Nothing -> (True, s1, b)+ Just (s1',b') -> (False, s1', b')+ in+ case f2 s2 b' of+ Nothing | u -> Nothing+ | otherwise -> Just ((s1', b', s2, c), c)+ Just (s2', c') -> Just ((s1', b', s2', c'), c')+cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) =+ sfSScan f (s1, eb, s2, cne) cne+ where+ f (s1, eb, s2, cne) a =+ case f1 s1 a of+ Nothing ->+ case eb of+ NoEvent -> Nothing+ Event b ->+ let (s2', c, cne') = f2 s2 b+ in+ Just ((s1, eb, s2', cne'), c)+ Just (s1', eb') ->+ case eb' of+ NoEvent -> Just ((s1', eb', s2, cne), cne)+ Event b ->+ let (s2', c, cne') = f2 s2 b+ in+ Just ((s1', eb', s2', cne'), c)+cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) =+ sfSScan f (s1, bne, s2, c) c+ where+ f (s1, bne, s2, c) ea =+ let (u, s1', b', bne') = case ea of+ NoEvent -> (True, s1, bne, bne)+ Event a ->+ let (s1', b, bne') = f1 s1 a+ in+ (False, s1', b, bne')+ in+ case f2 s2 b' of+ Nothing | u -> Nothing+ | otherwise -> Just (seq s1' (s1', bne', s2, c), c)+ Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c')+cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) =+ sfEP f (s1, s2, cne) (vfyNoEv bne cne)+ where+ f (s1, s2, cne) a =+ case f1 s1 a of+ (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne)+ (s1', Event b, NoEvent) ->+ let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne')+ _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event."+cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =+ cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)+cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) =+ cpXX (cpXG sf1 f21) (cpXA sf22 fd23)+cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) =+ cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) +cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =+ cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23+cpXX sf1 sf2 = SF' tf + where+ tf dt a = (cpXX sf1' sf2', c)+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) dt b++cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d+cpAXA FDI sf2 fd3 = cpXA sf2 fd3+cpAXA fd1 sf2 FDI = cpAX fd1 sf2+cpAXA (FDC b) sf2 fd3 = cpCXA b sf2 fd3+cpAXA _ _ (FDC d) = sfConst d +cpAXA fd1 sf2 fd3 = + cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2+ where+ cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d)+ -> SF' b c -> SF' a d+ cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) =+ sfArr (fdComp (fdComp fd1 fd2) fd3)+ cpAXAAux fd1 _ fd3 _ sf2@(SFSScan _ _ _ _) =+ cpAX fd1 (cpXA sf2 fd3)+ cpAXAAux fd1 _ fd3 _ sf2@(SFEP _ _ _ _) =+ cpAX fd1 (cpXA sf2 fd3)+ cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) =+ cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3)+ cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3+ where+ tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c)+ where+ (sf2', c) = (sfTF' sf2) dt (f1 a)++cpAX :: FunDesc a b -> SF' b c -> SF' a c+cpAX FDI sf2 = sf2+cpAX (FDC b) sf2 = cpCX b sf2+cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2+cpAX (FDG f1) sf2 = cpGX f1 sf2++cpXA :: SF' a b -> FunDesc b c -> SF' a c+cpXA sf1 FDI = sf1+cpXA _ (FDC c) = sfConst c+cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne+cpXA sf1 (FDG f2) = cpXG sf1 f2++cpCX :: b -> SF' b c -> SF' a c+cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b)+cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c+cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne)+cpCX b (SFCpAXA _ fd21 sf22 fd23) =+ cpCXA ((fdFun fd21) b) sf22 fd23+cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI+ where+ tf dt _ = (cpCX b sf2', c)+ where+ (sf2', c) = (sfTF' sf2) dt b++cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d+cpCXA b sf2 FDI = cpCX b sf2+cpCXA _ _ (FDC c) = sfConst c+cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2+ where+ cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d)+ -> SF' b c -> SF' a d+ cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b))+ cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c)+ where+ f' s _ = case f s b of+ Nothing -> Nothing+ Just (s', c') -> Just (s', f3 c') + cpCXAAux _ b _ f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne))+ cpCXAAux _ b fd3 _ (SFCpAXA _ fd21 sf22 fd23) =+ cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3)+ cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3+ where+ tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c)+ where+ (sf2', c) = (sfTF' sf2) dt b++cpGX :: (a -> b) -> SF' b c -> SF' a c+cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2+ where+ cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c+ cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)+ cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c+ cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =+ cpAXA (fdComp fd1 fd21) sf22 fd23+ cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI+ where+ tf dt a = (cpGXAux fd1 f1 sf2', c)+ where+ (sf2', c) = (sfTF' sf2) dt (f1 a)++cpXG :: SF' a b -> (b -> c) -> SF' a c+cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1+ where+ cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c+ cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)+ cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b)+ where+ f' s a = case f s a of+ Nothing -> Nothing+ Just (s', b') -> Just (s', f2 b') + cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne)+ where+ f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne')+ cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) =+ cpAXA fd11 sf12 (fdComp fd22 fd2)+ cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2+ where+ tf dt a = (cpXGAux fd2 f2 sf1', f2 b)+ where+ (sf1', b) = (sfTF' sf1) dt a+cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c+cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2+ where+ cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b + -> SF' b c -> SF' (Event a) c+ cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)+ cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c+ cpEXAux _ f1 f1ne (SFEP _ f2 s cne) =+ sfEP f (s, cne) (vfyNoEv f1ne cne)+ where+ f scne@(s, cne) a =+ case (f1 (Event a)) of+ NoEvent -> (scne, cne, cne)+ Event b ->+ let (s', c, cne') = f2 s b in ((s', cne'), c, cne')+ cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) =+ cpAXA (fdComp fd1 fd21) sf22 fd23+ cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI+ where+ tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c)+ where+ (sf2', c) =+ case ea of+ NoEvent -> (sfTF' sf2) dt f1ne+ _ -> (sfTF' sf2) dt (f1 ea)++cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c+cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1+ where+ cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c+ -> SF' a (Event b) -> SF' a c+ cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)+ cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb)+ where+ f' s a = case f s a of+ Nothing -> Nothing+ Just (s', NoEvent) -> Just (s', f2ne) + Just (s', eb') -> Just (s', f2 eb') + cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) =+ sfEP f s (vfyNoEv ebne f2ne)+ where+ f s a =+ case f1 s a of+ (s', NoEvent, NoEvent) -> (s', f2ne, f2ne)+ (s', eb, NoEvent) -> (s', f2 eb, f2ne)+ _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event."+ cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) =+ cpAXA fd11 sf12 (fdComp fd13 fd2)+ cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2+ where+ tf dt a = (cpXEAux fd2 f2 f2ne sf1',+ case eb of NoEvent -> f2ne; _ -> f2 eb)+ where+ (sf1', eb) = (sfTF' sf1) dt a++firstPrim :: SF a b -> SF (a,c) (b,c)+firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+ where+ tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))+ where+ (sf1, b0) = tf10 a0 ++fpAux :: SF' a b -> SF' (a,c) (b,c)+fpAux (SFArr _ FDI) = sfId+fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c))+fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))+fpAux sf1 = SF' tf+ where+ tf dt ~(a, c) = (fpAux sf1', (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a ++secondPrim :: SF a b -> SF (c,a) (c,b)+secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+ where+ tf0 ~(c0, a0) = (spAux sf1, (c0, b0))+ where+ (sf1, b0) = tf10 a0 ++spAux :: SF' a b -> SF' (c,a) (c,b)+spAux (SFArr _ FDI) = sfId+spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b))+spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))+spAux sf1 = SF' tf+ where+ tf dt ~(c, a) = (spAux sf1', (c, b))+ where+ (sf1', b) = (sfTF' sf1) dt a ++parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d)+parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+ where+ tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0))+ where+ (sf1, b0) = tf10 a0 + (sf2, d0) = tf20 c0 ++ psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d)+ psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2)+ psXX (SFArr _ FDI) sf2 = spAux sf2+ psXX (SFArr _ (FDC b)) sf2 = psCX b sf2+ psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2+ psXX sf1 (SFArr _ FDI) = fpAux sf1+ psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d+ psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2)+ psXX sf1 sf2 = SF' tf+ where+ tf dt ~(a, c) = (psXX sf1' sf2', (b, d))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', d) = (sfTF' sf2) dt c+ + psCX :: b -> SF' c d -> SF' (a,c) (b,d)+ psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2)+ psCX b sf2 = SF' tf+ where+ tf dt ~(_, c) = (psCX b sf2', (b, d))+ where+ (sf2', d) = (sfTF' sf2) dt c+ + psXC :: SF' a b -> d -> SF' (a,c) (b,d)+ psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d))+ psXC sf1 d = SF' tf+ where+ tf dt ~(a, _) = (psXC sf1' d, (b, d))+ where+ (sf1', b) = (sfTF' sf1) dt a++ psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d)+ psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2)+ psAX f1 sf2 = SF' tf+ where+ tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d))+ where+ (sf2', d) = (sfTF' sf2) dt c++ psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d)+ psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2))+ psXA sf1 f2 = SF' tf+ where+ tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))+ where+ (sf1', b) = (sfTF' sf1) dt a++parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)+parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+ where+ tf0 a0 = (pfoXX sf1 sf2, (b0, c0))+ where+ (sf1, b0) = tf10 a0 + (sf2, c0) = tf20 a0 + pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c)+ pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2)+ pfoXX (SFArr _ FDI) sf2 = pfoIX sf2+ pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2+ pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2+ pfoXX sf1 (SFArr _ FDI) = pfoXI sf1+ pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c+ pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2)+ pfoXX sf1 sf2 = SF' tf+ where+ tf dt a = (pfoXX sf1' sf2', (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) dt a+ pfoIX :: SF' a c -> SF' a (a ,c)+ pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2)+ pfoIX sf2 = SF' tf+ where+ tf dt a = (pfoIX sf2', (a, c))+ where+ (sf2', c) = (sfTF' sf2) dt a+ pfoXI :: SF' a b -> SF' a (b ,a)+ pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)+ pfoXI sf1 = SF' tf+ where+ tf dt a = (pfoXI sf1', (b, a))+ where+ (sf1', b) = (sfTF' sf1) dt a+ pfoCX :: b -> SF' a c -> SF' a (b ,c)+ pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2)+ pfoCX b sf2 = SF' tf+ where+ tf dt a = (pfoCX b sf2', (b, c))+ where+ (sf2', c) = (sfTF' sf2) dt a+ pfoXC :: SF' a b -> c -> SF' a (b ,c)+ pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c))+ pfoXC sf1 c = SF' tf+ where+ tf dt a = (pfoXC sf1' c, (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a+ pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c)+ pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2)+ pfoAX f1 sf2 = SF' tf+ where+ tf dt a = (pfoAX f1 sf2', (f1 a, c))+ where+ (sf2', c) = (sfTF' sf2) dt a+ pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c)+ pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2))+ pfoXA sf1 f2 = SF' tf+ where+ tf dt a = (pfoXA sf1' f2, (b, f2 a))+ where+ (sf1', b) = (sfTF' sf1) dt a++instance ArrowLoop SF where+ loop = loopPrim++-- | Loop a signal function.+-- Use the 'loop' function from the 'ArrowLoop' class,+-- rather than this function. +-- The second output is connected to the second input. This permits recursion +-- by making the output of a signal function available to itself. +loopPrim :: SF (a,c) (b,c) -- ^ Signal function, producing output as which + -- it will receive as input.+ -> SF a b -- ^ Looped signal function+loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+ where+ tf0 a0 = (loopAux sf1, b0)+ where+ (sf1, (b0, c0)) = tf10 (a0, c0)++ loopAux :: SF' (a,c) (b,c) -> SF' a b+ loopAux (SFArr _ FDI) = sfId+ loopAux (SFArr _ (FDC (b, _))) = sfConst b+ loopAux (SFArr _ fd1) =+ sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b)+ loopAux sf1 = SF' tf+ where+ tf dt a = (loopAux sf1', b)+ where+ (sf1', (b, c)) = (sfTF' sf1) dt (a, c)++-- | The identity signal function. Use in place of +--+-- > arr id+identity :: SF a a+identity = SF {sfTF = \a -> (sfId, a)}++-- | The constant signal function. Use +--+-- > constant x+--+-- in place of+--+-- > arr $ const x+constant :: b -> SF a b+constant b = SF {sfTF = \_ -> (sfConst b, b)}++-- | The time of this part of the signal graph.+-- Note that if a signal function is switched in,+-- the time is relative to the moment of switching,+-- not the moment that animation started.+localTime :: SF a Time+localTime = constant 1.0 >>> integral++-- | identical to 'localTime'+time :: SF a Time+time = localTime++-- | Override the output value for a signal function+-- at the first instant it is processed+(-->) :: b -> SF a b -> SF a b+b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}++-- | Override the input value for a signal function at the+-- first instant it is processed.+(>--) :: a -> SF a b -> SF a b+a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}++-- | Apply a function to the output at the first instant of a signal function+(-=>) :: (b -> b) -> SF a b -> SF a b+f -=> (SF {sfTF = tf10}) =+ SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}++-- | Apply a function to the input at the first instant of a signal function+(>=-) :: (a -> a) -> SF a b -> SF a b+f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}++-- | Output a value at the first instant, and forever after pass the input+-- value through+initially :: a -- ^ Value at first instant+ -> SF a a+initially = (--> identity)++-- | Signal function:+-- apply a function to an accumulator at each instant. Note that +-- the output value is the value of the accumulator at each instant.+sscan :: (b -> a -> b ) -- ^ Function from accumulator and input to accumulator+ -> b -- ^ Initial accumulator value+ -> SF a b -- ^ Accumulating scan signal function+sscan f b_init = sscanPrim f' b_init b_init+ where+ f' b a = let b' = f b a in Just (b', b')++-- | Never produce an event+never :: SF a (Event b)+never = SF {sfTF = \_ -> (sfNever, NoEvent)}++-- | Produce an event immediately (at the moment of switching in or animation)+-- and never again.+now :: b -- ^ Value for event+ -> SF a (Event b) -- ^ Signal function producing +now b0 = (Event b0 --> never)++-- | Produce an event delayed by some time.+after :: Time -- ^ Time to wait before producing event+ -> b -- ^ Value for event+ -> SF a (Event b) -- ^ Signal function producing event after+ -- specified period+after q x = afterEach [(q,x)]++-- | Produce event every so often (but not immediately)+repeatedly :: Time -- ^ Time between events+ -> b -- ^ Value for all events+ -> SF a (Event b) -- ^ Signal function producing repeated event+repeatedly q x | q > 0 = afterEach qxs+ | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."+ where+ qxs = (q,x):qxs ++-- | Takes a list of time delays and values to a signal function+-- producing events.+afterEach :: [(Time,b)] -- ^ Time since previous event or start and value for+ -- event+ -> SF a (Event b)+afterEach qxs = afterEachCat qxs >>> arr (fmap head)++afterEachCat :: [(Time,b)] -> SF a (Event [b])+afterEachCat [] = never+afterEachCat ((q,x):qxs)+ | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period."+ | otherwise = SF {sfTF = tf0}+ where+ tf0 _ = if q <= 0 then+ emitEventsScheduleNext 0.0 [x] qxs+ else+ (awaitNextEvent (-q) x qxs, NoEvent)++ emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs))+ emitEventsScheduleNext t xs ((q,x):qxs)+ | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period."+ | t' >= 0 = emitEventsScheduleNext t' (x:xs) qxs+ | otherwise = (awaitNextEvent t' x qxs, Event (reverse xs))+ where+ t' = t - q+ awaitNextEvent t x qxs = SF' tf+ where+ tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs+ | otherwise = (awaitNextEvent t' x qxs, NoEvent)+ where+ t' = t + dt++-- | Delay events passing through +delayEvent :: Time -- ^ Time to delay events+ -> SF (Event a) (Event a) -- ^ Signal function delaying events+delayEvent q | q < 0 = usrErr "AFRP" "delayEvent" "Negative delay."+ | q == 0 = identity+ | otherwise = delayEventCat q >>> arr (fmap head)+++delayEventCat :: Time -> SF (Event a) (Event [a])+delayEventCat q | q < 0 = usrErr "AFRP" "delayEventCat" "Negative delay."+ | q == 0 = arr (fmap (:[]))+ | otherwise = SF {sfTF = tf0}+ where+ tf0 e = (case e of+ NoEvent -> noPendingEvent+ Event x -> pendingEvents (-q) [] [] (-q) x,+ NoEvent)++ noPendingEvent = SF' tf+ where+ tf _ e = (case e of+ NoEvent -> noPendingEvent+ Event x -> pendingEvents (-q) [] [] (-q) x,+ NoEvent)+ + pendingEvents t_last rqxs qxs t_next x = SF' tf+ where+ tf dt e+ | t_next' >= 0 =+ emitEventsScheduleNext e t_last' rqxs qxs t_next' [x]+ | otherwise = + (pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent)+ where+ t_next' = t_next + dt+ t_last' = t_last + dt + (t_last'', rqxs') =+ case e of+ NoEvent -> (t_last', rqxs)+ Event x' -> (-q, (t_last'+q,x') : rqxs)++ emitEventsScheduleNext e _ [] [] _ rxs =+ (case e of+ NoEvent -> noPendingEvent+ Event x -> pendingEvents (-q) [] [] (-q) x, + Event (reverse rxs))+ emitEventsScheduleNext e t_last rqxs [] t_next rxs =+ emitEventsScheduleNext e t_last [] (reverse rqxs) t_next rxs+ emitEventsScheduleNext e t_last rqxs ((q', x') : qxs') t_next rxs+ | q' > t_next = (case e of+ NoEvent -> + pendingEvents t_last + rqxs + qxs'+ (t_next - q')+ x'+ Event x'' ->+ pendingEvents (-q) + ((t_last+q, x'') : rqxs)+ qxs'+ (t_next - q')+ x',+ Event (reverse rxs))+ | otherwise = emitEventsScheduleNext e+ t_last+ rqxs + qxs' + (t_next - q')+ (x' : rxs)+-- | Produce an event whenever the input goes from 'False' to 'True'+edge :: SF Bool (Event ())+edge = iEdge True+++iEdge :: Bool -> SF Bool (Event ())+iEdge b = sscanPrim f (if b then 2 else 0) NoEvent+ where+ f :: Int -> Bool -> Maybe (Int, Event ())+ f 0 False = Nothing+ f 0 True = Just (1, Event ())+ f 1 False = Just (0, NoEvent)+ f 1 True = Just (2, NoEvent)+ f 2 False = Just (0, NoEvent)+ f 2 True = Nothing+ f _ _ = undefined++-- | Produce an event carrying a specified value whenever+-- the input goes from 'False' to 'True'+edgeTag :: a -- ^ Value for events+ -> SF Bool (Event a)+edgeTag a = edge >>> arr (`tag` a)++-- | Produce the value carried by the Maybe whenever the input goes+-- from 'Nothing' to 'Just'+edgeJust :: SF (Maybe a) (Event a)+edgeJust = edgeBy isJustEdge (Just undefined)+ where+ isJustEdge Nothing Nothing = Nothing+ isJustEdge Nothing ma@(Just _) = ma+ isJustEdge (Just _) (Just _) = Nothing+ isJustEdge (Just _) Nothing = Nothing++-- | Compare the input at the current and previous instant +-- and produce an event based on the comparison+edgeBy :: (a -> a -> Maybe b) -- ^ Comparison function.+ -- An event will occur at any instant where the + -- value of this function is 'Just'.+ -> a -- ^ initial \"previous\" instant.+ -> SF a (Event b) -- ^ Signal function comparing instants+edgeBy isEdge a_init = SF {sfTF = tf0}+ where+ tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))++ ebAux a_prev = SF' tf+ where+ tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))++-- | Suppress a possible event at the instant of animation or switching in+notYet :: SF (Event a) (Event a)+notYet = initially NoEvent++-- | Suppress all but the first event passing through+once :: SF (Event a) (Event a)+once = takeEvents 1++-- | Only permit a certain number of events+takeEvents :: Int -- ^ Number of events to permit+ -> SF (Event a) (Event a) -- ^ Signal function only permitting+ -- that many events+takeEvents n | n <= 0 = never+takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1)))++-- | Suppress a certain number of initial events+dropEvents :: Int -- ^ Number of events to suppress initially+ -> SF (Event a) (Event a) -- ^ Signal function suppressing+ -- That many events initially+dropEvents n | n <= 0 = identity+dropEvents n = dSwitch (never &&& identity)+ (const (NoEvent >-- dropEvents (n - 1)))++-- | Switch in a new signal function produced from an event, at the instant+-- of that event.+switch :: SF a (b, Event c) -- ^ Signal function which may eventually produce + -- an event.+ -> (c -> SF a b) -- ^ Function producing a signal function from the+ -- event value+ -> SF a b -- ^ Signal function which may switch to+ -- a new signal function.+switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+ where+ tf0 a0 =+ case tf10 a0 of+ (sf1, (b0, NoEvent)) -> (switchAux sf1 k, b0)+ (_, (_, Event c0)) -> sfTF (k c0) a0+++ switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+ switchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b+ switchAux (SFArr _ fd1) k = switchAuxA1 (fdFun fd1) k+ switchAux sf1 k = SF' tf+ where+ tf dt a =+ case (sfTF' sf1) dt a of+ (sf1', (b, NoEvent)) -> (switchAux sf1' k, b)+ (_, (_, Event c)) -> sfTF (k c) a++ switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b+ switchAuxA1 f1 k = sf+ where+ sf = SF' tf+ tf _ a =+ case f1 a of+ (b, NoEvent) -> (sf, b)+ (_, Event c) -> sfTF (k c) a++-- | Decoupled version of 'switch'.+dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+ where+ tf0 a0 =+ let (sf1, (b0, ec0)) = tf10 a0+ in (case ec0 of+ NoEvent -> dSwitchAux sf1 k+ Event c0 -> fst (sfTF (k c0) a0),+ b0)++ dSwitchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+ dSwitchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b+ dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k+ dSwitchAux sf1 k = SF' tf+ where+ tf dt a =+ let (sf1', (b, ec)) = (sfTF' sf1) dt a+ in (case ec of+ NoEvent -> dSwitchAux sf1' k+ Event c -> fst (sfTF (k c) a),++ b)++ dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b+ dSwitchAuxA1 f1 k = sf+ where+ sf = SF' tf + tf _ a =+ let (b, ec) = f1 a+ in (case ec of+ NoEvent -> sf+ Event c -> fst (sfTF (k c) a),++ b)++-- | Switches in new signal functions carried by input events.+rSwitch :: SF a b -- ^ Initial signal function+ -> SF (a, Event (SF a b)) b -- ^ Signal function which may+ -- be changed by an event carrying a new+ -- signal function+rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)++-- | Decoupled version of 'rswitch'+drSwitch :: SF a b -> SF (a, Event (SF a b)) b+drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)++-- This is rather complicated and I'm not sure I understand it.+-- I will document it once I'm sure of how it works. Dr. Nilsson's+-- original comments also expressed skepticism about its correctness+-- and performance. Perhaps it should be removed?+-- | Continuation based switching (undocumented) +kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+ where+ tf0 a0 =+ let (sf1, b0) = tf10 a0+ in+ case tfe0 (a0, b0) of+ (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0)+ (_, Event c0) -> sfTF (k sf10 c0) a0++ kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe+ kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe+ kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1+ kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) + kSwitchAux sf1 sfe = SF' tf + where+ tf dt a =+ let (sf1', b) = (sfTF' sf1) dt a+ in+ case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)+ (_, Event c) -> sfTF (k (freeze sf1 dt) c) a+++ kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b+ kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde)+ kSwitchAuxC1 b sfe = SF' tf + where+ tf dt a =+ case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b)+ (_, Event c) -> sfTF (k (constant b) c) a+ kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1+ kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde)+ kSwitchAuxA1 f1 sfe = SF' tf + where+ tf dt a =+ let b = f1 a+ in+ case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b)+ (_, Event c) -> sfTF (k (arr f1) c) a++ kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe+ kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe+ kSwitchAuxAE sf1 fe = SF' tf + where+ tf dt a =+ let (sf1', b) = (sfTF' sf1) dt a+ in+ case fe (a, b) of+ NoEvent -> (kSwitchAuxAE sf1' fe, b)+ Event c -> sfTF (k (freeze sf1 dt) c) a++ kSwitchAuxC1AE b fe = SF' tf + where+ tf _ a =+ case fe (a, b) of+ NoEvent -> (kSwitchAuxC1AE b fe, b)+ Event c -> sfTF (k (constant b) c) a++ kSwitchAuxA1AE f1 fe = SF' tf + where+ tf _ a =+ let b = f1 a+ in+ case fe (a, b) of+ NoEvent -> (kSwitchAuxA1AE f1 fe, b)+ Event c -> sfTF (k (arr f1) c) a++-- | Decoupled version of 'kswitch'+dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+ where+ tf0 a0 =+ let (sf1, b0) = tf10 a0+ in (case tfe0 (a0, b0) of+ (sfe, NoEvent) -> dkSwitchAux sf1 sfe+ (_, Event c0) -> fst (sfTF (k sf10 c0) a0),+ b0)++ dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1+ dkSwitchAux sf1 sfe = SF' tf + where+ tf dt a =+ let (sf1', b) = (sfTF' sf1) dt a+ in (case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> dkSwitchAux sf1' sfe'+ (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),+ b)++-- | Pair a value with every value in a collection+broadcast :: Functor col => a -> col sf -> col (a, sf)+broadcast a sfs = fmap (\sf -> (a, sf)) sfs++-- | Broadcast the same output to a collection of signal functions,+-- producing a collection of outputs.+parB :: Functor col => col (SF a b) -> SF a (col b)+parB = par broadcast++-- | Take a single input and broadcast it to a collection of functions,+-- until an event is triggered, then switch into another SF producing a+-- collection of outputs+pSwitchB :: Functor col =>+ col (SF a b) -- ^ Initial collection of signal functions+ -> SF (a, col b) (Event c) -- ^ Produces collection update events+ -- based on the input and output of the parallel+ -- SF.+ -> (col (SF a b) -> c -> SF a (col b)) -- ^ Produces the SF to replace+ -- the initial parallel sf+ -- upon event output from the SF+ -- above+ -> SF a (col b)+pSwitchB = pSwitch broadcast+++-- | "pSwitchB", but switched output is visible on the sample frame+-- after the event occurs+dpSwitchB :: Functor col =>+ col (SF a b) + -> SF (a,col b) (Event c) + -> (col (SF a b) -> c -> SF a (col b))+ -> SF a (col b)+dpSwitchB = dpSwitch broadcast++-- | Broadcast intput to a collection of signal functions,+-- and transform that collection with mutator functions carried in events+rpSwitchB :: Functor col =>+ col (SF a b) -- ^ Initial collection of signal functions+ -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) + -- ^ Signal function taking input to broadcast and mutating events and+ -- producing the output of the collection of SFs+rpSwitchB = rpSwitch broadcast+++-- | "rpSwitchB", but switched output is visible on the sample frame after+-- the event occurs+drpSwitchB :: Functor col =>+ col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+drpSwitchB = drpSwitch broadcast+++-- | Route input to a static collection of signal functions+par :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function, pair+ -- input values with signal functions+ -> col (SF b c) -- ^ Collection of signal functions+ -> SF a (col c)+par rf sfs0 = SF {sfTF = tf0}+ where+ tf0 a0 =+ let bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ sfs = fmap fst sfcs0+ cs0 = fmap snd sfcs0+ in+ (parAux rf sfs, cs0)++parAux :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF' b c)+ -> SF' a (col c)+parAux rf sfs = SF' tf + where+ tf dt a = + let bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ sfs' = fmap fst sfcs'+ cs = fmap snd sfcs'+ in+ (parAux rf sfs', cs)++-- | Like "par", but takes an extra SF which looks at the input and output+-- of the parallel switching combinator and switches in a new SF at that point+pSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function, pair+ -- output with SFs in the+ -- collection+ -> col (SF b c) -- ^ Initial collection of SFs+ -> SF (a, col c) (Event d) -- ^ Switching event SF, takes input and output+ -- of parallel SF and produces a switching event+ + -> (col (SF b c) -> d -> SF a (col c)) -- ^ Takes collection of SFs and+ -- value of switching event and+ -- produces SF to switch into+ -> SF a (col c)+pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}+ where+ tf0 a0 =+ let bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ sfs = fmap fst sfcs0+ cs0 = fmap snd sfcs0+ in+ case (sfTF sfe0) (a0, cs0) of+ (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0)+ (_, Event d0) -> sfTF (k sfs0 d0) a0++ pSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs+ pSwitchAux sfs sfe = SF' tf+ where+ tf dt a =+ let bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ sfs' = fmap fst sfcs'+ cs = fmap snd sfcs'+ in+ case (sfTF' sfe) dt (a, cs) of+ (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)+ (_, Event d) -> sfTF (k (freezeCol sfs dt) d) a+++-- | "pSwitch", but the output from the switched-in signal function is visible+-- | in the sample frame after the event.+dpSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF b c)+ -> SF (a, col c) (Event d)+ -> (col (SF b c) -> d -> SF a (col c))+ -> SF a (col c)+dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}+ where+ tf0 a0 =+ let bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ cs0 = fmap snd sfcs0+ in+ (case (sfTF sfe0) (a0, cs0) of+ (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe+ (_, Event d0) -> fst (sfTF (k sfs0 d0) a0),+ cs0)++ dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs+ dpSwitchAux sfs sfe = SF' tf + where+ tf dt a =+ let bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ cs = fmap snd sfcs'+ in+ (case (sfTF' sfe) dt (a, cs) of+ (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')+ sfe'+ (_, Event d) -> fst (sfTF (k (freezeCol sfs dt)+ d)+ a),+ cs)++-- | Dynamic collections of signal functions with a routing function+rpSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function+ -> col (SF b c) -- ^ Initial collection of signal functions+ -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c) + -- ^ Signal function accepting events which mutate the collection+ +rpSwitch rf sfs =+ pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- rpSwitch rf (f sfs')+ + +-- | "rpSwitch", but the output of a switched-in SF is visible in the sample+-- frame after the switch+drpSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+drpSwitch rf sfs =+ dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- drpSwitch rf (f sfs')++-- | For backwards compatibility only.+old_hold :: a -> SF (Event a) a+old_hold a_init = switch (constant a_init &&& identity)+ ((NoEvent >--) . old_hold)++-- | Output the initial value or the value of the last event.+hold :: a -- ^ Initial value+ -> SF (Event a) a -- ^ Signal function which constantly outputs+ -- the value of the last event.+hold a_init = epPrim f () a_init+ where+ f _ a = ((), a, a)++-- | Decoupled version of 'hold'. Begins outputting event value the instant+-- after the event occurence.+dHold :: a -> SF (Event a) a+dHold a0 = hold a0 >>> iPre a0++-- | Hold the value of a 'Maybe' input.+trackAndHold :: a -- ^ Initial value+ -> SF (Maybe a) a -- ^ Output the initial value or+ -- the value of the most recent 'Just'+trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init++-- | For backwards compatability only.+old_accum :: a -> SF (Event (a -> a)) (Event a)+old_accum = accumBy (flip ($))++-- | Apply a function carried by an event to an accumulator, producing+-- an event with the new value of the accumulator.+accum :: a -- ^ Initial accumulator value.+ -> SF (Event (a -> a)) (Event a) -- ^ Signal function from events+ -- carrying functions to events with+ -- the value of those functions + -- applied to the accumulator+accum a_init = epPrim f a_init NoEvent+ where+ f a g = (a', Event a', NoEvent)+ where+ a' = g a++-- | As with 'accum' but output the value of the accumulator.+accumHold :: a -- ^ Initial value of accumulator+ -> SF (Event (a -> a)) a -- ^ Signal function from events+ -- carrying functions to events with+ -- the value of those functions applied+ -- to the accumulator+accumHold a_init = epPrim f a_init a_init+ where+ f a g = (a', a', a')+ where+ a' = g a++-- | Decoupled version of 'accumHold'. Updated accumulator values begin output +-- at the instant /after/ the updating event.+dAccumHold :: a -> SF (Event (a -> a)) a+dAccumHold a_init = accumHold a_init >>> iPre a_init++-- | For backwards compatibility only.+old_accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)+old_accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)+ where+ abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)++-- | Provide a function and initial accumulator to process events, produce+-- each new accumulator vale as an event.+accumBy :: (b -> a -> b) -- ^ Function from accumulator and event value to+ -- accumulator.+ -> b -- ^ Initial accumulator value+ -> SF (Event a) (Event b) -- ^ Signal function processing events+ -- with accumulator function+accumBy g b_init = epPrim f b_init NoEvent+ where+ f b a = (b', Event b', NoEvent)+ where+ b' = g b a++-- | As in 'accumBy' but produce the accumulator value as a continuous signal.+accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+accumHoldBy g b_init = epPrim f b_init b_init+ where+ f b a = (b', b', b')+ where+ b' = g b a++-- | Decoupled version of 'accumHoldBy'. Output signal changes at the instant+-- /after/ an event.+dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init++-- | For backwards compatibility only.+old_accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+old_accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)+ where+ afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)+ afAux (c, Just b) = switch (now b &&& notYet) $ \a -> afAux (f c a)++-- | Filter events with an accumulator.+accumFilter :: (c -> a -> (c, Maybe b)) -- ^ Function from accumulator value and+ -- event value to new accumulator value+ -- and possible event value.+ -> c -- ^ Initial accumulator value.+ -> SF (Event a) (Event b) -- ^ Signal function filtering events.+accumFilter g c_init = epPrim f c_init NoEvent+ where+ f c a = case g c a of+ (c', Nothing) -> (c', NoEvent, NoEvent)+ (c', Just b) -> (c', Event b, NoEvent)++-- | For backwards compatibility only.+old_pre :: SF a a+old_pre = SF {sfTF = tf0}+ where+ tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")++ preAux a_prev = SF' tf+ where+ tf _ a = (preAux a, a_prev)++-- | For backwards compatibility only.+old_iPre :: a -> SF a a+old_iPre = (--> old_pre)++-- | Uninitialized one-instant delay. +pre :: SF a a+pre = sscanPrim f uninit uninit+ where+ f c a = Just (a, c)+ uninit = usrErr "AFRP" "pre" "Uninitialized pre operator."++-- | Iniitialized one-instant delay+iPre :: a -- ^ Value of delayed function at first instant+ -> SF a a -- ^ One-instant delay+iPre = (--> pre)++-- | Delay a (non-event) signal by a specific time offsent. For events please+-- use 'delayEvent'.+delay :: Time -- ^ Time offset to delay signal by+ -> a -- ^ Initial value until time offset is reached+ -> SF a a -- ^ delayed signal function+delay q a_init | q < 0 = usrErr "AFRP" "delay" "Negative delay."+ | q == 0 = identity+ | otherwise = SF {sfTF = tf0}+ where+ tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init)++ delayAux _ [] _ _ = undefined+ delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf+ where+ tf dt a | t_diff' < bdt =+ (delayAux rbuf' buf t_diff' a_prev, a_prev)+ | otherwise = nextSmpl rbuf' buf' (t_diff' - bdt) ba+ where+ t_diff' = t_diff + dt+ rbuf' = (dt, a) : rbuf+ + nextSmpl rbuf [] t_diff a =+ nextSmpl [] (reverse rbuf) t_diff a+ nextSmpl rbuf buf@((bdt, ba) : buf') t_diff a+ | t_diff < bdt = (delayAux rbuf buf t_diff a, a)+ | otherwise = nextSmpl rbuf buf' (t_diff-bdt) ba+ +-- | Integrate a signal with respect to time.+{-# INLINE integral #-}+integral :: VectorSpace a s => SF a a+integral = SF {sfTF = tf0}+ where+ igrl0 = zeroVector++ tf0 a0 = (integralAux igrl0 a0, igrl0)++ integralAux igrl a_prev = SF' tf + where+ tf dt a = (integralAux igrl' a, igrl')+ where+ igrl' = igrl ^+^ realToFrac dt *^ a_prev+++imIntegral :: VectorSpace a s => a -> SF a a+imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)++iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+f `iterFrom` b = SF (iterAux b) where+ iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b)++derivative :: VectorSpace a s => SF a a+derivative = SF {sfTF = tf0}+ where+ tf0 a0 = (derivativeAux a0, zeroVector)++ derivativeAux a_prev = SF' tf+ where+ tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)++loopPre :: c -> SF (a,c) (b,c) -> SF a b+loopPre c_init sf = loop (second (iPre c_init) >>> sf)++loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b+loopIntegral sf = loop (second integral >>> sf)++noise :: (RandomGen g, Random b) => g -> SF a b+noise g0 = streamToSF (randoms g0)++noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b+noiseR range g0 = streamToSF (randomRs range g0)++streamToSF :: [b] -> SF a b+streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!"+streamToSF (b:bs) = SF {sfTF = tf0}+ where+ tf0 _ = (stsfAux bs, b)++ stsfAux [] = intErr "AFRP" "streamToSF" "Empty list!"+ stsfAux (b:bs) = SF' tf+ where+ tf _ _ = (stsfAux bs, b)++occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)+occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}+ | otherwise = usrErr "AFRP" "occasionally"+ "Non-positive average interval."+ where+ tf0 _ = (occAux ((randoms g) :: [Time]), NoEvent)++ occAux [] = undefined+ occAux (r:rs) = SF' tf+ where+ tf dt _ = let p = 1 - exp (-(dt/t_avg))+ in (occAux rs, if r < p then Event x else NoEvent)+reactimate :: IO a+ -> (Bool -> IO (DTime, Maybe a))+ -> (Bool -> b -> IO Bool)+ -> SF a b+ -> IO ()++reactimate init sense actuate (SF {sfTF = tf0}) =+ do+ a0 <- init+ let (sf, b0) = tf0 a0+ loop sf a0 b0+ where+ loop sf a b = do+ done <- actuate True b+ unless (a `seq` b `seq` done) $ do+ (dt, ma') <- sense False+ let a' = maybe a id ma'+ (sf', b') = (sfTF' sf) dt a'+ loop sf' a' b'++data ReactState a b = ReactState {+ rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,+ rsSF :: SF' a b,+ rsA :: a,+ rsB :: b+ } ++type ReactHandle a b = IORef (ReactState a b)++reactInit :: IO a + -> (ReactHandle a b -> Bool -> b -> IO Bool) + -> SF a b+ -> IO (ReactHandle a b)+reactInit init actuate (SF {sfTF = tf0}) = + do a0 <- init+ let (sf,b0) = tf0 a0+ r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,+ rsA = a0, rsB = b0 })+ done <- actuate r True b0+ return r++react :: ReactHandle a b+ -> (DTime,Maybe a)+ -> IO Bool+react rh (dt,ma') = + do rs@(ReactState {rsActuate = actuate,+ rsSF = sf,+ rsA = a,+ rsB = b }) <- readIORef rh+ let a' = maybe a id ma'+ (sf',b') = (sfTF' sf) dt a'+ writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})+ done <- actuate rh True b'+ return done ++embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]+embed sf0 (a0, dtas) = b0 : loop a0 sf dtas+ where+ (sf, b0) = (sfTF sf0) a0++ loop _ _ [] = []+ loop a_prev sf ((dt, ma) : dtas) =+ b : (a `seq` b `seq` (loop a sf' dtas))+ where+ a = maybe a_prev id ma+ (sf', b) = (sfTF' sf) dt a++embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b+embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}+ where+ tts = scanl (\t (dt, _) -> t + dt) 0 dtas+ bbs@(b:_) = embed sf0 (a0, dtas)++ tf0 _ = (esAux 0 (zip tts bbs), b)++ esAux _ [] = intErr "AFRP" "embedSynch" "Empty list!"+ esAux tp_prev tbtbs = SF' tf+ where+ tf dt r | r < 0 = usrErr "AFRP" "embedSynch"+ "Negative ratio."+ | otherwise = let tp = tp_prev + dt * r+ (b, tbtbs') = advance tp tbtbs+ in+ (esAux tp tbtbs', b)+ advance _ tbtbs@[(_, b)] = (b, tbtbs)+ advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))+ | tp < t' = (b, tbtbtbs)+ | t' <= tp = advance tp tbtbs+ advance _ _ = undefined++deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])+deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list."+deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas+++deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])+deltaEncodeBy _ _ [] = usrErr "AFRP" "deltaEncodeBy" "Empty input list."+deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))+ where+ debAux _ [] = []+ debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as+ | otherwise = Just a : debAux a as+ +-- | A step in evaluating a signal function+newtype Step a b = Step { stepSf :: SF' a b }++-- | Initialize a signal function for stepping through+initStep :: a -- ^ Value at time 0+ -> SF a b -- ^ Signal function to animate+ -> (b, Step a b) -- ^ Output at time 0, next step+initStep x sf = + let (sf', x') = sfTF sf x in+ (x', Step sf')+ +-- | Go to the next step of a signal function+step :: DTime -- ^ Time offset+ -> a -- ^ Value at new time+ -> Step a b -- ^ Step to evaluate+ -> (b, Step a b) -- ^ output value at this time, and next step+step dt x (Step sf) = + let (sf', x') = sfTF' sf dt x in+ (x', Step sf')+ +
+ src/FRP/Animas/AffineSpace.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+-- |+-- Module : FRP.Animas.AffineSpace+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Affine space type relation.++module FRP.Animas.AffineSpace where++import FRP.Animas.VectorSpace++infix 6 .+^, .-^, .-.++-- | Typeclass for an Affine space.+-- Minimal complete definition: 'origin', '(.+^)', '(.-.)' +class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where+ -- | The origin value of an affine space+ origin :: p+ -- | Add a vector to a point, obtaining a new point.+ (.+^) :: p -> v -> p+ -- | Subtract a vector from a point, obtaining a new point.+ (.-^) :: p -> v -> p+ -- | Take the difference of two points, returning a vector+ (.-.) :: p -> p -> v+ -- | The scalar distance between two points.+ distance :: p -> p -> a++ p .-^ v = p .+^ (negateVector v)++ distance p1 p2 = norm (p1 .-. p2)
+ src/FRP/Animas/Diagnostics.hs view
@@ -0,0 +1,27 @@+-- |+-- Module : FRP.Animas.Diagnostics+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : portable+--+-- Standardized error-reporting for Animas++module FRP.Animas.Diagnostics where++-- | Error created by improper usage+usrErr :: String -- ^ Module name+ -> String -- ^ Function name+ -> String -- ^ Error message+ -> a +usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)++-- | Error internal to yampa (a bug)+intErr :: String -- ^ Module name+ -> String -- ^ Function name+ -> String -- ^ Error message+ -> a+intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "+ ++ msg)
+ src/FRP/Animas/Event.hs view
@@ -0,0 +1,178 @@+-- |+-- Module : FRP.Animas.Event+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : portable+--+-- Definition of Animas Event type and functions on that type.+--++module FRP.Animas.Event where++import FRP.Animas.Diagnostics+import FRP.Animas.Forceable+++infixl 8 `tag`, `attach`, `gate`+infixl 7 `joinE`+infixl 6 `lMerge`, `rMerge`, `merge`++-- | Event type+data Event a = NoEvent+ | Event a++-- | Not an event+noEvent :: Event a+noEvent = NoEvent++-- | Force the first item of a pair to not be an event+noEventFst :: (Event a, b) -- ^ Input pair+ -> (Event c, b) -- ^ No event pair+noEventFst (_, b) = (NoEvent, b)++-- | Force the second item of a pair to not be an event+noEventSnd :: (a, Event b) -- ^ Input pair+ -> (a, Event c) -- ^ No event pair+noEventSnd (a, _) = (a, NoEvent)++instance Eq a => Eq (Event a) where+ NoEvent == NoEvent = True+ (Event x) == (Event y) = x == y+ _ == _ = False++instance Ord a => Ord (Event a) where+ compare NoEvent NoEvent = EQ+ compare NoEvent (Event _) = LT+ compare (Event _) NoEvent = GT+ compare (Event x) (Event y) = compare x y++instance Functor Event where+ fmap _ NoEvent = NoEvent+ fmap f (Event a) = Event (f a)++instance Forceable a => Forceable (Event a) where+ force ea@NoEvent = ea+ force ea@(Event a) = force a `seq` ea++-- | Internal: Convert a 'Maybe' value to an event+maybeToEvent :: Maybe a -> Event a+maybeToEvent Nothing = NoEvent+maybeToEvent (Just a) = Event a++-- | Apply a function to an event, or return a default value+event :: a -- ^ Default value+ -> (b -> a) -- ^ Function from event value+ -> Event b -- ^ Event+ -> a -- ^ Return value+event a _ NoEvent = a+event _ f (Event b) = f b++-- | Extract a value from an event. This function will produce an error if+-- applied to a NoEvent function+fromEvent :: Event a -> a+fromEvent (Event a) = a+fromEvent NoEvent = usrErr "AFRP" "fromEvent" "Not an event."++-- | Predicate: is a value an event occurence+isEvent :: Event a -> Bool+isEvent NoEvent = False+isEvent (Event _) = True++-- | Predicate: is a value not an event occurence+isNoEvent :: Event a -> Bool+isNoEvent = not . isEvent++-- | Replace a possible event occurence with a new occurence carrying a+-- replacement value+tag :: Event a -- ^ Possible event occurence+ -> b -- ^ Replacement value+ -> Event b+e `tag` b = fmap (const b) e++-- | See above+tagWith :: b -> Event a -> Event b+tagWith = flip tag++-- | Pair a value with an event occurrence's value, creating a new+-- event occurrence+attach :: Event a -> b -> Event (a, b)+e `attach` b = fmap (\a -> (a, b)) e++-- | If both inputs are event occurrences, produce the left event.+lMerge :: Event a -> Event a -> Event a+le `lMerge` re = event re Event le++-- | If both inputs are event occurences, produce the right event.+rMerge :: Event a -> Event a -> Event a+rMerge = flip lMerge++-- | If both inputs are event occurences, produce an error.+merge :: Event a -> Event a -> Event a+merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.")++-- | If both inputs are event occurences, merge them with the supplied+-- function+mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a+mergeBy _ NoEvent NoEvent = NoEvent+mergeBy _ le@(Event _) NoEvent = le+mergeBy _ NoEvent re@(Event _) = re+mergeBy resolve (Event l) (Event r) = Event (resolve l r)++-- | Apply functions to an event occurences from two sources+mapMerge :: (a -> c) -- ^ Function for occurences in first source+ -> (b -> c) -- ^ Function for occurences in second source+ -> (a -> b -> c) -- ^ Function for occurences in both sources+ -> Event a -- ^ First source+ -> Event b -- ^ Second source+ -> Event c -- ^ Merged/mapped events+mapMerge _ _ _ NoEvent NoEvent = NoEvent+mapMerge lf _ _ (Event l) NoEvent = Event (lf l)+mapMerge _ rf _ NoEvent (Event r) = Event (rf r)+mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r)++-- | Produce the event occurence closest to the head of the list,+-- if one exists.+mergeEvents :: [Event a] -> Event a+mergeEvents = foldr lMerge NoEvent++-- | From a list of event sources+-- produce an event occurence with a list of values of occurrences+catEvents :: [Event a] -> Event [a]+catEvents eas = case [ a | Event a <- eas ] of+ [] -> NoEvent+ as -> Event as++-- | If there is an occurence from both sources, produce an occurence+-- with both values.+joinE :: Event a -> Event b -> Event (a,b)+joinE NoEvent _ = NoEvent+joinE _ NoEvent = NoEvent+joinE (Event l) (Event r) = Event (l,r)++-- | Create a pair of event occurences from a single event occurence+-- with a pair of values+splitE :: Event (a,b) -> (Event a, Event b)+splitE NoEvent = (NoEvent, NoEvent)+splitE (Event (a,b)) = (Event a, Event b)++-- | Apply a predicate to event occurences and forward them only if+-- it matches+filterE :: (a -> Bool) -> Event a -> Event a+filterE p e@(Event a) = if (p a) then e else NoEvent+filterE _ NoEvent = NoEvent++-- | Apply a 'Maybe' function to event occurences,+-- producing events only for 'Just' values.+mapFilterE :: (a -> Maybe b) -> Event a -> Event b+mapFilterE _ NoEvent = NoEvent+mapFilterE f (Event a) = case f a of+ Nothing -> NoEvent+ Just b -> Event b++-- | Only pass through events if some external condition is true.+gate :: Event a -> Bool -> Event a+_ `gate` False = NoEvent+e `gate` True = e
+ src/FRP/Animas/Forceable.hs view
@@ -0,0 +1,76 @@+-- |+-- Module : FRP.Animas.Forceable+-- Copyright : (c) Zhanyong Wan, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : portable+--+-- Hyperstrict evaluation.+++module FRP.Animas.Forceable where++-- | Typeclass for values whose entire structure may be made strict+class Forceable a where+ -- | Forces the value of an expression and returns it+ force :: a -> a+++instance Forceable Int where+ force = id+++instance Forceable Integer where+ force = id+++instance Forceable Double where+ force = id+++instance Forceable Float where+ force = id+++instance Forceable Bool where+ force = id+++instance Forceable () where+ force = id+++instance Forceable Char where+ force = id+++instance (Forceable a, Forceable b) => Forceable (a, b) where+ force p@(a, b) = force a `seq` force b `seq` p+++instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where+ force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p+++instance (Forceable a, Forceable b, Forceable c, Forceable d) =>+ Forceable (a, b, c, d) where+ force p@(a, b, c, d) =+ force a `seq` force b `seq` force c `seq` force d `seq` p+++instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) =>+ Forceable (a, b, c, d, e) where+ force p@(a, b, c, d, e) =+ force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p+++instance (Forceable a) => Forceable [a] where+ force nil@[] = nil+ force xs@(x:xs') = force x `seq` force xs' `seq` xs+++instance (Forceable a) => Forceable (Maybe a) where+ force mx@Nothing = mx+ force mx@(Just x) = force x `seq` mx
+ src/FRP/Animas/Geometry.hs view
@@ -0,0 +1,29 @@+-- |+-- Module : FRP.Animas.Geometry+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Basic geometrical abstractions.+++module FRP.Animas.Geometry (+ module FRP.Animas.VectorSpace,+ module FRP.Animas.AffineSpace,+ module FRP.Animas.Vector2,+ module FRP.Animas.Vector3,+ module FRP.Animas.Point2,+ module FRP.Animas.Point3+) where++import FRP.Animas.VectorSpace+import FRP.Animas.AffineSpace+import FRP.Animas.Vector2+import FRP.Animas.Vector3+import FRP.Animas.Point2+import FRP.Animas.Point3++
+ src/FRP/Animas/Internals.hs view
@@ -0,0 +1,30 @@+-- |+-- Module : FRP.Animas.Internals+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : portable+--+-- An interface giving access to some of the internal+-- details of the Animas implementation.+--+-- This interface is indended to be used when the need arises to break+-- abstraction barriers, e.g. for interfacing Animas to the real world, for+-- debugging purposes, or the like. Be aware that the internal details+-- may change. Relying on this interface means that your code is not+-- insulated against such changes.++module FRP.Animas.Internals (+ Event(..) +) where++import FRP.Animas.Event++instance Show a => Show (Event a) where+ showsPrec d NoEvent = showString "NoEvent"+ showsPrec d (Event a) = showParen (d >= 10)+ (showString "Event " . showsPrec 10 a)++
+ src/FRP/Animas/MergeableRecord.hs view
@@ -0,0 +1,87 @@+-- |+-- Module : FRP.Animas.MergeableRecord+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : portable+--+-- Framework for record merging.+--+-- Idea:+--+-- MergeableRecord is intended to be a super class for classes providing+-- update operations on records. The ADT induced by such a set of operations+-- can be considered a "mergeable record", which can be merged into larger+-- mergeable records essentially by function composition. Finalization turns+-- a mergeable record into a record.+--+-- Typical use:+--+-- Given+--+-- > data Foo = Foo {l1 :: T1, l2 :: T2}+--+-- one define a mergeable record type (MR Foo) by the following instance:+--+-- @+-- instance MergeableRecord Foo where+-- mrDefault = Foo {l1 = v1_dflt, l2 = v2_dflt}+-- @+--+-- Typically, one would also provide definitions for setting the fields,+-- possibly (but not necessarily) overloaded:+--+-- @+-- instance HasL1 Foo where+-- setL1 v = mrMake (\foo -> foo {l1 = v})+-- @+--+-- Now Foo records can be created as follows:+--+-- @+-- let foo1 = setL1 v1+-- ...+-- let foo2 = setL2 v2 ~+~ foo1+-- ...+-- let foo<N> = setL1 vN ~+~ foo<N-1>+-- let fooFinal = mrFinalize foo<N>+-- @++module FRP.Animas.MergeableRecord (+ MergeableRecord(..),+ MR, + mrMake,+ (~+~),+ mrMerge,+ mrFinalize+) where++-- | Typeclass for mergeable records+class MergeableRecord a where+ -- | The default value of a record type+ mrDefault :: a+++-- | Type constructor for mergeable records.+newtype MergeableRecord a => MR a = MR (a -> a)+++-- | Construction of a mergeable record.+mrMake :: MergeableRecord a => (a -> a) -> MR a+mrMake f = (MR f)+++-- | Merge two mergeable records. Left \"overrides\" in case of conflict.+(~+~) :: MergeableRecord a => MR a -> MR a -> MR a+(MR f1) ~+~ (MR f2) = MR (f1 . f2)++-- | Equivalent to '(~+~)' above.+mrMerge :: MergeableRecord a => MR a -> MR a -> MR a+mrMerge = (~+~)+++-- | Finalization: turn a mergeable record into a record.+mrFinalize :: MergeableRecord a => MR a -> a+mrFinalize (MR f) = f mrDefault
+ src/FRP/Animas/Miscellany.hs view
@@ -0,0 +1,124 @@+-- |+-- Module : FRP.Animas.Miscellany+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : portable+--+-- Collection of entities that really should be part+-- of the Haskell 98 prelude or simply have no better+-- home.+--+-- !!! Reverse function composition should go.+-- !!! Better to use '<<<' and '>>>' for, respectively,+-- !!! function composition and reverse function composition.++module FRP.Animas.Miscellany (+ ( # ),+ dup,+ swap,+ mapFst,+ mapSnd,+ sel3_1, sel3_2, sel3_3,+ sel4_1, sel4_2, sel4_3, sel4_4,+ sel5_1, sel5_2, sel5_3, sel5_4, sel5_5,+ fDiv,+ fMod,+ fDivMod+) where++infixl 9 #+infixl 7 `fDiv`, `fMod`++-- | Reverse composition+( # ) :: (a -> b) -> (b -> c) -> (a -> c)+(#) = flip (.)++-- | Duplicate a value into a pair+dup :: a -> (a,a)+dup x = (x,x)++-- | Swap the values in a pair+swap :: (a,b) -> (b,a)+swap ~(x,y) = (y,x)++-- | Apply a function to the first value in each pair in a list of pairs.+mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]+mapFst _ [] = []+mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys++-- | Above, but apply the function to the second value+mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]+mapSnd _ [] = []+mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys++-- | First value of a triple+sel3_1 :: (a, b, c) -> a+sel3_1 (x,_,_) = x++-- | Second value of a triple+sel3_2 :: (a, b, c) -> b+sel3_2 (_,x,_) = x++-- | Third value of a triple+sel3_3 :: (a, b, c) -> c+sel3_3 (_,_,x) = x++-- | First value of a quadruple+sel4_1 :: (a, b, c, d) -> a+sel4_1 (x,_,_,_) = x++-- | Second value of a quadruple+sel4_2 :: (a, b, c, d) -> b+sel4_2 (_,x,_,_) = x++-- | Third value of a quadruple+sel4_3 :: (a, b, c, d) -> c+sel4_3 (_,_,x,_) = x++-- | Fourth value of a quadruple+sel4_4 :: (a, b, c, d) -> d+sel4_4 (_,_,_,x) = x++-- | First value of a quintuple+sel5_1 :: (a, b, c, d, e) -> a+sel5_1 (x,_,_,_,_) = x++-- | Second value of a quintuple+sel5_2 :: (a, b, c, d, e) -> b+sel5_2 (_,x,_,_,_) = x++-- | Third value of a quintuple+sel5_3 :: (a, b, c, d, e) -> c+sel5_3 (_,_,x,_,_) = x++-- | Fourth value of a quintuple+sel5_4 :: (a, b, c, d, e) -> d+sel5_4 (_,_,_,x,_) = x++-- | Fifth value of a quintuple+sel5_5 :: (a, b, c, d, e) -> e+sel5_5 (_,_,_,_,x) = x++-- | Whole integer quotient+fDiv :: (RealFrac a) => a -- ^ Dividend+ -> a -- ^ Divisor+ -> Integer -- ^ Integer quotient+fDiv x y = fst $ fDivMod x y++-- | Remainder after whole integer quotient+fMod :: (RealFrac a) => a -- ^ Dividend+ -> a -- ^ Divisor+ -> a -- ^ Remainder+fMod x y = snd $ fDivMod x y++-- | Whole integer quotient and remainder +fDivMod :: (RealFrac a) => a -- ^ Dividend+ -> a -- ^ Divisor+ -> (Integer, a) -- ^ Integer quotient and remainder+fDivMod x y = (q, r)+ where+ q = (floor (x/y))+ r = x - fromIntegral q * y
+ src/FRP/Animas/Point2.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-- |+-- Module : FRP.Animas.Point2+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- 2D point abstraction (R^2).+--+-- ToDo: Deriving Show, or provide dedicated show instance?+--++module FRP.Animas.Point2 (+ Point2(..),+ point2X,+ point2Y+) where++import FRP.Animas.VectorSpace ()+import FRP.Animas.AffineSpace+import FRP.Animas.Vector2+import FRP.Animas.Forceable++-- | Two-dimensional real-valued point+data RealFloat a => Point2 a = Point2 !a !a deriving (Eq, Show)++-- | X coordinate+point2X :: RealFloat a => Point2 a -> a+point2X (Point2 x _) = x++-- | Y coordinate+point2Y :: RealFloat a => Point2 a -> a+point2Y (Point2 _ y) = y+++instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where+ origin = Point2 0 0++ (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v)++ (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v)++ (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2)++instance RealFloat a => Forceable (Point2 a) where+ force = id
+ src/FRP/Animas/Point3.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-- |+-- Module : FRP.Animas.Point3+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- 3D point abstraction (R^3).+--++module FRP.Animas.Point3 (+ Point3(..),+ point3X,+ point3Y,+ point3Z+) where++import FRP.Animas.VectorSpace ()+import FRP.Animas.AffineSpace+import FRP.Animas.Vector3+import FRP.Animas.Forceable++-- | 3-dimensional, real-valued point+data RealFloat a => Point3 a = Point3 !a !a !a deriving Eq++-- | X coordinate+point3X :: RealFloat a => Point3 a -> a+point3X (Point3 x _ _) = x++-- | Y coordinate+point3Y :: RealFloat a => Point3 a -> a+point3Y (Point3 _ y _) = y++-- | Z coordinate+point3Z :: RealFloat a => Point3 a -> a+point3Z (Point3 _ _ z) = z++instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where+ origin = Point3 0 0 0++ (Point3 x y z) .+^ v =+ Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v)++ (Point3 x y z) .-^ v =+ Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v)++ (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) =+ vector3 (x1 - x2) (y1 - y2) (z1 - z2)++instance RealFloat a => Forceable (Point3 a) where+ force = id
+ src/FRP/Animas/Task.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE Rank2Types #-}+-- |+-- Module : FRP.Animas.Task+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Task abstraction on top of signal transformers.+--++module FRP.Animas.Task (+ Task,+ mkTask, -- :: SF a (b, Event c) -> Task a b c+ runTask, -- :: Task a b c -> SF a (Either b c) -- Might change.+ runTask_, -- :: Task a b c -> SF a b+ taskToSF, -- :: Task a b c -> SF a (b, Event c) -- Might change.+ constT, -- :: b -> Task a b c+ sleepT, -- :: Time -> b -> Task a b ()+ snapT, -- :: Task a b a+ timeOut, -- :: Task a b c -> Time -> Task a b (Maybe c)+ abortWhen, -- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)+ repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a+ for, -- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()+ forAll, -- :: Monad m => [a] -> (a -> m b) -> m ()+ forEver -- :: Monad m => m a -> m b+) where++import FRP.Animas+import FRP.Animas.Utilities (snap)+import FRP.Animas.Diagnostics++infixl 0 `timeOut`, `abortWhen`, `repeatUntil`+++------------------------------------------------------------------------------+-- The Task type+------------------------------------------------------------------------------++-- CPS-based representation allowing a termination to be detected.+-- (Note the rank 2 polymorphic type!)+-- The representation can be changed if necessary, but the Monad laws+-- follow trivially in this case.+newtype Task a b c =+ Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))+++unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d))+unTask (Task f) = f+++mkTask :: SF a (b, Event c) -> Task a b c+mkTask st = Task (switch (st >>> first (arr Left)))+++-- "Runs" a task (unusually bad name?). The output from the resulting+-- signal transformer is tagged with Left while the underlying task is+-- running. Once the task has terminated, the output goes constant with+-- the value Right x, where x is the value of the terminating event.+runTask :: Task a b c -> SF a (Either b c)+runTask tk = (unTask tk) (\c -> constant (Right c))+++-- Runs a task. The output becomes undefined once the underlying task has+-- terminated. Convenient e.g. for tasks which are known not to terminate.+runTask_ :: Task a b c -> SF a b+runTask_ tk = runTask tk+ >>> arr (either id (usrErr "AFRPTask" "runTask_"+ "Task terminated!"))+++-- Seems as if the following is convenient after all. Suitable name???+-- Maybe that implies a representation change for Tasks?+-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)+taskToSF :: Task a b c -> SF a (b, Event c)+taskToSF tk = runTask tk+ >>> (arr (either id ((usrErr "AFRPTask" "runTask_"+ "Task terminated!")))+ &&& edgeBy isEdge (Left undefined))+ where+ isEdge (Left _) (Left _) = Nothing+ isEdge (Left _) (Right c) = Just c+ isEdge (Right _) (Right _) = Nothing+ isEdge (Right _) (Left _) = Nothing+++------------------------------------------------------------------------------+-- Monad instance+------------------------------------------------------------------------------++instance Monad (Task a b) where+ tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))+ return x = Task (\k -> k x)++{-+Let's check the monad laws:++ t >>= return+ = \k -> t (\c -> return c k)+ = \k -> t (\c -> (\x -> \k -> k x) c k)+ = \k -> t (\c -> (\x -> \k' -> k' x) c k)+ = \k -> t (\c -> k c)+ = \k -> t k+ = t+ QED++ return x >>= f+ = \k -> (return x) (\c -> f c k)+ = \k -> (\k -> k x) (\c -> f c k)+ = \k -> (\k' -> k' x) (\c -> f c k)+ = \k -> (\c -> f c k) x+ = \k -> f x k+ = f x+ QED++ (t >>= f) >>= g+ = \k -> (t >>= f) (\c -> g c k)+ = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k)+ = \k -> t (\c' -> f c' (\c -> g c k))+ = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k)+ = \k -> t (\c' -> (\x -> f x >>= g) c' k)+ = t >>= (\x -> f x >>= g)+ QED++No surprises (obviously, since this is essentially just the CPS monad).+-}+++------------------------------------------------------------------------------+-- Basic tasks+------------------------------------------------------------------------------++-- Non-terminating task with constant output b.+constT :: b -> Task a b c+constT b = mkTask (constant b &&& never)+++-- "Sleeps" for t seconds with constant output b.+sleepT :: Time -> b -> Task a b ()+sleepT t b = mkTask (constant b &&& after t ())+++-- Takes a "snapshot" of the input and terminates immediately with the input+-- value as the result. No time passes; law:+--+-- snapT >> snapT = snapT+--+snapT :: Task a b a+snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)+++------------------------------------------------------------------------------+-- Basic tasks combinators+------------------------------------------------------------------------------++-- Impose a time out on a task.+timeOut :: Task a b c -> Time -> Task a b (Maybe c)+tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)+ where+ aux ((b, ec), et) = (b, (lMerge (fmap Just ec)+ (fmap (const Nothing) et)))+++-- Run a "guarding" event source (SF a (Event b)) in parallel with a+-- (possibly non-terminating) task. The task will be aborted at the+-- first occurrence of the event source (if it has not terminated itself+-- before that). Useful for separating sequencing and termination concerns.+-- E.g. we can do something "useful", but in parallel watch for a (exceptional)+-- condition which should terminate that activity, whithout having to check+-- for that condition explicitly during each and every phase of the activity.+-- Example: tsk `abortWhen` lbp+abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)+tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)+ where+ aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))+++------------------------------------------------------------------------------+-- Loops+------------------------------------------------------------------------------++-- These are general monadic combinators. Maybe they don't really belong here.++-- Repeat m until result satisfies the predicate p+repeatUntil :: Monad m => m a -> (a -> Bool) -> m a+m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x+++-- C-style for-loop.+-- Example: for 0 (+1) (>=10) ...+for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()+for i f p m = if p i then m >> for (f i) f p m else return ()+++-- Perform the monadic operation for each element in the list.+forAll :: Monad m => [a] -> (a -> m b) -> m ()+forAll = flip mapM_+++-- Repeat m for ever.+forEver :: Monad m => m a -> m b+forEver m = m >> forEver m+++-- Alternatives/other potentially useful signatures:+-- until :: a -> (a -> M a) -> (a -> Bool) -> M a+-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b+-- while??? It could be:+-- while :: a -> (a -> Bool) -> (a -> M a) -> M a+++------------------------------------------------------------------------------+-- Monad transformers?+------------------------------------------------------------------------------++-- What about monad transformers if we want to compose this monad with+-- other capabilities???
+ src/FRP/Animas/Utilities.hs view
@@ -0,0 +1,242 @@+-- |+-- Module : FRP.Animas.Utilities+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : portable+--+-- Derived utility definitions.+--+-- ToDo:+--+-- * Possibly add+-- impulse :: VectorSpace a k => a -> Event a+-- But to do that, we need access to Event, which we currently do not have.+--+-- * The general arrow utilities should be moved to a module+-- FRP.Animas.Utilities.+--+-- * I'm not sure structuring the Animas \"core\" according to what is+-- core functionality and what's not is all that useful. There are+-- many cases where we want to implement combinators that fairly+-- easily could be implemented in terms of others as primitives simply+-- because we expect that that implementation is going to be much more+-- efficient, and that the combinators are used sufficiently often to+-- warrant doing this. E.g. 'switch' should be a primitive, even though+-- it could be derived from 'pSwitch'.+--+-- * Reconsider 'recur'. If an event source has an immediate occurrence,+-- we'll get into a loop. For example: recur now. Maybe suppress+-- initial occurrences? Initial occurrences are rather pointless in this+-- case anyway.++module FRP.Animas.Utilities (+ arr2,+ arr3,+ arr4,+ arr5,+ lift0,+ lift1,+ lift2,+ lift3,+ lift4,+ lift5,+ snap,+ snapAfter,+ sample,+ recur,+ andThen,+ sampleWindow,+ parZ,+ pSwitchZ,+ dpSwitchZ,+ rpSwitchZ,+ drpSwitchZ,+ provided,+ old_dHold,+ dTrackAndHold,+ old_accumHold,+ old_dAccumHold,+ old_accumHoldBy,+ old_dAccumHoldBy,+ count,+ fby,+ impulseIntegral,+ old_impulseIntegral+) where++import FRP.Animas.Diagnostics+import FRP.Animas+++infixr 5 `andThen`+infixr 0 `fby`++arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d+arr2 = arr . uncurry+++arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e+arr3 = arr . \h (b, c, d) -> h b c d+++arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f+arr4 = arr . \h (b, c, d, e) -> h b c d e+++arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g+arr5 = arr . \h (b, c, d, e, f) -> h b c d e f+++lift0 :: Arrow a => c -> a b c+lift0 c = arr (const c)+++lift1 :: Arrow a => (c -> d) -> (a b c -> a b d)+lift1 f = \a -> a >>> arr f+++lift2 :: Arrow a => (c -> d -> e) -> (a b c -> a b d -> a b e)+lift2 f = \a1 a2 -> a1 &&& a2 >>> arr2 f+++lift3 :: Arrow a => (c -> d -> e -> f) -> (a b c -> a b d -> a b e -> a b f)+lift3 f = \a1 a2 a3 -> (lift2 f) a1 a2 &&& a3 >>> arr2 ($)+++lift4 :: Arrow a => (c->d->e->f->g) -> (a b c->a b d->a b e->a b f->a b g)+lift4 f = \a1 a2 a3 a4 -> (lift3 f) a1 a2 a3 &&& a4 >>> arr2 ($)+++lift5 :: Arrow a =>+ (c->d->e->f->g->h) -> (a b c->a b d->a b e->a b f->a b g->a b h)+lift5 f = \a1 a2 a3 a4 a5 ->(lift4 f) a1 a2 a3 a4 &&& a5 >>> arr2 ($)+++-- | Produce an event with the input value at time 0+snap :: SF a (Event a)+snap = switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now+++-- | Produce an event with the input value at or as soon after the specified+-- time delay.+snapAfter :: Time -> SF a (Event a)+snapAfter t_ev = switch (never+ &&& (identity+ &&& after t_ev () >>^ \(a, e) -> e `tag` a))+ now+++-- | Sample a signal at regular intervals.+sample :: Time -> SF a (Event a)+sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a+++-- | Restart an event source directly after its first event occurence+recur :: SF a (Event b) -> SF a (Event b)+recur sfe = switch (never &&& sfe) $ \b -> Event b --> (recur (NoEvent-->sfe))++-- | Start a second event source as soon as the first produces an event.+-- (When used infix, andThen is right associative, so, for instance,+-- x `andThen` y `andThen` z will produce the first event of x, then of y,+-- then of z.+andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b)+sfe1 `andThen` sfe2 = dSwitch (sfe1 >>^ dup) (const sfe2)+++sampleWindow :: Int -> Time -> SF a (Event [a])+sampleWindow wl q =+ identity &&& afterEachCat (repeat (q, ()))+ >>> arr (\(a, e) -> fmap (map (const a)) e)+ >>> accumBy updateWindow []+ where+ updateWindow w as = drop (max (length w' - wl) 0) w'+ where+ w' = w ++ as++safeZip :: String -> [a] -> [b] -> [(a,b)]+safeZip fn as bs = safeZip' as bs+ where+ safeZip' _ [] = []+ safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs++ head' [] = err+ head' (a:_) = a++ tail' [] = err+ tail' (_:as) = as++ err = usrErr "AFRPUtilities" fn "Input list too short."+++parZ :: [SF a b] -> SF [a] [b]+parZ = par (safeZip "parZ")+++pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b])+ -> SF [a] [b]+pSwitchZ = pSwitch (safeZip "pSwitchZ")+++dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b])+ -> SF [a] [b]+dpSwitchZ = dpSwitch (safeZip "dpSwitchZ")+++rpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+rpSwitchZ = rpSwitch (safeZip "rpSwitchZ")+++drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+drpSwitchZ = drpSwitch (safeZip "drpSwitchZ")++-- | Run one SF if a predicate is true, otherwise run another SF.+provided :: (a -> Bool) -- ^ Predicate on input values+ -> SF a b -- ^ SF if predicate is true+ -> SF a b -- ^ SF if predicate is false+ -> SF a b -- ^ SF total+provided p sft sff =+ switch (constant undefined &&& snap) $ \a0 ->+ if p a0 then stt else stf+ where+ stt = switch (sft &&& (not . p ^>> edge)) (const stf)+ stf = switch (sff &&& (p ^>> edge)) (const stt)++old_dHold :: a -> SF (Event a) a+old_dHold a0 = dSwitch (constant a0 &&& identity) dHold'+ where+ dHold' a = dSwitch (constant a &&& notYet) dHold'+++-- | Decoupled track and hold: on occurence of a 'Just' input,+-- the /next/ output is the value of the 'Just' value.+dTrackAndHold :: a -> SF (Maybe a) a+dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init++old_accumHold :: a -> SF (Event (a -> a)) a+old_accumHold a_init = old_accum a_init >>> old_hold a_init++old_dAccumHold :: a -> SF (Event (a -> a)) a+old_dAccumHold a_init = old_accum a_init >>> old_dHold a_init++old_accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+old_accumHoldBy f b_init = old_accumBy f b_init >>> old_hold b_init++old_dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+old_dAccumHoldBy f b_init = old_accumBy f b_init >>> old_dHold b_init++-- | Count the number of event occurences, producing a new event+-- occurence with each updated count.+count :: Integral b => SF (Event a) (Event b)+count = accumBy (\n _ -> n + 1) 0++fby :: b -> SF a b -> SF a b+b0 `fby` sf = b0 --> sf >>> pre++impulseIntegral :: VectorSpace a k => SF (a, Event a) a+impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)++old_impulseIntegral :: VectorSpace a k => SF (a, Event a) a+old_impulseIntegral = (integral *** old_accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)
+ src/FRP/Animas/Vector2.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-- |+-- Module : FRP.Animas.Vector2+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- 2D vector abstraction (R^2).+--+-- ToDo: Deriving Show, or provide dedicated show instance?++module FRP.Animas.Vector2 (+ Vector2,+ vector2,+ vector2X,+ vector2Y,+ vector2XY,+ vector2Polar,+ vector2Rho,+ vector2Theta,+ vector2RhoTheta,+ vector2Rotate+) where++import FRP.Animas.VectorSpace+import FRP.Animas.Forceable++-- | 2-dimensional vector type+data RealFloat a => Vector2 a = Vector2 !a !a deriving (Eq,Show)++-- | Create a 2D vector+vector2 :: RealFloat a + => a -- ^ X magnitude+ -> a -- ^ Y magnitude+ -> Vector2 a -- ^ Vector+vector2 x y = Vector2 x y++-- ^ Obtain the X-magnitude of a vector+vector2X :: RealFloat a => Vector2 a -> a+vector2X (Vector2 x _) = x++-- ^ Obtain the Y-magnitude of a vector+vector2Y :: RealFloat a => Vector2 a -> a+vector2Y (Vector2 _ y) = y++-- ^ Obtain the X and Y magnitudes of a vector as an ordered pair+vector2XY :: RealFloat a => + Vector2 a + -> (a, a) -- ^ (X, Y)+vector2XY (Vector2 x y) = (x, y)++-- ^ Create a vector from polar coordinates (magnitude/rho, direction/theta (radians))+vector2Polar :: RealFloat a => + a -- ^ Rho+ -> a -- ^ Theta+ -> Vector2 a -- ^ Vector+vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta) ++-- ^ Obtain the magnitude of a vector+vector2Rho :: RealFloat a => Vector2 a -> a+vector2Rho (Vector2 x y) = sqrt (x * x + y * y)++-- ^ Obtain the direction of a vector+vector2Theta :: RealFloat a => Vector2 a -> a+vector2Theta (Vector2 x y) = atan2 y x++-- ^ Obtain the magnitude and direction of a vector as an ordered pair+vector2RhoTheta :: RealFloat a => + Vector2 a + -> (a, a) -- ^ (Rho, Theta)+vector2RhoTheta v = (vector2Rho v, vector2Theta v)++instance RealFloat a => VectorSpace (Vector2 a) a where+ zeroVector = Vector2 0 0++ a *^ (Vector2 x y) = Vector2 (a * x) (a * y)++ (Vector2 x y) ^/ a = Vector2 (x / a) (y / a)++ negateVector (Vector2 x y) = (Vector2 (-x) (-y))++ (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2)++ (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2)++ (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2+++-- ^ Rotate a vector by some angle theta+vector2Rotate :: RealFloat a => a -- ^ Theta (radians)+ -> Vector2 a -- ^ Initial vector+ -> Vector2 a -- ^ Rotated vector+vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta')++instance RealFloat a => Forceable (Vector2 a) where+ force = id
+ src/FRP/Animas/Vector3.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- |+-- Module : FRP.Animas.Vector3+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- 3D vector abstraction (R^3).+--+-- ToDo: Deriving Show, or provide dedicated show instance?++module FRP.Animas.Vector3 (++ Vector3,+ vector3,+ vector3X,+ vector3Y,+ vector3Z,+ vector3XYZ,+ vector3Spherical,+ vector3Rho,+ vector3Theta,+ vector3Phi,+ vector3RhoThetaPhi,+ vector3Rotate+) where++import FRP.Animas.VectorSpace+import FRP.Animas.Forceable++-- | 3-dimensional vector+data RealFloat a => Vector3 a = Vector3 !a !a !a deriving (Eq, Show)++-- | Construct a 3 dimensional vector+vector3 :: RealFloat a => a -- ^ X magnitude+ -> a -- ^ Y magnitude+ -> a -- ^ Z magnitude+ -> Vector3 a -- ^ Vector+vector3 x y z = Vector3 x y z++-- | X magnitude of the vector+vector3X :: RealFloat a => Vector3 a -> a+vector3X (Vector3 x _ _) = x++-- | Y magnitude of the vector+vector3Y :: RealFloat a => Vector3 a -> a+vector3Y (Vector3 _ y _) = y++-- | Z magnitude of the vector+vector3Z :: RealFloat a => Vector3 a -> a+vector3Z (Vector3 _ _ z) = z++-- | Ordered pair of magnitudes of the vector+vector3XYZ :: RealFloat a => Vector3 a + -> (a, a, a) -- ^ (X, Y, Z)+vector3XYZ (Vector3 x y z) = (x, y, z)++-- | Spherical coordinates to vector+vector3Spherical :: RealFloat a => a -- ^ magnitude+ -> a -- ^ Theta-direction+ -> a -- ^ Phi-direction+ -> Vector3 a+vector3Spherical rho theta phi =+ Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi)+ where+ rhoSinPhi = rho * sin phi++-- | Magnitude of a vector+vector3Rho :: RealFloat a => Vector3 a -> a+vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z)++-- | Theta-direction of a vector+vector3Theta :: RealFloat a => Vector3 a -> a+vector3Theta (Vector3 x y _) = atan2 y x++-- | Phi-direction of a vector+vector3Phi :: RealFloat a => Vector3 a -> a+vector3Phi v@(Vector3 _ _ z) = acos (z / vector3Rho v)++-- | Magnitude and directions of a vector as an ordered triple+vector3RhoThetaPhi :: RealFloat a => Vector3 a + -> (a, a, a) -- ^ (Rho, Theta, Phi)+vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi)+ where+ rho = sqrt (x * x + y * y + z * z)+ theta = atan2 y x+ phi = acos (z / rho)++instance RealFloat a => VectorSpace (Vector3 a) a where+ zeroVector = Vector3 0 0 0++ a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z)++ (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a)++ negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z))++ (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2)++ (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2)++ (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2+++-- | Rotate a vector+vector3Rotate :: RealFloat a => + a -- ^ Difference of theta+ -> a -- ^ Difference of phi + -> Vector3 a -- ^ Initial vector+ -> Vector3 a -- ^ Rotated vector+vector3Rotate theta' phi' v =+ vector3Spherical (vector3Rho v)+ (vector3Theta v + theta')+ (vector3Phi v + phi')++instance RealFloat a => Forceable (Vector3 a) where+ force = id
+ src/FRP/Animas/VectorSpace.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+-- |+-- Module : FRP.Animas.VectorSpace+-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : nilsson@cs.yale.edu+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Vector space type relation and basic instances.++module FRP.Animas.VectorSpace where++infixr *^+infixl ^/+infix 7 `dot`+infixl 6 ^+^, ^-^++-- | Type class for a vector space+class Floating a => VectorSpace v a | v -> a where+ -- | Vector with no magnitude+ zeroVector :: v+ -- | Scale the magnitude+ (*^) :: a -> v -> v+ -- | De-scale the magnitude+ (^/) :: v -> a -> v+ -- | Negation+ negateVector :: v -> v+ -- | Combine two vectors additively+ (^+^) :: v -> v -> v+ -- | Subtract a vector from another+ (^-^) :: v -> v -> v+ -- | Take the dot-product of two vectors+ dot :: v -> v -> a+ -- | Vector norm+ norm :: v -> a+ -- | Produce a unit vector in the direction of a vector+ normalize :: v -> v++ v ^/ a = (1/a) *^ v++ negateVector v = (-1) *^ v++ v1 ^-^ v2 = v1 ^+^ negateVector v2++ norm v = sqrt (v `dot` v)++ normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"+ where+ nv = norm v++instance VectorSpace Float Float where+ zeroVector = 0++ a *^ x = a * x++ x ^/ a = x / a++ negateVector x = (-x)++ x1 ^+^ x2 = x1 + x2++ x1 ^-^ x2 = x1 - x2++ x1 `dot` x2 = x1 * x2+++instance VectorSpace Double Double where+ zeroVector = 0++ a *^ x = a * x++ x ^/ a = x / a++ negateVector x = (-x)++ x1 ^+^ x2 = x1 + x2++ x1 ^-^ x2 = x1 - x2++ x1 `dot` x2 = x1 * x2+++instance Floating a => VectorSpace (a,a) a where+ zeroVector = (0,0)++ a *^ (x,y) = (a * x, a * y)++ (x,y) ^/ a = (x / a, y / a)++ negateVector (x,y) = (-x, -y)++ (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2)++ (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2)++ (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2+++instance Floating a => VectorSpace (a,a,a) a where+ zeroVector = (0,0,0)++ a *^ (x,y,z) = (a * x, a * y, a * z)++ (x,y,z) ^/ a = (x / a, y / a, z / a)++ negateVector (x,y,z) = (-x, -y, -z)++ (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2)++ (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2)++ (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2+++instance Floating a => VectorSpace (a,a,a,a) a where+ zeroVector = (0,0,0,0)++ a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u)++ (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a)++ negateVector (x,y,z,u) = (-x, -y, -z, -u)++ (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2)++ (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2)++ (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2+++instance Floating a => VectorSpace (a,a,a,a,a) a where+ zeroVector = (0,0,0,0,0)++ a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v)++ (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a)++ negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v)++ (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2)++ (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2)++ (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) =+ x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2