diff --git a/bearriver.cabal b/bearriver.cabal --- a/bearriver.cabal +++ b/bearriver.cabal @@ -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 diff --git a/src/FRP/BearRiver.hs b/src/FRP/BearRiver.hs --- a/src/FRP/BearRiver.hs +++ b/src/FRP/BearRiver.hs @@ -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) diff --git a/src/FRP/Yampa.hs b/src/FRP/Yampa.hs --- a/src/FRP/Yampa.hs +++ b/src/FRP/Yampa.hs @@ -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 diff --git a/src/FRP/Yampa/AffineSpace.hs b/src/FRP/Yampa/AffineSpace.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/AffineSpace.hs @@ -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) diff --git a/src/FRP/Yampa/Point2.hs b/src/FRP/Yampa/Point2.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Point2.hs @@ -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) diff --git a/src/FRP/Yampa/Point3.hs b/src/FRP/Yampa/Point3.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Point3.hs @@ -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) diff --git a/src/FRP/Yampa/Vector2.hs b/src/FRP/Yampa/Vector2.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Vector2.hs @@ -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') diff --git a/src/FRP/Yampa/Vector3.hs b/src/FRP/Yampa/Vector3.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Vector3.hs @@ -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') diff --git a/src/FRP/Yampa/VectorSpace.hs b/src/FRP/Yampa/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/VectorSpace.hs @@ -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