summaryrefslogtreecommitdiff
path: root/examples/Static.hs
diff options
context:
space:
mode:
authorAlberto Ruiz <aruiz@um.es>2007-10-01 18:52:46 +0000
committerAlberto Ruiz <aruiz@um.es>2007-10-01 18:52:46 +0000
commitd925bada507562250a75587c409bdb35bbbc6ed8 (patch)
tree3c83410ce29de563f55b00923298494d9a7c64d9 /examples/Static.hs
parentc99b8fd6e3f8a2fb365ec12baf838f864b118ece (diff)
misc examples
Diffstat (limited to 'examples/Static.hs')
-rw-r--r--examples/Static.hs104
1 files changed, 104 insertions, 0 deletions
diff --git a/examples/Static.hs b/examples/Static.hs
new file mode 100644
index 0000000..c4856f5
--- /dev/null
+++ b/examples/Static.hs
@@ -0,0 +1,104 @@
1{-# OPTIONS_GHC -fglasgow-exts -fth -fallow-overlapping-instances -fallow-undecidable-instances #-}
2
3module Static where
4
5import Language.Haskell.TH
6import Numeric.LinearAlgebra
7import Foreign
8import Language.Haskell.TH.Syntax
9
10instance Lift Double where
11 lift x = return (LitE (RationalL (toRational x)))
12
13--instance (Lift a, Storable a) => Lift (Vector a ) where
14
15tdim :: Int -> ExpQ
16tdim 0 = [| Z |]
17tdim n = [| S $(tdim (n-1)) |]
18
19
20data Z = Z deriving Show
21data S a = S a deriving Show
22
23class Dim a
24
25instance Dim Z
26instance Dim a => Dim (S a)
27
28class Sum a b c | a b -> c -- , a c -> b, b c -> a
29
30instance Sum Z a a
31instance Sum a Z a
32instance Sum a b c => Sum a (S b) (S c)
33
34newtype SVec d t = SVec (Vector t) deriving Show
35newtype SMat r c t = SMat (Matrix t) deriving Show
36
37createl :: d -> [Double] -> SVec d Double
38createl d l = SVec (fromList l)
39
40createv :: Storable t => d -> Vector t -> SVec d t
41createv d v = SVec v
42
43--vec'' v = [|createv ($(tdim (dim v))) v|]
44
45vec' :: [Double] -> ExpQ
46vec' d = [| createl ($(tdim (length d))) d |]
47
48
49createml :: (Dim r, Dim c) => r -> c -> Int -> Int -> [Double] -> SMat r c Double
50createml _ _ r c l = SMat ((r><c) l)
51
52mat :: Int -> Int -> [Double] -> ExpQ
53mat r c l = [| createml ($(tdim r)) ($(tdim c)) r c l |]
54
55vec :: [Double] -> ExpQ
56vec d = [|mat (length d) 1 d|]
57
58covec :: [Double] -> ExpQ
59covec d = mat 1 (length d) d
60
61scalar :: SMat (S Z) (S Z) Double -> Double
62scalar (SMat m) = flatten m @> 0
63
64v = fromList [1..5] :: Vector Double
65l = [1,1.5..5::Double]
66
67k = [11..30::Int]
68
69rawv (SVec v) = v
70raw (SMat m) = m
71
72liftStatic :: (Matrix a -> Matrix b -> Matrix c) -> SMat dr dc a -> SMat dr dc b -> SMat dr dc c
73liftStatic f a b = SMat (f (raw a) (raw b))
74
75a |+| b = liftStatic (+) a b
76
77prod :: SMat r k Double -> SMat k c Double -> SMat r c Double
78prod a b = SMat (raw a <> raw b)
79
80strans :: SMat r c Double -> SMat c r Double
81strans = SMat . trans . raw
82
83sdot a b = scalar (prod a b)
84
85jv :: (Field t, Sum r1 r2 r3) => SMat r1 c t -> SMat r2 c t -> SMat r3 c t
86jv a b = SMat ((raw a) <-> (raw b))
87
88-- curiously, we cannot easily fold jv because the matrics are not of the same type.
89
90jh a b = strans (jv (strans a) (strans b))
91
92
93homog :: (Field t) => SMat r c t -> SMat (S r) c t
94homog m = SMat (raw m <-> constant 1 (cols (raw m)))
95
96inhomog :: (Linear Vector t) => SMat (S (S r)) c t -> SMat r c t
97inhomog (SMat m) = SMat (sm <> d) where
98 sm = takeRows r' m
99 d = diag $ 1 / (flatten $ dropRows r' m)
100 r' = rows m -1
101
102
103ht t vs = inhomog (t `prod` homog vs)
104