bearriver 0.0.1 → 0.10.4

raw patch · 9 files changed

+778/−6 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• bearriver.cabal +9/−4
• src/FRP/BearRiver.hs +238/−1
• src/FRP/Yampa.hs +13/−1
• src/FRP/Yampa/AffineSpace.hs +43/−0
• src/FRP/Yampa/Point2.hs +55/−0
• src/FRP/Yampa/Point3.hs +60/−0
• src/FRP/Yampa/Vector2.hs +93/−0
• src/FRP/Yampa/Vector3.hs +111/−0
• src/FRP/Yampa/VectorSpace.hs +156/−0

@@ -1,8 +1,7 @@ name:                bearriver-version:             0.0.1-synopsis:            A Yampa replacement based on Dunai.-description:         BearRiver is an API compatible replacement of Yampa-                     based on Dunai.+version:             0.10.4+synopsis:            A replacement of Yampa based on Monadic Stream Functions.+description:         A Yampa replacement built using Dunai. homepage:            keera.co.uk license:             BSD3 license-file:        LICENSE@@ -16,6 +15,12 @@  library   exposed-modules:     FRP.Yampa,+                       FRP.Yampa.Point2,+                       FRP.Yampa.VectorSpace,+                       FRP.Yampa.Vector2,+                       FRP.Yampa.Point3,+                       FRP.Yampa.Vector3,+                       FRP.Yampa.AffineSpace,                        FRP.BearRiver    build-depends:       base >=4.7 && <5, transformers >=0.3, mtl, dunai

@@ -1,1 +1,238 @@-module FRP.BearRiver where+{-# LANGUAGE RankNTypes #-}+module FRP.BearRiver+  (module FRP.BearRiver, module X)+ where+-- This is an implementation of Yampa using our Monadic Stream Processing+-- library. We focus only on core Yampa. We will use this module later to+-- reimplement an example of a Yampa system.+--+-- While we may not introduce all the complexity of Yampa today (all kinds of+-- switches, etc.) our goal is to show that the approach is promising and that+-- there do not seem to exist any obvious limitations.++import           Control.Applicative+import           Control.Arrow                as X+import           Control.Monad                (mapM)+import           Control.Monad.Reader+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.MStreamF+import           Data.Traversable             as T+import           Data.Functor.Identity+import           Data.Maybe+import           Data.MonadicStreamFunction   as X hiding (iPre, reactimate, switch, sum, trace)+import qualified Data.MonadicStreamFunction   as MSF+import           Data.MonadicStreamFunction.ArrowLoop+import           FRP.Yampa.VectorSpace        as X++type Time  = Double+type DTime = Double++type SF m        = MStreamF (ClockInfo m)+type ClockInfo m = ReaderT DTime m++identity :: Monad m => SF m a a+identity = arr id++constant :: Monad m => b -> SF m a b+constant = arr . const++iPre :: Monad m => a -> SF m a a+iPre i = MStreamF $ \i' -> return (i, iPre i')++-- * Continuous time++time :: Monad m => SF m () Time+time = integral <<< constant 1++integral :: (Monad m, VectorSpace a s) => SF m a a+integral = integralFrom zeroVector++integralFrom :: (Monad m, VectorSpace a s) => a -> SF m a a+integralFrom n0 = MStreamF $ \n -> do+  dt <- ask+  let acc = n0 ^+^ realToFrac dt *^ n+  acc `seq` return (acc, integralFrom acc)++derivative :: (Monad m, VectorSpace a s) => SF m a a+derivative = derivativeFrom zeroVector++derivativeFrom :: (Monad m, VectorSpace a s) => a -> SF m a a+derivativeFrom n0 = MStreamF $ \n -> do+  dt <- ask+  let res = (n ^-^ n0) ^/ realToFrac dt+  res `seq` return (res, derivativeFrom n)++-- * Events++data Event a = Event a | NoEvent+ deriving Show++instance Functor Event where+  fmap f NoEvent   = NoEvent+  fmap f (Event c) = Event (f c)++instance Applicative Event where+  pure = Event++  Event f <*> Event x = Event (f x)+  _       <*> _       = NoEvent++noEvent :: Event a+noEvent = NoEvent++event :: a -> (b -> a) -> Event b -> a+event _ f (Event x) = f x+event x _ NoEvent   = x++fromEvent (Event x) = x+fromEvent _         = error "fromEvent NoEvent"++isEvent (Event _) = True+isEvent _         = False++tag :: Event a -> b -> Event b+tag NoEvent   _ = NoEvent+tag (Event _) b = Event b++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)++lMerge :: Event a -> Event a -> Event a+lMerge = mergeBy (\e1 _e2 -> e1)++-- ** Relation to other types++eventToMaybe = event Nothing Just+maybeToEvent = maybe NoEvent Event++boolToEvent :: Bool -> Event ()+boolToEvent True  = Event ()+boolToEvent False = NoEvent++-- * Hybrid SF m combinators++edge :: Monad m => SF m Bool (Event ())+edge = edgeFrom True++edgeBy :: Monad m => (a -> a -> Maybe b) -> a -> SF m a (Event b)+edgeBy isEdge a_prev = MStreamF $ \a ->+  return (maybeToEvent (isEdge a_prev a), edgeBy isEdge a)++edgeFrom :: Monad m => Bool -> SF m Bool (Event())+edgeFrom prev = MStreamF $ \a -> do+  let res = if prev then NoEvent else if a then Event () else NoEvent+      ct  = edgeFrom a+  return (res, ct)++-- | Suppression of initial (at local time 0) event.+notYet :: Monad m => SF m (Event a) (Event a)+notYet = feedback False $ arr (\(e,c) ->+  if c then (e, True) else (NoEvent, True))++hold :: Monad m => a -> SF m (Event a) a+hold a = feedback a $ arr $ \(e,a') ->+  dup (event a' id e)+ where dup x = (x,x)++loopPre :: Monad m => c -> SF m (a, c) (b, c) -> SF m a b+loopPre = feedback++after :: Monad m+      => Time -- ^ The time /q/ after which the event should be produced+      -> b    -- ^ Value to produce at that time+      -> SF m a (Event b)+after q x = feedback q $ go+ where go = MStreamF $ \(_, t) -> do+              dt <- ask+              let t' = t - dt+                  e  = if t > 0 && t' < 0 then Event x else NoEvent+                  ct = if t' < 0 then constant (NoEvent, t') else go+              return ((e, t'), ct)++(-->) :: Monad m => b -> SF m a b -> SF m a b+b0 --> sf = MStreamF $ \a -> do +  (_, ct) <- unMStreamF sf a+  return (b0, ct)++accumHoldBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) b+accumHoldBy f b = feedback b $ arr $ \(a, b') ->+  let b'' = event b' (f b') a+  in (b'', b'')++dpSwitchB :: (Monad m , Traversable col)+          => col (SF m a b) -> SF m (a, col b) (Event c) -> (col (SF m a b) -> c -> SF m a (col b))+          -> SF m a (col b)+dpSwitchB sfs sfF sfCs = MStreamF $ \a -> do+  res <- T.mapM (`unMStreamF` a) sfs+  let bs   = fmap fst res+      sfs' = fmap snd res+  (e,sfF') <- unMStreamF sfF (a, bs)+  let ct = case e of+             Event c -> sfCs sfs' c+             NoEvent -> dpSwitchB sfs' sfF' sfCs +  return (bs, ct)++dSwitch ::  Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b+dSwitch sf sfC = MStreamF $ \a -> do+  (o, ct) <- unMStreamF sf a+  case o of+    (b, Event c) -> do (_,ct') <- unMStreamF (sfC c) a+                       return (b, ct')+    (b, NoEvent) -> return (b, dSwitch ct sfC)++switch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b+switch sf sfC = MStreamF $ \a -> do+  (o, ct) <- unMStreamF sf a+  case o of+    (_, Event c) -> unMStreamF (sfC c) a+    (b, NoEvent) -> return (b, switch ct sfC)++parC :: Monad m => SF m a b -> SF m [a] [b]+parC sf = parC' [sf]++parC' :: Monad m => [SF m a b] -> SF m [a] [b]+parC' sfs = MStreamF $ \as -> do+  os <- T.mapM (\(a,sf) -> unMStreamF sf a) $ zip as sfs+  let bs  = fmap fst os+      cts = fmap snd os+  return (bs, parC' cts)++-- NOTE: BUG in this function, it needs two a's but we+-- can only provide one+iterFrom :: Monad m => (a -> a -> DTime -> b -> b) -> b -> SF m a b+iterFrom f b = MStreamF $ \a -> do+  dt <- ask+  let b' = f a a dt b+  return (b, iterFrom f b')++reactimate :: IO a -> (Bool -> IO (DTime, Maybe a)) -> (Bool -> b -> IO Bool) -> SF Identity a b -> IO ()+reactimate senseI sense actuate sf = do+  -- runMaybeT $ MSF.reactimate $ liftMStreamFTrans (senseSF >>> sfIO) >>> actuateSF+  MSF.reactimateB $ senseSF >>> sfIO >>> actuateSF+  return ()+ where sfIO        = liftMStreamFPurer (return.runIdentity) (runReaderS sf)++       -- Sense+       senseSF     = switch senseFirst senseRest+       senseFirst  = liftMStreamF_ senseI >>> (arr $ \x -> ((0, x), Event x))+       senseRest a = liftMStreamF_ (sense True) >>> (arr id *** keepLast a)++       keepLast :: Monad m => a -> MStreamF m (Maybe a) a+       keepLast a = MStreamF $ \ma -> let a' = fromMaybe a ma in return (a', keepLast a')++       -- Consume/render+       -- actuateSF :: MStreamF IO b ()+       -- actuateSF    = arr (\x -> (True, x)) >>> liftMStreamF (lift . uncurry actuate) >>> exitIf+       actuateSF    = arr (\x -> (True, x)) >>> liftMStreamF (uncurry actuate)++       switch sf sfC = MSF.switch (sf >>> second (arr eventToMaybe)) sfC++-- * Auxiliary++-- ** Tuples++dup  x     = (x,x)+swap (x,y) = (y,x)

@@ -1,2 +1,14 @@-module FRP.Yampa where+module FRP.Yampa (module X) where +import           FRP.BearRiver         as X hiding (andThen, SF)+import           FRP.Yampa.AffineSpace as X+import           FRP.Yampa.Point2      as X+import           FRP.Yampa.Point3      as X+import           FRP.Yampa.Vector2     as X+import           FRP.Yampa.Vector3     as X+import           FRP.Yampa.VectorSpace as X++import           Data.Functor.Identity+import qualified FRP.BearRiver         as BR++type SF = BR.SF Identity

@@ -0,0 +1,43 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.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.Yampa.AffineSpace where++import FRP.Yampa.VectorSpace++------------------------------------------------------------------------------+-- Affine Space type relation+------------------------------------------------------------------------------++infix 6 .+^, .-^, .-.++-- Maybe origin should not be a class method, even though an origin+-- can be assocoated with any affine space.+-- Maybe distance should not be a class method, in which case the constraint+-- on the coefficient space (a) could be Fractional (i.e., a Field), which+-- seems closer to the mathematical definition of affine space, provided+-- the constraint on the coefficient space for VectorSpace is also Fractional.++-- Minimal instance: origin, .+^, .^.+class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where+    origin   :: p+    (.+^)    :: p -> v -> p+    (.-^)    :: p -> v -> p+    (.-.)    :: p -> p -> v+    distance :: p -> p -> a++    p .-^ v = p .+^ (negateVector v)++    distance p1 p2 = norm (p1 .-. p2)

@@ -0,0 +1,55 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.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.Yampa.Point2 (+    -- module AFRPVectorSpace,+    -- module AFRPAffineSpace,+    -- module AFRPVector2,+    Point2(..), -- Non-abstract, instance of AffineSpace+    point2X,    -- :: RealFloat a => Point2 a -> a+    point2Y     -- :: RealFloat a => Point2 a -> a+) where++import FRP.Yampa.VectorSpace ()+import FRP.Yampa.AffineSpace+import FRP.Yampa.Vector2++------------------------------------------------------------------------------+-- 2D point, constructors and selectors.+------------------------------------------------------------------------------++data RealFloat a => Point2 a = Point2 !a !a deriving (Eq, Show)++point2X :: RealFloat a => Point2 a -> a+point2X (Point2 x _) = x++point2Y :: RealFloat a => Point2 a -> a+point2Y (Point2 _ y) = y+++------------------------------------------------------------------------------+-- Affine space instance+------------------------------------------------------------------------------++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)

