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