Import Upstream version 3a2upstream/3a2

1 files changed, 187 insertions, 44 deletions

diff --git a/solid.scm b/solid.scm
index 8b0ea56..f0b1666 100644
--- a/solid.scm
+++ b/solid.scm
@@ -1,5 +1,5 @@
 ;;; "solid.scm" Solid Modeling with VRML97
-; Copyright 2001 Aubrey Jaffer
+; Copyright 2001, 2004 Aubrey Jaffer
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -36,7 +36,7 @@
 ;;@ftindex solid-modeling
 ;;
 ;;@noindent
-;;@uref{http://swissnet.ai.mit.edu/~jaffer/Solid/#Example} gives an
+;;@uref{http://swiss.csail.mit.edu/~jaffer/Solid/#Example} gives an
 ;;example use of this package.
 
 (define pi/180 (/ (* 4 (atan 1)) 180))
@@ -169,7 +169,7 @@
 ;;elements of @2, then the color at the zenith and nadir are taken from
 ;;the colors paired with the angles nearest them.
 ;;
-;;@0 fills horizontal bands with interpolated colors on the backgroud
+;;@0 fills horizontal bands with interpolated colors on the background
 ;;sphere encasing the world.
 (define (scene:sphere colors angles)
   (define seen0? 0)
@@ -233,7 +233,7 @@
 		 (cons (car colors) ground-colors)
 		 (cons (car angles) ground-angles))))))
 
-;;@body Returns a blue and brown backgroud sphere encasing the world.
+;;@body Returns a blue and brown background sphere encasing the world.
 (define (scene:sky-and-dirt)
   (scene:sphere
    '((0.0 0.2 0.7)
@@ -245,7 +245,7 @@
      (0.3 0.2 0.0))
    '(90 15 0 0 -15 -70 -90)))
 
-;;@body Returns a blue and green backgroud sphere encasing the world.
+;;@body Returns a blue and green background sphere encasing the world.
 (define (scene:sky-and-grass)
   (scene:sphere
     '((0.0 0.2 0.7)
@@ -281,8 +281,9 @@
 			       latitude
 			       (solar-hour julian-day hour)))
 	 (phi_s (cadr theta_s))
-	 (sun-xyz (sunlight-CIEXYZ turbidity (car theta_s)))
-	 (sun-color (and sun-xyz (CIEXYZ->color sun-xyz))))
+	 (sun-chroma (sunlight-chromaticity turbidity (car theta_s)))
+	 (sun-color (and sun-chroma
+			 (CIEXYZ->color (apply chromaticity->CIEXYZ sun-chroma)))))
     (set! theta_s (car theta_s))
     (set! strength (if (null? strength) 1 (car strength)))
     (if (not strength) (set! strength 0))
@@ -317,8 +318,9 @@
 			       latitude
 			       (solar-hour julian-day hour)))
 	 (phi_s (cadr theta_s))
-	 (sun-xyz (sunlight-CIEXYZ turbidity (car theta_s)))
-	 (sun-color (and sun-xyz (CIEXYZ->color sun-xyz)))
+	 (sun-chroma (sunlight-chromaticity turbidity (car theta_s)))
+	 (sun-color (and sun-chroma
+			 (CIEXYZ->color (apply chromaticity->CIEXYZ sun-chroma))))
 	 (color-func (overcast-sky-color-xyY turbidity (car theta_s))))
     (set! theta_s (car theta_s))
     (set! strength (if (null? strength) 1 (car strength)))
@@ -349,12 +351,14 @@
 (define (scene:viewpoint name distance compass . pitch)
   (set! pitch (* pi/180 (if (null? pitch) 0 (car pitch))))
   (set! compass (* pi/180 compass))
-  (let ((vp
-	 (sprintf #f "Viewpoint {description \"%s\" %s %s}"
-		  name
-		  (sprintf #f "position 0 0 %g" distance)
-		  (sprintf #f "orientation 1 0 0 %g" pitch))))
-    (sprintf #f "Transform {rotation 0 -1 0 %g children [%s]}\\n" compass vp)))
+  (let ((level				;fieldOfView 0.785398 (pi/4)
+	 (sprintf #f "Viewpoint {position 0 0 %g description %#a}"
+		  distance name)))
+    (define tilt
+      (sprintf #f "Transform {rotation 1 0 0 %g children [%s]}\\n"
+	       pitch level))
+    (sprintf #f "Transform {rotation 0 -1 0 %g children [%s]}\\n"
+	     compass tilt)))
 
 ;;@body Returns 6 viewpoints, one at the center of each face of a cube
 ;;with sides 2 * @1, centered on the origin.
@@ -568,17 +572,21 @@
 
 ;;@args radius height appearance
 ;;@args radius height
-;;Returns a right cylinder with dimensions @1 and @code{(abs @2)}
+;;Returns a right cylinder with dimensions @code{(abs @1)} and @code{(abs @2)}
 ;;centered on the origin.  If @2 is positive, then the cylinder ends
-;;will be capped.  @3 determines the surface properties of the returned
+;;will be capped.  If @1 is negative, then only the ends will appear.
+;;@3 determines the surface properties of the returned
 ;;object.
 (define (solid:cylinder radius height . appearance)
   (solid:node "Shape"
 	      (if (null? appearance) "" (string-append (car appearance) " "))
 	      "geometry "
 	      (solid:node "Cylinder"
-			  (sprintf #f "height %g radius %g%s"
-				   (abs height) radius
+			  (sprintf #f "height %g radius %g%s%s"
+				   (abs height) (abs radius)
+				   (if (negative? radius)
+				       " side FALSE"
+				       "")
 				   (if (negative? height)
 				       " bottom FALSE top FALSE"
 				       "")))))
@@ -647,6 +655,44 @@
 	  (apply solid:sphere .5 appearance)))
 	(else (slib:error 'solid:ellipsoid '? (cons geometry appearance)))))
 
+;;@args coordinates appearance
+;;@args coordinates
+;;@1 must be a list or vector of coordinate lists or vectors
+;;specifying the x, y, and z coordinates of points.  @0 returns lines
+;;connecting successive pairs of points.  If called with one argument,
+;;then the polyline will be white.  If @2 is given, then the polyline
+;;will have its emissive color only; being black if @2 does not have
+;;an emissive color.
+;;
+;;The following code will return a red line between points at
+;;@code{(1 2 3)} and @code{(4 5 6)}:
+;;@example
+;;(solid:polyline '((1 2 3) (4 5 6)) (solid:color #f 0 #f 0 '(1 0 0)))
+;;@end example
+(define (solid:polyline coordinates . args)
+  (define coordslist (if (list? coordinates)
+			 coordinates
+			 (array->list coordinates)))
+  (solid:node
+   "Shape"
+   (case (length args)
+     ((1) (car args))
+     ((0) "")
+     (else (slib:error 'solid:indexed-polylines 'too-many-args)))
+   " geometry "
+   (solid:node
+    " IndexedLineSet"
+    (sprintf #f " coord Coordinate { point [%s] }\\n coordIndex [%s]"
+	     (apply string-append
+		    (map (lambda (lst)
+			   (apply sprintf #f " %g %g %g,"
+				  (if (vector? lst) (vector->list lst) lst)))
+			 coordslist))
+	     (do ((idx (+ -1 (length coordslist)) (+ -1 idx))
+		  (lst '() (cons (sprintf #f " %g," idx) lst)))
+		 ((negative? idx)
+		  (apply string-append lst)))))))
+
 ;;@args width height depth colorray appearance
 ;;@args width height depth appearance
 ;;@args width height depth
@@ -677,12 +723,12 @@
 	  '(-1 0 0) 90 (solid:bry width depth height args)))))
 
 (define (solid:bry width heights depth args)
-  (define shape (array-shape heights))
-  (if (not (eqv? 2 (length shape)))
-      (slib:error 'solid:basrelief 'rank? shape))
-  (let ((xdim (- (cadadr shape) (caadr shape) -1))
-	(zdim (- (cadar shape) (caar shape) -1)))
-    (define elevs (solid:extract-elevations heights shape))
+  (define dimensions (array-dimensions heights))
+  (if (not (eqv? 2 (length dimensions)))
+      (slib:error 'solid:basrelief 'rank? dimensions))
+  (let ((xdim (cadr dimensions))
+	(zdim (car dimensions)))
+    (define elevs (solid:extract-elevations heights dimensions))
     (solid:translation
      (list (* -1/2 width) 0 (* -1/2 depth))
      (solid:node
@@ -697,7 +743,7 @@
        " ElevationGrid"
        " solid FALSE"
        (sprintf #f "  xDimension %g xSpacing %g zDimension %g zSpacing %g\\n"
-		xdim (/ width xdim) zdim (/ depth zdim))
+		xdim (/ width (+ -1 xdim)) zdim (/ depth (+ -1 zdim)))
        (sprintf #f "   height [%s]\\n" elevs)
        (if (and (not (null? args)) (<= 2 (array-rank (car args))))
 	   (case (length args)
@@ -705,35 +751,39 @@
 	     ((1 0) ""))
 	   ""))))))
 
-(define (solid:extract-elevations heights shape)
-  (define zdim (- (cadar shape) (caar shape) -1))
+(define (solid:extract-elevations heights dimensions)
+  (define zdim (cadr dimensions))
   (define cnt 0)
   (define hts '())
   (define lns '())
   (array-for-each
    (lambda (ht)
-     (set! hts (cons (sprintf #f " %g" ht) hts))
      (set! cnt (+ 1 cnt))
-     (cond ((>= cnt zdim)
-	    (set! cnt 0)
-	    (set! lns (cons (sprintf #f "  %s\\n"
-				     (apply string-append (reverse hts)))
-			    lns))
-	    (set! hts '()))))
+     (set! hts (cons (sprintf #f
+			      (if (zero? (modulo cnt 8)) "\\n     %g" " %g") ht)
+		     hts))
+     (cond
+      ((>= cnt zdim)
+       (set! cnt 0)
+       (set! lns (cons (apply string-append
+			      (cons "  "
+				    (reverse (cons (sprintf #f "\\n") hts))))
+		       lns))
+       (set! hts '()))))
    heights)
   (if (not (null? hts)) (slib:error 'solid:extract-elevations 'leftover hts))
   (apply string-append (reverse lns)))
 
 (define (solid:extract-colors heights colora)
-  (define hshape (array-shape heights))
-  (define cshape (array-shape colora))
-  (cond ((equal? hshape cshape))
-	((and (eqv? 2 (length cshape))
+  (define hdims (array-dimensions heights))
+  (define cdims (array-dimensions colora))
+  (cond ((equal? hdims cdims))
+	((and (eqv? 2 (length cdims))
 	      (equal? '(0 1 0 1) (map -
-				      (apply append hshape)
-				      (apply append cshape)))))
-	(else (slib:error 'solid:basrelief 'mismatch 'shape hshape cshape)))
-  (let ((ldim (- (cadadr cshape) (caadr cshape) -1))
+				      (apply append hdims)
+				      (apply append cdims)))))
+	(else (slib:error 'solid:basrelief 'mismatch 'dimensions hdims cdims)))
+  (let ((ldim (cadr cdims))
 	(cnt 0)
 	(sts '())
 	(lns '()))
@@ -749,9 +799,45 @@
 	      (set! sts '()))))
      colora)
     (sprintf #f " colorPerVertex %s color Color {color [%s]}\\n"
-	     (if (equal? hshape cshape) "TRUE" "FALSE")
+	     (if (equal? hdims cdims) "TRUE" "FALSE")
 	     (apply string-append (reverse lns)))))
 
+;;@args fontstyle str len appearance
+;;@args fontstyle str len
+;;
+;;@1 must be a value returned by @code{solid:font}.
+;;
+;;@2 must be a string or list of strings.
+;;
+;;@3 must be #f, a nonnegative integer, or list of nonnegative
+;;integers.
+;;
+;;@4, if given, determines the surface properties of the returned
+;;object.
+;;
+;;@0 returns a two-sided, flat text object positioned in the Z=0 plane
+;;of the local coordinate system
+(define (solid:text fontstyle str lengths . appearance)
+  (solid:node
+   "Shape"
+   (if (null? appearance) "" (string-append (car appearance) " "))
+   "geometry "
+   (solid:node
+    "Text"
+    (sprintf #f "fontStyle %s string [ %s ]%s"
+	     fontstyle
+	     (apply string-append
+		    (map (lambda (st) (sprintf #f " %#a" st))
+			 (if (string? str) (list str) str)))
+	     (cond ((not lengths) "")
+		   ((number? lengths)
+		    (sprintf #f " maxExtent %g" lengths))
+		   (else
+		    (sprintf #f " length [ %s ]"
+			     (apply string-append
+				    (map (lambda (x) (sprintf #f " %g" x))
+					 lengths)))))))))
+
 ;;@subheading Surface Attributes
 
 ;;@args diffuseColor ambientIntensity specularColor shininess emissiveColor transparency
@@ -839,6 +925,63 @@
 		       (coordinates2string translation))
 	      ""))))))
 
+;;; X11 foundry-family-weight-slant-setwidth-style-pixelSize-pointSize-Xresolution-Yresolution-spacing-averageWidth-registry-encoding
+
+;;@body
+;;Returns a fontstyle object suitable for passing as an argument to
+;;@code{solid:text}.  Any of the arguments may be #f, in which case
+;;its default value, which is first in each list of allowed values, is
+;;used.
+;;
+;;@1 is a case-sensitive string naming a font; @samp{SERIF},
+;;@samp{SANS}, and @samp{TYPEWRITER} are supported at the minimum.
+;;
+;;@2 is a case-sensitive string @samp{PLAIN}, @samp{BOLD},
+;;@samp{ITALIC}, or @samp{BOLDITALIC}.
+;;
+;;@3 is a case-sensitive string @samp{FIRST}, @samp{BEGIN},
+;;@samp{MIDDLE}, or @samp{END}; or a list of one or two case-sensitive
+;;strings (same choices).  The mechanics of @3 get complicated; it is
+;;explained by tables 6.2 to 6.7 of
+;;@url{http://www.web3d.org/x3d/specifications/vrml/ISO-IEC-14772-IS-VRML97WithAmendment1/part1/nodesRef.html#Table6.2}
+;;
+;;
+;;@4 is the extent, in the non-advancing direction, of the text.
+;;@4 defaults to 1.
+;;
+;;@5 is the ratio of the line (or column) offset to @4.
+;;@5 defaults to 1.
+;;
+;;@6 is the RFC-1766 language name.
+;;
+;;@7 is a list of two numbers: @w{@code{(@var{x} @var{y})}}.  If
+;;@w{@code{(> (abs @var{x}) (abs @var{y}))}}, then the text will be
+;;arrayed horizontally; otherwise vertically.  The direction in which
+;;characters are arrayed is determined by the sign of the major axis:
+;;positive @var{x} being left-to-right; positive @var{y} being
+;;top-to-bottom.
+(define (solid:font family style justify size spacing language direction)
+  (define (field name value)
+    (if value (sprintf #f " %s %#a" name value) ""))
+  (define (bfield name boolean)
+    (sprintf #f " %s %s" name (if boolean "TRUE" "FALSE")))
+  (solid:node "FontStyle"
+	      (field "family" family)
+	      (field "style" style)
+	      (if (list? justify)
+		  (apply sprintf #f " %s [%#a %#a]" "justify" justify)
+		  (field "justify" justify))
+	      (field "size" size)
+	      (field "spacing" spacing)
+	      (field "language" language)
+	      (if direction
+		  (string-append
+		   (bfield "horizontal" (> (abs (car direction))
+					   (abs (cadr direction))))
+		   (bfield "leftToRight" (positive? (car direction)))
+		   (bfield "topToBottom" (positive? (cadr direction))))
+		  "")))
+
 ;;@subheading Aggregating Objects
 
 ;;@body Returns a row of @1 @2 objects spaced evenly @3 apart.