"GOOD MATCH"


 48% expressions used (2292/4715)
 21% boolean coverage (18/83)
      21% guards (12/55), 17 always True, 8 always False, 18 unevaluated
      22% 'if' conditions (6/27), 3 always True, 3 always False, 15 unevaluated
       0% qualifiers (0/1), 1 unevaluated
 38% alternatives used (124/322)
 40% local declarations used (89/218)
 49% top-level declarations used (146/295)


-----<module CSG>-----
100% expressions used (0/0)
100% boolean coverage (0/0)
     100% guards (0/0)
     100% 'if' conditions (0/0)
     100% qualifiers (0/0)
100% alternatives used (0/0)
100% local declarations used (0/0)
100% top-level declarations used (0/0)
-----<module Construct>-----
 60% expressions used (381/635)
100% boolean coverage (0/0)
     100% guards (0/0)
     100% 'if' conditions (0/0)
     100% qualifiers (0/0)
 41% alternatives used (5/12)
100% local declarations used (5/5)
 41% top-level declarations used (17/41)
-----<module Data>-----
 39% expressions used (254/646)
  0% boolean coverage (0/4)
       0% guards (0/4), 1 always True, 3 unevaluated
     100% 'if' conditions (0/0)
     100% qualifiers (0/0)
  3% alternatives used (2/51)
  0% local declarations used (0/2)
 22% top-level declarations used (10/45)
-----<module Eval>-----
 57% expressions used (361/628)
 20% boolean coverage (1/5)
     100% guards (0/0)
      20% 'if' conditions (1/5), 1 always False, 3 unevaluated
     100% qualifiers (0/0)
 59% alternatives used (40/67)
 36% local declarations used (4/11)
 62% top-level declarations used (22/35)
-----<module Geometry>-----
 70% expressions used (300/427)
 10% boolean coverage (1/10)
      10% guards (1/10), 3 always True, 1 always False, 5 unevaluated
     100% 'if' conditions (0/0)
     100% qualifiers (0/0)
 40% alternatives used (4/10)
 66% local declarations used (2/3)
 58% top-level declarations used (42/72)
-----<module Illumination>-----
 44% expressions used (299/678)
 18% boolean coverage (3/16)
      16% guards (2/12), 2 always True, 1 always False, 7 unevaluated
      33% 'if' conditions (1/3), 1 always True, 1 always False
       0% qualifiers (0/1), 1 unevaluated
 38% alternatives used (16/42)
 57% local declarations used (27/47)
 45% top-level declarations used (11/24)
-----<module Intersections>-----
 38% expressions used (382/1001)
 33% boolean coverage (11/33)
      40% guards (8/20), 8 always True, 3 always False, 1 unevaluated
      23% 'if' conditions (3/13), 10 unevaluated
     100% qualifiers (0/0)
 42% alternatives used (35/83)
 36% local declarations used (44/120)
 63% top-level declarations used (14/22)
-----<module Interval>-----
 41% expressions used (69/165)
  8% boolean coverage (1/12)
      11% guards (1/9), 3 always True, 3 always False, 2 unevaluated
       0% 'if' conditions (0/3), 2 always True, 1 unevaluated
     100% qualifiers (0/0)
 39% alternatives used (9/23)
 25% local declarations used (1/4)
 47% top-level declarations used (8/17)
-----<module Main>-----
100% expressions used (6/6)
100% boolean coverage (0/0)
     100% guards (0/0)
     100% 'if' conditions (0/0)
     100% qualifiers (0/0)
100% alternatives used (0/0)
100% local declarations used (0/0)
100% top-level declarations used (1/1)
-----<module Misc>-----
  0% expressions used (0/10)
100% boolean coverage (0/0)
     100% guards (0/0)
     100% 'if' conditions (0/0)
     100% qualifiers (0/0)
100% alternatives used (0/0)
100% local declarations used (0/0)
  0% top-level declarations used (0/1)
-----<module Parse>-----
 72% expressions used (192/264)
 50% boolean coverage (1/2)
     100% guards (0/0)
      50% 'if' conditions (1/2), 1 always False
     100% qualifiers (0/0)
 42% alternatives used (6/14)
100% local declarations used (2/2)
 80% top-level declarations used (16/20)
-----<module Primitives>-----
 20% expressions used (5/24)
100% boolean coverage (0/0)
     100% guards (0/0)
     100% 'if' conditions (0/0)
     100% qualifiers (0/0)
100% alternatives used (0/0)
100% local declarations used (0/0)
 16% top-level declarations used (1/6)
-----<module Surface>-----
 18% expressions used (43/231)
  0% boolean coverage (0/1)
     100% guards (0/0)
       0% 'if' conditions (0/1), 1 unevaluated
     100% qualifiers (0/0)
 35% alternatives used (7/20)
 16% local declarations used (4/24)
 36% top-level declarations used (4/11)


Writing: Main.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>-- Modified to read sample input directly from a file.
<span class="lineno">    7 </span>
<span class="lineno">    8 </span>module Main where
<span class="lineno">    9 </span>
<span class="lineno">   10 </span>import System
<span class="lineno">   11 </span>
<span class="lineno">   12 </span>import Parse
<span class="lineno">   13 </span>import Eval
<span class="lineno">   14 </span>
<span class="lineno">   15 </span><span class="decl"><span class="istickedoff">main = do { str &lt;- readFile &quot;galois.gml&quot;</span>
<span class="lineno">   16 </span><span class="spaces">          </span><span class="istickedoff">; mainEval (rayParse str)</span>
<span class="lineno">   17 </span><span class="spaces">          </span><span class="istickedoff">}</span></span>

</pre>
</html>
Writing: Parse.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Parse where
<span class="lineno">    7 </span>
<span class="lineno">    8 </span>import Char
<span class="lineno">    9 </span>import Text.ParserCombinators.Parsec hiding (token)
<span class="lineno">   10 </span>
<span class="lineno">   11 </span>import Data
<span class="lineno">   12 </span>
<span class="lineno">   13 </span>
<span class="lineno">   14 </span>program :: Parser Code
<span class="lineno">   15 </span><span class="decl"><span class="istickedoff">program =</span>
<span class="lineno">   16 </span><span class="spaces">  </span><span class="istickedoff">do { whiteSpace</span>
<span class="lineno">   17 </span><span class="spaces">     </span><span class="istickedoff">; ts &lt;- tokenList</span>
<span class="lineno">   18 </span><span class="spaces">     </span><span class="istickedoff">; eof</span>
<span class="lineno">   19 </span><span class="spaces">     </span><span class="istickedoff">; return ts</span>
<span class="lineno">   20 </span><span class="spaces">     </span><span class="istickedoff">}</span></span>
<span class="lineno">   21 </span>
<span class="lineno">   22 </span>tokenList :: Parser Code
<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>
<span class="lineno">   24 </span>
<span class="lineno">   25 </span>token :: Parser GMLToken
<span class="lineno">   26 </span><span class="decl"><span class="istickedoff">token =</span>
<span class="lineno">   27 </span><span class="spaces">       </span><span class="istickedoff">do { ts &lt;- braces   tokenList          ; return (TBody ts) } </span>
<span class="lineno">   28 </span><span class="spaces">  </span><span class="istickedoff">&lt;|&gt;  do { ts &lt;- brackets tokenList          ; return (TArray ts) }</span>
<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>
<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>
<span class="lineno">   31 </span><span class="spaces">  </span><span class="istickedoff">&lt;|&gt; (do { char '/'   -- No whitespace after slash</span>
<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>
<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>
<span class="lineno">   34 </span>
<span class="lineno">   35 </span>pident :: Bool -&gt; Parser GMLToken
<span class="lineno">   36 </span><span class="decl"><span class="istickedoff">pident rebind =</span>
<span class="lineno">   37 </span><span class="spaces">  </span><span class="istickedoff">do { id &lt;- ident</span>
<span class="lineno">   38 </span><span class="spaces">     </span><span class="istickedoff">; case (lookup id opTable) of</span>
<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>
<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>
<span class="lineno">   41 </span><span class="spaces">     </span><span class="istickedoff">}</span></span>
<span class="lineno">   42 </span>
<span class="lineno">   43 </span>ident :: Parser String
<span class="lineno">   44 </span><span class="decl"><span class="istickedoff">ident = lexeme $</span>
<span class="lineno">   45 </span><span class="spaces">  </span><span class="istickedoff">do { l &lt;- letter</span>
<span class="lineno">   46 </span><span class="spaces">     </span><span class="istickedoff">; ls &lt;- many (satisfy (\x -&gt; isAlphaNum x || x == '-' || x == '_'))</span>
<span class="lineno">   47 </span><span class="spaces">     </span><span class="istickedoff">; return (l:ls)</span>
<span class="lineno">   48 </span><span class="spaces">     </span><span class="istickedoff">}</span></span>
<span class="lineno">   49 </span>
<span class="lineno">   50 </span>gmlString :: Parser String
<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>
<span class="lineno">   52 </span>
<span class="lineno">   53 </span>-- Tests for numbers
<span class="lineno">   54 </span>-- Hugs breaks on big exponents (&gt; ~40)
<span class="lineno">   55 </span><span class="decl"><span class="nottickedoff">test_number = &quot;1234 -1234 1 -0 0&quot; ++</span>
<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>
<span class="lineno">   57 </span><span class="spaces">              </span><span class="nottickedoff">&quot; -1234.5678e12 -1234.5678E-12 -1234.5678E12&quot; ++</span>
<span class="lineno">   58 </span><span class="spaces">              </span><span class="nottickedoff">&quot; 1234e11 1234E33 -1234e33 1234e-33&quot; ++</span>
<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>
<span class="lineno">   60 </span>              
<span class="lineno">   61 </span>
<span class="lineno">   62 </span>-- Always int or real
<span class="lineno">   63 </span>number :: Parser GMLToken
<span class="lineno">   64 </span><span class="decl"><span class="istickedoff">number = lexeme $</span>
<span class="lineno">   65 </span><span class="spaces">  </span><span class="istickedoff">do { s &lt;- optSign</span>
<span class="lineno">   66 </span><span class="spaces">     </span><span class="istickedoff">; n &lt;- decimal</span>
<span class="lineno">   67 </span><span class="spaces">     </span><span class="istickedoff">;     do { string &quot;.&quot;</span>
<span class="lineno">   68 </span><span class="spaces">              </span><span class="istickedoff">; m &lt;- decimal</span>
<span class="lineno">   69 </span><span class="spaces">              </span><span class="istickedoff">; e &lt;- option &quot;&quot; exponent'</span>
<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>
<span class="lineno">   71 </span><span class="spaces">              </span><span class="istickedoff">}</span>
<span class="lineno">   72 </span><span class="spaces">       </span><span class="istickedoff">&lt;|&gt; do { e &lt;- exponent'</span>
<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>
<span class="lineno">   74 </span><span class="spaces">              </span><span class="istickedoff">}</span>
<span class="lineno">   75 </span><span class="spaces">       </span><span class="istickedoff">&lt;|&gt; do { return (TInt (read (s ++ n))) }</span>
<span class="lineno">   76 </span><span class="spaces">     </span><span class="istickedoff">}</span></span>
<span class="lineno">   77 </span>
<span class="lineno">   78 </span>exponent' :: Parser String
<span class="lineno">   79 </span><span class="decl"><span class="istickedoff">exponent' = try $</span>
<span class="lineno">   80 </span><span class="spaces">  </span><span class="istickedoff">do { e &lt;- oneOf &quot;eE&quot;</span>
<span class="lineno">   81 </span><span class="spaces">     </span><span class="istickedoff">; s &lt;- <span class="nottickedoff">optSign</span></span>
<span class="lineno">   82 </span><span class="spaces">     </span><span class="istickedoff">; n &lt;- <span class="nottickedoff">decimal</span></span>
<span class="lineno">   83 </span><span class="spaces">     </span><span class="istickedoff">; <span class="nottickedoff">return (e:s ++ n)</span></span>
<span class="lineno">   84 </span><span class="spaces">     </span><span class="istickedoff">}</span></span>
<span class="lineno">   85 </span>
<span class="lineno">   86 </span><span class="decl"><span class="istickedoff">decimal = many1 digit</span></span>
<span class="lineno">   87 </span>
<span class="lineno">   88 </span>optSign :: Parser String
<span class="lineno">   89 </span><span class="decl"><span class="istickedoff">optSign = option &quot;&quot; (string &quot;-&quot;)</span></span>
<span class="lineno">   90 </span>
<span class="lineno">   91 </span>
<span class="lineno">   92 </span>------------------------------------------------------
<span class="lineno">   93 </span>-- Library for tokenizing.
<span class="lineno">   94 </span>
<span class="lineno">   95 </span><span class="decl"><span class="istickedoff">braces   p = between (symbol &quot;{&quot;) (symbol &quot;}&quot;) p</span></span>
<span class="lineno">   96 </span><span class="decl"><span class="istickedoff">brackets p = between (symbol &quot;[&quot;) (symbol &quot;]&quot;) p</span></span>
<span class="lineno">   97 </span>
<span class="lineno">   98 </span><span class="decl"><span class="istickedoff">symbol name = lexeme (string name)</span></span>
<span class="lineno">   99 </span>
<span class="lineno">  100 </span><span class="decl"><span class="istickedoff">lexeme p = do{ x &lt;- p; whiteSpace; return x  }</span></span>
<span class="lineno">  101 </span>
<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>
<span class="lineno">  103 </span><span class="spaces">  </span><span class="istickedoff">where simpleSpace = skipMany1 (oneOf &quot; \t\n\r\v&quot;)    </span>
<span class="lineno">  104 </span><span class="spaces">        </span><span class="istickedoff">oneLineComment =</span>
<span class="lineno">  105 </span><span class="spaces">            </span><span class="istickedoff">do{ string &quot;%&quot;</span>
<span class="lineno">  106 </span><span class="spaces">              </span><span class="istickedoff">; skipMany (noneOf &quot;\n\r\v&quot;)</span>
<span class="lineno">  107 </span><span class="spaces">              </span><span class="istickedoff">; return ()</span>
<span class="lineno">  108 </span><span class="spaces">              </span><span class="istickedoff">}</span></span>
<span class="lineno">  109 </span>
<span class="lineno">  110 </span>
<span class="lineno">  111 </span>------------------------------------------------------------------------------
<span class="lineno">  112 </span>
<span class="lineno">  113 </span>rayParse :: String -&gt; Code
<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>
<span class="lineno">  115 </span><span class="spaces">              </span><span class="istickedoff">Left err -&gt; <span class="nottickedoff">error (show err)</span></span>
<span class="lineno">  116 </span><span class="spaces">              </span><span class="istickedoff">Right x  -&gt; x</span></span>
<span class="lineno">  117 </span>
<span class="lineno">  118 </span>rayParseF :: String -&gt; IO Code
<span class="lineno">  119 </span><span class="decl"><span class="nottickedoff">rayParseF file =</span>
<span class="lineno">  120 </span><span class="spaces">  </span><span class="nottickedoff">do { r &lt;- parseFromFile program file</span>
<span class="lineno">  121 </span><span class="spaces">     </span><span class="nottickedoff">; case r of</span>
<span class="lineno">  122 </span><span class="spaces">       </span><span class="nottickedoff">Left err -&gt; error (show err)</span>
<span class="lineno">  123 </span><span class="spaces">       </span><span class="nottickedoff">Right x  -&gt; return x</span>
<span class="lineno">  124 </span><span class="spaces">     </span><span class="nottickedoff">}</span></span>
<span class="lineno">  125 </span>
<span class="lineno">  126 </span>run :: String -&gt; IO ()
<span class="lineno">  127 </span><span class="decl"><span class="nottickedoff">run is = case (parse program &quot;&quot; is) of</span>
<span class="lineno">  128 </span><span class="spaces">         </span><span class="nottickedoff">Left err -&gt; print err</span>
<span class="lineno">  129 </span><span class="spaces">         </span><span class="nottickedoff">Right x  -&gt; print x</span></span>
<span class="lineno">  130 </span>
<span class="lineno">  131 </span>runF :: IO ()
<span class="lineno">  132 </span><span class="decl"><span class="nottickedoff">runF =</span>
<span class="lineno">  133 </span><span class="spaces">  </span><span class="nottickedoff">do { r &lt;- parseFromFile program &quot;simple.gml&quot;</span>
<span class="lineno">  134 </span><span class="spaces">     </span><span class="nottickedoff">; case r of</span>
<span class="lineno">  135 </span><span class="spaces">       </span><span class="nottickedoff">Left err -&gt; print err</span>
<span class="lineno">  136 </span><span class="spaces">       </span><span class="nottickedoff">Right x  -&gt; print x</span>
<span class="lineno">  137 </span><span class="spaces">     </span><span class="nottickedoff">}</span></span>

</pre>
</html>
Writing: Data.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Data where
<span class="lineno">    7 </span>
<span class="lineno">    8 </span>import Array
<span class="lineno">    9 </span>
<span class="lineno">   10 </span>import CSG      
<span class="lineno">   11 </span>import Geometry
<span class="lineno">   12 </span>import Illumination
<span class="lineno">   13 </span>import Primitives
<span class="lineno">   14 </span>import Surface
<span class="lineno">   15 </span>
<span class="lineno">   16 </span>import Debug.Trace
<span class="lineno">   17 </span>
<span class="lineno">   18 </span>-- Now the parsed (expresssion) language
<span class="lineno">   19 </span>
<span class="lineno">   20 </span>type Name = String
<span class="lineno">   21 </span>
<span class="lineno">   22 </span>type Code = [GMLToken]
<span class="lineno">   23 </span>
<span class="lineno">   24 </span>data GMLToken
<span class="lineno">   25 </span>    -- All these can occur in parsed code
<span class="lineno">   26 </span>        = TOp     GMLOp
<span class="lineno">   27 </span>        | TId     Name
<span class="lineno">   28 </span>        | TBind   Name
<span class="lineno">   29 </span>        | TBool   Bool
<span class="lineno">   30 </span>        | TInt    Int
<span class="lineno">   31 </span>        | TReal   Double
<span class="lineno">   32 </span>        | TString String
<span class="lineno">   33 </span>        | TBody   Code
<span class="lineno">   34 </span>        | TArray  Code
<span class="lineno">   35 </span>        | TApply
<span class="lineno">   36 </span>        | TIf
<span class="lineno">   37 </span>         -- These can occur in optimized/transformed code
<span class="lineno">   38 </span>         -- NONE (yet!)
<span class="lineno">   39 </span>
<span class="lineno">   40 </span>
<span class="lineno">   41 </span>instance Show GMLToken where
<span class="lineno">   42 </span>   <span class="decl"><span class="nottickedoff">showsPrec p (TOp op)     = shows op</span>
<span class="lineno">   43 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TId id)     = showString id</span>
<span class="lineno">   44 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TBind id)   = showString ('/' : id)</span>
<span class="lineno">   45 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TBool bool) = shows bool</span>
<span class="lineno">   46 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TInt i)     = shows i</span>
<span class="lineno">   47 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TReal d)    = shows d</span>
<span class="lineno">   48 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TString s)  = shows s</span>
<span class="lineno">   49 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TBody code) = shows code</span>
<span class="lineno">   50 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TArray code) = showString &quot;[ &quot; </span>
<span class="lineno">   51 </span><span class="spaces">                            </span><span class="nottickedoff">. foldr (\ a b -&gt; a . showChar ' ' . b) id (map shows code) </span>
<span class="lineno">   52 </span><span class="spaces">                            </span><span class="nottickedoff">. showString &quot;]&quot;</span>
<span class="lineno">   53 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TApply)     = showString &quot;apply&quot; </span>
<span class="lineno">   54 </span><span class="spaces">   </span><span class="nottickedoff">showsPrec p (TIf)        = showString &quot;if&quot;</span></span> 
<span class="lineno">   55 </span>
<span class="lineno">   56 </span>   <span class="decl"><span class="nottickedoff">showList  code = showString &quot;{ &quot; </span>
<span class="lineno">   57 </span><span class="spaces">                  </span><span class="nottickedoff">. foldr (\ a b -&gt; a . showChar ' ' . b) id (map shows code) </span>
<span class="lineno">   58 </span><span class="spaces">                  </span><span class="nottickedoff">. showString &quot;}&quot;</span></span>
<span class="lineno">   59 </span>
<span class="lineno">   60 </span>
<span class="lineno">   61 </span>-- Now the value language, used inside the interpreter
<span class="lineno">   62 </span>
<span class="lineno">   63 </span>type Stack = [GMLValue]
<span class="lineno">   64 </span>
<span class="lineno">   65 </span>data GMLValue
<span class="lineno">   66 </span>        = VBool    !Bool
<span class="lineno">   67 </span>        | VInt     !Int
<span class="lineno">   68 </span>        | VReal    !Double
<span class="lineno">   69 </span>        | VString  String
<span class="lineno">   70 </span>        | VClosure Env Code
<span class="lineno">   71 </span>        | VArray   (Array Int GMLValue)               -- FIXME: Haskell array
<span class="lineno">   72 </span>        -- uses the interpreter version of point
<span class="lineno">   73 </span>        | VPoint   { xPoint :: !Double
<span class="lineno">   74 </span>                   , yPoint :: !Double 
<span class="lineno">   75 </span>                   , zPoint :: !Double 
<span class="lineno">   76 </span>                   } 
<span class="lineno">   77 </span>        -- these are abstract to the interpreter
<span class="lineno">   78 </span>        | VObject  Object
<span class="lineno">   79 </span>        | VLight   Light 
<span class="lineno">   80 </span>        -- This is an abstract object, used by the abstract interpreter
<span class="lineno">   81 </span>        | VAbsObj  AbsObj
<span class="lineno">   82 </span>
<span class="lineno">   83 </span>
<span class="lineno">   84 </span>-- There are only *3* basic abstract values,
<span class="lineno">   85 </span>-- and the combinators also.
<span class="lineno">   86 </span>
<span class="lineno">   87 </span>data AbsObj 
<span class="lineno">   88 </span>    = AbsFACE 
<span class="lineno">   89 </span>    | AbsU 
<span class="lineno">   90 </span>    | AbsV
<span class="lineno">   91 </span>      deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
<span class="lineno">   92 </span>
<span class="lineno">   93 </span>instance Show GMLValue where
<span class="lineno">   94 </span>   <span class="decl"><span class="nottickedoff">showsPrec p value = showString (showStkEle value)</span></span>
<span class="lineno">   95 </span>
<span class="lineno">   96 </span>showStkEle :: GMLValue -&gt; String
<span class="lineno">   97 </span><span class="decl"><span class="nottickedoff">showStkEle (VBool b)      = show b ++ &quot; :: Bool&quot;</span>
<span class="lineno">   98 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VInt i)       = show i ++ &quot; :: Int&quot;</span>
<span class="lineno">   99 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VReal r)      = show r ++ &quot; :: Real&quot;</span>
<span class="lineno">  100 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VString s)    = show s ++ &quot; :: String&quot;</span>
<span class="lineno">  101 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VClosure {})  = &quot;&lt;closure&gt; :: Closure&quot;</span>
<span class="lineno">  102 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VArray arr)   </span>
<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>
<span class="lineno">  104 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VPoint x y z) = &quot;(&quot; ++ show x </span>
<span class="lineno">  105 </span><span class="spaces">                         </span><span class="nottickedoff">++ &quot;,&quot; ++ show y</span>
<span class="lineno">  106 </span><span class="spaces">                         </span><span class="nottickedoff">++ &quot;,&quot; ++ show z</span>
<span class="lineno">  107 </span><span class="spaces">                         </span><span class="nottickedoff">++ &quot;) :: Point&quot;</span>
<span class="lineno">  108 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VObject {})   = &quot;&lt;Object&gt; :: Object&quot;</span>
<span class="lineno">  109 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VLight {})    = &quot;&lt;Light&gt; :: Object&quot;</span>
<span class="lineno">  110 </span><span class="spaces"></span><span class="nottickedoff">showStkEle (VAbsObj vobs) = &quot;{{ &quot; ++ show vobs ++ &quot;}} :: AbsObj&quot;</span></span>
<span class="lineno">  111 </span>
<span class="lineno">  112 </span>-- An abstract environment
<span class="lineno">  113 </span>
<span class="lineno">  114 </span>newtype Env = Env [(Name, GMLValue)] deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
<span class="lineno">  115 </span>
<span class="lineno">  116 </span>emptyEnv :: Env
<span class="lineno">  117 </span><span class="decl"><span class="nottickedoff">emptyEnv = Env []</span></span>
<span class="lineno">  118 </span>
<span class="lineno">  119 </span>extendEnv :: Env -&gt; Name -&gt; GMLValue -&gt; Env
<span class="lineno">  120 </span><span class="decl"><span class="istickedoff">extendEnv (Env e) n v = Env ((n, v):e)</span></span>
<span class="lineno">  121 </span>
<span class="lineno">  122 </span>lookupEnv :: Env -&gt; Name -&gt; Maybe GMLValue
<span class="lineno">  123 </span><span class="decl"><span class="istickedoff">lookupEnv (Env e) n = lookup n e</span></span>
<span class="lineno">  124 </span>
<span class="lineno">  125 </span>-- All primitive operators
<span class="lineno">  126 </span>-- 
<span class="lineno">  127 </span>-- There is no Op_apply, Op_false, Op_true and Op_if
<span class="lineno">  128 </span>-- (because they appear explcitly in the rules).
<span class="lineno">  129 </span>
<span class="lineno">  130 </span>data GMLOp
<span class="lineno">  131 </span>   = Op_acos
<span class="lineno">  132 </span>   | Op_addi
<span class="lineno">  133 </span>   | Op_addf
<span class="lineno">  134 </span>   | Op_asin
<span class="lineno">  135 </span>   | Op_clampf
<span class="lineno">  136 </span>   | Op_cone
<span class="lineno">  137 </span>   | Op_cos
<span class="lineno">  138 </span>   | Op_cube
<span class="lineno">  139 </span>   | Op_cylinder
<span class="lineno">  140 </span>   | Op_difference
<span class="lineno">  141 </span>   | Op_divi
<span class="lineno">  142 </span>   | Op_divf
<span class="lineno">  143 </span>   | Op_eqi
<span class="lineno">  144 </span>   | Op_eqf
<span class="lineno">  145 </span>   | Op_floor
<span class="lineno">  146 </span>   | Op_frac
<span class="lineno">  147 </span>   | Op_get
<span class="lineno">  148 </span>   | Op_getx
<span class="lineno">  149 </span>   | Op_gety
<span class="lineno">  150 </span>   | Op_getz
<span class="lineno">  151 </span>   | Op_intersect
<span class="lineno">  152 </span>   | Op_length
<span class="lineno">  153 </span>   | Op_lessi
<span class="lineno">  154 </span>   | Op_lessf
<span class="lineno">  155 </span>   | Op_light
<span class="lineno">  156 </span>   | Op_modi
<span class="lineno">  157 </span>   | Op_muli
<span class="lineno">  158 </span>   | Op_mulf
<span class="lineno">  159 </span>   | Op_negi
<span class="lineno">  160 </span>   | Op_negf
<span class="lineno">  161 </span>   | Op_plane
<span class="lineno">  162 </span>   | Op_point
<span class="lineno">  163 </span>   | Op_pointlight
<span class="lineno">  164 </span>   | Op_real
<span class="lineno">  165 </span>   | Op_render
<span class="lineno">  166 </span>   | Op_rotatex
<span class="lineno">  167 </span>   | Op_rotatey
<span class="lineno">  168 </span>   | Op_rotatez
<span class="lineno">  169 </span>   | Op_scale
<span class="lineno">  170 </span>   | Op_sin
<span class="lineno">  171 </span>   | Op_sphere
<span class="lineno">  172 </span>   | Op_spotlight
<span class="lineno">  173 </span>   | Op_sqrt
<span class="lineno">  174 </span>   | Op_subi
<span class="lineno">  175 </span>   | Op_subf
<span class="lineno">  176 </span>   | Op_trace       -- non standard, for debugging GML programs
<span class="lineno">  177 </span>   | Op_translate
<span class="lineno">  178 </span>   | Op_union
<span class="lineno">  179 </span>   | Op_uscale
<span class="lineno">  180 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>,<span class="nottickedoff"><span class="decl"><span class="nottickedoff">Ord</span></span></span>,<span class="decl"><span class="nottickedoff"><span class="decl"><span class="istickedoff"><span class="decl"><span class="istickedoff">Ix</span></span></span></span></span></span>,<span class="decl"><span class="istickedoff"><span class="decl"><span class="istickedoff">Bounded</span></span></span></span>)
<span class="lineno">  181 </span>
<span class="lineno">  182 </span>instance Show GMLOp where
<span class="lineno">  183 </span>   <span class="decl"><span class="nottickedoff">showsPrec _ op = showString (opNameTable ! op)</span></span>
<span class="lineno">  184 </span>
<span class="lineno">  185 </span>
<span class="lineno">  186 </span>------------------------------------------------------------------------------
<span class="lineno">  187 </span>
<span class="lineno">  188 </span>-- And how we use the op codes (there names, there interface)
<span class="lineno">  189 </span>
<span class="lineno">  190 </span>-- These keywords include, &quot;apply&quot;, &quot;if&quot;, &quot;true&quot; and &quot;false&quot;,
<span class="lineno">  191 </span>-- they are not parsed as operators, but are
<span class="lineno">  192 </span>-- captured by the parser as a special case.
<span class="lineno">  193 </span>
<span class="lineno">  194 </span>keyWords :: [String]
<span class="lineno">  195 </span><span class="decl"><span class="nottickedoff">keyWords = [ kwd | (kwd,_,_) &lt;- opcodes ]</span></span>
<span class="lineno">  196 </span>
<span class="lineno">  197 </span>-- Lookup has to look from the start (or else...)
<span class="lineno">  198 </span>opTable :: [(Name,GMLToken)]
<span class="lineno">  199 </span><span class="decl"><span class="istickedoff">opTable = [ (kwd,op) | (kwd,op,_) &lt;- opcodes ]</span></span>
<span class="lineno">  200 </span>
<span class="lineno">  201 </span>opNameTable :: Array GMLOp Name
<span class="lineno">  202 </span><span class="decl"><span class="nottickedoff">opNameTable = array (minBound,maxBound) </span>
<span class="lineno">  203 </span><span class="spaces">                  </span><span class="nottickedoff">[ (op,name) | (name,TOp op,_) &lt;- opcodes ]</span></span>
<span class="lineno">  204 </span>
<span class="lineno">  205 </span><span class="decl"><span class="nottickedoff">undef = error &quot;undefined function&quot;</span></span>
<span class="lineno">  206 </span><span class="decl"><span class="nottickedoff">image = error &quot;undefined function: talk to image group&quot;</span></span>
<span class="lineno">  207 </span>
<span class="lineno">  208 </span>-- typically, its best to have *one* opcode table,
<span class="lineno">  209 </span>-- so that mis-alignments do not happen.
<span class="lineno">  210 </span>
<span class="lineno">  211 </span>opcodes :: [(String,GMLToken,PrimOp)]
<span class="lineno">  212 </span><span class="decl"><span class="istickedoff">opcodes =</span>
<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>
<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>
<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>
<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>
<span class="lineno">  217 </span><span class="spaces"> </span><span class="istickedoff">] ++ map (\ (a,b,c) -&gt; (a,TOp b,c))</span>
<span class="lineno">  218 </span><span class="spaces">   </span><span class="istickedoff">-- These are just invocation, any coersions need to occur between here</span>
<span class="lineno">  219 </span><span class="spaces">   </span><span class="istickedoff">-- and before arriving at the application code (like deg -&gt; rad).</span>
<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>
<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>
<span class="lineno">  222 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;addf&quot;,       Op_addf,   Real_Real_Real (+))</span>
<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>
<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>
<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>
<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>
<span class="lineno">  227 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;cube&quot;,       Op_cube,   Surface_Obj cube)</span>
<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>
<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>
<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>
<span class="lineno">  231 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;divf&quot;,       Op_divf,   Real_Real_Real (/))</span>
<span class="lineno">  232 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;eqi&quot;,        Op_eqi,     Int_Int_Bool (==))</span>
<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>
<span class="lineno">  234 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;floor&quot;,      Op_floor,         Real_Int floor)</span>
<span class="lineno">  235 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;frac&quot;,       Op_frac,   Real_Real (snd . properFraction))</span>
<span class="lineno">  236 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;get&quot;,        Op_get,     Arr_Int_Value ixGet)</span>
<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>
<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>
<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>
<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>
<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>
<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>
<span class="lineno">  243 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;lessf&quot;,      Op_lessf,         Real_Real_Bool (&lt;))</span>
<span class="lineno">  244 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;light&quot;,      Op_light,         Point_Color_Light light)</span>
<span class="lineno">  245 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;modi&quot;,       Op_modi,   Int_Int_Int (ourRem))</span>
<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>
<span class="lineno">  247 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;mulf&quot;,       Op_mulf,   Real_Real_Real (*))</span>
<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>
<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>
<span class="lineno">  250 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;plane&quot;,      Op_plane,         Surface_Obj plane)</span>
<span class="lineno">  251 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;point&quot;,      Op_point,         Real_Real_Real_Point VPoint)</span>
<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>
<span class="lineno">  253 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;real&quot;,       Op_real,   Int_Real fromIntegral)</span>
<span class="lineno">  254 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;render&quot;,     Op_render,       Render $ render eye)</span>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<span class="lineno">  267 </span><span class="spaces"> </span><span class="istickedoff">, (&quot;union&quot;,      Op_union,         Obj_Obj_Obj union)</span>
<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>
<span class="lineno">  269 </span><span class="spaces"> </span><span class="istickedoff">]</span></span>
<span class="lineno">  270 </span>
<span class="lineno">  271 </span>-- This enumerate all possible ways of calling the fixed primitives
<span class="lineno">  272 </span>
<span class="lineno">  273 </span>-- The datatype captures the type at the *interp* level,
<span class="lineno">  274 </span>-- the type of the functional is mirrored on this (using Haskell types).
<span class="lineno">  275 </span>
<span class="lineno">  276 </span>data PrimOp
<span class="lineno">  277 </span>
<span class="lineno">  278 </span>    -- 1 argument 
<span class="lineno">  279 </span>    = Int_Int         (Int -&gt; Int)
<span class="lineno">  280 </span>    | Real_Real       (Double -&gt; Double)
<span class="lineno">  281 </span>    | Point_Real      (Double -&gt; Double -&gt; Double -&gt; Double)
<span class="lineno">  282 </span>    | Surface_Obj     (SurfaceFn Color Double -&gt; Object)
<span class="lineno">  283 </span>    | Real_Int        (Double -&gt; Int)
<span class="lineno">  284 </span>    | Int_Real        (Int -&gt; Double)
<span class="lineno">  285 </span>    | Arr_Int         (Array Int GMLValue -&gt; Int)
<span class="lineno">  286 </span>
<span class="lineno">  287 </span>    -- 2 arguments 
<span class="lineno">  288 </span>    | Int_Int_Int     (Int -&gt; Int -&gt; Int)
<span class="lineno">  289 </span>    | Int_Int_Bool    (Int -&gt; Int -&gt; Bool)
<span class="lineno">  290 </span>    | Real_Real_Real  (Double -&gt; Double -&gt; Double)
<span class="lineno">  291 </span>    | Real_Real_Bool  (Double -&gt; Double -&gt; Bool)
<span class="lineno">  292 </span>    | Arr_Int_Value   (Array Int GMLValue -&gt; Int -&gt; GMLValue)
<span class="lineno">  293 </span>
<span class="lineno">  294 </span>    -- Many arguments, typically image mangling
<span class="lineno">  295 </span>
<span class="lineno">  296 </span>    | Obj_Obj_Obj            (Object -&gt; Object -&gt; Object)
<span class="lineno">  297 </span>    | Point_Color_Light      (Coords -&gt; Color -&gt; Light)
<span class="lineno">  298 </span>    | Real_Real_Real_Point   (Double -&gt; Double -&gt; Double -&gt; GMLValue)
<span class="lineno">  299 </span>    | Obj_Real_Obj           (Object -&gt; Double -&gt; Object)
<span class="lineno">  300 </span>    | Obj_Real_Real_Real_Obj (Object -&gt; Double -&gt; Double -&gt; Double -&gt; Object)
<span class="lineno">  301 </span>    | Value_String_Value     (GMLValue -&gt; String -&gt; GMLValue)
<span class="lineno">  302 </span>
<span class="lineno">  303 </span>    | Point_Point_Color_Real_Real_Light 
<span class="lineno">  304 </span>                             (Coords -&gt; Coords -&gt; Color -&gt; Radian -&gt; Radian -&gt; Light)
<span class="lineno">  305 </span>    -- And finally render
<span class="lineno">  306 </span>    | Render                 (Color -&gt; [Light] -&gt; Object -&gt; Int -&gt; Double -&gt; Int -&gt; Int -&gt; String -&gt; IO ())
<span class="lineno">  307 </span>
<span class="lineno">  308 </span>data Type 
<span class="lineno">  309 </span>    = TyBool 
<span class="lineno">  310 </span>    | TyInt 
<span class="lineno">  311 </span>    | TyReal 
<span class="lineno">  312 </span>    | TyString 
<span class="lineno">  313 </span>    | TyCode 
<span class="lineno">  314 </span>    | TyArray 
<span class="lineno">  315 </span>    | TyPoint 
<span class="lineno">  316 </span>    | TyObject 
<span class="lineno">  317 </span>    | TyLight
<span class="lineno">  318 </span>    | TyAlpha
<span class="lineno">  319 </span>    | TyAbsObj
<span class="lineno">  320 </span>      deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>,<span class="nottickedoff"><span class="decl"><span class="nottickedoff">Ord</span></span></span>,<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Ix</span></span></span></span></span></span>,<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Bounded</span></span></span></span>)
<span class="lineno">  321 </span>
<span class="lineno">  322 </span><span class="decl"><span class="nottickedoff">typeTable = </span>
<span class="lineno">  323 </span><span class="spaces">  </span><span class="nottickedoff">[ ( TyBool,   &quot;Bool&quot;)</span>
<span class="lineno">  324 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyInt,    &quot;Int&quot;)</span>
<span class="lineno">  325 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyReal,   &quot;Real&quot;)</span>
<span class="lineno">  326 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyString, &quot;String&quot;)</span>
<span class="lineno">  327 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyCode,   &quot;Code&quot;)</span>
<span class="lineno">  328 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyArray,  &quot;Array&quot;)</span>
<span class="lineno">  329 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyPoint,  &quot;Point&quot;)</span>
<span class="lineno">  330 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyObject, &quot;Object&quot;)</span>
<span class="lineno">  331 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyLight,  &quot;Light&quot;)</span>
<span class="lineno">  332 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyAlpha,  &quot;&lt;anything&gt;&quot;)</span>
<span class="lineno">  333 </span><span class="spaces">  </span><span class="nottickedoff">, ( TyAbsObj, &quot;&lt;abs&gt;&quot;)</span>
<span class="lineno">  334 </span><span class="spaces">  </span><span class="nottickedoff">]</span></span>
<span class="lineno">  335 </span>
<span class="lineno">  336 </span><span class="decl"><span class="nottickedoff">typeNames = array (minBound,maxBound) typeTable</span></span>
<span class="lineno">  337 </span>
<span class="lineno">  338 </span>instance Show Type where
<span class="lineno">  339 </span>   <span class="decl"><span class="nottickedoff">showsPrec _ op = showString (typeNames ! op)</span></span>
<span class="lineno">  340 </span>
<span class="lineno">  341 </span>getPrimOpType :: PrimOp -&gt; [Type]
<span class="lineno">  342 </span><span class="decl"><span class="nottickedoff">getPrimOpType (Int_Int         _) = [TyInt]</span>
<span class="lineno">  343 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real       _) = [TyReal]</span>
<span class="lineno">  344 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Point_Real      _) = [TyPoint]</span>
<span class="lineno">  345 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Surface_Obj     _) = [TyCode]</span>
<span class="lineno">  346 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Int        _) = [TyReal]</span>
<span class="lineno">  347 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Int_Real        _) = [TyInt]</span>
<span class="lineno">  348 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Arr_Int         _) = [TyArray]</span>
<span class="lineno">  349 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Int_Int_Int     _) = [TyInt,TyInt]</span>
<span class="lineno">  350 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Int_Int_Bool    _) = [TyInt,TyInt]</span>
<span class="lineno">  351 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real_Real  _) = [TyReal,TyReal]</span>
<span class="lineno">  352 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real_Bool  _) = [TyReal,TyReal]</span>
<span class="lineno">  353 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Arr_Int_Value   _) = [TyArray,TyInt]</span>
<span class="lineno">  354 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Obj_Obj_Obj            _) = [TyObject,TyObject]</span>
<span class="lineno">  355 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Point_Color_Light      _) = [TyPoint,TyPoint]</span>
<span class="lineno">  356 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Real_Real_Real_Point   _) = [TyReal,TyReal,TyReal]</span>
<span class="lineno">  357 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Obj_Real_Obj           _) = [TyObject,TyReal]</span>
<span class="lineno">  358 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Obj_Real_Real_Real_Obj _) = [TyObject,TyReal,TyReal,TyReal]</span>
<span class="lineno">  359 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Value_String_Value     _) = [TyAlpha,TyString]</span>
<span class="lineno">  360 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Point_Point_Color_Real_Real_Light _) </span>
<span class="lineno">  361 </span><span class="spaces">                                         </span><span class="nottickedoff">= [TyPoint,TyPoint,TyPoint,TyReal,TyReal]</span>
<span class="lineno">  362 </span><span class="spaces"></span><span class="nottickedoff">getPrimOpType (Render                 _) = [TyPoint,</span>
<span class="lineno">  363 </span><span class="spaces">                                            </span><span class="nottickedoff">TyLight,</span>
<span class="lineno">  364 </span><span class="spaces">                                            </span><span class="nottickedoff">TyObject,</span>
<span class="lineno">  365 </span><span class="spaces">                                            </span><span class="nottickedoff">TyInt,</span>
<span class="lineno">  366 </span><span class="spaces">                                            </span><span class="nottickedoff">TyReal,</span>
<span class="lineno">  367 </span><span class="spaces">                                            </span><span class="nottickedoff">TyReal,</span>
<span class="lineno">  368 </span><span class="spaces">                                            </span><span class="nottickedoff">TyReal,</span>
<span class="lineno">  369 </span><span class="spaces">                                            </span><span class="nottickedoff">TyString]</span></span>
<span class="lineno">  370 </span>
<span class="lineno">  371 </span>
<span class="lineno">  372 </span>-- Some primitives with better error message
<span class="lineno">  373 </span>
<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>
<span class="lineno">  375 </span>
<span class="lineno">  376 </span>
<span class="lineno">  377 </span>ixGet :: Array Int GMLValue -&gt; Int -&gt; GMLValue
<span class="lineno">  378 </span><span class="decl"><span class="istickedoff">ixGet arr i</span>
<span class="lineno">  379 </span><span class="spaces">   </span><span class="istickedoff">| <span class="tickonlytrue">inRange (bounds arr) i</span> = arr ! i</span>
<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>
<span class="lineno">  381 </span><span class="spaces">                     </span><span class="istickedoff"><span class="nottickedoff">++ show i </span></span>
<span class="lineno">  382 </span><span class="spaces">                     </span><span class="istickedoff"><span class="nottickedoff">++ &quot; (should be between 0 and &quot; </span></span>
<span class="lineno">  383 </span><span class="spaces">                     </span><span class="istickedoff"><span class="nottickedoff">++ show (snd (bounds arr)) ++ &quot;)&quot;)</span></span></span>
<span class="lineno">  384 </span>
<span class="lineno">  385 </span>ourQuot :: Int -&gt; Int -&gt; Int
<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>
<span class="lineno">  387 </span><span class="spaces"></span><span class="nottickedoff">ourQuot a b = a `quot` b</span></span>
<span class="lineno">  388 </span>
<span class="lineno">  389 </span>ourRem :: Int -&gt; Int -&gt; Int
<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>
<span class="lineno">  391 </span><span class="spaces"></span><span class="istickedoff">ourRem a b = a `rem` b</span></span>
<span class="lineno">  392 </span>
<span class="lineno">  393 </span>ourSqrt :: Double -&gt; Double
<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>
<span class="lineno">  395 </span><span class="spaces">          </span><span class="nottickedoff">| otherwise = sqrt n</span></span>
<span class="lineno">  396 </span>
<span class="lineno">  397 </span>
<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>
<span class="lineno">  399 </span>
<span class="lineno">  400 </span>-- The problem specification gets the mapping for spheres backwards
<span class="lineno">  401 </span>-- (it maps the image from right to left).
<span class="lineno">  402 </span>-- We've fixed that in the raytracing library so that it goes from left
<span class="lineno">  403 </span>-- to right, but to keep the GML front compatible with the problem
<span class="lineno">  404 </span>-- statement, we reverse it here.
<span class="lineno">  405 </span>
<span class="lineno">  406 </span>sphere' :: SurfaceFn Color Double -&gt; CSG (SurfaceFn Color Double)
<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>
<span class="lineno">  408 </span><span class="spaces"></span><span class="nottickedoff">sphere' s = sphere s</span></span>

</pre>
</html>
Writing: Illumination.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>-- Modified to use stdout (for testing)
<span class="lineno">    7 </span>
<span class="lineno">    8 </span>module Illumination
<span class="lineno">    9 </span>    ( Object
<span class="lineno">   10 </span>    , Light (..)
<span class="lineno">   11 </span>    , light, pointlight, spotlight
<span class="lineno">   12 </span>    , render
<span class="lineno">   13 </span>    ) where
<span class="lineno">   14 </span>
<span class="lineno">   15 </span>import Array
<span class="lineno">   16 </span>import Char(chr)
<span class="lineno">   17 </span>import Maybe
<span class="lineno">   18 </span>
<span class="lineno">   19 </span>import Geometry
<span class="lineno">   20 </span>import CSG
<span class="lineno">   21 </span>import Surface
<span class="lineno">   22 </span>import Misc
<span class="lineno">   23 </span>
<span class="lineno">   24 </span>type Object = CSG (SurfaceFn Color Double)
<span class="lineno">   25 </span>
<span class="lineno">   26 </span>data Cxt = Cxt {ambient::Color, lights::[Light], object::Object, depth::Int}
<span class="lineno">   27 </span>        deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
<span class="lineno">   28 </span>
<span class="lineno">   29 </span>render :: (Matrix,Matrix) -&gt; Color -&gt; [Light] -&gt; Object -&gt; Int -&gt;
<span class="lineno">   30 </span>          Radian -&gt; Int -&gt; Int -&gt; String -&gt; IO ()
<span class="lineno">   31 </span><span class="decl"><span class="istickedoff">render (m,m') amb ls obj dep fov wid ht file</span>
<span class="lineno">   32 </span><span class="spaces">  </span><span class="istickedoff">= do { debugging</span>
<span class="lineno">   33 </span><span class="spaces">       </span><span class="istickedoff">; txt &lt;- readFile &quot;galois.sample&quot;</span>
<span class="lineno">   34 </span><span class="spaces">       </span><span class="istickedoff">; let vals = read txt</span>
<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>
<span class="lineno">   36 </span><span class="spaces">       </span><span class="istickedoff">; if <span class="tickonlyfalse">length vals /= length rt_vals</span></span>
<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>
<span class="lineno">   38 </span><span class="spaces">           </span><span class="istickedoff">else do {</span>
<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>
<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>
<span class="lineno">   41 </span><span class="spaces">                   </span><span class="istickedoff">}}</span>
<span class="lineno">   42 </span><span class="spaces">                   </span><span class="istickedoff"></span>
<span class="lineno">   43 </span><span class="spaces">  </span><span class="istickedoff">where</span>
<span class="lineno">   44 </span><span class="spaces">    </span><span class="istickedoff">debugging = return <span class="nottickedoff">()</span></span>
<span class="lineno">   45 </span><span class="spaces"></span><span class="istickedoff">{-</span>
<span class="lineno">   46 </span><span class="spaces">                </span><span class="istickedoff">do { putStrLn (show cxt)</span>
<span class="lineno">   47 </span><span class="spaces">                   </span><span class="istickedoff">; putStrLn (show (width, delta, aspect, left, top))</span>
<span class="lineno">   48 </span><span class="spaces">                   </span><span class="istickedoff">}</span>
<span class="lineno">   49 </span><span class="spaces"></span><span class="istickedoff">-}</span>
<span class="lineno">   50 </span><span class="spaces">    </span><span class="istickedoff">obj' = transform (m',m) obj</span>
<span class="lineno">   51 </span><span class="spaces">    </span><span class="istickedoff">ls'  = [ transformLight m' l | l &lt;- ls ]</span>
<span class="lineno">   52 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">pixelA = listArray ((1,1), (ht,wid))</span></span>
<span class="lineno">   53 </span><span class="spaces">                       </span><span class="istickedoff"><span class="nottickedoff">[ illumination cxt (start,pixel i j)</span></span>
<span class="lineno">   54 </span><span class="spaces">                       </span><span class="istickedoff"><span class="nottickedoff">| j &lt;- take ht  [0.5..]</span></span>
<span class="lineno">   55 </span><span class="spaces">                       </span><span class="istickedoff"><span class="nottickedoff">, i &lt;- take wid [0.5..] ]</span></span>
<span class="lineno">   56 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">antiA  = pixelA //</span></span>
<span class="lineno">   57 </span><span class="spaces">             </span><span class="istickedoff"><span class="nottickedoff">[ (ix, superSample ix (pixelA ! ix))</span></span>
<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>
<span class="lineno">   59 </span><span class="spaces">             </span><span class="istickedoff"><span class="nottickedoff">, let ix = (j, i)</span></span>
<span class="lineno">   60 </span><span class="spaces">             </span><span class="istickedoff"><span class="nottickedoff">, contrast ix pixelA ]</span></span>
<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>
<span class="lineno">   62 </span><span class="spaces">             </span><span class="istickedoff">| j &lt;- take ht [0.5..]</span>
<span class="lineno">   63 </span><span class="spaces">             </span><span class="istickedoff">]</span>
<span class="lineno">   64 </span><span class="spaces">    </span><span class="istickedoff">cxt    = Cxt {ambient=amb, lights=ls',  object=obj', depth=dep}</span>
<span class="lineno">   65 </span><span class="spaces">    </span><span class="istickedoff">start  = point  0 0 (-1)</span>
<span class="lineno">   66 </span><span class="spaces">    </span><span class="istickedoff">width  = 2 * tan (fov/2)</span>
<span class="lineno">   67 </span><span class="spaces">    </span><span class="istickedoff">delta  = width / fromIntegral wid</span>
<span class="lineno">   68 </span><span class="spaces">    </span><span class="istickedoff">aspect = fromIntegral ht / fromIntegral wid</span>
<span class="lineno">   69 </span><span class="spaces">    </span><span class="istickedoff">left   = - width / 2</span>
<span class="lineno">   70 </span><span class="spaces">    </span><span class="istickedoff">top    = - left * aspect</span>
<span class="lineno">   71 </span><span class="spaces">    </span><span class="istickedoff">pixel i j = vector (left + i*delta) (top - j*delta) 1</span>
<span class="lineno">   72 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   73 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">superSample (y, x) col = avg $ col:</span></span>
<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>
<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>
<span class="lineno">   76 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">]</span></span></span> 
<span class="lineno">   77 </span>
<span class="lineno">   78 </span><span class="decl"><span class="nottickedoff">avg cs = divN (fromIntegral (length cs)) (uncolor (sumCC cs))</span>
<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>
<span class="lineno">   80 </span>
<span class="lineno">   81 </span>contrast :: (Int, Int) -&gt; Array (Int, Int) Color -&gt; Bool
<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>
<span class="lineno">   83 </span><span class="spaces">                                  </span><span class="nottickedoff">| xd &lt;- [-1, 1], yd &lt;- [-1, 1]</span>
<span class="lineno">   84 </span><span class="spaces">                                  </span><span class="nottickedoff">]</span>
<span class="lineno">   85 </span><span class="spaces">  </span><span class="nottickedoff">where cur = arr ! (x, y)</span>
<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>
<span class="lineno">   87 </span><span class="spaces">           </span><span class="nottickedoff">where</span>
<span class="lineno">   88 </span><span class="spaces">                 </span><span class="nottickedoff">(r,g,b) = uncolor col</span></span>
<span class="lineno">   89 </span>
<span class="lineno">   90 </span>
<span class="lineno">   91 </span>illumination :: Cxt -&gt; Ray -&gt; Color
<span class="lineno">   92 </span><span class="decl"><span class="istickedoff">illumination cxt (r,v)</span>
<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>
<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>
<span class="lineno">   95 </span><span class="spaces">                      </span><span class="istickedoff">Nothing -&gt; black</span>
<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>
<span class="lineno">   97 </span>
<span class="lineno">   98 </span>illum :: Cxt -&gt; (Point,Vector,Properties Color Double) -&gt; Vector -&gt; Color
<span class="lineno">   99 </span><span class="decl"><span class="istickedoff">illum cxt (pos,normV,(col,kd,ks,n)) v</span>
<span class="lineno">  100 </span><span class="spaces">  </span><span class="istickedoff">= ambTerm `addCC` difTerm `addCC` spcTerm `addCC` recTerm</span>
<span class="lineno">  101 </span><span class="spaces">  </span><span class="istickedoff">where</span>
<span class="lineno">  102 </span><span class="spaces">    </span><span class="istickedoff">visibleLights = unobscured pos (object cxt) (lights cxt) normV</span>
<span class="lineno">  103 </span><span class="spaces">    </span><span class="istickedoff"><span class="nottickedoff">d = depth cxt</span></span>
<span class="lineno">  104 </span><span class="spaces">    </span><span class="istickedoff">amb = ambient cxt</span>
<span class="lineno">  105 </span><span class="spaces">    </span><span class="istickedoff">newV = subVV v (multSV (2 * dot normV v) normV)</span>
<span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  107 </span><span class="spaces">    </span><span class="istickedoff">ambTerm = multSC kd (multCC amb col)</span>
<span class="lineno">  108 </span><span class="spaces">    </span><span class="istickedoff">difTerm = multSC kd (sumCC [multSC (dot normV lj) (multCC intensity col)</span>
<span class="lineno">  109 </span><span class="spaces">               </span><span class="istickedoff">|(loc,intensity) &lt;- visibleLights,</span>
<span class="lineno">  110 </span><span class="spaces">               </span><span class="istickedoff">let lj = normalize ({- pos `subVV` -} loc)])</span>
<span class="lineno">  111 </span><span class="spaces">    </span><span class="istickedoff">-- ZZ might want to avoid the phong, when you can...</span>
<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>
<span class="lineno">  113 </span><span class="spaces">               </span><span class="istickedoff">|(loc,intensity) &lt;- visibleLights,</span>
<span class="lineno">  114 </span><span class="spaces">               </span><span class="istickedoff">-- ZZ note this is specific to the light at infinity</span>
<span class="lineno">  115 </span><span class="spaces">               </span><span class="istickedoff">let lj = {- pos `subVV` -} normalize loc,</span>
<span class="lineno">  116 </span><span class="spaces">               </span><span class="istickedoff">let hj = normalize (lj `subVV` normalize v)])</span>
<span class="lineno">  117 </span><span class="spaces">    </span><span class="istickedoff">recTerm  = if recCoeff `nearC` black then black else multCC recCoeff recRay</span>
<span class="lineno">  118 </span><span class="spaces">    </span><span class="istickedoff">recCoeff = multSC ks col</span>
<span class="lineno">  119 </span><span class="spaces">    </span><span class="istickedoff">recRay   = illumination cxt (pos,newV)</span></span>
<span class="lineno">  120 </span>
<span class="lineno">  121 </span>showBitmapA :: Int -&gt; Int -&gt; Array (Int, Int) Color -&gt; String
<span class="lineno">  122 </span><span class="decl"><span class="nottickedoff">showBitmapA wid ht arr</span>
<span class="lineno">  123 </span><span class="spaces">  </span><span class="nottickedoff">= header ++ concatMap scaleColor (elems arr)</span>
<span class="lineno">  124 </span><span class="spaces">  </span><span class="nottickedoff">where</span>
<span class="lineno">  125 </span><span class="spaces">    </span><span class="nottickedoff">scaleColor col = [scalePixel r, scalePixel g, scalePixel b]</span>
<span class="lineno">  126 </span><span class="spaces">           </span><span class="nottickedoff">where (r,g,b) = uncolor col</span>
<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>
<span class="lineno">  128 </span>
<span class="lineno">  129 </span>showBitmap :: Int -&gt; Int -&gt;[[Color]] -&gt; String
<span class="lineno">  130 </span><span class="decl"><span class="nottickedoff">showBitmap wid ht pss</span>
<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>
<span class="lineno">  132 </span><span class="spaces">  </span><span class="nottickedoff">= header ++ concat [[scalePixel r,scalePixel g,scalePixel b] </span>
<span class="lineno">  133 </span><span class="spaces">                      </span><span class="nottickedoff">| ps &lt;- pss, (r,g,b) &lt;- map uncolor ps]</span>
<span class="lineno">  134 </span><span class="spaces">  </span><span class="nottickedoff">where</span>
<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>
<span class="lineno">  136 </span><span class="spaces"></span><span class="nottickedoff">showBitmap _ _ _ = error &quot;incorrect length of bitmap string&quot;</span></span>
<span class="lineno">  137 </span>
<span class="lineno">  138 </span>scalePixel :: Double -&gt; Char
<span class="lineno">  139 </span><span class="decl"><span class="nottickedoff">scalePixel p = chr (floor (clampf p * 255))</span></span>
<span class="lineno">  140 </span>
<span class="lineno">  141 </span>showBitmap' :: Int -&gt; Int -&gt;[[Color]] -&gt; [Int]
<span class="lineno">  142 </span><span class="decl"><span class="istickedoff">showBitmap' wid ht pss</span>
<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>
<span class="lineno">  144 </span><span class="spaces">  </span><span class="istickedoff">= concat [ concat [  [scalePixel' r,scalePixel' g,scalePixel' b]</span>
<span class="lineno">  145 </span><span class="spaces">                    </span><span class="istickedoff">| (r,g,b) &lt;- map uncolor ps]</span>
<span class="lineno">  146 </span><span class="spaces">           </span><span class="istickedoff">| ps &lt;- pss ]</span>
<span class="lineno">  147 </span><span class="spaces">  </span><span class="istickedoff">where</span>
<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>
<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>
<span class="lineno">  150 </span>
<span class="lineno">  151 </span>scalePixel' :: Double -&gt; Int
<span class="lineno">  152 </span><span class="decl"><span class="istickedoff">scalePixel' p = floor (clampf p * 255)</span></span>
<span class="lineno">  153 </span>
<span class="lineno">  154 </span>-- Lights
<span class="lineno">  155 </span>
<span class="lineno">  156 </span>data Light = Light Vector Color
<span class="lineno">  157 </span>           | PointLight Point Color 
<span class="lineno">  158 </span>           | SpotLight Point Point Color Radian Double
<span class="lineno">  159 </span>   deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
<span class="lineno">  160 </span>
<span class="lineno">  161 </span>light :: Coords -&gt; Color -&gt; Light
<span class="lineno">  162 </span><span class="decl"><span class="istickedoff">light (x,y,z) color =</span>
<span class="lineno">  163 </span><span class="spaces">  </span><span class="istickedoff">Light (normalize (vector (-x) (-y) (-z))) color</span></span>
<span class="lineno">  164 </span><span class="decl"><span class="nottickedoff">pointlight (x,y,z) color =</span>
<span class="lineno">  165 </span><span class="spaces">  </span><span class="nottickedoff">PointLight (point x y z) color</span></span>
<span class="lineno">  166 </span><span class="decl"><span class="nottickedoff">spotlight (x,y,z) (p,q,r) col cutoff exp =</span>
<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>
<span class="lineno">  168 </span>
<span class="lineno">  169 </span><span class="decl"><span class="istickedoff">transformLight m (Light v c) = Light (multMV m v) c</span>
<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>
<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>
<span class="lineno">  172 </span>
<span class="lineno">  173 </span>unobscured :: Point -&gt; Object -&gt; [Light] -&gt;  Vector -&gt; [(Vector,Color)]
<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>
<span class="lineno">  175 </span>
<span class="lineno">  176 </span>unobscure :: Point -&gt; Object -&gt; Vector -&gt;  Light -&gt; Maybe (Vector,Color)
<span class="lineno">  177 </span><span class="decl"><span class="istickedoff">unobscure pos obj normV (Light vec color)</span>
<span class="lineno">  178 </span><span class="spaces">  </span><span class="istickedoff">-- ZZ probably want to make this faster</span>
<span class="lineno">  179 </span><span class="spaces">  </span><span class="istickedoff">| vec `dot` normV &lt; 0 = Nothing</span>
<span class="lineno">  180 </span><span class="spaces">  </span><span class="istickedoff">| intersects (pos `addPV` (0.0001 `multSV` vec),vec) obj = Nothing</span>
<span class="lineno">  181 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>               = Just (vec,color)</span>
<span class="lineno">  182 </span><span class="spaces"></span><span class="istickedoff">unobscure pos obj normV (PointLight pp color)</span>
<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>
<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>
<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>
<span class="lineno">  186 </span><span class="spaces">      </span><span class="istickedoff">where <span class="nottickedoff">vec = pp `subPP` pos</span></span>
<span class="lineno">  187 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">is  = attenuate vec color</span></span>
<span class="lineno">  188 </span><span class="spaces"></span><span class="istickedoff">unobscure org obj normV (SpotLight pos at color cutoff exp)</span>
<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>
<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>
<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>
<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>
<span class="lineno">  193 </span><span class="spaces">      </span><span class="istickedoff">where <span class="nottickedoff">vec   = pos `subPP` org</span></span>
<span class="lineno">  194 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">vec'  = pos `subPP` at</span></span>
<span class="lineno">  195 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">angle = acos (normalize vec `dot` (normalize vec'))</span></span>
<span class="lineno">  196 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  197 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">asp   = normalize (at `subPP` pos)</span>            </span>
<span class="lineno">  198 </span><span class="spaces">            </span><span class="istickedoff"><span class="nottickedoff">qsp   = normalize (org `subPP` pos)</span></span>
<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>
<span class="lineno">  200 </span>
<span class="lineno">  201 </span>attenuate :: Vector -&gt; Color -&gt; Color
<span class="lineno">  202 </span><span class="decl"><span class="nottickedoff">attenuate vec color = (100 / (99 + sq (norm vec))) `multSC` color</span></span>
<span class="lineno">  203 </span>
<span class="lineno">  204 </span>--
<span class="lineno">  205 </span>
<span class="lineno">  206 </span><span class="decl"><span class="istickedoff">castRay ray p</span>
<span class="lineno">  207 </span><span class="spaces">  </span><span class="istickedoff">= case intersectRayWithObject ray p of</span>
<span class="lineno">  208 </span><span class="spaces">    </span><span class="istickedoff">(True, _, _)                     -&gt; <span class="nottickedoff">Nothing</span> -- eye is inside</span>
<span class="lineno">  209 </span><span class="spaces">    </span><span class="istickedoff">(False, [], _)                   -&gt; Nothing -- eye is inside</span>
<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>
<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>
<span class="lineno">  212 </span><span class="spaces">    </span><span class="istickedoff">(False, (t, b, (s, p0)) : _, _)     -&gt;</span>
<span class="lineno">  213 </span><span class="spaces">        </span><span class="istickedoff">let (v, prop) = surface s p0 in</span>
<span class="lineno">  214 </span><span class="spaces">            </span><span class="istickedoff">Just (offsetToPoint ray t, v, prop)</span></span>
<span class="lineno">  215 </span>
<span class="lineno">  216 </span><span class="decl"><span class="istickedoff">intersects ray p</span>
<span class="lineno">  217 </span><span class="spaces">  </span><span class="istickedoff">= case intersectRayWithObject ray p of</span>
<span class="lineno">  218 </span><span class="spaces">    </span><span class="istickedoff">(True, _, _)                  -&gt; <span class="nottickedoff">False</span></span>
<span class="lineno">  219 </span><span class="spaces">    </span><span class="istickedoff">(False, [], _)                -&gt; False</span>
<span class="lineno">  220 </span><span class="spaces">    </span><span class="istickedoff">(False, (0, b, _) : _, _)     -&gt; <span class="nottickedoff">False</span></span>
<span class="lineno">  221 </span><span class="spaces">    </span><span class="istickedoff">(False, (i, False, _) : _, _) -&gt; <span class="nottickedoff">False</span></span>
<span class="lineno">  222 </span><span class="spaces">    </span><span class="istickedoff">(False, (i, b, _) : _, _)     -&gt; True</span></span>
<span class="lineno">  223 </span>
<span class="lineno">  224 </span>intersectWithin :: Ray -&gt; Object -&gt; Bool
<span class="lineno">  225 </span><span class="decl"><span class="nottickedoff">intersectWithin ray p</span>
<span class="lineno">  226 </span><span class="spaces">  </span><span class="nottickedoff">= case intersectRayWithObject ray p of</span>
<span class="lineno">  227 </span><span class="spaces">    </span><span class="nottickedoff">(True, _, _)                  -&gt; False -- eye is inside</span>
<span class="lineno">  228 </span><span class="spaces">    </span><span class="nottickedoff">(False, [], _)                -&gt; False -- eye is inside</span>
<span class="lineno">  229 </span><span class="spaces">    </span><span class="nottickedoff">(False, (0, b, _) : _, _)     -&gt; False -- eye is inside</span>
<span class="lineno">  230 </span><span class="spaces">    </span><span class="nottickedoff">(False, (i, False, _) : _, _) -&gt; False -- eye is inside</span>
<span class="lineno">  231 </span><span class="spaces">    </span><span class="nottickedoff">(False, (t, b, _) : _, _)     -&gt; t &lt; 1.0</span></span>

</pre>
</html>
Writing: Geometry.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Geometry
<span class="lineno">    7 </span>    ( Coords
<span class="lineno">    8 </span>    , Ray
<span class="lineno">    9 </span>    , Point  -- abstract
<span class="lineno">   10 </span>    , Vector -- abstract
<span class="lineno">   11 </span>    , Matrix -- abstract
<span class="lineno">   12 </span>    , Color  -- abstract
<span class="lineno">   13 </span>    , Box(..)
<span class="lineno">   14 </span>    , Radian
<span class="lineno">   15 </span>    , matrix
<span class="lineno">   16 </span>    , coord
<span class="lineno">   17 </span>    , color
<span class="lineno">   18 </span>    , uncolor
<span class="lineno">   19 </span>    , xCoord , yCoord , zCoord
<span class="lineno">   20 </span>    , xComponent , yComponent , zComponent
<span class="lineno">   21 </span>    , point
<span class="lineno">   22 </span>    , vector
<span class="lineno">   23 </span>    , nearV
<span class="lineno">   24 </span>    , point_to_vector
<span class="lineno">   25 </span>    , vector_to_point
<span class="lineno">   26 </span>    , dot
<span class="lineno">   27 </span>    , cross
<span class="lineno">   28 </span>    , tangents
<span class="lineno">   29 </span>    , addVV
<span class="lineno">   30 </span>    , addPV
<span class="lineno">   31 </span>    , subVV
<span class="lineno">   32 </span>    , negV
<span class="lineno">   33 </span>    , subPP
<span class="lineno">   34 </span>    , norm
<span class="lineno">   35 </span>    , normalize
<span class="lineno">   36 </span>    , dist2
<span class="lineno">   37 </span>    , sq
<span class="lineno">   38 </span>    , distFrom0Sq
<span class="lineno">   39 </span>    , distFrom0
<span class="lineno">   40 </span>    , multSV
<span class="lineno">   41 </span>    , multMM
<span class="lineno">   42 </span>    , transposeM
<span class="lineno">   43 </span>    , multMV
<span class="lineno">   44 </span>    , multMP
<span class="lineno">   45 </span>    , multMQ
<span class="lineno">   46 </span>    , multMR
<span class="lineno">   47 </span>    , white
<span class="lineno">   48 </span>    , black
<span class="lineno">   49 </span>    , addCC
<span class="lineno">   50 </span>    , subCC
<span class="lineno">   51 </span>    , sumCC
<span class="lineno">   52 </span>    , multCC
<span class="lineno">   53 </span>    , multSC
<span class="lineno">   54 </span>    , nearC
<span class="lineno">   55 </span>    , offsetToPoint
<span class="lineno">   56 </span>    , epsilon
<span class="lineno">   57 </span>    , inf
<span class="lineno">   58 </span>    , nonZero
<span class="lineno">   59 </span>    , eqEps
<span class="lineno">   60 </span>    , near
<span class="lineno">   61 </span>    , clampf
<span class="lineno">   62 </span>    ) where
<span class="lineno">   63 </span>
<span class="lineno">   64 </span>import List 
<span class="lineno">   65 </span>
<span class="lineno">   66 </span>type Coords = (Double,Double,Double)
<span class="lineno">   67 </span>
<span class="lineno">   68 </span>type Ray = (Point,Vector)    -- origin of ray, and unit vector giving direction
<span class="lineno">   69 </span>
<span class="lineno">   70 </span>data Point  = P !Double !Double !Double -- implicit extra arg of 1
<span class="lineno">   71 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
<span class="lineno">   72 </span>data Vector = V !Double !Double !Double -- implicit extra arg of 0
<span class="lineno">   73 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>, <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>)
<span class="lineno">   74 </span>data Matrix = M !Quad   !Quad   !Quad   !Quad
<span class="lineno">   75 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
<span class="lineno">   76 </span>
<span class="lineno">   77 </span>data Color  = C !Double !Double !Double
<span class="lineno">   78 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>, <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Eq</span></span></span></span>)
<span class="lineno">   79 </span>
<span class="lineno">   80 </span>data Box = B !Double !Double !Double !Double !Double !Double
<span class="lineno">   81 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
<span class="lineno">   82 </span>
<span class="lineno">   83 </span>data Quad   = Q !Double !Double !Double !Double
<span class="lineno">   84 </span>    deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
<span class="lineno">   85 </span>
<span class="lineno">   86 </span>type Radian = Double
<span class="lineno">   87 </span>
<span class="lineno">   88 </span>type Tup4 a = (a,a,a,a)
<span class="lineno">   89 </span>
<span class="lineno">   90 </span>--{-# INLINE matrix #-}
<span class="lineno">   91 </span>matrix :: Tup4 (Tup4 Double) -&gt; Matrix
<span class="lineno">   92 </span><span class="decl"><span class="istickedoff">matrix ((m11, m12, m13, m14),</span>
<span class="lineno">   93 </span><span class="spaces">          </span><span class="istickedoff">(m21, m22, m23, m24),</span>
<span class="lineno">   94 </span><span class="spaces">          </span><span class="istickedoff">(m31, m32, m33, m34),</span>
<span class="lineno">   95 </span><span class="spaces">          </span><span class="istickedoff">(m41, m42, m43, m44))</span>
<span class="lineno">   96 </span><span class="spaces">  </span><span class="istickedoff">= M (Q m11 m12 m13 m14)</span>
<span class="lineno">   97 </span><span class="spaces">      </span><span class="istickedoff">(Q m21 m22 m23 m24)</span>
<span class="lineno">   98 </span><span class="spaces">      </span><span class="istickedoff">(Q m31 m32 m33 m34)</span>
<span class="lineno">   99 </span><span class="spaces">      </span><span class="istickedoff">(Q m41 m42 m43 m44)</span></span>
<span class="lineno">  100 </span>
<span class="lineno">  101 </span><span class="decl"><span class="nottickedoff">coord x y z = (x, y, z)</span></span>
<span class="lineno">  102 </span>
<span class="lineno">  103 </span><span class="decl"><span class="istickedoff">color r g b = C r g b</span></span>
<span class="lineno">  104 </span>
<span class="lineno">  105 </span><span class="decl"><span class="istickedoff">uncolor (C r g b) = (r,g,b)</span></span>
<span class="lineno">  106 </span>
<span class="lineno">  107 </span>{-# INLINE xCoord #-}
<span class="lineno">  108 </span><span class="decl"><span class="istickedoff">xCoord (P x y z) = x</span></span>
<span class="lineno">  109 </span>{-# INLINE yCoord #-}
<span class="lineno">  110 </span><span class="decl"><span class="istickedoff">yCoord (P x y z) = y</span></span>
<span class="lineno">  111 </span>{-# INLINE zCoord #-}
<span class="lineno">  112 </span><span class="decl"><span class="istickedoff">zCoord (P x y z) = z</span></span>
<span class="lineno">  113 </span>
<span class="lineno">  114 </span>{-# INLINE xComponent #-}
<span class="lineno">  115 </span><span class="decl"><span class="istickedoff">xComponent (V x y z) = x</span></span>
<span class="lineno">  116 </span>{-# INLINE yComponent #-}
<span class="lineno">  117 </span><span class="decl"><span class="istickedoff">yComponent (V x y z) = y</span></span>
<span class="lineno">  118 </span>{-# INLINE zComponent #-}
<span class="lineno">  119 </span><span class="decl"><span class="istickedoff">zComponent (V x y z) = z</span></span>
<span class="lineno">  120 </span>
<span class="lineno">  121 </span>point :: Double -&gt; Double -&gt; Double -&gt; Point
<span class="lineno">  122 </span><span class="decl"><span class="istickedoff">point x y z = P x y z</span></span>
<span class="lineno">  123 </span>
<span class="lineno">  124 </span>vector :: Double -&gt; Double -&gt; Double -&gt; Vector
<span class="lineno">  125 </span><span class="decl"><span class="istickedoff">vector x y z = V x y z</span></span>
<span class="lineno">  126 </span>
<span class="lineno">  127 </span>nearV :: Vector -&gt; Vector -&gt; Bool
<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>
<span class="lineno">  129 </span>
<span class="lineno">  130 </span>point_to_vector :: Point -&gt; Vector
<span class="lineno">  131 </span><span class="decl"><span class="nottickedoff">point_to_vector (P x y z) = V x y z</span></span>
<span class="lineno">  132 </span>
<span class="lineno">  133 </span>vector_to_point :: Vector -&gt; Point
<span class="lineno">  134 </span><span class="decl"><span class="nottickedoff">vector_to_point (V x y z)  = P x y z</span></span> 
<span class="lineno">  135 </span>
<span class="lineno">  136 </span>{-# INLINE vector_to_quad #-}
<span class="lineno">  137 </span>vector_to_quad :: Vector -&gt; Quad
<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>
<span class="lineno">  139 </span>
<span class="lineno">  140 </span>{-# INLINE point_to_quad #-}
<span class="lineno">  141 </span>point_to_quad :: Point -&gt; Quad
<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>
<span class="lineno">  143 </span>
<span class="lineno">  144 </span>{-# INLINE quad_to_point #-}
<span class="lineno">  145 </span>quad_to_point :: Quad -&gt; Point
<span class="lineno">  146 </span><span class="decl"><span class="istickedoff">quad_to_point (Q x y z _) = P x y z</span></span>
<span class="lineno">  147 </span>
<span class="lineno">  148 </span>{-# INLINE quad_to_vector #-}
<span class="lineno">  149 </span>quad_to_vector :: Quad -&gt; Vector
<span class="lineno">  150 </span><span class="decl"><span class="istickedoff">quad_to_vector (Q x y z _) = V x y z</span></span>
<span class="lineno">  151 </span>
<span class="lineno">  152 </span>--{-# INLINE dot #-}
<span class="lineno">  153 </span>dot :: Vector -&gt; Vector -&gt; Double
<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>
<span class="lineno">  155 </span>
<span class="lineno">  156 </span>cross :: Vector -&gt; Vector -&gt; Vector
<span class="lineno">  157 </span><span class="decl"><span class="istickedoff">cross (V x1 y1 z1) (V x2 y2 z2)</span>
<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>
<span class="lineno">  159 </span>
<span class="lineno">  160 </span>-- assumption: the input vector is a normal
<span class="lineno">  161 </span>tangents :: Vector -&gt; (Vector, Vector)
<span class="lineno">  162 </span><span class="decl"><span class="nottickedoff">tangents v@(V x y z)</span>
<span class="lineno">  163 </span><span class="spaces">  </span><span class="nottickedoff">= (v1, v `cross` v1)</span>
<span class="lineno">  164 </span><span class="spaces">  </span><span class="nottickedoff">where v1 | x == 0    = normalize (vector 0 z (-y))</span>
<span class="lineno">  165 </span><span class="spaces">           </span><span class="nottickedoff">| otherwise = normalize (vector (-y) x 0)</span></span>
<span class="lineno">  166 </span>
<span class="lineno">  167 </span>{-# INLINE dot4 #-}
<span class="lineno">  168 </span>dot4 :: Quad -&gt; Quad -&gt; Double
<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>
<span class="lineno">  170 </span>
<span class="lineno">  171 </span>addVV :: Vector -&gt; Vector -&gt; Vector
<span class="lineno">  172 </span><span class="decl"><span class="nottickedoff">addVV (V x1 y1 z1) (V x2 y2 z2) </span>
<span class="lineno">  173 </span><span class="spaces">    </span><span class="nottickedoff">= V (x1 + x2) (y1 + y2) (z1 + z2)</span></span>
<span class="lineno">  174 </span>
<span class="lineno">  175 </span>addPV :: Point -&gt; Vector -&gt; Point
<span class="lineno">  176 </span><span class="decl"><span class="istickedoff">addPV (P x1 y1 z1) (V x2 y2 z2) </span>
<span class="lineno">  177 </span><span class="spaces">    </span><span class="istickedoff">= P (x1 + x2) (y1 + y2) (z1 + z2)</span></span>
<span class="lineno">  178 </span>
<span class="lineno">  179 </span>subVV :: Vector -&gt; Vector -&gt; Vector
<span class="lineno">  180 </span><span class="decl"><span class="istickedoff">subVV (V x1 y1 z1) (V x2 y2 z2) </span>
<span class="lineno">  181 </span><span class="spaces">    </span><span class="istickedoff">= V (x1 - x2) (y1 - y2) (z1 - z2)</span></span>
<span class="lineno">  182 </span>
<span class="lineno">  183 </span>negV :: Vector -&gt; Vector
<span class="lineno">  184 </span><span class="decl"><span class="nottickedoff">negV (V x1 y1 z1) </span>
<span class="lineno">  185 </span><span class="spaces">    </span><span class="nottickedoff">= V (-x1) (-y1) (-z1)</span></span>
<span class="lineno">  186 </span>
<span class="lineno">  187 </span>subPP :: Point -&gt; Point -&gt; Vector
<span class="lineno">  188 </span><span class="decl"><span class="nottickedoff">subPP (P x1 y1 z1) (P x2 y2 z2) </span>
<span class="lineno">  189 </span><span class="spaces">    </span><span class="nottickedoff">= V (x1 - x2) (y1 - y2) (z1 - z2)</span></span>
<span class="lineno">  190 </span>
<span class="lineno">  191 </span>--{-# INLINE norm #-}
<span class="lineno">  192 </span>norm :: Vector -&gt; Double
<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>
<span class="lineno">  194 </span>
<span class="lineno">  195 </span>--{-# INLINE normalize #-}
<span class="lineno">  196 </span>-- normalize a vector to a unit vector
<span class="lineno">  197 </span>normalize :: Vector -&gt; Vector
<span class="lineno">  198 </span><span class="decl"><span class="istickedoff">normalize v@(V x y z)</span>
<span class="lineno">  199 </span><span class="spaces">             </span><span class="istickedoff">| <span class="tickonlytrue">norm /= 0</span> = multSV (1/norm) v</span>
<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>
<span class="lineno">  201 </span><span class="spaces">    </span><span class="istickedoff">where norm = sqrt (sq x + sq y + sq z)</span></span>
<span class="lineno">  202 </span>
<span class="lineno">  203 </span>-- This does computes the distance *squared*
<span class="lineno">  204 </span>dist2 :: Point -&gt; Point -&gt; Double
<span class="lineno">  205 </span><span class="decl"><span class="nottickedoff">dist2 us vs = sq x + sq y + sq z</span>
<span class="lineno">  206 </span><span class="spaces">    </span><span class="nottickedoff">where</span>
<span class="lineno">  207 </span><span class="spaces">       </span><span class="nottickedoff">(V x y z) = subPP us vs</span></span>
<span class="lineno">  208 </span>
<span class="lineno">  209 </span>{-# INLINE sq #-}
<span class="lineno">  210 </span>sq :: Double -&gt; Double
<span class="lineno">  211 </span><span class="decl"><span class="istickedoff">sq d = d * d</span></span> 
<span class="lineno">  212 </span>
<span class="lineno">  213 </span>{-# INLINE distFrom0Sq #-}
<span class="lineno">  214 </span>distFrom0Sq :: Point -&gt; Double  -- Distance of point from origin.
<span class="lineno">  215 </span><span class="decl"><span class="nottickedoff">distFrom0Sq (P x y z) = sq x + sq y + sq z</span></span>
<span class="lineno">  216 </span>
<span class="lineno">  217 </span>{-# INLINE distFrom0 #-}
<span class="lineno">  218 </span>distFrom0 :: Point -&gt; Double  -- Distance of point from origin.
<span class="lineno">  219 </span><span class="decl"><span class="nottickedoff">distFrom0 p = sqrt (distFrom0Sq p)</span></span>
<span class="lineno">  220 </span>
<span class="lineno">  221 </span>--{-# INLINE multSV #-}
<span class="lineno">  222 </span>multSV :: Double -&gt; Vector -&gt; Vector
<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>
<span class="lineno">  224 </span>
<span class="lineno">  225 </span>--{-# INLINE multMM #-}
<span class="lineno">  226 </span>multMM :: Matrix -&gt; Matrix -&gt; Matrix
<span class="lineno">  227 </span><span class="decl"><span class="istickedoff">multMM m1@(M q1 q2 q3 q4) m2</span>
<span class="lineno">  228 </span><span class="spaces">     </span><span class="istickedoff">= M (multMQ m2' q1)</span>
<span class="lineno">  229 </span><span class="spaces">         </span><span class="istickedoff">(multMQ m2' q2)</span>
<span class="lineno">  230 </span><span class="spaces">         </span><span class="istickedoff">(multMQ m2' q3)</span>
<span class="lineno">  231 </span><span class="spaces">         </span><span class="istickedoff">(multMQ m2' q4)</span>
<span class="lineno">  232 </span><span class="spaces">  </span><span class="istickedoff">where</span>
<span class="lineno">  233 </span><span class="spaces">     </span><span class="istickedoff">m2' = transposeM m2</span></span>
<span class="lineno">  234 </span>
<span class="lineno">  235 </span>{-# INLINE transposeM #-}     
<span class="lineno">  236 </span>transposeM :: Matrix -&gt; Matrix
<span class="lineno">  237 </span><span class="decl"><span class="istickedoff">transposeM (M (Q e11  e12  e13  e14)</span>
<span class="lineno">  238 </span><span class="spaces">              </span><span class="istickedoff">(Q e21  e22  e23  e24)</span>
<span class="lineno">  239 </span><span class="spaces">              </span><span class="istickedoff">(Q e31  e32  e33  e34)</span>
<span class="lineno">  240 </span><span class="spaces">              </span><span class="istickedoff">(Q e41  e42  e43  e44)) = (M (Q e11  e21  e31  e41)</span>
<span class="lineno">  241 </span><span class="spaces">                                           </span><span class="istickedoff">(Q e12  e22  e32  e42)</span>
<span class="lineno">  242 </span><span class="spaces">                                           </span><span class="istickedoff">(Q e13  e23  e33  e43)</span>
<span class="lineno">  243 </span><span class="spaces">                                           </span><span class="istickedoff">(Q e14  e24  e34  e44))</span></span>
<span class="lineno">  244 </span>
<span class="lineno">  245 </span>
<span class="lineno">  246 </span>--multMM m1 m2 = [map (dot4 row) (transpose m2) | row &lt;- m1]
<span class="lineno">  247 </span>
<span class="lineno">  248 </span>--{-# INLINE multMV #-}
<span class="lineno">  249 </span>multMV :: Matrix -&gt; Vector -&gt; Vector
<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>
<span class="lineno">  251 </span>
<span class="lineno">  252 </span>--{-# INLINE multMP #-}
<span class="lineno">  253 </span>multMP :: Matrix -&gt; Point -&gt; Point
<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>
<span class="lineno">  255 </span>
<span class="lineno">  256 </span>-- mat vec = map (dot4 vec) mat
<span class="lineno">  257 </span>
<span class="lineno">  258 </span>{-# INLINE multMQ #-}
<span class="lineno">  259 </span>multMQ :: Matrix -&gt; Quad -&gt; Quad
<span class="lineno">  260 </span><span class="decl"><span class="istickedoff">multMQ (M q1 q2 q3 q4) q</span>
<span class="lineno">  261 </span><span class="spaces">       </span><span class="istickedoff">= Q (dot4 q q1)</span>
<span class="lineno">  262 </span><span class="spaces">           </span><span class="istickedoff">(dot4 q q2)</span>
<span class="lineno">  263 </span><span class="spaces">           </span><span class="istickedoff">(dot4 q q3)</span>
<span class="lineno">  264 </span><span class="spaces">           </span><span class="istickedoff">(dot4 q q4)</span></span>
<span class="lineno">  265 </span>
<span class="lineno">  266 </span>{-# INLINE multMR #-}
<span class="lineno">  267 </span>multMR :: Matrix -&gt; Ray -&gt; Ray
<span class="lineno">  268 </span><span class="decl"><span class="istickedoff">multMR m (r, v) = (multMP m r, multMV m v)</span></span>
<span class="lineno">  269 </span>
<span class="lineno">  270 </span>white :: Color
<span class="lineno">  271 </span><span class="decl"><span class="nottickedoff">white = C 1 1 1</span></span>
<span class="lineno">  272 </span>black :: Color
<span class="lineno">  273 </span><span class="decl"><span class="istickedoff">black = C 0 0 0</span></span>
<span class="lineno">  274 </span>
<span class="lineno">  275 </span>addCC :: Color -&gt; Color -&gt; Color
<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>
<span class="lineno">  277 </span>
<span class="lineno">  278 </span>subCC :: Color -&gt; Color -&gt; Color
<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>
<span class="lineno">  280 </span>
<span class="lineno">  281 </span>sumCC :: [Color] -&gt; Color
<span class="lineno">  282 </span><span class="decl"><span class="istickedoff">sumCC = foldr addCC black</span></span>
<span class="lineno">  283 </span>
<span class="lineno">  284 </span>multCC :: Color -&gt; Color -&gt; Color
<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>
<span class="lineno">  286 </span>
<span class="lineno">  287 </span>multSC :: Double -&gt; Color -&gt; Color
<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>
<span class="lineno">  289 </span>
<span class="lineno">  290 </span>nearC :: Color -&gt; Color -&gt; Bool
<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>
<span class="lineno">  292 </span>
<span class="lineno">  293 </span>offsetToPoint :: Ray -&gt; Double -&gt; Point
<span class="lineno">  294 </span><span class="decl"><span class="istickedoff">offsetToPoint (r,v) i = r `addPV` (i `multSV` v)</span></span>
<span class="lineno">  295 </span>
<span class="lineno">  296 </span>--
<span class="lineno">  297 </span>
<span class="lineno">  298 </span>epsilon, inf :: Double      -- aproximate zero and infinity
<span class="lineno">  299 </span><span class="decl"><span class="istickedoff">epsilon = 1.0e-10</span></span>
<span class="lineno">  300 </span><span class="decl"><span class="istickedoff">inf = 1.0e20</span></span>
<span class="lineno">  301 </span>
<span class="lineno">  302 </span>nonZero :: Double -&gt; Double         -- Use before a division. It makes definitions
<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>
<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>
<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
<span class="lineno">  306 </span>
<span class="lineno">  307 </span>
<span class="lineno">  308 </span><span class="decl"><span class="istickedoff">eqEps x y = abs (x-y) &lt; epsilon</span></span>
<span class="lineno">  309 </span><span class="decl"><span class="istickedoff">near = eqEps</span></span>
<span class="lineno">  310 </span>
<span class="lineno">  311 </span>clampf :: Double -&gt; Double
<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>
<span class="lineno">  313 </span><span class="spaces">         </span><span class="istickedoff">| p &gt; 1 = 1</span>
<span class="lineno">  314 </span><span class="spaces">         </span><span class="istickedoff">| <span class="tickonlytrue">True</span>  = p</span></span>

</pre>
</html>
Writing: CSG.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module CSG(module Construct,
<span class="lineno">    7 </span>           module Geometry,
<span class="lineno">    8 </span>           module Intersections,
<span class="lineno">    9 </span>           module Interval,
<span class="lineno">   10 </span>           module Misc) where
<span class="lineno">   11 </span>
<span class="lineno">   12 </span>import Construct
<span class="lineno">   13 </span>import Geometry
<span class="lineno">   14 </span>import Intersections
<span class="lineno">   15 </span>import Interval
<span class="lineno">   16 </span>import Misc

</pre>
</html>
Writing: Construct.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Construct
<span class="lineno">    7 </span>    ( Surface (..)
<span class="lineno">    8 </span>    , Face (..)
<span class="lineno">    9 </span>    , CSG (..)
<span class="lineno">   10 </span>    , Texture
<span class="lineno">   11 </span>    , Transform
<span class="lineno">   12 </span>    , union, intersect, difference
<span class="lineno">   13 </span>    , plane, sphere, cube, cylinder, cone
<span class="lineno">   14 </span>    , transform
<span class="lineno">   15 </span>    , translate, translateX, translateY, translateZ
<span class="lineno">   16 </span>    , scale, scaleX, scaleY, scaleZ, uscale
<span class="lineno">   17 </span>    , rotateX, rotateY, rotateZ
<span class="lineno">   18 </span>    , eye, translateEye
<span class="lineno">   19 </span>    , rotateEyeX, rotateEyeY, rotateEyeZ
<span class="lineno">   20 </span>    ) where
<span class="lineno">   21 </span>
<span class="lineno">   22 </span>import Geometry
<span class="lineno">   23 </span>
<span class="lineno">   24 </span>-- In each case, we model the surface by a point and a pair of tangent vectors.
<span class="lineno">   25 </span>-- This gives us enough information to determine the surface
<span class="lineno">   26 </span>-- normal at that point, which is all that is required by the current
<span class="lineno">   27 </span>-- illumination model.  We can't just save the surface normal because
<span class="lineno">   28 </span>-- that isn't preserved by transformations.
<span class="lineno">   29 </span>
<span class="lineno">   30 </span>data Surface
<span class="lineno">   31 </span>  = Planar Point Vector Vector
<span class="lineno">   32 </span>  | Spherical Point Vector Vector
<span class="lineno">   33 </span>  | Cylindrical Point Vector Vector
<span class="lineno">   34 </span>  | Conic Point Vector Vector
<span class="lineno">   35 </span>  deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
<span class="lineno">   36 </span>
<span class="lineno">   37 </span>data Face
<span class="lineno">   38 </span>  = PlaneFace
<span class="lineno">   39 </span>  | SphereFace
<span class="lineno">   40 </span>  | CubeFront
<span class="lineno">   41 </span>  | CubeBack
<span class="lineno">   42 </span>  | CubeLeft
<span class="lineno">   43 </span>  | CubeRight
<span class="lineno">   44 </span>  | CubeTop
<span class="lineno">   45 </span>  | CubeBottom
<span class="lineno">   46 </span>  | CylinderSide
<span class="lineno">   47 </span>  | CylinderTop
<span class="lineno">   48 </span>  | CylinderBottom
<span class="lineno">   49 </span>  | ConeSide
<span class="lineno">   50 </span>  | ConeBase
<span class="lineno">   51 </span>  deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
<span class="lineno">   52 </span>
<span class="lineno">   53 </span>data CSG a
<span class="lineno">   54 </span>  = Plane a
<span class="lineno">   55 </span>  | Sphere a
<span class="lineno">   56 </span>  | Cylinder a
<span class="lineno">   57 </span>  | Cube a
<span class="lineno">   58 </span>  | Cone a
<span class="lineno">   59 </span>  | Transform Matrix Matrix (CSG a)
<span class="lineno">   60 </span>  | Union (CSG a) (CSG a)
<span class="lineno">   61 </span>  | Intersect (CSG a) (CSG a)
<span class="lineno">   62 </span>  | Difference (CSG a) (CSG a)
<span class="lineno">   63 </span>  | Box Box (CSG a)
<span class="lineno">   64 </span>  deriving (<span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>)
<span class="lineno">   65 </span>
<span class="lineno">   66 </span>-- the data returned for determining surface texture
<span class="lineno">   67 </span>-- the Face tells which face of a primitive this is
<span class="lineno">   68 </span>-- the Point is the point of intersection in object coordinates
<span class="lineno">   69 </span>-- the a is application-specific texture information
<span class="lineno">   70 </span>type Texture a = (Face, Point, a)
<span class="lineno">   71 </span>
<span class="lineno">   72 </span>union, intersect, difference       :: CSG a -&gt; CSG a -&gt; CSG a
<span class="lineno">   73 </span>
<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>
<span class="lineno">   75 </span><span class="spaces"></span><span class="istickedoff">union p q = Union p q</span></span>
<span class="lineno">   76 </span>
<span class="lineno">   77 </span>-- rather pessimistic
<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>
<span class="lineno">   79 </span><span class="spaces"></span><span class="nottickedoff">intersect p q = Intersect p q</span></span>
<span class="lineno">   80 </span>
<span class="lineno">   81 </span><span class="decl"><span class="nottickedoff">difference (Box b1 p) q = Box b1 (Difference p q)</span>
<span class="lineno">   82 </span><span class="spaces"></span><span class="nottickedoff">-- no need to box again inside</span>
<span class="lineno">   83 </span><span class="spaces"></span><span class="nottickedoff">-- difference p@(Box b1 _) q = Box b1 (Difference p q)</span>
<span class="lineno">   84 </span><span class="spaces"></span><span class="nottickedoff">difference p q = Difference p q</span></span>
<span class="lineno">   85 </span>
<span class="lineno">   86 </span><span class="decl"><span class="istickedoff">mkBox b p = Box b p</span></span>
<span class="lineno">   87 </span>
<span class="lineno">   88 </span>plane, sphere, cube, cylinder, cone     :: a -&gt; CSG a
<span class="lineno">   89 </span>
<span class="lineno">   90 </span><span class="decl"><span class="istickedoff">plane = Plane</span></span>
<span class="lineno">   91 </span><span class="decl"><span class="nottickedoff">sphere s =</span>
<span class="lineno">   92 </span><span class="spaces">    </span><span class="nottickedoff">mkBox (B (-1 - epsilon) (1 + epsilon)</span>
<span class="lineno">   93 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)</span>
<span class="lineno">   94 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)) (Sphere s)</span></span>
<span class="lineno">   95 </span><span class="decl"><span class="nottickedoff">cone s =</span>
<span class="lineno">   96 </span><span class="spaces">    </span><span class="nottickedoff">mkBox (B (-1 - epsilon) (1 + epsilon)</span>
<span class="lineno">   97 </span><span class="spaces">             </span><span class="nottickedoff">(   - epsilon) (1 + epsilon)</span>
<span class="lineno">   98 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)) (Cone s)</span></span>
<span class="lineno">   99 </span><span class="decl"><span class="istickedoff">cube s =</span>
<span class="lineno">  100 </span><span class="spaces">    </span><span class="istickedoff">mkBox (B (- epsilon) (1 + epsilon)</span>
<span class="lineno">  101 </span><span class="spaces">             </span><span class="istickedoff">(- epsilon) (1 + epsilon)</span>
<span class="lineno">  102 </span><span class="spaces">             </span><span class="istickedoff">(- epsilon) (1 + epsilon)) (Cube s)</span></span>
<span class="lineno">  103 </span><span class="decl"><span class="nottickedoff">cylinder s =</span>
<span class="lineno">  104 </span><span class="spaces">    </span><span class="nottickedoff">mkBox (B (-1 - epsilon) (1 + epsilon)</span>
<span class="lineno">  105 </span><span class="spaces">             </span><span class="nottickedoff">(   - epsilon) (1 + epsilon)</span>
<span class="lineno">  106 </span><span class="spaces">             </span><span class="nottickedoff">(-1 - epsilon) (1 + epsilon)) (Cylinder s)</span></span>
<span class="lineno">  107 </span>
<span class="lineno">  108 </span>----------------------------
<span class="lineno">  109 </span>-- Object transformations
<span class="lineno">  110 </span>----------------------------
<span class="lineno">  111 </span>
<span class="lineno">  112 </span>type Transform = (Matrix, Matrix)
<span class="lineno">  113 </span>
<span class="lineno">  114 </span>transform :: Transform -&gt; CSG a -&gt; CSG a
<span class="lineno">  115 </span>
<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>
<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>
<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>
<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>
<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>
<span class="lineno">  121 </span><span class="spaces"></span><span class="istickedoff">transform (m, m')   prim                 = Transform  m m' prim</span></span>
<span class="lineno">  122 </span>
<span class="lineno">  123 </span>translate                      :: Coords -&gt; CSG a -&gt; CSG a
<span class="lineno">  124 </span>translateX, translateY, translateZ      :: Double -&gt; CSG a -&gt; CSG a
<span class="lineno">  125 </span>
<span class="lineno">  126 </span><span class="decl"><span class="istickedoff">translate xyz = transform $ transM xyz</span></span>
<span class="lineno">  127 </span><span class="decl"><span class="nottickedoff">translateX x = translate (x, 0, 0)</span></span>
<span class="lineno">  128 </span><span class="decl"><span class="nottickedoff">translateY y = translate (0, y, 0)</span></span>
<span class="lineno">  129 </span><span class="decl"><span class="nottickedoff">translateZ z = translate (0, 0, z)</span></span>
<span class="lineno">  130 </span>
<span class="lineno">  131 </span>scale                    :: Coords -&gt; CSG a -&gt; CSG a
<span class="lineno">  132 </span>scaleX, scaleY, scaleZ, uscale   :: Double -&gt; CSG a -&gt; CSG a
<span class="lineno">  133 </span>
<span class="lineno">  134 </span><span class="decl"><span class="istickedoff">scale xyz = transform $ scaleM xyz</span></span>
<span class="lineno">  135 </span><span class="decl"><span class="nottickedoff">scaleX x = scale (x, 1, 1)</span></span>
<span class="lineno">  136 </span><span class="decl"><span class="nottickedoff">scaleY y = scale (1, y, 1)</span></span>
<span class="lineno">  137 </span><span class="decl"><span class="nottickedoff">scaleZ z = scale (1, 1, z)</span></span>
<span class="lineno">  138 </span><span class="decl"><span class="istickedoff">uscale u = scale (u,u,u)</span></span>
<span class="lineno">  139 </span>
<span class="lineno">  140 </span>rotateX, rotateY, rotateZ             :: Radian -&gt; CSG a -&gt; CSG a
<span class="lineno">  141 </span>
<span class="lineno">  142 </span><span class="decl"><span class="istickedoff">rotateX a = transform $ rotxM a</span></span>
<span class="lineno">  143 </span><span class="decl"><span class="istickedoff">rotateY a = transform $ rotyM a</span></span>
<span class="lineno">  144 </span><span class="decl"><span class="nottickedoff">rotateZ a = transform $ rotzM a</span></span>
<span class="lineno">  145 </span>
<span class="lineno">  146 </span><span class="decl"><span class="istickedoff">unit = matrix</span>
<span class="lineno">  147 </span><span class="spaces">      </span><span class="istickedoff">( ( 1.0, 0.0, 0.0, 0.0 ),</span>
<span class="lineno">  148 </span><span class="spaces">        </span><span class="istickedoff">( 0.0, 1.0, 0.0, 0.0 ),</span>
<span class="lineno">  149 </span><span class="spaces">        </span><span class="istickedoff">( 0.0, 0.0, 1.0, 0.0 ),</span>
<span class="lineno">  150 </span><span class="spaces">        </span><span class="istickedoff">( 0.0, 0.0, 0.0, 1.0 ) )</span></span>
<span class="lineno">  151 </span>
<span class="lineno">  152 </span><span class="decl"><span class="istickedoff">transM (x, y, z)</span>
<span class="lineno">  153 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
<span class="lineno">  154 </span><span class="spaces">      </span><span class="istickedoff">( ( 1, 0, 0, x ),</span>
<span class="lineno">  155 </span><span class="spaces">        </span><span class="istickedoff">( 0, 1, 0, y ),</span>
<span class="lineno">  156 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 1, z ),</span>
<span class="lineno">  157 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 0, 1 ) ),</span>
<span class="lineno">  158 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
<span class="lineno">  159 </span><span class="spaces">      </span><span class="istickedoff">( ( 1, 0, 0, -x ),</span>
<span class="lineno">  160 </span><span class="spaces">        </span><span class="istickedoff">( 0, 1, 0, -y ),</span>
<span class="lineno">  161 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 1, -z ),</span>
<span class="lineno">  162 </span><span class="spaces">        </span><span class="istickedoff">( 0, 0, 0,  1 ) ) )</span></span>
<span class="lineno">  163 </span>
<span class="lineno">  164 </span><span class="decl"><span class="istickedoff">scaleM (x, y, z)</span>
<span class="lineno">  165 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
<span class="lineno">  166 </span><span class="spaces">      </span><span class="istickedoff">( (   x',    0,    0, 0 ),</span>
<span class="lineno">  167 </span><span class="spaces">        </span><span class="istickedoff">(    0,   y',    0, 0 ),</span>
<span class="lineno">  168 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0,   z', 0 ),</span>
<span class="lineno">  169 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0,    0, 1 ) ),</span>
<span class="lineno">  170 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
<span class="lineno">  171 </span><span class="spaces">      </span><span class="istickedoff">( ( 1/x',    0,    0, 0 ),</span>
<span class="lineno">  172 </span><span class="spaces">        </span><span class="istickedoff">(    0, 1/y',    0, 0 ),</span>
<span class="lineno">  173 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0, 1/z', 0 ),</span>
<span class="lineno">  174 </span><span class="spaces">        </span><span class="istickedoff">(    0,    0,    0, 1 ) ) )</span>
<span class="lineno">  175 </span><span class="spaces">  </span><span class="istickedoff">where x' = nonZero x</span>
<span class="lineno">  176 </span><span class="spaces">        </span><span class="istickedoff">y' = nonZero y</span>
<span class="lineno">  177 </span><span class="spaces">        </span><span class="istickedoff">z' = nonZero z</span></span>
<span class="lineno">  178 </span>
<span class="lineno">  179 </span><span class="decl"><span class="istickedoff">rotxM t</span>
<span class="lineno">  180 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
<span class="lineno">  181 </span><span class="spaces">      </span><span class="istickedoff">( (      1,      0,      0, 0 ),</span>
<span class="lineno">  182 </span><span class="spaces">        </span><span class="istickedoff">(      0,  cos t, -sin t, 0 ),</span>
<span class="lineno">  183 </span><span class="spaces">        </span><span class="istickedoff">(      0,  sin t,  cos t, 0 ),</span>
<span class="lineno">  184 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ),</span>
<span class="lineno">  185 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
<span class="lineno">  186 </span><span class="spaces">      </span><span class="istickedoff">( (      1,      0,      0, 0 ),</span>
<span class="lineno">  187 </span><span class="spaces">        </span><span class="istickedoff">(      0,  cos t,  sin t, 0 ),</span>
<span class="lineno">  188 </span><span class="spaces">        </span><span class="istickedoff">(      0, -sin t,  cos t, 0 ),</span>
<span class="lineno">  189 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ) )</span></span>
<span class="lineno">  190 </span>
<span class="lineno">  191 </span><span class="decl"><span class="istickedoff">rotyM t</span>
<span class="lineno">  192 </span><span class="spaces">  </span><span class="istickedoff">= ( matrix</span>
<span class="lineno">  193 </span><span class="spaces">      </span><span class="istickedoff">( (  cos t,      0,  sin t, 0 ),</span>
<span class="lineno">  194 </span><span class="spaces">        </span><span class="istickedoff">(      0,      1,      0, 0 ),</span>
<span class="lineno">  195 </span><span class="spaces">        </span><span class="istickedoff">( -sin t,      0,  cos t, 0 ),</span>
<span class="lineno">  196 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ),</span>
<span class="lineno">  197 </span><span class="spaces">      </span><span class="istickedoff">matrix</span>
<span class="lineno">  198 </span><span class="spaces">      </span><span class="istickedoff">( (  cos t,      0, -sin t, 0 ),</span>
<span class="lineno">  199 </span><span class="spaces">        </span><span class="istickedoff">(      0,      1,      0, 0 ),</span>
<span class="lineno">  200 </span><span class="spaces">        </span><span class="istickedoff">(  sin t,      0,  cos t, 0 ),</span>
<span class="lineno">  201 </span><span class="spaces">        </span><span class="istickedoff">(      0,      0,      0, 1 ) ) )</span></span>
<span class="lineno">  202 </span>
<span class="lineno">  203 </span><span class="decl"><span class="nottickedoff">rotzM t</span>
<span class="lineno">  204 </span><span class="spaces">  </span><span class="nottickedoff">= ( matrix</span>
<span class="lineno">  205 </span><span class="spaces">      </span><span class="nottickedoff">( (  cos t, -sin t,      0, 0 ),</span>
<span class="lineno">  206 </span><span class="spaces">        </span><span class="nottickedoff">(  sin t,  cos t,      0, 0 ),</span>
<span class="lineno">  207 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      1, 0 ),</span>
<span class="lineno">  208 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      0, 1 ) ),</span>
<span class="lineno">  209 </span><span class="spaces">      </span><span class="nottickedoff">matrix</span>
<span class="lineno">  210 </span><span class="spaces">      </span><span class="nottickedoff">( (  cos t,  sin t,      0, 0 ),</span>
<span class="lineno">  211 </span><span class="spaces">        </span><span class="nottickedoff">( -sin t,  cos t,      0, 0 ),</span>
<span class="lineno">  212 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      1, 0 ),</span>
<span class="lineno">  213 </span><span class="spaces">        </span><span class="nottickedoff">(      0,      0,      0, 1 ) ) )</span></span>
<span class="lineno">  214 </span>
<span class="lineno">  215 </span>-------------------
<span class="lineno">  216 </span>-- Eye transformations
<span class="lineno">  217 </span>
<span class="lineno">  218 </span>-- These are used to specify placement of the eye.
<span class="lineno">  219 </span>-- `eye' starts out at (0, 0, -1).
<span class="lineno">  220 </span>-- These are implemented as inverse transforms of the model.
<span class="lineno">  221 </span>-------------------
<span class="lineno">  222 </span>
<span class="lineno">  223 </span>eye                       :: Transform
<span class="lineno">  224 </span>translateEye          :: Coords -&gt; Transform -&gt; Transform
<span class="lineno">  225 </span>rotateEyeX, rotateEyeY, rotateEyeZ      :: Radian -&gt; Transform -&gt; Transform
<span class="lineno">  226 </span>
<span class="lineno">  227 </span><span class="decl"><span class="istickedoff">eye = (unit, unit)</span></span>
<span class="lineno">  228 </span><span class="decl"><span class="nottickedoff">translateEye xyz (eye1, eye2)</span>
<span class="lineno">  229 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
<span class="lineno">  230 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = transM xyz</span></span>
<span class="lineno">  231 </span><span class="decl"><span class="nottickedoff">rotateEyeX t (eye1, eye2)</span>
<span class="lineno">  232 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
<span class="lineno">  233 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = rotxM t</span></span>
<span class="lineno">  234 </span><span class="decl"><span class="nottickedoff">rotateEyeY t (eye1, eye2)</span>
<span class="lineno">  235 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
<span class="lineno">  236 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = rotyM t</span></span>
<span class="lineno">  237 </span><span class="decl"><span class="nottickedoff">rotateEyeZ t (eye1, eye2)</span>
<span class="lineno">  238 </span><span class="spaces">  </span><span class="nottickedoff">= (multMM m1 eye1, multMM eye2 m2)</span>
<span class="lineno">  239 </span><span class="spaces">  </span><span class="nottickedoff">where (m1, m2) = rotzM t</span></span>
<span class="lineno">  240 </span>
<span class="lineno">  241 </span>-------------------
<span class="lineno">  242 </span>-- Bounding boxes
<span class="lineno">  243 </span>-------------------
<span class="lineno">  244 </span>
<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>
<span class="lineno">  246 </span><span class="spaces">    </span><span class="nottickedoff">B (x11 `min` x21) (x12 `max` x22)</span>
<span class="lineno">  247 </span><span class="spaces">      </span><span class="nottickedoff">(y11 `min` y21) (y12 `max` y22)</span>
<span class="lineno">  248 </span><span class="spaces">      </span><span class="nottickedoff">(z11 `min` z21) (z12 `max` z22)</span></span>
<span class="lineno">  249 </span>
<span class="lineno">  250 </span><span class="decl"><span class="istickedoff">transformBox t (B x1  x2  y1  y2  z1  z2)</span>
<span class="lineno">  251 </span><span class="spaces">  </span><span class="istickedoff">= (B (foldr1 min (map xCoord pts'))</span>
<span class="lineno">  252 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 max (map xCoord pts'))</span>
<span class="lineno">  253 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 min (map yCoord pts'))</span>
<span class="lineno">  254 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 max (map yCoord pts'))</span>
<span class="lineno">  255 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 min (map zCoord pts'))</span>
<span class="lineno">  256 </span><span class="spaces">       </span><span class="istickedoff">(foldr1 max (map zCoord pts')))</span>
<span class="lineno">  257 </span><span class="spaces">  </span><span class="istickedoff">where pts' = map (multMP t) pts</span>
<span class="lineno">  258 </span><span class="spaces">        </span><span class="istickedoff">pts =  [point x1 y1 z1,</span>
<span class="lineno">  259 </span><span class="spaces">                </span><span class="istickedoff">point x1 y1 z2,</span>
<span class="lineno">  260 </span><span class="spaces">                </span><span class="istickedoff">point x1 y2 z1,</span>
<span class="lineno">  261 </span><span class="spaces">                </span><span class="istickedoff">point x1 y2 z2,</span>
<span class="lineno">  262 </span><span class="spaces">                </span><span class="istickedoff">point x2 y1 z1,</span>
<span class="lineno">  263 </span><span class="spaces">                </span><span class="istickedoff">point x2 y1 z2,</span>
<span class="lineno">  264 </span><span class="spaces">                </span><span class="istickedoff">point x2 y2 z1,</span>
<span class="lineno">  265 </span><span class="spaces">                </span><span class="istickedoff">point x2 y2 z2]</span></span>

</pre>
</html>
Writing: Intersections.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Intersections 
<span class="lineno">    7 </span>    ( intersectRayWithObject,
<span class="lineno">    8 </span>      quadratic
<span class="lineno">    9 </span>    ) where
<span class="lineno">   10 </span>
<span class="lineno">   11 </span>import Maybe(isJust)
<span class="lineno">   12 </span>
<span class="lineno">   13 </span>import Construct
<span class="lineno">   14 </span>import Geometry
<span class="lineno">   15 </span>import Interval
<span class="lineno">   16 </span>import Misc
<span class="lineno">   17 </span>
<span class="lineno">   18 </span>-- This is factored into two bits.  The main function `intersections'
<span class="lineno">   19 </span>-- intersects a line with an object.
<span class="lineno">   20 </span>-- The wrapper call `intersectRayWithObject' coerces this to an intersection
<span class="lineno">   21 </span>-- with a ray by clamping the result to start at 0.
<span class="lineno">   22 </span>
<span class="lineno">   23 </span><span class="decl"><span class="istickedoff">intersectRayWithObject ray p</span>
<span class="lineno">   24 </span><span class="spaces">  </span><span class="istickedoff">= clampIntervals is</span>
<span class="lineno">   25 </span><span class="spaces">  </span><span class="istickedoff">where is = intersections ray p</span></span>
<span class="lineno">   26 </span>
<span class="lineno">   27 </span><span class="decl"><span class="istickedoff">clampIntervals (True, [], True) = <span class="nottickedoff">(False, [(0, True, undefined)], True)</span></span>
<span class="lineno">   28 </span><span class="spaces"></span><span class="istickedoff">clampIntervals empty@(False, [], False) = empty</span>
<span class="lineno">   29 </span><span class="spaces"></span><span class="istickedoff">clampIntervals (True, is@((i, False, p) : is'), isOpen)</span>
<span class="lineno">   30 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">i `near` 0 || i &lt; 0</span></span>
<span class="lineno">   31 </span><span class="spaces">  </span><span class="istickedoff">= clampIntervals (False, is', isOpen)</span>
<span class="lineno">   32 </span><span class="spaces">  </span><span class="istickedoff">| <span class="nottickedoff">otherwise</span></span>
<span class="lineno">   33 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(False, (0, True, undefined) : is, isOpen)</span></span>
<span class="lineno">   34 </span><span class="spaces"></span><span class="istickedoff">clampIntervals ivals@(False, is@((i, True, p) : is'), isOpen)</span>
<span class="lineno">   35 </span><span class="spaces">  </span><span class="istickedoff">| i `near` 0 || i &lt; 0</span>
<span class="lineno">   36 </span><span class="spaces">  </span><span class="istickedoff">-- can unify this with first case...</span>
<span class="lineno">   37 </span><span class="spaces">  </span><span class="istickedoff">= clampIntervals (True, is', isOpen)</span>
<span class="lineno">   38 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span></span>
<span class="lineno">   39 </span><span class="spaces">  </span><span class="istickedoff">= ivals</span></span>
<span class="lineno">   40 </span>
<span class="lineno">   41 </span><span class="decl"><span class="istickedoff">intersections ray (Union p q)</span>
<span class="lineno">   42 </span><span class="spaces">  </span><span class="istickedoff">= unionIntervals is js</span>
<span class="lineno">   43 </span><span class="spaces">  </span><span class="istickedoff">where is = intersections ray p</span>
<span class="lineno">   44 </span><span class="spaces">        </span><span class="istickedoff">js = intersections ray q</span>
<span class="lineno">   45 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   46 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Intersect p q)</span>
<span class="lineno">   47 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectIntervals is js</span></span>
<span class="lineno">   48 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">is = intersections ray p</span></span>
<span class="lineno">   49 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">js = intersections ray q</span></span>
<span class="lineno">   50 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   51 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Difference p q)</span>
<span class="lineno">   52 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">differenceIntervals is (negateSurfaces js)</span></span>
<span class="lineno">   53 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">is = intersections ray p</span></span>
<span class="lineno">   54 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">js = intersections ray q</span></span>
<span class="lineno">   55 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   56 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Transform m m' p)</span>
<span class="lineno">   57 </span><span class="spaces">  </span><span class="istickedoff">= mapI (xform m) is</span>
<span class="lineno">   58 </span><span class="spaces">  </span><span class="istickedoff">where is = intersections (m' `multMR` ray) p</span>
<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>
<span class="lineno">   60 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   61 </span><span class="spaces"></span><span class="istickedoff">intersections ray (Box box p)</span>
<span class="lineno">   62 </span><span class="spaces">  </span><span class="istickedoff">| intersectWithBox ray box = intersections ray p</span>
<span class="lineno">   63 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span> = emptyIList</span>
<span class="lineno">   64 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   65 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Plane s)</span>
<span class="lineno">   66 </span><span class="spaces">  </span><span class="istickedoff">= intersectPlane ray s</span>
<span class="lineno">   67 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   68 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Sphere s)</span>
<span class="lineno">   69 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectSphere ray s</span></span>
<span class="lineno">   70 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   71 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Cube s)</span>
<span class="lineno">   72 </span><span class="spaces">  </span><span class="istickedoff">= intersectCube ray s</span>
<span class="lineno">   73 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   74 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Cylinder s)</span>
<span class="lineno">   75 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectCylinder ray s</span></span>
<span class="lineno">   76 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   77 </span><span class="spaces"></span><span class="istickedoff">intersections ray p@(Cone s)</span>
<span class="lineno">   78 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">intersectCone ray s</span></span></span>
<span class="lineno">   79 </span>
<span class="lineno">   80 </span>negateSurfaces :: IList (Surface, Texture a) -&gt; IList (Surface, Texture a)
<span class="lineno">   81 </span><span class="decl"><span class="nottickedoff">negateSurfaces = mapI negSurf</span>
<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>
<span class="lineno">   83 </span>
<span class="lineno">   84 </span><span class="decl"><span class="nottickedoff">negateSurface (Planar p0 v0 v1)</span>
<span class="lineno">   85 </span><span class="spaces">  </span><span class="nottickedoff">= Planar p0 v1 v0</span>
<span class="lineno">   86 </span><span class="spaces"></span><span class="nottickedoff">negateSurface (Spherical p0 v0 v1)</span>
<span class="lineno">   87 </span><span class="spaces">  </span><span class="nottickedoff">= Spherical p0 v1 v0</span>
<span class="lineno">   88 </span><span class="spaces"></span><span class="nottickedoff">negateSurface (Cylindrical p0 v0 v1)</span>
<span class="lineno">   89 </span><span class="spaces">  </span><span class="nottickedoff">= Cylindrical p0 v1 v0</span>
<span class="lineno">   90 </span><span class="spaces"></span><span class="nottickedoff">negateSurface (Conic p0 v0 v1)</span>
<span class="lineno">   91 </span><span class="spaces">  </span><span class="nottickedoff">= Conic p0 v1 v0</span></span>
<span class="lineno">   92 </span>
<span class="lineno">   93 </span><span class="decl"><span class="istickedoff">transformSurface m (Planar p0 v0 v1)</span>
<span class="lineno">   94 </span><span class="spaces">  </span><span class="istickedoff">= Planar <span class="nottickedoff">p0'</span> v0' v1'</span>
<span class="lineno">   95 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
<span class="lineno">   96 </span><span class="spaces">        </span><span class="istickedoff">v0' = multMV m v0</span>
<span class="lineno">   97 </span><span class="spaces">        </span><span class="istickedoff">v1' = multMV m v1</span>
<span class="lineno">   98 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   99 </span><span class="spaces"></span><span class="istickedoff">transformSurface m (Spherical p0 v0 v1)</span>
<span class="lineno">  100 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">Spherical p0' v0' v1'</span></span>
<span class="lineno">  101 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
<span class="lineno">  102 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v0' = multMV m v0</span></span>
<span class="lineno">  103 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v1' = multMV m v1</span></span>
<span class="lineno">  104 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  105 </span><span class="spaces"></span><span class="istickedoff">-- ditto as above</span>
<span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff">transformSurface m (Cylindrical p0 v0 v1)</span>
<span class="lineno">  107 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">Cylindrical p0' v0' v1'</span></span>
<span class="lineno">  108 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
<span class="lineno">  109 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v0' = multMV m v0</span></span>
<span class="lineno">  110 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v1' = multMV m v1</span></span>
<span class="lineno">  111 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  112 </span><span class="spaces"></span><span class="istickedoff">transformSurface m (Conic p0 v0 v1)</span>
<span class="lineno">  113 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">Conic p0' v0' v1'</span></span>
<span class="lineno">  114 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">p0' = multMP m p0</span></span>
<span class="lineno">  115 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v0' = multMV m v0</span></span>
<span class="lineno">  116 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v1' = multMV m v1</span></span></span>
<span class="lineno">  117 </span>
<span class="lineno">  118 </span>--------------------------------
<span class="lineno">  119 </span>-- Plane
<span class="lineno">  120 </span>--------------------------------
<span class="lineno">  121 </span>
<span class="lineno">  122 </span>intersectPlane :: Ray -&gt; a -&gt; IList (Surface, Texture a)
<span class="lineno">  123 </span><span class="decl"><span class="istickedoff">intersectPlane ray texture = intersectXZPlane PlaneFace ray 0.0 texture</span></span>
<span class="lineno">  124 </span>
<span class="lineno">  125 </span>intersectXZPlane :: Face -&gt; Ray -&gt; Double -&gt; a -&gt; IList (Surface, Texture a)
<span class="lineno">  126 </span><span class="decl"><span class="istickedoff">intersectXZPlane n (r,v) yoffset texture</span>
<span class="lineno">  127 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlyfalse">b `near` 0</span></span>
<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>
<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>
<span class="lineno">  130 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  131 </span><span class="spaces">    </span><span class="istickedoff">-- The line intersects the plane. Find t such that</span>
<span class="lineno">  132 </span><span class="spaces">    </span><span class="istickedoff">-- (x + at, y + bt, z + ct) intersects the X-Z plane.</span>
<span class="lineno">  133 </span><span class="spaces">    </span><span class="istickedoff">-- t may be negative (the ray starts within the halfspace),</span>
<span class="lineno">  134 </span><span class="spaces">    </span><span class="istickedoff">-- but we'll catch that later when we clamp the intervals</span>
<span class="lineno">  135 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  136 </span><span class="spaces">  </span><span class="istickedoff">| b &lt; 0       -- the ray is pointing downwards</span>
<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>
<span class="lineno">  138 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  139 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>   -- the ray is pointing upwards</span>
<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>
<span class="lineno">  141 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  142 </span><span class="spaces">  </span><span class="istickedoff">where t0 = (yoffset-y) / b</span>
<span class="lineno">  143 </span><span class="spaces">        </span><span class="istickedoff">x0 = x + a * t0</span>
<span class="lineno">  144 </span><span class="spaces">        </span><span class="istickedoff">z0 = z + c * t0</span>
<span class="lineno">  145 </span><span class="spaces">        </span><span class="istickedoff">p0 = point x0 0 z0</span>
<span class="lineno">  146 </span><span class="spaces">        </span><span class="istickedoff">v0 = vector 0 0 1</span>
<span class="lineno">  147 </span><span class="spaces">        </span><span class="istickedoff">v1 = vector 1 0 0</span>
<span class="lineno">  148 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  149 </span><span class="spaces">        </span><span class="istickedoff">x = xCoord r</span>
<span class="lineno">  150 </span><span class="spaces">        </span><span class="istickedoff">y = yCoord r</span>
<span class="lineno">  151 </span><span class="spaces">        </span><span class="istickedoff">z = zCoord r</span>
<span class="lineno">  152 </span><span class="spaces">        </span><span class="istickedoff">a = xComponent v</span>
<span class="lineno">  153 </span><span class="spaces">        </span><span class="istickedoff">b = yComponent v</span>
<span class="lineno">  154 </span><span class="spaces">        </span><span class="istickedoff">c = zComponent v</span></span>
<span class="lineno">  155 </span>
<span class="lineno">  156 </span>
<span class="lineno">  157 </span>--------------------------------
<span class="lineno">  158 </span>-- Sphere
<span class="lineno">  159 </span>--------------------------------
<span class="lineno">  160 </span>
<span class="lineno">  161 </span>intersectSphere :: Ray -&gt; a -&gt; IList (Surface, Texture a)
<span class="lineno">  162 </span><span class="decl"><span class="nottickedoff">intersectSphere ray@(r, v) texture</span>
<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>
<span class="lineno">  164 </span><span class="spaces">    </span><span class="nottickedoff">-- unit sphere, that is, such that:</span>
<span class="lineno">  165 </span><span class="spaces">    </span><span class="nottickedoff">--   (x + ta)^2 + (y + tb)^2 + (z + tc)^2 = 1</span>
<span class="lineno">  166 </span><span class="spaces">    </span><span class="nottickedoff">-- This is a quadratic equation in t:</span>
<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>
<span class="lineno">  168 </span><span class="spaces">    </span><span class="nottickedoff">let c1 = sq a + sq b + sq c</span>
<span class="lineno">  169 </span><span class="spaces">        </span><span class="nottickedoff">c2 = 2 * (x * a + y * b + z * c)</span>
<span class="lineno">  170 </span><span class="spaces">        </span><span class="nottickedoff">c3 = sq x + sq y + sq z - 1</span>
<span class="lineno">  171 </span><span class="spaces">    </span><span class="nottickedoff">in</span>
<span class="lineno">  172 </span><span class="spaces">        </span><span class="nottickedoff">case quadratic c1 c2 c3 of</span>
<span class="lineno">  173 </span><span class="spaces">        </span><span class="nottickedoff">Nothing -&gt; emptyIList</span>
<span class="lineno">  174 </span><span class="spaces">        </span><span class="nottickedoff">Just (t1, t2) -&gt; entryexit (g t1) (g t2)</span>
<span class="lineno">  175 </span><span class="spaces">    </span><span class="nottickedoff">where x = xCoord r</span>
<span class="lineno">  176 </span><span class="spaces">          </span><span class="nottickedoff">y = yCoord r</span>
<span class="lineno">  177 </span><span class="spaces">          </span><span class="nottickedoff">z = zCoord r</span>
<span class="lineno">  178 </span><span class="spaces">          </span><span class="nottickedoff">a = xComponent v</span>
<span class="lineno">  179 </span><span class="spaces">          </span><span class="nottickedoff">b = yComponent v</span>
<span class="lineno">  180 </span><span class="spaces">          </span><span class="nottickedoff">c = zComponent v</span>
<span class="lineno">  181 </span><span class="spaces">          </span><span class="nottickedoff">g t = (t, (Spherical origin v1 v2, (SphereFace, p0, texture)))</span>
<span class="lineno">  182 </span><span class="spaces">              </span><span class="nottickedoff">where origin = point 0 0 0</span>
<span class="lineno">  183 </span><span class="spaces">                    </span><span class="nottickedoff">x0 = x + t * a</span>
<span class="lineno">  184 </span><span class="spaces">                    </span><span class="nottickedoff">y0 = y + t * b</span>
<span class="lineno">  185 </span><span class="spaces">                    </span><span class="nottickedoff">z0 = z + t * c</span>
<span class="lineno">  186 </span><span class="spaces">                    </span><span class="nottickedoff">p0 = point  x0 y0 z0</span>
<span class="lineno">  187 </span><span class="spaces">                    </span><span class="nottickedoff">v0 = vector x0 y0 z0</span>
<span class="lineno">  188 </span><span class="spaces">                    </span><span class="nottickedoff">(v1, v2) = tangents v0</span></span>
<span class="lineno">  189 </span>
<span class="lineno">  190 </span>
<span class="lineno">  191 </span>--------------------------------
<span class="lineno">  192 </span>-- Cube
<span class="lineno">  193 </span>--------------------------------
<span class="lineno">  194 </span>
<span class="lineno">  195 </span>intersectCube :: Ray -&gt; a -&gt; IList (Surface, Texture a)
<span class="lineno">  196 </span><span class="decl"><span class="istickedoff">intersectCube ray@(r, v) texture</span>
<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>
<span class="lineno">  198 </span><span class="spaces">    </span><span class="istickedoff">-- the unit cube satisfies:</span>
<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>
<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>
<span class="lineno">  201 </span><span class="spaces">    </span><span class="istickedoff">-- intersection points.</span>
<span class="lineno">  202 </span><span class="spaces">    </span><span class="istickedoff">case intersectSlabIval (intersectCubeSlab face2 face3 x a)</span>
<span class="lineno">  203 </span><span class="spaces">        </span><span class="istickedoff">(intersectSlabIval (intersectCubeSlab face5 face4 y b)</span>
<span class="lineno">  204 </span><span class="spaces">                           </span><span class="istickedoff">(intersectCubeSlab face0 <span class="nottickedoff">face1</span> z c)) of</span>
<span class="lineno">  205 </span><span class="spaces">    </span><span class="istickedoff">Nothing -&gt; emptyIList</span>
<span class="lineno">  206 </span><span class="spaces">    </span><span class="istickedoff">Just (t1, t2) -&gt; entryexit (g t1) (g t2)</span>
<span class="lineno">  207 </span><span class="spaces">  </span><span class="istickedoff">where g ((n, v0, v1), t)</span>
<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>
<span class="lineno">  209 </span><span class="spaces">          </span><span class="istickedoff">where p0 = offsetToPoint ray t</span>
<span class="lineno">  210 </span><span class="spaces">        </span><span class="istickedoff">face0 = (CubeFront,  vectorY, vectorX)</span>
<span class="lineno">  211 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">face1 = (CubeBack,   vectorX, vectorY)</span></span>
<span class="lineno">  212 </span><span class="spaces">        </span><span class="istickedoff">face2 = (CubeLeft,   vectorZ, vectorY)</span>
<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>
<span class="lineno">  214 </span><span class="spaces">        </span><span class="istickedoff">face4 = (CubeTop,    vectorZ, vectorX)</span>
<span class="lineno">  215 </span><span class="spaces">        </span><span class="istickedoff">face5 = (CubeBottom, vectorX, vectorZ)</span>
<span class="lineno">  216 </span><span class="spaces">        </span><span class="istickedoff">vectorX = vector 1 0 0</span>
<span class="lineno">  217 </span><span class="spaces">        </span><span class="istickedoff">vectorY = vector 0 1 0</span>
<span class="lineno">  218 </span><span class="spaces">        </span><span class="istickedoff">vectorZ = vector 0 0 1</span>
<span class="lineno">  219 </span><span class="spaces">        </span><span class="istickedoff">x = xCoord r</span>
<span class="lineno">  220 </span><span class="spaces">        </span><span class="istickedoff">y = yCoord r</span>
<span class="lineno">  221 </span><span class="spaces">        </span><span class="istickedoff">z = zCoord r</span>
<span class="lineno">  222 </span><span class="spaces">        </span><span class="istickedoff">a = xComponent v</span>
<span class="lineno">  223 </span><span class="spaces">        </span><span class="istickedoff">b = yComponent v</span>
<span class="lineno">  224 </span><span class="spaces">        </span><span class="istickedoff">c = zComponent v</span></span>
<span class="lineno">  225 </span>
<span class="lineno">  226 </span><span class="decl"><span class="istickedoff">intersectCubeSlab n m w d</span>
<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>
<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>
<span class="lineno">  229 </span><span class="spaces">  </span><span class="istickedoff">| d &gt; 0      = Just ((n,  (-w)/d), (m, (1-w)/d))</span>
<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>
<span class="lineno">  231 </span>
<span class="lineno">  232 </span><span class="decl"><span class="istickedoff">intersectSlabIval Nothing Nothing  = <span class="nottickedoff">Nothing</span></span>
<span class="lineno">  233 </span><span class="spaces"></span><span class="istickedoff">intersectSlabIval Nothing (Just i) = <span class="nottickedoff">Nothing</span></span>
<span class="lineno">  234 </span><span class="spaces"></span><span class="istickedoff">intersectSlabIval (Just i) Nothing = Nothing</span>
<span class="lineno">  235 </span><span class="spaces"></span><span class="istickedoff">intersectSlabIval (Just (nu1@(n1, u1), mv1@(m1, v1)))</span>
<span class="lineno">  236 </span><span class="spaces">                  </span><span class="istickedoff">(Just (nu2@(n2, u2), mv2@(m2, v2)))</span>
<span class="lineno">  237 </span><span class="spaces">  </span><span class="istickedoff">= checkInterval (nu, mv)</span>
<span class="lineno">  238 </span><span class="spaces">  </span><span class="istickedoff">where nu = if u1 &lt; u2 then nu2 else nu1</span>
<span class="lineno">  239 </span><span class="spaces">        </span><span class="istickedoff">mv = if v1 &lt; v2 then mv1 else mv2</span>
<span class="lineno">  240 </span><span class="spaces">        </span><span class="istickedoff">checkInterval numv@(nu@(_, u), (m, v))</span>
<span class="lineno">  241 </span><span class="spaces">          </span><span class="istickedoff">-- rounding error may force us to push v out a bit</span>
<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>
<span class="lineno">  243 </span><span class="spaces">          </span><span class="istickedoff">| u    &lt;   v = Just numv</span>
<span class="lineno">  244 </span><span class="spaces">          </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>  = Nothing</span></span>
<span class="lineno">  245 </span>
<span class="lineno">  246 </span>
<span class="lineno">  247 </span>--------------------------------
<span class="lineno">  248 </span>-- Cylinder
<span class="lineno">  249 </span>--------------------------------
<span class="lineno">  250 </span>
<span class="lineno">  251 </span>intersectCylinder :: Ray -&gt; a -&gt; IList (Surface, Texture a)
<span class="lineno">  252 </span><span class="decl"><span class="nottickedoff">intersectCylinder ray texture</span>
<span class="lineno">  253 </span><span class="spaces">  </span><span class="nottickedoff">= isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom</span>
<span class="lineno">  254 </span><span class="spaces">  </span><span class="nottickedoff">where isectSide   = intersectCylSide ray texture</span>
<span class="lineno">  255 </span><span class="spaces">        </span><span class="nottickedoff">isectTop    = intersectXZPlane CylinderTop ray 1.0 texture</span>
<span class="lineno">  256 </span><span class="spaces">        </span><span class="nottickedoff">isectBottom = complementIntervals $ negateSurfaces $</span>
<span class="lineno">  257 </span><span class="spaces">                      </span><span class="nottickedoff">intersectXZPlane CylinderBottom ray 0.0 texture</span></span>
<span class="lineno">  258 </span>
<span class="lineno">  259 </span><span class="decl"><span class="nottickedoff">intersectCylSide (r, v) texture</span>
<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>
<span class="lineno">  261 </span><span class="spaces">    </span><span class="nottickedoff">-- cylinder if:</span>
<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>
<span class="lineno">  263 </span><span class="spaces">    </span><span class="nottickedoff">if (sq a + sq c) `near` 0</span>
<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>
<span class="lineno">  265 </span><span class="spaces">         </span><span class="nottickedoff">-- the cylinder sides.  It's either all in, or all out</span>
<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>
<span class="lineno">  267 </span><span class="spaces">   </span><span class="nottickedoff">else -- Find values of t that solve the quadratic equation</span>
<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>
<span class="lineno">  269 </span><span class="spaces">        </span><span class="nottickedoff">let c1 = sq a + sq c</span>
<span class="lineno">  270 </span><span class="spaces">            </span><span class="nottickedoff">c2 = 2 * (x * a + z * c)</span>
<span class="lineno">  271 </span><span class="spaces">            </span><span class="nottickedoff">c3 = sq x + sq z - 1</span>
<span class="lineno">  272 </span><span class="spaces">        </span><span class="nottickedoff">in</span>
<span class="lineno">  273 </span><span class="spaces">        </span><span class="nottickedoff">case quadratic c1 c2 c3 of</span>
<span class="lineno">  274 </span><span class="spaces">        </span><span class="nottickedoff">Nothing -&gt; emptyIList</span>
<span class="lineno">  275 </span><span class="spaces">        </span><span class="nottickedoff">Just (t1, t2) -&gt; entryexit (g t1) (g t2)</span>
<span class="lineno">  276 </span><span class="spaces"></span><span class="nottickedoff"></span>
<span class="lineno">  277 </span><span class="spaces">  </span><span class="nottickedoff">where sqxy = sq x + sq y</span>
<span class="lineno">  278 </span><span class="spaces">        </span><span class="nottickedoff">g t = (t, (Cylindrical origin v1 v2, (CylinderSide, p0, texture)))</span>
<span class="lineno">  279 </span><span class="spaces">            </span><span class="nottickedoff">where origin = point 0 0 0</span>
<span class="lineno">  280 </span><span class="spaces">                  </span><span class="nottickedoff">x0 = x + t * a</span>
<span class="lineno">  281 </span><span class="spaces">                  </span><span class="nottickedoff">y0 = y + t * b</span>
<span class="lineno">  282 </span><span class="spaces">                  </span><span class="nottickedoff">z0 = z + t * c</span>
<span class="lineno">  283 </span><span class="spaces">                  </span><span class="nottickedoff">p0 = point  x0 y0 z0</span>
<span class="lineno">  284 </span><span class="spaces">                  </span><span class="nottickedoff">v0 = vector x0 0 z0</span>
<span class="lineno">  285 </span><span class="spaces">                  </span><span class="nottickedoff">(v1, v2) = tangents v0</span>
<span class="lineno">  286 </span><span class="spaces"></span><span class="nottickedoff"></span>
<span class="lineno">  287 </span><span class="spaces">        </span><span class="nottickedoff">x = xCoord r</span>
<span class="lineno">  288 </span><span class="spaces">        </span><span class="nottickedoff">y = yCoord r</span>
<span class="lineno">  289 </span><span class="spaces">        </span><span class="nottickedoff">z = zCoord r</span>
<span class="lineno">  290 </span><span class="spaces">        </span><span class="nottickedoff">a = xComponent v</span>
<span class="lineno">  291 </span><span class="spaces">        </span><span class="nottickedoff">b = yComponent v</span>
<span class="lineno">  292 </span><span class="spaces">        </span><span class="nottickedoff">c = zComponent v</span></span>
<span class="lineno">  293 </span>
<span class="lineno">  294 </span>
<span class="lineno">  295 </span>-------------------
<span class="lineno">  296 </span>-- Cone
<span class="lineno">  297 </span>-------------------
<span class="lineno">  298 </span>
<span class="lineno">  299 </span>intersectCone :: Ray -&gt; a -&gt; IList (Surface, Texture a)
<span class="lineno">  300 </span><span class="decl"><span class="nottickedoff">intersectCone ray texture</span>
<span class="lineno">  301 </span><span class="spaces">  </span><span class="nottickedoff">= isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom</span>
<span class="lineno">  302 </span><span class="spaces">  </span><span class="nottickedoff">where isectSide   = intersectConeSide ray texture</span>
<span class="lineno">  303 </span><span class="spaces">        </span><span class="nottickedoff">isectTop    = intersectXZPlane ConeBase ray 1.0 texture</span>
<span class="lineno">  304 </span><span class="spaces">        </span><span class="nottickedoff">isectBottom = complementIntervals $ negateSurfaces $</span>
<span class="lineno">  305 </span><span class="spaces">                      </span><span class="nottickedoff">intersectXZPlane ConeBase ray 0.0 texture</span></span>
<span class="lineno">  306 </span>
<span class="lineno">  307 </span><span class="decl"><span class="nottickedoff">intersectConeSide (r, v) texture</span>
<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>
<span class="lineno">  309 </span><span class="spaces">    </span><span class="nottickedoff">-- intersection, we must have:</span>
<span class="lineno">  310 </span><span class="spaces">    </span><span class="nottickedoff">--    (x + ta)^2 + (z + tc)^2 = (y + tb)^2</span>
<span class="lineno">  311 </span><span class="spaces">    </span><span class="nottickedoff">-- which is the following quadratic equation:</span>
<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>
<span class="lineno">  313 </span><span class="spaces">    </span><span class="nottickedoff">let c1 = sq a - sq b + sq c</span>
<span class="lineno">  314 </span><span class="spaces">        </span><span class="nottickedoff">c2 = 2 * (x * a - y * b + c * z)</span>
<span class="lineno">  315 </span><span class="spaces">        </span><span class="nottickedoff">c3 = sq x - sq y + sq z</span>
<span class="lineno">  316 </span><span class="spaces">    </span><span class="nottickedoff">in  case quadratic c1 c2 c3 of</span>
<span class="lineno">  317 </span><span class="spaces">        </span><span class="nottickedoff">Nothing -&gt; emptyIList</span>
<span class="lineno">  318 </span><span class="spaces">        </span><span class="nottickedoff">Just (t1, t2) -&gt;</span>
<span class="lineno">  319 </span><span class="spaces">            </span><span class="nottickedoff">-- If either intersection strikes the middle, then the other</span>
<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>
<span class="lineno">  321 </span><span class="spaces">            </span><span class="nottickedoff">-- strike using the &quot;good&quot; value.</span>
<span class="lineno">  322 </span><span class="spaces">            </span><span class="nottickedoff">-- If the intersections straddle the origin, then it's</span>
<span class="lineno">  323 </span><span class="spaces">            </span><span class="nottickedoff">-- an exit/entry pair, otherwise it's an entry/exit pair.</span>
<span class="lineno">  324 </span><span class="spaces">            </span><span class="nottickedoff">let y1 = y + t1 * b</span>
<span class="lineno">  325 </span><span class="spaces">                </span><span class="nottickedoff">y2 = y + t2 * b</span>
<span class="lineno">  326 </span><span class="spaces">            </span><span class="nottickedoff">in  if y1 `near` 0                  then entryexit (g t1) (g t1)</span>
<span class="lineno">  327 </span><span class="spaces">                </span><span class="nottickedoff">else if y2 `near` 0             then entryexit (g t2) (g t2)</span>
<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>
<span class="lineno">  329 </span><span class="spaces">                </span><span class="nottickedoff">else                                 entryexit (g t1) (g t2)</span>
<span class="lineno">  330 </span><span class="spaces"></span><span class="nottickedoff"></span>
<span class="lineno">  331 </span><span class="spaces">  </span><span class="nottickedoff">where g t = (t, (Conic origin v1 v2, (ConeSide, p0, texture)))</span>
<span class="lineno">  332 </span><span class="spaces">            </span><span class="nottickedoff">where origin = point 0 0 0</span>
<span class="lineno">  333 </span><span class="spaces">                  </span><span class="nottickedoff">x0 = x + t * a</span>
<span class="lineno">  334 </span><span class="spaces">                  </span><span class="nottickedoff">y0 = y + t * b</span>
<span class="lineno">  335 </span><span class="spaces">                  </span><span class="nottickedoff">z0 = z + t * c</span>
<span class="lineno">  336 </span><span class="spaces">                  </span><span class="nottickedoff">p0 = point  x0 y0 z0</span>
<span class="lineno">  337 </span><span class="spaces">                  </span><span class="nottickedoff">v0 = normalize $ vector x0 (-y0) z0</span>
<span class="lineno">  338 </span><span class="spaces">                  </span><span class="nottickedoff">(v1, v2) = tangents v0</span>
<span class="lineno">  339 </span><span class="spaces"></span><span class="nottickedoff"></span>
<span class="lineno">  340 </span><span class="spaces">        </span><span class="nottickedoff">x = xCoord r</span>
<span class="lineno">  341 </span><span class="spaces">        </span><span class="nottickedoff">y = yCoord r</span>
<span class="lineno">  342 </span><span class="spaces">        </span><span class="nottickedoff">z = zCoord r</span>
<span class="lineno">  343 </span><span class="spaces">        </span><span class="nottickedoff">a = xComponent v</span>
<span class="lineno">  344 </span><span class="spaces">        </span><span class="nottickedoff">b = yComponent v</span>
<span class="lineno">  345 </span><span class="spaces">        </span><span class="nottickedoff">c = zComponent v</span>
<span class="lineno">  346 </span><span class="spaces"></span><span class="nottickedoff"></span>
<span class="lineno">  347 </span><span class="spaces">        </span><span class="nottickedoff">-- beyond me why this isn't defined in the prelude...</span>
<span class="lineno">  348 </span><span class="spaces">        </span><span class="nottickedoff">xor False b = b</span>
<span class="lineno">  349 </span><span class="spaces">        </span><span class="nottickedoff">xor True  b = not b</span></span>
<span class="lineno">  350 </span>
<span class="lineno">  351 </span>
<span class="lineno">  352 </span>-------------------
<span class="lineno">  353 </span>-- Solving quadratics
<span class="lineno">  354 </span>-------------------
<span class="lineno">  355 </span>
<span class="lineno">  356 </span>quadratic :: Double -&gt; Double -&gt; Double -&gt; Maybe (Double, Double)
<span class="lineno">  357 </span><span class="decl"><span class="nottickedoff">quadratic a b c =</span>
<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>
<span class="lineno">  359 </span><span class="spaces">  </span><span class="nottickedoff">let d = sq b - 4 * a * c</span>
<span class="lineno">  360 </span><span class="spaces">      </span><span class="nottickedoff">d' = if d `near` 0 then 0 else d</span>
<span class="lineno">  361 </span><span class="spaces">  </span><span class="nottickedoff">in if d' &lt; 0</span>
<span class="lineno">  362 </span><span class="spaces">     </span><span class="nottickedoff">then Nothing -- There are no real roots.</span>
<span class="lineno">  363 </span><span class="spaces">     </span><span class="nottickedoff">else</span>
<span class="lineno">  364 </span><span class="spaces">        </span><span class="nottickedoff">if a &gt; 0 then Just (((-b) - sqrt d') / (2 * a),</span>
<span class="lineno">  365 </span><span class="spaces">                            </span><span class="nottickedoff">((-b) + sqrt d') / (2 * a))</span>
<span class="lineno">  366 </span><span class="spaces">                 </span><span class="nottickedoff">else Just (((-b) + sqrt d') / (2 * a),</span>
<span class="lineno">  367 </span><span class="spaces">                            </span><span class="nottickedoff">((-b) - sqrt d') / (2 * a))</span></span>
<span class="lineno">  368 </span>
<span class="lineno">  369 </span>-------------------
<span class="lineno">  370 </span>-- Bounding boxes
<span class="lineno">  371 </span>-------------------
<span class="lineno">  372 </span>
<span class="lineno">  373 </span>data MaybeInterval = Interval !Double !Double 
<span class="lineno">  374 </span>                  | NoInterval
<span class="lineno">  375 </span>
<span class="lineno">  376 </span><span class="decl"><span class="istickedoff">isInterval (Interval _ _) = True</span>
<span class="lineno">  377 </span><span class="spaces"></span><span class="istickedoff">isInterval _              = False</span></span>
<span class="lineno">  378 </span>
<span class="lineno">  379 </span>intersectWithBox :: Ray -&gt; Box -&gt; Bool
<span class="lineno">  380 </span><span class="decl"><span class="istickedoff">intersectWithBox (r, v) (B x1 x2 y1 y2 z1 z2)</span>
<span class="lineno">  381 </span><span class="spaces">  </span><span class="istickedoff">= isInterval interval</span>
<span class="lineno">  382 </span><span class="spaces">  </span><span class="istickedoff">where x_interval = intersectRayWithSlab (xCoord r) (xComponent v) (x1, x2)</span>
<span class="lineno">  383 </span><span class="spaces">        </span><span class="istickedoff">y_interval = intersectRayWithSlab (yCoord r) (yComponent v) (y1, y2)</span>
<span class="lineno">  384 </span><span class="spaces">        </span><span class="istickedoff">z_interval = intersectRayWithSlab (zCoord r) (zComponent v) (z1, z2)</span>
<span class="lineno">  385 </span><span class="spaces">        </span><span class="istickedoff">interval = intersectInterval x_interval</span>
<span class="lineno">  386 </span><span class="spaces">                   </span><span class="istickedoff">(intersectInterval y_interval z_interval)</span></span>
<span class="lineno">  387 </span>
<span class="lineno">  388 </span>intersectInterval :: MaybeInterval -&gt; MaybeInterval -&gt; MaybeInterval
<span class="lineno">  389 </span><span class="decl"><span class="istickedoff">intersectInterval NoInterval _ = <span class="nottickedoff">NoInterval</span></span>
<span class="lineno">  390 </span><span class="spaces"></span><span class="istickedoff">intersectInterval _ NoInterval = NoInterval</span>
<span class="lineno">  391 </span><span class="spaces"></span><span class="istickedoff">intersectInterval (Interval a b) (Interval c d)</span>
<span class="lineno">  392 </span><span class="spaces">  </span><span class="istickedoff">| b &lt; c || d &lt; a = NoInterval</span>
<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>
<span class="lineno">  394 </span>
<span class="lineno">  395 </span>{-# INLINE intersectRayWithSlab #-}
<span class="lineno">  396 </span>intersectRayWithSlab :: Double -&gt; Double -&gt; (Double,Double) -&gt; MaybeInterval
<span class="lineno">  397 </span><span class="decl"><span class="istickedoff">intersectRayWithSlab xCoord alpha (x1, x2)</span>
<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>
<span class="lineno">  399 </span><span class="spaces">  </span><span class="istickedoff">| alpha &gt;  0 = Interval a b</span>
<span class="lineno">  400 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>  = Interval b a </span>
<span class="lineno">  401 </span><span class="spaces">  </span><span class="istickedoff">where a = (x1 - xCoord) / alpha</span>
<span class="lineno">  402 </span><span class="spaces">        </span><span class="istickedoff">b = (x2 - xCoord) / alpha</span></span>
<span class="lineno">  403 </span>
<span class="lineno">  404 </span><span class="decl"><span class="istickedoff">infInterval = Interval (-inf) inf</span></span>

</pre>
</html>
Writing: Misc.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Misc where
<span class="lineno">    7 </span>
<span class="lineno">    8 </span>import Debug.Trace
<span class="lineno">    9 </span>
<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>
<span class="lineno">   11 </span>-- debug s v = v

</pre>
</html>
Writing: Interval.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Interval
<span class="lineno">    7 </span>    ( IList
<span class="lineno">    8 </span>    , Intersection
<span class="lineno">    9 </span>    , emptyIList, openIList
<span class="lineno">   10 </span>    , mkEntry, mkExit
<span class="lineno">   11 </span>    , entryexit, exitentry
<span class="lineno">   12 </span>    , mapI
<span class="lineno">   13 </span>    , unionIntervals, intersectIntervals, differenceIntervals
<span class="lineno">   14 </span>    , complementIntervals
<span class="lineno">   15 </span>    ) where
<span class="lineno">   16 </span>
<span class="lineno">   17 </span>import Geometry
<span class="lineno">   18 </span>
<span class="lineno">   19 </span>-- The result of a ray trace is represented as a list of surface
<span class="lineno">   20 </span>-- intersections.  Each intersection is a point along the ray with
<span class="lineno">   21 </span>-- a flag indicating whether this intersection is an entry or an
<span class="lineno">   22 </span>-- exit from the solid.  Each intersection also carries unspecified
<span class="lineno">   23 </span>-- surface data for use by the illumination model.
<span class="lineno">   24 </span>
<span class="lineno">   25 </span>-- Just the list of intersections isn't enough, however.  An empty
<span class="lineno">   26 </span>-- list can denote either a trace that is always within the solid
<span class="lineno">   27 </span>-- or never in the solid.  To dissambiguate, an extra flag is kept
<span class="lineno">   28 </span>-- that indicates whether we are starting inside or outside of the
<span class="lineno">   29 </span>-- solid.  As a convenience, we also keep an additional flag that
<span class="lineno">   30 </span>-- indicates whether the last intersection ends inside or outside.
<span class="lineno">   31 </span>
<span class="lineno">   32 </span>type IList a       = (Bool, [Intersection a], Bool)
<span class="lineno">   33 </span>type Intersection a     = (Double, Bool, a)
<span class="lineno">   34 </span>
<span class="lineno">   35 </span><span class="decl"><span class="istickedoff">emptyIList = (False, [], False)</span></span>
<span class="lineno">   36 </span><span class="decl"><span class="nottickedoff">openIList = (True, [], True)</span></span>
<span class="lineno">   37 </span>
<span class="lineno">   38 </span><span class="decl"><span class="istickedoff">mapI f (b1, is, b2) = (b1, map f is, b2)</span></span>
<span class="lineno">   39 </span>
<span class="lineno">   40 </span><span class="decl"><span class="istickedoff">isEntry (_, entry, _) = entry</span></span>
<span class="lineno">   41 </span><span class="decl"><span class="nottickedoff">isExit  (_, entry, _) = not entry</span></span>
<span class="lineno">   42 </span>
<span class="lineno">   43 </span><span class="decl"><span class="istickedoff">mkEntry (t, a) = (t, True,  a)</span></span>
<span class="lineno">   44 </span><span class="decl"><span class="istickedoff">mkExit  (t, a) = (t, False, a)</span></span>
<span class="lineno">   45 </span>
<span class="lineno">   46 </span><span class="decl"><span class="istickedoff">entryexit w1 w2 = (False, [mkEntry w1, mkExit w2], False)</span></span>
<span class="lineno">   47 </span><span class="decl"><span class="nottickedoff">exitentry w1 w2 = (True, [mkExit w1, mkEntry w2], True)</span></span>
<span class="lineno">   48 </span><span class="decl"><span class="nottickedoff">arrange   w1@(t1, _) w2@(t2, _) | t1 &lt; t2   = entryexit w1 w2</span>
<span class="lineno">   49 </span><span class="spaces">                                </span><span class="nottickedoff">| otherwise = entryexit w2 w1</span></span>
<span class="lineno">   50 </span>
<span class="lineno">   51 </span>
<span class="lineno">   52 </span>cmpI :: Intersection a -&gt; Intersection a -&gt; Ordering
<span class="lineno">   53 </span><span class="decl"><span class="istickedoff">cmpI (i, _, _) (j, _, _)</span>
<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>
<span class="lineno">   55 </span><span class="spaces">  </span><span class="istickedoff">| i   &lt;    j = LT</span>
<span class="lineno">   56 </span><span class="spaces">  </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span>  = GT</span></span>
<span class="lineno">   57 </span>
<span class="lineno">   58 </span><span class="decl"><span class="nottickedoff">bad (b1, [], b2) = b1 /= b2</span>
<span class="lineno">   59 </span><span class="spaces"></span><span class="nottickedoff">bad (b1, is, b2) = bad' b1 is || b2 /= b3</span>
<span class="lineno">   60 </span><span class="spaces">  </span><span class="nottickedoff">where (_, b3, _) = last is</span></span>
<span class="lineno">   61 </span>
<span class="lineno">   62 </span><span class="decl"><span class="nottickedoff">bad' b [] = False</span>
<span class="lineno">   63 </span><span class="spaces"></span><span class="nottickedoff">bad' b ((_, c, _) : is) = b == c || bad' c is</span></span>
<span class="lineno">   64 </span>
<span class="lineno">   65 </span>unionIntervals :: IList a -&gt; IList a -&gt; IList a
<span class="lineno">   66 </span><span class="decl"><span class="istickedoff">unionIntervals (isStartOpen, is, isEndOpen) (jsStartOpen, js, jsEndOpen)</span>
<span class="lineno">   67 </span><span class="spaces">  </span><span class="istickedoff">= (isStartOpen || jsStartOpen, uniIntervals is js, isEndOpen || jsEndOpen)</span>
<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>
<span class="lineno">   69 </span><span class="spaces">                           </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span> = is</span>
<span class="lineno">   70 </span><span class="spaces">        </span><span class="istickedoff">uniIntervals [] js | <span class="tickonlyfalse">isEndOpen</span> = <span class="nottickedoff">[]</span></span>
<span class="lineno">   71 </span><span class="spaces">                           </span><span class="istickedoff">| <span class="tickonlytrue">otherwise</span> = js</span>
<span class="lineno">   72 </span><span class="spaces">        </span><span class="istickedoff">uniIntervals is@(i : is') js@(j : js')</span>
<span class="lineno">   73 </span><span class="spaces">          </span><span class="istickedoff">= case cmpI i j of</span>
<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>
<span class="lineno">   75 </span><span class="spaces">                                            </span><span class="istickedoff"><span class="nottickedoff">else uniIntervals is' js'</span></span>
<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>
<span class="lineno">   77 </span><span class="spaces">                               </span><span class="istickedoff">else     <span class="nottickedoff">uniIntervals is' js</span></span>
<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>
<span class="lineno">   79 </span><span class="spaces">                               </span><span class="istickedoff">else     <span class="nottickedoff">uniIntervals is js'</span></span></span>
<span class="lineno">   80 </span>
<span class="lineno">   81 </span>intersectIntervals :: IList a -&gt; IList a -&gt; IList a
<span class="lineno">   82 </span><span class="decl"><span class="nottickedoff">intersectIntervals is js</span>
<span class="lineno">   83 </span><span class="spaces">  </span><span class="nottickedoff">= complementIntervals (unionIntervals is' js')</span>
<span class="lineno">   84 </span><span class="spaces">  </span><span class="nottickedoff">where is' = complementIntervals is</span>
<span class="lineno">   85 </span><span class="spaces">        </span><span class="nottickedoff">js' = complementIntervals js</span></span>
<span class="lineno">   86 </span>
<span class="lineno">   87 </span>differenceIntervals :: IList a -&gt; IList a -&gt; IList a
<span class="lineno">   88 </span><span class="decl"><span class="nottickedoff">differenceIntervals is js</span>
<span class="lineno">   89 </span><span class="spaces">  </span><span class="nottickedoff">= complementIntervals (unionIntervals is' js)</span>
<span class="lineno">   90 </span><span class="spaces">  </span><span class="nottickedoff">where is' = complementIntervals is</span></span>
<span class="lineno">   91 </span>
<span class="lineno">   92 </span>complementIntervals :: IList a -&gt; IList a
<span class="lineno">   93 </span><span class="decl"><span class="nottickedoff">complementIntervals (o1, is, o2)</span>
<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>
<span class="lineno">   95 </span>
<span class="lineno">   96 </span>-- tests...
<span class="lineno">   97 </span>
<span class="lineno">   98 </span>{-
<span class="lineno">   99 </span>mkIn, mkOut :: Double -&gt; Intersection a
<span class="lineno">  100 </span>mkIn x = (x, True, undefined)
<span class="lineno">  101 </span>mkOut x = (x, False, undefined)
<span class="lineno">  102 </span>
<span class="lineno">  103 </span>i1 =  (False, [ mkIn 2, mkOut 7 ], False)
<span class="lineno">  104 </span>i1' = (True, [ mkOut 2, mkIn 7 ], True)
<span class="lineno">  105 </span>i2 =  (False, [ mkIn 1, mkOut 3, mkIn 4, mkOut 5, mkIn 6, mkOut 8 ], False)
<span class="lineno">  106 </span>
<span class="lineno">  107 </span>t1 = unionIntervals i1 i2
<span class="lineno">  108 </span>t2 = intersectIntervals i1 i2
<span class="lineno">  109 </span>t3 = intersectIntervals i2 i1
<span class="lineno">  110 </span>t4 = complementIntervals i1
<span class="lineno">  111 </span>t5 = intersectIntervals i2 i1'
<span class="lineno">  112 </span>t6 = differenceIntervals i2 i1
<span class="lineno">  113 </span>t7 = differenceIntervals i2 i2
<span class="lineno">  114 </span>
<span class="lineno">  115 </span>sh (o1,is,o2) =
<span class="lineno">  116 </span>    do  if o1 then putStr &quot;...&quot; else return ()
<span class="lineno">  117 </span>        putStr $ foldr1 (++) (map si is)
<span class="lineno">  118 </span>        if o2 then putStr &quot;...&quot; else return ()
<span class="lineno">  119 </span>si (i, True, _, _) = &quot;&lt;&quot; ++ show i
<span class="lineno">  120 </span>si (i, False, _, _) = &quot; &quot; ++ show i ++ &quot;&gt;&quot;
<span class="lineno">  121 </span>-}

</pre>
</html>
Writing: Surface.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Surface
<span class="lineno">    7 </span>    ( SurfaceFn (..)
<span class="lineno">    8 </span>    , Properties
<span class="lineno">    9 </span>    , sfun, sconst
<span class="lineno">   10 </span>    , prop
<span class="lineno">   11 </span>    , matte, shiny
<span class="lineno">   12 </span>    , chgColor
<span class="lineno">   13 </span>    , surface
<span class="lineno">   14 </span>    ) where
<span class="lineno">   15 </span>
<span class="lineno">   16 </span>import Geometry
<span class="lineno">   17 </span>import CSG
<span class="lineno">   18 </span>import Misc
<span class="lineno">   19 </span>
<span class="lineno">   20 </span>-- the surface gets passed face then u then v.
<span class="lineno">   21 </span>data SurfaceFn c v = SFun (Int -&gt; Double -&gt; Double -&gt; Properties c v)
<span class="lineno">   22 </span>                   | SConst (Properties c v)
<span class="lineno">   23 </span>
<span class="lineno">   24 </span>sfun :: (Int -&gt; Double -&gt; Double -&gt; Properties c v) -&gt; SurfaceFn c v
<span class="lineno">   25 </span><span class="decl"><span class="nottickedoff">sfun = SFun</span></span>
<span class="lineno">   26 </span>sconst :: Properties c v -&gt; SurfaceFn c v
<span class="lineno">   27 </span><span class="decl"><span class="nottickedoff">sconst = SConst</span></span>
<span class="lineno">   28 </span>
<span class="lineno">   29 </span>type Properties c v = (c, v, v, v)
<span class="lineno">   30 </span>
<span class="lineno">   31 </span><span class="decl"><span class="istickedoff">prop c d s p = (c, d, s, p)</span></span>
<span class="lineno">   32 </span>
<span class="lineno">   33 </span><span class="decl"><span class="nottickedoff">matte = (white, 1.0, 0.0, 1.0)</span></span>
<span class="lineno">   34 </span><span class="decl"><span class="nottickedoff">shiny = (white, 0.0, 1.0, 1.0)</span></span>
<span class="lineno">   35 </span>
<span class="lineno">   36 </span>chgColor :: c -&gt; Properties d v -&gt; Properties c v
<span class="lineno">   37 </span><span class="decl"><span class="nottickedoff">chgColor c (_, d, s, p) = (c, d, s, p)</span></span>
<span class="lineno">   38 </span>
<span class="lineno">   39 </span>instance (Show c, Show v) =&gt; Show (SurfaceFn c v) where
<span class="lineno">   40 </span>  <span class="decl"><span class="nottickedoff">show (SFun _)   = &quot;Surface function&quot;</span>
<span class="lineno">   41 </span><span class="spaces">  </span><span class="nottickedoff">-- show (SConst p) = &quot;Surface constant: &quot; ++ show p</span>
<span class="lineno">   42 </span><span class="spaces">  </span><span class="nottickedoff">show (SConst p) = &quot;Surface constant&quot;</span></span>
<span class="lineno">   43 </span>
<span class="lineno">   44 </span>evalSurface :: SurfaceFn Color Double -&gt; Int -&gt; Double -&gt; Double -&gt; Properties Color Double
<span class="lineno">   45 </span><span class="decl"><span class="istickedoff">evalSurface (SConst p) = <span class="nottickedoff">\_ _ _ -&gt; p</span></span>
<span class="lineno">   46 </span><span class="spaces"></span><span class="istickedoff">evalSurface (SFun f)   = f</span></span>
<span class="lineno">   47 </span>
<span class="lineno">   48 </span>-- calculate surface properties, given the type of
<span class="lineno">   49 </span>-- surface, and intersection point in object coordinates
<span class="lineno">   50 </span>
<span class="lineno">   51 </span>-- surface :: Surface SurfaceFn -&gt; (Int, Point) -&gt; (Vector, Properties)
<span class="lineno">   52 </span>
<span class="lineno">   53 </span><span class="decl"><span class="istickedoff">surface (Planar _ v0 v1) (n, p0, fn)</span>
<span class="lineno">   54 </span><span class="spaces">  </span><span class="istickedoff">= (norm, evalSurface fn <span class="nottickedoff">n'</span> u v)</span>
<span class="lineno">   55 </span><span class="spaces">  </span><span class="istickedoff">where norm = normalize $ cross v0 v1</span>
<span class="lineno">   56 </span><span class="spaces">        </span><span class="istickedoff">(n', u, v) = planarUV n p0</span>
<span class="lineno">   57 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   58 </span><span class="spaces"></span><span class="istickedoff">surface (Spherical _ v0 v1) (_, p0, fn)</span>
<span class="lineno">   59 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(norm, evalSurface fn 0 u v)</span></span>
<span class="lineno">   60 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">x = xCoord p0</span></span>
<span class="lineno">   61 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">y = yCoord p0</span></span>
<span class="lineno">   62 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">z = zCoord p0</span></span>
<span class="lineno">   63 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">k = sqrt (1 - sq y)</span></span>
<span class="lineno">   64 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">theta = adjustRadian (atan2 (x / k) (z / k))</span></span>
<span class="lineno">   65 </span><span class="spaces">        </span><span class="istickedoff">-- correct so that the image grows left-to-right</span>
<span class="lineno">   66 </span><span class="spaces">        </span><span class="istickedoff">-- instead of right-to-left</span>
<span class="lineno">   67 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">u = 1.0 - clampf (theta / (2 * pi))</span></span>
<span class="lineno">   68 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v =       clampf ((y + 1) / 2)</span></span>
<span class="lineno">   69 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">norm = normalize $ cross v0 v1</span></span>
<span class="lineno">   70 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   71 </span><span class="spaces"></span><span class="istickedoff">-- ZZ ignore the (incorrect) surface model, and estimate the normal</span>
<span class="lineno">   72 </span><span class="spaces"></span><span class="istickedoff">-- from the intersection in object space</span>
<span class="lineno">   73 </span><span class="spaces"></span><span class="istickedoff">surface (Cylindrical _ v0 v1) (_, p0, fn)</span>
<span class="lineno">   74 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(norm, evalSurface fn 0 u v)</span></span>
<span class="lineno">   75 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">x = xCoord p0</span></span>
<span class="lineno">   76 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">y = yCoord p0</span></span>
<span class="lineno">   77 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">z = zCoord p0</span></span>
<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>
<span class="lineno">   79 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v = y</span></span>
<span class="lineno">   80 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">norm = normalize $ cross v0 v1</span></span>
<span class="lineno">   81 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   82 </span><span class="spaces"></span><span class="istickedoff">-- ZZ ignore the (incorrect) surface model, and estimate the normal</span>
<span class="lineno">   83 </span><span class="spaces"></span><span class="istickedoff">-- from the intersection in object space</span>
<span class="lineno">   84 </span><span class="spaces"></span><span class="istickedoff">surface (Conic _ v0 v1) (_, p0, fn)</span>
<span class="lineno">   85 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">(norm, evalSurface fn 0 u v)</span></span>
<span class="lineno">   86 </span><span class="spaces">  </span><span class="istickedoff">where <span class="nottickedoff">x = xCoord p0</span></span>
<span class="lineno">   87 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">y = yCoord p0</span></span>
<span class="lineno">   88 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">z = zCoord p0</span></span>
<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>
<span class="lineno">   90 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">v = y</span></span>
<span class="lineno">   91 </span><span class="spaces">        </span><span class="istickedoff"><span class="nottickedoff">norm = normalize $ cross v0 v1</span></span></span>
<span class="lineno">   92 </span>
<span class="lineno">   93 </span><span class="decl"><span class="istickedoff">planarUV face p0</span>
<span class="lineno">   94 </span><span class="spaces">  </span><span class="istickedoff">= case face of</span>
<span class="lineno">   95 </span><span class="spaces">    </span><span class="istickedoff">PlaneFace      -&gt; (<span class="nottickedoff">0</span>, x, z)</span>
<span class="lineno">   96 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   97 </span><span class="spaces">    </span><span class="istickedoff">CubeFront      -&gt; (<span class="nottickedoff">0</span>, x, y)</span>
<span class="lineno">   98 </span><span class="spaces">    </span><span class="istickedoff">CubeBack       -&gt; <span class="nottickedoff">(1, x, y)</span></span>
<span class="lineno">   99 </span><span class="spaces">    </span><span class="istickedoff">CubeLeft       -&gt; (<span class="nottickedoff">2</span>, z, y)</span>
<span class="lineno">  100 </span><span class="spaces">    </span><span class="istickedoff">CubeRight      -&gt; <span class="nottickedoff">(3, z, y)</span></span>
<span class="lineno">  101 </span><span class="spaces">    </span><span class="istickedoff">CubeTop        -&gt; (<span class="nottickedoff">4</span>, x, z)</span>
<span class="lineno">  102 </span><span class="spaces">    </span><span class="istickedoff">CubeBottom     -&gt; (<span class="nottickedoff">5</span>, x, z)</span>
<span class="lineno">  103 </span><span class="spaces"></span><span class="istickedoff"></span>
<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>
<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>
<span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff"></span>
<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>
<span class="lineno">  108 </span><span class="spaces">  </span><span class="istickedoff">where x = xCoord p0</span>
<span class="lineno">  109 </span><span class="spaces">        </span><span class="istickedoff">y = yCoord p0</span>
<span class="lineno">  110 </span><span class="spaces">        </span><span class="istickedoff">z = zCoord p0</span></span>
<span class="lineno">  111 </span>
<span class="lineno">  112 </span>-- misc
<span class="lineno">  113 </span>
<span class="lineno">  114 </span>adjustRadian :: Radian -&gt; Radian
<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>

</pre>
</html>
Writing: Primitives.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Primitives where
<span class="lineno">    7 </span>
<span class="lineno">    8 </span>rad2deg :: Double -&gt; Double
<span class="lineno">    9 </span><span class="decl"><span class="nottickedoff">rad2deg r = r * 180 / pi</span></span>
<span class="lineno">   10 </span>
<span class="lineno">   11 </span>deg2rad :: Double -&gt; Double
<span class="lineno">   12 </span><span class="decl"><span class="istickedoff">deg2rad d = d * pi / 180</span></span>
<span class="lineno">   13 </span>
<span class="lineno">   14 </span>addi :: Int -&gt; Int -&gt; Int
<span class="lineno">   15 </span><span class="decl"><span class="nottickedoff">addi = (+)</span></span>
<span class="lineno">   16 </span>
<span class="lineno">   17 </span>addf :: Double -&gt; Double -&gt; Double
<span class="lineno">   18 </span><span class="decl"><span class="nottickedoff">addf = (+)</span></span>
<span class="lineno">   19 </span>
<span class="lineno">   20 </span>acosD :: Double -&gt; Double
<span class="lineno">   21 </span><span class="decl"><span class="nottickedoff">acosD x = acos x * 180 / pi</span></span>
<span class="lineno">   22 </span>
<span class="lineno">   23 </span>asinD :: Double -&gt; Double
<span class="lineno">   24 </span><span class="decl"><span class="nottickedoff">asinD x = asin x * 180 / pi</span></span>

</pre>
</html>
Writing: Eval.hs.html
<html><style type="text/css">
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
span.nottickedoff { background: yellow}
span.istickedoff { background: white }
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
span.tickonlytrue  { margin: -1px; border: 1px solid #60de51; background: #60de51 }
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
span.decl { font-weight: bold }
span.spaces    { background: white }
</style>
<pre>
<span class="lineno">    1 </span>-- Copyright (c) 2000 Galois Connections, Inc.
<span class="lineno">    2 </span>-- All rights reserved.  This software is distributed as
<span class="lineno">    3 </span>-- free software under the license in the file &quot;LICENSE&quot;,
<span class="lineno">    4 </span>-- which is included in the distribution.
<span class="lineno">    5 </span>
<span class="lineno">    6 </span>module Eval where
<span class="lineno">    7 </span>
<span class="lineno">    8 </span>import Array
<span class="lineno">    9 </span>
<span class="lineno">   10 </span>import Geometry
<span class="lineno">   11 </span>import CSG
<span class="lineno">   12 </span>import Surface
<span class="lineno">   13 </span>import Data
<span class="lineno">   14 </span>import Parse (rayParse, rayParseF)
<span class="lineno">   15 </span>
<span class="lineno">   16 </span>class Monad m =&gt; MonadEval m where
<span class="lineno">   17 </span>  doOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; m Stack
<span class="lineno">   18 </span>  tick :: m ()
<span class="lineno">   19 </span>  err  :: String -&gt; m a
<span class="lineno">   20 </span>
<span class="lineno">   21 </span>  <span class="decl"><span class="istickedoff">tick = return <span class="nottickedoff">()</span></span></span>
<span class="lineno">   22 </span>
<span class="lineno">   23 </span>newtype Pure a = Pure a deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
<span class="lineno">   24 </span>
<span class="lineno">   25 </span>instance Monad Pure where
<span class="lineno">   26 </span>    <span class="decl"><span class="istickedoff">Pure x &gt;&gt;= k = k x</span></span>
<span class="lineno">   27 </span>    <span class="decl"><span class="istickedoff">return       = Pure</span></span>
<span class="lineno">   28 </span>    <span class="decl"><span class="nottickedoff">fail s       = error s</span></span>
<span class="lineno">   29 </span>
<span class="lineno">   30 </span>instance MonadEval Pure where
<span class="lineno">   31 </span>  <span class="decl"><span class="istickedoff">doOp   = doPureOp</span></span> 
<span class="lineno">   32 </span>  <span class="decl"><span class="nottickedoff">err  s = error s</span></span>
<span class="lineno">   33 </span>
<span class="lineno">   34 </span>instance MonadEval IO where
<span class="lineno">   35 </span>  <span class="decl"><span class="istickedoff">doOp prim op stk = do { -- putStrLn (&quot;Calling &quot; ++ show op</span>
<span class="lineno">   36 </span><span class="spaces">                          </span><span class="istickedoff">--           ++ &quot; &lt;&lt; &quot; ++ show stk ++ &quot; &gt;&gt;&quot;)</span>
<span class="lineno">   37 </span><span class="spaces">                          </span><span class="istickedoff">doAllOp  prim op stk</span>
<span class="lineno">   38 </span><span class="spaces">                        </span><span class="istickedoff">}</span></span>
<span class="lineno">   39 </span>  <span class="decl"><span class="nottickedoff">err  s = error s</span></span>
<span class="lineno">   40 </span>
<span class="lineno">   41 </span>data State
<span class="lineno">   42 </span>        = State { env   :: Env
<span class="lineno">   43 </span>                , stack :: Stack
<span class="lineno">   44 </span>                , code  :: Code
<span class="lineno">   45 </span>                } deriving <span class="decl"><span class="nottickedoff"><span class="decl"><span class="nottickedoff">Show</span></span></span></span>
<span class="lineno">   46 </span>
<span class="lineno">   47 </span>callback :: Env -&gt; Code -&gt; Stack -&gt; Stack
<span class="lineno">   48 </span><span class="decl"><span class="istickedoff">callback env code stk</span>
<span class="lineno">   49 </span><span class="spaces">      </span><span class="istickedoff">= case eval (State { env = env, stack = stk, code = code}) of</span>
<span class="lineno">   50 </span><span class="spaces">             </span><span class="istickedoff">Pure stk -&gt; stk</span></span>
<span class="lineno">   51 </span>
<span class="lineno">   52 </span>{-# SPECIALIZE eval ::  State -&gt; Pure Stack #-}
<span class="lineno">   53 </span>{-# SPECIALIZE eval ::  State -&gt; IO Stack #-}
<span class="lineno">   54 </span>
<span class="lineno">   55 </span>eval :: MonadEval m =&gt; State -&gt; m Stack
<span class="lineno">   56 </span><span class="decl"><span class="istickedoff">eval st =</span>
<span class="lineno">   57 </span><span class="spaces">  </span><span class="istickedoff">do { () &lt;- return () -- $ unsafePerformIO (print st)   -- Functional debugger</span>
<span class="lineno">   58 </span><span class="spaces">     </span><span class="istickedoff">; if moreCode st then</span>
<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>
<span class="lineno">   60 </span><span class="spaces">            </span><span class="istickedoff">; st' &lt;- step st</span>
<span class="lineno">   61 </span><span class="spaces">            </span><span class="istickedoff">; eval st'</span>
<span class="lineno">   62 </span><span class="spaces">            </span><span class="istickedoff">}</span>
<span class="lineno">   63 </span><span class="spaces">        </span><span class="istickedoff">else return (stack st)</span>
<span class="lineno">   64 </span><span class="spaces">     </span><span class="istickedoff">}</span></span>
<span class="lineno">   65 </span>     
<span class="lineno">   66 </span>moreCode :: State -&gt; Bool
<span class="lineno">   67 </span><span class="decl"><span class="istickedoff">moreCode (State {code = []}) = False</span>
<span class="lineno">   68 </span><span class="spaces"></span><span class="istickedoff">moreCode _                   = True</span></span>
<span class="lineno">   69 </span>
<span class="lineno">   70 </span>-- Step has a precondition that there *is* code to run
<span class="lineno">   71 </span>{-# SPECIALIZE step ::  State -&gt; Pure State #-}
<span class="lineno">   72 </span>{-# SPECIALIZE step ::  State -&gt; IO State #-}
<span class="lineno">   73 </span>step :: MonadEval m =&gt; State -&gt; m State
<span class="lineno">   74 </span>
<span class="lineno">   75 </span>-- Rule 1: Pushing BaseValues
<span class="lineno">   76 </span><span class="decl"><span class="istickedoff">step st@(State{ stack = stack, code = (TBool b):cs })    </span>
<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>
<span class="lineno">   78 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ stack = stack, code = (TInt i):cs })     </span>
<span class="lineno">   79 </span><span class="spaces">    </span><span class="istickedoff">= return (st { stack = (VInt i):stack,     code = cs })</span>
<span class="lineno">   80 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ stack = stack, code = (TReal r):cs })    </span>
<span class="lineno">   81 </span><span class="spaces">    </span><span class="istickedoff">= return (st { stack = (VReal r):stack,    code = cs })</span>
<span class="lineno">   82 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ stack = stack, code = (TString s):cs })  </span>
<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>
<span class="lineno">   84 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   85 </span><span class="spaces"></span><span class="istickedoff">-- Rule 2: Name binding</span>
<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>
<span class="lineno">   87 </span><span class="spaces">  </span><span class="istickedoff">return (State { env = extendEnv env id v, stack = stack,  code = cs })</span>
<span class="lineno">   88 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = [], code = (TBind id):cs }) =</span>
<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>
<span class="lineno">   90 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   91 </span><span class="spaces"></span><span class="istickedoff">-- Rule 3: Name lookup</span>
<span class="lineno">   92 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = (TId id):cs }) =</span>
<span class="lineno">   93 </span><span class="spaces">  </span><span class="istickedoff">case (lookupEnv env id) of</span>
<span class="lineno">   94 </span><span class="spaces">  </span><span class="istickedoff">Just v -&gt; return (st { stack = v:stack,  code = cs })</span>
<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>
<span class="lineno">   96 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">   97 </span><span class="spaces"></span><span class="istickedoff">-- Rule 4: Closure creation</span>
<span class="lineno">   98 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = (TBody body):cs }) =</span>
<span class="lineno">   99 </span><span class="spaces">  </span><span class="istickedoff">return (st { stack = (VClosure env body):stack, code = cs })</span>
<span class="lineno">  100 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  101 </span><span class="spaces"></span><span class="istickedoff">-- Rule 5: Application</span>
<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>
<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>
<span class="lineno">  104 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
<span class="lineno">  105 </span><span class="spaces">     </span><span class="istickedoff">}</span>
<span class="lineno">  106 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = [], code = TApply:cs }) =</span>
<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>
<span class="lineno">  108 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = _:_, code = TApply:cs }) =</span>
<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>
<span class="lineno">  110 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  111 </span><span class="spaces"></span><span class="istickedoff">-- Rule 6: Arrays</span>
<span class="lineno">  112 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = TArray code':cs }) =</span>
<span class="lineno">  113 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- eval (State {env = env, stack = [], code = code'})</span>
<span class="lineno">  114 </span><span class="spaces">     </span><span class="istickedoff">; let last = length stk-1</span>
<span class="lineno">  115 </span><span class="spaces">     </span><span class="istickedoff">; let arr = array (0,last) (zip [last,last-1..] stk)</span>
<span class="lineno">  116 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = (VArray arr):stack, code = cs })</span>
<span class="lineno">  117 </span><span class="spaces">     </span><span class="istickedoff">}</span>
<span class="lineno">  118 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  119 </span><span class="spaces"></span><span class="istickedoff">-- Rule 7 &amp; 8: If statement</span>
<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>
<span class="lineno">  121 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- eval (State {env = e1, stack = stack, code = c1})</span>
<span class="lineno">  122 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
<span class="lineno">  123 </span><span class="spaces">     </span><span class="istickedoff">}</span>
<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>
<span class="lineno">  125 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- eval (State {env = e2, stack = stack, code = c2})</span>
<span class="lineno">  126 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
<span class="lineno">  127 </span><span class="spaces">     </span><span class="istickedoff">}</span>
<span class="lineno">  128 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = _, code = TIf:cs }) =</span>
<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>
<span class="lineno">  130 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  131 </span><span class="spaces"></span><span class="istickedoff">-- Rule 9: Operators</span>
<span class="lineno">  132 </span><span class="spaces"></span><span class="istickedoff">step st@(State{ env = env, stack = stack, code = (TOp op):cs }) =</span>
<span class="lineno">  133 </span><span class="spaces">  </span><span class="istickedoff">do { stk &lt;- doOp (opFnTable ! op) op stack</span>
<span class="lineno">  134 </span><span class="spaces">     </span><span class="istickedoff">; return (st { stack = stk, code = cs })</span>
<span class="lineno">  135 </span><span class="spaces">     </span><span class="istickedoff">}</span>
<span class="lineno">  136 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  137 </span><span class="spaces"></span><span class="istickedoff">-- Rule Opps</span>
<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>
<span class="lineno">  139 </span>
<span class="lineno">  140 </span>
<span class="lineno">  141 </span>--------------------------------------------------------------------------
<span class="lineno">  142 </span>-- Operator code
<span class="lineno">  143 </span>
<span class="lineno">  144 </span>opFnTable :: Array GMLOp PrimOp
<span class="lineno">  145 </span><span class="decl"><span class="istickedoff">opFnTable = array (minBound,maxBound) </span>
<span class="lineno">  146 </span><span class="spaces">                  </span><span class="istickedoff">[ (op,prim) | (_,TOp op,prim) &lt;- opcodes ]</span></span>
<span class="lineno">  147 </span>
<span class="lineno">  148 </span>
<span class="lineno">  149 </span>
<span class="lineno">  150 </span>
<span class="lineno">  151 </span>doPureOp :: (MonadEval m) =&gt; PrimOp -&gt; GMLOp -&gt; Stack -&gt; m Stack
<span class="lineno">  152 </span><span class="decl"><span class="istickedoff">doPureOp _ Op_render _ = </span>
<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>
<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
<span class="lineno">  155 </span>
<span class="lineno">  156 </span>{-# SPECIALIZE doPrimOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; Pure Stack #-}
<span class="lineno">  157 </span>{-# SPECIALIZE doPrimOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; IO Stack #-}
<span class="lineno">  158 </span>{-# SPECIALIZE doPrimOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; Abs Stack #-}
<span class="lineno">  159 </span>
<span class="lineno">  160 </span>doPrimOp ::  (MonadEval m) =&gt; PrimOp -&gt; GMLOp -&gt; Stack -&gt; m Stack
<span class="lineno">  161 </span>
<span class="lineno">  162 </span>-- 1 argument.
<span class="lineno">  163 </span>
<span class="lineno">  164 </span><span class="decl"><span class="istickedoff">doPrimOp (Int_Int fn) _ (VInt i1:stk)</span>
<span class="lineno">  165 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">return ((VInt (fn i1)) : stk)</span></span>
<span class="lineno">  166 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Real fn) _ (VReal r1:stk)</span>
<span class="lineno">  167 </span><span class="spaces">  </span><span class="istickedoff">= return ((VReal (fn r1)) : stk)</span>
<span class="lineno">  168 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Point_Real fn) _ (VPoint x y z:stk)</span>
<span class="lineno">  169 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">return ((VReal (fn x y z)) : stk)</span></span>
<span class="lineno">  170 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  171 </span><span class="spaces"></span><span class="istickedoff">-- This is where the callbacks happen from...</span>
<span class="lineno">  172 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)</span>
<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>
<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>
<span class="lineno">  175 </span><span class="spaces">           </span><span class="istickedoff"><span class="nottickedoff">let</span></span>
<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>
<span class="lineno">  177 </span><span class="spaces">           </span><span class="istickedoff"><span class="nottickedoff">in</span></span>
<span class="lineno">  178 </span><span class="spaces">               </span><span class="istickedoff"><span class="nottickedoff">return ((VObject (fn (SConst res))) : stk)</span></span>
<span class="lineno">  179 </span><span class="spaces">      </span><span class="istickedoff">_ -&gt; return ((VObject (fn (SFun call))) : stk)</span>
<span class="lineno">  180 </span><span class="spaces">  </span><span class="istickedoff">where </span>
<span class="lineno">  181 </span><span class="spaces">        </span><span class="istickedoff">-- The most general case</span>
<span class="lineno">  182 </span><span class="spaces">        </span><span class="istickedoff">call i r1 r2 =</span>
<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>
<span class="lineno">  184 </span><span class="spaces">             </span><span class="istickedoff">[VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] </span>
<span class="lineno">  185 </span><span class="spaces">                 </span><span class="istickedoff">-&gt; prop (color c1 c2 c3) r1 r2 r3</span>
<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>
<span class="lineno">  187 </span><span class="spaces">                         </span><span class="istickedoff"><span class="nottickedoff">++ show stk)</span></span>
<span class="lineno">  188 </span><span class="spaces">       </span><span class="istickedoff"></span>
<span class="lineno">  189 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Int fn) _ (VReal r1:stk)</span>
<span class="lineno">  190 </span><span class="spaces">  </span><span class="istickedoff">= return ((VInt (fn r1)) : stk)</span>
<span class="lineno">  191 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Int_Real fn) _ (VInt r1:stk)</span>
<span class="lineno">  192 </span><span class="spaces">  </span><span class="istickedoff">= return ((VReal (fn r1)) : stk)</span>
<span class="lineno">  193 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Arr_Int fn) _ (VArray arr:stk)</span>
<span class="lineno">  194 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">return ((VInt (fn arr)) : stk)</span></span>
<span class="lineno">  195 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  196 </span><span class="spaces"></span><span class="istickedoff">-- 2 arguments.</span>
<span class="lineno">  197 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  198 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk)</span>
<span class="lineno">  199 </span><span class="spaces">  </span><span class="istickedoff">= return ((VInt (fn i1 i2)) : stk)</span>
<span class="lineno">  200 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk)</span>
<span class="lineno">  201 </span><span class="spaces">  </span><span class="istickedoff">= return ((VBool (fn i1 i2)) : stk)</span>
<span class="lineno">  202 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk)</span>
<span class="lineno">  203 </span><span class="spaces">  </span><span class="istickedoff">= return ((VReal (fn r1 r2)) : stk)</span>
<span class="lineno">  204 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk)</span>
<span class="lineno">  205 </span><span class="spaces">  </span><span class="istickedoff">= return ((VBool (fn r1 r2)) : stk)</span>
<span class="lineno">  206 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk)</span>
<span class="lineno">  207 </span><span class="spaces">  </span><span class="istickedoff">= return ((fn arr i) : stk)</span>
<span class="lineno">  208 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  209 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  210 </span><span class="spaces">    </span><span class="istickedoff">-- Many arguments, typically image mangling</span>
<span class="lineno">  211 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  212 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk)</span>
<span class="lineno">  213 </span><span class="spaces">  </span><span class="istickedoff">= return ((VObject (fn o1 o2)) : <span class="nottickedoff">stk</span>)</span>
<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>
<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>
<span class="lineno">  216 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Point_Point_Color_Real_Real_Light fn) _ </span>
<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>
<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>
<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>
<span class="lineno">  220 </span><span class="spaces">  </span><span class="istickedoff">= return ((fn r1 r2 r3) : stk)</span>
<span class="lineno">  221 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk)</span>
<span class="lineno">  222 </span><span class="spaces">  </span><span class="istickedoff">= return (VObject (fn o r) : <span class="nottickedoff">stk</span>)</span>
<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>
<span class="lineno">  224 </span><span class="spaces">  </span><span class="istickedoff">= return (VObject (fn o r1 r2 r3) : stk)</span>
<span class="lineno">  225 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  226 </span><span class="spaces"></span><span class="istickedoff">-- This one is our testing harness</span>
<span class="lineno">  227 </span><span class="spaces"></span><span class="istickedoff">doPrimOp (Value_String_Value fn) _ (VString s:o:stk)</span>
<span class="lineno">  228 </span><span class="spaces">  </span><span class="istickedoff">= <span class="nottickedoff">res `seq` return (res : stk)</span></span>
<span class="lineno">  229 </span><span class="spaces">  </span><span class="istickedoff">where</span>
<span class="lineno">  230 </span><span class="spaces">     </span><span class="istickedoff"><span class="nottickedoff">res = fn o s</span></span>
<span class="lineno">  231 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  232 </span><span class="spaces"></span><span class="istickedoff">doPrimOp primOp op args </span>
<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>
<span class="lineno">  234 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">show op ++ &quot;\&quot;\n\n| &quot; ++</span></span>
<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>
<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>
<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>
<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>
<span class="lineno">  239 </span><span class="spaces">                  </span><span class="istickedoff"><span class="nottickedoff">are ++ &quot;\n|\n| &quot; ++ </span></span>
<span class="lineno">  240 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">unwords [ &quot;(&quot; ++ show arg ++ &quot;)&quot; </span></span>
<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>
<span class="lineno">  242 </span><span class="spaces">          </span><span class="istickedoff"><span class="nottickedoff">++ &quot;    (top of stack is on the right hand side)\n\n&quot;)</span></span>
<span class="lineno">  243 </span><span class="spaces">  </span><span class="istickedoff">where</span>
<span class="lineno">  244 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">len   = length types</span></span>
<span class="lineno">  245 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">s =  (if len /= 1 then &quot;s&quot; else &quot;&quot;)</span></span>
<span class="lineno">  246 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">are =  (if len /= 1 then &quot;are&quot; else &quot;is&quot;)</span></span>
<span class="lineno">  247 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">the =  (if len /= 1 then &quot;&quot; else &quot; the&quot;)</span></span>
<span class="lineno">  248 </span><span class="spaces">      </span><span class="istickedoff"><span class="nottickedoff">types = getPrimOpType primOp</span></span></span>
<span class="lineno">  249 </span>
<span class="lineno">  250 </span>
<span class="lineno">  251 </span>-- Render is somewhat funny, becauase it can only get called at top level.
<span class="lineno">  252 </span>-- All other operations are purely functional.
<span class="lineno">  253 </span>
<span class="lineno">  254 </span>doAllOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; IO Stack
<span class="lineno">  255 </span><span class="decl"><span class="istickedoff">doAllOp (Render render) Op_render</span>
<span class="lineno">  256 </span><span class="spaces">                           </span><span class="istickedoff">(VString str:VInt ht:VInt wid:VReal fov</span>
<span class="lineno">  257 </span><span class="spaces">                           </span><span class="istickedoff">:VInt dep:VObject obj:VArray arr</span>
<span class="lineno">  258 </span><span class="spaces">                           </span><span class="istickedoff">:VPoint r g b : stk)</span>
<span class="lineno">  259 </span><span class="spaces">  </span><span class="istickedoff">= do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht <span class="nottickedoff">str</span></span>
<span class="lineno">  260 </span><span class="spaces">       </span><span class="istickedoff">; return <span class="nottickedoff">stk</span></span>
<span class="lineno">  261 </span><span class="spaces">       </span><span class="istickedoff">}</span>
<span class="lineno">  262 </span><span class="spaces">  </span><span class="istickedoff">where</span>
<span class="lineno">  263 </span><span class="spaces">      </span><span class="istickedoff">lights = [ light | (VLight light) &lt;- elems arr ]</span>
<span class="lineno">  264 </span><span class="spaces"></span><span class="istickedoff"></span>
<span class="lineno">  265 </span><span class="spaces"></span><span class="istickedoff">doAllOp primOp op stk = doPrimOp primOp <span class="nottickedoff">op</span> stk</span></span> -- call the purely functional operators
<span class="lineno">  266 </span>
<span class="lineno">  267 </span>------------------------------------------------------------------------------
<span class="lineno">  268 </span>{-
<span class="lineno">  269 </span> - Abstract evaluation.
<span class="lineno">  270 </span> -
<span class="lineno">  271 </span> - The idea is you check for constant code that 
<span class="lineno">  272 </span> - (1) does not look at its arguments
<span class="lineno">  273 </span> - (2) gives a fixed result
<span class="lineno">  274 </span> -
<span class="lineno">  275 </span> - We run for 100 steps.
<span class="lineno">  276 </span> -
<span class="lineno">  277 </span> -}
<span class="lineno">  278 </span>
<span class="lineno">  279 </span>absapply :: Env -&gt; Code -&gt; Stack -&gt; Maybe Stack
<span class="lineno">  280 </span><span class="decl"><span class="istickedoff">absapply env code stk = </span>
<span class="lineno">  281 </span><span class="spaces">     </span><span class="istickedoff">case runAbs (eval (State env stk code)) 100 of</span>
<span class="lineno">  282 </span><span class="spaces">       </span><span class="istickedoff">AbsState stk _ -&gt; <span class="nottickedoff">Just stk</span></span>
<span class="lineno">  283 </span><span class="spaces">       </span><span class="istickedoff">AbsFail m      -&gt; Nothing</span></span>
<span class="lineno">  284 </span>
<span class="lineno">  285 </span>newtype Abs a   = Abs { runAbs :: Int -&gt; AbsState a }
<span class="lineno">  286 </span>data AbsState a = AbsState a !Int
<span class="lineno">  287 </span>                | AbsFail String
<span class="lineno">  288 </span>
<span class="lineno">  289 </span>instance Monad Abs where
<span class="lineno">  290 </span>    <span class="decl"><span class="istickedoff">(Abs fn) &gt;&gt;= k = Abs (\ s -&gt; case fn s of</span>
<span class="lineno">  291 </span><span class="spaces">                                   </span><span class="istickedoff">AbsState r s' -&gt; runAbs (k r) s'</span>
<span class="lineno">  292 </span><span class="spaces">                                   </span><span class="istickedoff">AbsFail m     -&gt; AbsFail <span class="nottickedoff">m</span>)</span></span>
<span class="lineno">  293 </span>    <span class="decl"><span class="istickedoff">return x     = Abs (\ n -&gt; AbsState x n)</span></span>
<span class="lineno">  294 </span>    <span class="decl"><span class="istickedoff">fail s       = Abs (\ n -&gt; AbsFail <span class="nottickedoff">s</span>)</span></span>
<span class="lineno">  295 </span>
<span class="lineno">  296 </span>instance MonadEval Abs where
<span class="lineno">  297 </span>  <span class="decl"><span class="istickedoff">doOp = doAbsOp</span></span>
<span class="lineno">  298 </span>  <span class="decl"><span class="istickedoff">err  = fail</span></span>
<span class="lineno">  299 </span>  <span class="decl"><span class="istickedoff">tick = Abs (\ n -&gt; if <span class="tickonlyfalse">n &lt;= 0</span></span>
<span class="lineno">  300 </span><span class="spaces">                     </span><span class="istickedoff">then <span class="nottickedoff">AbsFail &quot;run out of time&quot;</span></span>
<span class="lineno">  301 </span><span class="spaces">                     </span><span class="istickedoff">else AbsState <span class="nottickedoff">()</span> (n-1))</span></span>
<span class="lineno">  302 </span>
<span class="lineno">  303 </span>doAbsOp :: PrimOp -&gt; GMLOp -&gt; Stack -&gt; Abs Stack
<span class="lineno">  304 </span><span class="decl"><span class="istickedoff">doAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk) </span>
<span class="lineno">  305 </span><span class="spaces">               </span><span class="istickedoff">= <span class="nottickedoff">return ((VPoint r1 r2 r3) : stk)</span></span>
<span class="lineno">  306 </span><span class="spaces"> </span><span class="istickedoff">-- here, you could have an (AbsPoint :: AbsObj) which you put on the</span>
<span class="lineno">  307 </span><span class="spaces"> </span><span class="istickedoff">-- stack, with any object in the three fields.</span>
<span class="lineno">  308 </span><span class="spaces"></span><span class="istickedoff">doAbsOp _ op _ = err <span class="nottickedoff">(&quot;operator not understood (&quot; ++ show op ++ &quot;)&quot;)</span></span></span>
<span class="lineno">  309 </span>
<span class="lineno">  310 </span>------------------------------------------------------------------------------
<span class="lineno">  311 </span>-- Driver
<span class="lineno">  312 </span>
<span class="lineno">  313 </span>mainEval :: Code -&gt; IO ()
<span class="lineno">  314 </span><span class="decl"><span class="istickedoff">mainEval prog = do { stk &lt;- eval (State <span class="nottickedoff">emptyEnv</span> [] prog) </span>
<span class="lineno">  315 </span><span class="spaces">                   </span><span class="istickedoff">; return <span class="nottickedoff">()</span></span>
<span class="lineno">  316 </span><span class="spaces">                   </span><span class="istickedoff">}</span></span>
<span class="lineno">  317 </span>{- 
<span class="lineno">  318 </span>  * Oops, one of the example actually has something
<span class="lineno">  319 </span>  * on the stack at the end. 
<span class="lineno">  320 </span>  * Oh well...
<span class="lineno">  321 </span>                  ; if null stk
<span class="lineno">  322 </span>                     then return ()
<span class="lineno">  323 </span>                    else do { putStrLn done
<span class="lineno">  324 </span>                             ; print stk
<span class="lineno">  325 </span>                             }
<span class="lineno">  326 </span>-}
<span class="lineno">  327 </span>
<span class="lineno">  328 </span><span class="decl"><span class="nottickedoff">done = &quot;Items still on stack at (successfull) termination of program&quot;</span></span>
<span class="lineno">  329 </span>
<span class="lineno">  330 </span>------------------------------------------------------------------------------
<span class="lineno">  331 </span>-- testing
<span class="lineno">  332 </span>
<span class="lineno">  333 </span>test :: String -&gt; Pure Stack
<span class="lineno">  334 </span><span class="decl"><span class="nottickedoff">test is = eval (State emptyEnv [] (rayParse is))</span></span>
<span class="lineno">  335 </span>
<span class="lineno">  336 </span>testF :: String -&gt; IO Stack
<span class="lineno">  337 </span><span class="decl"><span class="nottickedoff">testF is = do prog &lt;- rayParseF is</span>
<span class="lineno">  338 </span><span class="spaces">              </span><span class="nottickedoff">eval (State emptyEnv [] prog)</span></span>
<span class="lineno">  339 </span>
<span class="lineno">  340 </span>testA :: String -&gt; Either String (Stack,Int)
<span class="lineno">  341 </span><span class="decl"><span class="nottickedoff">testA is = case runAbs (eval (State emptyEnv </span>
<span class="lineno">  342 </span><span class="spaces">                                    </span><span class="nottickedoff">[VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV]</span>
<span class="lineno">  343 </span><span class="spaces">                                    </span><span class="nottickedoff">(rayParse is))) 100 of</span>
<span class="lineno">  344 </span><span class="spaces">             </span><span class="nottickedoff">AbsState a n -&gt; Right (a,n)</span>
<span class="lineno">  345 </span><span class="spaces">             </span><span class="nottickedoff">AbsFail m -&gt; Left m</span></span>
<span class="lineno">  346 </span>
<span class="lineno">  347 </span><span class="decl"><span class="nottickedoff">abstest1 = &quot;1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply&quot;</span></span> 
<span class="lineno">  348 </span>
<span class="lineno">  349 </span>-- should be [3:: Int]
<span class="lineno">  350 </span><span class="decl"><span class="nottickedoff">et1 = test &quot;1 /x { x } /f 2 /x f apply x addi&quot;</span></span>
<span class="lineno">  351 </span>
<span class="lineno">  352 </span>
<span class="lineno">  353 </span>
<span class="lineno">  354 </span>
<span class="lineno">  355 </span>

</pre>
</html>
Writing: hpc_index.html
<html><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51;  }
td.invbar { background-color: #f25913;  }
table.dashboard { border-collapse: collapse  ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
</style>
<table class="dashboard" width="100%" border=1>
<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
<td>&nbsp;&nbsp;<tt>module <a href="CSG.hs.html">CSG</a></tt></td>
<td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Construct.hs.html">Construct</a></tt></td>
<td align="right">41%</td><td>17/41</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>5/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">60%</td><td>381/635</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Data.hs.html">Data</a></tt></td>
<td align="right">22%</td><td>10/45</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="22%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">3%</td><td>2/51</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="3%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>254/646</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Eval.hs.html">Eval</a></tt></td>
<td align="right">62%</td><td>22/35</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="62%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">59%</td><td>40/67</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="59%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">57%</td><td>361/628</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="57%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Geometry.hs.html">Geometry</a></tt></td>
<td align="right">58%</td><td>42/72</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">40%</td><td>4/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="40%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">70%</td><td>300/427</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="70%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Illumination.hs.html">Illumination</a></tt></td>
<td align="right">45%</td><td>11/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="45%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>16/42</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">44%</td><td>299/678</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="44%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Intersections.hs.html">Intersections</a></tt></td>
<td align="right">63%</td><td>14/22</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="63%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>35/83</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>382/1001</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Interval.hs.html">Interval</a></tt></td>
<td align="right">47%</td><td>8/17</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="47%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>9/23</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>69/165</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Main.hs.html">Main</a></tt></td>
<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">100%</td><td>6/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Misc.hs.html">Misc</a></tt></td>
<td align="right">0%</td><td>0/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">0%</td><td>0/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Parse.hs.html">Parse</a></tt></td>
<td align="right">80%</td><td>16/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="80%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>6/14</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">72%</td><td>192/264</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="72%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Primitives.hs.html">Primitives</a></tt></td>
<td align="right">16%</td><td>1/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="16%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">20%</td><td>5/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="20%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Surface.hs.html">Surface</a></tt></td>
<td align="right">36%</td><td>4/11</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="36%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">35%</td><td>7/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="35%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">18%</td><td>43/231</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="18%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr></tr><tr style="background: #e0e0e0">
<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>
<td align="right">49%</td><td>146/295</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="49%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>124/322</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">48%</td><td>2292/4715</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="48%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
</table></html>
Writing: hpc_index_fun.html
<html><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51;  }
td.invbar { background-color: #f25913;  }
table.dashboard { border-collapse: collapse  ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
</style>
<table class="dashboard" width="100%" border=1>
<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
<td>&nbsp;&nbsp;<tt>module <a href="Main.hs.html">Main</a></tt></td>
<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">100%</td><td>6/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Parse.hs.html">Parse</a></tt></td>
<td align="right">80%</td><td>16/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="80%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>6/14</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">72%</td><td>192/264</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="72%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Intersections.hs.html">Intersections</a></tt></td>
<td align="right">63%</td><td>14/22</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="63%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>35/83</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>382/1001</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Eval.hs.html">Eval</a></tt></td>
<td align="right">62%</td><td>22/35</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="62%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">59%</td><td>40/67</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="59%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">57%</td><td>361/628</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="57%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Geometry.hs.html">Geometry</a></tt></td>
<td align="right">58%</td><td>42/72</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">40%</td><td>4/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="40%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">70%</td><td>300/427</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="70%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Interval.hs.html">Interval</a></tt></td>
<td align="right">47%</td><td>8/17</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="47%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>9/23</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>69/165</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Illumination.hs.html">Illumination</a></tt></td>
<td align="right">45%</td><td>11/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="45%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>16/42</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">44%</td><td>299/678</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="44%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Construct.hs.html">Construct</a></tt></td>
<td align="right">41%</td><td>17/41</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>5/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">60%</td><td>381/635</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Surface.hs.html">Surface</a></tt></td>
<td align="right">36%</td><td>4/11</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="36%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">35%</td><td>7/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="35%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">18%</td><td>43/231</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="18%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Data.hs.html">Data</a></tt></td>
<td align="right">22%</td><td>10/45</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="22%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">3%</td><td>2/51</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="3%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>254/646</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Primitives.hs.html">Primitives</a></tt></td>
<td align="right">16%</td><td>1/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="16%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">20%</td><td>5/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="20%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Misc.hs.html">Misc</a></tt></td>
<td align="right">0%</td><td>0/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">0%</td><td>0/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="CSG.hs.html">CSG</a></tt></td>
<td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td></tr>
<tr></tr><tr style="background: #e0e0e0">
<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>
<td align="right">49%</td><td>146/295</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="49%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>124/322</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">48%</td><td>2292/4715</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="48%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
</table></html>
Writing: hpc_index_alt.html
<html><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51;  }
td.invbar { background-color: #f25913;  }
table.dashboard { border-collapse: collapse  ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
</style>
<table class="dashboard" width="100%" border=1>
<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
<td>&nbsp;&nbsp;<tt>module <a href="Eval.hs.html">Eval</a></tt></td>
<td align="right">62%</td><td>22/35</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="62%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">59%</td><td>40/67</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="59%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">57%</td><td>361/628</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="57%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Parse.hs.html">Parse</a></tt></td>
<td align="right">80%</td><td>16/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="80%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>6/14</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">72%</td><td>192/264</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="72%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Intersections.hs.html">Intersections</a></tt></td>
<td align="right">63%</td><td>14/22</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="63%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>35/83</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>382/1001</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Construct.hs.html">Construct</a></tt></td>
<td align="right">41%</td><td>17/41</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>5/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">60%</td><td>381/635</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Geometry.hs.html">Geometry</a></tt></td>
<td align="right">58%</td><td>42/72</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">40%</td><td>4/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="40%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">70%</td><td>300/427</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="70%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Interval.hs.html">Interval</a></tt></td>
<td align="right">47%</td><td>8/17</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="47%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>9/23</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>69/165</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Illumination.hs.html">Illumination</a></tt></td>
<td align="right">45%</td><td>11/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="45%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>16/42</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">44%</td><td>299/678</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="44%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Surface.hs.html">Surface</a></tt></td>
<td align="right">36%</td><td>4/11</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="36%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">35%</td><td>7/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="35%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">18%</td><td>43/231</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="18%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Data.hs.html">Data</a></tt></td>
<td align="right">22%</td><td>10/45</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="22%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">3%</td><td>2/51</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="3%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>254/646</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Main.hs.html">Main</a></tt></td>
<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">100%</td><td>6/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="CSG.hs.html">CSG</a></tt></td>
<td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Misc.hs.html">Misc</a></tt></td>
<td align="right">0%</td><td>0/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">0%</td><td>0/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Primitives.hs.html">Primitives</a></tt></td>
<td align="right">16%</td><td>1/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="16%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">20%</td><td>5/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="20%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr></tr><tr style="background: #e0e0e0">
<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>
<td align="right">49%</td><td>146/295</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="49%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>124/322</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">48%</td><td>2292/4715</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="48%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
</table></html>
Writing: hpc_index_exp.html
<html><style type="text/css">table.bar { background-color: #f25913; }
td.bar { background-color: #60de51;  }
td.invbar { background-color: #f25913;  }
table.dashboard { border-collapse: collapse  ; border: solid 1px black }
.dashboard td { border: solid 1px black }
.dashboard th { border: solid 1px black }
</style>
<table class="dashboard" width="100%" border=1>
<tr><th rowspan=2><a href="hpc_index.html">module</a></th><th colspan=3><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan=3><a href="hpc_index_alt.html">Alternatives</a></th><th colspan=3><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th><th>%</th><th colspan=2>covered / total</th></tr><tr>
<td>&nbsp;&nbsp;<tt>module <a href="Main.hs.html">Main</a></tt></td>
<td align="right">100%</td><td>1/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">100%</td><td>6/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Parse.hs.html">Parse</a></tt></td>
<td align="right">80%</td><td>16/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="80%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>6/14</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">72%</td><td>192/264</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="72%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Geometry.hs.html">Geometry</a></tt></td>
<td align="right">58%</td><td>42/72</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="58%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">40%</td><td>4/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="40%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">70%</td><td>300/427</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="70%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Construct.hs.html">Construct</a></tt></td>
<td align="right">41%</td><td>17/41</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>5/12</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">60%</td><td>381/635</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="60%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Eval.hs.html">Eval</a></tt></td>
<td align="right">62%</td><td>22/35</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="62%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">59%</td><td>40/67</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="59%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">57%</td><td>361/628</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="57%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Illumination.hs.html">Illumination</a></tt></td>
<td align="right">45%</td><td>11/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="45%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>16/42</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">44%</td><td>299/678</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="44%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Interval.hs.html">Interval</a></tt></td>
<td align="right">47%</td><td>8/17</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="47%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>9/23</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">41%</td><td>69/165</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="41%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Data.hs.html">Data</a></tt></td>
<td align="right">22%</td><td>10/45</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="22%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">3%</td><td>2/51</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="3%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">39%</td><td>254/646</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="39%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Intersections.hs.html">Intersections</a></tt></td>
<td align="right">63%</td><td>14/22</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="63%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">42%</td><td>35/83</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="42%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>382/1001</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Primitives.hs.html">Primitives</a></tt></td>
<td align="right">16%</td><td>1/6</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="16%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">20%</td><td>5/24</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="20%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Surface.hs.html">Surface</a></tt></td>
<td align="right">36%</td><td>4/11</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="36%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">35%</td><td>7/20</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="35%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">18%</td><td>43/231</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="18%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="Misc.hs.html">Misc</a></tt></td>
<td align="right">0%</td><td>0/1</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">0%</td><td>0/10</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="100%"><tr><td height=12 class="invbar"></td></tr></table></td></tr></table></td></tr>
<tr>
<td>&nbsp;&nbsp;<tt>module <a href="CSG.hs.html">CSG</a></tt></td>
<td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td><td align="right">-&nbsp;</td><td>0/0</td><td width=100>&nbsp;</td></tr>
<tr></tr><tr style="background: #e0e0e0">
<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>
<td align="right">49%</td><td>146/295</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="49%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">38%</td><td>124/322</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="38%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td><td align="right">48%</td><td>2292/4715</td><td width=100><table cellpadding=0 cellspacing=0 width="100" class="bar"><tr><td><table cellpadding=0 cellspacing=0 width="48%"><tr><td height=12 class="bar"></td></tr></table></td></tr></table></td></tr>
</table></html>


