ghc/tests/programs/galois_raytrace/Data.hs

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