path: root/testsuite/tests/ghc-regress/programs/galois_raytrace/Data.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 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