  Copyright ( c ) 2000 Galois Connections , Inc.
-- All rights reserved.  This software is distributed as
-- free software under the license in the file "LICENSE",
-- which is included in the distribution.

module Eval where

import Control.Monad
import Data.Array

import Geometry
import CSG
import Surface
import Data
import Parse (rayParse, rayParseF)

class Monad m => MonadEval m where
  doOp :: PrimOp -> GMLOp -> Stack -> m Stack
  tick :: m ()
  err  :: String -> m a

  tick = return ()

newtype Pure a = Pure a deriving Show

instance Functor Pure where
    fmap = liftM

instance Applicative Pure where
    pure = Pure
    (<*>) = ap

instance Monad Pure where
    Pure x >>= k = k x
    return       = pure

instance MonadEval Pure where
  doOp   = doPureOp
  err  s = error s

instance MonadEval IO where
  doOp prim op stk = do { -- putStrLn ("Calling " ++ show op
                          --           ++ " << " ++ show stk ++ " >>")
                          doAllOp  prim op stk
                        }
  err  s = error s

data State
        = State { env   :: Env
                , stack :: Stack
                , code  :: Code
                } deriving Show

callback :: Env -> Code -> Stack -> Stack
callback env code stk
      = case eval (State { env = env, stack = stk, code = code}) of
             Pure stk -> stk

# SPECIALIZE eval : :   State - > Pure Stack #
# SPECIALIZE eval : :   State - > IO Stack #

eval :: MonadEval m => State -> m Stack
eval st =
  do { () <- return () -- $ unsafePerformIO (print st)   -- Functional debugger
     ; if moreCode st then
  tick first , so as to catch loops on new eval .
            ; st' <- step st
            ; eval st'
            }
        else return (stack st)
     }

moreCode :: State -> Bool
moreCode (State {code = []}) = False
moreCode _                   = True

-- Step has a precondition that there *is* code to run
# SPECIALIZE step : :   State - > Pure State #
# SPECIALIZE step : :   State - > IO State #
step :: MonadEval m => State -> m State

  Rule 1 : Pushing BaseValues
step st@(State{ stack = stack, code = (TBool b):cs })
    = return (st { stack = (VBool b):stack,    code = cs })
step st@(State{ stack = stack, code = (TInt i):cs })
    = return (st { stack = (VInt i):stack,     code = cs })
step st@(State{ stack = stack, code = (TReal r):cs })
    = return (st { stack = (VReal r):stack,    code = cs })
step st@(State{ stack = stack, code = (TString s):cs })
    = return (st { stack = (VString s):stack,  code = cs })

  Rule 2 : Name binding
step st@(State{ env = env, stack = (v:stack), code = (TBind id):cs }) =
  return (State { env = extendEnv env id v, stack = stack,  code = cs })
step st@(State{ env = env, stack = [], code = (TBind id):cs }) =
  err "Attempt to bind the top of an empty stack"

  Rule 3 : Name lookup
step st@(State{ env = env, stack = stack, code = (TId id):cs }) =
  case (lookupEnv env id) of
  Just v -> return (st { stack = v:stack,  code = cs })
  Nothing -> err ("Cannot find value for identifier: " ++ id)

-- Rule 4: Closure creation
step st@(State{ env = env, stack = stack, code = (TBody body):cs }) =
  return (st { stack = (VClosure env body):stack, code = cs })

-- Rule 5: Application
step st@(State{ env = env, stack = (VClosure env' code'):stack, code = TApply:cs }) =
  do { stk <- eval (State {env = env', stack = stack, code = code'})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = [], code = TApply:cs }) =
  err "Application with an empty stack"
step st@(State{ env = env, stack = _:_, code = TApply:cs }) =
  err "Application of a non-closure"

  Rule 6 : Arrays
step st@(State{ env = env, stack = stack, code = TArray code':cs }) =
  do { stk <- eval (State {env = env, stack = [], code = code'})
     ; let last = length stk-1
     ; let arr = array (0,last) (zip [last,last-1..] stk)
     ; return (st { stack = (VArray arr):stack, code = cs })
     }

-- Rule 7 & 8: If statement
step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool True):stack, code = TIf:cs }) =
  do { stk <- eval (State {env = e1, stack = stack, code = c1})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool False):stack, code = TIf:cs }) =
  do { stk <- eval (State {env = e2, stack = stack, code = c2})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = _, code = TIf:cs }) =
  err "Incorrect use of if (bad and/or inappropriate values on the stack)"

  Rule 9 : Operators
