diff --git a/Animas.cabal b/Animas.cabal new file mode 100644 --- /dev/null +++ b/Animas.cabal @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/FRP/Animas.hs b/src/FRP/Animas.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas.hs @@ -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') + + diff --git a/src/FRP/Animas/AffineSpace.hs b/src/FRP/Animas/AffineSpace.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/AffineSpace.hs @@ -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) diff --git a/src/FRP/Animas/Diagnostics.hs b/src/FRP/Animas/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Diagnostics.hs @@ -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) diff --git a/src/FRP/Animas/Event.hs b/src/FRP/Animas/Event.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Event.hs @@ -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 diff --git a/src/FRP/Animas/Forceable.hs b/src/FRP/Animas/Forceable.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Forceable.hs @@ -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 diff --git a/src/FRP/Animas/Geometry.hs b/src/FRP/Animas/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Geometry.hs @@ -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 + + diff --git a/src/FRP/Animas/Internals.hs b/src/FRP/Animas/Internals.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Internals.hs @@ -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) + + diff --git a/src/FRP/Animas/MergeableRecord.hs b/src/FRP/Animas/MergeableRecord.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/MergeableRecord.hs @@ -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 = setL1 vN ~+~ foo +-- let fooFinal = mrFinalize foo +-- @ + +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 diff --git a/src/FRP/Animas/Miscellany.hs b/src/FRP/Animas/Miscellany.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Miscellany.hs @@ -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 diff --git a/src/FRP/Animas/Point2.hs b/src/FRP/Animas/Point2.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Point2.hs @@ -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 diff --git a/src/FRP/Animas/Point3.hs b/src/FRP/Animas/Point3.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Point3.hs @@ -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 diff --git a/src/FRP/Animas/Task.hs b/src/FRP/Animas/Task.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Task.hs @@ -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??? diff --git a/src/FRP/Animas/Utilities.hs b/src/FRP/Animas/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Utilities.hs @@ -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 (^+^) diff --git a/src/FRP/Animas/Vector2.hs b/src/FRP/Animas/Vector2.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Vector2.hs @@ -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 diff --git a/src/FRP/Animas/Vector3.hs b/src/FRP/Animas/Vector3.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/Vector3.hs @@ -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 diff --git a/src/FRP/Animas/VectorSpace.hs b/src/FRP/Animas/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Animas/VectorSpace.hs @@ -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