@@ -0,0 +1,60 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.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.Yampa.Point3 (+    -- module AFRPVectorSpace,+    -- module AFRPAffineSpace,+    -- module AFRPVector3,+    Point3(..), -- Non-abstract, instance of AffineSpace+    point3X,    -- :: RealFloat a => Point3 a -> a+    point3Y,    -- :: RealFloat a => Point3 a -> a+    point3Z     -- :: RealFloat a => Point3 a -> a+) where++import FRP.Yampa.VectorSpace ()+import FRP.Yampa.AffineSpace+import FRP.Yampa.Vector3++------------------------------------------------------------------------------+-- 3D point, constructors and selectors.+------------------------------------------------------------------------------++data RealFloat a => Point3 a = Point3 !a !a !a deriving Eq++point3X :: RealFloat a => Point3 a -> a+point3X (Point3 x _ _) = x++point3Y :: RealFloat a => Point3 a -> a+point3Y (Point3 _ y _) = y++point3Z :: RealFloat a => Point3 a -> a+point3Z (Point3 _ _ z) = z+++------------------------------------------------------------------------------+-- Affine space instance+------------------------------------------------------------------------------++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)

@@ -0,0 +1,93 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.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.Yampa.Vector2 (+    Vector2,            -- Abstract, instance of VectorSpace+    vector2,            -- :: RealFloat a => a -> a -> Vector2 a+    vector2X,           -- :: RealFloat a => Vector2 a -> a+    vector2Y,           -- :: RealFloat a => Vector2 a -> a+    vector2XY,          -- :: RealFloat a => Vector2 a -> (a, a)+    vector2Polar,       -- :: RealFloat a => a -> a -> Vector2 a+    vector2Rho,         -- :: RealFloat a => Vector2 a -> a+    vector2Theta,       -- :: RealFloat a => Vector2 a -> a+    vector2RhoTheta,    -- :: RealFloat a => Vector2 a -> (a, a)+    vector2Rotate       -- :: RealFloat a => a -> Vector2 a -> Vector2 a+) where++import FRP.Yampa.VectorSpace+++------------------------------------------------------------------------------+-- 2D vector, constructors and selectors.+------------------------------------------------------------------------------++-- Restrict coefficient space to RealFloat (rather than Floating) for now.+-- While unclear if a complex coefficient space would be useful (and if the+-- result really would be a 2d vector), the only thing causing trouble is the+-- use of atan2 in vector2Theta. Maybe atan2 can be generalized?++data RealFloat a => Vector2 a = Vector2 !a !a deriving (Eq,Show)++vector2 :: RealFloat a => a -> a -> Vector2 a+vector2 = Vector2++vector2X :: RealFloat a => Vector2 a -> a+vector2X (Vector2 x _) = x++vector2Y :: RealFloat a => Vector2 a -> a+vector2Y (Vector2 _ y) = y++vector2XY :: RealFloat a => Vector2 a -> (a, a)+vector2XY (Vector2 x y) = (x, y)++vector2Polar :: RealFloat a => a -> a -> Vector2 a+vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta)++vector2Rho :: RealFloat a => Vector2 a -> a+vector2Rho (Vector2 x y) = sqrt (x * x + y * y)++vector2Theta :: RealFloat a => Vector2 a -> a+vector2Theta (Vector2 x y) = atan2 y x++vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a)+vector2RhoTheta v = (vector2Rho v, vector2Theta v)++------------------------------------------------------------------------------+-- Vector space instance+------------------------------------------------------------------------------++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+++------------------------------------------------------------------------------+-- Additional operations+------------------------------------------------------------------------------++vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a+vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta')