step st@(State{ env = env, stack = stack, code = (TOp op):cs }) =
  do { stk <- doOp (opFnTable ! op) op stack
     ; return (st { stack = stk, code = cs })
     }

-- Rule Opps
step _ = err "Tripped on sidewalk while stepping."


--------------------------------------------------------------------------
-- Operator code

opFnTable :: Array GMLOp PrimOp
opFnTable = array (minBound,maxBound)
                  [ (op,prim) | (_,TOp op,prim) <- opcodes ]




doPureOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
doPureOp _ Op_render _ =
    err ("\nAttempting to call render from inside a purely functional callback.")
doPureOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators

# SPECIALIZE doPrimOp : : PrimOp - > GMLOp - > Stack - > Pure Stack #
# SPECIALIZE doPrimOp : : PrimOp - > GMLOp - > Stack - > IO Stack #
# SPECIALIZE doPrimOp : : PrimOp - > GMLOp - > Stack - > Abs Stack #

doPrimOp ::  (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack

  1 argument .

doPrimOp (Int_Int fn) _ (VInt i1:stk)
  = return ((VInt (fn i1)) : stk)
doPrimOp (Real_Real fn) _ (VReal r1:stk)
  = return ((VReal (fn r1)) : stk)
doPrimOp (Point_Real fn) _ (VPoint x y z:stk)
  = return ((VReal (fn x y z)) : stk)

-- This is where the callbacks happen from...
doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)
  = case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of
      Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] ->
           let
               res = prop (color c1 c2 c3) r1 r2 r3
           in
               return ((VObject (fn (SConst res))) : stk)
      _ -> return ((VObject (fn (SFun call))) : stk)
  where
        -- The most general case
        call i r1 r2 =
          case callback env code [VReal r2,VReal r1,VInt i] of
             [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3]
                 -> prop (color c1 c2 c3) r1 r2 r3
             stk -> error ("callback failed: incorrectly typed return arguments"
                         ++ show stk)

doPrimOp (Real_Int fn) _ (VReal r1:stk)
  = return ((VInt (fn r1)) : stk)
doPrimOp (Int_Real fn) _ (VInt r1:stk)
  = return ((VReal (fn r1)) : stk)
doPrimOp (Arr_Int fn) _ (VArray arr:stk)
  = return ((VInt (fn arr)) : stk)

  2 arguments .

doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk)
  = return ((VInt (fn i1 i2)) : stk)
doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk)
  = return ((VBool (fn i1 i2)) : stk)
doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk)
  = return ((VReal (fn r1 r2)) : stk)
doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk)
  = return ((VBool (fn r1 r2)) : stk)
doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk)
  = return ((fn arr i) : stk)


    -- Many arguments, typically image mangling

doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk)
  = return ((VObject (fn o1 o2)) : stk)
doPrimOp (Point_Color_Light fn) _ (VPoint r g b:VPoint x y z : stk)
  = return (VLight (fn (x,y,z) (color r g b)) : stk)
doPrimOp (Point_Point_Color_Real_Real_Light fn) _
         (VReal r2:VReal r1:VPoint r g b:VPoint x2 y2 z2:VPoint x1 y1 z1 : stk)
  = return (VLight (fn (x1,y1,z1) (x2,y2,z2) (color r g b) r1 r2) : stk)
doPrimOp (Real_Real_Real_Point fn) _ (VReal r3:VReal r2:VReal r1:stk)
  = return ((fn r1 r2 r3) : stk)
doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk)
  = return (VObject (fn o r) : stk)
doPrimOp (Obj_Real_Real_Real_Obj fn) _ (VReal r3:VReal r2:VReal r1:VObject o:stk)
  = return (VObject (fn o r1 r2 r3) : stk)

-- This one is our testing harness
doPrimOp (Value_String_Value fn) _ (VString s:o:stk)
  = res `seq` return (res : stk)
  where
     res = fn o s

