Ticket #2416: TheModule.hs

File TheModule.hs, 3.9 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
14module TheModule where
15import Prelude hiding (head,map,foldl,foldr,zipWith)
16import qualified Prelude as P
17import Foreign
18
19
20
21
22-- the generic vector type : a fixed-length list
23
24data a :. b = !a :. !b
25  deriving (Eq,Ord,Read,Show)
26
27infixr :.
28
29type Vec2  a = a :. a :. ()
30type Vec3  a = a :. (Vec2 a)
31type Vec4  a = a :. (Vec3 a)
32type Mat44 a = Vec4 (Vec4 a)
33
34
35
36
37
38dot u v = fold (+) (zipWith (*) u v)
39{-# INLINE dot #-}
40
41multmv m v = map (dot v) m
42{-# INLINE multmv #-}
43
44
45
46-- basic vector functions : map,fold,zipWith
47
48class Map a b u v | u -> a, v -> b, b u -> v, a v -> u where
49  map :: (a -> b) -> u -> v
50
51instance Map a b (a :. ()) (b :. ()) where
52  map f (x :. ()) = (f x) :. ()
53  {-# INLINE map #-}
54
55instance Map a b (a':.u) (b':.v) => Map a b (a:.a':.u) (b:.b':.v) where
56  map f (x:.v) = (f x):.(map f v)
57  {-# INLINE map #-}
58
59
60class ZipWith a b c u v w | u->a, v->b, w->c, u v c -> w where
61  zipWith :: (a -> b -> c) -> u -> v -> w
62
63instance ZipWith a b c (a:.()) (b:.()) (c:.()) where
64  zipWith f (x:._) (y:._) = f x y :.()
65  {-# INLINE zipWith #-}
66
67instance ZipWith a b c (a:.()) (b:.b:.bs) (c:.()) where
68  zipWith f (x:._) (y:._) = f x y :.()
69  {-# INLINE zipWith #-}
70
71instance ZipWith a b c (a:.a:.as) (b:.()) (c:.()) where
72  zipWith f (x:._) (y:._) = f x y :.()
73  {-# INLINE zipWith #-}
74
75instance
76  ZipWith a b c (a':.u) (b':.v) (c':.w)
77  => ZipWith a b c (a:.a':.u) (b:.b':.v) (c:.c':.w)
78    where
79      zipWith f (x:.u) (y:.v) = f x y :. zipWith f u v
80      {-# INLINE zipWith #-}
81
82
83class Fold a v | v -> a where
84  fold  :: (a -> a -> a) -> v -> a
85  foldl :: (b -> a -> b) -> b -> v -> b
86  foldr :: (a -> b -> b) -> b -> v -> b
87
88instance Fold a (a:.()) where
89  fold  f   (a:._) = a
90  foldl f z (a:._) = f z a
91  foldr f z (a:._) = f a z
92  {-# INLINE fold #-}
93  {-# INLINE foldl #-}
94  {-# INLINE foldr #-}
95
96instance Fold a (a':.u) => Fold a (a:.a':.u) where
97  fold  f   (a:.v) = f a (fold f v)
98  foldl f z (a:.v) = f (foldl f z v) a
99  foldr f z (a:.v) = f a (foldr f z v)
100  {-# INLINE fold #-}
101  {-# INLINE foldl #-}
102  {-# INLINE foldr #-}
103
104
105-- storable instances for vectors
106
107instance Storable a => Storable (a:.()) where
108  sizeOf _ = sizeOf (undefined::a)
109  alignment _ = alignment (undefined::a)
110  peek !p = peek (castPtr p) >>= \a -> return (a:.())
111  peekByteOff !p !o = peek (p`plusPtr`o)
112  peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::a)))
113  poke !p (a:._) = poke (castPtr p) a
114  pokeByteOff !p !o !x = poke (p`plusPtr`o) x
115  pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::a))) x
116  {-# INLINE sizeOf #-}
117  {-# INLINE alignment #-}
118  {-# INLINE peek #-}
119  {-# INLINE peekByteOff #-}
120  {-# INLINE peekElemOff #-}
121  {-# INLINE poke #-}
122  {-# INLINE pokeByteOff #-}
123  {-# INLINE pokeElemOff #-}
124
125instance (Storable a, Storable (a:.v)) 
126  => Storable (a:.a:.v) 
127  where
128  sizeOf _ = sizeOf (undefined::a) + sizeOf (undefined::(a:.v))
129  alignment _ = alignment (undefined::a)
130  peek !p = 
131    peek (castPtr p) >>= \a -> 
132    peek (castPtr (p`plusPtr`sizeOf(undefined::a))) >>= \v -> 
133    return (a:.v)
134  peekByteOff !p !o = peek (p`plusPtr`o)
135  peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v))))
136  poke !p (a:.v) = 
137    poke (castPtr p) a >> 
138    poke (castPtr (p`plusPtr`sizeOf(undefined::a))) v
139  pokeByteOff !p !o !x = poke (p`plusPtr`o) x
140  pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::(a:.a:.v)))) x
141  {-# INLINE sizeOf #-}
142  {-# INLINE alignment #-}
143  {-# INLINE peek #-}
144  {-# INLINE peekByteOff #-}
145  {-# INLINE peekElemOff #-}
146  {-# INLINE poke #-}
147  {-# INLINE pokeByteOff #-}
148  {-# INLINE pokeElemOff #-}
149
150