diff options
Diffstat (limited to 'testsuite/tests/programs/galois_raytrace/Data.hs')
| -rw-r--r-- | testsuite/tests/programs/galois_raytrace/Data.hs | 408 |
1 files changed, 408 insertions, 0 deletions
diff --git a/testsuite/tests/programs/galois_raytrace/Data.hs b/testsuite/tests/programs/galois_raytrace/Data.hs new file mode 100644 index 0000000000..11e12ab79f --- /dev/null +++ b/testsuite/tests/programs/galois_raytrace/Data.hs @@ -0,0 +1,408 @@ +-- 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 Data where + +import Array + +import CSG +import Geometry +import Illumination +import Primitives +import Surface + +import Debug.Trace + +-- Now the parsed (expresssion) language + +type Name = String + +type Code = [GMLToken] + +data GMLToken + -- All these can occur in parsed code + = TOp GMLOp + | TId Name + | TBind Name + | TBool Bool + | TInt Int + | TReal Double + | TString String + | TBody Code + | TArray Code + | TApply + | TIf + -- These can occur in optimized/transformed code + -- NONE (yet!) + + +instance Show GMLToken where + showsPrec p (TOp op) = shows op + showsPrec p (TId id) = showString id + showsPrec p (TBind id) = showString ('/' : id) + showsPrec p (TBool bool) = shows bool + showsPrec p (TInt i) = shows i + showsPrec p (TReal d) = shows d + showsPrec p (TString s) = shows s + showsPrec p (TBody code) = shows code + showsPrec p (TArray code) = showString "[ " + . foldr (\ a b -> a . showChar ' ' . b) id (map shows code) + . showString "]" + showsPrec p (TApply) = showString "apply" + showsPrec p (TIf) = showString "if" + + showList code = showString "{ " + . foldr (\ a b -> a . showChar ' ' . b) id (map shows code) + . showString "}" + + +-- Now the value language, used inside the interpreter + +type Stack = [GMLValue] + +data GMLValue + = VBool !Bool + | VInt !Int + | VReal !Double + | VString String + | VClosure Env Code + | VArray (Array Int GMLValue) -- FIXME: Haskell array + -- uses the interpreter version of point + | VPoint { xPoint :: !Double + , yPoint :: !Double + , zPoint :: !Double + } + -- these are abstract to the interpreter + | VObject Object + | VLight Light + -- This is an abstract object, used by the abstract interpreter + | VAbsObj AbsObj + + +-- There are only *3* basic abstract values, +-- and the combinators also. + +data AbsObj + = AbsFACE + | AbsU + | AbsV + deriving (Show) + +instance Show GMLValue where + showsPrec p value = showString (showStkEle value) + +showStkEle :: GMLValue -> String +showStkEle (VBool b) = show b ++ " :: Bool" +showStkEle (VInt i) = show i ++ " :: Int" +showStkEle (VReal r) = show r ++ " :: Real" +showStkEle (VString s) = show s ++ " :: String" +showStkEle (VClosure {}) = "<closure> :: Closure" +showStkEle (VArray arr) + = "<array (" ++ show (succ (snd (bounds arr))) ++ " elements)> :: Array" +showStkEle (VPoint x y z) = "(" ++ show x + ++ "," ++ show y + ++ "," ++ show z + ++ ") :: Point" +showStkEle (VObject {}) = "<Object> :: Object" +showStkEle (VLight {}) = "<Light> :: Object" +showStkEle (VAbsObj vobs) = "{{ " ++ show vobs ++ "}} :: AbsObj" + +-- An abstract environment + +newtype Env = Env [(Name, GMLValue)] deriving Show + +emptyEnv :: Env +emptyEnv = Env [] + +extendEnv :: Env -> Name -> GMLValue -> Env +extendEnv (Env e) n v = Env ((n, v):e) + +lookupEnv :: Env -> Name -> Maybe GMLValue +lookupEnv (Env e) n = lookup n e + +-- All primitive operators +-- +-- There is no Op_apply, Op_false, Op_true and Op_if +-- (because they appear explcitly in the rules). + +data GMLOp + = Op_acos + | Op_addi + | Op_addf + | Op_asin + | Op_clampf + | Op_cone + | Op_cos + | Op_cube + | Op_cylinder + | Op_difference + | Op_divi + | Op_divf + | Op_eqi + | Op_eqf + | Op_floor + | Op_frac + | Op_get + | Op_getx + | Op_gety + | Op_getz + | Op_intersect + | Op_length + | Op_lessi + | Op_lessf + | Op_light + | Op_modi + | Op_muli + | Op_mulf + | Op_negi + | Op_negf + | Op_plane + | Op_point + | Op_pointlight + | Op_real + | Op_render + | Op_rotatex + | Op_rotatey + | Op_rotatez + | Op_scale + | Op_sin + | Op_sphere + | Op_spotlight + | Op_sqrt + | Op_subi + | Op_subf + | Op_trace -- non standard, for debugging GML programs + | Op_translate + | Op_union + | Op_uscale + deriving (Eq,Ord,Ix,Bounded) + +instance Show GMLOp where + showsPrec _ op = showString (opNameTable ! op) + + +------------------------------------------------------------------------------ + +-- And how we use the op codes (there names, there interface) + +-- These keywords include, "apply", "if", "true" and "false", +-- they are not parsed as operators, but are +-- captured by the parser as a special case. + +keyWords :: [String] +keyWords = [ kwd | (kwd,_,_) <- opcodes ] + +-- Lookup has to look from the start (or else...) +opTable :: [(Name,GMLToken)] +opTable = [ (kwd,op) | (kwd,op,_) <- opcodes ] + +opNameTable :: Array GMLOp Name +opNameTable = array (minBound,maxBound) + [ (op,name) | (name,TOp op,_) <- opcodes ] + +undef = error "undefined function" +image = error "undefined function: talk to image group" + +-- typically, its best to have *one* opcode table, +-- so that mis-alignments do not happen. + +opcodes :: [(String,GMLToken,PrimOp)] +opcodes = + [ ("apply", TApply, error "incorrect use of apply") + , ("if", TIf, error "incorrect use of if") + , ("false", TBool False, error "incorrect use of false") + , ("true", TBool True, error "incorrect use of true") + ] ++ map (\ (a,b,c) -> (a,TOp b,c)) + -- These are just invocation, any coersions need to occur between here + -- and before arriving at the application code (like deg -> rad). + [ ("acos", Op_acos, Real_Real (rad2deg . acos)) + , ("addi", Op_addi, Int_Int_Int (+)) + , ("addf", Op_addf, Real_Real_Real (+)) + , ("asin", Op_asin, Real_Real (rad2deg . asin)) + , ("clampf", Op_clampf, Real_Real clampf) + , ("cone", Op_cone, Surface_Obj cone) + , ("cos", Op_cos, Real_Real (cos . deg2rad)) + , ("cube", Op_cube, Surface_Obj cube) + , ("cylinder", Op_cylinder, Surface_Obj cylinder) + , ("difference", Op_difference, Obj_Obj_Obj difference) + , ("divi", Op_divi, Int_Int_Int (ourQuot)) + , ("divf", Op_divf, Real_Real_Real (/)) + , ("eqi", Op_eqi, Int_Int_Bool (==)) + , ("eqf", Op_eqf, Real_Real_Bool (==)) + , ("floor", Op_floor, Real_Int floor) + , ("frac", Op_frac, Real_Real (snd . properFraction)) + , ("get", Op_get, Arr_Int_Value ixGet) + , ("getx", Op_getx, Point_Real (\ x y z -> x)) + , ("gety", Op_gety, Point_Real (\ x y z -> y)) + , ("getz", Op_getz, Point_Real (\ x y z -> z)) + , ("intersect", Op_intersect, Obj_Obj_Obj intersect) + , ("length", Op_length, Arr_Int (succ . snd . bounds)) + , ("lessi", Op_lessi, Int_Int_Bool (<)) + , ("lessf", Op_lessf, Real_Real_Bool (<)) + , ("light", Op_light, Point_Color_Light light) + , ("modi", Op_modi, Int_Int_Int (ourRem)) + , ("muli", Op_muli, Int_Int_Int (*)) + , ("mulf", Op_mulf, Real_Real_Real (*)) + , ("negi", Op_negi, Int_Int negate) + , ("negf", Op_negf, Real_Real negate) + , ("plane", Op_plane, Surface_Obj plane) + , ("point", Op_point, Real_Real_Real_Point VPoint) + , ("pointlight", Op_pointlight, Point_Color_Light pointlight) + , ("real", Op_real, Int_Real fromIntegral) + , ("render", Op_render, Render $ render eye) + , ("rotatex", Op_rotatex, Obj_Real_Obj (\ o d -> rotateX (deg2rad d) o)) + , ("rotatey", Op_rotatey, Obj_Real_Obj (\ o d -> rotateY (deg2rad d) o)) + , ("rotatez", Op_rotatez, Obj_Real_Obj (\ o d -> rotateZ (deg2rad d) o)) + , ("scale", Op_scale, Obj_Real_Real_Real_Obj (\ o x y z -> scale (x,y,z) o)) + , ("sin", Op_sin, Real_Real (sin . deg2rad)) + , ("sphere", Op_sphere, Surface_Obj sphere') -- see comment at end of file + , ("spotlight", Op_spotlight, Point_Point_Color_Real_Real_Light mySpotlight) + , ("sqrt", Op_sqrt, Real_Real ourSqrt) + , ("subi", Op_subi, Int_Int_Int (-)) + , ("subf", Op_subf, Real_Real_Real (-)) + , ("trace", Op_trace, Value_String_Value mytrace) + , ("translate", Op_translate, Obj_Real_Real_Real_Obj (\ o x y z -> translate (x,y,z) o)) + , ("union", Op_union, Obj_Obj_Obj union) + , ("uscale", Op_uscale, Obj_Real_Obj (\ o r -> uscale r o)) + ] + +-- This enumerate all possible ways of calling the fixed primitives + +-- The datatype captures the type at the *interp* level, +-- the type of the functional is mirrored on this (using Haskell types). + +data PrimOp + + -- 1 argument + = Int_Int (Int -> Int) + | Real_Real (Double -> Double) + | Point_Real (Double -> Double -> Double -> Double) + | Surface_Obj (SurfaceFn Color Double -> Object) + | Real_Int (Double -> Int) + | Int_Real (Int -> Double) + | Arr_Int (Array Int GMLValue -> Int) + + -- 2 arguments + | Int_Int_Int (Int -> Int -> Int) + | Int_Int_Bool (Int -> Int -> Bool) + | Real_Real_Real (Double -> Double -> Double) + | Real_Real_Bool (Double -> Double -> Bool) + | Arr_Int_Value (Array Int GMLValue -> Int -> GMLValue) + + -- Many arguments, typically image mangling + + | Obj_Obj_Obj (Object -> Object -> Object) + | Point_Color_Light (Coords -> Color -> Light) + | Real_Real_Real_Point (Double -> Double -> Double -> GMLValue) + | Obj_Real_Obj (Object -> Double -> Object) + | Obj_Real_Real_Real_Obj (Object -> Double -> Double -> Double -> Object) + | Value_String_Value (GMLValue -> String -> GMLValue) + + | Point_Point_Color_Real_Real_Light + (Coords -> Coords -> Color -> Radian -> Radian -> Light) + -- And finally render + | Render (Color -> [Light] -> Object -> Int -> Double -> Int -> Int -> String -> IO ()) + +data Type + = TyBool + | TyInt + | TyReal + | TyString + | TyCode + | TyArray + | TyPoint + | TyObject + | TyLight + | TyAlpha + | TyAbsObj + deriving (Eq,Ord,Ix,Bounded) + +typeTable = + [ ( TyBool, "Bool") + , ( TyInt, "Int") + , ( TyReal, "Real") + , ( TyString, "String") + , ( TyCode, "Code") + , ( TyArray, "Array") + , ( TyPoint, "Point") + , ( TyObject, "Object") + , ( TyLight, "Light") + , ( TyAlpha, "<anything>") + , ( TyAbsObj, "<abs>") + ] + +typeNames = array (minBound,maxBound) typeTable + +instance Show Type where + showsPrec _ op = showString (typeNames ! op) + +getPrimOpType :: PrimOp -> [Type] +getPrimOpType (Int_Int _) = [TyInt] +getPrimOpType (Real_Real _) = [TyReal] +getPrimOpType (Point_Real _) = [TyPoint] +getPrimOpType (Surface_Obj _) = [TyCode] +getPrimOpType (Real_Int _) = [TyReal] +getPrimOpType (Int_Real _) = [TyInt] +getPrimOpType (Arr_Int _) = [TyArray] +getPrimOpType (Int_Int_Int _) = [TyInt,TyInt] +getPrimOpType (Int_Int_Bool _) = [TyInt,TyInt] +getPrimOpType (Real_Real_Real _) = [TyReal,TyReal] +getPrimOpType (Real_Real_Bool _) = [TyReal,TyReal] +getPrimOpType (Arr_Int_Value _) = [TyArray,TyInt] +getPrimOpType (Obj_Obj_Obj _) = [TyObject,TyObject] +getPrimOpType (Point_Color_Light _) = [TyPoint,TyPoint] +getPrimOpType (Real_Real_Real_Point _) = [TyReal,TyReal,TyReal] +getPrimOpType (Obj_Real_Obj _) = [TyObject,TyReal] +getPrimOpType (Obj_Real_Real_Real_Obj _) = [TyObject,TyReal,TyReal,TyReal] +getPrimOpType (Value_String_Value _) = [TyAlpha,TyString] +getPrimOpType (Point_Point_Color_Real_Real_Light _) + = [TyPoint,TyPoint,TyPoint,TyReal,TyReal] +getPrimOpType (Render _) = [TyPoint, + TyLight, + TyObject, + TyInt, + TyReal, + TyReal, + TyReal, + TyString] + + +-- Some primitives with better error message + +mytrace v s = trace (s ++" : "++ show v ++ "\n") v + + +ixGet :: Array Int GMLValue -> Int -> GMLValue +ixGet arr i + | inRange (bounds arr) i = arr ! i + | otherwise = error ("failed access with index value " + ++ show i + ++ " (should be between 0 and " + ++ show (snd (bounds arr)) ++ ")") + +ourQuot :: Int -> Int -> Int +ourQuot _ 0 = error "attempt to use divi to divide by 0" +ourQuot a b = a `quot` b + +ourRem :: Int -> Int -> Int +ourRem _ 0 = error "attempt to use remi to divide by 0" +ourRem a b = a `rem` b + +ourSqrt :: Double -> Double +ourSqrt n | n < 0 = error "attempt to use sqrt on a negative number" + | otherwise = sqrt n + + +mySpotlight p1 p2 col cutoff exp = spotlight p1 p2 col (deg2rad cutoff) exp + +-- The problem specification gets the mapping for spheres backwards +-- (it maps the image from right to left). +-- We've fixed that in the raytracing library so that it goes from left +-- to right, but to keep the GML front compatible with the problem +-- statement, we reverse it here. + +sphere' :: SurfaceFn Color Double -> CSG (SurfaceFn Color Double) +sphere' (SFun f) = sphere (SFun (\i u v -> f i (1 - u) v)) +sphere' s = sphere s |