doPrimOp primOp op args
  = err ("\n\ntype error when attempting to execute builtin primitive \"" ++
          show op ++ "\"\n\n| " ++
          show op ++ " takes " ++ show (length types) ++ " argument" ++ s
                   ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++
          "      " ++ unwords [ show ty | ty <- types ]  ++ "\n|\n|" ++
          " currently, the relevant argument" ++ s ++ " on the stack " ++
                  are ++ "\n|\n| " ++
          unwords [ "(" ++ show arg ++ ")"
                  | arg <-  reverse (take (length types) args) ]  ++ "\n|\n| "
          ++ "    (top of stack is on the right hand side)\n\n")
  where
      len   = length types
      s =  (if len /= 1 then "s" else "")
      are =  (if len /= 1 then "are" else "is")
      the =  (if len /= 1 then "" else " the")
      types = getPrimOpType primOp


-- Render is somewhat funny, because it can only get called at top level.
-- All other operations are purely functional.

doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack
doAllOp (Render render) Op_render
                           (VString str:VInt ht:VInt wid:VReal fov
                           :VInt dep:VObject obj:VArray arr
                           :VPoint r g b : stk)
  = do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str
       ; return stk
       }
  where
      lights = [ light | (VLight light) <- elems arr ]

doAllOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators

------------------------------------------------------------------------------

  - Abstract evaluation . 
  - 
  - The idea is you check for constant code that 
  - ( 1 ) does not look at its arguments 
  - ( 2 ) gives a fixed result 
  - 
  - We run for 100 steps . 
  - 
 
 - Abstract evaluation.
 -
 - The idea is you check for constant code that
 - (1) does not look at its arguments
 - (2) gives a fixed result
 -
 - We run for 100 steps.
 -
 -}

absapply :: Env -> Code -> Stack -> Maybe Stack
absapply env code stk =
     case runAbs (eval (State env stk code)) 100 of
       AbsState stk _ -> Just stk
       AbsFail m      -> Nothing

newtype Abs a   = Abs { runAbs :: Int -> AbsState a }
data AbsState a = AbsState a !Int
                | AbsFail String

instance Functor Abs where
    fmap = liftM

instance Applicative Abs where
    pure x = Abs (\ n -> AbsState x n)
    (<*>) = ap

instance Monad Abs where
    (Abs fn) >>= k = Abs (\ s -> case fn s of
                                   AbsState r s' -> runAbs (k r) s'
                                   AbsFail m     -> AbsFail m)
    return       = pure

instance MonadFail Abs where
    fail s       = Abs (\ n -> AbsFail s)

instance MonadEval Abs where
  doOp = doAbsOp
  err  = fail
  tick = Abs (\ n -> if n <= 0
                     then AbsFail "run out of time"
                     else AbsState () (n-1))

doAbsOp :: PrimOp -> GMLOp -> Stack -> Abs Stack
doAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk)
               = return ((VPoint r1 r2 r3) : stk)
 -- here, you could have an (AbsPoint :: AbsObj) which you put on the
  stack , with any object in the three fields .
doAbsOp _ op _ = err ("operator not understood (" ++ show op ++ ")")

------------------------------------------------------------------------------
-- Driver

mainEval :: Code -> IO ()
mainEval prog = do { stk <- eval (State emptyEnv [] prog)
                   ; return ()
                   }

   * Oops , one of the example actually has something 
   * on the stack at the end . 
   * Oh well ... 
                    ; if null stk 
                      then return ( ) 
                      else do { putStrLn done 
                              ; print stk 
                              } 

  * Oops, one of the example actually has something
  * on the stack at the end.
  * Oh well...
                   ; if null stk
                     then return ()
                     else do { putStrLn done
                             ; print stk
                             }
-}

done = "Items still on stack at (successful) termination of program"

------------------------------------------------------------------------------
-- testing

test :: String -> Pure Stack
test is = eval (State emptyEnv [] (rayParse is))

testF :: String -> IO Stack
testF is = do prog <- rayParseF is
              eval (State emptyEnv [] prog)

testA :: String -> Either String (Stack,Int)
testA is = case runAbs (eval (State emptyEnv
                                    [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV]
                                    (rayParse is))) 100 of
             AbsState a n -> Right (a,n)
             AbsFail m -> Left m

abstest1 = "1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply"

  should be [ 3 : : Int ]
