Commit cf28b7c8 authored by Ben Gamari's avatar Ben Gamari 🐢 Committed by Andreas Klebinger

parallel/gray: Detabify

parent 63aa657c
......@@ -4,10 +4,10 @@
-- which is included in the distribution.
module CSG(module Construct,
module Geometry,
module Intersections,
module Interval,
module Misc) where
module Geometry,
module Intersections,
module Interval,
module Misc) where
import Construct
import Geometry
......
......@@ -69,7 +69,7 @@ data CSG a
-- the a is application-specific texture information
type Texture a = (Face, Point, a)
union, intersect, difference :: CSG a -> CSG a -> CSG a
union, intersect, difference :: CSG a -> CSG a -> CSG a
union p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Union p q)
union p q = Union p q
......@@ -85,25 +85,25 @@ difference p q = Difference p q
mkBox b p = Box b p
plane, sphere, cube, cylinder, cone :: a -> CSG a
plane, sphere, cube, cylinder, cone :: a -> CSG a
plane = Plane
sphere s =
mkBox (B (-1 - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Sphere s)
(-1 - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Sphere s)
cone s =
mkBox (B (-1 - epsilon) (1 + epsilon)
( - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Cone s)
( - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Cone s)
cube s =
mkBox (B (- epsilon) (1 + epsilon)
(- epsilon) (1 + epsilon)
(- epsilon) (1 + epsilon)) (Cube s)
(- epsilon) (1 + epsilon)
(- epsilon) (1 + epsilon)) (Cube s)
cylinder s =
mkBox (B (-1 - epsilon) (1 + epsilon)
( - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Cylinder s)
( - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Cylinder s)
----------------------------
-- Object transformations
......@@ -120,16 +120,16 @@ transform mm' (Difference p q) = Difference (transform mm' p) (trans
transform mm'@(m,_) (Box box p) = Box (transformBox m box) (transform mm' p)
transform (m, m') prim = Transform m m' prim
translate :: Coords -> CSG a -> CSG a
translateX, translateY, translateZ :: Double -> CSG a -> CSG a
translate :: Coords -> CSG a -> CSG a
translateX, translateY, translateZ :: Double -> CSG a -> CSG a
translate xyz = transform $ transM xyz
translateX x = translate (x, 0, 0)
translateY y = translate (0, y, 0)
translateZ z = translate (0, 0, z)
scale :: Coords -> CSG a -> CSG a
scaleX, scaleY, scaleZ, uscale :: Double -> CSG a -> CSG a
scale :: Coords -> CSG a -> CSG a
scaleX, scaleY, scaleZ, uscale :: Double -> CSG a -> CSG a
scale xyz = transform $ scaleM xyz
scaleX x = scale (x, 1, 1)
......@@ -137,7 +137,7 @@ scaleY y = scale (1, y, 1)
scaleZ z = scale (1, 1, z)
uscale u = scale (u,u,u)
rotateX, rotateY, rotateZ :: Radian -> CSG a -> CSG a
rotateX, rotateY, rotateZ :: Radian -> CSG a -> CSG a
rotateX a = transform $ rotxM a
rotateY a = transform $ rotyM a
......@@ -145,72 +145,72 @@ rotateZ a = transform $ rotzM a
unit = matrix
( ( 1.0, 0.0, 0.0, 0.0 ),
( 0.0, 1.0, 0.0, 0.0 ),
( 0.0, 0.0, 1.0, 0.0 ),
( 0.0, 0.0, 0.0, 1.0 ) )
( 0.0, 1.0, 0.0, 0.0 ),
( 0.0, 0.0, 1.0, 0.0 ),
( 0.0, 0.0, 0.0, 1.0 ) )
transM (x, y, z)
= ( matrix
( ( 1, 0, 0, x ),
( 0, 1, 0, y ),
( 0, 0, 1, z ),
( 0, 0, 0, 1 ) ),
( 0, 1, 0, y ),
( 0, 0, 1, z ),
( 0, 0, 0, 1 ) ),
matrix
( ( 1, 0, 0, -x ),
( 0, 1, 0, -y ),
( 0, 0, 1, -z ),
( 0, 0, 0, 1 ) ) )
( 0, 1, 0, -y ),
( 0, 0, 1, -z ),
( 0, 0, 0, 1 ) ) )
scaleM (x, y, z)
= ( matrix
( ( x', 0, 0, 0 ),
( 0, y', 0, 0 ),
( 0, 0, z', 0 ),
( 0, 0, 0, 1 ) ),
( 0, y', 0, 0 ),
( 0, 0, z', 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( 1/x', 0, 0, 0 ),
( 0, 1/y', 0, 0 ),
( 0, 0, 1/z', 0 ),
( 0, 0, 0, 1 ) ) )
( 0, 1/y', 0, 0 ),
( 0, 0, 1/z', 0 ),
( 0, 0, 0, 1 ) ) )
where x' = nonZero x
y' = nonZero y
z' = nonZero z
y' = nonZero y
z' = nonZero z
rotxM t
= ( matrix
( ( 1, 0, 0, 0 ),
( 0, cos t, -sin t, 0 ),
( 0, sin t, cos t, 0 ),
( 0, 0, 0, 1 ) ),
( 0, cos t, -sin t, 0 ),
( 0, sin t, cos t, 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( 1, 0, 0, 0 ),
( 0, cos t, sin t, 0 ),
( 0, -sin t, cos t, 0 ),
( 0, 0, 0, 1 ) ) )
( 0, cos t, sin t, 0 ),
( 0, -sin t, cos t, 0 ),
( 0, 0, 0, 1 ) ) )
rotyM t
= ( matrix
( ( cos t, 0, sin t, 0 ),
( 0, 1, 0, 0 ),
( -sin t, 0, cos t, 0 ),
( 0, 0, 0, 1 ) ),
( 0, 1, 0, 0 ),
( -sin t, 0, cos t, 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( cos t, 0, -sin t, 0 ),
( 0, 1, 0, 0 ),
( sin t, 0, cos t, 0 ),
( 0, 0, 0, 1 ) ) )
( 0, 1, 0, 0 ),
( sin t, 0, cos t, 0 ),
( 0, 0, 0, 1 ) ) )
rotzM t
= ( matrix
( ( cos t, -sin t, 0, 0 ),
( sin t, cos t, 0, 0 ),
( 0, 0, 1, 0 ),
( 0, 0, 0, 1 ) ),
( sin t, cos t, 0, 0 ),
( 0, 0, 1, 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( cos t, sin t, 0, 0 ),
( -sin t, cos t, 0, 0 ),
( 0, 0, 1, 0 ),
( 0, 0, 0, 1 ) ) )
( -sin t, cos t, 0, 0 ),
( 0, 0, 1, 0 ),
( 0, 0, 0, 1 ) ) )
-------------------
-- Eye transformations
......@@ -220,9 +220,9 @@ rotzM t
-- These are implemented as inverse transforms of the model.
-------------------
eye :: Transform
translateEye :: Coords -> Transform -> Transform
rotateEyeX, rotateEyeY, rotateEyeZ :: Radian -> Transform -> Transform
eye :: Transform
translateEye :: Coords -> Transform -> Transform
rotateEyeX, rotateEyeY, rotateEyeZ :: Radian -> Transform -> Transform
eye = (unit, unit)
translateEye xyz (eye1, eye2)
......@@ -255,11 +255,11 @@ transformBox t (B x1 x2 y1 y2 z1 z2)
(foldr1 min (map zCoord pts'))
(foldr1 max (map zCoord pts')))
where pts' = map (multMP t) pts
pts = [point x1 y1 z1,
point x1 y1 z2,
point x1 y2 z1,
point x1 y2 z2,
point x2 y1 z1,
point x2 y1 z2,
point x2 y2 z1,
point x2 y2 z2]
pts = [point x1 y1 z1,
point x1 y1 z2,
point x1 y2 z1,
point x1 y2 z2,
point x2 y1 z1,
point x2 y1 z2,
point x2 y2 z1,
point x2 y2 z2]
......@@ -23,19 +23,19 @@ 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!)
= 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
......@@ -63,22 +63,22 @@ instance Show GMLToken where
type Stack = [GMLValue]
data GMLValue
= VBool !Bool
| VInt !Int
| VReal !Double
| VString String
| VClosure Env Code
| VArray (Array Int GMLValue) -- FIXME: Haskell array
= 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
| 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
| VObject Object
| VLight Light
-- This is an abstract object, used by the abstract interpreter
| VAbsObj AbsObj
-- There are only *3* basic abstract values,
......@@ -200,7 +200,7 @@ opTable = [ (kwd,op) | (kwd,op,_) <- opcodes ]
opNameTable :: Array GMLOp Name
opNameTable = array (minBound,maxBound)
[ (op,name) | (name,TOp op,_) <- opcodes ]
[ (op,name) | (name,TOp op,_) <- opcodes ]
undef = error "undefined function"
image = error "undefined function: talk to image group"
......@@ -210,62 +210,62 @@ image = error "undefined function: talk to image group"
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")
[ ("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)
[ ("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))
, ("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)
, ("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
, ("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 (-))
, ("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))
, ("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
......
......@@ -49,10 +49,10 @@ instance MonadEval IO where
err s = error s
data State
= State { env :: Env
, stack :: Stack
, code :: Code
} deriving Show
= State { env :: Env
, stack :: Stack
, code :: Code
} deriving Show
callback :: Env -> Code -> Stack -> Stack
callback env code stk
......@@ -158,7 +158,7 @@ parList (x:xs) = x `par` parList xs
opFnTable :: Array GMLOp PrimOp
opFnTable = array (minBound,maxBound)
[ (op,prim) | (_,TOp op,prim) <- opcodes ]
[ (op,prim) | (_,TOp op,prim) <- opcodes ]
......@@ -188,7 +188,7 @@ doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)
= case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of
Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] ->
let
res = prop (color c1 c2 c3) r1 r2 r3
res = prop (color c1 c2 c3) r1 r2 r3
in
return ((VObject (fn (SConst res))) : stk)
_ -> return ((VObject (fn (SFun call))) : stk)
......@@ -197,7 +197,7 @@ doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)
call i r1 r2 =
case callback env code [VReal r2,VReal r1,VInt i] of
[VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3]
-> prop (color c1 c2 c3) r1 r2 r3
-> prop (color c1 c2 c3) r1 r2 r3
stk -> error ("callback failed: incorrectly typed return arguments"
++ show stk)
......@@ -248,10 +248,10 @@ doPrimOp primOp op args
= err ("\n\ntype error when attempting to execute builtin primitive \"" ++
show op ++ "\"\n\n| " ++
show op ++ " takes " ++ show (length types) ++ " argument" ++ s
++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++
++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++
" " ++ unwords [ show ty | ty <- types ] ++ "\n|\n|" ++
" currently, the relevent argument" ++ s ++ " on the stack " ++
are ++ "\n|\n| " ++
are ++ "\n|\n| " ++
unwords [ "(" ++ show arg ++ ")"
| arg <- reverse (take (length types) args) ] ++ "\n|\n| "
++ " (top of stack is on the right hand side)\n\n")
......@@ -268,7 +268,7 @@ doPrimOp primOp op args
doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack
doAllOp (Render render) Op_render
(VString str:VInt ht:VInt wid:VReal fov
(VString str:VInt ht:VInt wid:VReal fov
:VInt dep:VObject obj:VArray arr
:VPoint r g b : stk)
= do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str
......@@ -310,7 +310,7 @@ instance Applicative Abs where
instance Monad Abs where
(Abs fn) >>= k = Abs (\ s -> case fn s of
AbsState r s' -> runAbs (k r) s'
AbsState r s' -> runAbs (k r) s'
AbsFail m -> AbsFail m)
return = pure
fail s = Abs (\ n -> AbsFail s)
......@@ -340,9 +340,9 @@ mainEval prog = do { stk <- eval (State emptyEnv [] prog)
* Oops, one of the example actually has something
* on the stack at the end.
* Oh well...
; if null stk
; if null stk
then return ()
else do { putStrLn done
else do { putStrLn done
; print stk
}
-}
......
......@@ -162,7 +162,7 @@ tangents :: Vector -> (Vector, Vector)
tangents v@(V x y z)
= (v1, v `cross` v1)
where v1 | x == 0 = normalize (vector 0 z (-y))
| otherwise = normalize (vector (-y) x 0)
| otherwise = normalize (vector (-y) x 0)
{-# INLINE dot4 #-}
dot4 :: Quad -> Quad -> Double
......@@ -197,7 +197,7 @@ norm (V x y z) = sqrt (sq x + sq y + sq z)
normalize :: Vector -> Vector
normalize v@(V x y z)
| norm /= 0 = multSV (1/norm) v
| otherwise = error "normalize empty!"
| otherwise = error "normalize empty!"
where norm = sqrt (sq x + sq y + sq z)
-- This does computes the distance *squared*
......
......@@ -112,14 +112,14 @@ illum cxt (pos,normV,(col,kd,ks,n)) v
ambTerm = multSC kd (multCC amb col)
difTerm = multSC kd (sumCC [multSC (dot normV lj) (multCC intensity col)
|(loc,intensity) <- visibleLights,
let lj = normalize ({- pos `subVV` -} loc)])
|(loc,intensity) <- visibleLights,
let lj = normalize ({- pos `subVV` -} loc)])
-- ZZ might want to avoid the phong, when you can...
spcTerm = multSC ks (sumCC [multSC ((dot normV hj) ** n ) (multCC intensity col)
|(loc,intensity) <- visibleLights,
-- ZZ note this is specific to the light at infinity
let lj = {- pos `subVV` -} normalize loc,
let hj = normalize (lj `subVV` normalize v)])
|(loc,intensity) <- visibleLights,
-- ZZ note this is specific to the light at infinity
let lj = {- pos `subVV` -} normalize loc,
let hj = normalize (lj `subVV` normalize v)])
recTerm = if recCoeff `nearC` black then black else multCC recCoeff recRay
recCoeff = multSC ks col
recRay = illumination cxt (pos,newV)
......@@ -217,8 +217,8 @@ castRay ray p
(False, (0, b, _) : _, _) -> Nothing -- eye is inside
(False, (i, False, _) : _, _) -> Nothing -- eye is inside
(False, (t, b, (s, p0)) : _, _) ->
let (v, prop) = surface s p0 in
Just (offsetToPoint ray t, v, prop)
let (v, prop) = surface s p0 in
Just (offsetToPoint ray t, v, prop)
intersects ray p
= case intersectRayWithObject ray p of
......
This diff is collapsed.
......@@ -29,8 +29,8 @@ import Geometry
-- solid. As a convenience, we also keep an additional flag that
-- indicates whether the last intersection ends inside or outside.
type IList a = (Bool, [Intersection a], Bool)
type Intersection a = (Double, Bool, a)
type IList a = (Bool, [Intersection a], Bool)
type Intersection a = (Double, Bool, a)
emptyIList = (False, [], False)
openIList = (True, [], True)
......@@ -46,7 +46,7 @@ mkExit (t, a) = (t, False, a)
entryexit w1 w2 = (False, [mkEntry w1, mkExit w2], False)
exitentry w1 w2 = (True, [mkExit w1, mkEntry w2], True)
arrange w1@(t1, _) w2@(t2, _) | t1 < t2 = entryexit w1 w2
| otherwise = entryexit w2 w1
| otherwise = entryexit w2 w1
cmpI :: Intersection a -> Intersection a -> Ordering
......@@ -66,23 +66,23 @@ unionIntervals :: IList a -> IList a -> IList a
unionIntervals (isStartOpen, is, isEndOpen) (jsStartOpen, js, jsEndOpen)
= (isStartOpen || jsStartOpen, uniIntervals is js, isEndOpen || jsEndOpen)
where uniIntervals is [] | jsEndOpen = []
| otherwise = is
uniIntervals [] js | isEndOpen = []
| otherwise = js
uniIntervals is@(i : is') js@(j : js')
= case cmpI i j of
EQ -> if isEntry i == isEntry j then i : uniIntervals is' js'
else uniIntervals is' js'
LT -> if isEntry j then i : uniIntervals is' js
else uniIntervals is' js
GT -> if isEntry i then j : uniIntervals is js'
else uniIntervals is js'
| otherwise = is
uniIntervals [] js | isEndOpen = []
| otherwise = js
uniIntervals is@(i : is') js@(j : js')
= case cmpI i j of
EQ -> if isEntry i == isEntry j then i : uniIntervals is' js'
else uniIntervals is' js'
LT -> if isEntry j then i : uniIntervals is' js
else uniIntervals is' js
GT -> if isEntry i then j : uniIntervals is js'
else uniIntervals is js'
intersectIntervals :: IList a -> IList a -> IList a
intersectIntervals is js
= complementIntervals (unionIntervals is' js')
where is' = complementIntervals is
js' = complementIntervals js
js' = complementIntervals js
differenceIntervals :: IList a -> IList a -> IList a
differenceIntervals is js
......@@ -114,8 +114,8 @@ t7 = differenceIntervals i2 i2
sh (o1,is,o2) =
do if o1 then putStr "..." else return ()
putStr $ foldr1 (++) (map si is)
if o2 then putStr "..." else return ()
putStr $ foldr1 (++) (map si is)
if o2 then putStr "..." else return ()
si (i, True, _, _) = "<" ++ show i
si (i, False, _, _) = " " ++ show i ++ ">"
-}
......@@ -53,42 +53,42 @@ evalSurface (SFun f) = f
surface (Planar _ v0 v1) (n, p0, fn)
= (norm, evalSurface fn n' u v)
where norm = normalize $ cross v0 v1
(n', u, v) = planarUV n p0
(n', u, v) = planarUV n p0
surface (Spherical _ v0 v1) (_, p0, fn)
= (norm, evalSurface fn 0 u v)
where x = xCoord p0
y = yCoord p0
z = zCoord p0
k = sqrt (1 - sq y)
theta = adjustRadian (atan2 (x / k) (z / k))
-- correct so that the image grows left-to-right
-- instead of right-to-left
u = 1.0 - clampf (theta / (2 * pi))
v = clampf ((y + 1) / 2)
norm = normalize $ cross v0 v1
y = yCoord p0
z = zCoord p0
k = sqrt (1 - sq y)
theta = adjustRadian (atan2 (x / k) (z / k))
-- correct so that the image grows left-to-right
-- instead of right-to-left
u = 1.0 - clampf (theta / (2 * pi))
v = clampf ((y + 1) / 2)
norm = normalize $ cross v0 v1
-- ZZ ignore the (incorrect) surface model, and estimate the normal
-- from the intersection in object space
surface (Cylindrical _ v0 v1) (_, p0, fn)
= (norm, evalSurface fn 0 u v)
where x = xCoord p0
y = yCoord p0
z = zCoord p0
u = clampf $ adjustRadian (atan2 x z) / (2 * pi)
v = y
norm = normalize $ cross v0 v1
y = yCoord p0
z = zCoord p0
u = clampf $ adjustRadian (atan2 x z) / (2 * pi)
v = y
norm = normalize $ cross v0 v1
-- ZZ ignore the (incorrect) surface model, and estimate the normal
-- from the intersection in object space
surface (Conic _ v0 v1) (_, p0, fn)
= (norm, evalSurface fn 0 u v)
where x = xCoord p0
y = yCoord p0
z = zCoord p0
u = clampf $ adjustRadian (atan2 (x / y) (z / y)) / (2 * pi)
v = y
norm = normalize $ cross v0 v1
y = yCoord p0
z = zCoord p0