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