2 * Translated by Stephen
Weeks (sweeks@sweeks
.com
) 2000-10-11 from the
3 * PLClub OCaml winning entry to the
2000 ICFP programming contest
.
22 exception Failure
of string
24 fun failwith s
= raise(Failure s
)
32 val lowercase
= toLower
33 val uppercase
= toUpper
39 type out_channel
= outstream
40 val open_out
= openOut
41 val open_out_bin
= open_out
42 fun output_string (out
, s
) = output(out
, s
)
43 val close_out
= closeOut
54 val of_list
= fromList
58 val unsafe_get
= Array
.sub
59 val unsafe_set
= Array
.update
61 fun map f a
= Array
.tabulate(length a
, fn i
=> f(Array
.sub(a
, i
)))
66 fun for(a
: int, b
, f
) =
71 else (f a
; loop(a
+ 1))
75 fun forDown(b
: int, a
, f
) =
80 else (f b
; loop(b
- 1))
93 val float_of_int
= float
102 (* A hack for hash tables
with string domain
where performance doesn
't matter
. *)
107 val add
: ('a
, 'b
) t
-> string -> 'b
-> unit
108 val create
: int -> ('a
, 'b
) t
109 val find
: ('a
, 'b
) t
-> string -> 'b
112 datatype ('a
, 'b
) t
= T
of (string * 'b
) list ref
114 fun create _
= T (ref
[])
116 fun add (T t
) k d
= t
:= (k
, d
) :: !t
118 fun find (T (ref t
)) k
=
119 case List.find (fn (k
', _
) => k
= k
') t
of
120 NONE
=> raise Not_found
136 fun exit i
= Posix
.Process
.exit(Word8.fromInt i
)
146 val dtr
= acos (~
1.0) / 180.0
147 val rtd
= 180.0 / acos (~
1.0)
149 fun dcos t
= cos (t
* dtr
)
150 fun dsin t
= sin (t
* dtr
)
151 fun dtan t
= tan (t
* dtr
)
152 fun dacos x
= rtd
* acos x
154 val infinity
= Real.posInf
155 val minus_infinity
= Real.negInf
157 fun max_float (x
, y
: float
) = if x
>= y
then x
else y
164 (**** Matrix arithmetic
****)
166 type t
= float
array (* 4-dimension matrix
*)
167 type v
= float
* float
* float
* float (* 4-dimension vector
*)
171 val translate
: (*x
:*)float
* (*y
:*)float
* (*z
:*)float
-> t
172 val scale
: (*x
:*)float
* (*y
:*)float
* (*z
:*)float
-> t
173 val uscale
: float
-> t
174 val unscale
: (*x
:*)float
* (*y
:*)float
* (*z
:*)float
-> t
175 val unuscale
: float
-> t
176 val rotatex
: float
-> t
177 val rotatey
: float
-> t
178 val rotatez
: float
-> t
180 (* Operations on matrices
*)
182 val vmul
: t
* v
-> v
183 val transpose
: t
-> t
185 val add_scaled
: v
* float
* v
-> v
188 val prod
: v
* v
-> float
189 val square
: v
-> float
190 val normalize
: v
-> v
193 structure Matrix
: MATRIX
=
200 type v
= float
* float
* float
* float
202 (**** Basic matrices
****)
205 Array
.of_list
[1.0, 0.0, 0.0, 0.0,
210 fun translate(x
, y
, z
) =
211 Array
.of_list
[1.0, 0.0, 0.0, ~ x
,
216 fun unscale(x
, y
, z
) =
217 Array
.of_list
[ x
, 0.0, 0.0, 0.0,
222 fun scale(x
, y
, z
) = unscale (1.0 / x
, 1.0 / y
, 1.0 / z
)
224 fun unuscale s
= unscale (s
, s
, s
)
226 fun uscale s
= scale (s
, s
, s
)
233 Array
.of_list
[ 1.0, 0.0, 0.0, 0.0,
244 Array
.of_list
[ co
, 0.0, ~ si
, 0.0,
255 Array
.of_list
[ co
, si
, 0.0, 0.0,
261 (*** Operations on matrices
***)
263 fun get (m
: t
, i
, j
) = Array
.unsafe_get (m
, i
* 4 + j
)
264 fun set (m
: t
, i
, j
, v
) = Array
.unsafe_set (m
, i
* 4 + j
, v
)
268 val m
'' = Array
.make (16, 0.0)
271 for(0, 3, fn j
=> let
273 |
lp (k
, s
) = lp (k
+1, s
+ get(m
, i
, k
) * get(m
', k
, j
))
275 set(m
'', i
, j
, lp(0, 0.0))
281 let val m
' = Array
.make (16, 0.0)
284 set (m
', i
, j
, get (m
, j
, i
))))
288 fun vmul (m
, (x
, y
, z
, t
)) =
289 (x
* get(m
, 0, 0) + y
* get(m
, 0, 1) + z
* get(m
, 0, 2) + t
* get(m
, 0, 3),
290 x
* get(m
, 1, 0) + y
* get(m
, 1, 1) + z
* get(m
, 1, 2) + t
* get(m
, 1, 3),
291 x
* get(m
, 2, 0) + y
* get(m
, 2, 1) + z
* get(m
, 2, 2) + t
* get(m
, 2, 3),
292 x
* get(m
, 3, 0) + y
* get(m
, 3, 1) + z
* get(m
, 3, 2) + t
* get(m
, 3, 3))
294 fun add_scaled (x
: v
, t
, v
: v
) : v
=
300 fun add (x
: v
, y
: v
) : v
=
306 fun sub (x
: v
, y
: v
) : v
=
312 fun prod (x
: v
, y
: v
) : real =
313 #
1 x
* #
1 y
+ #
2 x
* #
2 y
+ #
3 x
* #
3 y
+ #
4 x
* #
4 y
315 fun square (vx
, vy
, vz
, vt
) : real =
316 vx
* vx
+ vy
* vy
+ vz
* vz
+ vt
* vt
318 fun normalize (x
: v
): v
=
320 val nx
= sqrt (prod (x
, x
))
335 signature LEX_TOKEN_STRUCTS
=
339 signature LEX_TOKEN
=
341 include LEX_TOKEN_STRUCTS
347 | Identifier
of string
356 functor LexToken(S
: LEX_TOKEN_STRUCTS
): LEX_TOKEN
=
365 | Identifier
of string
376 functor Lex(structure Token
: LEX_TOKEN
)=
378 structure UserDeclarations
=
380 val chars
: char list ref
= ref
[]
384 type lexresult
= Token
.t
386 val eof
: lexarg
-> lexresult
=
389 fun fail s
= raise Fail s
391 end (* end of user routines
*)
392 exception LexError (* raised
if illegal leaf action tried
*)
396 datatype yyfinstate
= N
of int
397 type statedata
= {fin
: yyfinstate list
, trans
: string}
398 (* transition
& final state table
*)
402 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
403 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
404 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
405 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
406 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
407 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
408 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
409 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
413 "\000\000\000\000\000\000\000\000\000\026\026\026\000\026\000\000\
414 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
415 \\026\000\025\000\000\024\000\000\000\000\000\000\000\023\000\021\
416 \\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\
417 \\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\
418 \\009\009\009\009\009\009\009\009\009\009\009\011\000\010\000\000\
419 \\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\
420 \\009\009\009\009\009\009\009\009\009\009\009\008\000\007\000\000\
424 "\000\000\000\000\000\000\000\000\000\027\029\029\000\028\000\000\
425 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
426 \\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\
427 \\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\
428 \\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\
429 \\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\
430 \\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\
431 \\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\000\
435 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
436 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
437 \\030\030\031\030\030\030\030\030\030\030\030\030\030\030\030\030\
438 \\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\
439 \\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\
440 \\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\
441 \\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\
442 \\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\000\
446 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
447 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
448 \\000\000\000\000\000\000\000\000\000\000\000\000\000\009\000\000\
449 \\009\009\009\009\009\009\009\009\009\009\000\000\000\000\000\000\
450 \\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\
451 \\009\009\009\009\009\009\009\009\009\009\009\000\000\000\000\009\
452 \\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\
453 \\009\009\009\009\009\009\009\009\009\009\009\000\000\000\000\000\
457 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
458 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
459 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\
460 \\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\
461 \\000\000\000\000\000\013\000\000\000\000\000\000\000\000\000\000\
462 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
463 \\000\000\000\000\000\013\000\000\000\000\000\000\000\000\000\000\
464 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
468 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
469 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
470 \\000\000\000\000\000\000\000\000\000\000\000\000\000\015\000\000\
471 \\014\014\014\014\014\014\014\014\014\014\000\000\000\000\000\000\
472 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
473 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
474 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
475 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
479 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
480 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
481 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
482 \\014\014\014\014\014\014\014\014\014\014\000\000\000\000\000\000\
483 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
484 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
485 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
486 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
490 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
491 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
492 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
493 \\017\017\017\017\017\017\017\017\017\017\000\000\000\000\000\000\
494 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
495 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
496 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
497 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
501 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
502 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
503 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
504 \\017\017\017\017\017\017\017\017\017\017\000\000\000\000\000\000\
505 \\000\000\000\000\000\018\000\000\000\000\000\000\000\000\000\000\
506 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
507 \\000\000\000\000\000\018\000\000\000\000\000\000\000\000\000\000\
508 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
512 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
513 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
514 \\000\000\000\000\000\000\000\000\000\000\000\000\000\020\000\000\
515 \\019\019\019\019\019\019\019\019\019\019\000\000\000\000\000\000\
516 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
517 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
518 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
519 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
523 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
524 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
525 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
526 \\019\019\019\019\019\019\019\019\019\019\000\000\000\000\000\000\
527 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
528 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
529 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
530 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
534 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
535 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
536 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
537 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
538 \\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\
539 \\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\
540 \\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\
541 \\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\
545 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
546 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
547 \\000\000\000\000\000\000\000\000\000\000\000\000\000\022\000\000\
548 \\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\000\
549 \\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\
550 \\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\022\
551 \\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\
552 \\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\
556 "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
557 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
558 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
559 \\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\
560 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
561 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
562 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
563 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
567 "\000\000\000\000\000\000\000\000\000\000\029\000\000\000\000\000\
568 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
569 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
570 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
571 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
572 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
573 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
574 \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
579 val s
= map
f (rev (tl (rev s
)))
580 exception LexHackingError
581 fun look ((j
,x
)::r
, i
) = if i
= j
then x
else look(r
, i
)
582 |
look ([], i
) = raise LexHackingError
583 fun g
{fin
=x
, trans
=i
} = {fin
=x
, trans
=look(s
,i
)}
584 in Vector.fromList(map g
585 [{fin
= [], trans
= 0},
586 {fin
= [], trans
= 1},
587 {fin
= [], trans
= 1},
588 {fin
= [], trans
= 3},
589 {fin
= [], trans
= 3},
590 {fin
= [], trans
= 5},
591 {fin
= [], trans
= 5},
592 {fin
= [(N
13)], trans
= 0},
593 {fin
= [(N
11)], trans
= 0},
594 {fin
= [(N
49)], trans
= 9},
595 {fin
= [(N
9)], trans
= 0},
596 {fin
= [(N
7)], trans
= 0},
597 {fin
= [(N
39)], trans
= 12},
598 {fin
= [], trans
= 13},
599 {fin
= [(N
35)], trans
= 14},
600 {fin
= [], trans
= 14},
601 {fin
= [], trans
= 16},
602 {fin
= [(N
35)], trans
= 17},
603 {fin
= [], trans
= 18},
604 {fin
= [(N
35)], trans
= 19},
605 {fin
= [], trans
= 19},
606 {fin
= [], trans
= 21},
607 {fin
= [(N
20)], trans
= 22},
608 {fin
= [], trans
= 23},
609 {fin
= [(N
43)], trans
= 0},
610 {fin
= [(N
41)], trans
= 0},
611 {fin
= [(N
5)], trans
= 0},
612 {fin
= [(N
58)], trans
= 0},
613 {fin
= [(N
55)], trans
= 28},
614 {fin
= [(N
55)], trans
= 0},
615 {fin
= [(N
62)], trans
= 0},
616 {fin
= [(N
60),(N
62)], trans
= 0}])
618 structure StartStates
=
620 datatype yystartstate
= STARTSTATE
of int
622 (* start state definitions
*)
624 val C
= STARTSTATE
3;
625 val INITIAL
= STARTSTATE
1;
626 val S
= STARTSTATE
5;
629 type result
= UserDeclarations
.lexresult
630 exception LexerError (* raised
if illegal leaf action tried
*)
634 fun makeLexer (yyinput
: int -> string) =
635 let val yygone0
:int=1
636 val yyb
= ref
"\n" (* buffer
*)
637 val yybl
: int ref
= ref
1 (*buffer length
*)
638 val yybufpos
: int ref
= ref
1 (* location
of next character to use
*)
639 val yygone
: int ref
= ref
yygone0 (* position
in file
of beginning
of buffer
*)
640 val yydone
= ref
false (* eof found yet?
*)
641 val yybegin
: int ref
= ref
1 (*Current
'start state
' for lexer
*)
643 val YYBEGIN
= fn (Internal
.StartStates
.STARTSTATE x
) =>
646 fun lex (yyarg
as (())) =
647 let fun continue() : Internal
.result
=
648 let fun scan (s
,AcceptingLeaves
: Internal
.yyfinstate list list
,l
,i0
: int) =
649 let fun action (i
: int,nil
) = raise LexError
650 |
action (i
,nil
::l
) = action (i
-1,l
)
651 |
action (i
,(node
::acts
)::l
) =
654 (let fun yymktext() = String.substring(!yyb
,i0
,i
-i0
)
655 val yypos
: int = i0
+ !yygone
656 fun REJECT() = action(i
,acts
::l
)
657 open UserDeclarations Internal
.StartStates
658 in (yybufpos
:= i
; case yyk
of
660 (* Application actions
*)
663 |
13 => (Token
.Rbrace
)
664 |
20 => let val yytext
=yymktext() in Token
.Binder(String.extract(yytext
, 1, NONE
)) end
665 |
35 => let val yytext
=yymktext() in Token
.Real(case Real.fromString yytext
of
667 fail(concat
["bad real constant ", yytext
])
669 |
39 => let val yytext
=yymktext() in Token
.Int(case Int.fromString yytext
of
671 fail(concat
["bad int constant ", yytext
])
673 |
41 => (chars
:= []; YYBEGIN S
; continue())
674 |
43 => (YYBEGIN C
; continue())
675 |
49 => let val yytext
=yymktext() in Token
.Identifier yytext
end
677 |
55 => (YYBEGIN INITIAL
; continue())
679 |
60 => (let val s
= (implode(rev(!chars
)) before chars
:= nil
)
683 |
62 => let val yytext
=yymktext() in chars
:= String.sub(yytext
, 0) :: !chars
685 |
7 => (Token
.Lbracket
)
686 |
9 => (Token
.Rbracket
)
687 | _
=> raise Internal
.LexerError
691 val {fin
,trans
} = Vector.sub(Internal
.tab
, s
)
692 val NewAcceptingLeaves
= fin
::AcceptingLeaves
694 if trans
= #
trans(Vector.sub(Internal
.tab
,0))
695 then action(l
,NewAcceptingLeaves
696 ) else let val newchars
= if !yydone
then "" else yyinput
1024
697 in if (String.size newchars
)=0
698 then (yydone
:= true;
699 if (l
=i0
) then UserDeclarations
.eof yyarg
700 else action(l
,NewAcceptingLeaves
))
701 else (if i0
=l
then yyb
:= newchars
702 else yyb
:= String.substring(!yyb
,i0
,l
-i0
)^newchars
;
703 yygone
:= !yygone
+i0
;
704 yybl
:= String.size (!yyb
);
705 scan (s
,AcceptingLeaves
,l
-i0
,0))
707 else let val NewChar
= Char.ord(CharVector
.sub(!yyb
,l
))
708 val NewChar
= if NewChar
<128 then NewChar
else 128
709 val NewState
= Char.ord(CharVector
.sub(trans
,NewChar
))
710 in if NewState
=0 then action(l
,NewAcceptingLeaves
)
711 else scan(NewState
,NewAcceptingLeaves
,l
+1,i0
)
715 val start
= if String.substring(!yyb
,!yybufpos
-1,1)="\n"
716 then !yybegin
+1 else !yybegin
718 in scan(!yybegin (* start
*),nil
,!yybufpos
,!yybufpos
)
727 (**** Basic types
: programs
, values
, ... ****)
730 Acos | Addi | Addf | Apply | Asin | Clampf | Cone | Cos | Cube
731 | Cylinder | Difference | Divi | Divf | Eqi | Eqf | Floor | Frac
732 | Get | Getx | Gety | Getz | If | Intersect | Length | Lessi | Lessf
733 | Light | Modi | Muli | Mulf | Negi | Negf | Plane | Point
734 | Pointlight |
Real | Render | Rotatex | Rotatey | Rotatez | Scale
735 | Sin | Sphere | Spotlight | Sqrt | Subi | Subf | Translate | Union
750 (* internal representation
of program tokens
*)
754 | Ident
' of int (* index to environment stack
*)
763 | Val
' of v (* inlined value
*)
771 | VClos
of v list
* t
' list
772 | VFun
of (v list
-> v list
) (* XXX for the compiler
*)
774 | VPoint
of v
* v
* v (* XXX Maybe these should be floats?
*)
778 | VStLight
of v
* v
* v
* v
* v
781 OObj
of kind
* closure ref
784 Matrix
.t
* (* World to object
*)
785 Matrix
.t
* (* Object to world
*)
786 float
* (* Scale factor
*)
788 | OUnion
of obj
* obj
789 | OInter
of obj
* obj
800 Unopt
of v (* Unoptimized function
*)
802 | Cst
of (float
* float
* float
* float
* float
* float
)
804 (* Translation
of an identifier
*)
805 val translate
: string -> t
807 (* Get the name
of an identifier
*)
808 (* val name
: t
' -> string *)
810 exception Stuck_computation
of v list
* v list
* t
' list
811 exception Stuck_computation
' (* for compiler
*)
813 val read
: TextIO.instream
-> t list
815 structure Program
: PROGRAM
=
821 Acos | Addi | Addf | Apply | Asin | Clampf | Cone | Cos | Cube
822 | Cylinder | Difference | Divi | Divf | Eqi | Eqf | Floor | Frac
823 | Get | Getx | Gety | Getz | If | Intersect | Length | Lessi | Lessf
824 | Light | Modi | Muli | Mulf | Negi | Negf | Plane | Point
825 | Pointlight |
Real | Render | Rotatex | Rotatey | Rotatez | Scale
826 | Sin | Sphere | Spotlight | Sqrt | Subi | Subf | Translate | Union
843 | Ident
' of int (* index to environment stack
*)
852 | Val
' of v (* inlined value
*)
859 | VClos
of v list
* t
' list
860 | VFun
of (v list
-> v list
) (* XXX for the compiler
*)
862 | VPoint
of v
* v
* v
866 | VStLight
of v
* v
* v
* v
* v
869 OObj
of kind
* closure ref
872 Matrix
.t
* (* World to object
*)
873 Matrix
.t
* (* Object to world
*)
874 float
* (* Scale factor
*)
876 | OUnion
of obj
* obj
877 | OInter
of obj
* obj
890 | Cst
of (float
* float
* float
* float
* float
* float
)
892 fun create_hashtables size init
=
894 val tbl
: (string, t
) Hashtbl
.t
= Hashtbl
.create size
895 (* val tbl
' = Hashtbl
.create size
*)
897 List.iter (fn (key
, data
) => Hashtbl
.add tbl key data
) init
;
898 (* List.iter (fn (data
, key
) -> Hashtbl
.add tbl
' key data
) init
; *)
902 val keywords(*, keyword_name
)*) =
903 create_hashtables
101
904 (* Booleans are either the literal
true or the literal
false. *)
905 [ ("true", Bool true),
906 ("false", Bool false),
907 (* Operators (see appendix
) *)
911 ("apply", Prim Apply
),
913 ("clampf", Prim Clampf
),
917 ("cylinder", Prim Cylinder
),
918 ("difference", Prim Difference
),
923 ("floor", Prim Floor
),
930 ("intersect", Prim Intersect
),
931 ("length", Prim Length
),
932 ("lessi", Prim Lessi
),
933 ("lessf", Prim Lessf
),
934 ("light", Prim Light
),
940 ("plane", Prim Plane
),
941 ("point", Prim Point
),
942 ("pointlight", Prim Pointlight
),
944 ("render", Prim Render
),
945 ("rotatex", Prim Rotatex
),
946 ("rotatey", Prim Rotatey
),
947 ("rotatez", Prim Rotatez
),
948 ("scale", Prim Scale
),
950 ("sphere", Prim Sphere
),
951 ("spotlight", Prim Spotlight
),
955 ("translate", Prim Translate
),
956 ("union", Prim Union
),
957 ("uscale", Prim Uscale
)]
960 Hashtbl
.find keywords i
961 handle Not_found
=> Ident i
964 * Hashtbl
.find keyword_name
967 * | _
-> raise Not_found
)
970 exception Stuck_computation
of v list
* v list
* t
' list
971 exception Stuck_computation
' (* for compiler
*)
973 structure LexToken
= LexToken()
974 structure Lex
= Lex(structure Token
= LexToken
)
976 fun read(ins
: TextIO.instream
): t list
=
978 val lex
: unit
-> LexToken
.t
=
979 Lex
.makeLexer(fn n
=> TextIO.inputN(ins
, n
))()
981 val next
: LexToken
.t option ref
= ref NONE
983 fun token(): LexToken
.t
=
986 | SOME t
=> (next
:= NONE
; t
)
987 fun save(t
: LexToken
.t
): unit
=
990 fun bad() = failwith
"invalid input"
991 fun many(done
: LexToken
.t
-> bool): t list
=
993 fun loop(ac
: t list
) =
995 NONE
=> if done(token())
998 | SOME t
=> loop(t
:: ac
)
1001 and one(): t option
=
1002 let fun tok t
= SOME t
1004 LexToken
.Binder x
=> tok(Binder x
)
1005 | LexToken
.Bool b
=> tok(Bool b
)
1006 | LexToken
.Identifier x
=> tok(translate x
)
1007 | LexToken
.Int i
=> tok(Int i
)
1008 | LexToken
.Lbrace
=>
1009 SOME(Fun(many(fn LexToken
.Rbrace
=> true | _
=> false)))
1010 | LexToken
.Lbracket
=>
1011 SOME(Arr(many(fn LexToken
.Rbracket
=> true | _
=>false)))
1012 | LexToken
.Real r
=> tok(Float r
)
1013 | LexToken
.String s
=> tok(String s
)
1014 | t
=> (save t
; NONE
)
1016 in many(fn LexToken
.Eof
=> true | _
=> false)
1026 val init
: (*width
:*)int * (*height
:*)int -> pixmap
1027 val dump
: string * pixmap
-> unit
1028 (* val load
: string -> pixmap
*)
1030 val width
: pixmap
-> int
1031 val height
: pixmap
-> int
1033 val get
: pixmap
* int * int * int -> int
1034 val set
: pixmap
* int * int * int * int -> unit
1035 val setp
: pixmap
* int * int * int * int * int -> unit
1037 structure Ppm
: PPM
=
1042 structure Array
= Word8Array
1043 structure Word = Word8
1045 type pixmap
= Array
.array
* int
1047 fun get ((img
, width
), i
, j
, k
) =
1048 Word.toInt (Array
.sub (img
, ((j
* width
) + i
) * 3 + k
))
1050 fun set ((img
, width
), i
, j
, k
, v
) =
1051 Array
.update (img
, ((j
* width
) + i
) * 3 + k
, Word.fromInt v
)
1053 fun setp ((img
, width
), i
, j
, r
, g
, b
) =
1054 let val p
= ((j
* width
) + i
) * 3
1055 in Array
.update(img
, p
, Word.fromInt r
)
1056 ; Array
.update(img
, p
+ 1, Word.fromInt g
)
1057 ; Array
.update(img
, p
+ 2, Word.fromInt b
)
1060 fun init (width
, height
) =
1061 (Array
.array(height
* width
* 3, 0w0
), width
)
1063 fun width (s
, width
) = width
1064 fun height (s
, width
) = Array
.length s
div width
div 3
1066 fun dump (file
, (img
, width
)) =
1068 val sz
= Array
.length img
1069 val height
= sz
div 3 div width
1070 val f
= open_out_bin file
1071 in output_string (f
, "P6\n# PL Club - translated to SML\n")
1072 ; output_string (f
, concat
[Int.toString width
, " ",
1073 Int.toString height
, "\n255\n"])
1074 ; output_string (f
, Byte
.unpackString (Word8ArraySlice
.slice
1080 * let f
= open_in_bin file
in
1081 * assert (input_line f
= "P6");
1082 * assert ((input_line f
).[0] = '#
');
1083 * let s
= input_line f
in
1085 * while s
.[!i
] >= '0' && s
.[!i
] <= '9' do incr i done
;
1086 * let width
= int_of_string (String.sub s
0 !i
) in
1088 * int_of_string (String.sub
s (!i
+ 1) (String.length s
- !i
- 1)) in
1089 * assert (input_line f
= "255");
1090 * let (s
, _
) as img
= init width height
in
1091 * really_input f s
0 (String.length s
);
1100 val apply
: (Program
.v
* Program
.v list
-> Program
.v list
) ref
1101 val inline_closure
: (Program
.v
-> Program
.v
) ref
1104 (*amb
:*)(float
* float
* float
) * (*lights
:*) Program
.v array
*
1105 (*obj
:*)Program
.obj
* (*depth
:*)int * (*fov
:*)float
*
1106 (*wid
:*)int * (*ht
:*)int *
1107 (*file
:*)string -> unit
1109 structure Render
: RENDER
=
1116 (* Scene description
*)
1117 datatype kind
= (* section
3.2 *)
1118 SSphere
of Matrix
.v (* Center
*) * float (* Square
of the radius
*)
1120 | SCube
of Matrix
.v (* Normal x
= 0 *) *
1121 Matrix
.v (* Normal y
= 0 *) *
1122 Matrix
.v (* Normal z
= 0 *)
1123 | SCylind
of Matrix
.v (* Normal
*)
1124 | SCone
of Matrix
.v (* Normal
*)
1125 | SPlane
of Matrix
.v (* Equation
*) * Matrix
.v (* Normal
*)
1127 datatype scene
= (* section
3.7 *)
1128 SObj
of kind
* closure
ref (* surface function
*) * Matrix
.t
1129 | SBound
of scene
* Matrix
.v (* Center
*) * float (* Square
of the radius
*)
1130 | SUnion
of scene
* scene
1131 | SInter
of scene
* scene
1132 | SDiff
of scene
* scene
1134 datatype light
= (* section
3.5 *)
1135 Light
of Matrix
.v (* negated
& normalized
*) * (float
* float
* float
)
1136 | PtLight
of Matrix
.v
* (float
* float
* float
)
1137 | StLight
of Matrix
.v
* Matrix
.v (* negated
& normalized
*) *
1138 (float
* float
* float
) * float (* cos
*) * float
1141 { amb
: float
* float
* float
,
1142 lights
: light array
,
1148 (**** Scene calculation
****)
1150 (* Plane equation
and normal
in world coordinates
*)
1151 fun plane_eq(m
, v
) =
1153 val n
= vmul (transpose m
, v
)
1155 (n
, normalize(#
1 n
, #
2 n
, #
3 n
, 0.0))
1158 val origin
= ( 0.0, 0.0, 0.0, 1.0 )
1159 val cube_center
= ( 0.5, 0.5, 0.5, 1.0 )
1160 val cylinder_center
= ( 0.0, 0.5, 0.0, 1.0 )
1161 val cone_center
= ( 0.0, 1.0, 0.0, 1.0 )
1163 fun intern_obj(m
, m1
, scale
, isom
, ob
) =
1164 (* apply transformations
*)
1166 OObj (OSphere
, f
) =>
1170 val center
= vmul (m1
, origin
)
1171 val radius
= scale
* scale
1173 SBound (SObj (SSphere (center
, radius
), f
, m
), center
, radius
)
1177 val center
= vmul (m1
, origin
)
1178 val radius
= scale
* scale
1180 SBound (SObj (SEllips
, f
, m
), center
, radius
)
1182 |
OObj (OCube
, f
) =>
1184 val (nx
, nx
') = plane_eq(m
, (1.0, 0.0, 0.0, 0.0))
1185 val (ny
, ny
') = plane_eq(m
, (0.0, 1.0, 0.0, 0.0))
1186 val (nz
, nz
') = plane_eq(m
, (0.0, 0.0, 1.0, 0.0))
1187 val c
= SObj (SCube (nx
', ny
', nz
'), f
, m
)
1189 SBound (c
, vmul (m1
, cube_center
), scale
* scale
* 0.75)
1191 |
OObj (OCylind
, f
) =>
1193 val (n
, n
') = plane_eq(m
, (0.0, 1.0, 0.0, 0.0))
1194 val c
= SObj (SCylind n
', f
, m
)
1196 SBound (c
, vmul(m1
, cylinder_center
), scale
* scale
* 1.25)
1198 |
OObj (OCone
, f
) =>
1200 val (n
, n
') = plane_eq(m
, (0.0, 1.0, 0.0, 0.0))
1201 val c
= SObj (SCone n
', f
, m
)
1203 SBound (c
, vmul(m1
, cone_center
), scale
* scale
)
1205 |
OObj (OPlane
, f
) =>
1207 val (n
, n
') = plane_eq(m
, (0.0, 1.0, 0.0, 0.0))
1209 SObj (SPlane (n
, n
'), f
, m
)
1211 |
OTransform (o', m
', m
'1, scale
', isom
') =>
1213 (Matrix
.mul(m
', m
), Matrix
.mul(m1
, m
'1),
1214 scale
* scale
', isom
andalso isom
', o')
1215 |
OUnion (o1
, o2
) =>
1216 SUnion (intern_obj(m
, m1
, scale
, isom
, o1
),
1217 intern_obj(m
, m1
, scale
, isom
, o2
))
1218 |
OInter (o1
, o2
) =>
1219 SInter (intern_obj(m
, m1
, scale
, isom
, o1
),
1220 intern_obj(m
, m1
, scale
, isom
, o2
))
1221 |
ODiff (ODiff (o1
, o2
), o3
) =>
1222 (* Better to have unions that diffs for introducing bounds
*)
1223 intern_obj(m
, m1
, scale
, isom
, (ODiff (o1
, OUnion (o2
, o3
))))
1225 SDiff (intern_obj(m
, m1
, scale
, isom
, o1
),
1226 intern_obj(m
, m1
, scale
, isom
, o2
))
1228 fun intern_lights a
=
1230 (fn VLight (VPoint (VFloat x
, VFloat y
, VFloat z
),
1231 VPoint (VFloat r
, VFloat g
, VFloat b
)) =>
1232 Light (normalize (neg (x
, y
, z
, 0.0)), (r
, g
, b
))
1233 |
VPtLight (VPoint (VFloat x
, VFloat y
, VFloat z
),
1234 VPoint (VFloat r
, VFloat g
, VFloat b
)) =>
1235 PtLight ((x
, y
, z
, 1.0), (r
, g
, b
))
1236 |
VStLight (VPoint (VFloat x
, VFloat y
, VFloat z
),
1237 VPoint (VFloat x
', VFloat y
', VFloat z
'),
1238 VPoint (VFloat r
, VFloat g
, VFloat b
),
1239 VFloat cutoff
, VFloat exp
) =>
1240 StLight ((x
, y
, z
, 1.0),
1241 normalize (x
- x
', y
- y
', z
- z
', 0.0),
1242 (r
, g
, b
), dcos cutoff
, exp
)
1244 raise(Fail
"assert false"))
1247 (**** Scene optimization
****)
1249 fun flatten_rec(sc
, rem
) =
1251 SUnion (sc1
, sc2
) => flatten_rec(sc1
, flatten_rec(sc2
, rem
))
1254 fun flatten_union sc
= flatten_rec(sc
, [])
1256 fun object_cost k
: int =
1263 | SPlane _
=> 0 (* Planes
do not have a bounding box anyway
*)
1265 fun add_bound (r0
, (x
, r
, cost
, sc
)) =
1268 if r
< 0.0 orelse cost
<= 1
1271 (1, SBound (sc
, x
, r
))
1273 (* Cost
of bounds
*)
1275 val c0
= r0
+ r
* float cost
1276 (* Cost ofout bounds
*)
1277 val c1
= r0
* float cost
1280 (1, SBound (sc
, x
, r
))
1285 fun union_bound (dsc1
as (x1
, r1
, cost1
, sc1
),
1286 dsc2
as (x2
, r2
, cost2
, sc2
)) =
1289 val (cost2
', sc2
') = add_bound(r1
, dsc2
)
1291 (x1
, r1
, cost1
, SUnion (sc1
, sc2
'))
1293 else if r2
< 0.0 then
1295 val (cost1
', sc1
') = add_bound (r2
, dsc1
)
1297 (x2
, r2
, cost2
, SUnion (sc1
', sc2
))
1301 val d
= sqrt (square (sub(x2
, x1
)))
1305 if d
+ r2
' <= r1
' then
1307 val (cost2
', sc2
') = add_bound (r1
, dsc2
)
1309 (x1
, r1
, cost1
+ cost2
', SUnion (sc1
, sc2
'))
1311 else if d
+ r1
' <= r2
' then
1313 val (cost1
', sc1
') = add_bound (r2
, dsc1
)
1315 (x2
, r2
, cost1
' + cost2
, SUnion (sc1
', sc2
))
1319 val r
' = (r1
' + r2
' + d
) * 0.5
1321 val x
= add_scaled (x1
, (r
' - r1
') / d
, sub(x2
, x1
))
1322 val (cost1
', sc1
') = add_bound (r
, dsc1
)
1323 val (cost2
', sc2
') = add_bound (r
, dsc2
)
1325 (x
, r
, cost1
' + cost2
', SUnion (sc1
', sc2
'))
1329 fun union_radius (dsc1
as (x1
, r1
, cost1
, sc1
),
1330 dsc2
as (x2
, r2
, cost2
, sc2
)) =
1332 val d
= sqrt (square (sub (x2
, x1
)))
1336 if d
+ r2
' <= r1
' then r1
else
1337 if d
+ r1
' <= r2
' then r2
else
1339 val r
' = (r1
' + r2
' + d
) * 0.5
1347 sc1
:: sc2
:: r
=> union_bound (sc1
, sc2
) :: merge2 r
1352 [] => raise(Fail
"assert false")
1354 | l
=> merge_union (merge2 l
)
1360 |
[sc1
, sc2
] => [union_bound(sc1
, sc2
)]
1363 val c
= Array
.of_list l
1364 val n
= Array
.length c
1365 val m
= Array2
.array(n
, n
, infinity
)
1367 for(0, n
- 1, fn i
=>
1368 for(0, n
- 1, fn j
=>
1370 then Array2
.update(m
, i
, j
,
1372 (Array
.sub(c
, i
), Array
.sub(c
, j
)))
1374 val remain
= Array
.init (n
, fn i
=> i
)
1379 val gain
= ref infinity
1386 val i
' = Array
.sub(remain
, i
)
1387 val j
' = Array
.sub(remain
, j
)
1389 if Array2
.sub(m
, i
', j
') < !gain
1391 (gain
:= Array2
.sub(m
, i
', j
')
1396 val i
= Array
.sub(remain
, !i0
)
1397 val j
= Array
.sub(remain
, !j0
)
1399 Array
.update(remain
, !j0
, Array
.sub(remain
, k
));
1401 union_bound (Array
.sub(c
, i
), Array
.sub(c
, j
)));
1402 for(0, k
- 1, fn j0
=>
1404 val j
= Array
.sub(remain
, j0
)
1412 (Array
.sub(c
, i
), Array
.sub(c
, j
)));
1416 (Array
.sub(c
, i
), Array
.sub(c
, j
))))
1420 in [Array
.sub(c
, Array
.sub(remain
, 0))]
1423 fun optimize_rec sc
=
1425 SObj (kind
, _
, _
) =>
1426 (origin
, ~
1.0, object_cost kind
, sc
)
1429 val l
= List.map
optimize_rec (flatten_union sc
)
1430 val unbounded
= List.filter (fn (_
, r
, _
, _
) => r
< 0.0) l
1431 val bounded
= List.filter (fn (_
, r
, _
, _
) => r
>= 0.0) l
1433 merge_union (opt_union bounded @ unbounded
)
1435 |
SInter (sc1
, sc2
) =>
1437 val (x1
, r1
, cost1
, sc1
) = optimize_rec sc1
1438 val (x2
, r2
, cost2
, sc2
) = optimize_rec sc2
1440 (* XXX We could have a tighter bound
... *)
1442 (x2
, r2
, cost2
, SInter (sc1
, sc2
))
1443 else if r1
< 0.0 then
1444 (x1
, r1
, cost1
, SInter (sc2
, sc1
))
1445 else if r1
< r2
then
1446 (x1
, r1
, cost1
, SInter (sc1
, sc2
))
1448 (x2
, r2
, cost1
, SInter (sc2
, sc1
))
1450 |
SDiff (sc1
, sc2
) =>
1452 val (x1
, r1
, cost1
, sc1
) = optimize_rec sc1
1453 val dsc2
as (x2
, r2
, cost2
, sc2
) = optimize_rec sc2
1454 val (cost2
', sc2
') = add_bound (r1
, dsc2
)
1456 (x1
, r1
, cost1
, SDiff (sc1
, sc2
'))
1458 |
SBound (sc1
, x
, r
) =>
1460 val (_
, _
, cost1
, sc1
) = optimize_rec sc1
1465 fun optimize sc
= #
2 (add_bound (~
1.0, optimize_rec sc
))
1467 (**** Rendering
****)
1469 (* operations for intervals
*)
1470 fun union (l1
, l2
) : (float
* scene
* float
* scene
) list
= (* ES
: checked
*)
1474 |
((i1
as (t1
, o1
, t1
', o1
')) :: r1
,
1475 (i2
as (t2
, o2
, t2
', o2
')) :: r2
) =>
1477 then i1
:: union(r1
, l2
)
1479 then i2
:: union(l1
, r2
)
1483 union(r1
, (t1
, o1
, t2
', o2
')::r2
)
1485 union((t1
, o1
, t1
', o1
')::r1
, r2
)
1488 union(r1
, ((t2
, o2
, t2
', o2
')::r2
))
1490 union((t2
, o2
, t1
', o1
')::r1
, r2
)
1492 fun inter (l1
, l2
) : (float
* scene
* float
* scene
) list
= (* ES
: checked
*)
1496 |
((i1
as (t1
, o1
, t1
', o1
')) :: r1
,
1497 (i2
as (t2
, o2
, t2
', o2
')) :: r2
) =>
1505 (t2
, o2
, t1
', o1
') :: inter(r1
, l2
)
1512 (t1
, o1
, t2
', o2
') :: inter(l1
, r2
)
1514 fun diff (l1
, l2
) : (float
* scene
* float
* scene
) list
= (* ES
: checked
*)
1518 |
((i1
as (t1
, o1
, t1
', o1
')) :: r1
,
1519 (i2
as (t2
, o2
, t2
', o2
')) :: r2
) =>
1521 then i1
:: diff(r1
, l2
)
1527 (t1
, o1
, t2
, o2
) :: diff(r1
, l2
)
1529 (t1
, o1
, t2
, o2
) :: diff((t2
', o2
', t1
', o1
') :: r1
, r2
)
1534 diff((t2
', o2
', t1
', o1
') :: r1
, r2
)
1536 (* intersection
of ray
and object
*)
1537 fun plane (orig
, dir
, scene
, eq
) : (float
* scene
* float
* scene
) list
=
1538 (* XXX Need to be checked
*)
1540 val porig
= prod (eq
, orig
)
1541 val pdir
= prod (eq
, dir
)
1542 val t
= ~ porig
/ pdir
1546 [(0.0, scene
, t
, scene
)]
1548 [(0.0, scene
, infinity
, scene
)]
1551 [(t
, scene
, infinity
, scene
)]
1556 fun band (obj
, x
, v
, i
) : (float
* scene
* float
* scene
) list
= (* ES
: checked
*)
1558 val t1
= ~
(i x
) / (i v
)
1559 val t2
= (1.0 - (i x
)) / (i v
)
1560 val t2
' = if t1
>= t2
then t1
else t2
1565 let val t1
' = if t1
<= t2
then t1
else t2
1568 [(0.0, obj
, t2
', obj
)]
1570 [(t1
', obj
, t2
', obj
)]
1574 fun cube (orig
, dir
, scene
, m
): (float
* scene
* float
* scene
) list
=
1577 val x
= vmul (m
, orig
)
1578 val v
= vmul (m
, dir
)
1580 case band (scene
, x
, v
, #
1) of
1583 case inter (l0
, band (scene
, x
, v
, #
2)) of
1585 | l1
=> inter (l1
, band (scene
, x
, v
, #
3))
1588 fun sphere (orig
, dir
, scene
, x
, r2
): (float
* scene
* float
* scene
) list
=
1590 val v
= sub (x
, orig
)
1591 (* Square
of the distance between the origin
and the center
of the sphere
*)
1593 val dir2
= square dir
1594 val p
= prod (v
, dir
)
1595 (* Square
of the distance between the ray
and the center
*)
1596 val d2
= v2
- p
* p
/ dir2
1602 val sq
= sqrt (delta
/ dir2
)
1603 val t1
= p
/ dir2
- sq
1604 val t2
= p
/ dir2
+ sq
1609 [(max_float (0.0, t1
), scene
, t2
, scene
)]
1613 fun ellipsoid (orig
, dir
, scene
, m
): (float
* scene
* float
* scene
) list
=
1616 val x
= vmul (m
, orig
)
1617 val v
= vmul (m
, dir
)
1620 val xv
= prod (x
, v
)
1621 val delta
= xv
* xv
- v2
* (x2
- 2.0)
1623 if delta
<= 0.0 then
1628 val t1
= (~ xv
- sq
) / v2
1629 val t2
= (~ xv
+ sq
) / v2
1633 [(max_float (0.0, t1
), scene
, t2
, scene
)]
1637 fun cylinder (orig
, dir
, scene
, m
): (float
* scene
* float
* scene
) list
=
1639 val x
= vmul (m
, orig
)
1640 val v
= vmul (m
, dir
)
1641 val x2
= #
1 x
* #
1 x
+ #
3 x
* #
3 x
- 1.0
1642 val v2
= #
1 v
* #
1 v
+ #
3 v
* #
3 v
1643 val xv
= #
1 x
* #
1 v
+ #
3 x
* #
3 v
1644 val delta
= xv
* xv
- v2
* x2
1646 if delta
<= 0.0 then
1651 val t1
= (~ xv
- sq
) / v2
1652 val t2
= (~ xv
+ sq
) / v2
1657 ([(max_float (0.0, t1
), scene
, t2
, scene
)],
1658 band (scene
, x
, v
, #
2))
1662 fun cone (orig
, dir
, scene
, m
): (float
* scene
* float
* scene
) list
=
1664 val x
= vmul (m
, orig
)
1665 val v
= vmul (m
, dir
)
1666 val x2
= #
1 x
* #
1 x
+ #
3 x
* #
3 x
- #
2 x
* #
2 x
1667 val v2
= #
1 v
* #
1 v
+ #
3 v
* #
3 v
- #
2 v
* #
2 v
1668 val xv
= #
1 x
* #
1 v
+ #
3 x
* #
3 v
- #
2 x
* #
2 v
1669 val delta
= xv
* xv
- v2
* x2
1671 if delta
<= 0.0 then
1676 val t1
= (~ xv
- sq
) / v2
1677 val t2
= (~ xv
+ sq
) / v2
1684 ([(max_float(0.0, t1
), scene
, t2
, scene
)],
1685 band (scene
, x
, v
, #
2))
1689 [(0.0, scene
, infinity
, scene
)]
1690 else if t2
<= 0.0 then
1691 [(t1
, scene
, infinity
, scene
)]
1693 [(0.0, scene
, t2
, scene
), (t1
, scene
, infinity
, scene
)],
1694 band (scene
, x
, v
, #
2))
1698 (* XXX Maybe we should check whether the sphere is completely behind us ?
*)
1699 fun intersect (orig
, dir
, x
, r2
) =
1701 val (vx
, vy
, vz
, vt
) = sub (x
, orig
)
1702 (* Square
of the distance between the origin
and the center
of the sphere
*)
1703 val v2
= vx
* vx
+ vy
* vy
+ vz
* vz
+ vt
* vt
1704 val (dx
, dy
, dz
, dt
) = dir
1705 val dir2
= dx
* dx
+ dy
* dy
+ dz
* dz
+ dt
* dt
1706 val p
= vx
* dx
+ vy
* dy
+ vz
* dz
+ vt
* dt
1707 (* Square
of the distance between the ray
and the center
*)
1708 val d2
= v2
- p
* p
/ dir2
1712 fun find_all (orig
, dir
, scene
) =
1714 SObj (SSphere (x
, r2
), _
, m
) =>
1715 sphere (orig
, dir
, scene
, x
, r2
)
1716 |
SObj (SEllips
, _
, m
) =>
1717 ellipsoid (orig
, dir
, scene
, m
)
1718 |
SObj (SCube _
, _
, m
) =>
1719 cube (orig
, dir
, scene
, m
)
1720 |
SObj (SCylind _
, _
, m
) =>
1721 cylinder (orig
, dir
, scene
, m
)
1722 |
SObj (SCone _
, _
, m
) =>
1723 cone (orig
, dir
, scene
, m
)
1724 |
SObj (SPlane (eq
, _
), _
, m
) =>
1725 plane (orig
, dir
, scene
, eq
)
1726 |
SBound (sc
, x
, r2
) =>
1727 if intersect (orig
, dir
, x
, r2
)
1728 then find_all (orig
, dir
, sc
)
1730 |
SUnion (sc1
, sc2
) =>
1731 union (find_all (orig
, dir
, sc1
), find_all (orig
, dir
, sc2
))
1732 |
SInter (sc1
, sc2
) =>
1733 let val l1
= find_all (orig
, dir
, sc1
)
1737 | _
=> inter(l1
, find_all (orig
, dir
, sc2
))
1739 |
SDiff (sc1
, sc2
) =>
1740 let val l1
= find_all(orig
, dir
, sc1
)
1744 | _
=> diff(l1
, find_all(orig
, dir
, sc2
))
1747 fun filter_inter_list l
=
1751 then filter_inter_list r
1755 fun hit_from_inter bounded l0
=
1756 let val l
= filter_inter_list l0
1760 |
(t
, _
, _
, _
)::r
=> (not bounded
orelse t
<= 1.0)
1763 fun hit(orig
, dir
, scene
, bounded
) =
1765 SObj (kind
, _
, m
) =>
1768 SSphere (x
, r2
) => sphere (orig
, dir
, scene
, x
, r2
)
1769 | SEllips
=> ellipsoid (orig
, dir
, scene
, m
)
1770 | SCube _
=> cube (orig
, dir
, scene
, m
)
1771 | SCylind _
=> cylinder (orig
, dir
, scene
, m
)
1772 | SCone _
=> cone (orig
, dir
, scene
, m
)
1773 |
SPlane (eq
, _
) => plane (orig
, dir
, scene
, eq
)) of
1776 if bounded
andalso t
> 1.0
1782 |
SBound (sc
, x
, r2
) =>
1783 intersect (orig
, dir
, x
, r2
) andalso hit (orig
, dir
, sc
, bounded
)
1784 |
SUnion (sc1
, sc2
) =>
1785 hit (orig
, dir
, sc1
, bounded
) orelse hit (orig
, dir
, sc2
, bounded
)
1786 |
SInter (sc1
, sc2
) =>
1787 let val l1
= find_all (orig
, dir
, sc1
)
1791 | _
=> hit_from_inter
bounded (inter(l1
, find_all (orig
, dir
, sc2
)))
1793 |
SDiff (sc1
, sc2
) =>
1795 val l1
= find_all(orig
, dir
, sc1
)
1799 | _
=> hit_from_inter
bounded (diff(l1
, find_all(orig
, dir
, sc2
)))
1802 fun visible (desc
: desc
, orig
, dir
, bounded
) =
1803 not (hit(orig
, dir
, #scene desc
, bounded
))
1805 val black
= (0.0, 0.0, 0.0)
1807 val apply
: ((Program
.v
* Program
.v list
) -> Program
.v list
) ref
=
1808 ref (fn _
=> raise(Fail
"assert false"))
1809 val inline_closure
: (Program
.v
-> Program
.v
) ref
=
1810 ref (fn _
=> raise(Fail
"assert false"))
1812 (* Value between
0 and 1 from the sinus
and cosinus
*)
1813 (* Actually
, only the sign
of the sinus is used
*)
1814 fun angle (si
, co
) =
1816 val u
= dacos co
/ 360.0
1818 if si
> 0.0 then u
else 1.0 - u
1821 (* XXX Check that
0 <= u
,v
<= 1 *)
1822 fun texture_coord (kind
, x
: v
) = (* section
3.6 *) (* ES
: checked
*)
1824 fun ellipsOrSphere() =
1827 val v
= (y
+ 1.0) * 0.5
1830 then [VFloat v
, VFloat
0.0, VInt
0]
1833 val u
= angle (#
1 x
, #
3 x
/ sqrt (1.0 - y
* y
))
1835 [VFloat v
, VFloat u
, VInt
0]
1838 in (* [v
; u
; face
] *)
1840 SEllips
=> ellipsOrSphere()
1841 | SSphere _
=> ellipsOrSphere()
1843 if abs_float (#
3 x
) < epsilon
then
1844 [VFloat (#
2 x
), VFloat (#
1 x
), VInt
0]
1845 else if abs_float ((#
3 x
) - 1.0) < epsilon
then
1846 [VFloat (#
2 x
), VFloat (#
1 x
), VInt
1]
1847 else if abs_float (#
1 x
) < epsilon
then
1848 [VFloat (#
2 x
), VFloat (#
3 x
), VInt
2]
1849 else if abs_float ((#
1 x
) - 1.0) < epsilon
then
1850 [VFloat (#
2 x
), VFloat (#
3 x
), VInt
3]
1851 else if abs_float ((#
2 x
) - 1.0) < epsilon
then
1852 [VFloat (#
3 x
), VFloat (#
1 x
), VInt
4]
1853 else (* if abs_float (#
2 x
) < epsilon
then *)
1854 [VFloat (#
3 x
), VFloat (#
1 x
), VInt
5]
1856 if abs_float (#
2 x
) < epsilon
then
1857 [VFloat (((#
3 x
) + 1.0) * 0.5), VFloat (((#
1 x
) + 1.0) * 0.5), VInt
2]
1858 else if abs_float ((#
2 x
) - 1.0) < epsilon
then
1859 [VFloat (((#
3 x
) + 1.0) * 0.5), VFloat (((#
1 x
) + 1.0) * 0.5), VInt
1]
1862 val u
= angle (#
1 x
, #
3 x
)
1864 [VFloat (#
2 x
), VFloat u
, VInt
0]
1869 if abs_float v
< epsilon
then
1870 [VFloat v
, VFloat
0.0, VInt
0]
1872 if abs_float ((#
2 x
) - 1.0) < epsilon
1874 [VFloat (((#
3 x
) + 1.0) * 0.5),
1875 VFloat (((#
1 x
) + 1.0) * 0.5),
1879 val u
= angle (#
1 x
, (#
3 x
) / v
)
1881 [VFloat v
, VFloat u
, VInt
0]
1885 [VFloat (#
3 x
), VFloat (#
1 x
), VInt
0]
1888 fun normal (kind
, m
, x
', x
) =
1891 normalize (sub (x
, x0
))
1893 let val (n0
, n1
, n2
, _
) = vmul (transpose m
, x
')
1895 normalize(n0
, n1
, n2
, 0.0)
1898 if abs_float (#
2 x
') < epsilon
1899 orelse abs_float (#
2 x
') - 1.0 < epsilon
then
1902 (* XXX Could be optimized
... *)
1904 val (n0
, n1
, n2
, _
) = vmul (transpose m
, (#
1 x
', 0.0, #
3 x
', 0.0))
1906 normalize(n0
, n1
, n2
, 0.0)
1909 if abs_float (#
2 x
') - 1.0 < epsilon
1913 val (n0
, n1
, n2
, _
) =
1914 vmul (transpose m
, (#
1 x
', ~
(#
2 x
'), #
3 x
', 0.0))
1916 normalize(n0
, n1
, n2
, 0.0)
1918 |
SCube (nx
, ny
, nz
) =>
1919 if abs_float (#
3 x
') < epsilon
1920 orelse abs_float (#
3 x
') - 1.0 < epsilon
1922 else if abs_float (#
1 x
') < epsilon
1923 orelse abs_float (#
1 x
') - 1.0 < epsilon
1929 fun apply_surface_fun (f
, v
) =
1930 case !apply(f
, v
) of
1931 [VFloat n
, VFloat ks
, VFloat kd
,
1932 VPoint (VFloat cr
, VFloat cg
, VFloat cb
)] =>
1933 (n
, ks
, kd
, cr
, cg
, cb
)
1935 failwith
"A surface function returns some incorrect values"
1937 fun trace (desc
: desc
, depth
: int, orig
, dir
) =
1939 val dir
= normalize dir
1941 case filter_inter_list (find_all(orig
, dir
, #scene desc
)) of
1943 |
(t
, ob
, _
, _
) :: _
=> trace_2(desc
, depth
, orig
, dir
, t
, ob
)
1946 and trace_2 (desc
, depth
: int, orig
, dir
, t
, obj
) =
1948 val x
= add_scaled (orig
, t
, dir
)
1951 SObj (kind
, f
, m
) =>
1953 val x
' = vmul (m
, x
)
1954 val (n
, ks
, kd
, cr
, cg
, cb
) =
1957 (* First we check whether the function would fail
*)
1959 val res
= apply_surface_fun(g
, texture_coord(kind
, x
'))
1960 fun stuck() = f
:= Opt (!inline_closure g
)
1962 (* Then
, we check whether it is a constant function
*)
1963 ((ignore (apply_surface_fun(g
,
1964 [VInt
0, VInt
0, VFloat
0.0]))
1966 handle Stuck_computation _
=> stuck()
1967 | Stuck_computation
' => stuck())
1971 apply_surface_fun (g
, texture_coord (kind
, x
'))
1974 val nm
= normal (kind
, m
, x
', x
)
1975 val p
= prod (dir
, nm
)
1976 val nm
= if p
> 0.0 then neg nm
else nm
1977 val p
= ~
(abs_float p
)
1978 (* Ambient composant
*)
1979 val (ar
, ag
, ab
) = #amb desc
1980 val r
= ref (kd
* ar
)
1981 val g
= ref (kd
* ag
)
1982 val b
= ref (kd
* ab
)
1984 val lights
= #lights desc
1986 for(0, Array
.length lights
- 1, fn i
=>
1987 case (Array
.sub(lights
, i
)) of
1988 Light (ldir
, (lr
, lg
, lb
)) =>
1990 val p
' = prod (ldir
, nm
)
1992 if p
' > 0.0 andalso visible (desc
, x
, ldir
, false)
1996 if ks
> epsilon
then
1998 ks
* prod (normalize
2010 |
PtLight (src
, (lr
, lg
, lb
)) =>
2012 val ldir
= sub (src
, x
)
2013 val ldir
' = normalize ldir
2014 val p
' = prod (ldir
', nm
)
2016 if p
' > 0.0 andalso visible(desc
, x
, ldir
, true)
2023 ks
* prod (normalize (sub (ldir
', dir
)),
2027 val int = 100.0 * int / (99.0 + square ldir
)
2035 |
StLight (src
, maindir
, (lr
, lg
, lb
), cutoff
, exp
) =>
2037 val ldir
= sub (src
, x
)
2038 val ldir
' = normalize ldir
2039 val p
' = prod (ldir
', nm
)
2040 val p
'' = prod (ldir
', maindir
)
2042 if p
' > 0.0 andalso p
'' > cutoff
2043 andalso visible(desc
, x
, ldir
, true)
2050 ks
* prod (normalize (sub(ldir
', dir
)),
2055 100.0 * int / (99.0 + square ldir
) *
2066 if ks
> epsilon
andalso depth
> 0
2069 val dir
' = add_scaled (dir
, ~
2.0 * p
, nm
)
2070 val (r
', g
', b
') = trace(desc
, depth
- 1, x
, dir
')
2077 in (!r
* cr
, !g
* cg
, !b
* cb
)
2079 | _
=> raise(Fail
"assert false")
2084 val i
= truncate (c
* 256.0)
2086 if i
< 0 then 0 else
2087 if i
>= 256 then 255 else
2091 fun f (amb
, lights
, obj
, depth
: int, fov
, wid
, ht
, file
) =
2093 val scene
= intern_obj(Matrix
.identity
, Matrix
.identity
, 1.0, true, obj
)
2094 val scene
= optimize scene
2095 val img
= Ppm
.init (wid
, ht
)
2096 val orig
= ( 0.0, 0.0, ~
1.0, 1.0 )
2097 val width
= 2.0 * dtan (0.5 * fov
)
2098 val delta
= width
/ float wid
2099 val x0
= ~ width
/ 2.0
2100 val y0
= delta
* float ht
/ 2.0
2101 val desc
= { amb
= amb
, lights
= intern_lights lights
, scene
= scene
}
2103 for(0, ht
- 1, fn j
=>
2104 for(0, wid
- 1, fn i
=>
2107 (x0
+ (float i
+ 0.5) * delta
,
2108 y0
- (float j
+ 0.5) * delta
,
2111 val (r
, g
, b
) = trace(desc
, depth
, orig
, dir
)
2113 Ppm
.setp (img
, i
, j
, conv r
, conv g
, conv b
)
2115 ; Ppm
.dump (file
, img
)
2121 val f
: Program
.t list
-> unit
2123 structure Eval
: EVAL
=
2129 val rtd
= 180.0 / acos (~
1.0)
2130 val dtr
= acos (~
1.0) / 180.0
2133 val zero
= VFloat
0.0
2134 val one
= VFloat
1.0
2136 fun lookup (env
, s
) : int =
2138 [] => failwith ("Unbound variable \"" ^ s ^
"\"")
2142 else 1 + (lookup(env
', s
))
2144 (* XXX embed values
*)
2145 fun conv (absenv
, p
) =
2148 | Float x
:: Float y
:: Float z
:: Prim Point
:: r
=>
2149 Val
' (VPoint (VFloat x
, VFloat y
, VFloat z
)) :: conv(absenv
, r
)
2152 Fun p
' => Fun
' (conv(absenv
, p
')) :: conv(absenv
, r
)
2153 | Arr p
' => Arr
' (conv(absenv
, p
')) :: conv(absenv
, r
)
2154 | Ident s
=> Ident
' (lookup(absenv
, s
)) :: conv(absenv
, r
)
2155 | Binder s
=> Binder
' :: conv (s
:: absenv
, r
)
2156 |
Int i
=> Val
' (VInt i
) :: conv(absenv
, r
)
2157 | Float f
=> Val
' (VFloat f
) :: conv(absenv
, r
)
2158 |
Bool b
=> Val
' (VBool b
) :: conv(absenv
, r
)
2159 |
String s
=> Val
' (VStr s
) :: conv(absenv
, r
)
2160 | Prim k
=> Prim
' k
:: conv(absenv
, r
))
2162 fun inline (offset
, env
, p
) =
2167 fun normal() = t
:: inline(offset
, env
, r
)
2169 Fun
' p
' => Fun
' (inline(offset
, env
, p
')) :: inline(offset
, env
, r
)
2170 | Arr
' p
' => Arr
' (inline(offset
, env
, p
')) :: inline(offset
, env
, r
)
2173 then Val
' (List.nth (env
, i
- offset
)) :: inline(offset
, env
, r
)
2175 | Binder
' => Binder
' :: inline (1 + offset
, env
, r
)
2176 | Prim
' _
=> normal()
2177 | Val
' _
=> normal()
2180 val inline_closure
=
2181 fn (VClos (env
, p
)) => VClos ([], inline(0, env
, p
))
2182 | _
=> failwith
"a surface function was actually not a function"
2184 val _
= Render
.inline_closure
:= inline_closure
2186 fun eval (env
, st
, p
) =
2189 (_
, Val
' v
:: r
) => eval(env
, (v
:: st
), r
)
2192 |
(v
::st
', Binder
' :: r
) => eval((v
:: env
), st
', r
)
2194 |
(_
, Ident
' i
:: r
) =>
2195 let val v
= List.nth(env
, i
)
2196 in eval(env
, (v
:: st
), r
)
2199 |
(_
, Fun
' f
:: r
) => eval(env
, (VClos (env
, f
) :: st
), r
)
2201 |
(VClos (env
', f
) :: st
', Prim
' Apply
:: r
) =>
2202 eval(env
, eval(env
', st
', f
), r
)
2204 |
(_
, Arr
' a
:: r
) =>
2205 eval(env
, (VArr (Array
.of_list (List.rev (eval(env
, [], a
))))) :: st
, r
)
2207 |
(VClos _
:: VClos (env
', iftrue
) :: VBool
true :: st
', Prim
' If
:: r
) =>
2208 eval(env
, eval(env
', st
', iftrue
), r
)
2209 |
(VClos (env
', iffalse
) :: VClos _
:: VBool
false :: st
', Prim
' If
:: r
) =>
2210 eval(env
, eval(env
', st
', iffalse
), r
)
2211 (* Operations on numbers
*)
2212 |
(VInt n2
:: VInt n1
:: st
', Prim
' Addi
:: r
) =>
2213 eval(env
, (VInt (n1
+ n2
) :: st
'), r
)
2214 |
(VFloat f2
:: VFloat f1
:: st
', Prim
' Addf
:: r
) =>
2215 eval(env
, (VFloat (f1
+ f2
) :: st
'), r
)
2216 |
(VFloat f
:: st
', Prim
' Acos
:: r
) =>
2217 eval(env
, (VFloat (deg (acos f
)) :: st
'), r
)
2218 |
(VFloat f
:: st
', Prim
' Asin
:: r
) =>
2219 eval(env
, (VFloat (deg (asin f
)) :: st
'), r
)
2220 |
((vf
as VFloat f
):: st
', Prim
' Clampf
:: r
) =>
2221 let val f
' = if f
< 0.0 then zero
else if f
> 1.0 then one
else vf
2222 in eval(env
, (f
' :: st
'), r
)
2224 |
(VFloat f
:: st
', Prim
' Cos
:: r
) =>
2225 eval(env
, (VFloat (cos (rad f
)) :: st
'), r
)
2226 |
(VInt n2
:: VInt n1
:: st
', Prim
' Divi
:: r
) =>
2227 eval(env
, (VInt (n1
div n2
) :: st
'), r
)
2228 |
(VFloat f2
:: VFloat f1
:: st
', Prim
' Divf
:: r
) =>
2229 eval(env
, (VFloat (f1
/ f2
) :: st
'), r
)
2230 |
(VInt n2
:: VInt n1
:: st
', Prim
' Eqi
:: r
) =>
2231 eval(env
, (VBool (n1
= n2
) :: st
'), r
)
2232 |
(VFloat f2
:: VFloat f1
:: st
', Prim
' Eqf
:: r
) =>
2233 eval(env
, (VBool (Real.==(f1
, f2
)) :: st
'), r
)
2234 |
(VFloat f
:: st
', Prim
' Floor
:: r
) =>
2235 eval(env
, (VInt (Real.floor f
) :: st
'), r
)
2236 |
(VFloat f
:: st
', Prim
' Frac
:: r
) =>
2237 eval(env
, (VFloat (Real.realMod f
) :: st
'), r
)
2238 |
(VInt n2
:: VInt n1
:: st
', Prim
' Lessi
:: r
) =>
2239 eval(env
, (VBool (n1
< n2
) :: st
'), r
)
2240 |
(VFloat f2
:: VFloat f1
:: st
', Prim
' Lessf
:: r
) =>
2241 eval(env
, (VBool (f1
< f2
) :: st
'), r
)
2242 |
(VInt n2
:: VInt n1
:: st
', Prim
' Modi
:: r
) =>
2243 eval(env
, (VInt (n1
mod n2
) :: st
'), r
)
2244 |
(VInt n2
:: VInt n1
:: st
', Prim
' Muli
:: r
) =>
2245 eval(env
, (VInt (n1
* n2
) :: st
'), r
)
2246 |
(VFloat f2
:: VFloat f1
:: st
', Prim
' Mulf
:: r
) =>
2247 eval(env
, (VFloat (f1
* f2
) :: st
'), r
)
2248 |
(VInt n
:: st
', Prim
' Negi
:: r
) => eval(env
, (VInt (~ n
) :: st
'), r
)
2249 |
(VFloat f
:: st
', Prim
' Negf
:: r
) => eval(env
, (VFloat (~ f
) :: st
'), r
)
2250 |
(VInt n
:: st
', Prim
' Real :: r
) => eval(env
, (VFloat (float n
) :: st
'), r
)
2251 |
(VFloat f
:: st
', Prim
' Sin
:: r
) => eval(env
, (VFloat (sin (rad f
)) :: st
'), r
)
2252 |
(VFloat f
:: st
', Prim
' Sqrt
:: r
) => eval(env
, (VFloat (sqrt f
) :: st
'), r
)
2253 |
(VInt n2
:: VInt n1
:: st
', Prim
' Subi
:: r
) => eval(env
, (VInt (n1
- n2
) :: st
'), r
)
2254 |
(VFloat f2
:: VFloat f1
:: st
', Prim
' Subf
:: r
) =>
2255 eval(env
, (VFloat (f1
- f2
) :: st
'), r
)
2256 (* Operations on points
*)
2257 |
(VPoint (x
, _
, _
) :: st
', Prim
' Getx
:: r
) => eval(env
, (x
:: st
'), r
)
2258 |
(VPoint (_
, y
, _
) :: st
', Prim
' Gety
:: r
) => eval(env
, (y
:: st
'), r
)
2259 |
(VPoint (_
, _
, z
) :: st
', Prim
' Getz
:: r
) => eval(env
, (z
:: st
'), r
)
2260 |
((z
as VFloat _
) :: (y
as VFloat _
) :: (x
as VFloat _
) :: st
',
2261 Prim
' Point
:: r
) =>
2262 eval(env
, (VPoint (x
, y
, z
) :: st
'), r
)
2263 |
(VInt i
:: VArr a
:: st
', Prim
' Get
:: r
) =>
2264 (* if compiled
of "-unsafe" *)
2265 if i
< 0 orelse i
>= Array
.length a
2266 then failwith
"illegal access beyond array boundary"
2267 else eval(env
, (Array
.sub(a
, i
) :: st
'), r
)
2268 |
(VArr a
:: st
', Prim
' Length
:: r
) =>
2269 eval(env
, (VInt (Array
.length a
) :: st
'), r
)
2270 (* Geometric primitives
*)
2271 |
((f
as VClos _
) :: st
', Prim
' Sphere
:: r
) =>
2272 eval(env
, (VObj (OObj (OSphere
, ref (Unopt f
))) :: st
'), r
)
2273 |
((f
as VClos _
) :: st
', Prim
' Cube
:: r
) =>
2274 eval(env
, (VObj (OObj (OCube
, ref (Unopt f
))) :: st
'), r
)
2275 |
((f
as VClos _
) :: st
', Prim
' Cylinder
:: r
) =>
2276 eval(env
, (VObj (OObj (OCylind
, ref (Unopt f
))) :: st
'), r
)
2277 |
((f
as VClos _
) :: st
', Prim
' Cone
:: r
) =>
2278 eval(env
, (VObj (OObj (OCone
, ref (Unopt f
))) :: st
'), r
)
2279 |
((f
as VClos _
) :: st
', Prim
' Plane
:: r
) =>
2280 eval(env
, (VObj (OObj (OPlane
, ref (Unopt f
))) :: st
'), r
)
2281 (* Transformations
*)
2282 |
(VFloat z
:: VFloat y
:: VFloat x
:: VObj ob
:: st
', Prim
' Translate
:: r
) =>
2284 (VObj (OTransform (ob
,
2285 Matrix
.translate (x
, y
, z
),
2286 Matrix
.translate (~ x
, ~ y
, ~ z
),
2287 1.0, true)) :: st
'),
2289 |
(VFloat z
:: VFloat y
:: VFloat x
:: VObj ob
:: st
', Prim
' Scale
:: r
) =>
2291 (VObj (OTransform (ob
,
2292 Matrix
.scale (x
, y
, z
),
2293 Matrix
.unscale (x
, y
, z
),
2294 Real.max (abs_float x
,
2295 (Real.max (abs_float y
, abs_float z
))),
2298 |
(VFloat s
:: VObj ob
:: st
', Prim
' Uscale
:: r
) =>
2300 (VObj (OTransform (ob
, Matrix
.uscale s
, Matrix
.unuscale s
,
2301 abs_float s
, true)) :: st
'),
2303 |
(VFloat t
:: VObj ob
:: st
', Prim
' Rotatex
:: r
) =>
2305 (VObj (OTransform (ob
, Matrix
.rotatex t
, Matrix
.rotatex (~ t
),
2306 1.0, true)) :: st
'),
2308 |
(VFloat t
:: VObj ob
:: st
', Prim
' Rotatey
:: r
) =>
2310 (VObj (OTransform (ob
, Matrix
.rotatey t
, Matrix
.rotatey (~ t
),
2311 1.0, true)) :: st
'),
2313 |
(VFloat t
:: VObj ob
:: st
', Prim
' Rotatez
:: r
) =>
2315 (VObj (OTransform (ob
, Matrix
.rotatez t
, Matrix
.rotatez (~ t
),
2316 1.0, true)) :: st
'),
2319 |
((color
as VPoint _
) :: (dir
as VPoint _
) :: st
', Prim
' Light
:: r
) =>
2320 eval(env
, (VLight (dir
, color
) :: st
'), r
)
2321 |
((color
as VPoint _
) :: (pos
as VPoint _
) :: st
', Prim
' Pointlight
:: r
) =>
2322 eval(env
, (VPtLight (pos
, color
) :: st
'), r
)
2323 |
((expon
as VFloat _
) :: (cutoff
as VFloat _
) :: (color
as VPoint _
) ::
2324 (at
as VPoint _
) :: (pos
as VPoint _
) :: st
', Prim
' Spotlight
:: r
) =>
2325 eval(env
, (VStLight (pos
, at
, color
, cutoff
, expon
) :: st
'), r
)
2326 (* Constructive geometry
*)
2327 |
((VObj o2
) :: (VObj o1
) :: st
', Prim
' Union
:: r
) =>
2328 eval(env
, (VObj (OUnion (o1
, o2
)) :: st
'), r
)
2329 |
((VObj o2
) :: (VObj o1
) :: st
', Prim
' Intersect
:: r
) =>
2330 eval(env
, (VObj (OInter (o1
, o2
)) :: st
'), r
)
2331 |
((VObj o2
) :: (VObj o1
) :: st
', Prim
' Difference
:: r
) =>
2332 eval(env
, (VObj (ODiff (o1
, o2
)) :: st
'), r
)
2334 |
(VStr file
:: VInt ht
:: VInt wid
:: VFloat fov
:: VInt depth
::
2335 VObj obj
:: VArr lights
:: VPoint (VFloat ax
, VFloat ay
, VFloat az
) ::
2336 st
', Prim
' Render
:: r
) =>
2338 amb the intensity
of ambient
light (a point
).
2339 lights is an array
of lights used to illuminate the scene
.
2340 obj is the scene to render
.
2341 depth is an integer limit on the recursive depth
of the ray tracing
.
2342 fov is the horizontal field
of view
in degrees (a
real number
).
2343 wid is the width
of the rendered image
in pixels (an integer
).
2344 ht is the height
of the rendered image
in pixels (an integer
).
2345 file is a
string specifying output file for the rendered image
.
2347 (Render
.f ((ax
, ay
, az
), lights
, obj
, depth
, fov
, wid
, ht
, file
)
2348 ; eval(env
, st
', r
))
2353 raise (Stuck_computation (env
, st
, p
))
2357 VClos (env
, p
) => eval(env
, st
, p
)
2358 | _
=> raise Fail
"assert false"
2360 val _
= Render
.apply
:= apply
2364 val st
= eval([], [], (conv([], p
)))
2368 | _
=> failwith
"error"
2369 end handle Stuck_computation (env
, st
, p
) => failwith
"stuck"
2375 Eval
.f (Program
.read (TextIO.openIn
"DATA/chess.gml"))