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