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 Data.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   -- entered oncetick = return ()
   22 
   23 newtype Pure a = Pure a deriving -- never entered-- never enteredShow
   24 
   25 instance Monad Pure where
   26     -- entered 10,417,773 timesPure x >>= k = k x
   27     -- entered oncereturn       = Pure
   28     -- never enteredfail s       = error s
   29 
   30 instance MonadEval Pure where
   31   -- entered oncedoOp   = doPureOp
   32   -- never enterederr  s = error s
   33 
   34 instance MonadEval IO where
   35   -- entered 14 timesdoOp prim op stk = do { -- putStrLn ("Calling " ++ show op
   36                           --           ++ " << " ++ show stk ++ " >>")
   37                           doAllOp  prim op stk
   38                         }
   39   -- never enterederr  s = error s
   40 
   41 data State
   42         = State { env   :: Env
   43                 , stack :: Stack
   44                 , code  :: Code
   45                 } deriving -- never entered-- never enteredShow
   46 
   47 callback :: Env -> Code -> Stack -> Stack
   48 -- entered 32,512 timescallback 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 -- entered 3,328,798 timeseval 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 -- entered 3,328,798 timesmoreCode (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 -- entered 3,059,036 timesstep 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 -- entered onceopFnTable = array (minBound,maxBound)
  146                   [ (op,prim) | (_,TOp op,prim) <- opcodes ]
  147 
  148 
  149 
  150 
  151 doPureOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
  152 -- entered 746,091 timesdoPureOp _ 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 -- entered 746,104 timesdoPrimOp (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 -- entered 14 timesdoAllOp (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 -- entered 2 timesabsapply 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     -- entered 54 times(Abs fn) >>= k = Abs (\ s -> case fn s of
  291                                    AbsState r s' -> runAbs (k r) s'
  292                                    AbsFail m     -> AbsFail m)
  293     -- entered 15 timesreturn x     = Abs (\ n -> AbsState x n)
  294     -- entered 2 timesfail s       = Abs (\ n -> AbsFail s)
  295 
  296 instance MonadEval Abs where
  297   -- entered oncedoOp = doAbsOp
  298   -- entered onceerr  = fail
  299   -- entered oncetick = 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 -- entered 2 timesdoAbsOp _ 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 -- entered oncemainEval 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 -- never entereddone = "Items still on stack at (successfull) termination of program"
  329 
  330 ------------------------------------------------------------------------------
  331 -- testing
  332 
  333 test :: String -> Pure Stack
  334 -- never enteredtest is = eval (State emptyEnv [] (rayParse is))
  335 
  336 testF :: String -> IO Stack
  337 -- never enteredtestF is = do prog <- rayParseF is
  338               eval (State emptyEnv [] prog)
  339 
  340 testA :: String -> Either String (Stack,Int)
  341 -- never enteredtestA 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 -- never enteredabstest1 = "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 -- never enteredet1 = test "1 /x { x } /f 2 /x f apply x addi"
  351 
  352 
  353 
  354 
  355