add Galois' Ray Tracer
[nofib.git] / parallel / gray / Data.hs
1 -- Copyright (c) 2000 Galois Connections, Inc.
2 -- All rights reserved. This software is distributed as
3 -- free software under the license in the file "LICENSE",
4 -- which is included in the distribution.
5
6 module Data where
7
8 import Array
9
10 import CSG
11 import Geometry
12 import Illumination
13 import Primitives
14 import Surface
15
16 import Debug.Trace
17
18 -- Now the parsed (expresssion) language
19
20 type Name = String
21
22 type Code = [GMLToken]
23
24 data GMLToken
25 -- All these can occur in parsed code
26 = TOp GMLOp
27 | TId Name
28 | TBind Name
29 | TBool Bool
30 | TInt Int
31 | TReal Double
32 | TString String
33 | TBody Code
34 | TArray Code
35 | TApply
36 | TIf
37 -- These can occur in optimized/transformed code
38 -- NONE (yet!)
39
40
41 instance Show GMLToken where
42 showsPrec p (TOp op) = shows op
43 showsPrec p (TId id) = showString id
44 showsPrec p (TBind id) = showString ('/' : id)
45 showsPrec p (TBool bool) = shows bool
46 showsPrec p (TInt i) = shows i
47 showsPrec p (TReal d) = shows d
48 showsPrec p (TString s) = shows s
49 showsPrec p (TBody code) = shows code
50 showsPrec p (TArray code) = showString "[ "
51 . foldr (\ a b -> a . showChar ' ' . b) id (map shows code)
52 . showString "]"
53 showsPrec p (TApply) = showString "apply"
54 showsPrec p (TIf) = showString "if"
55
56 showList code = showString "{ "
57 . foldr (\ a b -> a . showChar ' ' . b) id (map shows code)
58 . showString "}"
59
60
61 -- Now the value language, used inside the interpreter
62
63 type Stack = [GMLValue]
64
65 data GMLValue
66 = VBool !Bool
67 | VInt !Int
68 | VReal !Double
69 | VString String
70 | VClosure Env Code
71 | VArray (Array Int GMLValue) -- FIXME: Haskell array
72 -- uses the interpreter version of point
73 | VPoint { xPoint :: !Double
74 , yPoint :: !Double
75 , zPoint :: !Double
76 }
77 -- these are abstract to the interpreter
78 | VObject Object
79 | VLight Light
80 -- This is an abstract object, used by the abstract interpreter
81 | VAbsObj AbsObj
82
83
84 -- There are only *3* basic abstract values,
85 -- and the combinators also.
86
87 data AbsObj
88 = AbsFACE
89 | AbsU
90 | AbsV
91 deriving (Show)
92
93 instance Show GMLValue where
94 showsPrec p value = showString (showStkEle value)
95
96 showStkEle :: GMLValue -> String
97 showStkEle (VBool b) = show b ++ " :: Bool"
98 showStkEle (VInt i) = show i ++ " :: Int"
99 showStkEle (VReal r) = show r ++ " :: Real"
100 showStkEle (VString s) = show s ++ " :: String"
101 showStkEle (VClosure {}) = "<closure> :: Closure"
102 showStkEle (VArray arr)
103 = "<array (" ++ show (succ (snd (bounds arr))) ++ " elements)> :: Array"
104 showStkEle (VPoint x y z) = "(" ++ show x
105 ++ "," ++ show y
106 ++ "," ++ show z
107 ++ ") :: Point"
108 showStkEle (VObject {}) = "<Object> :: Object"
109 showStkEle (VLight {}) = "<Light> :: Object"
110 showStkEle (VAbsObj vobs) = "{{ " ++ show vobs ++ "}} :: AbsObj"
111
112 -- An abstract environment
113
114 newtype Env = Env [(Name, GMLValue)] deriving Show
115
116 emptyEnv :: Env
117 emptyEnv = Env []
118
119 extendEnv :: Env -> Name -> GMLValue -> Env
120 extendEnv (Env e) n v = Env ((n, v):e)
121
122 lookupEnv :: Env -> Name -> Maybe GMLValue
123 lookupEnv (Env e) n = lookup n e
124
125 -- All primitive operators
126 --
127 -- There is no Op_apply, Op_false, Op_true and Op_if
128 -- (because they appear explcitly in the rules).
129
130 data GMLOp
131 = Op_acos
132 | Op_addi
133 | Op_addf
134 | Op_asin
135 | Op_clampf
136 | Op_cone
137 | Op_cos
138 | Op_cube
139 | Op_cylinder
140 | Op_difference
141 | Op_divi
142 | Op_divf
143 | Op_eqi
144 | Op_eqf
145 | Op_floor
146 | Op_frac
147 | Op_get
148 | Op_getx
149 | Op_gety
150 | Op_getz
151 | Op_intersect
152 | Op_length
153 | Op_lessi
154 | Op_lessf
155 | Op_light
156 | Op_modi
157 | Op_muli
158 | Op_mulf
159 | Op_negi
160 | Op_negf
161 | Op_plane
162 | Op_point
163 | Op_pointlight
164 | Op_real
165 | Op_render
166 | Op_rotatex
167 | Op_rotatey
168 | Op_rotatez
169 | Op_scale
170 | Op_sin
171 | Op_sphere
172 | Op_spotlight
173 | Op_sqrt
174 | Op_subi
175 | Op_subf
176 | Op_trace -- non standard, for debugging GML programs
177 | Op_translate
178 | Op_union
179 | Op_uscale
180 deriving (Eq,Ord,Ix,Bounded)
181
182 instance Show GMLOp where
183 showsPrec _ op = showString (opNameTable ! op)
184
185
186 ------------------------------------------------------------------------------
187
188 -- And how we use the op codes (there names, there interface)
189
190 -- These keywords include, "apply", "if", "true" and "false",
191 -- they are not parsed as operators, but are
192 -- captured by the parser as a special case.
193
194 keyWords :: [String]
195 keyWords = [ kwd | (kwd,_,_) <- opcodes ]
196
197 -- Lookup has to look from the start (or else...)
198 opTable :: [(Name,GMLToken)]
199 opTable = [ (kwd,op) | (kwd,op,_) <- opcodes ]
200
201 opNameTable :: Array GMLOp Name
202 opNameTable = array (minBound,maxBound)
203 [ (op,name) | (name,TOp op,_) <- opcodes ]
204
205 undef = error "undefined function"
206 image = error "undefined function: talk to image group"
207
208 -- typically, its best to have *one* opcode table,
209 -- so that mis-alignments do not happen.
210
211 opcodes :: [(String,GMLToken,PrimOp)]
212 opcodes =
213 [ ("apply", TApply, error "incorrect use of apply")
214 , ("if", TIf, error "incorrect use of if")
215 , ("false", TBool False, error "incorrect use of false")
216 , ("true", TBool True, error "incorrect use of true")
217 ] ++ map (\ (a,b,c) -> (a,TOp b,c))
218 -- These are just invocation, any coersions need to occur between here
219 -- and before arriving at the application code (like deg -> rad).
220 [ ("acos", Op_acos, Real_Real (rad2deg . acos))
221 , ("addi", Op_addi, Int_Int_Int (+))
222 , ("addf", Op_addf, Real_Real_Real (+))
223 , ("asin", Op_asin, Real_Real (rad2deg . asin))
224 , ("clampf", Op_clampf, Real_Real clampf)
225 , ("cone", Op_cone, Surface_Obj cone)
226 , ("cos", Op_cos, Real_Real (cos . deg2rad))
227 , ("cube", Op_cube, Surface_Obj cube)
228 , ("cylinder", Op_cylinder, Surface_Obj cylinder)
229 , ("difference", Op_difference, Obj_Obj_Obj difference)
230 , ("divi", Op_divi, Int_Int_Int (ourQuot))
231 , ("divf", Op_divf, Real_Real_Real (/))
232 , ("eqi", Op_eqi, Int_Int_Bool (==))
233 , ("eqf", Op_eqf, Real_Real_Bool (==))
234 , ("floor", Op_floor, Real_Int floor)
235 , ("frac", Op_frac, Real_Real (snd . properFraction))
236 , ("get", Op_get, Arr_Int_Value ixGet)
237 , ("getx", Op_getx, Point_Real (\ x y z -> x))
238 , ("gety", Op_gety, Point_Real (\ x y z -> y))
239 , ("getz", Op_getz, Point_Real (\ x y z -> z))
240 , ("intersect", Op_intersect, Obj_Obj_Obj intersect)
241 , ("length", Op_length, Arr_Int (succ . snd . bounds))
242 , ("lessi", Op_lessi, Int_Int_Bool (<))
243 , ("lessf", Op_lessf, Real_Real_Bool (<))
244 , ("light", Op_light, Point_Color_Light light)
245 , ("modi", Op_modi, Int_Int_Int (ourRem))
246 , ("muli", Op_muli, Int_Int_Int (*))
247 , ("mulf", Op_mulf, Real_Real_Real (*))
248 , ("negi", Op_negi, Int_Int negate)
249 , ("negf", Op_negf, Real_Real negate)
250 , ("plane", Op_plane, Surface_Obj plane)
251 , ("point", Op_point, Real_Real_Real_Point VPoint)
252 , ("pointlight", Op_pointlight, Point_Color_Light pointlight)
253 , ("real", Op_real, Int_Real fromIntegral)
254 , ("render", Op_render, Render $ render eye)
255 , ("rotatex", Op_rotatex, Obj_Real_Obj (\ o d -> rotateX (deg2rad d) o))
256 , ("rotatey", Op_rotatey, Obj_Real_Obj (\ o d -> rotateY (deg2rad d) o))
257 , ("rotatez", Op_rotatez, Obj_Real_Obj (\ o d -> rotateZ (deg2rad d) o))
258 , ("scale", Op_scale, Obj_Real_Real_Real_Obj (\ o x y z -> scale (x,y,z) o))
259 , ("sin", Op_sin, Real_Real (sin . deg2rad))
260 , ("sphere", Op_sphere, Surface_Obj sphere') -- see comment at end of file
261 , ("spotlight", Op_spotlight, Point_Point_Color_Real_Real_Light mySpotlight)
262 , ("sqrt", Op_sqrt, Real_Real ourSqrt)
263 , ("subi", Op_subi, Int_Int_Int (-))
264 , ("subf", Op_subf, Real_Real_Real (-))
265 , ("trace", Op_trace, Value_String_Value mytrace)
266 , ("translate", Op_translate, Obj_Real_Real_Real_Obj (\ o x y z -> translate (x,y,z) o))
267 , ("union", Op_union, Obj_Obj_Obj union)
268 , ("uscale", Op_uscale, Obj_Real_Obj (\ o r -> uscale r o))
269 ]
270
271 -- This enumerate all possible ways of calling the fixed primitives
272
273 -- The datatype captures the type at the *interp* level,
274 -- the type of the functional is mirrored on this (using Haskell types).
275
276 data PrimOp
277
278 -- 1 argument
279 = Int_Int (Int -> Int)
280 | Real_Real (Double -> Double)
281 | Point_Real (Double -> Double -> Double -> Double)
282 | Surface_Obj (SurfaceFn Color Double -> Object)
283 | Real_Int (Double -> Int)
284 | Int_Real (Int -> Double)
285 | Arr_Int (Array Int GMLValue -> Int)
286
287 -- 2 arguments
288 | Int_Int_Int (Int -> Int -> Int)
289 | Int_Int_Bool (Int -> Int -> Bool)
290 | Real_Real_Real (Double -> Double -> Double)
291 | Real_Real_Bool (Double -> Double -> Bool)
292 | Arr_Int_Value (Array Int GMLValue -> Int -> GMLValue)
293
294 -- Many arguments, typically image mangling
295
296 | Obj_Obj_Obj (Object -> Object -> Object)
297 | Point_Color_Light (Coords -> Color -> Light)
298 | Real_Real_Real_Point (Double -> Double -> Double -> GMLValue)
299 | Obj_Real_Obj (Object -> Double -> Object)
300 | Obj_Real_Real_Real_Obj (Object -> Double -> Double -> Double -> Object)
301 | Value_String_Value (GMLValue -> String -> GMLValue)
302
303 | Point_Point_Color_Real_Real_Light
304 (Coords -> Coords -> Color -> Radian -> Radian -> Light)
305 -- And finally render
306 | Render (Color -> [Light] -> Object -> Int -> Double -> Int -> Int -> String -> IO ())
307
308 data Type
309 = TyBool
310 | TyInt
311 | TyReal
312 | TyString
313 | TyCode
314 | TyArray
315 | TyPoint
316 | TyObject
317 | TyLight
318 | TyAlpha
319 | TyAbsObj
320 deriving (Eq,Ord,Ix,Bounded)
321
322 typeTable =
323 [ ( TyBool, "Bool")
324 , ( TyInt, "Int")
325 , ( TyReal, "Real")
326 , ( TyString, "String")
327 , ( TyCode, "Code")
328 , ( TyArray, "Array")
329 , ( TyPoint, "Point")
330 , ( TyObject, "Object")
331 , ( TyLight, "Light")
332 , ( TyAlpha, "<anything>")
333 , ( TyAbsObj, "<abs>")
334 ]
335
336 typeNames = array (minBound,maxBound) typeTable
337
338 instance Show Type where
339 showsPrec _ op = showString (typeNames ! op)
340
341 getPrimOpType :: PrimOp -> [Type]
342 getPrimOpType (Int_Int _) = [TyInt]
343 getPrimOpType (Real_Real _) = [TyReal]
344 getPrimOpType (Point_Real _) = [TyPoint]
345 getPrimOpType (Surface_Obj _) = [TyCode]
346 getPrimOpType (Real_Int _) = [TyReal]
347 getPrimOpType (Int_Real _) = [TyInt]
348 getPrimOpType (Arr_Int _) = [TyArray]
349 getPrimOpType (Int_Int_Int _) = [TyInt,TyInt]
350 getPrimOpType (Int_Int_Bool _) = [TyInt,TyInt]
351 getPrimOpType (Real_Real_Real _) = [TyReal,TyReal]
352 getPrimOpType (Real_Real_Bool _) = [TyReal,TyReal]
353 getPrimOpType (Arr_Int_Value _) = [TyArray,TyInt]
354 getPrimOpType (Obj_Obj_Obj _) = [TyObject,TyObject]
355 getPrimOpType (Point_Color_Light _) = [TyPoint,TyPoint]
356 getPrimOpType (Real_Real_Real_Point _) = [TyReal,TyReal,TyReal]
357 getPrimOpType (Obj_Real_Obj _) = [TyObject,TyReal]
358 getPrimOpType (Obj_Real_Real_Real_Obj _) = [TyObject,TyReal,TyReal,TyReal]
359 getPrimOpType (Value_String_Value _) = [TyAlpha,TyString]
360 getPrimOpType (Point_Point_Color_Real_Real_Light _)
361 = [TyPoint,TyPoint,TyPoint,TyReal,TyReal]
362 getPrimOpType (Render _) = [TyPoint,
363 TyLight,
364 TyObject,
365 TyInt,
366 TyReal,
367 TyReal,
368 TyReal,
369 TyString]
370
371
372 -- Some primitives with better error message
373
374 mytrace v s = trace (s ++" : "++ show v ++ "\n") v
375
376
377 ixGet :: Array Int GMLValue -> Int -> GMLValue
378 ixGet arr i
379 | inRange (bounds arr) i = arr ! i
380 | otherwise = error ("failed access with index value "
381 ++ show i
382 ++ " (should be between 0 and "
383 ++ show (snd (bounds arr)) ++ ")")
384
385 ourQuot :: Int -> Int -> Int
386 ourQuot _ 0 = error "attempt to use divi to divide by 0"
387 ourQuot a b = a `quot` b
388
389 ourRem :: Int -> Int -> Int
390 ourRem _ 0 = error "attempt to use remi to divide by 0"
391 ourRem a b = a `rem` b
392
393 ourSqrt :: Double -> Double
394 ourSqrt n | n < 0 = error "attempt to use sqrt on a negative number"
395 | otherwise = sqrt n
396
397
398 mySpotlight p1 p2 col cutoff exp = spotlight p1 p2 col (deg2rad cutoff) exp
399
400 -- The problem specification gets the mapping for spheres backwards
401 -- (it maps the image from right to left).
402 -- We've fixed that in the raytracing library so that it goes from left
403 -- to right, but to keep the GML front compatible with the problem
404 -- statement, we reverse it here.
405
406 sphere' :: SurfaceFn Color Double -> CSG (SurfaceFn Color Double)
407 sphere' (SFun f) = sphere (SFun (\i u v -> f i (1 - u) v))
408 sphere' s = sphere s