Ticket #2416: Both.hs

File Both.hs, 4.4 KB (added by sedillard, 6 years ago)
Line 
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE NoMonomorphismRestriction #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE TypeSynonymInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13
14import Prelude hiding (map,foldl,foldr,zipWith)
15import Foreign
16import Control.Monad
17import System
18
19
20main =
21  do
22  n <- return . read . head =<< getArgs
23  a <- mallocArray n
24  b <- mallocArray n
25  c <- mallocArray n
26  forM_ [0..n-1] $ \i -> pokeElemOff a i m4
27  forM_ [0..n-1] $ \i -> pokeElemOff b i v4
28  forM_ [0..n-1] $ \i ->
29    peekElemOff a i >>= \ai ->
30      peekElemOff b i >>= \bi ->
31        pokeElemOff c i (multmv ai bi)
32  peekElemOff c 0 >>= print
33
34m4 = (1:.2:.3:.4:.()):.
35     (5:.6:.7:.7:.()):.
36     (9:.10:.11:.12:.()):.
37     (13:.13:.15:.16:.()):.() :: Mat44 Double
38
39v4 = 4:.3:.2:.1:.() :: Vec4 Double
40
41
42
43dot u v = fold (+) (zipWith (*) u v)
44{-# INLINE dot #-}
45
46multmv m v = map (dot v) m
47{-# INLINE multmv #-}
48
49
50-- the generic vector type : a fixed-length list
51
52data a :. b = !a :. !b
53  deriving (Eq,Ord,Read,Show)
54
55infixr :.
56
57type Vec2  a = a :. a :. ()
58type Vec3  a = a :. (Vec2 a)
59type Vec4  a = a :. (Vec3 a)
60type Mat44 a = Vec4 (Vec4 a)
61
62
63
64
65
66
67
68
69-- basic vector functions : map,fold,zipWith
70
71class Map a b u v | u -> a, v -> b, b u -> v, a v -> u where
72  map :: (a -> b) -> u -> v
73
74instance Map a b (a :. ()) (b :. ()) where
75  map f (x :. ()) = (f x) :. ()
76  {-# INLINE map #-}
77
78instance Map a b (a':.u) (b':.v) => Map a b (a:.a':.u) (b:.b':.v) where
79  map f (x:.v) = (f x):.(map f v)
80  {-# INLINE map #-}
81
82
83class ZipWith a b c u v w | u->a, v->b, w->c, u v c -> w where
84  zipWith :: (a -> b -> c) -> u -> v -> w
85
86instance ZipWith a b c (a:.()) (b:.()) (c:.()) where
87  zipWith f (x:._) (y:._) = f x y :.()
88  {-# INLINE zipWith #-}
89
90instance ZipWith a b c (a:.()) (b:.b:.bs) (c:.()) where
91  zipWith f (x:._) (y:._) = f x y :.()
92  {-# INLINE zipWith #-}
93
94instance ZipWith a b c (a:.a:.as) (b:.()) (c:.()) where
95  zipWith f (x:._) (y:._) = f x y :.()
96  {-# INLINE zipWith #-}
97
98instance
99  ZipWith a b c (a':.u) (b':.v) (c':.w)
100  => ZipWith a b c (a:.a':.u) (b:.b':.v) (c:.c':.w)
101    where
102      zipWith f (x:.u) (y:.v) = f x y :. zipWith f u v
103      {-# INLINE zipWith #-}
104
105
106class Fold a v | v -> a where
107  fold  :: (a -> a -> a) -> v -> a
108  foldl :: (b -> a -> b) -> b -> v -> b
109  foldr :: (a -> b -> b) -> b -> v -> b
110
111instance Fold a (a:.()) where
112  fold  f   (a:._) = a
113  foldl f z (a:._) = f z a
114  foldr f z (a:._) = f a z
115  {-# INLINE fold #-}
116  {-# INLINE foldl #-}
117  {-# INLINE foldr #-}
118
119instance Fold a (a':.u) => Fold a (a:.a':.u) where
120  fold  f   (a:.v) = f a (fold f v)
121  foldl f z (a:.v) = f (foldl f z v) a
122  foldr f z (a:.v) = f a (foldr f z v)
123  {-# INLINE fold #-}
124  {-# INLINE foldl #-}
125  {-# INLINE foldr #-}
126
127
128-- storable instances for vectors
129
130instance Storable a => Storable (a:.()) where
131  sizeOf _ = sizeOf (undefined::a)
132  alignment _ = alignment (undefined::a)
133  peek !p = peek (castPtr p) >>= \a -> return (a:.())
134  peekByteOff !p !o = peek (p`plusPtr`o)
135  peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::a)))
136  poke !p (a:._) = poke (castPtr p) a
137  pokeByteOff !p !o !x = poke (p`plusPtr`o) x
138  pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::a))) x
139  {-# INLINE sizeOf #-}
140  {-# INLINE alignment #-}
141  {-# INLINE peek #-}
142  {-# INLINE peekByteOff #-}
143  {-# INLINE peekElemOff #-}
144  {-# INLINE poke #-}
145  {-# INLINE pokeByteOff #-}
146  {-# INLINE pokeElemOff #-}
147
148instance (Storable a, Storable (a:.v)) 
149  => Storable (a:.a:.v) 
150  where
151  sizeOf _ = sizeOf (undefined::a) + sizeOf (undefined::(a:.v))
152  alignment _ = alignment (undefined::a)
153  peek !p = 
154    peek (castPtr p) >>= \a -> 
155    peek (castPtr (p`plusPtr`sizeOf(undefined::a))) >>= \v -> 
156    return (a:.v)
157  peekByteOff !p !o = peek (p`plusPtr`o)
158  peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v))))
159  poke !p (a:.v) = 
160    poke (castPtr p) a >> 
161    poke (castPtr (p`plusPtr`sizeOf(undefined::a))) v
162  pokeByteOff !p !o !x = poke (p`plusPtr`o) x
163  pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v)))) x
164  {-# INLINE sizeOf #-}
165  {-# INLINE alignment #-}
166  {-# INLINE peek #-}
167  {-# INLINE peekByteOff #-}
168  {-# INLINE peekElemOff #-}
169  {-# INLINE poke #-}
170  {-# INLINE pokeByteOff #-}
171  {-# INLINE pokeElemOff #-}
172
173
174