et1 = test "1 /x { x } /f 2 /x f apply x addi"






 All rights reserved.  This software is distributed as
 free software under the license in the file "LICENSE",
 which is included in the distribution.
 putStrLn ("Calling " ++ show op
           ++ " << " ++ show stk ++ " >>")
 $ unsafePerformIO (print st)   -- Functional debugger
 Step has a precondition that there *is* code to run
 Rule 4: Closure creation
 Rule 5: Application
 Rule 7 & 8: If statement
 Rule Opps
------------------------------------------------------------------------
 Operator code
 call the purely functional operators
 This is where the callbacks happen from...
 The most general case
 Many arguments, typically image mangling
 This one is our testing harness
 Render is somewhat funny, because it can only get called at top level.
 All other operations are purely functional.
 call the purely functional operators
----------------------------------------------------------------------------
 here, you could have an (AbsPoint :: AbsObj) which you put on the
----------------------------------------------------------------------------
 Driver
----------------------------------------------------------------------------
 testing
  Copyright ( c ) 2000 Galois Connections , Inc.

module Eval where

import Control.Monad
import Data.Array

import Geometry
import CSG
import Surface
import Data
import Parse (rayParse, rayParseF)

class Monad m => MonadEval m where
  doOp :: PrimOp -> GMLOp -> Stack -> m Stack
  tick :: m ()
  err  :: String -> m a

  tick = return ()

newtype Pure a = Pure a deriving Show

instance Functor Pure where
    fmap = liftM

instance Applicative Pure where
    pure = Pure
    (<*>) = ap

instance Monad Pure where
    Pure x >>= k = k x
    return       = pure

instance MonadEval Pure where
  doOp   = doPureOp
  err  s = error s

instance MonadEval IO where
                          doAllOp  prim op stk
                        }
  err  s = error s

data State
        = State { env   :: Env
                , stack :: Stack
                , code  :: Code
                } deriving Show

callback :: Env -> Code -> Stack -> Stack
callback env code stk
      = case eval (State { env = env, stack = stk, code = code}) of
             Pure stk -> stk

# SPECIALIZE eval : :   State - > Pure Stack #
# SPECIALIZE eval : :   State - > IO Stack #

eval :: MonadEval m => State -> m Stack
eval st =
     ; if moreCode st then
  tick first , so as to catch loops on new eval .
            ; st' <- step st
            ; eval st'
            }
        else return (stack st)
     }

moreCode :: State -> Bool
moreCode (State {code = []}) = False
moreCode _                   = True

# SPECIALIZE step : :   State - > Pure State #
# SPECIALIZE step : :   State - > IO State #
step :: MonadEval m => State -> m State

  Rule 1 : Pushing BaseValues
step st@(State{ stack = stack, code = (TBool b):cs })
    = return (st { stack = (VBool b):stack,    code = cs })
step st@(State{ stack = stack, code = (TInt i):cs })
    = return (st { stack = (VInt i):stack,     code = cs })
step st@(State{ stack = stack, code = (TReal r):cs })
    = return (st { stack = (VReal r):stack,    code = cs })
step st@(State{ stack = stack, code = (TString s):cs })
    = return (st { stack = (VString s):stack,  code = cs })

  Rule 2 : Name binding
step st@(State{ env = env, stack = (v:stack), code = (TBind id):cs }) =
  return (State { env = extendEnv env id v, stack = stack,  code = cs })
step st@(State{ env = env, stack = [], code = (TBind id):cs }) =
  err "Attempt to bind the top of an empty stack"

  Rule 3 : Name lookup
step st@(State{ env = env, stack = stack, code = (TId id):cs }) =
  case (lookupEnv env id) of
  Just v -> return (st { stack = v:stack,  code = cs })
  Nothing -> err ("Cannot find value for identifier: " ++ id)

step st@(State{ env = env, stack = stack, code = (TBody body):cs }) =
  return (st { stack = (VClosure env body):stack, code = cs })

step st@(State{ env = env, stack = (VClosure env' code'):stack, code = TApply:cs }) =
  do { stk <- eval (State {env = env', stack = stack, code = code'})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = [], code = TApply:cs }) =
  err "Application with an empty stack"
step st@(State{ env = env, stack = _:_, code = TApply:cs }) =
  err "Application of a non-closure"

  Rule 6 : Arrays
step st@(State{ env = env, stack = stack, code = TArray code':cs }) =
  do { stk <- eval (State {env = env, stack = [], code = code'})
     ; let last = length stk-1
     ; let arr = array (0,last) (zip [last,last-1..] stk)
     ; return (st { stack = (VArray arr):stack, code = cs })
     }

step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool True):stack, code = TIf:cs }) =
  do { stk <- eval (State {env = e1, stack = stack, code = c1})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool False):stack, code = TIf:cs }) =
  do { stk <- eval (State {env = e2, stack = stack, code = c2})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = _, code = TIf:cs }) =
  err "Incorrect use of if (bad and/or inappropriate values on the stack)"

  Rule 9 : Operators
step st@(State{ env = env, stack = stack, code = (TOp op):cs }) =
  do { stk <- doOp (opFnTable ! op) op stack
     ; return (st { stack = stk, code = cs })
     }

step _ = err "Tripped on sidewalk while stepping."



opFnTable :: Array GMLOp PrimOp
opFnTable = array (minBound,maxBound)
                  [ (op,prim) | (_,TOp op,prim) <- opcodes ]




doPureOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
doPureOp _ Op_render _ =
    err ("\nAttempting to call render from inside a purely functional callback.")

# SPECIALIZE doPrimOp : : PrimOp - > GMLOp - > Stack - > Pure Stack #
# SPECIALIZE doPrimOp : : PrimOp - > GMLOp - > Stack - > IO Stack #
# SPECIALIZE doPrimOp : : PrimOp - > GMLOp - > Stack - > Abs Stack #

doPrimOp ::  (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack

  1 argument .

doPrimOp (Int_Int fn) _ (VInt i1:stk)
  = return ((VInt (fn i1)) : stk)
doPrimOp (Real_Real fn) _ (VReal r1:stk)
  = return ((VReal (fn r1)) : stk)
doPrimOp (Point_Real fn) _ (VPoint x y z:stk)
  = return ((VReal (fn x y z)) : stk)

doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)
  = case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of
      Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] ->
           let
               res = prop (color c1 c2 c3) r1 r2 r3
           in
               return ((VObject (fn (SConst res))) : stk)
      _ -> return ((VObject (fn (SFun call))) : stk)
  where
        call i r1 r2 =
          case callback env code [VReal r2,VReal r1,VInt i] of
             [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3]
                 -> prop (color c1 c2 c3) r1 r2 r3
             stk -> error ("callback failed: incorrectly typed return arguments"
                         ++ show stk)

doPrimOp (Real_Int fn) _ (VReal r1:stk)
  = return ((VInt (fn r1)) : stk)
doPrimOp (Int_Real fn) _ (VInt r1:stk)
  = return ((VReal (fn r1)) : stk)
doPrimOp (Arr_Int fn) _ (VArray arr:stk)
  = return ((VInt (fn arr)) : stk)

  2 arguments .

doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk)
  = return ((VInt (fn i1 i2)) : stk)
doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk)
  = return ((VBool (fn i1 i2)) : stk)
doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk)
  = return ((VReal (fn r1 r2)) : stk)
doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk)
  = return ((VBool (fn r1 r2)) : stk)
doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk)
  = return ((fn arr i) : stk)



doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk)
  = return ((VObject (fn o1 o2)) : stk)
doPrimOp (Point_Color_Light fn) _ (VPoint r g b:VPoint x y z : stk)
  = return (VLight (fn (x,y,z) (color r g b)) : stk)
doPrimOp (Point_Point_Color_Real_Real_Light fn) _
         (VReal r2:VReal r1:VPoint r g b:VPoint x2 y2 z2:VPoint x1 y1 z1 : stk)
  = return (VLight (fn (x1,y1,z1) (x2,y2,z2) (color r g b) r1 r2) : stk)
doPrimOp (Real_Real_Real_Point fn) _ (VReal r3:VReal r2:VReal r1:stk)
  = return ((fn r1 r2 r3) : stk)
doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk)
  = return (VObject (fn o r) : stk)
doPrimOp (Obj_Real_Real_Real_Obj fn) _ (VReal r3:VReal r2:VReal r1:VObject o:stk)
  = return (VObject (fn o r1 r2 r3) : stk)

doPrimOp (Value_String_Value fn) _ (VString s:o:stk)
  = res `seq` return (res : stk)
  where
     res = fn o s

doPrimOp primOp op args
  = err ("\n\ntype error when attempting to execute builtin primitive \"" ++
          show op ++ "\"\n\n| " ++
          show op ++ " takes " ++ show (length types) ++ " argument" ++ s
                   ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++
          "      " ++ unwords [ show ty | ty <- types ]  ++ "\n|\n|" ++
          " currently, the relevant argument" ++ s ++ " on the stack " ++
                  are ++ "\n|\n| " ++
          unwords [ "(" ++ show arg ++ ")"
                  | arg <-  reverse (take (length types) args) ]  ++ "\n|\n| "
          ++ "    (top of stack is on the right hand side)\n\n")
  where
      len   = length types
      s =  (if len /= 1 then "s" else "")
      are =  (if len /= 1 then "are" else "is")
      the =  (if len /= 1 then "" else " the")
      types = getPrimOpType primOp



doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack
doAllOp (Render render) Op_render
                           (VString str:VInt ht:VInt wid:VReal fov
                           :VInt dep:VObject obj:VArray arr
                           :VPoint r g b : stk)
  = do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str
       ; return stk
       }
  where
      lights = [ light | (VLight light) <- elems arr ]



  - Abstract evaluation . 
  - 
  - The idea is you check for constant code that 
  - ( 1 ) does not look at its arguments 
  - ( 2 ) gives a fixed result 
  - 
  - We run for 100 steps . 
  - 
 
 - Abstract evaluation.
 -
 - The idea is you check for constant code that
 - (1) does not look at its arguments
 - (2) gives a fixed result
 -
 - We run for 100 steps.
 -
 -}

absapply :: Env -> Code -> Stack -> Maybe Stack
absapply env code stk =
     case runAbs (eval (State env stk code)) 100 of
       AbsState stk _ -> Just stk
       AbsFail m      -> Nothing

newtype Abs a   = Abs { runAbs :: Int -> AbsState a }
data AbsState a = AbsState a !Int
                | AbsFail String

instance Functor Abs where
    fmap = liftM

instance Applicative Abs where
    pure x = Abs (\ n -> AbsState x n)
    (<*>) = ap

instance Monad Abs where
    (Abs fn) >>= k = Abs (\ s -> case fn s of
                                   AbsState r s' -> runAbs (k r) s'
                                   AbsFail m     -> AbsFail m)
    return       = pure

instance MonadFail Abs where
    fail s       = Abs (\ n -> AbsFail s)

instance MonadEval Abs where
  doOp = doAbsOp
  err  = fail
  tick = Abs (\ n -> if n <= 0
                     then AbsFail "run out of time"
                     else AbsState () (n-1))

doAbsOp :: PrimOp -> GMLOp -> Stack -> Abs Stack
doAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk)
               = return ((VPoint r1 r2 r3) : stk)
  stack , with any object in the three fields .
doAbsOp _ op _ = err ("operator not understood (" ++ show op ++ ")")


mainEval :: Code -> IO ()
mainEval prog = do { stk <- eval (State emptyEnv [] prog)
                   ; return ()
                   }

   * Oops , one of the example actually has something 
   * on the stack at the end . 
   * Oh well ... 
                    ; if null stk 
                      then return ( ) 
                      else do { putStrLn done 
                              ; print stk 
                              } 

  * Oops, one of the example actually has something
  * on the stack at the end.
  * Oh well...
                   ; if null stk
                     then return ()
                     else do { putStrLn done
                             ; print stk
                             }
-}

done = "Items still on stack at (successful) termination of program"


test :: String -> Pure Stack
test is = eval (State emptyEnv [] (rayParse is))

testF :: String -> IO Stack
testF is = do prog <- rayParseF is
              eval (State emptyEnv [] prog)

testA :: String -> Either String (Stack,Int)
testA is = case runAbs (eval (State emptyEnv
                                    [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV]
                                    (rayParse is))) 100 of
             AbsState a n -> Right (a,n)
             AbsFail m -> Left m

abstest1 = "1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply"

  should be [ 3 : : Int ]
et1 = test "1 /x { x } /f 2 /x f apply x addi"