@@ -0,0 +1,111 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.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.Yampa.Vector3 (+    Vector3,            -- Abstract, instance of VectorSpace+    vector3,            -- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3X,           -- :: RealFloat a => Vector3 a -> a+    vector3Y,           -- :: RealFloat a => Vector3 a -> a+    vector3Z,           -- :: RealFloat a => Vector3 a -> a+    vector3XYZ,         -- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Spherical,   -- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3Rho,         -- :: RealFloat a => Vector3 a -> a+    vector3Theta,       -- :: RealFloat a => Vector3 a -> a+    vector3Phi,         -- :: RealFloat a => Vector3 a -> a+    vector3RhoThetaPhi, -- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Rotate       -- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a+) where++import FRP.Yampa.VectorSpace++------------------------------------------------------------------------------+-- 3D vector, constructors and selectors.+------------------------------------------------------------------------------++-- Restrict coefficient space to RealFloat (rather than Floating) for now.+-- While unclear if a complex coefficient space would be useful (and if the+-- result really would be a 3d vector), the only thing causing trouble is the+-- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized?++data RealFloat a => Vector3 a = Vector3 !a !a !a deriving (Eq, Show)++vector3 :: RealFloat a => a -> a -> a -> Vector3 a+vector3 = Vector3++vector3X :: RealFloat a => Vector3 a -> a+vector3X (Vector3 x _ _) = x++vector3Y :: RealFloat a => Vector3 a -> a+vector3Y (Vector3 _ y _) = y++vector3Z :: RealFloat a => Vector3 a -> a+vector3Z (Vector3 _ _ z) = z++vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a)+vector3XYZ (Vector3 x y z) = (x, y, z)++vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a+vector3Spherical rho theta phi =+    Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi)+    where+        rhoSinPhi = rho * sin phi++vector3Rho :: RealFloat a => Vector3 a -> a+vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z)++vector3Theta :: RealFloat a => Vector3 a -> a+vector3Theta (Vector3 x y _) = atan2 y x++vector3Phi :: RealFloat a => Vector3 a -> a+vector3Phi v@(Vector3 _ _ z) = acos (z / vector3Rho v)++vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a)+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)+++------------------------------------------------------------------------------+-- Vector space instance+------------------------------------------------------------------------------++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+++------------------------------------------------------------------------------+-- Additional operations+------------------------------------------------------------------------------++vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a+vector3Rotate theta' phi' v =+    vector3Spherical (vector3Rho v)+                     (vector3Theta v + theta')+                     (vector3Phi v + phi')

@@ -0,0 +1,156 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.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.Yampa.VectorSpace where++------------------------------------------------------------------------------+-- Vector space type relation+------------------------------------------------------------------------------++infixr *^+infixl ^/+infix 7 `dot`+infixl 6 ^+^, ^-^++-- Maybe norm and normalize should not be class methods, in which case+-- the constraint on the coefficient space (a) should (or, at least, could)+-- be Fractional (roughly a Field) rather than Floating.++-- Minimal instance: zeroVector, (*^), (^+^), dot+class (Eq a, Floating a) => VectorSpace v a | v -> a where+    zeroVector   :: v+    (*^)         :: a -> v -> v+    (^/)         :: v -> a -> v+    negateVector :: v -> v+    (^+^)        :: v -> v -> v+    (^-^)        :: v -> v -> v+    dot          :: v -> v -> a+    norm         :: v -> a+    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++------------------------------------------------------------------------------+-- Vector space instances for Float and Double+------------------------------------------------------------------------------++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+++------------------------------------------------------------------------------+-- Vector space instances for small tuples of Floating+------------------------------------------------------------------------------++instance (Eq a, 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 (Eq a, 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 (Eq a, 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 (Eq a, 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