path: root/testsuite/tests/ghc-regress/programs/galois_raytrace/Eval.hs

-- 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 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 Monad Pure where
    Pure x >>= k = k x
    return       = Pure
    fail s       = error s

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
       do { tick             -- 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 relevent 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, becauase 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.
 -
 -}

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 Monad Abs where
    (Abs fn) >>= k = Abs (\ s -> case fn s of
			           AbsState r s' -> runAbs (k r) s'
                                   AbsFail m     -> AbsFail m)
    return x     = Abs (\ n -> AbsState x n)
    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
                             }
-}

done = "Items still on stack at (successfull) 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"