Vec 0.9.9 → 1.0.5
raw patch · 5 files changed
Files
- Data/Vec.hs +5/−12
- Data/Vec/Base.hs +99/−100
- Data/Vec/LinAlg.hs +254/−139
- Data/Vec/Packed.hs +199/−74
- Vec.cabal +2/−2
Data/Vec.hs view
@@ -123,17 +123,10 @@ <http://graphics.cs.ucdavis.edu/~okreylos/ResDev/Geometry/index.html> -} -module Data.Vec - (module Data.Vec.Base- ,module Data.Vec.LinAlg- ,module Data.Vec.Packed- ,module Data.Vec.Nat- )-where--import Data.Vec.Base-import Data.Vec.LinAlg-import Data.Vec.Packed-import Data.Vec.Nat+module Data.Vec (module X) where+import Data.Vec.Base as X+import Data.Vec.LinAlg as X+import Data.Vec.Packed as X+import Data.Vec.Nat as X
Data/Vec/Base.hs view
@@ -27,11 +27,11 @@ --for UArray instances import Data.Array.Base as Array-import GHC.ST ( ST(..), runST )-import GHC.Prim +import GHC.ST ( ST(..), runST )+import GHC.Prim import GHC.Base ( Int(..) )-import GHC.Float ( Float(..), Double(..) )-import GHC.Word ( Word8(..) )+import GHC.Float ( Float(..), Double(..) )+import GHC.Word ( Word8(..) ) -- | The vector constructor. @(:.)@ for vectors is like @(:)@ for lists, and@@ -85,7 +85,7 @@ -- | The type constraint @Vec n a v@ infers the vector type @v@ from the--- length @n@, a type-level natural, and underlying component type @a@. +-- length @n@, a type-level natural, and underlying component type @a@. -- So @x :: Vec N4 a v => v@ declares @x@ to be a 4-vector of @a@s. class Vec n a v | n a -> v, v -> n a where@@ -118,13 +118,13 @@ -- distinction between this and 'matFromList', as you might accidentally use -- this when you mean that. Because number literals can be converted to -- vectors, and matrices are vectors of vectors, the following works- -- - -- > fromList [1,2,3,4] :: Mat22 Int + --+ -- > fromList [1,2,3,4] :: Mat22 Int -- > > ((1):.(1):.()):.((2):.(2):.()):.() -- -- even though we meant to do this --- -- > matFromList [1,2,3,4] :: Mat22 Int + -- > matFromList [1,2,3,4] :: Mat22 Int -- > > ((1):.(2):.()):.((3):.(4):.()):.() fromList :: [a] -> v @@ -140,7 +140,7 @@ getElem i (a :. _) | i == 0 = a | otherwise = error "getElem: index out of bounds"- setElem i a _ + setElem i a _ | i == 0 = a :. () | otherwise = error "setElem: index out of bounds" {-# INLINE setElem #-}@@ -162,7 +162,7 @@ -- | get or set a vector element, known at compile --time. Use the Nat types to access vector components. For instance, @get n0@---gets the x component, @set n2 44@ sets the z component to 44. +--gets the x component, @set n2 44@ sets the z component to 44. class Access n a v | v -> a where get :: n -> v -> a@@ -185,20 +185,20 @@ -- | The first element. -class Head v a | v -> a where +class Head v a | v -> a where head :: v -> a -instance Head (a :. as) a where +instance Head (a :. as) a where head (a :. _) = a {-# INLINE head #-} --- | All but the first element. +-- | All but the first element. -class Tail v v_ | v -> v_ where +class Tail v v_ | v -> v_ where tail :: v -> v_ -instance Tail (a :. as) as where +instance Tail (a :. as) as where tail (_ :. as) = as {-# INLINE tail #-} @@ -243,15 +243,15 @@ zipWith f (x:._) (y:._) = f x y :.() {-# INLINE zipWith #-} -instance - ZipWith a b c (a':.u) (b':.v) (c':.w) - => ZipWith a b c (a:.a':.u) (b:.b':.v) (c:.c':.w) +instance+ ZipWith a b c (a':.u) (b':.v) (c':.w)+ => ZipWith a b c (a:.a':.u) (b:.b':.v) (c:.c':.w) where zipWith f (x:.u) (y:.v) = f x y :. zipWith f u v {-# INLINE zipWith #-} --- | Fold a function over a vector. +-- | Fold a function over a vector. class Fold v a | v -> a where fold :: (a -> a -> a) -> v -> a@@ -259,7 +259,7 @@ foldr :: (a -> b -> b) -> b -> v -> b instance Fold (a:.()) a where- fold _ (a:._) = a + fold _ (a:._) = a foldl f z (a:._) = seq z $ f z a foldr f z (a:._) = f a z {-# INLINE fold #-}@@ -274,7 +274,7 @@ {-# INLINE foldl #-} {-# INLINE foldr #-} --- | Reverse a vector +-- | Reverse a vector reverse :: (Reverse' () v v') => v -> v' reverse v = reverse' () v {-# INLINE reverse #-}@@ -285,19 +285,19 @@ -- | Reverse helper function : accumulates the reversed list in its first argument class Reverse' p v v' | p v -> v' where reverse' :: p -> v -> v'- + instance Reverse' p () p where reverse' p () = p {-# INLINE reverse' #-} instance Reverse' (a:.p) v v' => Reverse' p (a:.v) v' where- reverse' p (a:.v) = reverse' (a:.p) v + reverse' p (a:.v) = reverse' (a:.p) v {-# INLINE reverse' #-} --- | Append two vectors +-- | Append two vectors -class Append v1 v2 v3 | v1 v2 -> v3, v1 v3 -> v2 where +class Append v1 v2 v3 | v1 v2 -> v3, v1 v3 -> v2 where append :: v1 -> v2 -> v3 instance Append () v v where@@ -325,7 +325,7 @@ take _ _ = () {-# INLINE take #-} -instance Take n v v' +instance Take n v v' => Take (Succ n) (a:.v) (a:.v') where take _ (a:.v) = a:.(take (undefined::n) v) {-# INLINE take #-}@@ -336,12 +336,12 @@ class Drop n v v' | n v -> v' where drop :: n -> v -> v'- + instance Drop N0 v v where drop _ = id {-# INLINE drop #-} -instance (Drop n (a:.v) v') +instance (Drop n (a:.v) v') => Drop (Succ n) (a:.a:.v) v' where drop _ (_:.v) = drop (undefined::n) v {-# INLINE drop #-}@@ -352,7 +352,7 @@ class Last v a | v -> a where last :: v -> a -instance Last (a:.()) a where +instance Last (a:.()) a where last (a:._) = a {-# INLINE last #-} @@ -361,8 +361,8 @@ {-# INLINE last #-} --- | @snoc v a@ appends the element a to the end of v. -class Snoc v a v' | v a -> v', v' -> v a where +-- | @snoc v a@ appends the element a to the end of v.+class Snoc v a v' | v a -> v', v' -> v a where snoc :: v -> a -> v' instance Snoc () a (a:.()) where@@ -406,7 +406,7 @@ {-# INLINE minimum #-} toList :: (Fold v a) => v -> [a]-toList = foldr (:) [] +toList = foldr (:) [] {-# INLINE toList #-} @@ -459,7 +459,7 @@ --- Storable instances. +-- Storable instances. instance Storable a => Storable (a:.()) where sizeOf _ = sizeOf (undefined::a)@@ -479,19 +479,19 @@ {-# INLINE pokeByteOff #-} {-# INLINE pokeElemOff #-} -instance (Vec (Succ (Succ n)) a (a:.a:.v), Storable a, Storable (a:.v)) - => Storable (a:.a:.v) +instance (Vec (Succ (Succ n)) a (a:.a:.v), Storable a, Storable (a:.v))+ => Storable (a:.a:.v) where sizeOf _ = sizeOf (undefined::a) + sizeOf (undefined::(a:.v)) alignment _ = alignment (undefined::a)- peek p = - peek (castPtr p) >>= \a -> - peek (castPtr (p`plusPtr`sizeOf(undefined::a))) >>= \v -> + peek p =+ peek (castPtr p) >>= \a ->+ peek (castPtr (p`plusPtr`sizeOf(undefined::a))) >>= \v -> return (a:.v) peekByteOff p o = peek (p`plusPtr`o) peekElemOff p i = peek (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v))))- poke p (a:.v) = - poke (castPtr p) a >> + poke p (a:.v) =+ poke (castPtr p) a >> poke (castPtr (p`plusPtr`sizeOf(undefined::a))) v pokeByteOff p o x = poke (p`plusPtr`o) x pokeElemOff p i x = poke (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v)))) x@@ -506,21 +506,21 @@ -- Num and Fractional instances : All arithmetic is done component-wise and--- literals construct uniform vectors and matrices. +-- literals construct uniform vectors and matrices. ----- The rule is : --- If the method is unary, it's a map. +-- The rule is :+-- If the method is unary, it's a map. -- If it's binary, it's a zipWith. instance- (Eq u, ShowVec u, Num a- ,Map a a (a:.u) (a:.u) + (Num a+ ,Map a a (a:.u) (a:.u) ,ZipWith a a a (a:.u) (a:.u) (a:.u) ,Vec (Succ l) a (a:.u) )- => Num (a:.u) + => Num (a:.u) where- (+) u v = zipWith (+) u v + (+) u v = zipWith (+) u v (-) u v = zipWith (-) u v (*) u v = zipWith (*) u v abs u = map abs u@@ -534,15 +534,14 @@ {-# INLINE fromInteger #-} -instance - (Eq u, ShowVec u, Fractional a+instance+ (Fractional a ,Ord (a:.u) ,ZipWith a a a (a:.u) (a:.u) (a:.u) ,Map a a (a:.u) (a:.u)- ,Vec (Succ l) a (a:.u)- ,Show (a:.u)- ) - => Fractional (a:.u) + ,Vec (Succ l) a (a:.u) + )+ => Fractional (a:.u) where (/) u v = zipWith (/) u v recip u = map recip u@@ -566,15 +565,15 @@ vaWrite# :: MutableByteArray# s# -> Int# -> v -> State# s# -> State# s# vaIndex# :: ByteArray# -> Int# -> v vaSizeOf# :: v -> Int# --the size of a vector in bytes- vaLength# :: v -> Int# --the length of a vector + vaLength# :: v -> Int# --the length of a vector init# :: v --the default item when newArray_ is used instance VecArrayRW (Int:.()) where vaRead# arr# i# s1# =- case readIntArray# arr# i# s1# of - (# s2#, x# #) -> (# s2#, ((I# x#):.()) #) - vaWrite# arr# i# ((I# x#):._) s1# = + case readIntArray# arr# i# s1# of+ (# s2#, x# #) -> (# s2#, ((I# x#):.()) #)+ vaWrite# arr# i# ((I# x#):._) s1# = case writeIntArray# arr# i# x# s1# of { s2# -> s2# } vaIndex# arr# i# = I# (indexIntArray# arr# i#) :. () vaSizeOf# _ = sizeOf# (undefined::Int)@@ -588,18 +587,18 @@ {-# INLINE init# #-} instance (VecArrayRW (Int:.v)) => VecArrayRW (Int:.Int:.v) where- vaRead# arr# i# s1# = - case readIntArray# arr# i# s1# of { (# s2#, x# #) -> - case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> + vaRead# arr# i# s1# =+ case readIntArray# arr# i# s1# of { (# s2#, x# #) ->+ case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> (# s3#, ((I# x#):.v) #) }}- vaWrite# arr# i# ((I# x#):.v) s1# = - case writeIntArray# arr# i# x# s1# of { s2# -> + vaWrite# arr# i# ((I# x#):.v) s1# =+ case writeIntArray# arr# i# x# s1# of { s2# -> case vaWrite# arr# (i# +# 1#) v s2# of { s3# -> s3# }}- vaIndex# arr# i# = I# (indexIntArray# arr# i#) :. + vaIndex# arr# i# = I# (indexIntArray# arr# i#) :. vaIndex# arr# (i# +# 1#) vaSizeOf# _ = sizeOf# (undefined::Int) +# vaSizeOf# (undefined::Int:.v) vaLength# _ = 1# +# vaLength# (undefined::Int:.v)- init# = 0 :. init# + init# = 0 :. init# {-# INLINE vaRead# #-} {-# INLINE vaWrite# #-} {-# INLINE vaIndex# #-}@@ -609,9 +608,9 @@ instance VecArrayRW (Double:.()) where vaRead# arr# i# s1# =- case readDoubleArray# arr# i# s1# of - (# s2#, x# #) -> (# s2#, ((D# x#):.()) #) - vaWrite# arr# i# ((D# x#):._) s1# = + case readDoubleArray# arr# i# s1# of+ (# s2#, x# #) -> (# s2#, ((D# x#):.()) #)+ vaWrite# arr# i# ((D# x#):._) s1# = case writeDoubleArray# arr# i# x# s1# of { s2# -> s2# } vaIndex# arr# i# = D# (indexDoubleArray# arr# i#) :. () vaSizeOf# _ = sizeOf# (undefined::Double)@@ -625,18 +624,18 @@ {-# INLINE init# #-} instance (VecArrayRW (Double:.v)) => VecArrayRW (Double:.Double:.v) where- vaRead# arr# i# s1# = - case readDoubleArray# arr# i# s1# of { (# s2#, x# #) -> - case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> + vaRead# arr# i# s1# =+ case readDoubleArray# arr# i# s1# of { (# s2#, x# #) ->+ case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> (# s3#, ((D# x#):.v) #) }}- vaWrite# arr# i# ((D# x#):.v) s1# = - case writeDoubleArray# arr# i# x# s1# of { s2# -> + vaWrite# arr# i# ((D# x#):.v) s1# =+ case writeDoubleArray# arr# i# x# s1# of { s2# -> case vaWrite# arr# (i# +# 1#) v s2# of { s3# -> s3# }}- vaIndex# arr# i# = D# (indexDoubleArray# arr# i#) :. + vaIndex# arr# i# = D# (indexDoubleArray# arr# i#) :. vaIndex# arr# (i# +# 1#) vaSizeOf# _ = sizeOf# (undefined::Double) +# vaSizeOf# (undefined::Double:.v) vaLength# _ = 1# +# vaLength# (undefined::Double:.v)- init# = 0 :. init# + init# = 0 :. init# {-# INLINE vaRead# #-} {-# INLINE vaWrite# #-} {-# INLINE vaIndex# #-}@@ -647,9 +646,9 @@ instance VecArrayRW (Float:.()) where vaRead# arr# i# s1# =- case readFloatArray# arr# i# s1# of - (# s2#, x# #) -> (# s2#, ((F# x#):.()) #) - vaWrite# arr# i# ((F# x#):._) s1# = + case readFloatArray# arr# i# s1# of+ (# s2#, x# #) -> (# s2#, ((F# x#):.()) #)+ vaWrite# arr# i# ((F# x#):._) s1# = case writeFloatArray# arr# i# x# s1# of { s2# -> s2# } vaIndex# arr# i# = F# (indexFloatArray# arr# i#) :. () vaSizeOf# _ = sizeOf# (undefined::Float)@@ -663,18 +662,18 @@ {-# INLINE init# #-} instance (VecArrayRW (Float:.v)) => VecArrayRW (Float:.Float:.v) where- vaRead# arr# i# s1# = - case readFloatArray# arr# i# s1# of { (# s2#, x# #) -> - case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> + vaRead# arr# i# s1# =+ case readFloatArray# arr# i# s1# of { (# s2#, x# #) ->+ case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> (# s3#, ((F# x#):.v) #) }}- vaWrite# arr# i# ((F# x#):.v) s1# = - case writeFloatArray# arr# i# x# s1# of { s2# -> + vaWrite# arr# i# ((F# x#):.v) s1# =+ case writeFloatArray# arr# i# x# s1# of { s2# -> case vaWrite# arr# (i# +# 1#) v s2# of { s3# -> s3# }}- vaIndex# arr# i# = F# (indexFloatArray# arr# i#) :. + vaIndex# arr# i# = F# (indexFloatArray# arr# i#) :. vaIndex# arr# (i# +# 1#) vaSizeOf# _ = sizeOf# (undefined::Float) +# vaSizeOf# (undefined::Float:.v) vaLength# _ = 1# +# vaLength# (undefined::Float:.v)- init# = 0 :. init# + init# = 0 :. init# {-# INLINE vaRead# #-} {-# INLINE vaWrite# #-} {-# INLINE vaIndex# #-}@@ -685,9 +684,9 @@ instance VecArrayRW (Word8:.()) where vaRead# arr# i# s1# =- case readWord8Array# arr# i# s1# of - (# s2#, x# #) -> (# s2#, ((W8# x#):.()) #) - vaWrite# arr# i# ((W8# x#):._) s1# = + case readWord8Array# arr# i# s1# of+ (# s2#, x# #) -> (# s2#, ((W8# x#):.()) #)+ vaWrite# arr# i# ((W8# x#):._) s1# = case writeWord8Array# arr# i# x# s1# of { s2# -> s2# } vaIndex# arr# i# = W8# (indexWord8Array# arr# i#) :. () vaSizeOf# _ = sizeOf# (undefined::Word8)@@ -701,18 +700,18 @@ {-# INLINE init# #-} instance (VecArrayRW (Word8:.v)) => VecArrayRW (Word8:.Word8:.v) where- vaRead# arr# i# s1# = - case readWord8Array# arr# i# s1# of { (# s2#, x# #) -> - case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> + vaRead# arr# i# s1# =+ case readWord8Array# arr# i# s1# of { (# s2#, x# #) ->+ case vaRead# arr# (i# +# 1#) s2# of { (# s3#, v #) -> (# s3#, ((W8# x#):.v) #) }}- vaWrite# arr# i# ((W8# x#):.v) s1# = - case writeWord8Array# arr# i# x# s1# of { s2# -> + vaWrite# arr# i# ((W8# x#):.v) s1# =+ case writeWord8Array# arr# i# x# s1# of { s2# -> case vaWrite# arr# (i# +# 1#) v s2# of { s3# -> s3# }}- vaIndex# arr# i# = W8# (indexWord8Array# arr# i#) :. + vaIndex# arr# i# = W8# (indexWord8Array# arr# i#) :. vaIndex# arr# (i# +# 1#) vaSizeOf# _ = sizeOf# (undefined::Word8) +# vaSizeOf# (undefined::Word8:.v) vaLength# _ = 1# +# vaLength# (undefined::Word8:.v)- init# = 0 :. init# + init# = 0 :. init# {-# INLINE vaRead# #-} {-# INLINE vaWrite# #-} {-# INLINE vaIndex# #-}@@ -730,16 +729,16 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-}- unsafeNewArray_ (l,u) = + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (\x# -> x# *# vaSizeOf# (undefined::a:.v) ) {-# INLINE newArray_ #-} newArray_ arrBounds = Array.newArray arrBounds init# {-# INLINE unsafeRead #-}- unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# -> - vaRead# marr# (vaLength# (undefined::a:.v) *# i#) s1# + unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# ->+ vaRead# marr# (vaLength# (undefined::a:.v) *# i#) s1# {-# INLINE unsafeWrite #-} unsafeWrite (STUArray _ _ _ marr#) (I# i#) v = ST $ \s1# ->- case vaWrite# marr# (vaLength# (undefined::a:.v) *# i#) v s1# of s2# -> (# s2#, () #) + case vaWrite# marr# (vaLength# (undefined::a:.v) *# i#) v s1# of s2# -> (# s2#, () #) instance VecArrayRW (a:.v) => IArray UArray (a:.v) where {-# INLINE bounds #-}@@ -749,13 +748,13 @@ {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies init# ) {-# INLINE unsafeAt #-}- unsafeAt (UArray _ _ _ arr#) (I# i#) = + unsafeAt (UArray _ _ _ arr#) (I# i#) = vaIndex# arr# (vaLength# (undefined::a:.v) *# i#) {-# INLINE unsafeReplace #-} unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) {-# INLINE unsafeAccum #-} unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) {-# INLINE unsafeAccumArray #-}- unsafeAccumArray f initialValue lu ies = + unsafeAccumArray f initialValue lu ies = runST (unsafeAccumArrayUArray f initialValue lu ies)
Data/Vec/LinAlg.hs view
@@ -1,6 +1,5 @@ {- Copyright (c) 2008, Scott E. Dillard. All rights reserved. -} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -14,7 +13,7 @@ {-# OPTIONS_HADDOCK ignore-exports,prune #-} -module Data.Vec.LinAlg +module Data.Vec.LinAlg (dot ,normSq ,norm@@ -44,6 +43,17 @@ ,invert ,invertAndDet ,solve+ ,translation+ ,rotationX+ ,rotationY+ ,rotationZ+ ,rotationVec+ ,rotationEuler+ ,rotationQuat+ ,rotationLookAt+ ,scaling+ ,perspective+ ,orthogonal ) where import Prelude hiding (map,zipWith,foldl,foldr,reverse,take,drop,@@ -56,24 +66,24 @@ import Data.Maybe -- | dot \/ inner \/ scalar product-dot :: (Num a, Num v, Fold v a) => v -> v -> a-dot u v = sum (u*v)+dot :: (Num a, Fold v a, ZipWith a a a v v v) => v -> v -> a+dot u v = fold (+) (zipWith (*) u v) {-# INLINE dot #-} -- | vector norm, squared-normSq :: (Num a, Num v, Fold v a) => v -> a+normSq :: (Num a, Num v, Fold v a, ZipWith a a a v v v) => v -> a normSq v = dot v v {-# INLINE normSq #-} -- | vector \/ L2 \/ Euclidean norm-norm :: (Num v, Floating a, Fold v a) => v -> a+norm :: (Num v, Floating a, Fold v a, ZipWith a a a v v v) => v -> a norm v = sqrt (dot v v) {-# INLINE norm #-} -- | @normalize v@ is a unit vector in the direction of @v@. @v@ is assumed -- non-null.-normalize :: (Floating a, Num v, Fold v a, Map a a v v) => v -> v-normalize v = map (/(norm v)) v+normalize :: (Floating a, Num v, Fold v a, Map a a v v, ZipWith a a a v v v) => v -> v+normalize v = map (/ norm v) v {-# INLINE normalize #-} -- | 3d cross product.@@ -94,7 +104,7 @@ -- | project a vector from homogenous coordinates. Last vector element is -- assumed non-zero.-project :: +project :: ( Reverse' () t1 v' , Fractional t1 , Vec a t t1@@ -105,10 +115,11 @@ -- | row vector * matrix-multvm :: +multvm :: ( Transpose m mt , Map v a mt v' , Fold v a+ , ZipWith a a a v v v , Num a , Num v ) => v -> m -> v'@@ -116,21 +127,23 @@ {-# INLINE multvm #-} -- | matrix * column vector-multmv :: +multmv :: ( Map v a m v' , Num v , Fold v a+ , ZipWith a a a v v v , Num a ) => m -> v -> v' multmv m v = map (dot v) m {-# INLINE multmv #-} --- | matrix * matrix -multmm :: +-- | matrix * matrix+multmm :: (Map v v' m1 m3 ,Map v a b v' ,Transpose m2 b ,Fold v a+ ,ZipWith a a a v v v ,Num v ,Num a ) => m1 -> m2 -> m3@@ -138,7 +151,7 @@ {-# INLINE multmm #-} -- | apply a translation to a projective transformation matrix-translate :: +translate :: (Transpose m mt ,Reverse' () mt (v' :. t) ,Reverse' (v' :. ()) t v'1@@ -147,19 +160,19 @@ ,Num a ,Snoc v a v' ) => v -> m -> m-translate v m = +translate v m = case reverse (transpose m) of- (h:.t) -> transpose (reverse (((homVec v) + h) :. t))+ (h:.t) -> transpose (reverse ((homVec v + h) :. t)) {-# INLINE translate #-} -- | get the @n@-th column as a vector. @n@ is a type-level natural. column :: (Transpose m mt, Access n v mt) => n -> m -> v-column n = get n . transpose +column n = get n . transpose {-# INLINE row #-} -- | get the @n@-th row as a vector. @n@ is a type-level natural. row :: (Access n a v) => n -> v -> a-row n = get n+row = get {-# INLINE column #-} @@ -167,13 +180,13 @@ -- because Transpose` can't do it, the fundeps there can't be bijective -- | matrix transposition-class Transpose a b | a -> b, b -> a where +class Transpose a b | a -> b, b -> a where transpose :: a -> b instance Transpose () () where transpose = id -instance +instance (Vec (Succ n) s (s:.ra) --(s:ra) is an n-vector of s'es (row of a) ,Vec (Succ m) (s:.ra) ((s:.ra):.a) --a is an m-vector of ra's ,Vec (Succ m) s (s:.rb) --rb is an m-vector of s'es (row of b)@@ -190,11 +203,11 @@ class Transpose' a b | a->b where transpose' :: a -> b -instance Transpose' () () where +instance Transpose' () () where transpose' = id {-# INLINE transpose' #-} -instance +instance (Transpose' vs vs') => Transpose' ( () :. vs ) vs' where transpose' (():.vs) = transpose' vs@@ -203,29 +216,29 @@ instance Transpose' ((x:.()):.()) ((x:.()):.()) where transpose' = id -instance +instance (Head xss_h xss_hh ,Map xss_h xss_hh (xss_h:.xss_t) xs' ,Tail xss_h xss_ht ,Map xss_h xss_ht (xss_h:.xss_t) xss_ ,Transpose' (xs :. xss_) xss' )- => Transpose' ((x:.xs):.(xss_h:.xss_t)) ((x:.xs'):.xss') + => Transpose' ((x:.xs):.(xss_h:.xss_t)) ((x:.xs'):.xss') where transpose' ((x:.xs):.xss) =- (x :. (map head xss)) :. (transpose' (xs :. (map tail xss) :: (xs:.xss_)))+ (x :. map head xss) :. transpose' (xs :. map tail xss :: (xs :. xss_)) {-# INLINE transpose' #-} -class SetDiagonal v m | m -> v, v -> m where+class SetDiagonal v m where -- |set the diagonal of an n-by-n matrix to a given n-vector setDiagonal :: v -> m -> m instance (Vec n a v, Vec n r m, SetDiagonal' N0 v m) => SetDiagonal v m where- setDiagonal v m = setDiagonal' (undefined::N0) v m+ setDiagonal = setDiagonal' (undefined :: N0) {-# INLINE setDiagonal #-} class SetDiagonal' n v m where@@ -235,13 +248,13 @@ setDiagonal' _ _ m = m {-# INLINE setDiagonal' #-} -instance +instance ( SetDiagonal' (Succ n) v m , Access n a r- ) => SetDiagonal' n (a:.v) (r:.m) + ) => SetDiagonal' n (a:.v) (r:.m) where- setDiagonal' _ (a:.v) (r:.m) = - (set (undefined::n) a r) :. (setDiagonal' (undefined::Succ n) v m)+ setDiagonal' _ (a:.v) (r:.m) =+ set (undefined :: n) a r :. setDiagonal' (undefined :: Succ n) v m {-# INLINE setDiagonal' #-} @@ -251,43 +264,43 @@ getDiagonal :: m -> v instance (Vec n a v, Vec n v m, GetDiagonal' N0 () m v) => GetDiagonal m v where- getDiagonal m = getDiagonal' (undefined::N0) () m+ getDiagonal = getDiagonal' (undefined :: N0) () {-# INLINE getDiagonal #-} class GetDiagonal' n p m v where getDiagonal' :: n -> p -> m -> v -instance +instance (Access n a r ,Append p (a:.()) (a:.p)- ) => GetDiagonal' n p (r:.()) (a:.p) + ) => GetDiagonal' n p (r:.()) (a:.p) where- getDiagonal' _ p (r:.()) = append p ((get (undefined::n) r) :. ())+ getDiagonal' _ p (r:.()) = append p (get (undefined :: n) r :. ()) {-# INLINE getDiagonal' #-} -instance +instance (Access n a r ,Append p (a:.()) p' ,GetDiagonal' (Succ n) p' (r:.m) v- ) + ) => GetDiagonal' n p (r:.r:.m) v where- getDiagonal' _ p (r:.m) = - getDiagonal' (undefined::Succ n) (append p ((get (undefined::n) r):.())) m+ getDiagonal' _ p (r:.m) =+ getDiagonal' (undefined::Succ n) (append p (get (undefined :: n) r :. ())) m {-# INLINE getDiagonal' #-} -- | @scale v m@ multiplies the diagonal of matrix @m@ by the vector @s@, component-wise. So -- @scale 5 m@ multiplies the diagonal by 5, whereas @scale 2:.1 m@ -- only scales the x component.-scale :: +scale :: ( GetDiagonal' N0 () m r , Num r , Vec n a r , Vec n r m , SetDiagonal' N0 r m ) => r -> m -> m-scale s m = setDiagonal (s * (getDiagonal m)) m+scale s m = setDiagonal (s * getDiagonal m) m {-# INLINE scale #-} @@ -300,7 +313,7 @@ -- | identity matrix (square) identity :: (Vec n a v, Vec n v m, Num v, Num m, SetDiagonal v m) => m-identity = diagonal 1 +identity = diagonal 1 {-# INLINE identity #-} @@ -320,7 +333,7 @@ --- The Determinant of a square matrix, by minor expansion. +-- The Determinant of a square matrix, by minor expansion. class Det' m a | m -> a where det' :: m -> a @@ -330,7 +343,7 @@ -instance +instance ( (a:.a:.v) ~ r -- a row of the matrix, an n-vector , ((a:.a:.v):.(a:.a:.v):.vs) ~ m -- an n*n matrix, n >= 2 , ((a:.v):.(a:.v):.vs_) ~ m_ -- an n*(n-1) matrix@@ -347,20 +360,20 @@ ) => Det' ((a:.a:.v):.(a:.a:.v):.vs) a -- et voila where det' m =- sum $ (negateOdds $ map head m) * map det' (dropConsec $ map tail m)+ sum $ negateOdds (map head m) * map det' (dropConsec $ map tail m) -- DropConsec: Drop consecutive elements, collecting the results. Given an -- n-vector v, drop each element from v, one at a time in sequence, and collect -- the resulting (n-1)-vectors into an n-vector (ie an n-by-(n-1) matrix). -- This is used for determinants.--- +-- -- dropConsec [1,2,3,4] = [[2,3,4],[1,3,4],[1,2,4],[1,2,3]] -- class DropConsec v vv | v -> vv where dropConsec :: v -> vv -instance +instance (Vec n a v ,Pred n n_ ,Vec n_ a v_@@ -368,25 +381,25 @@ ,DropConsec' () v vv ) => DropConsec v vv where- dropConsec v = dropConsec' () v + dropConsec = dropConsec' () {-# INLINE dropConsec #-} class DropConsec' p v vv where dropConsec' :: p -> v -> vv- + instance DropConsec' p (a:.()) (p:.()) where- dropConsec' p (a:.()) = (p:.())+ dropConsec' p (a:.()) = p :. () {-# INLINE dropConsec' #-} -instance +instance (Append p (a:.v) x ,Append p (a:.()) y ,DropConsec' y (a:.v) z- ) + ) => DropConsec' p (a:.a:.v) (x:.z) where- dropConsec' p (a:.v) = - (append p v) :. (dropConsec' (append p (a:.())) v)+ dropConsec' p (a:.v) =+ append p v :. dropConsec' (append p (a :. ())) v {-# INLINE dropConsec' #-} @@ -395,16 +408,16 @@ -- Used for determinants. class NegateOdds v where- negateOdds :: v -> v + negateOdds :: v -> v class NegateEvens v where- negateEvens :: v -> v + negateEvens :: v -> v -instance NegateOdds () where - negateOdds () = () +instance NegateOdds () where+ negateOdds () = () {-# INLINE negateOdds #-}-instance NegateEvens () where - negateEvens () = () +instance NegateEvens () where+ negateEvens () = () {-# INLINE negateEvens #-} instance (Num a, NegateEvens v) => NegateOdds (a:.v) where@@ -427,7 +440,7 @@ class ReplConsec a v vv | v->a, v->vv, vv->v, vv->a where replConsec :: a -> v -> vv -instance +instance (Vec n a v ,Vec n v vv ,ReplConsec' a () v vv@@ -443,15 +456,15 @@ replConsec' _ _ () = () {-# INLINE replConsec' #-} -instance +instance (Append p (a:.v) x ,Append p (a:.()) y ,ReplConsec' a y v z- ) + ) => ReplConsec' a p (a:.v) (x:.z) where- replConsec' r p (a:.v) = - (append p (r:.v)) :. (replConsec' r (append p (a :. ())) v)+ replConsec' r p (a:.v) =+ append p (r :. v) :. replConsec' r (append p (a :. ())) v {-# INLINE replConsec' #-} @@ -463,7 +476,7 @@ -- expression, with no branches or allocations (other than the result). You may -- need to increase the unfolding threshold to see this. -cramer'sRule :: +cramer'sRule :: (Map a a1 b1 v ,Transpose w b1 ,ZipWith a2 b vv v m w@@ -475,9 +488,9 @@ ,Det' a a1 ) => m -> v -> v cramer'sRule m b =- case map (\m' -> (det' m')/(det' m)) - (transpose (zipWith replConsec b m)) - of b' -> b' `asTypeOf` b + case map (\m' -> det' m' / det' m)+ (transpose (zipWith replConsec b m))+ of b' -> b' `asTypeOf` b {-# INLINE cramer'sRule #-} @@ -489,13 +502,10 @@ {-# INLINE mapFst #-} -class (Eq a, Num a) => NearZero a where+class Num a => NearZero a where -- | @nearZero x@ should be true when x is close enough to 0 to cause- -- significant error in division. + -- significant error in division. nearZero :: a -> Bool- nearZero 0 = True- nearZero _ = False- {-# INLINE nearZero #-} instance NearZero Float where nearZero x = abs x < 1e-6@@ -505,82 +515,84 @@ nearZero x = abs x < 1e-14 {-# INLINE nearZero #-} -instance NearZero Rational +instance NearZero Rational where+ nearZero 0 = True+ nearZero _ = False+ {-# INLINE nearZero #-} -- Pivot1 : find a non-zero pivot column and put a 1 there. Second return -- argument tracks value of determinant. Returns nothing if no pivot in the -- first row. Does not try to find the 'best' pivot, only an acceptable one:--- matrices are assumed small, roundoff error should be negligible. +-- matrices are assumed small, roundoff error should be negligible. -class Pivot1 a m where +class Pivot1 a m where pivot1 :: m -> Maybe (m,a) ---this instance prevents a fundep inferring type of a from m. instance Pivot1 a () where pivot1 _ = Nothing -instance - ( Show a, Fractional a, NearZero a- ) => Pivot1 a ((a:.()):.()) +instance+ ( Fractional a, NearZero a+ ) => Pivot1 a ((a:.()):.()) where- pivot1 ((p:._):._) + pivot1 ((p:._):._) | nearZero p = Nothing | otherwise = Just (1,p) {-# INLINE pivot1 #-} -instance - ( Fractional a, NearZero a +instance+ ( Fractional a, NearZero a , Map a a (a:.r) (a:.r)- ) => Pivot1 a ((a:.(a:.r)):.()) + ) => Pivot1 a ((a:.(a:.r)):.()) where- pivot1 ((p:.r):._) + pivot1 ((p:.r):._) | nearZero p = Nothing- | otherwise = Just ((1 :. (map (/p) r)):.(), p)+ | otherwise = Just ((1 :. map (/ p) r):.(), p) {-# INLINE pivot1 #-} -instance +instance ( Fractional a, NearZero a , Map a a (a:.r) (a:.r)- , ZipWith a a a (a:.r) (a:.r) (a:.r) + , ZipWith a a a (a:.r) (a:.r) (a:.r) , Map (a:.r) (a:.r) ((a:.r):.rs) ((a:.r):.rs)- , Pivot1 a ((a:.r):.rs) - ) => Pivot1 a ((a:.r):.(a:.r):.rs) + , Pivot1 a ((a:.r):.rs)+ ) => Pivot1 a ((a:.r):.(a:.r):.rs) where- pivot1 (row@(p:._):.rows) + pivot1 (row@(p:._):.rows) | nearZero p = pivot1 rows >>= \(r:.rs,p)-> Just(r:.row:.rs,p)- | otherwise = Just ( first:.(map add rows) , p)+ | otherwise = Just (first :. map add rows , p) where first = map (/p) row- add r@(x:._) = zipWith (-) r . map (*x) $ first + add r@(x:._) = zipWith (-) r . map (*x) $ first {-# INLINE pivot1 #-} -- Pivot : find a pivot. Second return argument tracks determinant. -- Returns Nothing if no pivot anywhere. -class Pivot a m | m -> a where+class Pivot a m where pivot :: m -> Maybe (m,a) instance Pivot a (():.v) where- pivot _ = Nothing+ pivot m = Nothing {-# INLINE pivot #-} -instance +instance ( Fractional a , NearZero a- , Pivot1 a rs + , Pivot1 a rs , Tail (a:.r) r- , Map (a:.r) r ((a:.r):.rs) (r:.rs') + , Map (a:.r) r ((a:.r):.rs) (r:.rs') , Map r (a:.r) (r:.rs') ((a:.r):.rs) , Pivot1 a ((a:.r):.rs) , Pivot a (r:.rs')- ) => Pivot a ((a:.r):.rs) + ) => Pivot a ((a:.r):.rs) where- pivot m = - mplus (pivot1 m) - (pivot (map tail m) >>= return . mapFst (map (0:.)) )+ pivot m =+ mplus (pivot1 m)+ (liftM (mapFst (map (0 :.))) (pivot (map tail m)) ) {-# INLINE pivot #-} @@ -595,19 +607,19 @@ class GaussElim a m | m -> a where -- | @gaussElim m@ returns a pair @(m',d)@ where @m'@ is @m@ in row echelon -- form and @d@ is the determinant of @m@. The determinant of @m'@ is 1 or 0,- -- i.e., the leading coefficient of each non-zero row is 1. - + -- i.e., the leading coefficient of each non-zero row is 1.+ gaussElim :: m -> (m,a) -instance (Num a, Pivot a (r:.())) => GaussElim a (r:.())+instance (Num a, Pivot a ((a :. r):.())) => GaussElim a ((a :. r):.()) where- gaussElim m = fromMaybe (m,1) (pivot m) + gaussElim m = fromMaybe (m,1) (pivot m) {-# INLINE gaussElim #-} -instance +instance ( Fractional a , Map (a:.r) r ((a:.r):.rs) rs_- , Map r (a:.r) rs_ ((a:.r):.rs) + , Map r (a:.r) rs_ ((a:.r):.rs) , Pivot a ((a:.r):.(a:.r):.rs) , GaussElim a rs_ ) => GaussElim a ((a:.r):.(a:.r):.rs)@@ -615,26 +627,26 @@ gaussElim m = flip (maybe (m,1)) (pivot m) $ \(row:.rows,p) -> case gaussElim (map tail rows)- of (rows',p') -> ( row:.(map (0:.) rows') , p*p')+ of (rows',p') -> ( row :. map (0 :.) rows' , p*p') {-# INLINE gaussElim #-} class BackSubstitute m where -- | backSubstitute takes a full rank matrix from row echelon form to reduced- -- row echelon form. Returns @Nothing@ if the matrix is rank deficient. - backSubstitute :: m -> Maybe m + -- row echelon form. Returns @Nothing@ if the matrix is rank deficient.+ backSubstitute :: m -> Maybe m instance NearZero a => BackSubstitute ((a:.r):.()) where- backSubstitute r@((a:._):._) + backSubstitute r@((a:._):._) | nearZero (1-a) = Just r | otherwise = Nothing {-# INLINE backSubstitute #-} -instance +instance ( Map (a:.r) r ((a:.r):.rs) rs_ --map tail , Map r (a:.r) rs_ ((a:.r):.rs) --map cons- , Fold aas (a,a:.r) + , Fold aas (a,a:.r) , ZipWith a a a (a:.r) (a:.r) (a:.r) , Map a a (a:.r) (a:.r) , ZipWith a (a:.r) (a,a:.r) r ((a:.r):.rs) aas@@ -642,11 +654,10 @@ , BackSubstitute rs_ ) => BackSubstitute ((a:.r):.(a:.r):.rs) where- backSubstitute m@(r@(rh:.rt):.rs) - | nearZero (1-rh) = - liftM (map (0:.)) (backSubstitute . map tail $ rs) >>= \rs' -> - return . (:.rs') . foldl (\v (a,w) -> sub v a w) r $ - zipWith (,) rt rs'+ backSubstitute m@(r@(rh:.rt):.rs)+ | nearZero (1-rh) =+ liftM (map (0:.)) (backSubstitute . map tail $ rs) >>= \rs' ->+ return . (:. rs') . foldl (\ v (a, w) -> sub v a w) r $ zipWith (,) rt rs' | otherwise = Nothing -- rank deficient where sub v a = zipWith (-) v . map (*a) {-# INLINE backSubstitute #-}@@ -657,16 +668,16 @@ class BackSubstitute' m where -- | backSubstitute' takes a full rank matrix from row echelon form to reduced -- row echelon form. Returns garbage is matrix is rank deficient.- backSubstitute' :: m -> m + backSubstitute' :: m -> m instance BackSubstitute' ((a:.r):.()) where backSubstitute' = id {-# INLINE backSubstitute' #-} -instance +instance ( Map (a:.r) r ((a:.r):.rs) rs_ --map tail , Map r (a:.r) rs_ ((a:.r):.rs) --map cons- , Fold aas (a,a:.r) + , Fold aas (a,a:.r) , ZipWith a a a (a:.r) (a:.r) (a:.r) , Map a a (a:.r) (a:.r) , ZipWith a (a:.r) (a,a:.r) r ((a:.r):.rs) aas@@ -674,16 +685,15 @@ , BackSubstitute' rs_ ) => BackSubstitute' ((a:.r):.(a:.r):.rs) where- backSubstitute' (r@(_:.rt):.rs) = - case map (0:.) (backSubstitute' . map tail $ rs) - of rs' -> (:.rs') $ foldl (\ v (a,w) -> sub v a w) r - (zipWith (,) rt rs')+ backSubstitute' (r@(_:.rt):.rs) =+ case map (0:.) (backSubstitute' . map tail $ rs)+ of rs' -> (:.rs') $ foldl (\ v (a,w) -> sub v a w) r (zipWith (,) rt rs') where sub v a = zipWith (-) v . map (*a) {-# INLINE backSubstitute' #-} -- | @invert m@ returns @Just@ the inverse of @m@ or @Nothing@ if @m@ is singular.-invert :: forall n a r m r' m'. +invert :: forall n a r m r' m'. ( Num r, Num m , Vec n a r -- r is row type , Vec n r m -- m is matrix type@@ -695,15 +705,15 @@ , GaussElim a m' , BackSubstitute m' ) => m -> Maybe m-invert m = - return i >>= backSubstitute . fst . gaussElim . zipWith append m - >>= return . map dropn+invert m =+ liftM (map dropn)+ ((backSubstitute . fst . gaussElim . zipWith append m) i) where dropn = drop (undefined::n) i = identity :: m {-# INLINE invert #-} -- | inverse and determinant. If det = 0, inverted matrix is garbage.-invertAndDet :: forall n a r m r' m'. +invertAndDet :: forall n a r m r' m'. ( Num a, Num r, Num m , Vec n a r -- r is row type , Vec n r m -- m is matrix type@@ -715,19 +725,19 @@ , GaussElim a m' , BackSubstitute m' ) => m -> (m,a)-invertAndDet m = +invertAndDet m = case backSubstitute rref of Nothing -> (m,0) Just m' -> ( map dropn m' , d )- where + where (rref,d) = gaussElim . zipWith append m $ i dropn = drop (undefined::n) i = identity :: m {-# INLINE invertAndDet #-} -- | Solution of linear system by Gaussian elimination. Returns @Nothing@--- if no solution. -solve :: forall n a v r m r' m'. +-- if no solution.+solve :: forall n a v r m r' m'. ( Num r, Num m , Vec n a r -- r is row type , Vec n r m -- m is matrix type@@ -738,13 +748,118 @@ , GaussElim a m' , BackSubstitute m' ) => m -> r -> Maybe r-solve m v = - return v >>= backSubstitute . fst . gaussElim . zipWith snoc m - >>= return . map (head . drop (undefined::n)) +solve m v =+ liftM (map (head . drop (undefined :: n)))+ ((backSubstitute . fst . gaussElim . zipWith snoc m) v) {-# INLINE solve #-} ++-- | A 4x4 translation matrix+translation :: Num a => Vec3 a -> Mat44 a+translation = flip translate identity++-- | A 4x4 rotation matrix for a rotation around the X axis+rotationX :: Floating a+ => a -- ^ The angle in radians+ -> Mat44 a+rotationX a = matFromList [1, 0, 0, 0,+ 0, cos a, -sin a, 0,+ 0, sin a, cos a, 0,+ 0, 0, 0, 1]++-- | A 4x4 rotation matrix for a rotation around the Y axis+rotationY :: Floating a+ => a -- ^ The angle in radians+ -> Mat44 a+rotationY a = matFromList [cos a, 0, sin a, 0,+ 0, 1, 0, 0,+ -sin a, 0, cos a, 0,+ 0, 0, 0, 1]++-- | A 4x4 rotation matrix for a rotation around the Z axis+rotationZ :: Floating a+ => a -- ^ The angle in radians+ -> Mat44 a+rotationZ a = matFromList [cos a, -sin a, 0, 0,+ sin a, cos a, 0, 0,+ 0, 0, 1, 0,+ 0, 0, 0, 1]++-- | A 4x4 rotation matrix for a rotation around an arbitrary normalized vector+rotationVec :: Floating a+ => Vec3 a -- ^ The normalized vector around which the rotation goes+ -> a -- ^ The angle in radians+ -> Mat44 a+rotationVec (x:.y:.z:.()) a =+ matFromList [x^2+(1-x^2)*c, x*y*(1-c)-z*s, x*z*(1-c)+y*s, 0,+ x*y*(1-c)+z*s, y^2+(1-y^2)*c, y*z*(1-c)-x*s, 0,+ x*z*(1-c)-y*s, y*z*(1-c)+x*s, z^2+(1-z^2)*c, 0,+ 0, 0, 0, 1]+ where c = cos a+ s = sin a++-- | A 4x4 rotation matrix from the euler angles yaw pitch and roll. Could be useful in e.g.+-- first person shooter games,+rotationEuler :: Floating a+ => Vec3 a -- rotation around x, y and z respectively+ -> Mat44 a+rotationEuler (x:.y:.z:.()) = rotationZ z `multmm` rotationY y `multmm` rotationX x++-- | A 4x4 rotation matrix from a normalized quaternion. Useful for most free flying rotations, such as airplanes.+rotationQuat :: Num a+ => Vec4 a -- ^ The quaternion with the real part (w) last+ -> Mat44 a+rotationQuat (x:.y:.z:.w:.()) =+ matFromList [1-2*y^2-2*z^2, 2*(x*y-z*w), 2*(x*z+y*w), 0,+ 2*(x*y+z*w), 1-2*x^2-2*z^2, 2*(y*z-x*w), 0,+ 2*(x*z-y*w), 2*(x*w+y*z), 1-2*x^2-2*y^2, 0,+ 0, 0, 0, 1]++-- | A 4x4 rotation matrix for turning toward a point. Useful for targeting a camera to a specific point.+rotationLookAt :: Floating a+ => Vec3 a -- ^ The up direction, not necessary unit length or perpendicular to the view vector+ -> Vec3 a -- ^ The viewers position+ -> Vec3 a -- ^ The point to look at+ -> Mat44 a+rotationLookAt up' pos target = transpose $ homVec left :. homVec up :. homVec forward :. homPoint 0 :. ()+ where+ forward = normalize $ pos - target+ left = normalize $ up' `cross` forward+ up = forward `cross`left++-- | A 4x4 scaling matrix+scaling :: Num a => Vec3 a -> Mat44 a+scaling = diagonal . homPoint++-- | A perspective projection matrix for a right handed coordinate system looking down negative z. This will project far plane to @z = +1@ and near plane to @z = -1@, i.e. into a left handed system.+perspective :: Floating a+ => a -- ^ Near plane clipping distance (always positive)+ -> a -- ^ Far plane clipping distance (always positive)+ -> a -- ^ Field of view of the y axis, in radians+ -> a -- ^ Aspect ratio, i.e. screen's width\/height+ -> Mat44 a+perspective n f fovy aspect = matFromList [2*n/(r-l), 0, -(r+l)/(r-l), 0,+ 0, 2*n/(t-b), (t+b)/(t-b), 0,+ 0, 0, -(f+n)/(f-n), -2*f*n/(f-n),+ 0,0,-1,0]+ where+ t = n*tan(fovy/2)+ b = -t+ r = aspect*t+ l = -r++-- | An orthogonal projection matrix for a right handed coordinate system looking down negative z. This will project far plane to @z = +1@ and near plane to @z = -1@, i.e. into a left handed system.+orthogonal :: Fractional a+ => a -- ^ Near plane clipping distance+ -> a -- ^ Far plane clipping distance+ -> Vec2 a -- ^ The size of the view (center aligned around origo)+ -> Mat44 a+orthogonal n f (w:.h:.()) = matFromList [2/w, 0, 0, 0,+ 0, 2/h, 0, 0,+ 0, 0, 2/(f-n), -(f+n)/(f-n),+ 0, 0, 0, 1]
Data/Vec/Packed.hs view
@@ -31,7 +31,7 @@ -- Double)@. The constructor name is also a synonym for the packed type name, -- i.e., @type Vec3D = Packed (Vec3 Double)@, so the packed type acts as if it -- had been declared @data Vec3D = Vec3D x y z@.--- +-- -- 'Storable', 'Num', 'Fractional', 'Fold', 'Map', and 'ZipWith' instances are -- provided for packed vectors, so some operations do not require pack/unpack. -- For example, @'dot'@ does not require pack/unpack because it is defined in@@ -58,52 +58,86 @@ import Data.Word import Data.Int import Foreign+import Foreign.C import Data.Array.Base as Array-import GHC.ST ( ST(..), runST )-import GHC.Prim +import GHC.ST ( ST(..), runST )+import GHC.Prim import GHC.Base ( Int(..) )-import GHC.Word ( Word(..) )-import GHC.Float ( Float(..), Double(..) )-import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) )-import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) )+import GHC.Word ( Word(..) )+import GHC.Float ( Float(..), Double(..) )+import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) )+import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) -- | PackedVec class : relates a vector type to its space-optimized--- representation. +-- representation. class PackedVec v where -- | The packed representation of 'v'- data Packed v + data Packed v pack :: v -> Packed v unpack :: Packed v -> v --who knows if this even does anything-{-# RULES +{-# RULES "Vec pack/unpack" forall x.- pack (unpack x) = x; + pack (unpack x) = x; "Vec unpack/pack" forall x. unpack (pack x) = x; #-} +instance PackedVec (Vec2 Bool) where+ data Packed (Vec2 Bool) = Vec2B !Bool !Bool+ deriving (Eq, Ord, Show, Read)+ pack (a:.b:.()) = Vec2B a b+ unpack (Vec2B a b) = a:.b:.()+ {-# INLINE pack #-}+ {-# INLINE unpack #-} +instance PackedVec (Vec3 Bool) where+ data Packed (Vec3 Bool) = Vec3B !Bool !Bool !Bool+ deriving (Eq, Ord, Show, Read)+ pack (a:.b:.c:.()) = Vec3B a b c+ unpack (Vec3B a b c) = a:.b:.c:.()+ {-# INLINE pack #-}+ {-# INLINE unpack #-} -instance PackedVec (Vec2 Int) where +instance PackedVec (Vec4 Bool) where+ data Packed (Vec4 Bool) = Vec4B !Bool !Bool !Bool !Bool+ deriving (Eq, Ord, Show, Read)+ pack (a:.b:.c:.d:.()) = Vec4B a b c d+ unpack (Vec4B a b c d) = a:.b:.c:.d:.()+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+++type Vec2B = Packed (Vec2 Bool)+type Vec3B = Packed (Vec3 Bool)+type Vec4B = Packed (Vec4 Bool)+++++instance PackedVec (Vec2 Int) where data Packed (Vec2 Int) = Vec2I {-#UNPACK#-} !Int {-#UNPACK#-} !Int- pack (a:.b:.()) = Vec2I a b - unpack (Vec2I a b) = a:.b:.() - {-# INLINE pack #-} - {-# INLINE unpack #-} + deriving (Eq, Ord, Show, Read)+ pack (a:.b:.()) = Vec2I a b+ unpack (Vec2I a b) = a:.b:.()+ {-# INLINE pack #-}+ {-# INLINE unpack #-} -instance PackedVec (Vec3 Int) where - data Packed (Vec3 Int) = Vec3I {-#UNPACK#-} !Int {-#UNPACK#-} !Int {-#UNPACK#-} !Int - pack (a:.b:.c:.()) = Vec3I a b c; +instance PackedVec (Vec3 Int) where+ data Packed (Vec3 Int) = Vec3I {-#UNPACK#-} !Int {-#UNPACK#-} !Int {-#UNPACK#-} !Int+ deriving (Eq, Ord, Show, Read)+ pack (a:.b:.c:.()) = Vec3I a b c; unpack (Vec3I a b c) = a:.b:.c:.();- {-# INLINE pack #-} - {-# INLINE unpack #-} + {-# INLINE pack #-}+ {-# INLINE unpack #-} -instance PackedVec (Vec4 Int) where +instance PackedVec (Vec4 Int) where data Packed (Vec4 Int) = Vec4I {-#UNPACK#-} !Int {-#UNPACK#-} !Int {-#UNPACK#-} !Int {-#UNPACK#-} !Int+ deriving (Eq, Ord, Show, Read) pack (a:.b:.c:.d:.()) = Vec4I a b c d unpack (Vec4I a b c d) = a:.b:.c:.d:.() {-# INLINE pack #-}@@ -117,22 +151,25 @@ -instance PackedVec (Vec2 Float) where +instance PackedVec (Vec2 Float) where data Packed (Vec2 Float) = Vec2F {-#UNPACK#-} !Float {-#UNPACK#-} !Float- pack (a:.b:.()) = Vec2F a b - unpack (Vec2F a b) = a:.b:.() - {-# INLINE pack #-} - {-# INLINE unpack #-} + deriving (Eq, Ord, Show, Read)+ pack (a:.b:.()) = Vec2F a b+ unpack (Vec2F a b) = a:.b:.()+ {-# INLINE pack #-}+ {-# INLINE unpack #-} -instance PackedVec (Vec3 Float) where - data Packed (Vec3 Float) = Vec3F {-#UNPACK#-} !Float {-#UNPACK#-} !Float {-#UNPACK#-} !Float - pack (a:.b:.c:.()) = Vec3F a b c; +instance PackedVec (Vec3 Float) where+ data Packed (Vec3 Float) = Vec3F {-#UNPACK#-} !Float {-#UNPACK#-} !Float {-#UNPACK#-} !Float+ deriving (Eq, Ord, Show, Read)+ pack (a:.b:.c:.()) = Vec3F a b c; unpack (Vec3F a b c) = a:.b:.c:.();- {-# INLINE pack #-} - {-# INLINE unpack #-} + {-# INLINE pack #-}+ {-# INLINE unpack #-} -instance PackedVec (Vec4 Float) where +instance PackedVec (Vec4 Float) where data Packed (Vec4 Float) = Vec4F {-#UNPACK#-} !Float {-#UNPACK#-} !Float {-#UNPACK#-} !Float {-#UNPACK#-} !Float+ deriving (Eq, Ord, Show, Read) pack (a:.b:.c:.d:.()) = Vec4F a b c d unpack (Vec4F a b c d) = a:.b:.c:.d:.() {-# INLINE pack #-}@@ -146,22 +183,25 @@ -instance PackedVec (Vec2 Double) where +instance PackedVec (Vec2 Double) where data Packed (Vec2 Double) = Vec2D {-#UNPACK#-} !Double {-#UNPACK#-} !Double- pack (a:.b:.()) = Vec2D a b - unpack (Vec2D a b) = a:.b:.() - {-# INLINE pack #-} - {-# INLINE unpack #-} + deriving (Eq, Ord, Show, Read)+ pack (a:.b:.()) = Vec2D a b+ unpack (Vec2D a b) = a:.b:.()+ {-# INLINE pack #-}+ {-# INLINE unpack #-} -instance PackedVec (Vec3 Double) where - data Packed (Vec3 Double) = Vec3D {-#UNPACK#-} !Double {-#UNPACK#-} !Double {-#UNPACK#-} !Double - pack (a:.b:.c:.()) = Vec3D a b c; +instance PackedVec (Vec3 Double) where+ data Packed (Vec3 Double) = Vec3D {-#UNPACK#-} !Double {-#UNPACK#-} !Double {-#UNPACK#-} !Double+ deriving (Eq, Ord, Show, Read)+ pack (a:.b:.c:.()) = Vec3D a b c; unpack (Vec3D a b c) = a:.b:.c:.();- {-# INLINE pack #-} - {-# INLINE unpack #-} + {-# INLINE pack #-}+ {-# INLINE unpack #-} -instance PackedVec (Vec4 Double) where +instance PackedVec (Vec4 Double) where data Packed (Vec4 Double) = Vec4D {-#UNPACK#-} !Double {-#UNPACK#-} !Double {-#UNPACK#-} !Double {-#UNPACK#-} !Double+ deriving (Eq, Ord, Show, Read) pack (a:.b:.c:.d:.()) = Vec4D a b c d unpack (Vec4D a b c d) = a:.b:.c:.d:.() {-# INLINE pack #-}@@ -171,6 +211,104 @@ type Vec3D = Packed (Vec3 Double) type Vec4D = Packed (Vec4 Double) +++++instance PackedVec (Vec2 CFloat) where+ data Packed (Vec2 CFloat) = Vec2CF {-# UNPACK #-} !CFloat {-# UNPACK #-} !CFloat+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.()) = Vec2CF x y+ unpack (Vec2CF x y) = x:.y:.()++instance PackedVec (Vec3 CFloat) where+ data Packed (Vec3 CFloat) = Vec3CF {-# UNPACK #-} !CFloat {-# UNPACK #-} !CFloat {-# UNPACK #-} !CFloat+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.z:.()) = Vec3CF x y z+ unpack (Vec3CF x y z) = x:.y:.z:.()++instance PackedVec (Vec4 CFloat) where+ data Packed (Vec4 CFloat) = Vec4CF {-# UNPACK #-} !CFloat {-# UNPACK #-} !CFloat {-# UNPACK #-} !CFloat {-# UNPACK #-} !CFloat+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.z:.w:.()) = Vec4CF x y z w+ unpack (Vec4CF x y z w) = x:.y:.z:.w:.()++type Vec2CF = Packed (Vec2 CFloat)+type Vec3CF = Packed (Vec3 CFloat)+type Vec4CF = Packed (Vec4 CFloat)++++++instance PackedVec (Vec2 CInt) where+ data Packed (Vec2 CInt) = Vec2CI {-# UNPACK #-} !CInt {-# UNPACK #-} !CInt+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.()) = Vec2CI x y+ unpack (Vec2CI x y) = x:.y:.()++instance PackedVec (Vec3 CInt) where+ data Packed (Vec3 CInt) = Vec3CI {-# UNPACK #-} !CInt {-# UNPACK #-} !CInt {-# UNPACK #-} !CInt+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.z:.()) = Vec3CI x y z+ unpack (Vec3CI x y z) = x:.y:.z:.()++instance PackedVec (Vec4 CInt) where+ data Packed (Vec4 CInt) = Vec4CI {-# UNPACK #-} !CInt {-# UNPACK #-} !CInt {-# UNPACK #-} !CInt {-# UNPACK #-} !CInt+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.z:.w:.()) = Vec4CI x y z w+ unpack (Vec4CI x y z w) = x:.y:.z:.w:.()++type Vec2CI = Packed (Vec2 CInt)+type Vec3CI = Packed (Vec3 CInt)+type Vec4CI = Packed (Vec4 CInt)+++++instance PackedVec (Vec2 CDouble) where+ data Packed (Vec2 CDouble) = Vec2CD {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.()) = Vec2CD x y+ unpack (Vec2CD x y) = x:.y:.()++instance PackedVec (Vec3 CDouble) where+ data Packed (Vec3 CDouble) = Vec3CD {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.z:.()) = Vec3CD x y z+ unpack (Vec3CD x y z) = x:.y:.z:.()++instance PackedVec (Vec4 CDouble) where+ data Packed (Vec4 CDouble) = Vec4CD {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble {-# UNPACK #-} !CDouble+ deriving (Eq, Ord, Show, Read)+ {-# INLINE pack #-}+ {-# INLINE unpack #-}+ pack (x:.y:.z:.w:.()) = Vec4CD x y z w+ unpack (Vec4CD x y z w) = x:.y:.z:.w:.()++type Vec2CD = Packed (Vec2 CDouble)+type Vec3CD = Packed (Vec3 CDouble)+type Vec4CD = Packed (Vec4 CDouble)++++ type Mat22D = Vec2 (Vec2D) type Mat23D = Vec2 (Vec3D) type Mat24D = Vec2 (Vec4D)@@ -180,29 +318,16 @@ -- | Construct a semi-packed matrix, one whose rows are packed.-packMat :: (Map row (Packed row) mat packedMat, PackedVec row) +packMat :: (Map row (Packed row) mat packedMat, PackedVec row) => mat -> packedMat packMat = map pack -unpackMat :: (Map (Packed row) row packedMat mat, PackedVec row) +unpackMat :: (Map (Packed row) row packedMat mat, PackedVec row) => packedMat -> mat unpackMat = map unpack -instance (Eq v, PackedVec v) => Eq (Packed v) where- u == v = unpack u == unpack v- u /= v = unpack u /= unpack v- {-# INLINE (==) #-}- {-# INLINE (/=) #-}--instance (Ord v, PackedVec v) => Ord (Packed v) where- compare u v = compare (unpack u) (unpack v)- {-# INLINE compare #-}--instance (Show v, PackedVec v) => Show (Packed v) where- show v = show (unpack v)--instance (Map a b u v, PackedVec u, PackedVec v) - => Map a b (Packed u) (Packed v) +instance (Map a b u v, PackedVec u, PackedVec v)+ => Map a b (Packed u) (Packed v) where map f = pack . map f . unpack {-# INLINE map #-}@@ -222,9 +347,9 @@ zipWith f u v = pack $ zipWith f (unpack u) (unpack v) {-# INLINE zipWith #-} -instance (Num v, PackedVec v) => Num (Packed v) +instance (Num v, PackedVec v) => Num (Packed v) where- (+) u v = pack (unpack u + unpack v) + (+) u v = pack (unpack u + unpack v) (-) u v = pack (unpack u - unpack v) (*) u v = pack (unpack u * unpack v) abs u = pack (abs (unpack u))@@ -236,7 +361,7 @@ {-# INLINE abs #-} {-# INLINE signum #-} {-# INLINE fromInteger #-}- + instance (Fractional v, PackedVec v) => Fractional (Packed v) where (/) u v = pack (unpack u / unpack v)@@ -277,7 +402,7 @@ {-# INLINE head #-} instance (Tail v t, PackedVec v, PackedVec t) => Tail (Packed v) (Packed t)- where + where tail v = pack (tail (unpack v)) {-# INLINE tail #-} @@ -286,25 +411,25 @@ last v = last (unpack v) {-# INLINE last #-} -instance (Snoc v a v', PackedVec v, PackedVec v') +instance (Snoc v a v', PackedVec v, PackedVec v') => Snoc (Packed v) a (Packed v') where snoc v a = pack (snoc (unpack v) a) {-# INLINE snoc #-} -instance (Reverse' () v v', PackedVec v, PackedVec v') +instance (Reverse' () v v', PackedVec v, PackedVec v') => Reverse' () (Packed v) (Packed v') where reverse' _ v = pack (reverse (unpack v)) {-# INLINE reverse' #-} -instance (Take (Succ n) v v', PackedVec v, PackedVec v') +instance (Take (Succ n) v v', PackedVec v, PackedVec v') => Take (Succ n) (Packed v) (Packed v') where take n v = pack (take n (unpack v)) {-# INLINE take #-} -instance (Drop n v v', PackedVec v, PackedVec v') +instance (Drop n v v', PackedVec v, PackedVec v') => Drop n (Packed v) (Packed v') where drop n v = pack (drop n (unpack v))@@ -336,18 +461,18 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-}- unsafeNewArray_ (l,u) = + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (\x# -> x# *# vaSizeOf# (undefined::a:.v) ) {-# INLINE newArray_ #-} newArray_ arrBounds = Array.newArray arrBounds (pack init#) {-# INLINE unsafeRead #-}- unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# -> - case vaRead# marr# (vaLength# (undefined::a:.v) *# i#) s1# of + unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# ->+ case vaRead# marr# (vaLength# (undefined::a:.v) *# i#) s1# of (# s2, v #) -> (# s2, pack v #) {-# INLINE unsafeWrite #-} unsafeWrite (STUArray _ _ _ marr#) (I# i#) v = ST $ \s1# ->- case vaWrite# marr# (vaLength# (undefined::a:.v) *# i#) (unpack v) s1# of - s2# -> (# s2#, () #) + case vaWrite# marr# (vaLength# (undefined::a:.v) *# i#) (unpack v) s1# of+ s2# -> (# s2#, () #) instance (VecArrayRW (a:.v), PackedVec (a:.v)) => IArray UArray (Packed (a:.v)) where {-# INLINE bounds #-}
Vec.cabal view
@@ -1,10 +1,10 @@ Name: Vec-Version: 0.9.9+Version: 1.0.5 License: BSD3 License-file: LICENSE Author: Scott E. Dillard Maintainer: Scott E. Dillard <sedillard@gmail.com>-Homepage: http://graphics.cs.ucdavis.edu/~sdillard/Vec+Homepage: http://github.net/sedillard/Vec Stability: Experimental Synopsis: Fixed-length lists and low-dimensional linear algebra. Description: