Changing raytracer tests to work with 6.9
[packages/hpc.git] / tests / raytrace / hpc_raytrace.stdout
1 "GOOD MATCH"
2
3
4  48% expressions used (2292/4718)
5  21% boolean coverage (18/83)
6       21% guards (12/55), 17 always True, 8 always False, 18 unevaluated
7       22% 'if' conditions (6/27), 3 always True, 3 always False, 15 unevaluated
8        0% qualifiers (0/1), 1 unevaluated
9  38% alternatives used (124/322)
10  40% local declarations used (89/218)
11  49% top-level declarations used (146/295)
12
13
14 -----<module CSG>-----
15 100% expressions used (0/0)
16 100% boolean coverage (0/0)
17      100% guards (0/0)
18      100% 'if' conditions (0/0)
19      100% qualifiers (0/0)
20 100% alternatives used (0/0)
21 100% local declarations used (0/0)
22 100% top-level declarations used (0/0)
23 -----<module Construct>-----
24  60% expressions used (381/635)
25 100% boolean coverage (0/0)
26      100% guards (0/0)
27      100% 'if' conditions (0/0)
28      100% qualifiers (0/0)
29  41% alternatives used (5/12)
30 100% local declarations used (5/5)
31  41% top-level declarations used (17/41)
32 -----<module Data>-----
33  39% expressions used (254/647)
34   0% boolean coverage (0/4)
35        0% guards (0/4), 1 always True, 3 unevaluated
36      100% 'if' conditions (0/0)
37      100% qualifiers (0/0)
38   3% alternatives used (2/51)
39   0% local declarations used (0/2)
40  22% top-level declarations used (10/45)
41 -----<module Eval>-----
42  57% expressions used (361/629)
43  20% boolean coverage (1/5)
44      100% guards (0/0)
45       20% 'if' conditions (1/5), 1 always False, 3 unevaluated
46      100% qualifiers (0/0)
47  59% alternatives used (40/67)
48  36% local declarations used (4/11)
49  62% top-level declarations used (22/35)
50 -----<module Geometry>-----
51  70% expressions used (300/427)
52  10% boolean coverage (1/10)
53       10% guards (1/10), 3 always True, 1 always False, 5 unevaluated
54      100% 'if' conditions (0/0)
55      100% qualifiers (0/0)
56  40% alternatives used (4/10)
57  66% local declarations used (2/3)
58  58% top-level declarations used (42/72)
59 -----<module Illumination>-----
60  44% expressions used (299/679)
61  18% boolean coverage (3/16)
62       16% guards (2/12), 2 always True, 1 always False, 7 unevaluated
63       33% 'if' conditions (1/3), 1 always True, 1 always False
64        0% qualifiers (0/1), 1 unevaluated
65  38% alternatives used (16/42)
66  57% local declarations used (27/47)
67  45% top-level declarations used (11/24)
68 -----<module Intersections>-----
69  38% expressions used (382/1001)
70  33% boolean coverage (11/33)
71       40% guards (8/20), 8 always True, 3 always False, 1 unevaluated
72       23% 'if' conditions (3/13), 10 unevaluated
73      100% qualifiers (0/0)
74  42% alternatives used (35/83)
75  36% local declarations used (44/120)
76  63% top-level declarations used (14/22)
77 -----<module Interval>-----
78  41% expressions used (69/165)
79   8% boolean coverage (1/12)
80       11% guards (1/9), 3 always True, 3 always False, 2 unevaluated
81        0% 'if' conditions (0/3), 2 always True, 1 unevaluated
82      100% qualifiers (0/0)
83  39% alternatives used (9/23)
84  25% local declarations used (1/4)
85  47% top-level declarations used (8/17)
86 -----<module Main>-----
87 100% expressions used (6/6)
88 100% boolean coverage (0/0)
89      100% guards (0/0)
90      100% 'if' conditions (0/0)
91      100% qualifiers (0/0)
92 100% alternatives used (0/0)
93 100% local declarations used (0/0)
94 100% top-level declarations used (1/1)
95 -----<module Misc>-----
96   0% expressions used (0/10)
97 100% boolean coverage (0/0)
98      100% guards (0/0)
99      100% 'if' conditions (0/0)
100      100% qualifiers (0/0)
101 100% alternatives used (0/0)
102 100% local declarations used (0/0)
103   0% top-level declarations used (0/1)
104 -----<module Parse>-----
105  72% expressions used (192/264)
106  50% boolean coverage (1/2)
107      100% guards (0/0)
108       50% 'if' conditions (1/2), 1 always False
109      100% qualifiers (0/0)
110  42% alternatives used (6/14)
111 100% local declarations used (2/2)
112  80% top-level declarations used (16/20)
113 -----<module Primitives>-----
114  20% expressions used (5/24)
115 100% boolean coverage (0/0)
116      100% guards (0/0)
117      100% 'if' conditions (0/0)
118      100% qualifiers (0/0)
119 100% alternatives used (0/0)
120 100% local declarations used (0/0)
121  16% top-level declarations used (1/6)
122 -----<module Surface>-----
123  18% expressions used (43/231)
124   0% boolean coverage (0/1)
125      100% guards (0/0)
126        0% 'if' conditions (0/1), 1 unevaluated
127      100% qualifiers (0/0)
128  35% alternatives used (7/20)
129  16% local declarations used (4/24)
130  36% top-level declarations used (4/11)
131
132
133 Writing: Main.hs.html
134 <html><style type="text/css">
135 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
136 span.nottickedoff { background: yellow}
137 span.istickedoff { background: white }
138 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
139 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
140 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
141 span.decl { font-weight: bold }
142 span.spaces    { background: white }
143 </style>
144 <pre>
145 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
146 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
147 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
148 <span class="lineno">    4 </span>-- which is included in the distribution.
149 <span class="lineno">    5 </span>
150 <span class="lineno">    6 </span>-- Modified to read sample input directly from a file.
151 <span class="lineno">    7 </span>
152 <span class="lineno">    8 </span>module Main where
153 <span class="lineno">    9 </span>
154 <span class="lineno">   10 </span>import System
155 <span class="lineno">   11 </span>
156 <span class="lineno">   12 </span>import Parse
157 <span class="lineno">   13 </span>import Eval
158 <span class="lineno">   14 </span>
159 <span class="lineno">   15 </span><span class="decl"><span class="istickedoff">main = do { str &lt;- readFile &quot;galois.gml&quot;</span>
160 <span class="lineno">   16 </span><span class="spaces">          </span><span class="istickedoff">; mainEval (rayParse str)</span>
161 <span class="lineno">   17 </span><span class="spaces">          </span><span class="istickedoff">}</span></span>
162
163 </pre>
164 </html>
165 Writing: Eval.hs.html
166 <html><style type="text/css">
167 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
168 span.nottickedoff { background: yellow}
169 span.istickedoff { background: white }
170 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
171 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
172 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
173 span.decl { font-weight: bold }
174 span.spaces    { background: white }
175 </style>
176 <pre>
177 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
178 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
179 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
180 <span class="lineno">    4 </span>-- which is included in the distribution.
181 <span class="lineno">    5 </span>
182 <span class="lineno">    6 </span>module Eval where
183 <span class="lineno">    7 </span>
184 <span class="lineno">    8 </span>import Array
185 <span class="lineno">    9 </span>
186 <span class="lineno">   10 </span>import Geometry
187 <span class="lineno">   11 </span>import CSG
188 <span class="lineno">   12 </span>import Surface
189 <span class="lineno">   13 </span>import Data
190 <span class="lineno">   14 </span>import Parse (rayParse, rayParseF)
191 <span class="lineno">   15 </span>
192 <span class="lineno">   16 </span>class Monad m =&gt; MonadEval m where
193 <span class="lineno">   17 </span>  doOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; m Stack
194 <span class="lineno">   18 </span>  tick :: m ()
195 <span class="lineno">   19 </span>  err  :: String -&gt; m a
196 <span class="lineno">   20 </span>
197 <span class="lineno">   21 </span>  <span class="decl"><span class="istickedoff">tick = return <span class="nottickedoff">()</span></span></span>
198 <span class="lineno">   22 </span>
199 <span class="lineno">   23 </span>newtype Pure a = Pure a deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
200 <span class="lineno">   24 </span>
201 <span class="lineno">   25 </span>instance Monad Pure where
202 <span class="lineno">   26 </span>    <span class="decl"><span class="istickedoff">Pure x &gt;&gt;= k = k x</span></span>
203 <span class="lineno">   27 </span>    <span class="decl"><span class="istickedoff">return       = Pure</span></span>
204 <span class="lineno">   28 </span>    <span class="decl"><span class="nottickedoff">fail s       = error s</span></span>
205 <span class="lineno">   29 </span>
206 <span class="lineno">   30 </span>instance MonadEval Pure where
207 <span class="lineno">   31 </span>  <span class="decl"><span class="istickedoff">doOp   = doPureOp</span></span> 
208 <span class="lineno">   32 </span>  <span class="decl"><span class="nottickedoff">err  s = error s</span></span>
209 <span class="lineno">   33 </span>
210 <span class="lineno">   34 </span>instance MonadEval IO where
211 <span class="lineno">   35 </span>  <span class="decl"><span class="istickedoff">doOp prim op stk = do { -- putStrLn (&quot;Calling &quot; ++ show op</span>
212 <span class="lineno">   36 </span><span class="spaces">                          </span><span class="istickedoff">--           ++ &quot; &lt;&lt; &quot; ++ show stk ++ &quot; &gt;&gt;&quot;)</span>
213 <span class="lineno">   37 </span><span class="spaces">                          </span><span class="istickedoff">doAllOp  prim op stk</span>
214 <span class="lineno">   38 </span><span class="spaces">                        </span><span class="istickedoff">}</span></span>
215 <span class="lineno">   39 </span>  <span class="decl"><span class="nottickedoff">err  s = error s</span></span>
216 <span class="lineno">   40 </span>
217 <span class="lineno">   41 </span>data State
218 <span class="lineno">   42 </span>        = State { env   :: Env
219 <span class="lineno">   43 </span>                , stack :: Stack
220 <span class="lineno">   44 </span>                , code  :: Code
221 <span class="lineno">   45 </span>                } deriving <span class="nottickedoff"><span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span></span>
222 <span class="lineno">   46 </span>
223 <span class="lineno">   47 </span>callback :: Env -&gt; Code -&gt; Stack -&gt; Stack
224 <span class="lineno">   48 </span><span class="decl"><span class="istickedoff">callback env code stk</span>
225 <span class="lineno">   49 </span><span class="spaces">      </span><span class="istickedoff">= case eval (State { env = env, stack = stk, code = code}) of</span>
226 <span class="lineno">   50 </span><span class="spaces">             </span><span class="istickedoff">Pure stk -&gt; stk</span></span>
227 <span class="lineno">   51 </span>
228 <span class="lineno">   52 </span>{-# SPECIALIZE eval ::  State -&gt; Pure Stack #-}
229 <span class="lineno">   53 </span>{-# SPECIALIZE eval ::  State -&gt; IO Stack #-}
230 <span class="lineno">   54 </span>
231 <span class="lineno">   55 </span>eval :: MonadEval m =&gt; State -&gt; m Stack
232 <span class="lineno">   56 </span><span class="decl"><span class="istickedoff">eval st =</span>
233 <span class="lineno">   57 </span><span class="spaces">  </span><span class="istickedoff">do { () &lt;- return () -- $ unsafePerformIO (print st)   -- Functional debugger</span>
234 <span class="lineno">   58 </span><span class="spaces">     </span><span class="istickedoff">; if moreCode st then</span>
235 <span class="lineno">   59 </span><span class="spaces">       </span><span class="istickedoff">do { tick             -- tick first, so as to catch loops on new eval.</span>
236 <span class="lineno">   60 </span><span class="spaces">            </span><span class="istickedoff">; st' &lt;- step st</span>
237 <span class="lineno">   61 </span><span class="spaces">            </span><span class="istickedoff">; eval st'</span>
238 <span class="lineno">   62 </span><span class="spaces">            </span><span class="istickedoff">}</span>
239 <span class="lineno">   63 </span><span class="spaces">        </span><span class="istickedoff">else return (stack st)</span>
240 <span class="lineno">   64 </span><span class="spaces">     </span><span class="istickedoff">}</span></span>
241 <span class="lineno">   65 </span>     
242 <span class="lineno">   66 </span>moreCode :: State -&gt; Bool
243 <span class="lineno">   67 </span><span class="decl"><span class="istickedoff">moreCode (State {code = []}) = False</span>
244 <span class="lineno">   68 </span><span class="spaces"></span><span class="istickedoff">moreCode _                   = True</span></span>
245 <span class="lineno">   69 </span>
246 <span class="lineno">   70 </span>-- Step has a precondition that there *is* code to run
247 <span class="lineno">   71 </span>{-# SPECIALIZE step ::  State -&gt; Pure State #-}
248 <span class="lineno">   72 </span>{-# SPECIALIZE step ::  State -&gt; IO State #-}
249 <span class="lineno">   73 </span>step :: MonadEval m =&gt; State -&gt; m State
250 <span class="lineno">   74 </span>
251 <span class="lineno">   75 </span>-- Rule 1: Pushing BaseValues
252 <span class="lineno">   76 </span><span class="decl"><span class="istickedoff">step st@(State{ stack = stack, code = (TBool b):cs })    </span>
253 <span class="lineno">   77 </span><span class="spaces">    </span><span class="istickedoff">= <span class="nottickedoff">return (st { stack = (VBool b):stack,    code = cs })</span></span>
254 <span class="lineno">   78 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ stack = stack, code = (TInt i):cs })     </span>
255 <span class="lineno">   79 </span><span class="spaces">    </span><span class="istickedoff">= return (st { stack = (VInt i):stack,     code = cs })</span>
256 <span class="lineno">   80 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ stack = stack, code = (TReal r):cs })    </span>
257 <span class="lineno">   81 </span><span class="spaces">    </span><span class="istickedoff">= return (st { stack = (VReal r):stack,    code = cs })</span>
258 <span class="lineno">   82 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ stack = stack, code = (TString s):cs })  </span>
259 <span class="lineno">   83 </span><span class="spaces">    </span><span class="istickedoff">= return (st { stack = (VString <span class="nottickedoff">s</span>):stack,  code = cs })</span>
260 <span class="lineno">   84 </span><span class="spaces"></span><span class="istickedoff"></span>
261 <span class="lineno">   85 </span><span class="spaces"></span><span class="istickedoff">-- Rule 2: Name binding</span>
262 <span class="lineno">   86 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = (v:stack), code = (TBind id):cs }) =</span>
263 <span class="lineno">   87 </span><span class="spaces">  </span><span class="istickedoff">return (State { env = extendEnv env id v, stack = stack,  code = cs })</span>
264 <span class="lineno">   88 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = [], code = (TBind id):cs }) =</span>
265 <span class="lineno">   89 </span><span class="spaces">  </span><span class="istickedoff"><span class="nottickedoff">err &quot;Attempt to bind the top of an empty stack&quot;</span></span>
266 <span class="lineno">   90 </span><span class="spaces"></span><span class="istickedoff"></span>
267 <span class="lineno">   91 </span><span class="spaces"></span><span class="istickedoff">-- Rule 3: Name lookup</span>
268 <span class="lineno">   92 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = (TId id):cs }) =</span>
269 <span class="lineno">   93 </span><span class="spaces">  </span><span class="istickedoff">case (lookupEnv env id) of</span>
270 <span class="lineno">   94 </span><span class="spaces">  </span><span class="istickedoff">Just v -&gt; return (st { stack = v:stack,  code = cs })</span>
271 <span class="lineno">   95 </span><span class="spaces">  </span><span class="istickedoff">Nothing -&gt; <span class="nottickedoff">err (&quot;Cannot find value for identifier: &quot; ++ id)</span></span>
272 <span class="lineno">   96 </span><span class="spaces"></span><span class="istickedoff"></span>
273 <span class="lineno">   97 </span><span class="spaces"></span><span class="istickedoff">-- Rule 4: Closure creation</span>
274 <span class="lineno">   98 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = (TBody body):cs }) =</span>
275 <span class="lineno">   99 </span><span class="spaces">  </span><span class="istickedoff">return (st { stack = (VClosure env body):stack, code = cs })</span>
276 <span class="lineno">  100 </span><span class="spaces"></span><span class="istickedoff"></span>
277 <span class="lineno">  101 </span><span class="spaces"></span><span class="istickedoff">-- Rule 5: Application</span>
278 <span class="lineno">  102 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = (VClosure env' code'):stack, code = TApply:cs }) =</span>
279 <span class="lineno">  103 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- eval (State {env = <span class="nottickedoff">env'</span>, stack = stack, code = code'})</span>
280 <span class="lineno">  104 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
281 <span class="lineno">  105 </span><span class="spaces">     </span><span class="istickedoff">}</span>
282 <span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = [], code = TApply:cs }) =</span>
283 <span class="lineno">  107 </span><span class="spaces">  </span><span class="istickedoff"><span class="nottickedoff">err &quot;Application with an empty stack&quot;</span></span>
284 <span class="lineno">  108 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = _:_, code = TApply:cs }) =</span>
285 <span class="lineno">  109 </span><span class="spaces">  </span><span class="istickedoff"><span class="nottickedoff">err &quot;Application of a non-closure&quot;</span></span>
286 <span class="lineno">  110 </span><span class="spaces"></span><span class="istickedoff"></span>
287 <span class="lineno">  111 </span><span class="spaces"></span><span class="istickedoff">-- Rule 6: Arrays</span>
288 <span class="lineno">  112 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = TArray code':cs }) =</span>
289 <span class="lineno">  113 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- eval (State {env = env, stack = [], code = code'})</span>
290 <span class="lineno">  114 </span><span class="spaces">     </span><span class="istickedoff">; let last = length stk-1</span>
291 <span class="lineno">  115 </span><span class="spaces">     </span><span class="istickedoff">; let arr = array (0,last) (zip [last,last-1..] stk)</span>
292 <span class="lineno">  116 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = (VArray arr):stack, code = cs })</span>
293 <span class="lineno">  117 </span><span class="spaces">     </span><span class="istickedoff">}</span>
294 <span class="lineno">  118 </span><span class="spaces"></span><span class="istickedoff"></span>
295 <span class="lineno">  119 </span><span class="spaces"></span><span class="istickedoff">-- Rule 7 &amp; 8: If statement</span>
296 <span class="lineno">  120 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool True):stack, code = TIf:cs }) =</span>
297 <span class="lineno">  121 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- eval (State {env = e1, stack = stack, code = c1})</span>
298 <span class="lineno">  122 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
299 <span class="lineno">  123 </span><span class="spaces">     </span><span class="istickedoff">}</span>
300 <span class="lineno">  124 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool False):stack, code = TIf:cs }) =</span>
301 <span class="lineno">  125 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- eval (State {env = e2, stack = stack, code = c2})</span>
302 <span class="lineno">  126 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
303 <span class="lineno">  127 </span><span class="spaces">     </span><span class="istickedoff">}</span>
304 <span class="lineno">  128 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = _, code = TIf:cs }) =</span>
305 <span class="lineno">  129 </span><span class="spaces">  </span><span class="istickedoff"><span class="nottickedoff">err &quot;Incorrect use of if (bad and/or inappropriate values on the stack)&quot;</span></span>
306 <span class="lineno">  130 </span><span class="spaces"></span><span class="istickedoff"></span>
307 <span class="lineno">  131 </span><span class="spaces"></span><span class="istickedoff">-- Rule 9: Operators</span>
308 <span class="lineno">  132 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = (TOp op):cs }) =</span>
309 <span class="lineno">  133 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- doOp (opFnTable ! op) op stack</span>
310 <span class="lineno">  134 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
311 <span class="lineno">  135 </span><span class="spaces">     </span><span class="istickedoff">}</span>
312 <span class="lineno">  136 </span><span class="spaces"></span><span class="istickedoff"></span>
313 <span class="lineno">  137 </span><span class="spaces"></span><span class="istickedoff">-- Rule Opps</span>
314 <span class="lineno">  138 </span><span class="spaces"></span><span class="istickedoff">step _ = <span class="nottickedoff">err &quot;Tripped on sidewalk while stepping.&quot;</span></span></span>
315 <span class="lineno">  139 </span>
316 <span class="lineno">  140 </span>
317 <span class="lineno">  141 </span>--------------------------------------------------------------------------
318 <span class="lineno">  142 </span>-- Operator code
319 <span class="lineno">  143 </span>
320 <span class="lineno">  144 </span>opFnTable :: Array GMLOp PrimOp
321 <span class="lineno">  145 </span><span class="decl"><span class="istickedoff">opFnTable = array (minBound,maxBound) </span>
322 <span class="lineno">  146 </span><span class="spaces">                  </span><span class="istickedoff">[ (op,prim) | (_,TOp op,prim) &lt;- opcodes ]</span></span>
323 <span class="lineno">  147 </span>
324 <span class="lineno">  148 </span>
325 <span class="lineno">  149 </span>
326 <span class="lineno">  150 </span>
327 <span class="lineno">  151 </span>doPureOp :: (MonadEval m) =&gt; PrimOp -&gt; GMLOp -&gt; Stack -&gt; m Stack
328 <span class="lineno">  152 </span><span class="decl"><span class="istickedoff">doPureOp _ Op_render _ = </span>
329 <span class="lineno">  153 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">err (&quot;\nAttempting to call render from inside a purely functional callback.&quot;)</span></span>
330 <span class="lineno">  154 </span><span class="spaces"></span><span class="istickedoff">doPureOp primOp op stk = doPrimOp primOp <span class="nottickedoff">op</span> stk</span></span> -- call the purely functional operators
331 <span class="lineno">  155 </span>
332 <span class="lineno">  156 </span>{-# SPECIALIZE doPrimOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; Pure Stack #-}
333 <span class="lineno">  157 </span>{-# SPECIALIZE doPrimOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; IO Stack #-}
334 <span class="lineno">  158 </span>{-# SPECIALIZE doPrimOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; Abs Stack #-}
335 <span class="lineno">  159 </span>
336 <span class="lineno">  160 </span>doPrimOp ::  (MonadEval m) =&gt; PrimOp -&gt; GMLOp -&gt; Stack -&gt; m Stack
337 <span class="lineno">  161 </span>
338 <span class="lineno">  162 </span>-- 1 argument.
339 <span class="lineno">  163 </span>
340 <span class="lineno">  164 </span><span class="decl"><span class="istickedoff">doPrimOp (Int_Int fn) _ (VInt i1:stk)</span>
341 <span class="lineno">  165 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">return ((VInt (fn i1)) : stk)</span></span>
342 <span class="lineno">  166 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Real fn) _ (VReal r1:stk)</span>
343 <span class="lineno">  167 </span><span class="spaces">  </span><span class="istickedoff">= return ((VReal (fn r1)) : stk)</span>
344 <span class="lineno">  168 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Point_Real fn) _ (VPoint x y z:stk)</span>
345 <span class="lineno">  169 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">return ((VReal (fn x y z)) : stk)</span></span>
346 <span class="lineno">  170 </span><span class="spaces"></span><span class="istickedoff"></span>
347 <span class="lineno">  171 </span><span class="spaces"></span><span class="istickedoff">-- This is where the callbacks happen from...</span>
348 <span class="lineno">  172 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)</span>
349 <span class="lineno">  173 </span><span class="spaces">  </span><span class="istickedoff">= case absapply env code [<span class="nottickedoff">VAbsObj AbsFACE</span>,<span class="nottickedoff">VAbsObj AbsU</span>,<span class="nottickedoff">VAbsObj AbsV</span>] of</span>
350 <span class="lineno">  174 </span><span class="spaces">      </span><span class="istickedoff">Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] -&gt; </span>
351 <span class="lineno">  175 </span><span class="spaces">           </span><span class="istickedoff"><span class="nottickedoff">let</span></span>
352 <span class="lineno">  176 </span><span class="spaces">               </span><span class="istickedoff"><span class="nottickedoff">res = prop (color c1 c2 c3) r1 r2 r3</span></span>
353 <span class="lineno">  177 </span><span class="spaces">           </span><span class="istickedoff"><span class="nottickedoff">in</span></span>
354 <span class="lineno">  178 </span><span class="spaces">               </span><span class="istickedoff"><span class="nottickedoff">return ((VObject (fn (SConst res))) : stk)</span></span>
355 <span class="lineno">  179 </span><span class="spaces">      </span><span class="istickedoff">_ -&gt; return ((VObject (fn (SFun call))) : stk)</span>
356 <span class="lineno">  180 </span><span class="spaces">  </span><span class="istickedoff">where </span>
357 <span class="lineno">  181 </span><span class="spaces">        </span><span class="istickedoff">-- The most general case</span>
358 <span class="lineno">  182 </span><span class="spaces">        </span><span class="istickedoff">call i r1 r2 =</span>
359 <span class="lineno">  183 </span><span class="spaces">          </span><span class="istickedoff">case callback env code [VReal r2,VReal r1,<span class="nottickedoff">VInt i</span>] of</span>
360 <span class="lineno">  184 </span><span class="spaces">             </span><span class="istickedoff">[VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] </span>
361 <span class="lineno">  185 </span><span class="spaces">                 </span><span class="istickedoff">-&gt; prop (color c1 c2 c3) r1 r2 r3</span>
362 <span class="lineno">  186 </span><span class="spaces">             </span><span class="istickedoff">stk -&gt; <span class="nottickedoff">error (&quot;callback failed: incorrectly typed return arguments&quot;</span></span>
363 <span class="lineno">  187 </span><span class="spaces">                         </span><span class="istickedoff"><span class="nottickedoff">++ show stk)</span></span>
364 <span class="lineno">  188 </span><span class="spaces">       </span><span class="istickedoff"></span>
365 <span class="lineno">  189 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Int fn) _ (VReal r1:stk)</span>
366 <span class="lineno">  190 </span><span class="spaces">  </span><span class="istickedoff">= return ((VInt (fn r1)) : stk)</span>
367 <span class="lineno">  191 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Int_Real fn) _ (VInt r1:stk)</span>
368 <span class="lineno">  192 </span><span class="spaces">  </span><span class="istickedoff">= return ((VReal (fn r1)) : stk)</span>
369 <span class="lineno">  193 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Arr_Int fn) _ (VArray arr:stk)</span>
370 <span class="lineno">  194 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">return ((VInt (fn arr)) : stk)</span></span>
371 <span class="lineno">  195 </span><span class="spaces"></span><span class="istickedoff"></span>
372 <span class="lineno">  196 </span><span class="spaces"></span><span class="istickedoff">-- 2 arguments.</span>
373 <span class="lineno">  197 </span><span class="spaces"></span><span class="istickedoff"></span>
374 <span class="lineno">  198 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk)</span>
375 <span class="lineno">  199 </span><span class="spaces">  </span><span class="istickedoff">= return ((VInt (fn i1 i2)) : stk)</span>
376 <span class="lineno">  200 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk)</span>
377 <span class="lineno">  201 </span><span class="spaces">  </span><span class="istickedoff">= return ((VBool (fn i1 i2)) : stk)</span>
378 <span class="lineno">  202 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk)</span>
379 <span class="lineno">  203 </span><span class="spaces">  </span><span class="istickedoff">= return ((VReal (fn r1 r2)) : stk)</span>
380 <span class="lineno">  204 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk)</span>
381 <span class="lineno">  205 </span><span class="spaces">  </span><span class="istickedoff">= return ((VBool (fn r1 r2)) : stk)</span>
382 <span class="lineno">  206 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk)</span>
383 <span class="lineno">  207 </span><span class="spaces">  </span><span class="istickedoff">= return ((fn arr i) : stk)</span>
384 <span class="lineno">  208 </span><span class="spaces"></span><span class="istickedoff"></span>
385 <span class="lineno">  209 </span><span class="spaces"></span><span class="istickedoff"></span>
386 <span class="lineno">  210 </span><span class="spaces">    </span><span class="istickedoff">-- Many arguments, typically image mangling</span>
387 <span class="lineno">  211 </span><span class="spaces"></span><span class="istickedoff"></span>
388 <span class="lineno">  212 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk)</span>
389 <span class="lineno">  213 </span><span class="spaces">  </span><span class="istickedoff">= return ((VObject (fn o1 o2)) : <span class="nottickedoff">stk</span>)</span>
390 <span class="lineno">  214 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Point_Color_Light fn) _ (VPoint r g b:VPoint x y z : stk)</span>
391 <span class="lineno">  215 </span><span class="spaces">  </span><span class="istickedoff">= return (VLight (fn (x,y,z) (color r g b)) : <span class="nottickedoff">stk</span>)</span>
392 <span class="lineno">  216 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Point_Point_Color_Real_Real_Light fn) _ </span>
393 <span class="lineno">  217 </span><span class="spaces">         </span><span class="istickedoff">(VReal r2:VReal r1:VPoint r g b:VPoint x2 y2 z2:VPoint x1 y1 z1 : stk)</span>
394 <span class="lineno">  218 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">return (VLight (fn (x1,y1,z1) (x2,y2,z2) (color r g b) r1 r2) : stk)</span></span>
395 <span class="lineno">  219 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Real_Real_Point fn) _ (VReal r3:VReal r2:VReal r1:stk)</span>
396 <span class="lineno">  220 </span><span class="spaces">  </span><span class="istickedoff">= return ((fn r1 r2 r3) : stk)</span>
397 <span class="lineno">  221 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk)</span>
398 <span class="lineno">  222 </span><span class="spaces">  </span><span class="istickedoff">= return (VObject (fn o r) : <span class="nottickedoff">stk</span>)</span>
399 <span class="lineno">  223 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Obj_Real_Real_Real_Obj fn) _ (VReal r3:VReal r2:VReal r1:VObject o:stk)</span>
400 <span class="lineno">  224 </span><span class="spaces">  </span><span class="istickedoff">= return (VObject (fn o r1 r2 r3) : stk)</span>
401 <span class="lineno">  225 </span><span class="spaces"></span><span class="istickedoff"></span>
402 <span class="lineno">  226 </span><span class="spaces"></span><span class="istickedoff">-- This one is our testing harness</span>
403 <span class="lineno">  227 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Value_String_Value fn) _ (VString s:o:stk)</span>
404 <span class="lineno">  228 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">res `seq` return (res : stk)</span></span>
405 <span class="lineno">  229 </span><span class="spaces">  </span><span class="istickedoff">where</span>
406 <span class="lineno">  230 </span><span class="spaces">     </span><span class="istickedoff"><span class="nottickedoff">res = fn o s</span></span>
407 <span class="lineno">  231 </span><span class="spaces"></span><span class="istickedoff"></span>
408 <span class="lineno">  232 </span><span class="spaces"></span><span class="istickedoff">doPrimOp primOp op args </span>
409 <span class="lineno">  233 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">err (&quot;\n\ntype error when attempting to execute builtin primitive \&quot;&quot; ++</span></span>
410 <span class="lineno">  234 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">show op ++ &quot;\&quot;\n\n| &quot; ++</span></span>
411 <span class="lineno">  235 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">show op ++ &quot; takes &quot; ++ show (length types) ++ &quot; argument&quot; ++ s</span></span>
412 <span class="lineno">  236 </span><span class="spaces">                   </span><span class="istickedoff"><span class="nottickedoff">++ &quot; with&quot; ++ the ++ &quot; type&quot; ++ s ++ &quot;\n|\n|&quot; ++</span></span>
413 <span class="lineno">  237 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">&quot;      &quot; ++ unwords [ show ty | ty &lt;- types ]  ++ &quot;\n|\n|&quot; ++ </span></span>
414 <span class="lineno">  238 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">&quot; currently, the relevent argument&quot; ++ s ++ &quot; on the stack &quot; ++ </span></span>
415 <span class="lineno">  239 </span><span class="spaces">                  </span><span class="istickedoff"><span class="nottickedoff">are ++ &quot;\n|\n| &quot; ++ </span></span>
416 <span class="lineno">  240 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">unwords [ &quot;(&quot; ++ show arg ++ &quot;)&quot; </span></span>
417 <span class="lineno">  241 </span><span class="spaces">                  </span><span class="istickedoff"><span class="nottickedoff">| arg &lt;-  reverse (take (length types) args) ]  ++ &quot;\n|\n| &quot;</span></span>
418 <span class="lineno">  242 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">++ &quot;    (top of stack is on the right hand side)\n\n&quot;)</span></span>
419 <span class="lineno">  243 </span><span class="spaces">  </span><span class="istickedoff">where</span>
420 <span class="lineno">  244 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">len   = length types</span></span>
421 <span class="lineno">  245 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">s =  (if len /= 1 then &quot;s&quot; else &quot;&quot;)</span></span>
422 <span class="lineno">  246 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">are =  (if len /= 1 then &quot;are&quot; else &quot;is&quot;)</span></span>
423 <span class="lineno">  247 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">the =  (if len /= 1 then &quot;&quot; else &quot; the&quot;)</span></span>
424 <span class="lineno">  248 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">types = getPrimOpType primOp</span></span></span>
425 <span class="lineno">  249 </span>
426 <span class="lineno">  250 </span>
427 <span class="lineno">  251 </span>-- Render is somewhat funny, becauase it can only get called at top level.
428 <span class="lineno">  252 </span>-- All other operations are purely functional.
429 <span class="lineno">  253 </span>
430 <span class="lineno">  254 </span>doAllOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; IO Stack
431 <span class="lineno">  255 </span><span class="decl"><span class="istickedoff">doAllOp (Render render) Op_render</span>
432 <span class="lineno">  256 </span><span class="spaces">                           </span><span class="istickedoff">(VString str:VInt ht:VInt wid:VReal fov</span>
433 <span class="lineno">  257 </span><span class="spaces">                           </span><span class="istickedoff">:VInt dep:VObject obj:VArray arr</span>
434 <span class="lineno">  258 </span><span class="spaces">                           </span><span class="istickedoff">:VPoint r g b : stk)</span>
435 <span class="lineno">  259 </span><span class="spaces">  </span><span class="istickedoff">= do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht <span class="nottickedoff">str</span></span>
436 <span class="lineno">  260 </span><span class="spaces">       </span><span class="istickedoff">; return <span class="nottickedoff">stk</span></span>
437 <span class="lineno">  261 </span><span class="spaces">       </span><span class="istickedoff">}</span>
438 <span class="lineno">  262 </span><span class="spaces">  </span><span class="istickedoff">where</span>
439 <span class="lineno">  263 </span><span class="spaces">      </span><span class="istickedoff">lights = [ light | (VLight light) &lt;- elems arr ]</span>
440 <span class="lineno">  264 </span><span class="spaces"></span><span class="istickedoff"></span>
441 <span class="lineno">  265 </span><span class="spaces"></span><span class="istickedoff">doAllOp primOp op stk = doPrimOp primOp <span class="nottickedoff">op</span> stk</span></span> -- call the purely functional operators
442 <span class="lineno">  266 </span>
443 <span class="lineno">  267 </span>------------------------------------------------------------------------------
444 <span class="lineno">  268 </span>{-
445 <span class="lineno">  269 </span> - Abstract evaluation.
446 <span class="lineno">  270 </span> -
447 <span class="lineno">  271 </span> - The idea is you check for constant code that 
448 <span class="lineno">  272 </span> - (1) does not look at its arguments
449 <span class="lineno">  273 </span> - (2) gives a fixed result
450 <span class="lineno">  274 </span> -
451 <span class="lineno">  275 </span> - We run for 100 steps.
452 <span class="lineno">  276 </span> -
453 <span class="lineno">  277 </span> -}
454 <span class="lineno">  278 </span>
455 <span class="lineno">  279 </span>absapply :: Env -&gt; Code -&gt; Stack -&gt; Maybe Stack
456 <span class="lineno">  280 </span><span class="decl"><span class="istickedoff">absapply env code stk = </span>
457 <span class="lineno">  281 </span><span class="spaces">     </span><span class="istickedoff">case runAbs (eval (State env stk code)) 100 of</span>
458 <span class="lineno">  282 </span><span class="spaces">       </span><span class="istickedoff">AbsState stk _ -&gt; <span class="nottickedoff">Just stk</span></span>
459 <span class="lineno">  283 </span><span class="spaces">       </span><span class="istickedoff">AbsFail m      -&gt; Nothing</span></span>
460 <span class="lineno">  284 </span>
461 <span class="lineno">  285 </span>newtype Abs a   = Abs { runAbs :: Int -&gt; AbsState a }
462 <span class="lineno">  286 </span>data AbsState a = AbsState a !Int
463 <span class="lineno">  287 </span>                | AbsFail String
464 <span class="lineno">  288 </span>
465 <span class="lineno">  289 </span>instance Monad Abs where
466 <span class="lineno">  290 </span>    <span class="decl"><span class="istickedoff">(Abs fn) &gt;&gt;= k = Abs (\ s -&gt; case fn s of</span>
467 <span class="lineno">  291 </span><span class="spaces">                                   </span><span class="istickedoff">AbsState r s' -&gt; runAbs (k r) s'</span>
468 <span class="lineno">  292 </span><span class="spaces">                                   </span><span class="istickedoff">AbsFail m     -&gt; AbsFail <span class="nottickedoff">m</span>)</span></span>
469 <span class="lineno">  293 </span>    <span class="decl"><span class="istickedoff">return x     = Abs (\ n -&gt; AbsState x n)</span></span>
470 <span class="lineno">  294 </span>    <span class="decl"><span class="istickedoff">fail s       = Abs (\ n -&gt; AbsFail <span class="nottickedoff">s</span>)</span></span>
471 <span class="lineno">  295 </span>
472 <span class="lineno">  296 </span>instance MonadEval Abs where
473 <span class="lineno">  297 </span>  <span class="decl"><span class="istickedoff">doOp = doAbsOp</span></span>
474 <span class="lineno">  298 </span>  <span class="decl"><span class="istickedoff">err  = fail</span></span>
475 <span class="lineno">  299 </span>  <span class="decl"><span class="istickedoff">tick = Abs (\ n -&gt; if <span class="tickonlyfalse">n &lt;= 0</span></span>
476 <span class="lineno">  300 </span><span class="spaces">                     </span><span class="istickedoff">then <span class="nottickedoff">AbsFail &quot;run out of time&quot;</span></span>
477 <span class="lineno">  301 </span><span class="spaces">                     </span><span class="istickedoff">else AbsState <span class="nottickedoff">()</span> (n-1))</span></span>
478 <span class="lineno">  302 </span>
479 <span class="lineno">  303 </span>doAbsOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; Abs Stack
480 <span class="lineno">  304 </span><span class="decl"><span class="istickedoff">doAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk) </span>
481 <span class="lineno">  305 </span><span class="spaces">               </span><span class="istickedoff">= <span class="nottickedoff">return ((VPoint r1 r2 r3) : stk)</span></span>
482 <span class="lineno">  306 </span><span class="spaces"> </span><span class="istickedoff">-- here, you could have an (AbsPoint :: AbsObj) which you put on the</span>
483 <span class="lineno">  307 </span><span class="spaces"> </span><span class="istickedoff">-- stack, with any object in the three fields.</span>
484 <span class="lineno">  308 </span><span class="spaces"></span><span class="istickedoff">doAbsOp _ op _ = err <span class="nottickedoff">(&quot;operator not understood (&quot; ++ show op ++ &quot;)&quot;)</span></span></span>
485 <span class="lineno">  309 </span>
486 <span class="lineno">  310 </span>------------------------------------------------------------------------------
487 <span class="lineno">  311 </span>-- Driver
488 <span class="lineno">  312 </span>
489 <span class="lineno">  313 </span>mainEval :: Code -&gt; IO ()
490 <span class="lineno">  314 </span><span class="decl"><span class="istickedoff">mainEval prog = do { stk &lt;- eval (State <span class="nottickedoff">emptyEnv</span> [] prog) </span>
491 <span class="lineno">  315 </span><span class="spaces">                   </span><span class="istickedoff">; return <span class="nottickedoff">()</span></span>
492 <span class="lineno">  316 </span><span class="spaces">                   </span><span class="istickedoff">}</span></span>
493 <span class="lineno">  317 </span>{- 
494 <span class="lineno">  318 </span>  * Oops, one of the example actually has something
495 <span class="lineno">  319 </span>  * on the stack at the end. 
496 <span class="lineno">  320 </span>  * Oh well...
497 <span class="lineno">  321 </span>                  ; if null stk
498 <span class="lineno">  322 </span>                     then return ()
499 <span class="lineno">  323 </span>                    else do { putStrLn done
500 <span class="lineno">  324 </span>                             ; print stk
501 <span class="lineno">  325 </span>                             }
502 <span class="lineno">  326 </span>-}
503 <span class="lineno">  327 </span>
504 <span class="lineno">  328 </span><span class="decl"><span class="nottickedoff">done = &quot;Items still on stack at (successfull) termination of program&quot;</span></span>
505 <span class="lineno">  329 </span>
506 <span class="lineno">  330 </span>------------------------------------------------------------------------------
507 <span class="lineno">  331 </span>-- testing
508 <span class="lineno">  332 </span>
509 <span class="lineno">  333 </span>test :: String -&gt; Pure Stack
510 <span class="lineno">  334 </span><span class="decl"><span class="nottickedoff">test is = eval (State emptyEnv [] (rayParse is))</span></span>
511 <span class="lineno">  335 </span>
512 <span class="lineno">  336 </span>testF :: String -&gt; IO Stack
513 <span class="lineno">  337 </span><span class="decl"><span class="nottickedoff">testF is = do prog &lt;- rayParseF is</span>
514 <span class="lineno">  338 </span><span class="spaces">              </span><span class="nottickedoff">eval (State emptyEnv [] prog)</span></span>
515 <span class="lineno">  339 </span>
516 <span class="lineno">  340 </span>testA :: String -&gt; Either String (Stack,Int)
517 <span class="lineno">  341 </span><span class="decl"><span class="nottickedoff">testA is = case runAbs (eval (State emptyEnv </span>
518 <span class="lineno">  342 </span><span class="spaces">                                    </span><span class="nottickedoff">[VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV]</span>
519 <span class="lineno">  343 </span><span class="spaces">                                    </span><span class="nottickedoff">(rayParse is))) 100 of</span>
520 <span class="lineno">  344 </span><span class="spaces">             </span><span class="nottickedoff">AbsState a n -&gt; Right (a,n)</span>
521 <span class="lineno">  345 </span><span class="spaces">             </span><span class="nottickedoff">AbsFail m -&gt; Left m</span></span>
522 <span class="lineno">  346 </span>
523 <span class="lineno">  347 </span><span class="decl"><span class="nottickedoff">abstest1 = &quot;1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply&quot;</span></span> 
524 <span class="lineno">  348 </span>
525 <span class="lineno">  349 </span>-- should be [3:: Int]
526 <span class="lineno">  350 </span><span class="decl"><span class="nottickedoff">et1 = test &quot;1 /x { x } /f 2 /x f apply x addi&quot;</span></span>
527 <span class="lineno">  351 </span>
528 <span class="lineno">  352 </span>
529 <span class="lineno">  353 </span>
530 <span class="lineno">  354 </span>
531 <span class="lineno">  355 </span>
532
533 </pre>
534 </html>
535 Writing: Data.hs.html
536 <html><style type="text/css">
537 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
538 span.nottickedoff { background: yellow}
539 span.istickedoff { background: white }
540 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
541 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
542 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
543 span.decl { font-weight: bold }
544 span.spaces    { background: white }
545 </style>
546 <pre>
547 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
548 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
549 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
550 <span class="lineno">    4 </span>-- which is included in the distribution.
551 <span class="lineno">    5 </span>
552 <span class="lineno">    6 </span>module Data where
553 <span class="lineno">    7 </span>
554 <span class="lineno">    8 </span>import Array
555 <span class="lineno">    9 </span>
556 <span class="lineno">   10 </span>import CSG      
557 <span class="lineno">   11 </span>import Geometry
558 <span class="lineno">   12 </span>import Illumination
559 <span class="lineno">   13 </span>import Primitives
560 <span class="lineno">   14 </span>import Surface
561 <span class="lineno">   15 </span>
562 <span class="lineno">   16 </span>import Debug.Trace
563 <span class="lineno">   17 </span>
564 <span class="lineno">   18 </span>-- Now the parsed (expresssion) language
565 <span class="lineno">   19 </span>
566 <span class="lineno">   20 </span>type Name = String
567 <span class="lineno">   21 </span>
568 <span class="lineno">   22 </span>type Code = [GMLToken]
569 <span class="lineno">   23 </span>
570 <span class="lineno">   24 </span>data GMLToken
571 <span class="lineno">   25 </span>    -- All these can occur in parsed code
572 <span class="lineno">   26 </span>        = TOp     GMLOp
573 <span class="lineno">   27 </span>        | TId     Name
574 <span class="lineno">   28 </span>        | TBind   Name
575 <span class="lineno">   29 </span>        | TBool   Bool
576 <span class="lineno">   30 </span>        | TInt    Int
577 <span class="lineno">   31 </span>        | TReal   Double
578 <span class="lineno">   32 </span>        | TString String
579 <span class="lineno">   33 </span>        | TBody   Code
580 <span class="lineno">   34 </span>        | TArray  Code
581 <span class="lineno">   35 </span>        | TApply
582 <span class="lineno">   36 </span>        | TIf
583 <span class="lineno">   37 </span>         -- These can occur in optimized/transformed code
584 <span class="lineno">   38 </span>         -- NONE (yet!)
585 <span class="lineno">   39 </span>
586 <span class="lineno">   40 </span>
587 <span class="lineno">   41 </span>instance <span class="nottickedoff">Show GMLToken</span> where
588 <span class="lineno">   42 </span>   <span class="decl"><span class="nottickedoff">showsPrec p (TOp op)     = shows op</span>
589 <span class="lineno">   43 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TId id)     = showString id</span>
590 <span class="lineno">   44 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TBind id)   = showString ('/' : id)</span>
591 <span class="lineno">   45 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TBool bool) = shows bool</span>
592 <span class="lineno">   46 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TInt i)     = shows i</span>
593 <span class="lineno">   47 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TReal d)    = shows d</span>
594 <span class="lineno">   48 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TString s)  = shows s</span>
595 <span class="lineno">   49 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TBody code) = shows code</span>
596 <span class="lineno">   50 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TArray code) = showString &quot;[ &quot; </span>
597 <span class="lineno">   51 </span><span class="spaces">                            </span><span class="nottickedoff">. foldr (\ a b -&gt; a . showChar ' ' . b) id (map shows code) </span>
598 <span class="lineno">   52 </span><span class="spaces">                            </span><span class="nottickedoff">. showString &quot;]&quot;</span>
599 <span class="lineno">   53 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TApply)     = showString &quot;apply&quot; </span>
600 <span class="lineno">   54 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TIf)        = showString &quot;if&quot;</span></span> 
601 <span class="lineno">   55 </span>
602 <span class="lineno">   56 </span>   <span class="decl"><span class="nottickedoff">showList  code = showString &quot;{ &quot; </span>
603 <span class="lineno">   57 </span><span class="spaces">                  </span><span class="nottickedoff">. foldr (\ a b -&gt; a . showChar ' ' . b) id (map shows code) </span>
604 <span class="lineno">   58 </span><span class="spaces">                  </span><span class="nottickedoff">. showString &quot;}&quot;</span></span>
605 <span class="lineno">   59 </span>
606 <span class="lineno">   60 </span>
607 <span class="lineno">   61 </span>-- Now the value language, used inside the interpreter
608 <span class="lineno">   62 </span>
609 <span class="lineno">   63 </span>type Stack = [GMLValue]
610 <span class="lineno">   64 </span>
611 <span class="lineno">   65 </span>data GMLValue
612 <span class="lineno">   66 </span>        = VBool    !Bool
613 <span class="lineno">   67 </span>        | VInt     !Int
614 <span class="lineno">   68 </span>        | VReal    !Double
615 <span class="lineno">   69 </span>        | VString  String
616 <span class="lineno">   70 </span>        | VClosure Env Code
617 <span class="lineno">   71 </span>        | VArray   (Array Int GMLValue)               -- FIXME: Haskell array
618 <span class="lineno">   72 </span>        -- uses the interpreter version of point
619 <span class="lineno">   73 </span>        | VPoint   { xPoint :: !Double
620 <span class="lineno">   74 </span>                   , yPoint :: !Double 
621 <span class="lineno">   75 </span>                   , zPoint :: !Double 
622 <span class="lineno">   76 </span>                   } 
623 <span class="lineno">   77 </span>        -- these are abstract to the interpreter
624 <span class="lineno">   78 </span>        | VObject  Object
625 <span class="lineno">   79 </span>        | VLight   Light 
626 <span class="lineno">   80 </span>        -- This is an abstract object, used by the abstract interpreter
627 <span class="lineno">   81 </span>        | VAbsObj  AbsObj
628 <span class="lineno">   82 </span>
629 <span class="lineno">   83 </span>
630 <span class="lineno">   84 </span>-- There are only *3* basic abstract values,
631 <span class="lineno">   85 </span>-- and the combinators also.
632 <span class="lineno">   86 </span>
633 <span class="lineno">   87 </span>data AbsObj 
634 <span class="lineno">   88 </span>    = AbsFACE 
635 <span class="lineno">   89 </span>    | AbsU 
636 <span class="lineno">   90 </span>    | AbsV
637 <span class="lineno">   91 </span>      deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
638 <span class="lineno">   92 </span>
639 <span class="lineno">   93 </span>instance Show GMLValue where
640 <span class="lineno">   94 </span>   <span class="decl"><span class="nottickedoff">showsPrec p value = showString (showStkEle value)</span></span>
641 <span class="lineno">   95 </span>
642 <span class="lineno">   96 </span>showStkEle :: GMLValue -&gt; String
643 <span class="lineno">   97 </span><span class="decl"><span class="nottickedoff">showStkEle (VBool b)      = show b ++ &quot; :: Bool&quot;</span>
644 <span class="lineno">   98 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VInt i)       = show i ++ &quot; :: Int&quot;</span>
645 <span class="lineno">   99 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VReal r)      = show r ++ &quot; :: Real&quot;</span>
646 <span class="lineno">  100 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VString s)    = show s ++ &quot; :: String&quot;</span>
647 <span class="lineno">  101 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VClosure {})  = &quot;&lt;closure&gt; :: Closure&quot;</span>
648 <span class="lineno">  102 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VArray arr)   </span>
649 <span class="lineno">  103 </span><span class="spaces">     </span><span class="nottickedoff">= &quot;&lt;array (&quot; ++  show (succ (snd (bounds arr))) ++ &quot; elements)&gt; :: Array&quot;</span>
650 <span class="lineno">  104 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VPoint x y z) = &quot;(&quot; ++ show x </span>
651 <span class="lineno">  105 </span><span class="spaces">                         </span><span class="nottickedoff">++ &quot;,&quot; ++ show y</span>
652 <span class="lineno">  106 </span><span class="spaces">                         </span><span class="nottickedoff">++ &quot;,&quot; ++ show z</span>
653 <span class="lineno">  107 </span><span class="spaces">                         </span><span class="nottickedoff">++ &quot;) :: Point&quot;</span>
654 <span class="lineno">  108 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VObject {})   = &quot;&lt;Object&gt; :: Object&quot;</span>
655 <span class="lineno">  109 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VLight {})    = &quot;&lt;Light&gt; :: Object&quot;</span>
656 <span class="lineno">  110 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VAbsObj vobs) = &quot;{{ &quot; ++ show vobs ++ &quot;}} :: AbsObj&quot;</span></span>
657 <span class="lineno">  111 </span>
658 <span class="lineno">  112 </span>-- An abstract environment
659 <span class="lineno">  113 </span>
660 <span class="lineno">  114 </span>newtype Env = Env [(Name, GMLValue)] deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
661 <span class="lineno">  115 </span>
662 <span class="lineno">  116 </span>emptyEnv :: Env
663 <span class="lineno">  117 </span><span class="decl"><span class="nottickedoff">emptyEnv = Env []</span></span>
664 <span class="lineno">  118 </span>
665 <span class="lineno">  119 </span>extendEnv :: Env -&gt; Name -&gt; GMLValue -&gt; Env
666 <span class="lineno">  120 </span><span class="decl"><span class="istickedoff">extendEnv (Env e) n v = Env ((n, v):e)</span></span>
667 <span class="lineno">  121 </span>
668 <span class="lineno">  122 </span>lookupEnv :: Env -&gt; Name -&gt; Maybe GMLValue
669 <span class="lineno">  123 </span><span class="decl"><span class="istickedoff">lookupEnv (Env e) n = lookup n e</span></span>
670 <span class="lineno">  124 </span>
671 <span class="lineno">  125 </span>-- All primitive operators
672 <span class="lineno">  126 </span>-- 
673 <span class="lineno">  127 </span>-- There is no Op_apply, Op_false, Op_true and Op_if
674 <span class="lineno">  128 </span>-- (because they appear explcitly in the rules).
675 <span class="lineno">  129 </span>
676 <span class="lineno">  130 </span>data GMLOp
677 <span class="lineno">  131 </span>   = Op_acos
678 <span class="lineno">  132 </span>   | Op_addi
679 <span class="lineno">  133 </span>   | Op_addf
680 <span class="lineno">  134 </span>   | Op_asin
681 <span class="lineno">  135 </span>   | Op_clampf
682 <span class="lineno">  136 </span>   | Op_cone
683 <span class="lineno">  137 </span>   | Op_cos
684 <span class="lineno">  138 </span>   | Op_cube
685 <span class="lineno">  139 </span>   | Op_cylinder
686 <span class="lineno">  140 </span>   | Op_difference
687 <span class="lineno">  141 </span>   | Op_divi
688 <span class="lineno">  142 </span>   | Op_divf
689 <span class="lineno">  143 </span>   | Op_eqi
690 <span class="lineno">  144 </span>   | Op_eqf
691 <span class="lineno">  145 </span>   | Op_floor
692 <span class="lineno">  146 </span>   | Op_frac
693 <span class="lineno">  147 </span>   | Op_get
694 <span class="lineno">  148 </span>   | Op_getx
695 <span class="lineno">  149 </span>   | Op_gety
696 <span class="lineno">  150 </span>   | Op_getz
697 <span class="lineno">  151 </span>   | Op_intersect
698 <span class="lineno">  152 </span>   | Op_length
699 <span class="lineno">  153 </span>   | Op_lessi
700 <span class="lineno">  154 </span>   | Op_lessf
701 <span class="lineno">  155 </span>   | Op_light
702 <span class="lineno">  156 </span>   | Op_modi
703 <span class="lineno">  157 </span>   | Op_muli
704 <span class="lineno">  158 </span>   | Op_mulf
705 <span class="lineno">  159 </span>   | Op_negi
706 <span class="lineno">  160 </span>   | Op_negf
707 <span class="lineno">  161 </span>   | Op_plane
708 <span class="lineno">  162 </span>   | Op_point
709 <span class="lineno">  163 </span>   | Op_pointlight
710 <span class="lineno">  164 </span>   | Op_real
711 <span class="lineno">  165 </span>   | Op_render
712 <span class="lineno">  166 </span>   | Op_rotatex
713 <span class="lineno">  167 </span>   | Op_rotatey
714 <span class="lineno">  168 </span>   | Op_rotatez
715 <span class="lineno">  169 </span>   | Op_scale
716 <span class="lineno">  170 </span>   | Op_sin
717 <span class="lineno">  171 </span>   | Op_sphere
718 <span class="lineno">  172 </span>   | Op_spotlight
719 <span class="lineno">  173 </span>   | Op_sqrt
720 <span class="lineno">  174 </span>   | Op_subi
721 <span class="lineno">  175 </span>   | Op_subf
722 <span class="lineno">  176 </span>   | Op_trace       -- non standard, for debugging GML programs
723 <span class="lineno">  177 </span>   | Op_translate
724 <span class="lineno">  178 </span>   | Op_union
725 <span class="lineno">  179 </span>   | Op_uscale
726 <span class="lineno">  180 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>,<span class="nottickedoff"><span class="decl"><span class="nottickedoff">Ord</span></span></span>,<span class="decl"><span class="nottickedoff"><span class="decl"><span class="istickedoff"><span class="decl"><span class="istickedoff">Ix</span></span></span></span></span></span>,<span class="decl"><span class="istickedoff"><span class="decl"><span class="istickedoff">Bounded</span></span></span></span>)
727 <span class="lineno">  181 </span>
728 <span class="lineno">  182 </span>instance Show GMLOp where
729 <span class="lineno">  183 </span>   <span class="decl"><span class="nottickedoff">showsPrec _ op = showString (opNameTable ! op)</span></span>
730 <span class="lineno">  184 </span>
731 <span class="lineno">  185 </span>
732 <span class="lineno">  186 </span>------------------------------------------------------------------------------
733 <span class="lineno">  187 </span>
734 <span class="lineno">  188 </span>-- And how we use the op codes (there names, there interface)
735 <span class="lineno">  189 </span>
736 <span class="lineno">  190 </span>-- These keywords include, &quot;apply&quot;, &quot;if&quot;, &quot;true&quot; and &quot;false&quot;,
737 <span class="lineno">  191 </span>-- they are not parsed as operators, but are
738 <span class="lineno">  192 </span>-- captured by the parser as a special case.
739 <span class="lineno">  193 </span>
740 <span class="lineno">  194 </span>keyWords :: [String]
741 <span class="lineno">  195 </span><span class="decl"><span class="nottickedoff">keyWords = [ kwd | (kwd,_,_) &lt;- opcodes ]</span></span>
742 <span class="lineno">  196 </span>
743 <span class="lineno">  197 </span>-- Lookup has to look from the start (or else...)
744 <span class="lineno">  198 </span>opTable :: [(Name,GMLToken)]
745 <span class="lineno">  199 </span><span class="decl"><span class="istickedoff">opTable = [ (kwd,op) | (kwd,op,_) &lt;- opcodes ]</span></span>
746 <span class="lineno">  200 </span>
747 <span class="lineno">  201 </span>opNameTable :: Array GMLOp Name
748 <span class="lineno">  202 </span><span class="decl"><span class="nottickedoff">opNameTable = array (minBound,maxBound) </span>
749 <span class="lineno">  203 </span><span class="spaces">                  </span><span class="nottickedoff">[ (op,name) | (name,TOp op,_) &lt;- opcodes ]</span></span>
750 <span class="lineno">  204 </span>
751 <span class="lineno">  205 </span><span class="decl"><span class="nottickedoff">undef = error &quot;undefined function&quot;</span></span>
752 <span class="lineno">  206 </span><span class="decl"><span class="nottickedoff">image = error &quot;undefined function: talk to image group&quot;</span></span>
753 <span class="lineno">  207 </span>
754 <span class="lineno">  208 </span>-- typically, its best to have *one* opcode table,
755 <span class="lineno">  209 </span>-- so that mis-alignments do not happen.
756 <span class="lineno">  210 </span>
757 <span class="lineno">  211 </span>opcodes :: [(String,GMLToken,PrimOp)]
758 <span class="lineno">  212 </span><span class="decl"><span class="istickedoff">opcodes =</span>
759 <span class="lineno">  213 </span><span class="spaces"> </span><span class="istickedoff">[ (&quot;apply&quot;,      TApply,           <span class="nottickedoff">error &quot;incorrect use of apply&quot;</span>)</span>
760 <span class="lineno">  214 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;if&quot;,         TIf,                   <span class="nottickedoff">error &quot;incorrect use of if&quot;</span>)</span>
761 <span class="lineno">  215 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;false&quot;,      TBool <span class="nottickedoff">False</span>,        <span class="nottickedoff">error &quot;incorrect use of false&quot;</span>)</span>
762 <span class="lineno">  216 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;true&quot;,       TBool <span class="nottickedoff">True</span>,            <span class="nottickedoff">error &quot;incorrect use of true&quot;</span>)</span>
763 <span class="lineno">  217 </span><span class="spaces"> </span><span class="istickedoff">] ++ map (\ (a,b,c) -&gt; (a,TOp b,c))</span>
764 <span class="lineno">  218 </span><span class="spaces">   </span><span class="istickedoff">-- These are just invocation, any coersions need to occur between here</span>
765 <span class="lineno">  219 </span><span class="spaces">   </span><span class="istickedoff">-- and before arriving at the application code (like deg -&gt; rad).</span>
766 <span class="lineno">  220 </span><span class="spaces"> </span><span class="istickedoff">[ (&quot;acos&quot;,       Op_acos,   <span class="nottickedoff">Real_Real (rad2deg . acos)</span>)</span>
767 <span class="lineno">  221 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;addi&quot;,       Op_addi,   <span class="nottickedoff">Int_Int_Int (+)</span>)</span>
768 <span class="lineno">  222 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;addf&quot;,       Op_addf,   Real_Real_Real (+))</span>
769 <span class="lineno">  223 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;asin&quot;,       Op_asin,   <span class="nottickedoff">Real_Real (rad2deg . asin)</span>)</span>
770 <span class="lineno">  224 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;clampf&quot;,     Op_clampf,       <span class="nottickedoff">Real_Real clampf</span>)</span>
771 <span class="lineno">  225 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;cone&quot;,       Op_cone,   <span class="nottickedoff">Surface_Obj cone</span>)</span>
772 <span class="lineno">  226 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;cos&quot;,        Op_cos,     <span class="nottickedoff">Real_Real (cos . deg2rad)</span>)</span>
773 <span class="lineno">  227 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;cube&quot;,       Op_cube,   Surface_Obj cube)</span>
774 <span class="lineno">  228 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;cylinder&quot;,   Op_cylinder,   <span class="nottickedoff">Surface_Obj cylinder</span>)</span>
775 <span class="lineno">  229 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;difference&quot;, Op_difference, <span class="nottickedoff">Obj_Obj_Obj difference</span>)</span>
776 <span class="lineno">  230 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;divi&quot;,       Op_divi,   <span class="nottickedoff">Int_Int_Int (ourQuot)</span>)</span>
777 <span class="lineno">  231 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;divf&quot;,       Op_divf,   Real_Real_Real (/))</span>
778 <span class="lineno">  232 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;eqi&quot;,        Op_eqi,     Int_Int_Bool (==))</span>
779 <span class="lineno">  233 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;eqf&quot;,        Op_eqf,     <span class="nottickedoff">Real_Real_Bool (==)</span>)</span>
780 <span class="lineno">  234 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;floor&quot;,      Op_floor,         Real_Int floor)</span>
781 <span class="lineno">  235 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;frac&quot;,       Op_frac,   Real_Real (snd . properFraction))</span>
782 <span class="lineno">  236 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;get&quot;,        Op_get,     Arr_Int_Value ixGet)</span>
783 <span class="lineno">  237 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;getx&quot;,       Op_getx,   <span class="nottickedoff">Point_Real (\ x y z -&gt; x)</span>)</span>
784 <span class="lineno">  238 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;gety&quot;,       Op_gety,   <span class="nottickedoff">Point_Real (\ x y z -&gt; y)</span>)</span>
785 <span class="lineno">  239 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;getz&quot;,       Op_getz,   <span class="nottickedoff">Point_Real (\ x y z -&gt; z)</span>)</span>
786 <span class="lineno">  240 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;intersect&quot;,  Op_intersect,  <span class="nottickedoff">Obj_Obj_Obj intersect</span>)</span>
787 <span class="lineno">  241 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;length&quot;,     Op_length,       <span class="nottickedoff">Arr_Int (succ . snd . bounds)</span>)</span>
788 <span class="lineno">  242 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;lessi&quot;,      Op_lessi,         <span class="nottickedoff">Int_Int_Bool (&lt;)</span>)</span>
789 <span class="lineno">  243 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;lessf&quot;,      Op_lessf,         Real_Real_Bool (&lt;))</span>
790 <span class="lineno">  244 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;light&quot;,      Op_light,         Point_Color_Light light)</span>
791 <span class="lineno">  245 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;modi&quot;,       Op_modi,   Int_Int_Int (ourRem))</span>
792 <span class="lineno">  246 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;muli&quot;,       Op_muli,   <span class="nottickedoff">Int_Int_Int (*)</span>)</span>
793 <span class="lineno">  247 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;mulf&quot;,       Op_mulf,   Real_Real_Real (*))</span>
794 <span class="lineno">  248 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;negi&quot;,       Op_negi,   <span class="nottickedoff">Int_Int negate</span>)</span>
795 <span class="lineno">  249 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;negf&quot;,       Op_negf,   <span class="nottickedoff">Real_Real negate</span>)</span>
796 <span class="lineno">  250 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;plane&quot;,      Op_plane,         Surface_Obj plane)</span>
797 <span class="lineno">  251 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;point&quot;,      Op_point,         Real_Real_Real_Point VPoint)</span>
798 <span class="lineno">  252 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;pointlight&quot;, Op_pointlight, <span class="nottickedoff">Point_Color_Light pointlight</span>)</span>
799 <span class="lineno">  253 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;real&quot;,       Op_real,   Int_Real fromIntegral)</span>
800 <span class="lineno">  254 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;render&quot;,     Op_render,       Render $ render eye)</span>
801 <span class="lineno">  255 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;rotatex&quot;,    Op_rotatex,     Obj_Real_Obj (\ o d -&gt; rotateX (deg2rad d) o))</span>
802 <span class="lineno">  256 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;rotatey&quot;,    Op_rotatey,     Obj_Real_Obj (\ o d -&gt; rotateY (deg2rad d) o)) </span>
803 <span class="lineno">  257 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;rotatez&quot;,    Op_rotatez,     <span class="nottickedoff">Obj_Real_Obj (\ o d -&gt; rotateZ (deg2rad d) o)</span>)</span>
804 <span class="lineno">  258 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;scale&quot;,      Op_scale,         <span class="nottickedoff">Obj_Real_Real_Real_Obj (\ o x y z -&gt; scale (x,y,z) o)</span>)</span>
805 <span class="lineno">  259 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;sin&quot;,        Op_sin,     <span class="nottickedoff">Real_Real (sin . deg2rad)</span>)</span>
806 <span class="lineno">  260 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;sphere&quot;,     Op_sphere,       <span class="nottickedoff">Surface_Obj sphere'</span>) -- see comment at end of file</span>
807 <span class="lineno">  261 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;spotlight&quot;,  Op_spotlight,  <span class="nottickedoff">Point_Point_Color_Real_Real_Light mySpotlight</span>)</span>
808 <span class="lineno">  262 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;sqrt&quot;,       Op_sqrt,   <span class="nottickedoff">Real_Real ourSqrt</span>)</span>
809 <span class="lineno">  263 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;subi&quot;,       Op_subi,   <span class="nottickedoff">Int_Int_Int (-)</span>)</span>
810 <span class="lineno">  264 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;subf&quot;,       Op_subf,   <span class="nottickedoff">Real_Real_Real (-)</span>)</span>
811 <span class="lineno">  265 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;trace&quot;,      Op_trace,      <span class="nottickedoff">Value_String_Value mytrace</span>)</span>
812 <span class="lineno">  266 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;translate&quot;,  Op_translate,  Obj_Real_Real_Real_Obj (\ o x y z -&gt; translate (x,y,z) o))</span>
813 <span class="lineno">  267 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;union&quot;,      Op_union,         Obj_Obj_Obj union)</span>
814 <span class="lineno">  268 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;uscale&quot;,     Op_uscale,       Obj_Real_Obj (\ o r -&gt; uscale r o))</span>
815 <span class="lineno">  269 </span><span class="spaces"> </span><span class="istickedoff">]</span></span>
816 <span class="lineno">  270 </span>
817 <span class="lineno">  271 </span>-- This enumerate all possible ways of calling the fixed primitives
818 <span class="lineno">  272 </span>
819 <span class="lineno">  273 </span>-- The datatype captures the type at the *interp* level,
820 <span class="lineno">  274 </span>-- the type of the functional is mirrored on this (using Haskell types).
821 <span class="lineno">  275 </span>
822 <span class="lineno">  276 </span>data PrimOp
823 <span class="lineno">  277 </span>
824 <span class="lineno">  278 </span>    -- 1 argument 
825 <span class="lineno">  279 </span>    = Int_Int         (Int -&gt; Int)
826 <span class="lineno">  280 </span>    | Real_Real       (Double -&gt; Double)
827 <span class="lineno">  281 </span>    | Point_Real      (Double -&gt; Double -&gt; Double -&gt; Double)
828 <span class="lineno">  282 </span>    | Surface_Obj     (SurfaceFn Color Double -&gt; Object)
829 <span class="lineno">  283 </span>    | Real_Int        (Double -&gt; Int)
830 <span class="lineno">  284 </span>    | Int_Real        (Int -&gt; Double)
831 <span class="lineno">  285 </span>    | Arr_Int         (Array Int GMLValue -&gt; Int)
832 <span class="lineno">  286 </span>
833 <span class="lineno">  287 </span>    -- 2 arguments 
834 <span class="lineno">  288 </span>    | Int_Int_Int     (Int -&gt; Int -&gt; Int)
835 <span class="lineno">  289 </span>    | Int_Int_Bool    (Int -&gt; Int -&gt; Bool)
836 <span class="lineno">  290 </span>    | Real_Real_Real  (Double -&gt; Double -&gt; Double)
837 <span class="lineno">  291 </span>    | Real_Real_Bool  (Double -&gt; Double -&gt; Bool)
838 <span class="lineno">  292 </span>    | Arr_Int_Value   (Array Int GMLValue -&gt; Int -&gt; GMLValue)
839 <span class="lineno">  293 </span>
840 <span class="lineno">  294 </span>    -- Many arguments, typically image mangling
841 <span class="lineno">  295 </span>
842 <span class="lineno">  296 </span>    | Obj_Obj_Obj            (Object -&gt; Object -&gt; Object)
843 <span class="lineno">  297 </span>    | Point_Color_Light      (Coords -&gt; Color -&gt; Light)
844 <span class="lineno">  298 </span>    | Real_Real_Real_Point   (Double -&gt; Double -&gt; Double -&gt; GMLValue)
845 <span class="lineno">  299 </span>    | Obj_Real_Obj           (Object -&gt; Double -&gt; Object)
846 <span class="lineno">  300 </span>    | Obj_Real_Real_Real_Obj (Object -&gt; Double -&gt; Double -&gt; Double -&gt; Object)
847 <span class="lineno">  301 </span>    | Value_String_Value     (GMLValue -&gt; String -&gt; GMLValue)
848 <span class="lineno">  302 </span>
849 <span class="lineno">  303 </span>    | Point_Point_Color_Real_Real_Light 
850 <span class="lineno">  304 </span>                             (Coords -&gt; Coords -&gt; Color -&gt; Radian -&gt; Radian -&gt; Light)
851 <span class="lineno">  305 </span>    -- And finally render
852 <span class="lineno">  306 </span>    | Render                 (Color -&gt; [Light] -&gt; Object -&gt; Int -&gt; Double -&gt; Int -&gt; Int -&gt; String -&gt; IO ())
853 <span class="lineno">  307 </span>
854 <span class="lineno">  308 </span>data Type 
855 <span class="lineno">  309 </span>    = TyBool 
856 <span class="lineno">  310 </span>    | TyInt 
857 <span class="lineno">  311 </span>    | TyReal 
858 <span class="lineno">  312 </span>    | TyString 
859 <span class="lineno">  313 </span>    | TyCode 
860 <span class="lineno">  314 </span>    | TyArray 
861 <span class="lineno">  315 </span>    | TyPoint 
862 <span class="lineno">  316 </span>    | TyObject 
863 <span class="lineno">  317 </span>    | TyLight
864 <span class="lineno">  318 </span>    | TyAlpha
865 <span class="lineno">  319 </span>    | TyAbsObj
866 <span class="lineno">  320 </span>      deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>,<span class="nottickedoff"><span class="decl"><span class="nottickedoff">Ord</span></span></span>,<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Ix</span></span></span></span></span></span>,<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Bounded</span></span></span></span>)
867 <span class="lineno">  321 </span>
868 <span class="lineno">  322 </span><span class="decl"><span class="nottickedoff">typeTable = </span>
869 <span class="lineno">  323 </span><span class="spaces">  </span><span class="nottickedoff">[ ( TyBool,   &quot;Bool&quot;)</span>
870 <span class="lineno">  324 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyInt,    &quot;Int&quot;)</span>
871 <span class="lineno">  325 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyReal,   &quot;Real&quot;)</span>
872 <span class="lineno">  326 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyString, &quot;String&quot;)</span>
873 <span class="lineno">  327 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyCode,   &quot;Code&quot;)</span>
874 <span class="lineno">  328 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyArray,  &quot;Array&quot;)</span>
875 <span class="lineno">  329 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyPoint,  &quot;Point&quot;)</span>
876 <span class="lineno">  330 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyObject, &quot;Object&quot;)</span>
877 <span class="lineno">  331 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyLight,  &quot;Light&quot;)</span>
878 <span class="lineno">  332 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyAlpha,  &quot;&lt;anything&gt;&quot;)</span>
879 <span class="lineno">  333 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyAbsObj, &quot;&lt;abs&gt;&quot;)</span>
880 <span class="lineno">  334 </span><span class="spaces">  </span><span class="nottickedoff">]</span></span>
881 <span class="lineno">  335 </span>
882 <span class="lineno">  336 </span><span class="decl"><span class="nottickedoff">typeNames = array (minBound,maxBound) typeTable</span></span>
883 <span class="lineno">  337 </span>
884 <span class="lineno">  338 </span>instance Show Type where
885 <span class="lineno">  339 </span>   <span class="decl"><span class="nottickedoff">showsPrec _ op = showString (typeNames ! op)</span></span>
886 <span class="lineno">  340 </span>
887 <span class="lineno">  341 </span>getPrimOpType :: PrimOp -&gt; [Type]
888 <span class="lineno">  342 </span><span class="decl"><span class="nottickedoff">getPrimOpType (Int_Int         _) = [TyInt]</span>
889 <span class="lineno">  343 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real       _) = [TyReal]</span>
890 <span class="lineno">  344 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Point_Real      _) = [TyPoint]</span>
891 <span class="lineno">  345 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Surface_Obj     _) = [TyCode]</span>
892 <span class="lineno">  346 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Int        _) = [TyReal]</span>
893 <span class="lineno">  347 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Int_Real        _) = [TyInt]</span>
894 <span class="lineno">  348 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Arr_Int         _) = [TyArray]</span>
895 <span class="lineno">  349 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Int_Int_Int     _) = [TyInt,TyInt]</span>
896 <span class="lineno">  350 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Int_Int_Bool    _) = [TyInt,TyInt]</span>
897 <span class="lineno">  351 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real_Real  _) = [TyReal,TyReal]</span>
898 <span class="lineno">  352 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real_Bool  _) = [TyReal,TyReal]</span>
899 <span class="lineno">  353 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Arr_Int_Value   _) = [TyArray,TyInt]</span>
900 <span class="lineno">  354 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Obj_Obj_Obj            _) = [TyObject,TyObject]</span>
901 <span class="lineno">  355 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Point_Color_Light      _) = [TyPoint,TyPoint]</span>
902 <span class="lineno">  356 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real_Real_Point   _) = [TyReal,TyReal,TyReal]</span>
903 <span class="lineno">  357 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Obj_Real_Obj           _) = [TyObject,TyReal]</span>
904 <span class="lineno">  358 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Obj_Real_Real_Real_Obj _) = [TyObject,TyReal,TyReal,TyReal]</span>
905 <span class="lineno">  359 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Value_String_Value     _) = [TyAlpha,TyString]</span>
906 <span class="lineno">  360 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Point_Point_Color_Real_Real_Light _) </span>
907 <span class="lineno">  361 </span><span class="spaces">                                         </span><span class="nottickedoff">= [TyPoint,TyPoint,TyPoint,TyReal,TyReal]</span>
908 <span class="lineno">  362 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Render                 _) = [TyPoint,</span>
909 <span class="lineno">  363 </span><span class="spaces">                                            </span><span class="nottickedoff">TyLight,</span>
910 <span class="lineno">  364 </span><span class="spaces">                                            </span><span class="nottickedoff">TyObject,</span>
911 <span class="lineno">  365 </span><span class="spaces">                                            </span><span class="nottickedoff">TyInt,</span>
912 <span class="lineno">  366 </span><span class="spaces">                                            </span><span class="nottickedoff">TyReal,</span>
913 <span class="lineno">  367 </span><span class="spaces">                                            </span><span class="nottickedoff">TyReal,</span>
914 <span class="lineno">  368 </span><span class="spaces">                                            </span><span class="nottickedoff">TyReal,</span>
915 <span class="lineno">  369 </span><span class="spaces">                                            </span><span class="nottickedoff">TyString]</span></span>
916 <span class="lineno">  370 </span>
917 <span class="lineno">  371 </span>
918 <span class="lineno">  372 </span>-- Some primitives with better error message
919 <span class="lineno">  373 </span>
920 <span class="lineno">  374 </span><span class="decl"><span class="nottickedoff">mytrace v s = trace (s ++&quot; : &quot;++ show v ++ &quot;\n&quot;) v</span></span>
921 <span class="lineno">  375 </span>
922 <span class="lineno">  376 </span>
923 <span class="lineno">  377 </span>ixGet :: Array Int GMLValue -&gt; Int -&gt; GMLValue
924 <span class="lineno">  378 </span><span class="decl"><span class="istickedoff">ixGet arr i</span>
925 <span class="lineno">  379 </span><span class="spaces">   </span><span class="istickedoff">| <span class="tickonlytrue">inRange (bounds arr) i</span> = arr ! i</span>
926 <span class="lineno">  380 </span><span class="spaces">   </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span> = <span class="nottickedoff">error (&quot;failed access with index value &quot; </span></span>
927 <span class="lineno">  381 </span><span class="spaces">                     </span><span class="istickedoff"><span class="nottickedoff">++ show i </span></span>
928 <span class="lineno">  382 </span><span class="spaces">                     </span><span class="istickedoff"><span class="nottickedoff">++ &quot; (should be between 0 and &quot; </span></span>
929 <span class="lineno">  383 </span><span class="spaces">                     </span><span class="istickedoff"><span class="nottickedoff">++ show (snd (bounds arr)) ++ &quot;)&quot;)</span></span></span>
930 <span class="lineno">  384 </span>
931 <span class="lineno">  385 </span>ourQuot :: Int -&gt; Int -&gt; Int
932 <span class="lineno">  386 </span><span class="decl"><span class="nottickedoff">ourQuot _ 0 = error &quot;attempt to use divi to divide by 0&quot;</span>
933 <span class="lineno">  387 </span><span class="spaces"></span><span class="nottickedoff">ourQuot a b = a `quot` b</span></span>
934 <span class="lineno">  388 </span>
935 <span class="lineno">  389 </span>ourRem :: Int -&gt; Int -&gt; Int
936 <span class="lineno">  390 </span><span class="decl"><span class="istickedoff">ourRem _ 0 = <span class="nottickedoff">error &quot;attempt to use remi to divide by 0&quot;</span></span>
937 <span class="lineno">  391 </span><span class="spaces"></span><span class="istickedoff">ourRem a b = a `rem` b</span></span>
938 <span class="lineno">  392 </span>
939 <span class="lineno">  393 </span>ourSqrt :: Double -&gt; Double
940 <span class="lineno">  394 </span><span class="decl"><span class="nottickedoff">ourSqrt n | n &lt; 0     = error &quot;attempt to use sqrt on a negative number&quot;</span>
941 <span class="lineno">  395 </span><span class="spaces">          </span><span class="nottickedoff">| otherwise = sqrt n</span></span>
942 <span class="lineno">  396 </span>
943 <span class="lineno">  397 </span>
944 <span class="lineno">  398 </span><span class="decl"><span class="nottickedoff">mySpotlight p1 p2 col cutoff exp = spotlight p1 p2 col (deg2rad cutoff) exp</span></span>
945 <span class="lineno">  399 </span>
946 <span class="lineno">  400 </span>-- The problem specification gets the mapping for spheres backwards
947 <span class="lineno">  401 </span>-- (it maps the image from right to left).
948 <span class="lineno">  402 </span>-- We've fixed that in the raytracing library so that it goes from left
949 <span class="lineno">  403 </span>-- to right, but to keep the GML front compatible with the problem
950 <span class="lineno">  404 </span>-- statement, we reverse it here.
951 <span class="lineno">  405 </span>
952 <span class="lineno">  406 </span>sphere' :: SurfaceFn Color Double -&gt; CSG (SurfaceFn Color Double)
953 <span class="lineno">  407 </span><span class="decl"><span class="nottickedoff">sphere' (SFun f) = sphere (SFun (\i u v -&gt; f i (1 - u) v))</span>
954 <span class="lineno">  408 </span><span class="spaces"></span><span class="nottickedoff">sphere' s = sphere s</span></span>
955
956 </pre>
957 </html>
958 Writing: Primitives.hs.html
959 <html><style type="text/css">
960 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
961 span.nottickedoff { background: yellow}
962 span.istickedoff { background: white }
963 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
964 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
965 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
966 span.decl { font-weight: bold }
967 span.spaces    { background: white }
968 </style>
969 <pre>
970 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
971 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
972 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
973 <span class="lineno">    4 </span>-- which is included in the distribution.
974 <span class="lineno">    5 </span>
975 <span class="lineno">    6 </span>module Primitives where
976 <span class="lineno">    7 </span>
977 <span class="lineno">    8 </span>rad2deg :: Double -&gt; Double
978 <span class="lineno">    9 </span><span class="decl"><span class="nottickedoff">rad2deg r = r * 180 / pi</span></span>
979 <span class="lineno">   10 </span>
980 <span class="lineno">   11 </span>deg2rad :: Double -&gt; Double
981 <span class="lineno">   12 </span><span class="decl"><span class="istickedoff">deg2rad d = d * pi / 180</span></span>
982 <span class="lineno">   13 </span>
983 <span class="lineno">   14 </span>addi :: Int -&gt; Int -&gt; Int
984 <span class="lineno">   15 </span><span class="decl"><span class="nottickedoff">addi = (+)</span></span>
985 <span class="lineno">   16 </span>
986 <span class="lineno">   17 </span>addf :: Double -&gt; Double -&gt; Double
987 <span class="lineno">   18 </span><span class="decl"><span class="nottickedoff">addf = (+)</span></span>
988 <span class="lineno">   19 </span>
989 <span class="lineno">   20 </span>acosD :: Double -&gt; Double
990 <span class="lineno">   21 </span><span class="decl"><span class="nottickedoff">acosD x = acos x * 180 / pi</span></span>
991 <span class="lineno">   22 </span>
992 <span class="lineno">   23 </span>asinD :: Double -&gt; Double
993 <span class="lineno">   24 </span><span class="decl"><span class="nottickedoff">asinD x = asin x * 180 / pi</span></span>
994
995 </pre>
996 </html>
997 Writing: Illumination.hs.html
998 <html><style type="text/css">
999 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
1000 span.nottickedoff { background: yellow}
1001 span.istickedoff { background: white }
1002 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
1003 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
1004 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
1005 span.decl { font-weight: bold }
1006 span.spaces    { background: white }
1007 </style>
1008 <pre>
1009 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
1010 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
1011 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
1012 <span class="lineno">    4 </span>-- which is included in the distribution.
1013 <span class="lineno">    5 </span>
1014 <span class="lineno">    6 </span>-- Modified to use stdout (for testing)
1015 <span class="lineno">    7 </span>
1016 <span class="lineno">    8 </span>module Illumination
1017 <span class="lineno">    9 </span>    ( Object
1018 <span class="lineno">   10 </span>    , Light (..)
1019 <span class="lineno">   11 </span>    , light, pointlight, spotlight
1020 <span class="lineno">   12 </span>    , render
1021 <span class="lineno">   13 </span>    ) where
1022 <span class="lineno">   14 </span>
1023 <span class="lineno">   15 </span>import Array
1024 <span class="lineno">   16 </span>import Char(chr)
1025 <span class="lineno">   17 </span>import Maybe
1026 <span class="lineno">   18 </span>
1027 <span class="lineno">   19 </span>import Geometry
1028 <span class="lineno">   20 </span>import CSG
1029 <span class="lineno">   21 </span>import Surface
1030 <span class="lineno">   22 </span>import Misc
1031 <span class="lineno">   23 </span>
1032 <span class="lineno">   24 </span>type Object = CSG (SurfaceFn Color Double)
1033 <span class="lineno">   25 </span>
1034 <span class="lineno">   26 </span>data Cxt = Cxt {ambient::Color, lights::[Light], object::Object, depth::Int}
1035 <span class="lineno">   27 </span>        deriving <span class="nottickedoff"><span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span></span>
1036 <span class="lineno">   28 </span>
1037 <span class="lineno">   29 </span>render :: (Matrix,Matrix) -&gt; Color -&gt; [Light] -&gt; Object -&gt; Int -&gt;
1038 <span class="lineno">   30 </span>          Radian -&gt; Int -&gt; Int -&gt; String -&gt; IO ()
1039 <span class="lineno">   31 </span><span class="decl"><span class="istickedoff">render (m,m') amb ls obj dep fov wid ht file</span>
1040 <span class="lineno">   32 </span><span class="spaces">  </span><span class="istickedoff">= do { debugging</span>
1041 <span class="lineno">   33 </span><span class="spaces">       </span><span class="istickedoff">; txt &lt;- readFile &quot;galois.sample&quot;</span>
1042 <span class="lineno">   34 </span><span class="spaces">       </span><span class="istickedoff">; let vals = read txt</span>
1043 <span class="lineno">   35 </span><span class="spaces">       </span><span class="istickedoff">; let rt_vals = showBitmap' <span class="nottickedoff">wid</span> <span class="nottickedoff">ht</span> pixels</span>
1044 <span class="lineno">   36 </span><span class="spaces">       </span><span class="istickedoff">; if <span class="tickonlyfalse">length vals /= length rt_vals</span></span>
1045 <span class="lineno">   37 </span><span class="spaces">           </span><span class="istickedoff">then <span class="nottickedoff">print (&quot;BAD LENGTH&quot;,length vals,length rt_vals)</span></span>
1046 <span class="lineno">   38 </span><span class="spaces">           </span><span class="istickedoff">else do {</span>
1047 <span class="lineno">   39 </span><span class="spaces">                   </span><span class="istickedoff">; let cmp = sum(zipWith (\ a b -&gt; abs (a - b) * abs (a - b)) vals rt_vals)</span>
1048 <span class="lineno">   40 </span><span class="spaces">                   </span><span class="istickedoff">; print $ if <span class="tickonlytrue">cmp &lt;= (length vals * 16)</span> then (&quot;GOOD MATCH&quot;) else <span class="nottickedoff">(&quot;BAD MATCH:&quot; ++ show cmp)</span></span>
1049 <span class="lineno">   41 </span><span class="spaces">                   </span><span class="istickedoff">}}</span>
1050 <span class="lineno">   42 </span><span class="spaces">                   </span><span class="istickedoff"></span>
1051 <span class="lineno">   43 </span><span class="spaces">  </span><span class="istickedoff">where</span>
1052 <span class="lineno">   44 </span><span class="spaces">    </span><span class="istickedoff">debugging = return <span class="nottickedoff">()</span></span>
1053 <span class="lineno">   45 </span><span class="spaces"></span><span class="istickedoff">{-</span>
1054 <span class="lineno">   46 </span><span class="spaces">                </span><span class="istickedoff">do { putStrLn (show cxt)</span>
1055 <span class="lineno">   47 </span><span class="spaces">                   </span><span class="istickedoff">; putStrLn (show (width, delta, aspect, left, top))</span>
1056 <span class="lineno">   48 </span><span class="spaces">                   </span><span class="istickedoff">}</span>
1057 <span class="lineno">   49 </span><span class="spaces"></span><span class="istickedoff">-}</span>
1058 <span class="lineno">   50 </span><span class="spaces">    </span><span class="istickedoff">obj' = transform (m',m) obj</span>
1059 <span class="lineno">   51 </span><span class="spaces">    </span><span class="istickedoff">ls'  = [ transformLight m' l | l &lt;- ls ]</span>
1060 <span class="lineno">   52 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">pixelA = listArray ((1,1), (ht,wid))</span></span>
1061 <span class="lineno">   53 </span><span class="spaces">                       </span><span class="istickedoff"><span class="nottickedoff">[ illumination cxt (start,pixel i j)</span></span>
1062 <span class="lineno">   54 </span><span class="spaces">                       </span><span class="istickedoff"><span class="nottickedoff">| j &lt;- take ht  [0.5..]</span></span>
1063 <span class="lineno">   55 </span><span class="spaces">                       </span><span class="istickedoff"><span class="nottickedoff">, i &lt;- take wid [0.5..] ]</span></span>
1064 <span class="lineno">   56 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">antiA  = pixelA //</span></span>
1065 <span class="lineno">   57 </span><span class="spaces">             </span><span class="istickedoff"><span class="nottickedoff">[ (ix, superSample ix (pixelA ! ix))</span></span>
1066 <span class="lineno">   58 </span><span class="spaces">             </span><span class="istickedoff"><span class="nottickedoff">| j &lt;- [2 .. ht - 1], i &lt;- [2 .. wid - 1]</span></span>
1067 <span class="lineno">   59 </span><span class="spaces">             </span><span class="istickedoff"><span class="nottickedoff">, let ix = (j, i)</span></span>
1068 <span class="lineno">   60 </span><span class="spaces">             </span><span class="istickedoff"><span class="nottickedoff">, contrast ix pixelA ]</span></span>
1069 <span class="lineno">   61 </span><span class="spaces">    </span><span class="istickedoff">pixels = [ [ illumination cxt (start,pixel i j) | i&lt;- take wid [0.5..] ]</span>
1070 <span class="lineno">   62 </span><span class="spaces">             </span><span class="istickedoff">| j &lt;- take ht [0.5..]</span>
1071 <span class="lineno">   63 </span><span class="spaces">             </span><span class="istickedoff">]</span>
1072 <span class="lineno">   64 </span><span class="spaces">    </span><span class="istickedoff">cxt    = Cxt {ambient=amb, lights=ls',  object=obj', depth=dep}</span>
1073 <span class="lineno">   65 </span><span class="spaces">    </span><span class="istickedoff">start  = point  0 0 (-1)</span>
1074 <span class="lineno">   66 </span><span class="spaces">    </span><span class="istickedoff">width  = 2 * tan (fov/2)</span>
1075 <span class="lineno">   67 </span><span class="spaces">    </span><span class="istickedoff">delta  = width / fromIntegral wid</span>
1076 <span class="lineno">   68 </span><span class="spaces">    </span><span class="istickedoff">aspect = fromIntegral ht / fromIntegral wid</span>
1077 <span class="lineno">   69 </span><span class="spaces">    </span><span class="istickedoff">left   = - width / 2</span>
1078 <span class="lineno">   70 </span><span class="spaces">    </span><span class="istickedoff">top    = - left * aspect</span>
1079 <span class="lineno">   71 </span><span class="spaces">    </span><span class="istickedoff">pixel i j = vector (left + i*delta) (top - j*delta) 1</span>
1080 <span class="lineno">   72 </span><span class="spaces"></span><span class="istickedoff"></span>
1081 <span class="lineno">   73 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">superSample (y, x) col = avg $ col:</span></span>
1082 <span class="lineno">   74 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">[ illumination cxt (start, pixel (fromIntegral x - 0.5 + xd) (fromIntegral y - 0.5 + yd))</span></span>
1083 <span class="lineno">   75 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">| (xd, yd) &lt;- [(-0.333, 0.0), (0.333, 0.0), (0.0, -0.333), (0.0, 0.333)]</span></span>
1084 <span class="lineno">   76 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">]</span></span></span> 
1085 <span class="lineno">   77 </span>
1086 <span class="lineno">   78 </span><span class="decl"><span class="nottickedoff">avg cs = divN (fromIntegral (length cs)) (uncolor (sumCC cs))</span>
1087 <span class="lineno">   79 </span><span class="spaces">  </span><span class="nottickedoff">where divN n (r,g,b) = color (r / n) (g / n) (b / n)</span></span>
1088 <span class="lineno">   80 </span>
1089 <span class="lineno">   81 </span>contrast :: (Int, Int) -&gt; Array (Int, Int) Color -&gt; Bool
1090 <span class="lineno">   82 </span><span class="decl"><span class="nottickedoff">contrast (x, y) arr = any diffMax [ subCC cur (arr ! (x + xd, y + yd))</span>
1091 <span class="lineno">   83 </span><span class="spaces">                                  </span><span class="nottickedoff">| xd &lt;- [-1, 1], yd &lt;- [-1, 1]</span>
1092 <span class="lineno">   84 </span><span class="spaces">                                  </span><span class="nottickedoff">]</span>
1093 <span class="lineno">   85 </span><span class="spaces">  </span><span class="nottickedoff">where cur = arr ! (x, y)</span>
1094 <span class="lineno">   86 </span><span class="spaces">        </span><span class="nottickedoff">diffMax col = (abs r) &gt; 0.25 || (abs g) &gt;  0.2 || (abs b) &gt; 0.4</span>
1095 <span class="lineno">   87 </span><span class="spaces">           </span><span class="nottickedoff">where</span>
1096 <span class="lineno">   88 </span><span class="spaces">                 </span><span class="nottickedoff">(r,g,b) = uncolor col</span></span>
1097 <span class="lineno">   89 </span>
1098 <span class="lineno">   90 </span>
1099 <span class="lineno">   91 </span>illumination :: Cxt -&gt; Ray -&gt; Color
1100 <span class="lineno">   92 </span><span class="decl"><span class="istickedoff">illumination cxt (r,v)</span>
1101 <span class="lineno">   93 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlyfalse">depth cxt &lt;= 0</span> = <span class="nottickedoff">black</span></span>
1102 <span class="lineno">   94 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>     = case castRay (r,v) (object cxt) of</span>
1103 <span class="lineno">   95 </span><span class="spaces">                      </span><span class="istickedoff">Nothing -&gt; black</span>
1104 <span class="lineno">   96 </span><span class="spaces">                      </span><span class="istickedoff">Just info -&gt; illum (cxt{depth=(depth cxt)-1}) info v</span></span>
1105 <span class="lineno">   97 </span>
1106 <span class="lineno">   98 </span>illum :: Cxt -&gt; (Point,Vector,Properties Color Double) -&gt; Vector -&gt; Color
1107 <span class="lineno">   99 </span><span class="decl"><span class="istickedoff">illum cxt (pos,normV,(col,kd,ks,n)) v</span>
1108 <span class="lineno">  100 </span><span class="spaces">  </span><span class="istickedoff">= ambTerm `addCC` difTerm `addCC` spcTerm `addCC` recTerm</span>
1109 <span class="lineno">  101 </span><span class="spaces">  </span><span class="istickedoff">where</span>
1110 <span class="lineno">  102 </span><span class="spaces">    </span><span class="istickedoff">visibleLights = unobscured pos (object cxt) (lights cxt) normV</span>
1111 <span class="lineno">  103 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">d = depth cxt</span></span>
1112 <span class="lineno">  104 </span><span class="spaces">    </span><span class="istickedoff">amb = ambient cxt</span>
1113 <span class="lineno">  105 </span><span class="spaces">    </span><span class="istickedoff">newV = subVV v (multSV (2 * dot normV v) normV)</span>
1114 <span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff"></span>
1115 <span class="lineno">  107 </span><span class="spaces">    </span><span class="istickedoff">ambTerm = multSC kd (multCC amb col)</span>
1116 <span class="lineno">  108 </span><span class="spaces">    </span><span class="istickedoff">difTerm = multSC kd (sumCC [multSC (dot normV lj) (multCC intensity col)</span>
1117 <span class="lineno">  109 </span><span class="spaces">               </span><span class="istickedoff">|(loc,intensity) &lt;- visibleLights,</span>
1118 <span class="lineno">  110 </span><span class="spaces">               </span><span class="istickedoff">let lj = normalize ({- pos `subVV` -} loc)])</span>
1119 <span class="lineno">  111 </span><span class="spaces">    </span><span class="istickedoff">-- ZZ might want to avoid the phong, when you can...</span>
1120 <span class="lineno">  112 </span><span class="spaces">    </span><span class="istickedoff">spcTerm = multSC ks (sumCC [multSC ((dot normV hj) ** n ) (multCC intensity col)</span>
1121 <span class="lineno">  113 </span><span class="spaces">               </span><span class="istickedoff">|(loc,intensity) &lt;- visibleLights,</span>
1122 <span class="lineno">  114 </span><span class="spaces">               </span><span class="istickedoff">-- ZZ note this is specific to the light at infinity</span>
1123 <span class="lineno">  115 </span><span class="spaces">               </span><span class="istickedoff">let lj = {- pos `subVV` -} normalize loc,</span>
1124 <span class="lineno">  116 </span><span class="spaces">               </span><span class="istickedoff">let hj = normalize (lj `subVV` normalize v)])</span>
1125 <span class="lineno">  117 </span><span class="spaces">    </span><span class="istickedoff">recTerm  = if recCoeff `nearC` black then black else multCC recCoeff recRay</span>
1126 <span class="lineno">  118 </span><span class="spaces">    </span><span class="istickedoff">recCoeff = multSC ks col</span>
1127 <span class="lineno">  119 </span><span class="spaces">    </span><span class="istickedoff">recRay   = illumination cxt (pos,newV)</span></span>
1128 <span class="lineno">  120 </span>
1129 <span class="lineno">  121 </span>showBitmapA :: Int -&gt; Int -&gt; Array (Int, Int) Color -&gt; String
1130 <span class="lineno">  122 </span><span class="decl"><span class="nottickedoff">showBitmapA wid ht arr</span>
1131 <span class="lineno">  123 </span><span class="spaces">  </span><span class="nottickedoff">= header ++ concatMap scaleColor (elems arr)</span>
1132 <span class="lineno">  124 </span><span class="spaces">  </span><span class="nottickedoff">where</span>
1133 <span class="lineno">  125 </span><span class="spaces">    </span><span class="nottickedoff">scaleColor col = [scalePixel r, scalePixel g, scalePixel b]</span>
1134 <span class="lineno">  126 </span><span class="spaces">           </span><span class="nottickedoff">where (r,g,b) = uncolor col</span>
1135 <span class="lineno">  127 </span><span class="spaces">    </span><span class="nottickedoff">header = &quot;P6\n#Galois\n&quot; ++ show wid ++ &quot; &quot; ++ show ht ++ &quot;\n255\n&quot;</span></span>
1136 <span class="lineno">  128 </span>
1137 <span class="lineno">  129 </span>showBitmap :: Int -&gt; Int -&gt;[[Color]] -&gt; String
1138 <span class="lineno">  130 </span><span class="decl"><span class="nottickedoff">showBitmap wid ht pss</span>
1139 <span class="lineno">  131 </span><span class="spaces"></span><span class="nottickedoff">-- type of assert  | length pss == ht &amp;&amp; all (\ ps -&gt; length ps == wid) pss</span>
1140 <span class="lineno">  132 </span><span class="spaces">  </span><span class="nottickedoff">= header ++ concat [[scalePixel r,scalePixel g,scalePixel b] </span>
1141 <span class="lineno">  133 </span><span class="spaces">                      </span><span class="nottickedoff">| ps &lt;- pss, (r,g,b) &lt;- map uncolor ps]</span>
1142 <span class="lineno">  134 </span><span class="spaces">  </span><span class="nottickedoff">where</span>
1143 <span class="lineno">  135 </span><span class="spaces">    </span><span class="nottickedoff">header = &quot;P6\n#Galois\n&quot; ++ show wid ++ &quot; &quot; ++ show ht ++ &quot;\n255\n&quot;</span>
1144 <span class="lineno">  136 </span><span class="spaces"></span><span class="nottickedoff">showBitmap _ _ _ = error &quot;incorrect length of bitmap string&quot;</span></span>
1145 <span class="lineno">  137 </span>
1146 <span class="lineno">  138 </span>scalePixel :: Double -&gt; Char
1147 <span class="lineno">  139 </span><span class="decl"><span class="nottickedoff">scalePixel p = chr (floor (clampf p * 255))</span></span>
1148 <span class="lineno">  140 </span>
1149 <span class="lineno">  141 </span>showBitmap' :: Int -&gt; Int -&gt;[[Color]] -&gt; [Int]
1150 <span class="lineno">  142 </span><span class="decl"><span class="istickedoff">showBitmap' wid ht pss</span>
1151 <span class="lineno">  143 </span><span class="spaces"></span><span class="istickedoff">-- type of assert  | length pss == ht &amp;&amp; all (\ ps -&gt; length ps == wid) pss</span>
1152 <span class="lineno">  144 </span><span class="spaces">  </span><span class="istickedoff">= concat [ concat [  [scalePixel' r,scalePixel' g,scalePixel' b]</span>
1153 <span class="lineno">  145 </span><span class="spaces">                    </span><span class="istickedoff">| (r,g,b) &lt;- map uncolor ps]</span>
1154 <span class="lineno">  146 </span><span class="spaces">           </span><span class="istickedoff">| ps &lt;- pss ]</span>
1155 <span class="lineno">  147 </span><span class="spaces">  </span><span class="istickedoff">where</span>
1156 <span class="lineno">  148 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">header = &quot;P3\n#Galois\n&quot; ++ show wid ++ &quot; &quot; ++ show ht ++ &quot;\n255\n&quot;</span></span>
1157 <span class="lineno">  149 </span><span class="spaces"></span><span class="istickedoff">showBitmap' _ _ _ = <span class="nottickedoff">error &quot;incorrect length of bitmap string&quot;</span></span></span>
1158 <span class="lineno">  150 </span>
1159 <span class="lineno">  151 </span>scalePixel' :: Double -&gt; Int
1160 <span class="lineno">  152 </span><span class="decl"><span class="istickedoff">scalePixel' p = floor (clampf p * 255)</span></span>
1161 <span class="lineno">  153 </span>
1162 <span class="lineno">  154 </span>-- Lights
1163 <span class="lineno">  155 </span>
1164 <span class="lineno">  156 </span>data Light = Light Vector Color
1165 <span class="lineno">  157 </span>           | PointLight Point Color 
1166 <span class="lineno">  158 </span>           | SpotLight Point Point Color Radian Double
1167 <span class="lineno">  159 </span>   deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
1168 <span class="lineno">  160 </span>
1169 <span class="lineno">  161 </span>light :: Coords -&gt; Color -&gt; Light
1170 <span class="lineno">  162 </span><span class="decl"><span class="istickedoff">light (x,y,z) color =</span>
1171 <span class="lineno">  163 </span><span class="spaces">  </span><span class="istickedoff">Light (normalize (vector (-x) (-y) (-z))) color</span></span>
1172 <span class="lineno">  164 </span><span class="decl"><span class="nottickedoff">pointlight (x,y,z) color =</span>
1173 <span class="lineno">  165 </span><span class="spaces">  </span><span class="nottickedoff">PointLight (point x y z) color</span></span>
1174 <span class="lineno">  166 </span><span class="decl"><span class="nottickedoff">spotlight (x,y,z) (p,q,r) col cutoff exp =</span>
1175 <span class="lineno">  167 </span><span class="spaces">  </span><span class="nottickedoff">SpotLight (point x y z) (point p q r) col cutoff exp</span></span>
1176 <span class="lineno">  168 </span>
1177 <span class="lineno">  169 </span><span class="decl"><span class="istickedoff">transformLight m (Light v c) = Light (multMV m v) c</span>
1178 <span class="lineno">  170 </span><span class="spaces"></span><span class="istickedoff">transformLight m (PointLight p c) = <span class="nottickedoff">PointLight (multMP m p) c</span></span>
1179 <span class="lineno">  171 </span><span class="spaces"></span><span class="istickedoff">transformLight m (SpotLight p q c r d) = <span class="nottickedoff">SpotLight (multMP m p) (multMP m q) c r d</span></span></span>
1180 <span class="lineno">  172 </span>
1181 <span class="lineno">  173 </span>unobscured :: Point -&gt; Object -&gt; [Light] -&gt;  Vector -&gt; [(Vector,Color)]
1182 <span class="lineno">  174 </span><span class="decl"><span class="istickedoff">unobscured pos obj lights normV = catMaybes (map (unobscure pos obj normV) lights)</span></span>
1183 <span class="lineno">  175 </span>
1184 <span class="lineno">  176 </span>unobscure :: Point -&gt; Object -&gt; Vector -&gt;  Light -&gt; Maybe (Vector,Color)
1185 <span class="lineno">  177 </span><span class="decl"><span class="istickedoff">unobscure pos obj normV (Light vec color)</span>
1186 <span class="lineno">  178 </span><span class="spaces">  </span><span class="istickedoff">-- ZZ probably want to make this faster</span>
1187 <span class="lineno">  179 </span><span class="spaces">  </span><span class="istickedoff">| vec `dot` normV &lt; 0 = Nothing</span>
1188 <span class="lineno">  180 </span><span class="spaces">  </span><span class="istickedoff">| intersects (pos `addPV` (0.0001 `multSV` vec),vec) obj = Nothing</span>
1189 <span class="lineno">  181 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>               = Just (vec,color)</span>
1190 <span class="lineno">  182 </span><span class="spaces"></span><span class="istickedoff">unobscure pos obj normV (PointLight pp color)</span>
1191 <span class="lineno">  183 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">vec `dot` normV &lt; 0</span>     = <span class="nottickedoff">Nothing</span></span>
1192 <span class="lineno">  184 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">intersectWithin (pos `addPV` (0.0001 `multSV` (normalize vec)), vec) obj</span> = <span class="nottickedoff">Nothing</span></span>
1193 <span class="lineno">  185 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span>               = <span class="nottickedoff">Just (vec,is)</span></span>
1194 <span class="lineno">  186 </span><span class="spaces">      </span><span class="istickedoff">where <span class="nottickedoff">vec = pp `subPP` pos</span></span>
1195 <span class="lineno">  187 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">is  = attenuate vec color</span></span>
1196 <span class="lineno">  188 </span><span class="spaces"></span><span class="istickedoff">unobscure org obj normV (SpotLight pos at color cutoff exp)</span>
1197 <span class="lineno">  189 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">vec `dot` normV &lt; 0</span>                                                 = <span class="nottickedoff">Nothing</span></span>
1198 <span class="lineno">  190 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">intersectWithin (org `addPV` (0.0001 `multSV` (normalize vec)), vec) obj</span> = <span class="nottickedoff">Nothing</span></span>
1199 <span class="lineno">  191 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">angle &gt; cutoff</span>                                                      = <span class="nottickedoff">Nothing</span></span>
1200 <span class="lineno">  192 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span>                                                           = <span class="nottickedoff">Just (vec, is)</span></span>
1201 <span class="lineno">  193 </span><span class="spaces">      </span><span class="istickedoff">where <span class="nottickedoff">vec   = pos `subPP` org</span></span>
1202 <span class="lineno">  194 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">vec'  = pos `subPP` at</span></span>
1203 <span class="lineno">  195 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">angle = acos (normalize vec `dot` (normalize vec'))</span></span>
1204 <span class="lineno">  196 </span><span class="spaces"></span><span class="istickedoff"></span>
1205 <span class="lineno">  197 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">asp   = normalize (at `subPP` pos)</span>            </span>
1206 <span class="lineno">  198 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">qsp   = normalize (org `subPP` pos)</span></span>
1207 <span class="lineno">  199 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">is    = attenuate vec (((asp `dot` qsp) ** exp) `multSC` color)</span></span></span>
1208 <span class="lineno">  200 </span>
1209 <span class="lineno">  201 </span>attenuate :: Vector -&gt; Color -&gt; Color
1210 <span class="lineno">  202 </span><span class="decl"><span class="nottickedoff">attenuate vec color = (100 / (99 + sq (norm vec))) `multSC` color</span></span>
1211 <span class="lineno">  203 </span>
1212 <span class="lineno">  204 </span>--
1213 <span class="lineno">  205 </span>
1214 <span class="lineno">  206 </span><span class="decl"><span class="istickedoff">castRay ray p</span>
1215 <span class="lineno">  207 </span><span class="spaces">  </span><span class="istickedoff">= case intersectRayWithObject ray p of</span>
1216 <span class="lineno">  208 </span><span class="spaces">    </span><span class="istickedoff">(True, _, _)                     -&gt; <span class="nottickedoff">Nothing</span> -- eye is inside</span>
1217 <span class="lineno">  209 </span><span class="spaces">    </span><span class="istickedoff">(False, [], _)                   -&gt; Nothing -- eye is inside</span>
1218 <span class="lineno">  210 </span><span class="spaces">    </span><span class="istickedoff">(False, (0, b, _) : _, _)        -&gt; <span class="nottickedoff">Nothing</span> -- eye is inside</span>
1219 <span class="lineno">  211 </span><span class="spaces">    </span><span class="istickedoff">(False, (i, False, _) : _, _)    -&gt; <span class="nottickedoff">Nothing</span> -- eye is inside</span>
1220 <span class="lineno">  212 </span><span class="spaces">    </span><span class="istickedoff">(False, (t, b, (s, p0)) : _, _)     -&gt;</span>
1221 <span class="lineno">  213 </span><span class="spaces">        </span><span class="istickedoff">let (v, prop) = surface s p0 in</span>
1222 <span class="lineno">  214 </span><span class="spaces">            </span><span class="istickedoff">Just (offsetToPoint ray t, v, prop)</span></span>
1223 <span class="lineno">  215 </span>
1224 <span class="lineno">  216 </span><span class="decl"><span class="istickedoff">intersects ray p</span>
1225 <span class="lineno">  217 </span><span class="spaces">  </span><span class="istickedoff">= case intersectRayWithObject ray p of</span>
1226 <span class="lineno">  218 </span><span class="spaces">    </span><span class="istickedoff">(True, _, _)                  -&gt; <span class="nottickedoff">False</span></span>
1227 <span class="lineno">  219 </span><span class="spaces">    </span><span class="istickedoff">(False, [], _)                -&gt; False</span>
1228 <span class="lineno">  220 </span><span class="spaces">    </span><span class="istickedoff">(False, (0, b, _) : _, _)     -&gt; <span class="nottickedoff">False</span></span>
1229 <span class="lineno">  221 </span><span class="spaces">    </span><span class="istickedoff">(False, (i, False, _) : _, _) -&gt; <span class="nottickedoff">False</span></span>
1230 <span class="lineno">  222 </span><span class="spaces">    </span><span class="istickedoff">(False, (i, b, _) : _, _)     -&gt; True</span></span>
1231 <span class="lineno">  223 </span>
1232 <span class="lineno">  224 </span>intersectWithin :: Ray -&gt; Object -&gt; Bool
1233 <span class="lineno">  225 </span><span class="decl"><span class="nottickedoff">intersectWithin ray p</span>
1234 <span class="lineno">  226 </span><span class="spaces">  </span><span class="nottickedoff">= case intersectRayWithObject ray p of</span>
1235 <span class="lineno">  227 </span><span class="spaces">    </span><span class="nottickedoff">(True, _, _)                  -&gt; False -- eye is inside</span>
1236 <span class="lineno">  228 </span><span class="spaces">    </span><span class="nottickedoff">(False, [], _)                -&gt; False -- eye is inside</span>
1237 <span class="lineno">  229 </span><span class="spaces">    </span><span class="nottickedoff">(False, (0, b, _) : _, _)     -&gt; False -- eye is inside</span>
1238 <span class="lineno">  230 </span><span class="spaces">    </span><span class="nottickedoff">(False, (i, False, _) : _, _) -&gt; False -- eye is inside</span>
1239 <span class="lineno">  231 </span><span class="spaces">    </span><span class="nottickedoff">(False, (t, b, _) : _, _)     -&gt; t &lt; 1.0</span></span>
1240
1241 </pre>
1242 </html>
1243 Writing: Misc.hs.html
1244 <html><style type="text/css">
1245 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
1246 span.nottickedoff { background: yellow}
1247 span.istickedoff { background: white }
1248 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
1249 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
1250 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
1251 span.decl { font-weight: bold }
1252 span.spaces    { background: white }
1253 </style>
1254 <pre>
1255 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
1256 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
1257 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
1258 <span class="lineno">    4 </span>-- which is included in the distribution.
1259 <span class="lineno">    5 </span>
1260 <span class="lineno">    6 </span>module Misc where
1261 <span class="lineno">    7 </span>
1262 <span class="lineno">    8 </span>import Debug.Trace
1263 <span class="lineno">    9 </span>
1264 <span class="lineno">   10 </span><span class="decl"><span class="nottickedoff">debug s v = trace (s ++&quot; : &quot;++ show v ++ &quot;\n&quot;) v</span></span>
1265 <span class="lineno">   11 </span>-- debug s v = v
1266
1267 </pre>
1268 </html>
1269 Writing: Surface.hs.html
1270 <html><style type="text/css">
1271 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
1272 span.nottickedoff { background: yellow}
1273 span.istickedoff { background: white }
1274 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
1275 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
1276 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
1277 span.decl { font-weight: bold }
1278 span.spaces    { background: white }
1279 </style>
1280 <pre>
1281 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
1282 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
1283 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
1284 <span class="lineno">    4 </span>-- which is included in the distribution.
1285 <span class="lineno">    5 </span>
1286 <span class="lineno">    6 </span>module Surface
1287 <span class="lineno">    7 </span>    ( SurfaceFn (..)
1288 <span class="lineno">    8 </span>    , Properties
1289 <span class="lineno">    9 </span>    , sfun, sconst
1290 <span class="lineno">   10 </span>    , prop
1291 <span class="lineno">   11 </span>    , matte, shiny
1292 <span class="lineno">   12 </span>    , chgColor
1293 <span class="lineno">   13 </span>    , surface
1294 <span class="lineno">   14 </span>    ) where
1295 <span class="lineno">   15 </span>
1296 <span class="lineno">   16 </span>import Geometry
1297 <span class="lineno">   17 </span>import CSG
1298 <span class="lineno">   18 </span>import Misc
1299 <span class="lineno">   19 </span>
1300 <span class="lineno">   20 </span>-- the surface gets passed face then u then v.
1301 <span class="lineno">   21 </span>data SurfaceFn c v = SFun (Int -&gt; Double -&gt; Double -&gt; Properties c v)
1302 <span class="lineno">   22 </span>                   | SConst (Properties c v)
1303 <span class="lineno">   23 </span>
1304 <span class="lineno">   24 </span>sfun :: (Int -&gt; Double -&gt; Double -&gt; Properties c v) -&gt; SurfaceFn c v
1305 <span class="lineno">   25 </span><span class="decl"><span class="nottickedoff">sfun = SFun</span></span>
1306 <span class="lineno">   26 </span>sconst :: Properties c v -&gt; SurfaceFn c v
1307 <span class="lineno">   27 </span><span class="decl"><span class="nottickedoff">sconst = SConst</span></span>
1308 <span class="lineno">   28 </span>
1309 <span class="lineno">   29 </span>type Properties c v = (c, v, v, v)
1310 <span class="lineno">   30 </span>
1311 <span class="lineno">   31 </span><span class="decl"><span class="istickedoff">prop c d s p = (c, d, s, p)</span></span>
1312 <span class="lineno">   32 </span>
1313 <span class="lineno">   33 </span><span class="decl"><span class="nottickedoff">matte = (white, 1.0, 0.0, 1.0)</span></span>
1314 <span class="lineno">   34 </span><span class="decl"><span class="nottickedoff">shiny = (white, 0.0, 1.0, 1.0)</span></span>
1315 <span class="lineno">   35 </span>
1316 <span class="lineno">   36 </span>chgColor :: c -&gt; Properties d v -&gt; Properties c v
1317 <span class="lineno">   37 </span><span class="decl"><span class="nottickedoff">chgColor c (_, d, s, p) = (c, d, s, p)</span></span>
1318 <span class="lineno">   38 </span>
1319 <span class="lineno">   39 </span>instance (Show c, Show v) =&gt; Show (SurfaceFn c v) where
1320 <span class="lineno">   40 </span>  <span class="decl"><span class="nottickedoff">show (SFun _)   = &quot;Surface function&quot;</span>
1321 <span class="lineno">   41 </span><span class="spaces">  </span><span class="nottickedoff">-- show (SConst p) = &quot;Surface constant: &quot; ++ show p</span>
1322 <span class="lineno">   42 </span><span class="spaces">  </span><span class="nottickedoff">show (SConst p) = &quot;Surface constant&quot;</span></span>
1323 <span class="lineno">   43 </span>
1324 <span class="lineno">   44 </span>evalSurface :: SurfaceFn Color Double -&gt; Int -&gt; Double -&gt; Double -&gt; Properties Color Double
1325 <span class="lineno">   45 </span><span class="decl"><span class="istickedoff">evalSurface (SConst p) = <span class="nottickedoff">\_ _ _ -&gt; p</span></span>
1326 <span class="lineno">   46 </span><span class="spaces"></span><span class="istickedoff">evalSurface (SFun f)   = f</span></span>
1327 <span class="lineno">   47 </span>
1328 <span class="lineno">   48 </span>-- calculate surface properties, given the type of
1329 <span class="lineno">   49 </span>-- surface, and intersection point in object coordinates
1330 <span class="lineno">   50 </span>
1331 <span class="lineno">   51 </span>-- surface :: Surface SurfaceFn -&gt; (Int, Point) -&gt; (Vector, Properties)
1332 <span class="lineno">   52 </span>
1333 <span class="lineno">   53 </span><span class="decl"><span class="istickedoff">surface (Planar _ v0 v1) (n, p0, fn)</span>
1334 <span class="lineno">   54 </span><span class="spaces">  </span><span class="istickedoff">= (norm, evalSurface fn <span class="nottickedoff">n'</span> u v)</span>
1335 <span class="lineno">   55 </span><span class="spaces">  </span><span class="istickedoff">where norm = normalize $ cross v0 v1</span>
1336 <span class="lineno">   56 </span><span class="spaces">        </span><span class="istickedoff">(n', u, v) = planarUV n p0</span>
1337 <span class="lineno">   57 </span><span class="spaces"></span><span class="istickedoff"></span>
1338 <span class="lineno">   58 </span><span class="spaces"></span><span class="istickedoff">surface (Spherical _ v0 v1) (_, p0, fn)</span>
1339 <span class="lineno">   59 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(norm, evalSurface fn 0 u v)</span></span>
1340 <span class="lineno">   60 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">x = xCoord p0</span></span>
1341 <span class="lineno">   61 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">y = yCoord p0</span></span>
1342 <span class="lineno">   62 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">z = zCoord p0</span></span>
1343 <span class="lineno">   63 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">k = sqrt (1 - sq y)</span></span>
1344 <span class="lineno">   64 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">theta = adjustRadian (atan2 (x / k) (z / k))</span></span>
1345 <span class="lineno">   65 </span><span class="spaces">        </span><span class="istickedoff">-- correct so that the image grows left-to-right</span>
1346 <span class="lineno">   66 </span><span class="spaces">        </span><span class="istickedoff">-- instead of right-to-left</span>
1347 <span class="lineno">   67 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">u = 1.0 - clampf (theta / (2 * pi))</span></span>
1348 <span class="lineno">   68 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v =       clampf ((y + 1) / 2)</span></span>
1349 <span class="lineno">   69 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">norm = normalize $ cross v0 v1</span></span>
1350 <span class="lineno">   70 </span><span class="spaces"></span><span class="istickedoff"></span>
1351 <span class="lineno">   71 </span><span class="spaces"></span><span class="istickedoff">-- ZZ ignore the (incorrect) surface model, and estimate the normal</span>
1352 <span class="lineno">   72 </span><span class="spaces"></span><span class="istickedoff">-- from the intersection in object space</span>
1353 <span class="lineno">   73 </span><span class="spaces"></span><span class="istickedoff">surface (Cylindrical _ v0 v1) (_, p0, fn)</span>
1354 <span class="lineno">   74 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(norm, evalSurface fn 0 u v)</span></span>
1355 <span class="lineno">   75 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">x = xCoord p0</span></span>
1356 <span class="lineno">   76 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">y = yCoord p0</span></span>
1357 <span class="lineno">   77 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">z = zCoord p0</span></span>
1358 <span class="lineno">   78 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">u = clampf $ adjustRadian (atan2 x z) / (2 * pi)</span></span>
1359 <span class="lineno">   79 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v = y</span></span>
1360 <span class="lineno">   80 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">norm = normalize $ cross v0 v1</span></span>
1361 <span class="lineno">   81 </span><span class="spaces"></span><span class="istickedoff"></span>
1362 <span class="lineno">   82 </span><span class="spaces"></span><span class="istickedoff">-- ZZ ignore the (incorrect) surface model, and estimate the normal</span>
1363 <span class="lineno">   83 </span><span class="spaces"></span><span class="istickedoff">-- from the intersection in object space</span>
1364 <span class="lineno">   84 </span><span class="spaces"></span><span class="istickedoff">surface (Conic _ v0 v1) (_, p0, fn)</span>
1365 <span class="lineno">   85 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(norm, evalSurface fn 0 u v)</span></span>
1366 <span class="lineno">   86 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">x = xCoord p0</span></span>
1367 <span class="lineno">   87 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">y = yCoord p0</span></span>
1368 <span class="lineno">   88 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">z = zCoord p0</span></span>
1369 <span class="lineno">   89 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">u = clampf $ adjustRadian (atan2 (x / y) (z / y)) / (2 * pi)</span></span>
1370 <span class="lineno">   90 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v = y</span></span>
1371 <span class="lineno">   91 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">norm = normalize $ cross v0 v1</span></span></span>
1372 <span class="lineno">   92 </span>
1373 <span class="lineno">   93 </span><span class="decl"><span class="istickedoff">planarUV face p0</span>
1374 <span class="lineno">   94 </span><span class="spaces">  </span><span class="istickedoff">= case face of</span>
1375 <span class="lineno">   95 </span><span class="spaces">    </span><span class="istickedoff">PlaneFace      -&gt; (<span class="nottickedoff">0</span>, x, z)</span>
1376 <span class="lineno">   96 </span><span class="spaces"></span><span class="istickedoff"></span>
1377 <span class="lineno">   97 </span><span class="spaces">    </span><span class="istickedoff">CubeFront      -&gt; (<span class="nottickedoff">0</span>, x, y)</span>
1378 <span class="lineno">   98 </span><span class="spaces">    </span><span class="istickedoff">CubeBack       -&gt; <span class="nottickedoff">(1, x, y)</span></span>
1379 <span class="lineno">   99 </span><span class="spaces">    </span><span class="istickedoff">CubeLeft       -&gt; (<span class="nottickedoff">2</span>, z, y)</span>
1380 <span class="lineno">  100 </span><span class="spaces">    </span><span class="istickedoff">CubeRight      -&gt; <span class="nottickedoff">(3, z, y)</span></span>
1381 <span class="lineno">  101 </span><span class="spaces">    </span><span class="istickedoff">CubeTop        -&gt; (<span class="nottickedoff">4</span>, x, z)</span>
1382 <span class="lineno">  102 </span><span class="spaces">    </span><span class="istickedoff">CubeBottom     -&gt; (<span class="nottickedoff">5</span>, x, z)</span>
1383 <span class="lineno">  103 </span><span class="spaces"></span><span class="istickedoff"></span>
1384 <span class="lineno">  104 </span><span class="spaces">    </span><span class="istickedoff">CylinderTop    -&gt; <span class="nottickedoff">(1, (x + 1) / 2, (z + 1) / 2)</span></span>
1385 <span class="lineno">  105 </span><span class="spaces">    </span><span class="istickedoff">CylinderBottom -&gt; <span class="nottickedoff">(2, (x + 1) / 2, (z + 1) / 2)</span></span>
1386 <span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff"></span>
1387 <span class="lineno">  107 </span><span class="spaces">    </span><span class="istickedoff">ConeBase       -&gt; <span class="nottickedoff">(1, (x + 1) / 2, (z + 1) / 2)</span></span>
1388 <span class="lineno">  108 </span><span class="spaces">  </span><span class="istickedoff">where x = xCoord p0</span>
1389 <span class="lineno">  109 </span><span class="spaces">        </span><span class="istickedoff">y = yCoord p0</span>
1390 <span class="lineno">  110 </span><span class="spaces">        </span><span class="istickedoff">z = zCoord p0</span></span>
1391 <span class="lineno">  111 </span>
1392 <span class="lineno">  112 </span>-- misc
1393 <span class="lineno">  113 </span>
1394 <span class="lineno">  114 </span>adjustRadian :: Radian -&gt; Radian
1395 <span class="lineno">  115 </span><span class="decl"><span class="nottickedoff">adjustRadian r = if r &gt; 0 then r else r + 2 * pi</span></span>
1396
1397 </pre>
1398 </html>
1399 Writing: CSG.hs.html
1400 <html><style type="text/css">
1401 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
1402 span.nottickedoff { background: yellow}
1403 span.istickedoff { background: white }
1404 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
1405 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
1406 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
1407 span.decl { font-weight: bold }
1408 span.spaces    { background: white }
1409 </style>
1410 <pre>
1411 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
1412 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
1413 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
1414 <span class="lineno">    4 </span>-- which is included in the distribution.
1415 <span class="lineno">    5 </span>
1416 <span class="lineno">    6 </span>module CSG(module Construct,
1417 <span class="lineno">    7 </span>           module Geometry,
1418 <span class="lineno">    8 </span>           module Intersections,
1419 <span class="lineno">    9 </span>           module Interval,
1420 <span class="lineno">   10 </span>           module Misc) where
1421 <span class="lineno">   11 </span>
1422 <span class="lineno">   12 </span>import Construct
1423 <span class="lineno">   13 </span>import Geometry
1424 <span class="lineno">   14 </span>import Intersections
1425 <span class="lineno">   15 </span>import Interval
1426 <span class="lineno">   16 </span>import Misc
1427
1428 </pre>
1429 </html>
1430 Writing: Interval.hs.html
1431 <html><style type="text/css">
1432 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
1433 span.nottickedoff { background: yellow}
1434 span.istickedoff { background: white }
1435 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
1436 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
1437 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
1438 span.decl { font-weight: bold }
1439 span.spaces    { background: white }
1440 </style>
1441 <pre>
1442 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
1443 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
1444 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
1445 <span class="lineno">    4 </span>-- which is included in the distribution.
1446 <span class="lineno">    5 </span>
1447 <span class="lineno">    6 </span>module Interval
1448 <span class="lineno">    7 </span>    ( IList
1449 <span class="lineno">    8 </span>    , Intersection
1450 <span class="lineno">    9 </span>    , emptyIList, openIList
1451 <span class="lineno">   10 </span>    , mkEntry, mkExit
1452 <span class="lineno">   11 </span>    , entryexit, exitentry
1453 <span class="lineno">   12 </span>    , mapI
1454 <span class="lineno">   13 </span>    , unionIntervals, intersectIntervals, differenceIntervals
1455 <span class="lineno">   14 </span>    , complementIntervals
1456 <span class="lineno">   15 </span>    ) where
1457 <span class="lineno">   16 </span>
1458 <span class="lineno">   17 </span>import Geometry
1459 <span class="lineno">   18 </span>
1460 <span class="lineno">   19 </span>-- The result of a ray trace is represented as a list of surface
1461 <span class="lineno">   20 </span>-- intersections.  Each intersection is a point along the ray with
1462 <span class="lineno">   21 </span>-- a flag indicating whether this intersection is an entry or an
1463 <span class="lineno">   22 </span>-- exit from the solid.  Each intersection also carries unspecified
1464 <span class="lineno">   23 </span>-- surface data for use by the illumination model.
1465 <span class="lineno">   24 </span>
1466 <span class="lineno">   25 </span>-- Just the list of intersections isn't enough, however.  An empty
1467 <span class="lineno">   26 </span>-- list can denote either a trace that is always within the solid
1468 <span class="lineno">   27 </span>-- or never in the solid.  To dissambiguate, an extra flag is kept
1469 <span class="lineno">   28 </span>-- that indicates whether we are starting inside or outside of the
1470 <span class="lineno">   29 </span>-- solid.  As a convenience, we also keep an additional flag that
1471 <span class="lineno">   30 </span>-- indicates whether the last intersection ends inside or outside.
1472 <span class="lineno">   31 </span>
1473 <span class="lineno">   32 </span>type IList a       = (Bool, [Intersection a], Bool)
1474 <span class="lineno">   33 </span>type Intersection a     = (Double, Bool, a)
1475 <span class="lineno">   34 </span>
1476 <span class="lineno">   35 </span><span class="decl"><span class="istickedoff">emptyIList = (False, [], False)</span></span>
1477 <span class="lineno">   36 </span><span class="decl"><span class="nottickedoff">openIList = (True, [], True)</span></span>
1478 <span class="lineno">   37 </span>
1479 <span class="lineno">   38 </span><span class="decl"><span class="istickedoff">mapI f (b1, is, b2) = (b1, map f is, b2)</span></span>
1480 <span class="lineno">   39 </span>
1481 <span class="lineno">   40 </span><span class="decl"><span class="istickedoff">isEntry (_, entry, _) = entry</span></span>
1482 <span class="lineno">   41 </span><span class="decl"><span class="nottickedoff">isExit  (_, entry, _) = not entry</span></span>
1483 <span class="lineno">   42 </span>
1484 <span class="lineno">   43 </span><span class="decl"><span class="istickedoff">mkEntry (t, a) = (t, True,  a)</span></span>
1485 <span class="lineno">   44 </span><span class="decl"><span class="istickedoff">mkExit  (t, a) = (t, False, a)</span></span>
1486 <span class="lineno">   45 </span>
1487 <span class="lineno">   46 </span><span class="decl"><span class="istickedoff">entryexit w1 w2 = (False, [mkEntry w1, mkExit w2], False)</span></span>
1488 <span class="lineno">   47 </span><span class="decl"><span class="nottickedoff">exitentry w1 w2 = (True, [mkExit w1, mkEntry w2], True)</span></span>
1489 <span class="lineno">   48 </span><span class="decl"><span class="nottickedoff">arrange   w1@(t1, _) w2@(t2, _) | t1 &lt; t2   = entryexit w1 w2</span>
1490 <span class="lineno">   49 </span><span class="spaces">                                </span><span class="nottickedoff">| otherwise = entryexit w2 w1</span></span>
1491 <span class="lineno">   50 </span>
1492 <span class="lineno">   51 </span>
1493 <span class="lineno">   52 </span>cmpI :: Intersection a -&gt; Intersection a -&gt; Ordering
1494 <span class="lineno">   53 </span><span class="decl"><span class="istickedoff">cmpI (i, _, _) (j, _, _)</span>
1495 <span class="lineno">   54 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlyfalse">i `near` j</span> = <span class="nottickedoff">EQ</span></span>
1496 <span class="lineno">   55 </span><span class="spaces">  </span><span class="istickedoff">| i   &lt;    j = LT</span>
1497 <span class="lineno">   56 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>  = GT</span></span>
1498 <span class="lineno">   57 </span>
1499 <span class="lineno">   58 </span><span class="decl"><span class="nottickedoff">bad (b1, [], b2) = b1 /= b2</span>
1500 <span class="lineno">   59 </span><span class="spaces"></span><span class="nottickedoff">bad (b1, is, b2) = bad' b1 is || b2 /= b3</span>
1501 <span class="lineno">   60 </span><span class="spaces">  </span><span class="nottickedoff">where (_, b3, _) = last is</span></span>
1502 <span class="lineno">   61 </span>
1503 <span class="lineno">   62 </span><span class="decl"><span class="nottickedoff">bad' b [] = False</span>
1504 <span class="lineno">   63 </span><span class="spaces"></span><span class="nottickedoff">bad' b ((_, c, _) : is) = b == c || bad' c is</span></span>
1505 <span class="lineno">   64 </span>
1506 <span class="lineno">   65 </span>unionIntervals :: IList a -&gt; IList a -&gt; IList a
1507 <span class="lineno">   66 </span><span class="decl"><span class="istickedoff">unionIntervals (isStartOpen, is, isEndOpen) (jsStartOpen, js, jsEndOpen)</span>
1508 <span class="lineno">   67 </span><span class="spaces">  </span><span class="istickedoff">= (isStartOpen || jsStartOpen, uniIntervals is js, isEndOpen || jsEndOpen)</span>
1509 <span class="lineno">   68 </span><span class="spaces">  </span><span class="istickedoff">where uniIntervals is [] | <span class="tickonlyfalse">jsEndOpen</span> = <span class="nottickedoff">[]</span></span>
1510 <span class="lineno">   69 </span><span class="spaces">                           </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span> = is</span>
1511 <span class="lineno">   70 </span><span class="spaces">        </span><span class="istickedoff">uniIntervals [] js | <span class="tickonlyfalse">isEndOpen</span> = <span class="nottickedoff">[]</span></span>
1512 <span class="lineno">   71 </span><span class="spaces">                           </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span> = js</span>
1513 <span class="lineno">   72 </span><span class="spaces">        </span><span class="istickedoff">uniIntervals is@(i : is') js@(j : js')</span>
1514 <span class="lineno">   73 </span><span class="spaces">          </span><span class="istickedoff">= case cmpI i j of</span>
1515 <span class="lineno">   74 </span><span class="spaces">            </span><span class="istickedoff">EQ -&gt; <span class="nottickedoff">if isEntry i == isEntry j then i : uniIntervals is' js'</span></span>
1516 <span class="lineno">   75 </span><span class="spaces">                                            </span><span class="istickedoff"><span class="nottickedoff">else uniIntervals is' js'</span></span>
1517 <span class="lineno">   76 </span><span class="spaces">            </span><span class="istickedoff">LT -&gt; if <span class="tickonlytrue">isEntry j</span> then i : <span class="nottickedoff">uniIntervals is' js</span></span>
1518 <span class="lineno">   77 </span><span class="spaces">                               </span><span class="istickedoff">else     <span class="nottickedoff">uniIntervals is' js</span></span>
1519 <span class="lineno">   78 </span><span class="spaces">            </span><span class="istickedoff">GT -&gt; if <span class="tickonlytrue">isEntry i</span> then j : uniIntervals is js'</span>
1520 <span class="lineno">   79 </span><span class="spaces">                               </span><span class="istickedoff">else     <span class="nottickedoff">uniIntervals is js'</span></span></span>
1521 <span class="lineno">   80 </span>
1522 <span class="lineno">   81 </span>intersectIntervals :: IList a -&gt; IList a -&gt; IList a
1523 <span class="lineno">   82 </span><span class="decl"><span class="nottickedoff">intersectIntervals is js</span>
1524 <span class="lineno">   83 </span><span class="spaces">  </span><span class="nottickedoff">= complementIntervals (unionIntervals is' js')</span>
1525 <span class="lineno">   84 </span><span class="spaces">  </span><span class="nottickedoff">where is' = complementIntervals is</span>
1526 <span class="lineno">   85 </span><span class="spaces">        </span><span class="nottickedoff">js' = complementIntervals js</span></span>
1527 <span class="lineno">   86 </span>
1528 <span class="lineno">   87 </span>differenceIntervals :: IList a -&gt; IList a -&gt; IList a
1529 <span class="lineno">   88 </span><span class="decl"><span class="nottickedoff">differenceIntervals is js</span>
1530 <span class="lineno">   89 </span><span class="spaces">  </span><span class="nottickedoff">= complementIntervals (unionIntervals is' js)</span>
1531 <span class="lineno">   90 </span><span class="spaces">  </span><span class="nottickedoff">where is' = complementIntervals is</span></span>
1532 <span class="lineno">   91 </span>
1533 <span class="lineno">   92 </span>complementIntervals :: IList a -&gt; IList a
1534 <span class="lineno">   93 </span><span class="decl"><span class="nottickedoff">complementIntervals (o1, is, o2)</span>
1535 <span class="lineno">   94 </span><span class="spaces">  </span><span class="nottickedoff">= (not o1, [ (i, not isentry, a) | (i, isentry, a) &lt;- is ], not o2)</span></span>
1536 <span class="lineno">   95 </span>
1537 <span class="lineno">   96 </span>-- tests...
1538 <span class="lineno">   97 </span>
1539 <span class="lineno">   98 </span>{-
1540 <span class="lineno">   99 </span>mkIn, mkOut :: Double -&gt; Intersection a
1541 <span class="lineno">  100 </span>mkIn x = (x, True, undefined)
1542 <span class="lineno">  101 </span>mkOut x = (x, False, undefined)
1543 <span class="lineno">  102 </span>
1544 <span class="lineno">  103 </span>i1 =  (False, [ mkIn 2, mkOut 7 ], False)
1545 <span class="lineno">  104 </span>i1' = (True, [ mkOut 2, mkIn 7 ], True)
1546 <span class="lineno">  105 </span>i2 =  (False, [ mkIn 1, mkOut 3, mkIn 4, mkOut 5, mkIn 6, mkOut 8 ], False)
1547 <span class="lineno">  106 </span>
1548 <span class="lineno">  107 </span>t1 = unionIntervals i1 i2
1549 <span class="lineno">  108 </span>t2 = intersectIntervals i1 i2
1550 <span class="lineno">  109 </span>t3 = intersectIntervals i2 i1
1551 <span class="lineno">  110 </span>t4 = complementIntervals i1
1552 <span class="lineno">  111 </span>t5 = intersectIntervals i2 i1'
1553 <span class="lineno">  112 </span>t6 = differenceIntervals i2 i1
1554 <span class="lineno">  113 </span>t7 = differenceIntervals i2 i2
1555 <span class="lineno">  114 </span>
1556 <span class="lineno">  115 </span>sh (o1,is,o2) =
1557 <span class="lineno">  116 </span>    do  if o1 then putStr &quot;...&quot; else return ()
1558 <span class="lineno">  117 </span>        putStr $ foldr1 (++) (map si is)
1559 <span class="lineno">  118 </span>        if o2 then putStr &quot;...&quot; else return ()
1560 <span class="lineno">  119 </span>si (i, True, _, _) = &quot;&lt;&quot; ++ show i
1561 <span class="lineno">  120 </span>si (i, False, _, _) = &quot; &quot; ++ show i ++ &quot;&gt;&quot;
1562 <span class="lineno">  121 </span>-}
1563
1564 </pre>
1565 </html>
1566 Writing: Geometry.hs.html
1567 <html><style type="text/css">
1568 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
1569 span.nottickedoff { background: yellow}
1570 span.istickedoff { background: white }
1571 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
1572 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
1573 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
1574 span.decl { font-weight: bold }
1575 span.spaces    { background: white }
1576 </style>
1577 <pre>
1578 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
1579 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
1580 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
1581 <span class="lineno">    4 </span>-- which is included in the distribution.
1582 <span class="lineno">    5 </span>
1583 <span class="lineno">    6 </span>module Geometry
1584 <span class="lineno">    7 </span>    ( Coords
1585 <span class="lineno">    8 </span>    , Ray
1586 <span class="lineno">    9 </span>    , Point  -- abstract
1587 <span class="lineno">   10 </span>    , Vector -- abstract
1588 <span class="lineno">   11 </span>    , Matrix -- abstract
1589 <span class="lineno">   12 </span>    , Color  -- abstract
1590 <span class="lineno">   13 </span>    , Box(..)
1591 <span class="lineno">   14 </span>    , Radian
1592 <span class="lineno">   15 </span>    , matrix
1593 <span class="lineno">   16 </span>    , coord
1594 <span class="lineno">   17 </span>    , color
1595 <span class="lineno">   18 </span>    , uncolor
1596 <span class="lineno">   19 </span>    , xCoord , yCoord , zCoord
1597 <span class="lineno">   20 </span>    , xComponent , yComponent , zComponent
1598 <span class="lineno">   21 </span>    , point
1599 <span class="lineno">   22 </span>    , vector
1600 <span class="lineno">   23 </span>    , nearV
1601 <span class="lineno">   24 </span>    , point_to_vector
1602 <span class="lineno">   25 </span>    , vector_to_point
1603 <span class="lineno">   26 </span>    , dot
1604 <span class="lineno">   27 </span>    , cross
1605 <span class="lineno">   28 </span>    , tangents
1606 <span class="lineno">   29 </span>    , addVV
1607 <span class="lineno">   30 </span>    , addPV
1608 <span class="lineno">   31 </span>    , subVV
1609 <span class="lineno">   32 </span>    , negV
1610 <span class="lineno">   33 </span>    , subPP
1611 <span class="lineno">   34 </span>    , norm
1612 <span class="lineno">   35 </span>    , normalize
1613 <span class="lineno">   36 </span>    , dist2
1614 <span class="lineno">   37 </span>    , sq
1615 <span class="lineno">   38 </span>    , distFrom0Sq
1616 <span class="lineno">   39 </span>    , distFrom0
1617 <span class="lineno">   40 </span>    , multSV
1618 <span class="lineno">   41 </span>    , multMM
1619 <span class="lineno">   42 </span>    , transposeM
1620 <span class="lineno">   43 </span>    , multMV
1621 <span class="lineno">   44 </span>    , multMP
1622 <span class="lineno">   45 </span>    , multMQ
1623 <span class="lineno">   46 </span>    , multMR
1624 <span class="lineno">   47 </span>    , white
1625 <span class="lineno">   48 </span>    , black
1626 <span class="lineno">   49 </span>    , addCC
1627 <span class="lineno">   50 </span>    , subCC
1628 <span class="lineno">   51 </span>    , sumCC
1629 <span class="lineno">   52 </span>    , multCC
1630 <span class="lineno">   53 </span>    , multSC
1631 <span class="lineno">   54 </span>    , nearC
1632 <span class="lineno">   55 </span>    , offsetToPoint
1633 <span class="lineno">   56 </span>    , epsilon
1634 <span class="lineno">   57 </span>    , inf
1635 <span class="lineno">   58 </span>    , nonZero
1636 <span class="lineno">   59 </span>    , eqEps
1637 <span class="lineno">   60 </span>    , near
1638 <span class="lineno">   61 </span>    , clampf
1639 <span class="lineno">   62 </span>    ) where
1640 <span class="lineno">   63 </span>
1641 <span class="lineno">   64 </span>import List 
1642 <span class="lineno">   65 </span>
1643 <span class="lineno">   66 </span>type Coords = (Double,Double,Double)
1644 <span class="lineno">   67 </span>
1645 <span class="lineno">   68 </span>type Ray = (Point,Vector)    -- origin of ray, and unit vector giving direction
1646 <span class="lineno">   69 </span>
1647 <span class="lineno">   70 </span>data Point  = P !Double !Double !Double -- implicit extra arg of 1
1648 <span class="lineno">   71 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
1649 <span class="lineno">   72 </span>data Vector = V !Double !Double !Double -- implicit extra arg of 0
1650 <span class="lineno">   73 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>, <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>)
1651 <span class="lineno">   74 </span>data Matrix = M !Quad   !Quad   !Quad   !Quad
1652 <span class="lineno">   75 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
1653 <span class="lineno">   76 </span>
1654 <span class="lineno">   77 </span>data Color  = C !Double !Double !Double
1655 <span class="lineno">   78 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>, <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>)
1656 <span class="lineno">   79 </span>
1657 <span class="lineno">   80 </span>data Box = B !Double !Double !Double !Double !Double !Double
1658 <span class="lineno">   81 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
1659 <span class="lineno">   82 </span>
1660 <span class="lineno">   83 </span>data Quad   = Q !Double !Double !Double !Double
1661 <span class="lineno">   84 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
1662 <span class="lineno">   85 </span>
1663 <span class="lineno">   86 </span>type Radian = Double
1664 <span class="lineno">   87 </span>
1665 <span class="lineno">   88 </span>type Tup4 a = (a,a,a,a)
1666 <span class="lineno">   89 </span>
1667 <span class="lineno">   90 </span>--{-# INLINE matrix #-}
1668 <span class="lineno">   91 </span>matrix :: Tup4 (Tup4 Double) -&gt; Matrix
1669 <span class="lineno">   92 </span><span class="decl"><span class="istickedoff">matrix ((m11, m12, m13, m14),</span>
1670 <span class="lineno">   93 </span><span class="spaces">          </span><span class="istickedoff">(m21, m22, m23, m24),</span>
1671 <span class="lineno">   94 </span><span class="spaces">          </span><span class="istickedoff">(m31, m32, m33, m34),</span>
1672 <span class="lineno">   95 </span><span class="spaces">          </span><span class="istickedoff">(m41, m42, m43, m44))</span>
1673 <span class="lineno">   96 </span><span class="spaces">  </span><span class="istickedoff">= M (Q m11 m12 m13 m14)</span>
1674 <span class="lineno">   97 </span><span class="spaces">      </span><span class="istickedoff">(Q m21 m22 m23 m24)</span>
1675 <span class="lineno">   98 </span><span class="spaces">      </span><span class="istickedoff">(Q m31 m32 m33 m34)</span>
1676 <span class="lineno">   99 </span><span class="spaces">      </span><span class="istickedoff">(Q m41 m42 m43 m44)</span></span>
1677 <span class="lineno">  100 </span>
1678 <span class="lineno">  101 </span><span class="decl"><span class="nottickedoff">coord x y z = (x, y, z)</span></span>
1679 <span class="lineno">  102 </span>
1680 <span class="lineno">  103 </span><span class="decl"><span class="istickedoff">color r g b = C r g b</span></span>
1681 <span class="lineno">  104 </span>
1682 <span class="lineno">  105 </span><span class="decl"><span class="istickedoff">uncolor (C r g b) = (r,g,b)</span></span>
1683 <span class="lineno">  106 </span>
1684 <span class="lineno">  107 </span>{-# INLINE xCoord #-}
1685 <span class="lineno">  108 </span><span class="decl"><span class="istickedoff">xCoord (P x y z) = x</span></span>
1686 <span class="lineno">  109 </span>{-# INLINE yCoord #-}
1687 <span class="lineno">  110 </span><span class="decl"><span class="istickedoff">yCoord (P x y z) = y</span></span>
1688 <span class="lineno">  111 </span>{-# INLINE zCoord #-}
1689 <span class="lineno">  112 </span><span class="decl"><span class="istickedoff">zCoord (P x y z) = z</span></span>
1690 <span class="lineno">  113 </span>
1691 <span class="lineno">  114 </span>{-# INLINE xComponent #-}
1692 <span class="lineno">  115 </span><span class="decl"><span class="istickedoff">xComponent (V x y z) = x</span></span>
1693 <span class="lineno">  116 </span>{-# INLINE yComponent #-}
1694 <span class="lineno">  117 </span><span class="decl"><span class="istickedoff">yComponent (V x y z) = y</span></span>
1695 <span class="lineno">  118 </span>{-# INLINE zComponent #-}
1696 <span class="lineno">  119 </span><span class="decl"><span class="istickedoff">zComponent (V x y z) = z</span></span>
1697 <span class="lineno">  120 </span>
1698 <span class="lineno">  121 </span>point :: Double -&gt; Double -&gt; Double -&gt; Point
1699 <span class="lineno">  122 </span><span class="decl"><span class="istickedoff">point x y z = P x y z</span></span>
1700 <span class="lineno">  123 </span>
1701 <span class="lineno">  124 </span>vector :: Double -&gt; Double -&gt; Double -&gt; Vector
1702 <span class="lineno">  125 </span><span class="decl"><span class="istickedoff">vector x y z = V x y z</span></span>
1703 <span class="lineno">  126 </span>
1704 <span class="lineno">  127 </span>nearV :: Vector -&gt; Vector -&gt; Bool
1705 <span class="lineno">  128 </span><span class="decl"><span class="nottickedoff">nearV (V a b c) (V d e f) = a `near` d &amp;&amp; b `near` e &amp;&amp; c `near` f</span></span>
1706 <span class="lineno">  129 </span>
1707 <span class="lineno">  130 </span>point_to_vector :: Point -&gt; Vector
1708 <span class="lineno">  131 </span><span class="decl"><span class="nottickedoff">point_to_vector (P x y z) = V x y z</span></span>
1709 <span class="lineno">  132 </span>
1710 <span class="lineno">  133 </span>vector_to_point :: Vector -&gt; Point
1711 <span class="lineno">  134 </span><span class="decl"><span class="nottickedoff">vector_to_point (V x y z)  = P x y z</span></span> 
1712 <span class="lineno">  135 </span>
1713 <span class="lineno">  136 </span>{-# INLINE vector_to_quad #-}
1714 <span class="lineno">  137 </span>vector_to_quad :: Vector -&gt; Quad
1715 <span class="lineno">  138 </span><span class="decl"><span class="istickedoff">vector_to_quad (V x y z) = Q x y z 0</span></span>
1716 <span class="lineno">  139 </span>
1717 <span class="lineno">  140 </span>{-# INLINE point_to_quad #-}
1718 <span class="lineno">  141 </span>point_to_quad :: Point -&gt; Quad
1719 <span class="lineno">  142 </span><span class="decl"><span class="istickedoff">point_to_quad (P x y z) = Q x y z 1</span></span>
1720 <span class="lineno">  143 </span>
1721 <span class="lineno">  144 </span>{-# INLINE quad_to_point #-}
1722 <span class="lineno">  145 </span>quad_to_point :: Quad -&gt; Point
1723 <span class="lineno">  146 </span><span class="decl"><span class="istickedoff">quad_to_point (Q x y z _) = P x y z</span></span>
1724 <span class="lineno">  147 </span>
1725 <span class="lineno">  148 </span>{-# INLINE quad_to_vector #-}
1726 <span class="lineno">  149 </span>quad_to_vector :: Quad -&gt; Vector
1727 <span class="lineno">  150 </span><span class="decl"><span class="istickedoff">quad_to_vector (Q x y z _) = V x y z</span></span>
1728 <span class="lineno">  151 </span>
1729 <span class="lineno">  152 </span>--{-# INLINE dot #-}
1730 <span class="lineno">  153 </span>dot :: Vector -&gt; Vector -&gt; Double
1731 <span class="lineno">  154 </span><span class="decl"><span class="istickedoff">dot (V x1 y1 z1) (V x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2</span></span>
1732 <span class="lineno">  155 </span>
1733 <span class="lineno">  156 </span>cross :: Vector -&gt; Vector -&gt; Vector
1734 <span class="lineno">  157 </span><span class="decl"><span class="istickedoff">cross (V x1 y1 z1) (V x2 y2 z2)</span>
1735 <span class="lineno">  158 </span><span class="spaces">  </span><span class="istickedoff">= V (y1 * z2 - z1 * y2) (z1 * x2 - x1 * z2) (x1 * y2 - y1 * x2)</span></span>
1736 <span class="lineno">  159 </span>
1737 <span class="lineno">  160 </span>-- assumption: the input vector is a normal
1738 <span class="lineno">  161 </span>tangents :: Vector -&gt; (Vector, Vector)
1739 <span class="lineno">  162 </span><span class="decl"><span class="nottickedoff">tangents v@(V x y z)</span>
1740 <span class="lineno">  163 </span><span class="spaces">  </span><span class="nottickedoff">= (v1, v `cross` v1)</span>
1741 <span class="lineno">  164 </span><span class="spaces">  </span><span class="nottickedoff">where v1 | x == 0    = normalize (vector 0 z (-y))</span>
1742 <span class="lineno">  165 </span><span class="spaces">           </span><span class="nottickedoff">| otherwise = normalize (vector (-y) x 0)</span></span>
1743 <span class="lineno">  166 </span>
1744 <span class="lineno">  167 </span>{-# INLINE dot4 #-}
1745 <span class="lineno">  168 </span>dot4 :: Quad -&gt; Quad -&gt; Double
1746 <span class="lineno">  169 </span><span class="decl"><span class="istickedoff">dot4 (Q x1 y1 z1 w1) (Q x2 y2 z2 w2) = x1 * x2 + y1 * y2 + z1 * z2 + w1 * w2</span></span>
1747 <span class="lineno">  170 </span>
1748 <span class="lineno">  171 </span>addVV :: Vector -&gt; Vector -&gt; Vector
1749 <span class="lineno">  172 </span><span class="decl"><span class="nottickedoff">addVV (V x1 y1 z1) (V x2 y2 z2) </span>
1750 <span class="lineno">  173 </span><span class="spaces">    </span><span class="nottickedoff">= V (x1 + x2) (y1 + y2) (z1 + z2)</span></span>
1751 <span class="lineno">  174 </span>
1752 <span class="lineno">  175 </span>addPV :: Point -&gt; Vector -&gt; Point
1753 <span class="lineno">  176 </span><span class="decl"><span class="istickedoff">addPV (P x1 y1 z1) (V x2 y2 z2) </span>
1754 <span class="lineno">  177 </span><span class="spaces">    </span><span class="istickedoff">= P (x1 + x2) (y1 + y2) (z1 + z2)</span></span>
1755 <span class="lineno">  178 </span>
1756 <span class="lineno">  179 </span>subVV :: Vector -&gt; Vector -&gt; Vector
1757 <span class="lineno">  180 </span><span class="decl"><span class="istickedoff">subVV (V x1 y1 z1) (V x2 y2 z2) </span>
1758 <span class="lineno">  181 </span><span class="spaces">    </span><span class="istickedoff">= V (x1 - x2) (y1 - y2) (z1 - z2)</span></span>
1759 <span class="lineno">  182 </span>
1760 <span class="lineno">  183 </span>negV :: Vector -&gt; Vector
1761 <span class="lineno">  184 </span><span class="decl"><span class="nottickedoff">negV (V x1 y1 z1) </span>
1762 <span class="lineno">  185 </span><span class="spaces">    </span><span class="nottickedoff">= V (-x1) (-y1) (-z1)</span></span>
1763 <span class="lineno">  186 </span>
1764 <span class="lineno">  187 </span>subPP :: Point -&gt; Point -&gt; Vector
1765 <span class="lineno">  188 </span><span class="decl"><span class="nottickedoff">subPP (P x1 y1 z1) (P x2 y2 z2) </span>
1766 <span class="lineno">  189 </span><span class="spaces">    </span><span class="nottickedoff">= V (x1 - x2) (y1 - y2) (z1 - z2)</span></span>
1767 <span class="lineno">  190 </span>
1768 <span class="lineno">  191 </span>--{-# INLINE norm #-}
1769 <span class="lineno">  192 </span>norm :: Vector -&gt; Double
1770 <span class="lineno">  193 </span><span class="decl"><span class="nottickedoff">norm (V x y z) = sqrt (sq x + sq y + sq z)</span></span>
1771 <span class="lineno">  194 </span>
1772 <span class="lineno">  195 </span>--{-# INLINE normalize #-}
1773 <span class="lineno">  196 </span>-- normalize a vector to a unit vector
1774 <span class="lineno">  197 </span>normalize :: Vector -&gt; Vector
1775 <span class="lineno">  198 </span><span class="decl"><span class="istickedoff">normalize v@(V x y z)</span>
1776 <span class="lineno">  199 </span><span class="spaces">             </span><span class="istickedoff">| <span class="tickonlytrue">norm /= 0</span> = multSV (1/norm) v</span>
1777 <span class="lineno">  200 </span><span class="spaces">             </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span> = <span class="nottickedoff">error &quot;normalize empty!&quot;</span></span>
1778 <span class="lineno">  201 </span><span class="spaces">    </span><span class="istickedoff">where norm = sqrt (sq x + sq y + sq z)</span></span>
1779 <span class="lineno">  202 </span>
1780 <span class="lineno">  203 </span>-- This does computes the distance *squared*
1781 <span class="lineno">  204 </span>dist2 :: Point -&gt; Point -&gt; Double
1782 <span class="lineno">  205 </span><span class="decl"><span class="nottickedoff">dist2 us vs = sq x + sq y + sq z</span>
1783 <span class="lineno">  206 </span><span class="spaces">    </span><span class="nottickedoff">where</span>
1784 <span class="lineno">  207 </span><span class="spaces">       </span><span class="nottickedoff">(V x y z) = subPP us vs</span></span>
1785 <span class="lineno">  208 </span>
1786 <span class="lineno">  209 </span>{-# INLINE sq #-}
1787 <span class="lineno">  210 </span>sq :: Double -&gt; Double
1788 <span class="lineno">  211 </span><span class="decl"><span class="istickedoff">sq d = d * d</span></span> 
1789 <span class="lineno">  212 </span>
1790 <span class="lineno">  213 </span>{-# INLINE distFrom0Sq #-}
1791 <span class="lineno">  214 </span>distFrom0Sq :: Point -&gt; Double  -- Distance of point from origin.
1792 <span class="lineno">  215 </span><span class="decl"><span class="nottickedoff">distFrom0Sq (P x y z) = sq x + sq y + sq z</span></span>
1793 <span class="lineno">  216 </span>
1794 <span class="lineno">  217 </span>{-# INLINE distFrom0 #-}
1795 <span class="lineno">  218 </span>distFrom0 :: Point -&gt; Double  -- Distance of point from origin.
1796 <span class="lineno">  219 </span><span class="decl"><span class="nottickedoff">distFrom0 p = sqrt (distFrom0Sq p)</span></span>
1797 <span class="lineno">  220 </span>
1798 <span class="lineno">  221 </span>--{-# INLINE multSV #-}
1799 <span class="lineno">  222 </span>multSV :: Double -&gt; Vector -&gt; Vector
1800 <span class="lineno">  223 </span><span class="decl"><span class="istickedoff">multSV k (V x y z) = V (k*x) (k*y) (k*z)</span></span>
1801 <span class="lineno">  224 </span>
1802 <span class="lineno">  225 </span>--{-# INLINE multMM #-}
1803 <span class="lineno">  226 </span>multMM :: Matrix -&gt; Matrix -&gt; Matrix
1804 <span class="lineno">  227 </span><span class="decl"><span class="istickedoff">multMM m1@(M q1 q2 q3 q4) m2</span>
1805 <span class="lineno">  228 </span><span class="spaces">     </span><span class="istickedoff">= M (multMQ m2' q1)</span>
1806 <span class="lineno">  229 </span><span class="spaces">         </span><span class="istickedoff">(multMQ m2' q2)</span>
1807 <span class="lineno">  230 </span><span class="spaces">         </span><span class="istickedoff">(multMQ m2' q3)</span>
1808 <span class="lineno">  231 </span><span class="spaces">         </span><span class="istickedoff">(multMQ m2' q4)</span>
1809 <span class="lineno">  232 </span><span class="spaces">  </span><span class="istickedoff">where</span>
1810 <span class="lineno">  233 </span><span class="spaces">     </span><span class="istickedoff">m2' = transposeM m2</span></span>
1811 <span class="lineno">  234 </span>
1812 <span class="lineno">  235 </span>{-# INLINE transposeM #-}     
1813 <span class="lineno">  236 </span>transposeM :: Matrix -&gt; Matrix
1814 <span class="lineno">  237 </span><span class="decl"><span class="istickedoff">transposeM (M (Q e11  e12  e13  e14)</span>
1815 <span class="lineno">  238 </span><span class="spaces">              </span><span class="istickedoff">(Q e21  e22  e23  e24)</span>
1816 <span class="lineno">  239 </span><span class="spaces">              </span><span class="istickedoff">(Q e31  e32  e33  e34)</span>
1817 <span class="lineno">  240 </span><span class="spaces">              </span><span class="istickedoff">(Q e41  e42  e43  e44)) = (M (Q e11  e21  e31  e41)</span>
1818 <span class="lineno">  241 </span><span class="spaces">                                           </span><span class="istickedoff">(Q e12  e22  e32  e42)</span>
1819 <span class="lineno">  242 </span><span class="spaces">                                           </span><span class="istickedoff">(Q e13  e23  e33  e43)</span>
1820 <span class="lineno">  243 </span><span class="spaces">                                           </span><span class="istickedoff">(Q e14  e24  e34  e44))</span></span>
1821 <span class="lineno">  244 </span>
1822 <span class="lineno">  245 </span>
1823 <span class="lineno">  246 </span>--multMM m1 m2 = [map (dot4 row) (transpose m2) | row &lt;- m1]
1824 <span class="lineno">  247 </span>
1825 <span class="lineno">  248 </span>--{-# INLINE multMV #-}
1826 <span class="lineno">  249 </span>multMV :: Matrix -&gt; Vector -&gt; Vector
1827 <span class="lineno">  250 </span><span class="decl"><span class="istickedoff">multMV m v = quad_to_vector (multMQ m (vector_to_quad v))</span></span>
1828 <span class="lineno">  251 </span>
1829 <span class="lineno">  252 </span>--{-# INLINE multMP #-}
1830 <span class="lineno">  253 </span>multMP :: Matrix -&gt; Point -&gt; Point
1831 <span class="lineno">  254 </span><span class="decl"><span class="istickedoff">multMP m p = quad_to_point (multMQ m (point_to_quad p))</span></span>
1832 <span class="lineno">  255 </span>
1833 <span class="lineno">  256 </span>-- mat vec = map (dot4 vec) mat
1834 <span class="lineno">  257 </span>
1835 <span class="lineno">  258 </span>{-# INLINE multMQ #-}
1836 <span class="lineno">  259 </span>multMQ :: Matrix -&gt; Quad -&gt; Quad
1837 <span class="lineno">  260 </span><span class="decl"><span class="istickedoff">multMQ (M q1 q2 q3 q4) q</span>
1838 <span class="lineno">  261 </span><span class="spaces">       </span><span class="istickedoff">= Q (dot4 q q1)</span>
1839 <span class="lineno">  262 </span><span class="spaces">           </span><span class="istickedoff">(dot4 q q2)</span>
1840 <span class="lineno">  263 </span><span class="spaces">           </span><span class="istickedoff">(dot4 q q3)</span>
1841 <span class="lineno">  264 </span><span class="spaces">           </span><span class="istickedoff">(dot4 q q4)</span></span>
1842 <span class="lineno">  265 </span>
1843 <span class="lineno">  266 </span>{-# INLINE multMR #-}
1844 <span class="lineno">  267 </span>multMR :: Matrix -&gt; Ray -&gt; Ray
1845 <span class="lineno">  268 </span><span class="decl"><span class="istickedoff">multMR m (r, v) = (multMP m r, multMV m v)</span></span>
1846 <span class="lineno">  269 </span>
1847 <span class="lineno">  270 </span>white :: Color
1848 <span class="lineno">  271 </span><span class="decl"><span class="nottickedoff">white = C 1 1 1</span></span>
1849 <span class="lineno">  272 </span>black :: Color
1850 <span class="lineno">  273 </span><span class="decl"><span class="istickedoff">black = C 0 0 0</span></span>
1851 <span class="lineno">  274 </span>
1852 <span class="lineno">  275 </span>addCC :: Color -&gt; Color -&gt; Color
1853 <span class="lineno">  276 </span><span class="decl"><span class="istickedoff">addCC (C a b c) (C d e f) = C (a+d) (b+e) (c+f)</span></span>
1854 <span class="lineno">  277 </span>
1855 <span class="lineno">  278 </span>subCC :: Color -&gt; Color -&gt; Color
1856 <span class="lineno">  279 </span><span class="decl"><span class="nottickedoff">subCC (C a b c) (C d e f) = C (a-d) (b-e) (c-f)</span></span>
1857 <span class="lineno">  280 </span>
1858 <span class="lineno">  281 </span>sumCC :: [Color] -&gt; Color
1859 <span class="lineno">  282 </span><span class="decl"><span class="istickedoff">sumCC = foldr addCC black</span></span>
1860 <span class="lineno">  283 </span>
1861 <span class="lineno">  284 </span>multCC :: Color -&gt; Color -&gt; Color
1862 <span class="lineno">  285 </span><span class="decl"><span class="istickedoff">multCC (C a b c) (C d e f) = C (a*d) (b*e) (c*f)</span></span>
1863 <span class="lineno">  286 </span>
1864 <span class="lineno">  287 </span>multSC :: Double -&gt; Color -&gt; Color
1865 <span class="lineno">  288 </span><span class="decl"><span class="istickedoff">multSC k       (C a b c) = C (a*k) (b*k) (c*k)</span></span>
1866 <span class="lineno">  289 </span>
1867 <span class="lineno">  290 </span>nearC :: Color -&gt; Color -&gt; Bool
1868 <span class="lineno">  291 </span><span class="decl"><span class="istickedoff">nearC (C a b c) (C d e f) = a `near` d &amp;&amp; b `near` e &amp;&amp; c `near` f</span></span>
1869 <span class="lineno">  292 </span>
1870 <span class="lineno">  293 </span>offsetToPoint :: Ray -&gt; Double -&gt; Point
1871 <span class="lineno">  294 </span><span class="decl"><span class="istickedoff">offsetToPoint (r,v) i = r `addPV` (i `multSV` v)</span></span>
1872 <span class="lineno">  295 </span>
1873 <span class="lineno">  296 </span>--
1874 <span class="lineno">  297 </span>
1875 <span class="lineno">  298 </span>epsilon, inf :: Double      -- aproximate zero and infinity
1876 <span class="lineno">  299 </span><span class="decl"><span class="istickedoff">epsilon = 1.0e-10</span></span>
1877 <span class="lineno">  300 </span><span class="decl"><span class="istickedoff">inf = 1.0e20</span></span>
1878 <span class="lineno">  301 </span>
1879 <span class="lineno">  302 </span>nonZero :: Double -&gt; Double         -- Use before a division. It makes definitions
1880 <span class="lineno">  303 </span><span class="decl"><span class="istickedoff">nonZero x | <span class="tickonlytrue">x &gt; epsilon</span>  = x        -- more complete and I bet the errors that get </span>
1881 <span class="lineno">  304 </span><span class="spaces">          </span><span class="istickedoff">| <span class="nottickedoff">x &lt; -epsilon</span> = <span class="nottickedoff">x</span>        -- introduced will be undetectable if epsilon</span>
1882 <span class="lineno">  305 </span><span class="spaces">          </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span>    = <span class="nottickedoff">epsilon</span></span></span>  -- is small enough
1883 <span class="lineno">  306 </span>
1884 <span class="lineno">  307 </span>
1885 <span class="lineno">  308 </span><span class="decl"><span class="istickedoff">eqEps x y = abs (x-y) &lt; epsilon</span></span>
1886 <span class="lineno">  309 </span><span class="decl"><span class="istickedoff">near = eqEps</span></span>
1887 <span class="lineno">  310 </span>
1888 <span class="lineno">  311 </span>clampf :: Double -&gt; Double
1889 <span class="lineno">  312 </span><span class="decl"><span class="istickedoff">clampf p | <span class="tickonlyfalse">p &lt; 0</span> = <span class="nottickedoff">0</span></span>
1890 <span class="lineno">  313 </span><span class="spaces">         </span><span class="istickedoff">| p &gt; 1 = 1</span>
1891 <span class="lineno">  314 </span><span class="spaces">         </span><span class="istickedoff">| <span class="tickonlytrue">True</span>  = p</span></span>
1892
1893 </pre>
1894 </html>
1895 Writing: Intersections.hs.html
1896 <html><style type="text/css">
1897 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
1898 span.nottickedoff { background: yellow}
1899 span.istickedoff { background: white }
1900 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
1901 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
1902 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
1903 span.decl { font-weight: bold }
1904 span.spaces    { background: white }
1905 </style>
1906 <pre>
1907 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
1908 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
1909 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
1910 <span class="lineno">    4 </span>-- which is included in the distribution.
1911 <span class="lineno">    5 </span>
1912 <span class="lineno">    6 </span>module Intersections 
1913 <span class="lineno">    7 </span>    ( intersectRayWithObject,
1914 <span class="lineno">    8 </span>      quadratic
1915 <span class="lineno">    9 </span>    ) where
1916 <span class="lineno">   10 </span>
1917 <span class="lineno">   11 </span>import Maybe(isJust)
1918 <span class="lineno">   12 </span>
1919 <span class="lineno">   13 </span>import Construct
1920 <span class="lineno">   14 </span>import Geometry
1921 <span class="lineno">   15 </span>import Interval
1922 <span class="lineno">   16 </span>import Misc
1923 <span class="lineno">   17 </span>
1924 <span class="lineno">   18 </span>-- This is factored into two bits.  The main function `intersections'
1925 <span class="lineno">   19 </span>-- intersects a line with an object.
1926 <span class="lineno">   20 </span>-- The wrapper call `intersectRayWithObject' coerces this to an intersection
1927 <span class="lineno">   21 </span>-- with a ray by clamping the result to start at 0.
1928 <span class="lineno">   22 </span>
1929 <span class="lineno">   23 </span><span class="decl"><span class="istickedoff">intersectRayWithObject ray p</span>
1930 <span class="lineno">   24 </span><span class="spaces">  </span><span class="istickedoff">= clampIntervals is</span>
1931 <span class="lineno">   25 </span><span class="spaces">  </span><span class="istickedoff">where is = intersections ray p</span></span>
1932 <span class="lineno">   26 </span>
1933 <span class="lineno">   27 </span><span class="decl"><span class="istickedoff">clampIntervals (True, [], True) = <span class="nottickedoff">(False, [(0, True, undefined)], True)</span></span>
1934 <span class="lineno">   28 </span><span class="spaces"></span><span class="istickedoff">clampIntervals empty@(False, [], False) = empty</span>
1935 <span class="lineno">   29 </span><span class="spaces"></span><span class="istickedoff">clampIntervals (True, is@((i, False, p) : is'), isOpen)</span>
1936 <span class="lineno">   30 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">i `near` 0 || i &lt; 0</span></span>
1937 <span class="lineno">   31 </span><span class="spaces">  </span><span class="istickedoff">= clampIntervals (False, is', isOpen)</span>
1938 <span class="lineno">   32 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span></span>
1939 <span class="lineno">   33 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(False, (0, True, undefined) : is, isOpen)</span></span>
1940 <span class="lineno">   34 </span><span class="spaces"></span><span class="istickedoff">clampIntervals ivals@(False, is@((i, True, p) : is'), isOpen)</span>
1941 <span class="lineno">   35 </span><span class="spaces">  </span><span class="istickedoff">| i `near` 0 || i &lt; 0</span>
1942 <span class="lineno">   36 </span><span class="spaces">  </span><span class="istickedoff">-- can unify this with first case...</span>
1943 <span class="lineno">   37 </span><span class="spaces">  </span><span class="istickedoff">= clampIntervals (True, is', isOpen)</span>
1944 <span class="lineno">   38 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span></span>
1945 <span class="lineno">   39 </span><span class="spaces">  </span><span class="istickedoff">= ivals</span></span>
1946 <span class="lineno">   40 </span>
1947 <span class="lineno">   41 </span><span class="decl"><span class="istickedoff">intersections ray (Union p q)</span>
1948 <span class="lineno">   42 </span><span class="spaces">  </span><span class="istickedoff">= unionIntervals is js</span>
1949 <span class="lineno">   43 </span><span class="spaces">  </span><span class="istickedoff">where is = intersections ray p</span>
1950 <span class="lineno">   44 </span><span class="spaces">        </span><span class="istickedoff">js = intersections ray q</span>
1951 <span class="lineno">   45 </span><span class="spaces"></span><span class="istickedoff"></span>
1952 <span class="lineno">   46 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Intersect p q)</span>
1953 <span class="lineno">   47 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectIntervals is js</span></span>
1954 <span class="lineno">   48 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">is = intersections ray p</span></span>
1955 <span class="lineno">   49 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">js = intersections ray q</span></span>
1956 <span class="lineno">   50 </span><span class="spaces"></span><span class="istickedoff"></span>
1957 <span class="lineno">   51 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Difference p q)</span>
1958 <span class="lineno">   52 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">differenceIntervals is (negateSurfaces js)</span></span>
1959 <span class="lineno">   53 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">is = intersections ray p</span></span>
1960 <span class="lineno">   54 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">js = intersections ray q</span></span>
1961 <span class="lineno">   55 </span><span class="spaces"></span><span class="istickedoff"></span>
1962 <span class="lineno">   56 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Transform m m' p)</span>
1963 <span class="lineno">   57 </span><span class="spaces">  </span><span class="istickedoff">= mapI (xform m) is</span>
1964 <span class="lineno">   58 </span><span class="spaces">  </span><span class="istickedoff">where is = intersections (m' `multMR` ray) p</span>
1965 <span class="lineno">   59 </span><span class="spaces">        </span><span class="istickedoff">xform m (i, b, (s, p0)) = (i, b, (transformSurface m s, p0))</span>
1966 <span class="lineno">   60 </span><span class="spaces"></span><span class="istickedoff"></span>
1967 <span class="lineno">   61 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Box box p)</span>
1968 <span class="lineno">   62 </span><span class="spaces">  </span><span class="istickedoff">| intersectWithBox ray box = intersections ray p</span>
1969 <span class="lineno">   63 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span> = emptyIList</span>
1970 <span class="lineno">   64 </span><span class="spaces"></span><span class="istickedoff"></span>
1971 <span class="lineno">   65 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Plane s)</span>
1972 <span class="lineno">   66 </span><span class="spaces">  </span><span class="istickedoff">= intersectPlane ray s</span>
1973 <span class="lineno">   67 </span><span class="spaces"></span><span class="istickedoff"></span>
1974 <span class="lineno">   68 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Sphere s)</span>
1975 <span class="lineno">   69 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectSphere ray s</span></span>
1976 <span class="lineno">   70 </span><span class="spaces"></span><span class="istickedoff"></span>
1977 <span class="lineno">   71 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Cube s)</span>
1978 <span class="lineno">   72 </span><span class="spaces">  </span><span class="istickedoff">= intersectCube ray s</span>
1979 <span class="lineno">   73 </span><span class="spaces"></span><span class="istickedoff"></span>
1980 <span class="lineno">   74 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Cylinder s)</span>
1981 <span class="lineno">   75 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectCylinder ray s</span></span>
1982 <span class="lineno">   76 </span><span class="spaces"></span><span class="istickedoff"></span>
1983 <span class="lineno">   77 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Cone s)</span>
1984 <span class="lineno">   78 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectCone ray s</span></span></span>
1985 <span class="lineno">   79 </span>
1986 <span class="lineno">   80 </span>negateSurfaces :: IList (Surface, Texture a) -&gt; IList (Surface, Texture a)
1987 <span class="lineno">   81 </span><span class="decl"><span class="nottickedoff">negateSurfaces = mapI negSurf</span>
1988 <span class="lineno">   82 </span><span class="spaces">  </span><span class="nottickedoff">where negSurf (i, b, (s,t)) = (i, b, (negateSurface s, t))</span></span>
1989 <span class="lineno">   83 </span>
1990 <span class="lineno">   84 </span><span class="decl"><span class="nottickedoff">negateSurface (Planar p0 v0 v1)</span>
1991 <span class="lineno">   85 </span><span class="spaces">  </span><span class="nottickedoff">= Planar p0 v1 v0</span>
1992 <span class="lineno">   86 </span><span class="spaces"></span><span class="nottickedoff">negateSurface (Spherical p0 v0 v1)</span>
1993 <span class="lineno">   87 </span><span class="spaces">  </span><span class="nottickedoff">= Spherical p0 v1 v0</span>
1994 <span class="lineno">   88 </span><span class="spaces"></span><span class="nottickedoff">negateSurface (Cylindrical p0 v0 v1)</span>
1995 <span class="lineno">   89 </span><span class="spaces">  </span><span class="nottickedoff">= Cylindrical p0 v1 v0</span>
1996 <span class="lineno">   90 </span><span class="spaces"></span><span class="nottickedoff">negateSurface (Conic p0 v0 v1)</span>
1997 <span class="lineno">   91 </span><span class="spaces">  </span><span class="nottickedoff">= Conic p0 v1 v0</span></span>
1998 <span class="lineno">   92 </span>
1999 <span class="lineno">   93 </span><span class="decl"><span class="istickedoff">transformSurface m (Planar p0 v0 v1)</span>
2000 <span class="lineno">   94 </span><span class="spaces">  </span><span class="istickedoff">= Planar <span class="nottickedoff">p0'</span> v0' v1'</span>
2001 <span class="lineno">   95 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
2002 <span class="lineno">   96 </span><span class="spaces">        </span><span class="istickedoff">v0' = multMV m v0</span>
2003 <span class="lineno">   97 </span><span class="spaces">        </span><span class="istickedoff">v1' = multMV m v1</span>
2004 <span class="lineno">   98 </span><span class="spaces"></span><span class="istickedoff"></span>
2005 <span class="lineno">   99 </span><span class="spaces"></span><span class="istickedoff">transformSurface m (Spherical p0 v0 v1)</span>
2006 <span class="lineno">  100 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">Spherical p0' v0' v1'</span></span>
2007 <span class="lineno">  101 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
2008 <span class="lineno">  102 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v0' = multMV m v0</span></span>
2009 <span class="lineno">  103 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v1' = multMV m v1</span></span>
2010 <span class="lineno">  104 </span><span class="spaces"></span><span class="istickedoff"></span>
2011 <span class="lineno">  105 </span><span class="spaces"></span><span class="istickedoff">-- ditto as above</span>
2012 <span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff">transformSurface m (Cylindrical p0 v0 v1)</span>
2013 <span class="lineno">  107 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">Cylindrical p0' v0' v1'</span></span>
2014 <span class="lineno">  108 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
2015 <span class="lineno">  109 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v0' = multMV m v0</span></span>
2016 <span class="lineno">  110 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v1' = multMV m v1</span></span>
2017 <span class="lineno">  111 </span><span class="spaces"></span><span class="istickedoff"></span>
2018 <span class="lineno">  112 </span><span class="spaces"></span><span class="istickedoff">transformSurface m (Conic p0 v0 v1)</span>
2019 <span class="lineno">  113 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">Conic p0' v0' v1'</span></span>
2020 <span class="lineno">  114 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
2021 <span class="lineno">  115 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v0' = multMV m v0</span></span>
2022 <span class="lineno">  116 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v1' = multMV m v1</span></span></span>
2023 <span class="lineno">  117 </span>
2024 <span class="lineno">  118 </span>--------------------------------
2025 <span class="lineno">  119 </span>-- Plane
2026 <span class="lineno">  120 </span>--------------------------------
2027 <span class="lineno">  121 </span>
2028 <span class="lineno">  122 </span>intersectPlane :: Ray -&gt; a -&gt; IList (Surface, Texture a)
2029 <span class="lineno">  123 </span><span class="decl"><span class="istickedoff">intersectPlane ray texture = intersectXZPlane PlaneFace ray 0.0 texture</span></span>
2030 <span class="lineno">  124 </span>
2031 <span class="lineno">  125 </span>intersectXZPlane :: Face -&gt; Ray -&gt; Double -&gt; a -&gt; IList (Surface, Texture a)
2032 <span class="lineno">  126 </span><span class="decl"><span class="istickedoff">intersectXZPlane n (r,v) yoffset texture</span>
2033 <span class="lineno">  127 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlyfalse">b `near` 0</span></span>
2034 <span class="lineno">  128 </span><span class="spaces">  </span><span class="istickedoff">= -- the ray is parallel to the plane - it's either all in, or all out</span>
2035 <span class="lineno">  129 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">if y `near` yoffset || y &lt; yoffset then openIList else emptyIList</span></span>
2036 <span class="lineno">  130 </span><span class="spaces"></span><span class="istickedoff"></span>
2037 <span class="lineno">  131 </span><span class="spaces">    </span><span class="istickedoff">-- The line intersects the plane. Find t such that</span>
2038 <span class="lineno">  132 </span><span class="spaces">    </span><span class="istickedoff">-- (x + at, y + bt, z + ct) intersects the X-Z plane.</span>
2039 <span class="lineno">  133 </span><span class="spaces">    </span><span class="istickedoff">-- t may be negative (the ray starts within the halfspace),</span>
2040 <span class="lineno">  134 </span><span class="spaces">    </span><span class="istickedoff">-- but we'll catch that later when we clamp the intervals</span>
2041 <span class="lineno">  135 </span><span class="spaces"></span><span class="istickedoff"></span>
2042 <span class="lineno">  136 </span><span class="spaces">  </span><span class="istickedoff">| b &lt; 0       -- the ray is pointing downwards</span>
2043 <span class="lineno">  137 </span><span class="spaces">  </span><span class="istickedoff">= (False, [mkEntry (t0, (Planar <span class="nottickedoff">p0</span> v0 v1, (n, p0, texture)))], <span class="nottickedoff">True</span>)</span>
2044 <span class="lineno">  138 </span><span class="spaces"></span><span class="istickedoff"></span>
2045 <span class="lineno">  139 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>   -- the ray is pointing upwards</span>
2046 <span class="lineno">  140 </span><span class="spaces">  </span><span class="istickedoff">= (True,  [mkExit (t0, (<span class="nottickedoff">Planar p0 v0 v1</span>, <span class="nottickedoff">(n, p0, texture)</span>))],  False)</span>
2047 <span class="lineno">  141 </span><span class="spaces"></span><span class="istickedoff"></span>
2048 <span class="lineno">  142 </span><span class="spaces">  </span><span class="istickedoff">where t0 = (yoffset-y) / b</span>
2049 <span class="lineno">  143 </span><span class="spaces">        </span><span class="istickedoff">x0 = x + a * t0</span>
2050 <span class="lineno">  144 </span><span class="spaces">        </span><span class="istickedoff">z0 = z + c * t0</span>
2051 <span class="lineno">  145 </span><span class="spaces">        </span><span class="istickedoff">p0 = point x0 0 z0</span>
2052 <span class="lineno">  146 </span><span class="spaces">        </span><span class="istickedoff">v0 = vector 0 0 1</span>
2053 <span class="lineno">  147 </span><span class="spaces">        </span><span class="istickedoff">v1 = vector 1 0 0</span>
2054 <span class="lineno">  148 </span><span class="spaces"></span><span class="istickedoff"></span>
2055 <span class="lineno">  149 </span><span class="spaces">        </span><span class="istickedoff">x = xCoord r</span>
2056 <span class="lineno">  150 </span><span class="spaces">        </span><span class="istickedoff">y = yCoord r</span>
2057 <span class="lineno">  151 </span><span class="spaces">        </span><span class="istickedoff">z = zCoord r</span>
2058 <span class="lineno">  152 </span><span class="spaces">        </span><span class="istickedoff">a = xComponent v</span>
2059 <span class="lineno">  153 </span><span class="spaces">        </span><span class="istickedoff">b = yComponent v</span>
2060 <span class="lineno">  154 </span><span class="spaces">        </span><span class="istickedoff">c = zComponent v</span></span>
2061 <span class="lineno">  155 </span>
2062 <span class="lineno">  156 </span>
2063 <span class="lineno">  157 </span>--------------------------------
2064 <span class="lineno">  158 </span>-- Sphere
2065 <span class="lineno">  159 </span>--------------------------------
2066 <span class="lineno">  160 </span>
2067 <span class="lineno">  161 </span>intersectSphere :: Ray -&gt; a -&gt; IList (Surface, Texture a)
2068 <span class="lineno">  162 </span><span class="decl"><span class="nottickedoff">intersectSphere ray@(r, v) texture</span>
2069 <span class="lineno">  163 </span><span class="spaces">  </span><span class="nottickedoff">= -- Find t such that (x + ta, y + tb, z + tc) intersects the</span>
2070 <span class="lineno">  164 </span><span class="spaces">    </span><span class="nottickedoff">-- unit sphere, that is, such that:</span>
2071 <span class="lineno">  165 </span><span class="spaces">    </span><span class="nottickedoff">--   (x + ta)^2 + (y + tb)^2 + (z + tc)^2 = 1</span>
2072 <span class="lineno">  166 </span><span class="spaces">    </span><span class="nottickedoff">-- This is a quadratic equation in t:</span>
2073 <span class="lineno">  167 </span><span class="spaces">    </span><span class="nottickedoff">--   t^2(a^2 + b^2 + c^2) + 2t(xa + yb + zc) + (x^2 + y^2 + z^2 - 1) = 0</span>
2074 <span class="lineno">  168 </span><span class="spaces">    </span><span class="nottickedoff">let c1 = sq a + sq b + sq c</span>
2075 <span class="lineno">  169 </span><span class="spaces">        </span><span class="nottickedoff">c2 = 2 * (x * a + y * b + z * c)</span>
2076 <span class="lineno">  170 </span><span class="spaces">        </span><span class="nottickedoff">c3 = sq x + sq y + sq z - 1</span>
2077 <span class="lineno">  171 </span><span class="spaces">    </span><span class="nottickedoff">in</span>
2078 <span class="lineno">  172 </span><span class="spaces">        </span><span class="nottickedoff">case quadratic c1 c2 c3 of</span>
2079 <span class="lineno">  173 </span><span class="spaces">        </span><span class="nottickedoff">Nothing -&gt; emptyIList</span>
2080 <span class="lineno">  174 </span><span class="spaces">        </span><span class="nottickedoff">Just (t1, t2) -&gt; entryexit (g t1) (g t2)</span>
2081 <span class="lineno">  175 </span><span class="spaces">    </span><span class="nottickedoff">where x = xCoord r</span>
2082 <span class="lineno">  176 </span><span class="spaces">          </span><span class="nottickedoff">y = yCoord r</span>
2083 <span class="lineno">  177 </span><span class="spaces">          </span><span class="nottickedoff">z = zCoord r</span>
2084 <span class="lineno">  178 </span><span class="spaces">          </span><span class="nottickedoff">a = xComponent v</span>
2085 <span class="lineno">  179 </span><span class="spaces">          </span><span class="nottickedoff">b = yComponent v</span>
2086 <span class="lineno">  180 </span><span class="spaces">          </span><span class="nottickedoff">c = zComponent v</span>
2087 <span class="lineno">  181 </span><span class="spaces">          </span><span class="nottickedoff">g t = (t, (Spherical origin v1 v2, (SphereFace, p0, texture)))</span>
2088 <span class="lineno">  182 </span><span class="spaces">              </span><span class="nottickedoff">where origin = point 0 0 0</span>
2089 <span class="lineno">  183 </span><span class="spaces">                    </span><span class="nottickedoff">x0 = x + t * a</span>
2090 <span class="lineno">  184 </span><span class="spaces">                    </span><span class="nottickedoff">y0 = y + t * b</span>
2091 <span class="lineno">  185 </span><span class="spaces">                    </span><span class="nottickedoff">z0 = z + t * c</span>
2092 <span class="lineno">  186 </span><span class="spaces">                    </span><span class="nottickedoff">p0 = point  x0 y0 z0</span>
2093 <span class="lineno">  187 </span><span class="spaces">                    </span><span class="nottickedoff">v0 = vector x0 y0 z0</span>
2094 <span class="lineno">  188 </span><span class="spaces">                    </span><span class="nottickedoff">(v1, v2) = tangents v0</span></span>
2095 <span class="lineno">  189 </span>
2096 <span class="lineno">  190 </span>
2097 <span class="lineno">  191 </span>--------------------------------
2098 <span class="lineno">  192 </span>-- Cube
2099 <span class="lineno">  193 </span>--------------------------------
2100 <span class="lineno">  194 </span>
2101 <span class="lineno">  195 </span>intersectCube :: Ray -&gt; a -&gt; IList (Surface, Texture a)
2102 <span class="lineno">  196 </span><span class="decl"><span class="istickedoff">intersectCube ray@(r, v) texture</span>
2103 <span class="lineno">  197 </span><span class="spaces">  </span><span class="istickedoff">= -- The set of t such that (x + at, y + bt, z + ct) lies within</span>
2104 <span class="lineno">  198 </span><span class="spaces">    </span><span class="istickedoff">-- the unit cube satisfies:</span>
2105 <span class="lineno">  199 </span><span class="spaces">    </span><span class="istickedoff">--    0 &lt;= x + at &lt;= 1,  0 &lt;= y + bt &lt;= 1,  0 &lt;= z + ct &lt;= 1</span>
2106 <span class="lineno">  200 </span><span class="spaces">    </span><span class="istickedoff">-- The minimum and maximum such values of t give us the two</span>
2107 <span class="lineno">  201 </span><span class="spaces">    </span><span class="istickedoff">-- intersection points.</span>
2108 <span class="lineno">  202 </span><span class="spaces">    </span><span class="istickedoff">case intersectSlabIval (intersectCubeSlab face2 face3 x a)</span>
2109 <span class="lineno">  203 </span><span class="spaces">        </span><span class="istickedoff">(intersectSlabIval (intersectCubeSlab face5 face4 y b)</span>
2110 <span class="lineno">  204 </span><span class="spaces">                           </span><span class="istickedoff">(intersectCubeSlab face0 <span class="nottickedoff">face1</span> z c)) of</span>
2111 <span class="lineno">  205 </span><span class="spaces">    </span><span class="istickedoff">Nothing -&gt; emptyIList</span>
2112 <span class="lineno">  206 </span><span class="spaces">    </span><span class="istickedoff">Just (t1, t2) -&gt; entryexit (g t1) (g t2)</span>
2113 <span class="lineno">  207 </span><span class="spaces">  </span><span class="istickedoff">where g ((n, v0, v1), t)</span>
2114 <span class="lineno">  208 </span><span class="spaces">          </span><span class="istickedoff">= (t, (Planar <span class="nottickedoff">p0</span> v0 v1, (n, p0, texture)))</span>
2115 <span class="lineno">  209 </span><span class="spaces">          </span><span class="istickedoff">where p0 = offsetToPoint ray t</span>
2116 <span class="lineno">  210 </span><span class="spaces">        </span><span class="istickedoff">face0 = (CubeFront,  vectorY, vectorX)</span>
2117 <span class="lineno">  211 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">face1 = (CubeBack,   vectorX, vectorY)</span></span>
2118 <span class="lineno">  212 </span><span class="spaces">        </span><span class="istickedoff">face2 = (CubeLeft,   vectorZ, vectorY)</span>
2119 <span class="lineno">  213 </span><span class="spaces">        </span><span class="istickedoff">face3 = (<span class="nottickedoff">CubeRight</span>,  <span class="nottickedoff">vectorY</span>, <span class="nottickedoff">vectorZ</span>)</span>
2120 <span class="lineno">  214 </span><span class="spaces">        </span><span class="istickedoff">face4 = (CubeTop,    vectorZ, vectorX)</span>
2121 <span class="lineno">  215 </span><span class="spaces">        </span><span class="istickedoff">face5 = (CubeBottom, vectorX, vectorZ)</span>
2122 <span class="lineno">  216 </span><span class="spaces">        </span><span class="istickedoff">vectorX = vector 1 0 0</span>
2123 <span class="lineno">  217 </span><span class="spaces">        </span><span class="istickedoff">vectorY = vector 0 1 0</span>
2124 <span class="lineno">  218 </span><span class="spaces">        </span><span class="istickedoff">vectorZ = vector 0 0 1</span>
2125 <span class="lineno">  219 </span><span class="spaces">        </span><span class="istickedoff">x = xCoord r</span>
2126 <span class="lineno">  220 </span><span class="spaces">        </span><span class="istickedoff">y = yCoord r</span>
2127 <span class="lineno">  221 </span><span class="spaces">        </span><span class="istickedoff">z = zCoord r</span>
2128 <span class="lineno">  222 </span><span class="spaces">        </span><span class="istickedoff">a = xComponent v</span>
2129 <span class="lineno">  223 </span><span class="spaces">        </span><span class="istickedoff">b = yComponent v</span>
2130 <span class="lineno">  224 </span><span class="spaces">        </span><span class="istickedoff">c = zComponent v</span></span>
2131 <span class="lineno">  225 </span>
2132 <span class="lineno">  226 </span><span class="decl"><span class="istickedoff">intersectCubeSlab n m w d</span>
2133 <span class="lineno">  227 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlyfalse">d `near` 0</span> = <span class="nottickedoff">if (0 &lt;= w) &amp;&amp; (w &lt;= 1)</span></span>
2134 <span class="lineno">  228 </span><span class="spaces">                 </span><span class="istickedoff"><span class="nottickedoff">then Just ((n, -inf), (m, inf)) else Nothing</span></span>
2135 <span class="lineno">  229 </span><span class="spaces">  </span><span class="istickedoff">| d &gt; 0      = Just ((n,  (-w)/d), (m, (1-w)/d))</span>
2136 <span class="lineno">  230 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>  = Just ((m, (1-w)/d), (n,  (-w)/d))</span></span>
2137 <span class="lineno">  231 </span>
2138 <span class="lineno">  232 </span><span class="decl"><span class="istickedoff">intersectSlabIval Nothing Nothing  = <span class="nottickedoff">Nothing</span></span>
2139 <span class="lineno">  233 </span><span class="spaces"></span><span class="istickedoff">intersectSlabIval Nothing (Just i) = <span class="nottickedoff">Nothing</span></span>
2140 <span class="lineno">  234 </span><span class="spaces"></span><span class="istickedoff">intersectSlabIval (Just i) Nothing = Nothing</span>
2141 <span class="lineno">  235 </span><span class="spaces"></span><span class="istickedoff">intersectSlabIval (Just (nu1@(n1, u1), mv1@(m1, v1)))</span>
2142 <span class="lineno">  236 </span><span class="spaces">                  </span><span class="istickedoff">(Just (nu2@(n2, u2), mv2@(m2, v2)))</span>
2143 <span class="lineno">  237 </span><span class="spaces">  </span><span class="istickedoff">= checkInterval (nu, mv)</span>
2144 <span class="lineno">  238 </span><span class="spaces">  </span><span class="istickedoff">where nu = if u1 &lt; u2 then nu2 else nu1</span>
2145 <span class="lineno">  239 </span><span class="spaces">        </span><span class="istickedoff">mv = if v1 &lt; v2 then mv1 else mv2</span>
2146 <span class="lineno">  240 </span><span class="spaces">        </span><span class="istickedoff">checkInterval numv@(nu@(_, u), (m, v))</span>
2147 <span class="lineno">  241 </span><span class="spaces">          </span><span class="istickedoff">-- rounding error may force us to push v out a bit</span>
2148 <span class="lineno">  242 </span><span class="spaces">          </span><span class="istickedoff">| <span class="tickonlyfalse">u `near` v</span> = <span class="nottickedoff">Just (nu, (m, u + epsilon))</span></span>
2149 <span class="lineno">  243 </span><span class="spaces">          </span><span class="istickedoff">| u    &lt;   v = Just numv</span>
2150 <span class="lineno">  244 </span><span class="spaces">          </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>  = Nothing</span></span>
2151 <span class="lineno">  245 </span>
2152 <span class="lineno">  246 </span>
2153 <span class="lineno">  247 </span>--------------------------------
2154 <span class="lineno">  248 </span>-- Cylinder
2155 <span class="lineno">  249 </span>--------------------------------
2156 <span class="lineno">  250 </span>
2157 <span class="lineno">  251 </span>intersectCylinder :: Ray -&gt; a -&gt; IList (Surface, Texture a)
2158 <span class="lineno">  252 </span><span class="decl"><span class="nottickedoff">intersectCylinder ray texture</span>
2159 <span class="lineno">  253 </span><span class="spaces">  </span><span class="nottickedoff">= isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom</span>
2160 <span class="lineno">  254 </span><span class="spaces">  </span><span class="nottickedoff">where isectSide   = intersectCylSide ray texture</span>
2161 <span class="lineno">  255 </span><span class="spaces">        </span><span class="nottickedoff">isectTop    = intersectXZPlane CylinderTop ray 1.0 texture</span>
2162 <span class="lineno">  256 </span><span class="spaces">        </span><span class="nottickedoff">isectBottom = complementIntervals $ negateSurfaces $</span>
2163 <span class="lineno">  257 </span><span class="spaces">                      </span><span class="nottickedoff">intersectXZPlane CylinderBottom ray 0.0 texture</span></span>
2164 <span class="lineno">  258 </span>
2165 <span class="lineno">  259 </span><span class="decl"><span class="nottickedoff">intersectCylSide (r, v) texture</span>
2166 <span class="lineno">  260 </span><span class="spaces">  </span><span class="nottickedoff">= -- The ray (x + ta, y + tb, z + tc) intersects the sides of the</span>
2167 <span class="lineno">  261 </span><span class="spaces">    </span><span class="nottickedoff">-- cylinder if:</span>
2168 <span class="lineno">  262 </span><span class="spaces">    </span><span class="nottickedoff">--    (x + ta)^2 + (z + tc)^2 = 1  and 0 &lt;= y + tb &lt;= 1.</span>
2169 <span class="lineno">  263 </span><span class="spaces">    </span><span class="nottickedoff">if (sq a + sq c) `near` 0</span>
2170 <span class="lineno">  264 </span><span class="spaces">    </span><span class="nottickedoff">then -- The ray is parallel to the Y-axis, and does not intersect</span>
2171 <span class="lineno">  265 </span><span class="spaces">         </span><span class="nottickedoff">-- the cylinder sides.  It's either all in, or all out</span>
2172 <span class="lineno">  266 </span><span class="spaces">        </span><span class="nottickedoff">if (sqxy `near` 1.0 || sqxy &lt; 1.0) then openIList else emptyIList</span>
2173 <span class="lineno">  267 </span><span class="spaces">   </span><span class="nottickedoff">else -- Find values of t that solve the quadratic equation</span>
2174 <span class="lineno">  268 </span><span class="spaces">        </span><span class="nottickedoff">--   (a^2 + c^2)t^2 + 2(ax + cz)t + x^2 + z^2 - 1 = 0</span>
2175 <span class="lineno">  269 </span><span class="spaces">        </span><span class="nottickedoff">let c1 = sq a + sq c</span>
2176 <span class="lineno">  270 </span><span class="spaces">            </span><span class="nottickedoff">c2 = 2 * (x * a + z * c)</span>
2177 <span class="lineno">  271 </span><span class="spaces">            </span><span class="nottickedoff">c3 = sq x + sq z - 1</span>
2178 <span class="lineno">  272 </span><span class="spaces">        </span><span class="nottickedoff">in</span>
2179 <span class="lineno">  273 </span><span class="spaces">        </span><span class="nottickedoff">case quadratic c1 c2 c3 of</span>
2180 <span class="lineno">  274 </span><span class="spaces">        </span><span class="nottickedoff">Nothing -&gt; emptyIList</span>
2181 <span class="lineno">  275 </span><span class="spaces">        </span><span class="nottickedoff">Just (t1, t2) -&gt; entryexit (g t1) (g t2)</span>
2182 <span class="lineno">  276 </span><span class="spaces"></span><span class="nottickedoff"></span>
2183 <span class="lineno">  277 </span><span class="spaces">  </span><span class="nottickedoff">where sqxy = sq x + sq y</span>
2184 <span class="lineno">  278 </span><span class="spaces">        </span><span class="nottickedoff">g t = (t, (Cylindrical origin v1 v2, (CylinderSide, p0, texture)))</span>
2185 <span class="lineno">  279 </span><span class="spaces">            </span><span class="nottickedoff">where origin = point 0 0 0</span>
2186 <span class="lineno">  280 </span><span class="spaces">                  </span><span class="nottickedoff">x0 = x + t * a</span>
2187 <span class="lineno">  281 </span><span class="spaces">                  </span><span class="nottickedoff">y0 = y + t * b</span>
2188 <span class="lineno">  282 </span><span class="spaces">                  </span><span class="nottickedoff">z0 = z + t * c</span>
2189 <span class="lineno">  283 </span><span class="spaces">                  </span><span class="nottickedoff">p0 = point  x0 y0 z0</span>
2190 <span class="lineno">  284 </span><span class="spaces">                  </span><span class="nottickedoff">v0 = vector x0 0 z0</span>
2191 <span class="lineno">  285 </span><span class="spaces">                  </span><span class="nottickedoff">(v1, v2) = tangents v0</span>
2192 <span class="lineno">  286 </span><span class="spaces"></span><span class="nottickedoff"></span>
2193 <span class="lineno">  287 </span><span class="spaces">        </span><span class="nottickedoff">x = xCoord r</span>
2194 <span class="lineno">  288 </span><span class="spaces">        </span><span class="nottickedoff">y = yCoord r</span>
2195 <span class="lineno">  289 </span><span class="spaces">        </span><span class="nottickedoff">z = zCoord r</span>
2196 <span class="lineno">  290 </span><span class="spaces">        </span><span class="nottickedoff">a = xComponent v</span>
2197 <span class="lineno">  291 </span><span class="spaces">        </span><span class="nottickedoff">b = yComponent v</span>
2198 <span class="lineno">  292 </span><span class="spaces">        </span><span class="nottickedoff">c = zComponent v</span></span>
2199 <span class="lineno">  293 </span>
2200 <span class="lineno">  294 </span>
2201 <span class="lineno">  295 </span>-------------------
2202 <span class="lineno">  296 </span>-- Cone
2203 <span class="lineno">  297 </span>-------------------
2204 <span class="lineno">  298 </span>
2205 <span class="lineno">  299 </span>intersectCone :: Ray -&gt; a -&gt; IList (Surface, Texture a)
2206 <span class="lineno">  300 </span><span class="decl"><span class="nottickedoff">intersectCone ray texture</span>
2207 <span class="lineno">  301 </span><span class="spaces">  </span><span class="nottickedoff">= isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom</span>
2208 <span class="lineno">  302 </span><span class="spaces">  </span><span class="nottickedoff">where isectSide   = intersectConeSide ray texture</span>
2209 <span class="lineno">  303 </span><span class="spaces">        </span><span class="nottickedoff">isectTop    = intersectXZPlane ConeBase ray 1.0 texture</span>
2210 <span class="lineno">  304 </span><span class="spaces">        </span><span class="nottickedoff">isectBottom = complementIntervals $ negateSurfaces $</span>
2211 <span class="lineno">  305 </span><span class="spaces">                      </span><span class="nottickedoff">intersectXZPlane ConeBase ray 0.0 texture</span></span>
2212 <span class="lineno">  306 </span>
2213 <span class="lineno">  307 </span><span class="decl"><span class="nottickedoff">intersectConeSide (r, v) texture</span>
2214 <span class="lineno">  308 </span><span class="spaces">  </span><span class="nottickedoff">= -- Find the points where the ray intersects the cond side.  At any points of</span>
2215 <span class="lineno">  309 </span><span class="spaces">    </span><span class="nottickedoff">-- intersection, we must have:</span>
2216 <span class="lineno">  310 </span><span class="spaces">    </span><span class="nottickedoff">--    (x + ta)^2 + (z + tc)^2 = (y + tb)^2</span>
2217 <span class="lineno">  311 </span><span class="spaces">    </span><span class="nottickedoff">-- which is the following quadratic equation:</span>
2218 <span class="lineno">  312 </span><span class="spaces">    </span><span class="nottickedoff">--    t^2(a^2-b^2+c^2) + 2t(xa-yb+cz) + (x^2-y^2+z^2) = 0</span>
2219 <span class="lineno">  313 </span><span class="spaces">    </span><span class="nottickedoff">let c1 = sq a - sq b + sq c</span>
2220 <span class="lineno">  314 </span><span class="spaces">        </span><span class="nottickedoff">c2 = 2 * (x * a - y * b + c * z)</span>
2221 <span class="lineno">  315 </span><span class="spaces">        </span><span class="nottickedoff">c3 = sq x - sq y + sq z</span>
2222 <span class="lineno">  316 </span><span class="spaces">    </span><span class="nottickedoff">in  case quadratic c1 c2 c3 of</span>
2223 <span class="lineno">  317 </span><span class="spaces">        </span><span class="nottickedoff">Nothing -&gt; emptyIList</span>
2224 <span class="lineno">  318 </span><span class="spaces">        </span><span class="nottickedoff">Just (t1, t2) -&gt;</span>
2225 <span class="lineno">  319 </span><span class="spaces">            </span><span class="nottickedoff">-- If either intersection strikes the middle, then the other</span>
2226 <span class="lineno">  320 </span><span class="spaces">            </span><span class="nottickedoff">-- can only be off by rounding error, so we make a tangent</span>
2227 <span class="lineno">  321 </span><span class="spaces">            </span><span class="nottickedoff">-- strike using the &quot;good&quot; value.</span>
2228 <span class="lineno">  322 </span><span class="spaces">            </span><span class="nottickedoff">-- If the intersections straddle the origin, then it's</span>
2229 <span class="lineno">  323 </span><span class="spaces">            </span><span class="nottickedoff">-- an exit/entry pair, otherwise it's an entry/exit pair.</span>
2230 <span class="lineno">  324 </span><span class="spaces">            </span><span class="nottickedoff">let y1 = y + t1 * b</span>
2231 <span class="lineno">  325 </span><span class="spaces">                </span><span class="nottickedoff">y2 = y + t2 * b</span>
2232 <span class="lineno">  326 </span><span class="spaces">            </span><span class="nottickedoff">in  if y1 `near` 0                  then entryexit (g t1) (g t1)</span>
2233 <span class="lineno">  327 </span><span class="spaces">                </span><span class="nottickedoff">else if y2 `near` 0             then entryexit (g t2) (g t2)</span>
2234 <span class="lineno">  328 </span><span class="spaces">                </span><span class="nottickedoff">else if (y1 &lt; 0) `xor` (y2 &lt; 0) then exitentry (g t1) (g t2)</span>
2235 <span class="lineno">  329 </span><span class="spaces">                </span><span class="nottickedoff">else                                 entryexit (g t1) (g t2)</span>
2236 <span class="lineno">  330 </span><span class="spaces"></span><span class="nottickedoff"></span>
2237 <span class="lineno">  331 </span><span class="spaces">  </span><span class="nottickedoff">where g t = (t, (Conic origin v1 v2, (ConeSide, p0, texture)))</span>
2238 <span class="lineno">  332 </span><span class="spaces">            </span><span class="nottickedoff">where origin = point 0 0 0</span>
2239 <span class="lineno">  333 </span><span class="spaces">                  </span><span class="nottickedoff">x0 = x + t * a</span>
2240 <span class="lineno">  334 </span><span class="spaces">                  </span><span class="nottickedoff">y0 = y + t * b</span>
2241 <span class="lineno">  335 </span><span class="spaces">                  </span><span class="nottickedoff">z0 = z + t * c</span>
2242 <span class="lineno">  336 </span><span class="spaces">                  </span><span class="nottickedoff">p0 = point  x0 y0 z0</span>
2243 <span class="lineno">  337 </span><span class="spaces">                  </span><span class="nottickedoff">v0 = normalize $ vector x0 (-y0) z0</span>
2244 <span class="lineno">  338 </span><span class="spaces">                  </span><span class="nottickedoff">(v1, v2) = tangents v0</span>
2245 <span class="lineno">  339 </span><span class="spaces"></span><span class="nottickedoff"></span>
2246 <span class="lineno">  340 </span><span class="spaces">        </span><span class="nottickedoff">x = xCoord r</span>
2247 <span class="lineno">  341 </span><span class="spaces">        </span><span class="nottickedoff">y = yCoord r</span>
2248 <span class="lineno">  342 </span><span class="spaces">        </span><span class="nottickedoff">z = zCoord r</span>
2249 <span class="lineno">  343 </span><span class="spaces">        </span><span class="nottickedoff">a = xComponent v</span>
2250 <span class="lineno">  344 </span><span class="spaces">        </span><span class="nottickedoff">b = yComponent v</span>
2251 <span class="lineno">  345 </span><span class="spaces">        </span><span class="nottickedoff">c = zComponent v</span>
2252 <span class="lineno">  346 </span><span class="spaces"></span><span class="nottickedoff"></span>
2253 <span class="lineno">  347 </span><span class="spaces">        </span><span class="nottickedoff">-- beyond me why this isn't defined in the prelude...</span>
2254 <span class="lineno">  348 </span><span class="spaces">        </span><span class="nottickedoff">xor False b = b</span>
2255 <span class="lineno">  349 </span><span class="spaces">        </span><span class="nottickedoff">xor True  b = not b</span></span>
2256 <span class="lineno">  350 </span>
2257 <span class="lineno">  351 </span>
2258 <span class="lineno">  352 </span>-------------------
2259 <span class="lineno">  353 </span>-- Solving quadratics
2260 <span class="lineno">  354 </span>-------------------
2261 <span class="lineno">  355 </span>
2262 <span class="lineno">  356 </span>quadratic :: Double -&gt; Double -&gt; Double -&gt; Maybe (Double, Double)
2263 <span class="lineno">  357 </span><span class="decl"><span class="nottickedoff">quadratic a b c =</span>
2264 <span class="lineno">  358 </span><span class="spaces">  </span><span class="nottickedoff">-- Solve the equation ax^2 + bx + c = 0 by using the quadratic formula.</span>
2265 <span class="lineno">  359 </span><span class="spaces">  </span><span class="nottickedoff">let d = sq b - 4 * a * c</span>
2266 <span class="lineno">  360 </span><span class="spaces">      </span><span class="nottickedoff">d' = if d `near` 0 then 0 else d</span>
2267 <span class="lineno">  361 </span><span class="spaces">  </span><span class="nottickedoff">in if d' &lt; 0</span>
2268 <span class="lineno">  362 </span><span class="spaces">     </span><span class="nottickedoff">then Nothing -- There are no real roots.</span>
2269 <span class="lineno">  363 </span><span class="spaces">     </span><span class="nottickedoff">else</span>
2270 <span class="lineno">  364 </span><span class="spaces">        </span><span class="nottickedoff">if a &gt; 0 then Just (((-b) - sqrt d') / (2 * a),</span>
2271 <span class="lineno">  365 </span><span class="spaces">                            </span><span class="nottickedoff">((-b) + sqrt d') / (2 * a))</span>
2272 <span class="lineno">  366 </span><span class="spaces">                 </span><span class="nottickedoff">else Just (((-b) + sqrt d') / (2 * a),</span>
2273 <span class="lineno">  367 </span><span class="spaces">                            </span><span class="nottickedoff">((-b) - sqrt d') / (2 * a))</span></span>
2274 <span class="lineno">  368 </span>
2275 <span class="lineno">  369 </span>-------------------
2276 <span class="lineno">  370 </span>-- Bounding boxes
2277 <span class="lineno">  371 </span>-------------------
2278 <span class="lineno">  372 </span>
2279 <span class="lineno">  373 </span>data MaybeInterval = Interval !Double !Double 
2280 <span class="lineno">  374 </span>                  | NoInterval
2281 <span class="lineno">  375 </span>
2282 <span class="lineno">  376 </span><span class="decl"><span class="istickedoff">isInterval (Interval _ _) = True</span>
2283 <span class="lineno">  377 </span><span class="spaces"></span><span class="istickedoff">isInterval _              = False</span></span>
2284 <span class="lineno">  378 </span>
2285 <span class="lineno">  379 </span>intersectWithBox :: Ray -&gt; Box -&gt; Bool
2286 <span class="lineno">  380 </span><span class="decl"><span class="istickedoff">intersectWithBox (r, v) (B x1 x2 y1 y2 z1 z2)</span>
2287 <span class="lineno">  381 </span><span class="spaces">  </span><span class="istickedoff">= isInterval interval</span>
2288 <span class="lineno">  382 </span><span class="spaces">  </span><span class="istickedoff">where x_interval = intersectRayWithSlab (xCoord r) (xComponent v) (x1, x2)</span>
2289 <span class="lineno">  383 </span><span class="spaces">        </span><span class="istickedoff">y_interval = intersectRayWithSlab (yCoord r) (yComponent v) (y1, y2)</span>
2290 <span class="lineno">  384 </span><span class="spaces">        </span><span class="istickedoff">z_interval = intersectRayWithSlab (zCoord r) (zComponent v) (z1, z2)</span>
2291 <span class="lineno">  385 </span><span class="spaces">        </span><span class="istickedoff">interval = intersectInterval x_interval</span>
2292 <span class="lineno">  386 </span><span class="spaces">                   </span><span class="istickedoff">(intersectInterval y_interval z_interval)</span></span>
2293 <span class="lineno">  387 </span>
2294 <span class="lineno">  388 </span>intersectInterval :: MaybeInterval -&gt; MaybeInterval -&gt; MaybeInterval
2295 <span class="lineno">  389 </span><span class="decl"><span class="istickedoff">intersectInterval NoInterval _ = <span class="nottickedoff">NoInterval</span></span>
2296 <span class="lineno">  390 </span><span class="spaces"></span><span class="istickedoff">intersectInterval _ NoInterval = NoInterval</span>
2297 <span class="lineno">  391 </span><span class="spaces"></span><span class="istickedoff">intersectInterval (Interval a b) (Interval c d)</span>
2298 <span class="lineno">  392 </span><span class="spaces">  </span><span class="istickedoff">| b &lt; c || d &lt; a = NoInterval</span>
2299 <span class="lineno">  393 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span> = Interval (a `max` c) (b `min` d)</span></span>
2300 <span class="lineno">  394 </span>
2301 <span class="lineno">  395 </span>{-# INLINE intersectRayWithSlab #-}
2302 <span class="lineno">  396 </span>intersectRayWithSlab :: Double -&gt; Double -&gt; (Double,Double) -&gt; MaybeInterval
2303 <span class="lineno">  397 </span><span class="decl"><span class="istickedoff">intersectRayWithSlab xCoord alpha (x1, x2)</span>
2304 <span class="lineno">  398 </span><span class="spaces">  </span><span class="istickedoff">| alpha == 0 = if xCoord &lt; x1 || xCoord &gt; x2 then NoInterval else infInterval</span>
2305 <span class="lineno">  399 </span><span class="spaces">  </span><span class="istickedoff">| alpha &gt;  0 = Interval a b</span>
2306 <span class="lineno">  400 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>  = Interval b a </span>
2307 <span class="lineno">  401 </span><span class="spaces">  </span><span class="istickedoff">where a = (x1 - xCoord) / alpha</span>
2308 <span class="lineno">  402 </span><span class="spaces">        </span><span class="istickedoff">b = (x2 - xCoord) / alpha</span></span>
2309 <span class="lineno">  403 </span>
2310 <span class="lineno">  404 </span><span class="decl"><span class="istickedoff">infInterval = Interval (-inf) inf</span></span>
2311
2312 </pre>
2313 </html>
2314 Writing: Construct.hs.html
2315 <html><style type="text/css">
2316 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
2317 span.nottickedoff { background: yellow}
2318 span.istickedoff { background: white }
2319 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
2320 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
2321 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
2322 span.decl { font-weight: bold }
2323 span.spaces    { background: white }
2324 </style>
2325 <pre>
2326 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
2327 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
2328 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
2329 <span class="lineno">    4 </span>-- which is included in the distribution.
2330 <span class="lineno">    5 </span>
2331 <span class="lineno">    6 </span>module Construct
2332 <span class="lineno">    7 </span>    ( Surface (..)
2333 <span class="lineno">    8 </span>    , Face (..)
2334 <span class="lineno">    9 </span>    , CSG (..)
2335 <span class="lineno">   10 </span>    , Texture
2336 <span class="lineno">   11 </span>    , Transform
2337 <span class="lineno">   12 </span>    , union, intersect, difference
2338 <span class="lineno">   13 </span>    , plane, sphere, cube, cylinder, cone
2339 <span class="lineno">   14 </span>    , transform
2340 <span class="lineno">   15 </span>    , translate, translateX, translateY, translateZ
2341 <span class="lineno">   16 </span>    , scale, scaleX, scaleY, scaleZ, uscale
2342 <span class="lineno">   17 </span>    , rotateX, rotateY, rotateZ
2343 <span class="lineno">   18 </span>    , eye, translateEye
2344 <span class="lineno">   19 </span>    , rotateEyeX, rotateEyeY, rotateEyeZ
2345 <span class="lineno">   20 </span>    ) where
2346 <span class="lineno">   21 </span>
2347 <span class="lineno">   22 </span>import Geometry
2348 <span class="lineno">   23 </span>
2349 <span class="lineno">   24 </span>-- In each case, we model the surface by a point and a pair of tangent vectors.
2350 <span class="lineno">   25 </span>-- This gives us enough information to determine the surface
2351 <span class="lineno">   26 </span>-- normal at that point, which is all that is required by the current
2352 <span class="lineno">   27 </span>-- illumination model.  We can't just save the surface normal because
2353 <span class="lineno">   28 </span>-- that isn't preserved by transformations.
2354 <span class="lineno">   29 </span>
2355 <span class="lineno">   30 </span>data Surface
2356 <span class="lineno">   31 </span>  = Planar Point Vector Vector
2357 <span class="lineno">   32 </span>  | Spherical Point Vector Vector
2358 <span class="lineno">   33 </span>  | Cylindrical Point Vector Vector
2359 <span class="lineno">   34 </span>  | Conic Point Vector Vector
2360 <span class="lineno">   35 </span>  deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
2361 <span class="lineno">   36 </span>
2362 <span class="lineno">   37 </span>data Face
2363 <span class="lineno">   38 </span>  = PlaneFace
2364 <span class="lineno">   39 </span>  | SphereFace
2365 <span class="lineno">   40 </span>  | CubeFront
2366 <span class="lineno">   41 </span>  | CubeBack
2367 <span class="lineno">   42 </span>  | CubeLeft
2368 <span class="lineno">   43 </span>  | CubeRight
2369 <span class="lineno">   44 </span>  | CubeTop
2370 <span class="lineno">   45 </span>  | CubeBottom
2371 <span class="lineno">   46 </span>  | CylinderSide
2372 <span class="lineno">   47 </span>  | CylinderTop
2373 <span class="lineno">   48 </span>  | CylinderBottom
2374 <span class="lineno">   49 </span>  | ConeSide
2375 <span class="lineno">   50 </span>  | ConeBase
2376 <span class="lineno">   51 </span>  deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
2377 <span class="lineno">   52 </span>
2378 <span class="lineno">   53 </span>data CSG a
2379 <span class="lineno">   54 </span>  = Plane a
2380 <span class="lineno">   55 </span>  | Sphere a
2381 <span class="lineno">   56 </span>  | Cylinder a
2382 <span class="lineno">   57 </span>  | Cube a
2383 <span class="lineno">   58 </span>  | Cone a
2384 <span class="lineno">   59 </span>  | Transform Matrix Matrix (CSG a)
2385 <span class="lineno">   60 </span>  | Union (CSG a) (CSG a)
2386 <span class="lineno">   61 </span>  | Intersect (CSG a) (CSG a)
2387 <span class="lineno">   62 </span>  | Difference (CSG a) (CSG a)
2388 <span class="lineno">   63 </span>  | Box Box (CSG a)
2389 <span class="lineno">   64 </span>  deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
2390 <span class="lineno">   65 </span>
2391 <span class="lineno">   66 </span>-- the data returned for determining surface texture
2392 <span class="lineno">   67 </span>-- the Face tells which face of a primitive this is
2393 <span class="lineno">   68 </span>-- the Point is the point of intersection in object coordinates
2394 <span class="lineno">   69 </span>-- the a is application-specific texture information
2395 <span class="lineno">   70 </span>type Texture a = (Face, Point, a)
2396 <span class="lineno">   71 </span>
2397 <span class="lineno">   72 </span>union, intersect, difference       :: CSG a -&gt; CSG a -&gt; CSG a
2398 <span class="lineno">   73 </span>
2399 <span class="lineno">   74 </span><span class="decl"><span class="istickedoff">union p@(Box b1 _) q@(Box b2 _) = <span class="nottickedoff">Box (mergeBox b1 b2) (Union p q)</span></span>
2400 <span class="lineno">   75 </span><span class="spaces"></span><span class="istickedoff">union p q = Union p q</span></span>
2401 <span class="lineno">   76 </span>
2402 <span class="lineno">   77 </span>-- rather pessimistic
2403 <span class="lineno">   78 </span><span class="decl"><span class="nottickedoff">intersect p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Intersect p q)</span>
2404 <span class="lineno">   79 </span><span class="spaces"></span><span class="nottickedoff">intersect p q = Intersect p q</span></span>
2405 <span class="lineno">   80 </span>
2406 <span class="lineno">   81 </span><span class="decl"><span class="nottickedoff">difference (Box b1 p) q = Box b1 (Difference p q)</span>
2407 <span class="lineno">   82 </span><span class="spaces"></span><span class="nottickedoff">-- no need to box again inside</span>
2408 <span class="lineno">   83 </span><span class="spaces"></span><span class="nottickedoff">-- difference p@(Box b1 _) q = Box b1 (Difference p q)</span>
2409 <span class="lineno">   84 </span><span class="spaces"></span><span class="nottickedoff">difference p q = Difference p q</span></span>
2410 <span class="lineno">   85 </span>
2411 <span class="lineno">   86 </span><span class="decl"><span class="istickedoff">mkBox b p = Box b p</span></span>
2412 <span class="lineno">   87 </span>
2413 <span class="lineno">   88 </span>plane, sphere, cube, cylinder, cone     :: a -&gt; CSG a
2414 <span class="lineno">   89 </span>
2415 <span class="lineno">   90 </span><span class="decl"><span class="istickedoff">plane = Plane</span></span>
2416 <span class="lineno">   91 </span><span class="decl"><span class="nottickedoff">sphere s =</span>
2417 <span class="lineno">   92 </span><span class="spaces">    </span><span class="nottickedoff">mkBox (B (-1 - epsilon) (1 + epsilon)</span>
2418 <span class="lineno">   93 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)</span>
2419 <span class="lineno">   94 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)) (Sphere s)</span></span>
2420 <span class="lineno">   95 </span><span class="decl"><span class="nottickedoff">cone s =</span>
2421 <span class="lineno">   96 </span><span class="spaces">    </span><span class="nottickedoff">mkBox (B (-1 - epsilon) (1 + epsilon)</span>
2422 <span class="lineno">   97 </span><span class="spaces">             </span><span class="nottickedoff">(   - epsilon) (1 + epsilon)</span>
2423 <span class="lineno">   98 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)) (Cone s)</span></span>
2424 <span class="lineno">   99 </span><span class="decl"><span class="istickedoff">cube s =</span>
2425 <span class="lineno">  100 </span><span class="spaces">    </span><span class="istickedoff">mkBox (B (- epsilon) (1 + epsilon)</span>
2426 <span class="lineno">  101 </span><span class="spaces">             </span><span class="istickedoff">(- epsilon) (1 + epsilon)</span>
2427 <span class="lineno">  102 </span><span class="spaces">             </span><span class="istickedoff">(- epsilon) (1 + epsilon)) (Cube s)</span></span>
2428 <span class="lineno">  103 </span><span class="decl"><span class="nottickedoff">cylinder s =</span>
2429 <span class="lineno">  104 </span><span class="spaces">    </span><span class="nottickedoff">mkBox (B (-1 - epsilon) (1 + epsilon)</span>
2430 <span class="lineno">  105 </span><span class="spaces">             </span><span class="nottickedoff">(   - epsilon) (1 + epsilon)</span>
2431 <span class="lineno">  106 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)) (Cylinder s)</span></span>
2432 <span class="lineno">  107 </span>
2433 <span class="lineno">  108 </span>----------------------------
2434 <span class="lineno">  109 </span>-- Object transformations
2435 <span class="lineno">  110 </span>----------------------------
2436 <span class="lineno">  111 </span>
2437 <span class="lineno">  112 </span>type Transform = (Matrix, Matrix)
2438 <span class="lineno">  113 </span>
2439 <span class="lineno">  114 </span>transform :: Transform -&gt; CSG a -&gt; CSG a
2440 <span class="lineno">  115 </span>
2441 <span class="lineno">  116 </span><span class="decl"><span class="istickedoff">transform (m, m')   (Transform mp mp' p) = Transform  (multMM m mp)       (multMM mp' m') p</span>
2442 <span class="lineno">  117 </span><span class="spaces"></span><span class="istickedoff">transform mm'       (Union p q)          = Union      (transform mm' p)   (transform mm' q)</span>
2443 <span class="lineno">  118 </span><span class="spaces"></span><span class="istickedoff">transform mm'       (Intersect p q)      = <span class="nottickedoff">Intersect  (transform mm' p)   (transform mm' q)</span></span>
2444 <span class="lineno">  119 </span><span class="spaces"></span><span class="istickedoff">transform mm'       (Difference p q)     = <span class="nottickedoff">Difference (transform mm' p)   (transform mm' q)</span></span>
2445 <span class="lineno">  120 </span><span class="spaces"></span><span class="istickedoff">transform mm'@(m,_) (Box box p)          = Box        (transformBox m box) (transform mm' p)</span>
2446 <span class="lineno">  121 </span><span class="spaces"></span><span class="istickedoff">transform (m, m')   prim                 = Transform  m m' prim</span></span>
2447 <span class="lineno">  122 </span>
2448 <span class="lineno">  123 </span>translate                      :: Coords -&gt; CSG a -&gt; CSG a
2449 <span class="lineno">  124 </span>translateX, translateY, translateZ      :: Double -&gt; CSG a -&gt; CSG a
2450 <span class="lineno">  125 </span>
2451 <span class="lineno">  126 </span><span class="decl"><span class="istickedoff">translate xyz = transform $ transM xyz</span></span>
2452 <span class="lineno">  127 </span><span class="decl"><span class="nottickedoff">translateX x = translate (x, 0, 0)</span></span>
2453 <span class="lineno">  128 </span><span class="decl"><span class="nottickedoff">translateY y = translate (0, y, 0)</span></span>
2454 <span class="lineno">  129 </span><span class="decl"><span class="nottickedoff">translateZ z = translate (0, 0, z)</span></span>
2455 <span class="lineno">  130 </span>
2456 <span class="lineno">  131 </span>scale                    :: Coords -&gt; CSG a -&gt; CSG a
2457 <span class="lineno">  132 </span>scaleX, scaleY, scaleZ, uscale   :: Double -&gt; CSG a -&gt; CSG a
2458 <span class="lineno">  133 </span>
2459 <span class="lineno">  134 </span><span class="decl"><span class="istickedoff">scale xyz = transform $ scaleM xyz</span></span>
2460 <span class="lineno">  135 </span><span class="decl"><span class="nottickedoff">scaleX x = scale (x, 1, 1)</span></span>
2461 <span class="lineno">  136 </span><span class="decl"><span class="nottickedoff">scaleY y = scale (1, y, 1)</span></span>
2462 <span class="lineno">  137 </span><span class="decl"><span class="nottickedoff">scaleZ z = scale (1, 1, z)</span></span>
2463 <span class="lineno">  138 </span><span class="decl"><span class="istickedoff">uscale u = scale (u,u,u)</span></span>
2464 <span class="lineno">  139 </span>
2465 <span class="lineno">  140 </span>rotateX, rotateY, rotateZ             :: Radian -&gt; CSG a -&gt; CSG a
2466 <span class="lineno">  141 </span>
2467 <span class="lineno">  142 </span><span class="decl"><span class="istickedoff">rotateX a = transform $ rotxM a</span></span>
2468 <span class="lineno">  143 </span><span class="decl"><span class="istickedoff">rotateY a = transform $ rotyM a</span></span>
2469 <span class="lineno">  144 </span><span class="decl"><span class="nottickedoff">rotateZ a = transform $ rotzM a</span></span>
2470 <span class="lineno">  145 </span>
2471 <span class="lineno">  146 </span><span class="decl"><span class="istickedoff">unit = matrix</span>
2472 <span class="lineno">  147 </span><span class="spaces">      </span><span class="istickedoff">( ( 1.0, 0.0, 0.0, 0.0 ),</span>
2473 <span class="lineno">  148 </span><span class="spaces">        </span><span class="istickedoff">( 0.0, 1.0, 0.0, 0.0 ),</span>
2474 <span class="lineno">  149 </span><span class="spaces">        </span><span class="istickedoff">( 0.0, 0.0, 1.0, 0.0 ),</span>
2475 <span class="lineno">  150 </span><span class="spaces">        </span><span class="istickedoff">( 0.0, 0.0, 0.0, 1.0 ) )</span></span>
2476 <span class="lineno">  151 </span>
2477 <span class="lineno">  152 </span><span class="decl"><span class="istickedoff">transM (x, y, z)</span>
2478 <span class="lineno">  153 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
2479 <span class="lineno">  154 </span><span class="spaces">      </span><span class="istickedoff">( ( 1, 0, 0, x ),</span>
2480 <span class="lineno">  155 </span><span class="spaces">        </span><span class="istickedoff">( 0, 1, 0, y ),</span>
2481 <span class="lineno">  156 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 1, z ),</span>
2482 <span class="lineno">  157 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 0, 1 ) ),</span>
2483 <span class="lineno">  158 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
2484 <span class="lineno">  159 </span><span class="spaces">      </span><span class="istickedoff">( ( 1, 0, 0, -x ),</span>
2485 <span class="lineno">  160 </span><span class="spaces">        </span><span class="istickedoff">( 0, 1, 0, -y ),</span>
2486 <span class="lineno">  161 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 1, -z ),</span>
2487 <span class="lineno">  162 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 0,  1 ) ) )</span></span>
2488 <span class="lineno">  163 </span>
2489 <span class="lineno">  164 </span><span class="decl"><span class="istickedoff">scaleM (x, y, z)</span>
2490 <span class="lineno">  165 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
2491 <span class="lineno">  166 </span><span class="spaces">      </span><span class="istickedoff">( (   x',    0,    0, 0 ),</span>
2492 <span class="lineno">  167 </span><span class="spaces">        </span><span class="istickedoff">(    0,   y',    0, 0 ),</span>
2493 <span class="lineno">  168 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0,   z', 0 ),</span>
2494 <span class="lineno">  169 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0,    0, 1 ) ),</span>
2495 <span class="lineno">  170 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
2496 <span class="lineno">  171 </span><span class="spaces">      </span><span class="istickedoff">( ( 1/x',    0,    0, 0 ),</span>
2497 <span class="lineno">  172 </span><span class="spaces">        </span><span class="istickedoff">(    0, 1/y',    0, 0 ),</span>
2498 <span class="lineno">  173 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0, 1/z', 0 ),</span>
2499 <span class="lineno">  174 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0,    0, 1 ) ) )</span>
2500 <span class="lineno">  175 </span><span class="spaces">  </span><span class="istickedoff">where x' = nonZero x</span>
2501 <span class="lineno">  176 </span><span class="spaces">        </span><span class="istickedoff">y' = nonZero y</span>
2502 <span class="lineno">  177 </span><span class="spaces">        </span><span class="istickedoff">z' = nonZero z</span></span>
2503 <span class="lineno">  178 </span>
2504 <span class="lineno">  179 </span><span class="decl"><span class="istickedoff">rotxM t</span>
2505 <span class="lineno">  180 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
2506 <span class="lineno">  181 </span><span class="spaces">      </span><span class="istickedoff">( (      1,      0,      0, 0 ),</span>
2507 <span class="lineno">  182 </span><span class="spaces">        </span><span class="istickedoff">(      0,  cos t, -sin t, 0 ),</span>
2508 <span class="lineno">  183 </span><span class="spaces">        </span><span class="istickedoff">(      0,  sin t,  cos t, 0 ),</span>
2509 <span class="lineno">  184 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ),</span>
2510 <span class="lineno">  185 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
2511 <span class="lineno">  186 </span><span class="spaces">      </span><span class="istickedoff">( (      1,      0,      0, 0 ),</span>
2512 <span class="lineno">  187 </span><span class="spaces">        </span><span class="istickedoff">(      0,  cos t,  sin t, 0 ),</span>
2513 <span class="lineno">  188 </span><span class="spaces">        </span><span class="istickedoff">(      0, -sin t,  cos t, 0 ),</span>
2514 <span class="lineno">  189 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ) )</span></span>
2515 <span class="lineno">  190 </span>
2516 <span class="lineno">  191 </span><span class="decl"><span class="istickedoff">rotyM t</span>
2517 <span class="lineno">  192 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
2518 <span class="lineno">  193 </span><span class="spaces">      </span><span class="istickedoff">( (  cos t,      0,  sin t, 0 ),</span>
2519 <span class="lineno">  194 </span><span class="spaces">        </span><span class="istickedoff">(      0,      1,      0, 0 ),</span>
2520 <span class="lineno">  195 </span><span class="spaces">        </span><span class="istickedoff">( -sin t,      0,  cos t, 0 ),</span>
2521 <span class="lineno">  196 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ),</span>
2522 <span class="lineno">  197 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
2523 <span class="lineno">  198 </span><span class="spaces">      </span><span class="istickedoff">( (  cos t,      0, -sin t, 0 ),</span>
2524 <span class="lineno">  199 </span><span class="spaces">        </span><span class="istickedoff">(      0,      1,      0, 0 ),</span>
2525 <span class="lineno">  200 </span><span class="spaces">        </span><span class="istickedoff">(  sin t,      0,  cos t, 0 ),</span>
2526 <span class="lineno">  201 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ) )</span></span>
2527 <span class="lineno">  202 </span>
2528 <span class="lineno">  203 </span><span class="decl"><span class="nottickedoff">rotzM t</span>
2529 <span class="lineno">  204 </span><span class="spaces">  </span><span class="nottickedoff">= ( matrix</span>
2530 <span class="lineno">  205 </span><span class="spaces">      </span><span class="nottickedoff">( (  cos t, -sin t,      0, 0 ),</span>
2531 <span class="lineno">  206 </span><span class="spaces">        </span><span class="nottickedoff">(  sin t,  cos t,      0, 0 ),</span>
2532 <span class="lineno">  207 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      1, 0 ),</span>
2533 <span class="lineno">  208 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      0, 1 ) ),</span>
2534 <span class="lineno">  209 </span><span class="spaces">      </span><span class="nottickedoff">matrix</span>
2535 <span class="lineno">  210 </span><span class="spaces">      </span><span class="nottickedoff">( (  cos t,  sin t,      0, 0 ),</span>
2536 <span class="lineno">  211 </span><span class="spaces">        </span><span class="nottickedoff">( -sin t,  cos t,      0, 0 ),</span>
2537 <span class="lineno">  212 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      1, 0 ),</span>
2538 <span class="lineno">  213 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      0, 1 ) ) )</span></span>
2539 <span class="lineno">  214 </span>
2540 <span class="lineno">  215 </span>-------------------
2541 <span class="lineno">  216 </span>-- Eye transformations
2542 <span class="lineno">  217 </span>
2543 <span class="lineno">  218 </span>-- These are used to specify placement of the eye.
2544 <span class="lineno">  219 </span>-- `eye' starts out at (0, 0, -1).
2545 <span class="lineno">  220 </span>-- These are implemented as inverse transforms of the model.
2546 <span class="lineno">  221 </span>-------------------
2547 <span class="lineno">  222 </span>
2548 <span class="lineno">  223 </span>eye                       :: Transform
2549 <span class="lineno">  224 </span>translateEye          :: Coords -&gt; Transform -&gt; Transform
2550 <span class="lineno">  225 </span>rotateEyeX, rotateEyeY, rotateEyeZ      :: Radian -&gt; Transform -&gt; Transform
2551 <span class="lineno">  226 </span>
2552 <span class="lineno">  227 </span><span class="decl"><span class="istickedoff">eye = (unit, unit)</span></span>
2553 <span class="lineno">  228 </span><span class="decl"><span class="nottickedoff">translateEye xyz (eye1, eye2)</span>
2554 <span class="lineno">  229 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
2555 <span class="lineno">  230 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = transM xyz</span></span>
2556 <span class="lineno">  231 </span><span class="decl"><span class="nottickedoff">rotateEyeX t (eye1, eye2)</span>
2557 <span class="lineno">  232 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
2558 <span class="lineno">  233 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = rotxM t</span></span>
2559 <span class="lineno">  234 </span><span class="decl"><span class="nottickedoff">rotateEyeY t (eye1, eye2)</span>
2560 <span class="lineno">  235 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
2561 <span class="lineno">  236 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = rotyM t</span></span>
2562 <span class="lineno">  237 </span><span class="decl"><span class="nottickedoff">rotateEyeZ t (eye1, eye2)</span>
2563 <span class="lineno">  238 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
2564 <span class="lineno">  239 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = rotzM t</span></span>
2565 <span class="lineno">  240 </span>
2566 <span class="lineno">  241 </span>-------------------
2567 <span class="lineno">  242 </span>-- Bounding boxes
2568 <span class="lineno">  243 </span>-------------------
2569 <span class="lineno">  244 </span>
2570 <span class="lineno">  245 </span><span class="decl"><span class="nottickedoff">mergeBox (B x11  x12  y11  y12  z11  z12) (B x21  x22  y21  y22  z21  z22) =</span>
2571 <span class="lineno">  246 </span><span class="spaces">    </span><span class="nottickedoff">B (x11 `min` x21) (x12 `max` x22)</span>
2572 <span class="lineno">  247 </span><span class="spaces">      </span><span class="nottickedoff">(y11 `min` y21) (y12 `max` y22)</span>
2573 <span class="lineno">  248 </span><span class="spaces">      </span><span class="nottickedoff">(z11 `min` z21) (z12 `max` z22)</span></span>
2574 <span class="lineno">  249 </span>
2575 <span class="lineno">  250 </span><span class="decl"><span class="istickedoff">transformBox t (B x1  x2  y1  y2  z1  z2)</span>
2576 <span class="lineno">  251 </span><span class="spaces">  </span><span class="istickedoff">= (B (foldr1 min (map xCoord pts'))</span>
2577 <span class="lineno">  252 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 max (map xCoord pts'))</span>
2578 <span class="lineno">  253 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 min (map yCoord pts'))</span>
2579 <span class="lineno">  254 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 max (map yCoord pts'))</span>
2580 <span class="lineno">  255 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 min (map zCoord pts'))</span>
2581 <span class="lineno">  256 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 max (map zCoord pts')))</span>
2582 <span class="lineno">  257 </span><span class="spaces">  </span><span class="istickedoff">where pts' = map (multMP t) pts</span>
2583 <span class="lineno">  258 </span><span class="spaces">        </span><span class="istickedoff">pts =  [point x1 y1 z1,</span>
2584 <span class="lineno">  259 </span><span class="spaces">                </span><span class="istickedoff">point x1 y1 z2,</span>
2585 <span class="lineno">  260 </span><span class="spaces">                </span><span class="istickedoff">point x1 y2 z1,</span>
2586 <span class="lineno">  261 </span><span class="spaces">                </span><span class="istickedoff">point x1 y2 z2,</span>
2587 <span class="lineno">  262 </span><span class="spaces">                </span><span class="istickedoff">point x2 y1 z1,</span>
2588 <span class="lineno">  263 </span><span class="spaces">                </span><span class="istickedoff">point x2 y1 z2,</span>
2589 <span class="lineno">  264 </span><span class="spaces">                </span><span class="istickedoff">point x2 y2 z1,</span>
2590 <span class="lineno">  265 </span><span class="spaces">                </span><span class="istickedoff">point x2 y2 z2]</span></span>
2591
2592 </pre>
2593 </html>
2594 Writing: Parse.hs.html
2595 <html><style type="text/css">
2596 span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
2597 span.nottickedoff { background: yellow}
2598 span.istickedoff { background: white }
2599 span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
2600 span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
2601 span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
2602 span.decl { font-weight: bold }
2603 span.spaces    { background: white }
2604 </style>
2605 <pre>
2606 <span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
2607 <span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
2608 <span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
2609 <span class="lineno">    4 </span>-- which is included in the distribution.
2610 <span class="lineno">    5 </span>
2611 <span class="lineno">    6 </span>module Parse where
2612 <span class="lineno">    7 </span>
2613 <span class="lineno">    8 </span>import Char
2614 <span class="lineno">    9 </span>import Text.ParserCombinators.Parsec hiding (token)
2615 <span class="lineno">   10 </span>
2616 <span class="lineno">   11 </span>import Data
2617 <span class="lineno">   12 </span>
2618 <span class="lineno">   13 </span>
2619 <span class="lineno">   14 </span>program :: Parser Code
2620 <span class="lineno">   15 </span><span class="decl"><span class="istickedoff">program =</span>
2621 <span class="lineno">   16 </span><span class="spaces">  </span><span class="istickedoff">do { whiteSpace</span>
2622 <span class="lineno">   17 </span><span class="spaces">     </span><span class="istickedoff">; ts &lt;- tokenList</span>
2623 <span class="lineno">   18 </span><span class="spaces">     </span><span class="istickedoff">; eof</span>
2624 <span class="lineno&q