75568f0b04d95035b46a092b07e06497adf83be3
[packages/hpc.git] / tests / raytrace / Eval.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 Eval where
7
8 import Array
9
10 import Geometry
11 import CSG
12 import Surface
13 import Data
14 import Parse (rayParse, rayParseF)
15
16 class Monad m => MonadEval m where
17 doOp :: PrimOp -> GMLOp -> Stack -> m Stack
18 tick :: m ()
19 err :: String -> m a
20
21 tick = return ()
22
23 newtype Pure a = Pure a deriving Show
24
25 instance Monad Pure where
26 Pure x >>= k = k x
27 return = Pure
28 fail s = error s
29
30 instance MonadEval Pure where
31 doOp = doPureOp
32 err s = error s
33
34 instance MonadEval IO where
35 doOp prim op stk = do { -- putStrLn ("Calling " ++ show op
36 -- ++ " << " ++ show stk ++ " >>")
37 doAllOp prim op stk
38 }
39 err s = error s
40
41 data State
42 = State { env :: Env
43 , stack :: Stack
44 , code :: Code
45 } deriving Show
46
47 callback :: Env -> Code -> Stack -> Stack
48 callback env code stk
49 = case eval (State { env = env, stack = stk, code = code}) of
50 Pure stk -> stk
51
52 {-# SPECIALIZE eval :: State -> Pure Stack #-}
53 {-# SPECIALIZE eval :: State -> IO Stack #-}
54
55 eval :: MonadEval m => State -> m Stack
56 eval st =
57 do { () <- return () -- $ unsafePerformIO (print st) -- Functional debugger
58 ; if moreCode st then
59 do { tick -- tick first, so as to catch loops on new eval.
60 ; st' <- step st
61 ; eval st'
62 }
63 else return (stack st)
64 }
65
66 moreCode :: State -> Bool
67 moreCode (State {code = []}) = False
68 moreCode _ = True
69
70 -- Step has a precondition that there *is* code to run
71 {-# SPECIALIZE step :: State -> Pure State #-}
72 {-# SPECIALIZE step :: State -> IO State #-}
73 step :: MonadEval m => State -> m State
74
75 -- Rule 1: Pushing BaseValues
76 step st@(State{ stack = stack, code = (TBool b):cs })
77 = return (st { stack = (VBool b):stack, code = cs })
78 step st@(State{ stack = stack, code = (TInt i):cs })
79 = return (st { stack = (VInt i):stack, code = cs })
80 step st@(State{ stack = stack, code = (TReal r):cs })
81 = return (st { stack = (VReal r):stack, code = cs })
82 step st@(State{ stack = stack, code = (TString s):cs })
83 = return (st { stack = (VString s):stack, code = cs })
84
85 -- Rule 2: Name binding
86 step st@(State{ env = env, stack = (v:stack), code = (TBind id):cs }) =
87 return (State { env = extendEnv env id v, stack = stack, code = cs })
88 step st@(State{ env = env, stack = [], code = (TBind id):cs }) =
89 err "Attempt to bind the top of an empty stack"
90
91 -- Rule 3: Name lookup
92 step st@(State{ env = env, stack = stack, code = (TId id):cs }) =
93 case (lookupEnv env id) of
94 Just v -> return (st { stack = v:stack, code = cs })
95 Nothing -> err ("Cannot find value for identifier: " ++ id)
96
97 -- Rule 4: Closure creation
98 step st@(State{ env = env, stack = stack, code = (TBody body):cs }) =
99 return (st { stack = (VClosure env body):stack, code = cs })
100
101 -- Rule 5: Application
102 step st@(State{ env = env, stack = (VClosure env' code'):stack, code = TApply:cs }) =
103 do { stk <- eval (State {env = env', stack = stack, code = code'})
104 ; return (st { stack = stk, code = cs })
105 }
106 step st@(State{ env = env, stack = [], code = TApply:cs }) =
107 err "Application with an empty stack"
108 step st@(State{ env = env, stack = _:_, code = TApply:cs }) =
109 err "Application of a non-closure"
110
111 -- Rule 6: Arrays
112 step st@(State{ env = env, stack = stack, code = TArray code':cs }) =
113 do { stk <- eval (State {env = env, stack = [], code = code'})
114 ; let last = length stk-1
115 ; let arr = array (0,last) (zip [last,last-1..] stk)
116 ; return (st { stack = (VArray arr):stack, code = cs })
117 }
118
119 -- Rule 7 & 8: If statement
120 step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool True):stack, code = TIf:cs }) =
121 do { stk <- eval (State {env = e1, stack = stack, code = c1})
122 ; return (st { stack = stk, code = cs })
123 }
124 step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool False):stack, code = TIf:cs }) =
125 do { stk <- eval (State {env = e2, stack = stack, code = c2})
126 ; return (st { stack = stk, code = cs })
127 }
128 step st@(State{ env = env, stack = _, code = TIf:cs }) =
129 err "Incorrect use of if (bad and/or inappropriate values on the stack)"
130
131 -- Rule 9: Operators
132 step st@(State{ env = env, stack = stack, code = (TOp op):cs }) =
133 do { stk <- doOp (opFnTable ! op) op stack
134 ; return (st { stack = stk, code = cs })
135 }
136
137 -- Rule Opps
138 step _ = err "Tripped on sidewalk while stepping."
139
140
141 --------------------------------------------------------------------------
142 -- Operator code
143
144 opFnTable :: Array GMLOp PrimOp
145 opFnTable = array (minBound,maxBound)
146 [ (op,prim) | (_,TOp op,prim) <- opcodes ]
147
148
149
150
151 doPureOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
152 doPureOp _ Op_render _ =
153 err ("\nAttempting to call render from inside a purely functional callback.")
154 doPureOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators
155
156 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Pure Stack #-}
157 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> IO Stack #-}
158 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Abs Stack #-}
159
160 doPrimOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
161
162 -- 1 argument.
163
164 doPrimOp (Int_Int fn) _ (VInt i1:stk)
165 = return ((VInt (fn i1)) : stk)
166 doPrimOp (Real_Real fn) _ (VReal r1:stk)
167 = return ((VReal (fn r1)) : stk)
168 doPrimOp (Point_Real fn) _ (VPoint x y z:stk)
169 = return ((VReal (fn x y z)) : stk)
170
171 -- This is where the callbacks happen from...
172 doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)
173 = case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of
174 Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] ->
175 let
176 res = prop (color c1 c2 c3) r1 r2 r3
177 in
178 return ((VObject (fn (SConst res))) : stk)
179 _ -> return ((VObject (fn (SFun call))) : stk)
180 where
181 -- The most general case
182 call i r1 r2 =
183 case callback env code [VReal r2,VReal r1,VInt i] of
184 [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3]
185 -> prop (color c1 c2 c3) r1 r2 r3
186 stk -> error ("callback failed: incorrectly typed return arguments"
187 ++ show stk)
188
189 doPrimOp (Real_Int fn) _ (VReal r1:stk)
190 = return ((VInt (fn r1)) : stk)
191 doPrimOp (Int_Real fn) _ (VInt r1:stk)
192 = return ((VReal (fn r1)) : stk)
193 doPrimOp (Arr_Int fn) _ (VArray arr:stk)
194 = return ((VInt (fn arr)) : stk)
195
196 -- 2 arguments.
197
198 doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk)
199 = return ((VInt (fn i1 i2)) : stk)
200 doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk)
201 = return ((VBool (fn i1 i2)) : stk)
202 doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk)
203 = return ((VReal (fn r1 r2)) : stk)
204 doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk)
205 = return ((VBool (fn r1 r2)) : stk)
206 doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk)
207 = return ((fn arr i) : stk)
208
209
210 -- Many arguments, typically image mangling
211
212 doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk)
213 = return ((VObject (fn o1 o2)) : stk)
214 doPrimOp (Point_Color_Light fn) _ (VPoint r g b:VPoint x y z : stk)
215 = return (VLight (fn (x,y,z) (color r g b)) : stk)
216 doPrimOp (Point_Point_Color_Real_Real_Light fn) _
217 (VReal r2:VReal r1:VPoint r g b:VPoint x2 y2 z2:VPoint x1 y1 z1 : stk)
218 = return (VLight (fn (x1,y1,z1) (x2,y2,z2) (color r g b) r1 r2) : stk)
219 doPrimOp (Real_Real_Real_Point fn) _ (VReal r3:VReal r2:VReal r1:stk)
220 = return ((fn r1 r2 r3) : stk)
221 doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk)
222 = return (VObject (fn o r) : stk)
223 doPrimOp (Obj_Real_Real_Real_Obj fn) _ (VReal r3:VReal r2:VReal r1:VObject o:stk)
224 = return (VObject (fn o r1 r2 r3) : stk)
225
226 -- This one is our testing harness
227 doPrimOp (Value_String_Value fn) _ (VString s:o:stk)
228 = res `seq` return (res : stk)
229 where
230 res = fn o s
231
232 doPrimOp primOp op args
233 = err ("\n\ntype error when attempting to execute builtin primitive \"" ++
234 show op ++ "\"\n\n| " ++
235 show op ++ " takes " ++ show (length types) ++ " argument" ++ s
236 ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++
237 " " ++ unwords [ show ty | ty <- types ] ++ "\n|\n|" ++
238 " currently, the relevent argument" ++ s ++ " on the stack " ++
239 are ++ "\n|\n| " ++
240 unwords [ "(" ++ show arg ++ ")"
241 | arg <- reverse (take (length types) args) ] ++ "\n|\n| "
242 ++ " (top of stack is on the right hand side)\n\n")
243 where
244 len = length types
245 s = (if len /= 1 then "s" else "")
246 are = (if len /= 1 then "are" else "is")
247 the = (if len /= 1 then "" else " the")
248 types = getPrimOpType primOp
249
250
251 -- Render is somewhat funny, becauase it can only get called at top level.
252 -- All other operations are purely functional.
253
254 doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack
255 doAllOp (Render render) Op_render
256 (VString str:VInt ht:VInt wid:VReal fov
257 :VInt dep:VObject obj:VArray arr
258 :VPoint r g b : stk)
259 = do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str
260 ; return stk
261 }
262 where
263 lights = [ light | (VLight light) <- elems arr ]
264
265 doAllOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators
266
267 ------------------------------------------------------------------------------
268 {-
269 - Abstract evaluation.
270 -
271 - The idea is you check for constant code that
272 - (1) does not look at its arguments
273 - (2) gives a fixed result
274 -
275 - We run for 100 steps.
276 -
277 -}
278
279 absapply :: Env -> Code -> Stack -> Maybe Stack
280 absapply env code stk =
281 case runAbs (eval (State env stk code)) 100 of
282 AbsState stk _ -> Just stk
283 AbsFail m -> Nothing
284
285 newtype Abs a = Abs { runAbs :: Int -> AbsState a }
286 data AbsState a = AbsState a !Int
287 | AbsFail String
288
289 instance Monad Abs where
290 (Abs fn) >>= k = Abs (\ s -> case fn s of
291 AbsState r s' -> runAbs (k r) s'
292 AbsFail m -> AbsFail m)
293 return x = Abs (\ n -> AbsState x n)
294 fail s = Abs (\ n -> AbsFail s)
295
296 instance MonadEval Abs where
297 doOp = doAbsOp
298 err = fail
299 tick = Abs (\ n -> if n <= 0
300 then AbsFail "run out of time"
301 else AbsState () (n-1))
302
303 doAbsOp :: PrimOp -> GMLOp -> Stack -> Abs Stack
304 doAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk)
305 = return ((VPoint r1 r2 r3) : stk)
306 -- here, you could have an (AbsPoint :: AbsObj) which you put on the
307 -- stack, with any object in the three fields.
308 doAbsOp _ op _ = err ("operator not understood (" ++ show op ++ ")")
309
310 ------------------------------------------------------------------------------
311 -- Driver
312
313 mainEval :: Code -> IO ()
314 mainEval prog = do { stk <- eval (State emptyEnv [] prog)
315 ; return ()
316 }
317 {-
318 * Oops, one of the example actually has something
319 * on the stack at the end.
320 * Oh well...
321 ; if null stk
322 then return ()
323 else do { putStrLn done
324 ; print stk
325 }
326 -}
327
328 done = "Items still on stack at (successfull) termination of program"
329
330 ------------------------------------------------------------------------------
331 -- testing
332
333 test :: String -> Pure Stack
334 test is = eval (State emptyEnv [] (rayParse is))
335
336 testF :: String -> IO Stack
337 testF is = do prog <- rayParseF is
338 eval (State emptyEnv [] prog)
339
340 testA :: String -> Either String (Stack,Int)
341 testA is = case runAbs (eval (State emptyEnv
342 [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV]
343 (rayParse is))) 100 of
344 AbsState a n -> Right (a,n)
345 AbsFail m -> Left m
346
347 abstest1 = "1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply"
348
349 -- should be [3:: Int]
350 et1 = test "1 /x { x } /f 2 /x f apply x addi"
351
352
353
354
355