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 Data where 7 8 import Data.Array 9 10 import CSG 11 import Geometry 12 import Illumination 13 import Primitives 14 import Surface 15 16 import Debug.Trace 17 18 -- Now the parsed (expresssion) language 19 20 type Name = String 21 22 type Code = [GMLToken] 23 24 data GMLToken 25 -- All these can occur in parsed code 26 = TOp GMLOp 27 | TId Name 28 | TBind Name 29 | TBool Bool 30 | TInt Int 31 | TReal Double 32 | TString String 33 | TBody Code 34 | TArray Code 35 | TApply 36 | TIf 37 -- These can occur in optimized/transformed code 38 -- NONE (yet!) 39 40 41 instance Show GMLToken where 42 -- never enteredshowsPrec p (TOp op) = shows op 43 showsPrec p (TId id) = showString id 44 showsPrec p (TBind id) = showString ('/' : id) 45 showsPrec p (TBool bool) = shows bool 46 showsPrec p (TInt i) = shows i 47 showsPrec p (TReal d) = shows d 48 showsPrec p (TString s) = shows s 49 showsPrec p (TBody code) = shows code 50 showsPrec p (TArray code) = showString "[ " 51 . foldr (\ a b -> a . showChar ' ' . b) id (map shows code) 52 . showString "]" 53 showsPrec p (TApply) = showString "apply" 54 showsPrec p (TIf) = showString "if" 55 56 -- never enteredshowList code = showString "{ " 57 . foldr (\ a b -> a . showChar ' ' . b) id (map shows code) 58 . showString "}" 59 60 61 -- Now the value language, used inside the interpreter 62 63 type Stack = [GMLValue] 64 65 data GMLValue 66 = VBool !Bool 67 | VInt !Int 68 | VReal !Double 69 | VString String 70 | VClosure Env Code 71 | VArray (Array Int GMLValue) -- FIXME: Haskell array 72 -- uses the interpreter version of point 73 | VPoint { xPoint :: !Double 74 , yPoint :: !Double 75 , zPoint :: !Double 76 } 77 -- these are abstract to the interpreter 78 | VObject Object 79 | VLight Light 80 -- This is an abstract object, used by the abstract interpreter 81 | VAbsObj AbsObj 82 83 84 -- There are only *3* basic abstract values, 85 -- and the combinators also. 86 87 data AbsObj 88 = AbsFACE 89 | AbsU 90 | AbsV 91 deriving (-- never entered-- never enteredShow) 92 93 instance Show GMLValue where 94 -- never enteredshowsPrec p value = showString (showStkEle value) 95 96 showStkEle :: GMLValue -> String 97 -- never enteredshowStkEle (VBool b) = show b ++ " :: Bool" 98 showStkEle (VInt i) = show i ++ " :: Int" 99 showStkEle (VReal r) = show r ++ " :: Real" 100 showStkEle (VString s) = show s ++ " :: String" 101 showStkEle (VClosure {}) = "<closure> :: Closure" 102 showStkEle (VArray arr) 103 = "<array (" ++ show (succ (snd (bounds arr))) ++ " elements)> :: Array" 104 showStkEle (VPoint x y z) = "(" ++ show x 105 ++ "," ++ show y 106 ++ "," ++ show z 107 ++ ") :: Point" 108 showStkEle (VObject {}) = "<Object> :: Object" 109 showStkEle (VLight {}) = "<Light> :: Object" 110 showStkEle (VAbsObj vobs) = "{{ " ++ show vobs ++ "}} :: AbsObj" 111 112 -- An abstract environment 113 114 newtype Env = Env [(Name, GMLValue)] deriving -- never entered-- never enteredShow 115 116 emptyEnv :: Env 117 -- never enteredemptyEnv = Env [] 118 119 extendEnv :: Env -> Name -> GMLValue -> Env 120 -- entered 441,868 timesextendEnv (Env e) n v = Env ((n, v):e) 121 122 lookupEnv :: Env -> Name -> Maybe GMLValue 123 -- entered 711,560 timeslookupEnv (Env e) n = lookup n e 124 125 -- All primitive operators 126 -- 127 -- There is no Op_apply, Op_false, Op_true and Op_if 128 -- (because they appear explcitly in the rules). 129 130 data GMLOp 131 = Op_acos 132 | Op_addi 133 | Op_addf 134 | Op_asin 135 | Op_clampf 136 | Op_cone 137 | Op_cos 138 | Op_cube 139 | Op_cylinder 140 | Op_difference 141 | Op_divi 142 | Op_divf 143 | Op_eqi 144 | Op_eqf 145 | Op_floor 146 | Op_frac 147 | Op_get 148 | Op_getx 149 | Op_gety 150 | Op_getz 151 | Op_intersect 152 | Op_length 153 | Op_lessi 154 | Op_lessf 155 | Op_light 156 | Op_modi 157 | Op_muli 158 | Op_mulf 159 | Op_negi 160 | Op_negf 161 | Op_plane 162 | Op_point 163 | Op_pointlight 164 | Op_real 165 | Op_render 166 | Op_rotatex 167 | Op_rotatey 168 | Op_rotatez 169 | Op_scale 170 | Op_sin 171 | Op_sphere 172 | Op_spotlight 173 | Op_sqrt 174 | Op_subi 175 | Op_subf 176 | Op_trace -- non standard, for debugging GML programs 177 | Op_translate 178 | Op_union 179 | Op_uscale 180 deriving (-- never entered-- never enteredEq,-- never entered-- never entered-- never entered-- never entered-- never enteredOrd,-- never entered-- entered 746,155 times-- entered 746,155 timesIx,-- entered once-- entered onceBounded) 181 182 instance Show GMLOp where 183 -- never enteredshowsPrec _ op = showString (opNameTable ! op) 184 185 186 ------------------------------------------------------------------------------ 187 188 -- And how we use the op codes (there names, there interface) 189 190 -- These keywords include, "apply", "if", "true" and "false", 191 -- they are not parsed as operators, but are 192 -- captured by the parser as a special case. 193 194 keyWords :: [String] 195 -- never enteredkeyWords = [ kwd | (kwd,_,_) <- opcodes ] 196 197 -- Lookup has to look from the start (or else...) 198 opTable :: [(Name,GMLToken)] 199 -- entered onceopTable = [ (kwd,op) | (kwd,op,_) <- opcodes ] 200 201 opNameTable :: Array GMLOp Name 202 -- never enteredopNameTable = array (minBound,maxBound) 203 [ (op,name) | (name,TOp op,_) <- opcodes ] 204 205 -- never enteredundef = error "undefined function" 206 -- never enteredimage = error "undefined function: talk to image group" 207 208 -- typically, its best to have *one* opcode table, 209 -- so that mis-alignments do not happen. 210 211 opcodes :: [(String,GMLToken,PrimOp)] 212 -- entered onceopcodes = 213 [ ("apply", TApply, error "incorrect use of apply") 214 , ("if", TIf, error "incorrect use of if") 215 , ("false", TBool False, error "incorrect use of false") 216 , ("true", TBool True, error "incorrect use of true") 217 ] ++ map (\ (a,b,c) -> (a,TOp b,c)) 218 -- These are just invocation, any coersions need to occur between here 219 -- and before arriving at the application code (like deg -> rad). 220 [ ("acos", Op_acos, Real_Real (rad2deg . acos)) 221 , ("addi", Op_addi, Int_Int_Int (+)) 222 , ("addf", Op_addf, Real_Real_Real (+)) 223 , ("asin", Op_asin, Real_Real (rad2deg . asin)) 224 , ("clampf", Op_clampf, Real_Real clampf) 225 , ("cone", Op_cone, Surface_Obj cone) 226 , ("cos", Op_cos, Real_Real (cos . deg2rad)) 227 , ("cube", Op_cube, Surface_Obj cube) 228 , ("cylinder", Op_cylinder, Surface_Obj cylinder) 229 , ("difference", Op_difference, Obj_Obj_Obj difference) 230 , ("divi", Op_divi, Int_Int_Int (ourQuot)) 231 , ("divf", Op_divf, Real_Real_Real (/)) 232 , ("eqi", Op_eqi, Int_Int_Bool (==)) 233 , ("eqf", Op_eqf, Real_Real_Bool (==)) 234 , ("floor", Op_floor, Real_Int floor) 235 , ("frac", Op_frac, Real_Real (snd . properFraction)) 236 , ("get", Op_get, Arr_Int_Value ixGet) 237 , ("getx", Op_getx, Point_Real (\ x y z -> x)) 238 , ("gety", Op_gety, Point_Real (\ x y z -> y)) 239 , ("getz", Op_getz, Point_Real (\ x y z -> z)) 240 , ("intersect", Op_intersect, Obj_Obj_Obj intersect) 241 , ("length", Op_length, Arr_Int (succ . snd . bounds)) 242 , ("lessi", Op_lessi, Int_Int_Bool (<)) 243 , ("lessf", Op_lessf, Real_Real_Bool (<)) 244 , ("light", Op_light, Point_Color_Light light) 245 , ("modi", Op_modi, Int_Int_Int (ourRem)) 246 , ("muli", Op_muli, Int_Int_Int (*)) 247 , ("mulf", Op_mulf, Real_Real_Real (*)) 248 , ("negi", Op_negi, Int_Int negate) 249 , ("negf", Op_negf, Real_Real negate) 250 , ("plane", Op_plane, Surface_Obj plane) 251 , ("point", Op_point, Real_Real_Real_Point VPoint) 252 , ("pointlight", Op_pointlight, Point_Color_Light pointlight) 253 , ("real", Op_real, Int_Real fromIntegral) 254 , ("render", Op_render, Render $ render eye) 255 , ("rotatex", Op_rotatex, Obj_Real_Obj (\ o d -> rotateX (deg2rad d) o)) 256 , ("rotatey", Op_rotatey, Obj_Real_Obj (\ o d -> rotateY (deg2rad d) o)) 257 , ("rotatez", Op_rotatez, Obj_Real_Obj (\ o d -> rotateZ (deg2rad d) o)) 258 , ("scale", Op_scale, Obj_Real_Real_Real_Obj (\ o x y z -> scale (x,y,z) o)) 259 , ("sin", Op_sin, Real_Real (sin . deg2rad)) 260 , ("sphere", Op_sphere, Surface_Obj sphere') -- see comment at end of file 261 , ("spotlight", Op_spotlight, Point_Point_Color_Real_Real_Light mySpotlight) 262 , ("sqrt", Op_sqrt, Real_Real ourSqrt) 263 , ("subi", Op_subi, Int_Int_Int (-)) 264 , ("subf", Op_subf, Real_Real_Real (-)) 265 , ("trace", Op_trace, Value_String_Value mytrace) 266 , ("translate", Op_translate, Obj_Real_Real_Real_Obj (\ o x y z -> translate (x,y,z) o)) 267 , ("union", Op_union, Obj_Obj_Obj union) 268 , ("uscale", Op_uscale, Obj_Real_Obj (\ o r -> uscale r o)) 269 ] 270 271 -- This enumerate all possible ways of calling the fixed primitives 272 273 -- The datatype captures the type at the *interp* level, 274 -- the type of the functional is mirrored on this (using Haskell types). 275 276 data PrimOp 277 278 -- 1 argument 279 = Int_Int (Int -> Int) 280 | Real_Real (Double -> Double) 281 | Point_Real (Double -> Double -> Double -> Double) 282 | Surface_Obj (SurfaceFn Color Double -> Object) 283 | Real_Int (Double -> Int) 284 | Int_Real (Int -> Double) 285 | Arr_Int (Array Int GMLValue -> Int) 286 287 -- 2 arguments 288 | Int_Int_Int (Int -> Int -> Int) 289 | Int_Int_Bool (Int -> Int -> Bool) 290 | Real_Real_Real (Double -> Double -> Double) 291 | Real_Real_Bool (Double -> Double -> Bool) 292 | Arr_Int_Value (Array Int GMLValue -> Int -> GMLValue) 293 294 -- Many arguments, typically image mangling 295 296 | Obj_Obj_Obj (Object -> Object -> Object) 297 | Point_Color_Light (Coords -> Color -> Light) 298 | Real_Real_Real_Point (Double -> Double -> Double -> GMLValue) 299 | Obj_Real_Obj (Object -> Double -> Object) 300 | Obj_Real_Real_Real_Obj (Object -> Double -> Double -> Double -> Object) 301 | Value_String_Value (GMLValue -> String -> GMLValue) 302 303 | Point_Point_Color_Real_Real_Light 304 (Coords -> Coords -> Color -> Radian -> Radian -> Light) 305 -- And finally render 306 | Render (Color -> [Light] -> Object -> Int -> Double -> Int -> Int -> String -> IO ()) 307 308 data Type 309 = TyBool 310 | TyInt 311 | TyReal 312 | TyString 313 | TyCode 314 | TyArray 315 | TyPoint 316 | TyObject 317 | TyLight 318 | TyAlpha 319 | TyAbsObj 320 deriving (-- never entered-- never enteredEq,-- never entered-- never entered-- never entered-- never entered-- never enteredOrd,-- never entered-- never entered-- never enteredIx,-- never entered-- never enteredBounded) 321 322 -- never enteredtypeTable = 323 [ ( TyBool, "Bool") 324 , ( TyInt, "Int") 325 , ( TyReal, "Real") 326 , ( TyString, "String") 327 , ( TyCode, "Code") 328 , ( TyArray, "Array") 329 , ( TyPoint, "Point") 330 , ( TyObject, "Object") 331 , ( TyLight, "Light") 332 , ( TyAlpha, "<anything>") 333 , ( TyAbsObj, "<abs>") 334 ] 335 336 -- never enteredtypeNames = array (minBound,maxBound) typeTable 337 338 instance Show Type where 339 -- never enteredshowsPrec _ op = showString (typeNames ! op) 340 341 getPrimOpType :: PrimOp -> [Type] 342 -- never enteredgetPrimOpType (Int_Int _) = [TyInt] 343 getPrimOpType (Real_Real _) = [TyReal] 344 getPrimOpType (Point_Real _) = [TyPoint] 345 getPrimOpType (Surface_Obj _) = [TyCode] 346 getPrimOpType (Real_Int _) = [TyReal] 347 getPrimOpType (Int_Real _) = [TyInt] 348 getPrimOpType (Arr_Int _) = [TyArray] 349 getPrimOpType (Int_Int_Int _) = [TyInt,TyInt] 350 getPrimOpType (Int_Int_Bool _) = [TyInt,TyInt] 351 getPrimOpType (Real_Real_Real _) = [TyReal,TyReal] 352 getPrimOpType (Real_Real_Bool _) = [TyReal,TyReal] 353 getPrimOpType (Arr_Int_Value _) = [TyArray,TyInt] 354 getPrimOpType (Obj_Obj_Obj _) = [TyObject,TyObject] 355 getPrimOpType (Point_Color_Light _) = [TyPoint,TyPoint] 356 getPrimOpType (Real_Real_Real_Point _) = [TyReal,TyReal,TyReal] 357 getPrimOpType (Obj_Real_Obj _) = [TyObject,TyReal] 358 getPrimOpType (Obj_Real_Real_Real_Obj _) = [TyObject,TyReal,TyReal,TyReal] 359 getPrimOpType (Value_String_Value _) = [TyAlpha,TyString] 360 getPrimOpType (Point_Point_Color_Real_Real_Light _) 361 = [TyPoint,TyPoint,TyPoint,TyReal,TyReal] 362 getPrimOpType (Render _) = [TyPoint, 363 TyLight, 364 TyObject, 365 TyInt, 366 TyReal, 367 TyReal, 368 TyReal, 369 TyString] 370 371 372 -- Some primitives with better error message 373 374 -- never enteredmytrace v s = trace (s ++" : "++ show v ++ "\n") v 375 376 377 ixGet :: Array Int GMLValue -> Int -> GMLValue 378 -- entered 65,024 timesixGet arr i 379 | inRange (bounds arr) i = arr ! i 380 | otherwise = error ("failed access with index value " 381 ++ show i 382 ++ " (should be between 0 and " 383 ++ show (snd (bounds arr)) ++ ")") 384 385 ourQuot :: Int -> Int -> Int 386 -- never enteredourQuot _ 0 = error "attempt to use divi to divide by 0" 387 ourQuot a b = a `quot` b 388 389 ourRem :: Int -> Int -> Int 390 -- entered 53,568 timesourRem _ 0 = error "attempt to use remi to divide by 0" 391 ourRem a b = a `rem` b 392 393 ourSqrt :: Double -> Double 394 -- never enteredourSqrt n | n < 0 = error "attempt to use sqrt on a negative number" 395 | otherwise = sqrt n 396 397 398 -- never enteredmySpotlight p1 p2 col cutoff exp = spotlight p1 p2 col (deg2rad cutoff) exp 399 400 -- The problem specification gets the mapping for spheres backwards 401 -- (it maps the image from right to left). 402 -- We've fixed that in the raytracing library so that it goes from left 403 -- to right, but to keep the GML front compatible with the problem 404 -- statement, we reverse it here. 405 406 sphere' :: SurfaceFn Color Double -> CSG (SurfaceFn Color Double) 407 -- never enteredsphere' (SFun f) = sphere (SFun (\i u v -> f i (1 - u) v)) 408 sphere' s = sphere s