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