;;; "solid.scm" Solid Modeling with VRML97
; 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
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(require 'printf)
(require 'array)
(require 'array-for-each)
(require 'color)
(require 'color-space)			;for xyY:normalize-colors
(require-if 'compiling 'daylight)

;;@ifset html
;;<A NAME="Solid">
;;@end ifset
;;@code{(require 'solid)}
;;@ifset html
;;</A>
;;@end ifset
;;@ftindex solids
;;@ftindex solid
;;@ftindex solid-modeling
;;
;;@noindent
;;@uref{http://swiss.csail.mit.edu/~jaffer/Solid/#Example} gives an
;;example use of this package.

(define pi/180 (/ (* 4 (atan 1)) 180))

;;@body Returns the VRML97 string (including header) of the concatenation
;;of strings @1, @dots{}.
(define (vrml . nodes)
  (apply vrml-append (sprintf #f "#VRML V2.0 utf8\\n") nodes))

;;@body Returns the concatenation with interdigitated newlines of
;;strings @1, @2, @dots{}.
(define (vrml-append node1 . node2)
  (define nl (string #\newline))
  (apply string-append
	 node1
	 (apply append (map (lambda (node) (list nl node)) node2))))

;;@body Writes to file named @1 the VRML97 string (including header) of
;;the concatenation of strings @2, @dots{}.
(define (vrml-to-file file . nodes)
  (call-with-output-file file
    (lambda (oprt)
      (for-each (lambda (str) (display str oprt) (newline oprt))
		(cons (sprintf #f "#VRML V2.0 utf8") nodes)))))

;;@body Returns a VRML97 string setting the title of the file in which
;;it appears to @1.  Additional strings @2, @dots{} are comments.
(define (world:info title . info)
  (string-append
   (apply string-append
	  (sprintf #f "WorldInfo {title %#a info  [" title)
	  (map (lambda (str) (sprintf #f "  %#a\\n" str)) info))
   (sprintf #f "  ]\\n}\\n")))

;;@noindent
;;
;;VRML97 strings passed to @code{vrml} and @code{vrml-to-file} as
;;arguments will appear in the resulting VRML code.  This string turns
;;off the headlight at the viewpoint:
;;@example
;;" NavigationInfo @{headlight FALSE@}"
;;@end example

;;@body Specifies the distant images on the inside faces of the cube
;;enclosing the virtual world.
(define (scene:panorama front right back left top bottom)
  (sprintf #f "Background {%s%s%s%s%s%s}"
	   (if front  (sprintf #f "\\n  frontUrl %#a" front) "")
	   (if right  (sprintf #f "\\n  rightUrl %#a" right) "")
	   (if back   (sprintf #f "\\n  backUrl %#a" back) "")
	   (if left   (sprintf #f "\\n  leftUrl %#a" left) "")
	   (if top    (sprintf #f "\\n  topUrl %#a" top) "")
	   (if bottom (sprintf #f "\\n  bottomUrl %#a" bottom) "")))

;; 2-dimensional coordinates.
(define (coordinates2string obj)
  (if (vector? obj) (set! obj (vector->list obj)))
  (case (length obj)
    ((2) (apply sprintf #f "%g %g" obj))
    (else (slib:error 'coordinates2string obj))))

;; This one will duplicate number argument.
(define (coordinate2string obj)
  (coordinates2string (if (number? obj) (list obj obj) obj)))

;; 3-dimensional coordinates.
(define (coordinates3string obj)
  (if (vector? obj) (set! obj (vector->list obj)))
  (case (length obj)
    ((3) (apply sprintf #f "%g %g %g" obj))
    (else (slib:error 'coordinates3string obj))))

;; This one will triplicate number argument.
(define (coordinate3string obj)
  (coordinates3string (if (number? obj) (list obj obj obj) obj)))

(define (solid-color->sRGB obj)
  (cond ((not obj) #f)
	((color? obj) (map (lambda (x) (/ x 255.0)) (color->sRGB obj)))
	((list? obj) obj)
	((vector? obj) obj)
	((integer? obj)
	 (list (/ (quotient obj 65536) 255)
	       (/ (modulo (quotient obj 256) 256) 255)
	       (/ (modulo obj 256) 255)))
	(else (slib:error 'solid:color? obj))))

(define (color->vrml-field obj)
  (and obj (coordinates3string (solid-color->sRGB obj))))

(define (colors->vrml-field objs)
  (if (null? objs)
      "[]"
      (sprintf #f "[ %s%s ]"
	       (color->vrml-field (car objs))
	       (apply string-append
		      (map (lambda (obj)
			     (sprintf #f ",\\n   %s" (color->vrml-field obj)))
			   (cdr objs))))))

(define (angles->vrml-field objs)
  (if (null? objs)
      "[]"
      (sprintf #f "[ %g%s ]"
	       (* pi/180 (car objs))
	       (apply string-append
		      (map (lambda (obj) (sprintf #f ", %g" (* pi/180 obj)))
			   (cdr objs))))))

(define (direction->vrml-field obj)
  (if (vector? obj) (set! obj (vector->list obj)))
  (coordinates3string
   (case (length obj)
     ((2) (let ((th (* (car obj) pi/180))
		(ph (* (cadr obj) pi/180)))
	    (list (* (sin ph) (sin th))
		  (- (cos th))
		  (* -1 (cos ph) (sin th)))))
     ((3) obj)
     (else (slib:error 'not 'direction obj)))))

;;@body
;;
;;@1 is a list of color objects.  Each may be of type
;;@ref{Color Data-Type, color}, a 24-bit sRGB integer, or a list of 3
;;numbers between 0.0 and 1.0.
;;
;;@2 is a list of non-increasing angles the same length as
;;@1.  Each angle is between 90 and -90 degrees.  If 90 or -90 are not
;;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 background
;;sphere encasing the world.
(define (scene:sphere colors angles)
  (define seen0? 0)
  (if (vector? colors) (set! colors (vector->list colors)))
  (if (vector? angles) (set! angles (vector->list angles)))
  (if (not (eqv? (length colors) (length angles)))
      (slib:error 'scene:sphere 'length (length colors) (length angles)))
  ;;(@print angles)
  (cond ((< (car angles) 90)
	 (set! colors (cons (car colors) colors))
	 (set! angles (cons 90 angles))))
  (set! colors (reverse colors))
  (set! angles (reverse angles))
  (cond ((> (car angles) -90)
	 (set! colors (cons (car colors) colors))
	 (set! angles (cons -90 angles))))
  (let loop ((colors colors) (angles angles)
	     (ground-colors '()) (ground-angles '()))
    ;;(print 'loop 'angles angles 'ground-angles ground-angles)
    (cond
     ((null? angles)			; No ground colors
      (sprintf
       #f "Background {%s%s}"
       (sprintf #f "\\n  skyColor %s" (colors->vrml-field colors))
       (sprintf #f "\\n  skyAngle %s" (angles->vrml-field (cdr angles)))))
     ((and (zero? seen0?) (zero? (car angles)))
      (set! seen0? (+ 1 seen0?))
      (loop (cdr colors) (cdr angles)
	    (cons (car colors) ground-colors)
	    (cons 0 ground-angles)))
     ((>= (car angles) 0)
      (or (> seen0? 1)
	  (null? colors)
	  (null? ground-colors)
	  (zero? (car angles))
	  (let* ((sw (- (car ground-angles)))
		 (gw (car angles))
		 (avgclr
		  (map (lambda (sx gx)
			 (/ (+ (* sw sx) (* gw gx)) (+ sw gw)))
		       (solid-color->sRGB (car colors))
		       (solid-color->sRGB (car ground-colors)))))
	    (set! colors (cons avgclr colors))
	    (set! angles (cons 0 angles))
	    (set! ground-colors (cons avgclr ground-colors))
	    (set! ground-angles (cons 0 ground-angles))))
      (set! colors (reverse colors))
      (set! angles (reverse angles))
      (set! ground-colors (reverse ground-colors))
      (set! ground-angles (reverse ground-angles))
      (set! angles (map (lambda (angle) (- 90 angle)) angles))
      (set! ground-angles (map (lambda (angle) (+ 90 angle)) ground-angles))
      ;;(print 'final 'angles angles 'ground-angles ground-angles)
      (sprintf
       #f "Background {%s%s%s%s}"
       (sprintf #f "\\n  skyColor %s" (colors->vrml-field colors))
       (sprintf #f "\\n  skyAngle %s" (angles->vrml-field (cdr angles)))
       (sprintf #f "\\n  groundColor %s" (colors->vrml-field ground-colors))
       (sprintf #f "\\n  groundAngle %s" (angles->vrml-field (cdr ground-angles)))))
     (else (loop (cdr colors) (cdr angles)
		 (cons (car colors) ground-colors)
		 (cons (car angles) ground-angles))))))

;;@body Returns a blue and brown background sphere encasing the world.
(define (scene:sky-and-dirt)
  (scene:sphere
   '((0.0 0.2 0.7)
     (0.0 0.5 1.0)
     (0.9 0.9 0.9)
     (0.6 0.6 0.6)
     (0.4 0.25 0.2)
     (0.2 0.1 0.0)
     (0.3 0.2 0.0))
   '(90 15 0 0 -15 -70 -90)))

;;@body Returns a blue and green background sphere encasing the world.
(define (scene:sky-and-grass)
  (scene:sphere
    '((0.0 0.2 0.7)
      (0.0 0.5 1.0)
      (0.9 0.9 0.9)
      (0.6 0.6 0.6)
      (0.1 0.4 0.1)
      (0.2 0.4 0.25)
      (0.2 0.1 0.0)
      (0.3 0.2 0.0))
    '(90 15 0 0 -10 -31 -70 -90)))

(define (replicate-for-strength strength proc)
  (apply string-append
	 (vector->list (make-vector
			(inexact->exact (ceiling strength))
			(proc (/ strength (ceiling strength)))))))

;;@args latitude julian-day hour turbidity strength
;;@args latitude julian-day hour turbidity
;;
;;@1 is the virtual place's latitude in degrees.  @2 is an integer from
;;0 to 366, the day of the year.  @3 is a real number from 0 to 24 for
;;the time of day; 12 is noon.  @4 is the degree of fogginess described
;;in @xref{Daylight, turbidity}.
;;
;;@0 returns a bright yellow, distant sphere where the sun would be at
;;@3 on @2 at @1.  If @5 is positive, included is a light source of @5
;;(default 1).
(define (scene:sun latitude julian-day hour turbidity . strength)
  (require 'daylight)
  (let* ((theta_s (solar-polar (solar-declination julian-day)
			       latitude
			       (solar-hour julian-day hour)))
	 (phi_s (cadr theta_s))
	 (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))
    (vrml-append
     (if (positive? strength)
	 (light:directional sun-color (list theta_s phi_s) strength)
	 "")
     (if (positive? strength)
	 (light:ambient sun-color strength)
	 "")
     (solid:rotation
      '(0 -1 0) phi_s
      (solid:rotation
       '(1 0 0) theta_s
       (solid:translation
	'(0 150.e1 0)
	(solid:sphere .695e1 (solid:color #f #f #f #f sun-color))))))))

;;@args latitude julian-day hour turbidity strength
;;@args latitude julian-day hour turbidity
;;
;;@1 is the virtual place's latitude in degrees.  @2 is an integer from
;;0 to 366, the day of the year.  @3 is a real number from 0 to 24 for
;;the time of day; 12 is noon.  @4 is the degree of cloudiness described
;;in @xref{Daylight, turbidity}.
;;
;;@0 returns an overcast sky as it might look at @3 on @2 at @1.  If @5
;;is positive, included is an ambient light source of @5 (default 1).
(define (scene:overcast latitude julian-day hour turbidity . strength)
  (require 'daylight)
  (let* ((theta_s (solar-polar (solar-declination julian-day)
			       latitude
			       (solar-hour julian-day hour)))
	 (phi_s (cadr theta_s))
	 (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)))
    (if (not strength) (set! strength 0))
    (vrml-append
     (if (positive? strength)
	 (light:ambient sun-color strength)
	 "")
     (do ((elev 90 (/ elev 2))
	  (angles '() (cons elev angles))
	  (xyYs   '() (cons (color-func (- 90 elev)) xyYs)))
	 ((< elev 2)
	  (scene:sphere
	   (map (lambda (xyY) (CIEXYZ->color (xyY->XYZ xyY)))
		(reverse (xyY:normalize-colors (cons '(0 0 0) xyYs))))
	   (reverse (cons -90 angles))))))))

;;@noindent
;;Viewpoints are objects in the virtual world, and can be transformed
;;individually or with solid objects.

;;@args name distance compass pitch
;;@args name distance compass
;;Returns a viewpoint named @1 facing the origin and placed @2 from it.
;;@3 is a number from 0 to 360 giving the compass heading.  @4 is a
;;number from -90 to 90, defaulting to 0, specifying the angle from the
;;horizontal.
(define (scene:viewpoint name distance compass . pitch)
  (set! pitch (* pi/180 (if (null? pitch) 0 (car pitch))))
  (set! compass (* pi/180 compass))
  (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.
(define (scene:viewpoints proximity)
  (string-append
   (scene:viewpoint "North" proximity 0)
   (scene:viewpoint "Up" proximity 0 90)
   (scene:viewpoint "East" proximity 90)
   (scene:viewpoint "South" proximity 180)
   (scene:viewpoint "Down" proximity 0 -90)
   (scene:viewpoint "West" proximity 270)))

;;@subheading Light Sources

;;@noindent
;;In VRML97, lights shine only on objects within the same children node
;;and descendants of that node.  Although it would have been convenient
;;to let light direction be rotated by @code{solid:rotation}, this
;;restricts a rotated light's visibility to objects rotated with it.

;;@noindent
;;To workaround this limitation, these directional light source
;;procedures accept either Cartesian or spherical coordinates for
;;direction.  A spherical coordinate is a list @code{(@var{theta}
;;@var{azimuth})}; where @var{theta} is the angle in degrees from the
;;zenith, and @var{azimuth} is the angle in degrees due west of south.

;;@noindent
;;It is sometimes useful for light sources to be brighter than @samp{1}.
;;When @var{intensity} arguments are greater than 1, these functions
;;gang multiple sources to reach the desired strength.

;;@args color intensity
;;@args color
;;Ambient light shines on all surfaces with which it is grouped.
;;
;;@1 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB
;;integer, or a list of 3 numbers between 0.0 and 1.0.  If @1 is #f,
;;then the default color will be used.  @2 is a real non-negative number
;;defaulting to @samp{1}.
;;
;;@0 returns a light source or sources of @1 with total strength of @2
;;(or 1 if omitted).
(define (light:ambient color . intensity)
  (replicate-for-strength
   (if (null? intensity) 1 (car intensity))
   (lambda (inten)
     (sprintf #f ;;direction included for "lookat" bug.
	      "DirectionalLight {color %s ambientIntensity %g intensity 0 direction 0 1 0}\\n"
	      (or (color->vrml-field color) "1 1 1")
	      inten))))

;;@args color direction intensity
;;@args color direction
;;@args color
;;Directional light shines parallel rays with uniform intensity on all
;;objects with which it is grouped.
;;
;;@1 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB
;;integer, or a list of 3 numbers between 0.0 and 1.0.  If @1 is #f,
;;then the default color will be used.
;;
;;@2 must be a list or vector of 2 or 3 numbers specifying the direction
;;to this light.  If @2 has 2 numbers, then these numbers are the angle
;;from zenith and the azimuth in degrees; if @2 has 3 numbers, then
;;these are taken as a Cartesian vector specifying the direction to the
;;light source.  The default direction is upwards; thus its light will
;;shine down.
;;
;;@3 is a real non-negative number defaulting to @samp{1}.
;;
;;@0 returns a light source or sources of @1 with total strength of @3,
;;shining from @2.
(define (light:directional color . args)
  (define nargs (length args))
  (let ((direction (and (>= nargs 1) (car args)))
	(intensity (and (>= nargs 2) (cadr args))))
    (replicate-for-strength
     (or intensity 1)
     (lambda (inten)
       (sprintf #f
		"DirectionalLight {color %s direction %s intensity %g}\\n"
		(or (color->vrml-field color) "1 1 1")
		(direction->vrml-field direction)
		inten)))))

;;@args attenuation radius aperture peak
;;@args attenuation radius aperture
;;@args attenuation radius
;;@args attenuation
;;
;;@1 is a list or vector of three nonnegative real numbers specifying
;;the reduction of intensity, the reduction of intensity with distance,
;;and the reduction of intensity as the square of distance.  @2 is the
;;distance beyond which the light does not shine.  @2 defaults to
;;@samp{100}.
;;
;;@3 is a real number between 0 and 180, the angle centered on the
;;light's axis through which it sheds some light.  @4 is a real number
;;between 0 and 90, the angle of greatest illumination.
(define (light:beam attenuation . args)
  (define nargs (length args))
  (list (and (>= nargs 3) (caddr args))
	(and (>= nargs 2) (cadr args))
	(coordinates3string attenuation)
	(and (>= nargs 1) (car args))))

;;@args location color intensity beam
;;@args location color intensity
;;@args location color
;;@args location
;;
;;Point light radiates from @1, intensity decreasing with distance,
;;towards all objects with which it is grouped.
;;
;;@2 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB
;;integer, or a list of 3 numbers between 0.0 and 1.0.  If @2 is #f,
;;then the default color will be used.  @3 is a real non-negative number
;;defaulting to @samp{1}.  @4 is a structure returned by
;;@code{light:beam} or #f.
;;
;;@0 returns a light source or sources at @1 of @2 with total strength
;;@3 and @4 properties.  Note that the pointlight itself is not visible.
;;To make it so, place an object with emissive appearance at @1.
(define (light:point location . args)
  (define nargs (length args))
  (let ((color       (and (>= nargs 1) (color->vrml-field (car args))))
	(intensity   (and (>= nargs 2) (cadr args)))
	(beamwidth   (and (>= nargs 3) (car (caddr args))))
	(cutoffangle (and (>= nargs 3) (cadr (caddr args))))
	(attenuation (and (>= nargs 3) (caddr (caddr args))))
	(radius      (and (>= nargs 3) (cadddr (caddr args)))))
    (replicate-for-strength
     (or intensity 1)
     (lambda (inten)
       (sprintf #f
		"PointLight {location %s color %s intensity %g%s}\\n"
		(coordinates3string location)
		color
		inten
		(if attenuation
		    (sprintf #f
			     "\\n
		attenuation %s radius %g"
			     attenuation
			     radius)
		    ""))))))

;;@args location direction color intensity beam
;;@args location direction color intensity
;;@args location direction color
;;@args location direction
;;@args location
;;
;;Spot light radiates from @1 towards @2, intensity decreasing with
;;distance, illuminating objects with which it is grouped.
;;
;;@2 must be a list or vector of 2 or 3 numbers specifying the direction
;;to this light.  If @2 has 2 numbers, then these numbers are the angle
;;from zenith and the azimuth in degrees; if @2 has 3 numbers, then
;;these are taken as a Cartesian vector specifying the direction to the
;;light source.  The default direction is upwards; thus its light will
;;shine down.
;;
;;@3 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB
;;integer, or a list of 3 numbers between 0.0 and 1.0.  If @3 is #f,
;;then the default color will be used.
;;
;;@4 is a real non-negative number defaulting to @samp{1}.
;;
;;@0 returns a light source or sources at @1 of @2 with total strength
;;@3.  Note that the spotlight itself is not visible.  To make it so,
;;place an object with emissive appearance at @1.
(define (light:spot location . args)
  (define nargs (length args))
  (let ((direction   (and (>= nargs 1) (coordinates3string (car args))))
	(color       (and (>= nargs 2) (color->vrml-field (cadr args))))
	(intensity   (and (>= nargs 3) (caddr args)))
	(beamwidth   (and (>= nargs 4) (car (cadddr args))))
	(cutoffangle (and (>= nargs 4) (cadr (cadddr args))))
	(attenuation (and (>= nargs 4) (caddr (cadddr args))))
	(radius      (and (>= nargs 4) (cadddr (cadddr args)))))
    (replicate-for-strength
     (or intensity 1)
     (lambda (inten)
       (sprintf #f
		"SpotLight {location %s direction %s color %s intensity %g%s}\\n"
		(coordinates3string location)
		direction
		color
		inten
		(if beamwidth
		    (sprintf #f
			     "\\n 
		beamWidth %g cutOffAngle %g attenuation %s radius %g"
			     (* pi/180 beamwidth)
			     (* pi/180 cutoffangle)
			     attenuation
			     radius)
		    ""))))))

;;@subheading Object Primitives

(define (solid:node . nodes)
  (sprintf #f "%s { %s }" (car nodes) (apply string-append (cdr nodes))))

;;@args geometry appearance
;;@args geometry
;;@1 must be a number or a list or vector of three numbers.  If @1 is a
;;number, the @0 returns a cube with sides of length @1 centered on the
;;origin.  Otherwise, @0 returns a rectangular box with dimensions @1
;;centered on the origin.  @2 determines the surface properties of the
;;returned object.
(define (solid:box geometry . appearance)
  (define geom
    (cond ((number? geometry) (list geometry geometry geometry))
	  ((vector? geometry) (vector->list geometry))
	  (else geometry)))
  (solid:node "Shape"
	      (if (null? appearance) "" (string-append (car appearance) " "))
	      "geometry "
	      (solid:node "Box" (sprintf #f "size %s"
					 (coordinate3string geom)))))

;;@body
;;Returns a box of the specified @1, but with the y-axis of a texture
;;specified in @2 being applied along the longest dimension in @1.
(define (solid:lumber geometry appearance)
  (define x (car geometry))
  (define y (cadr geometry))
  (define z (caddr geometry))
  (cond ((and (>= y x) (>= y z))
	 (solid:box geometry appearance))
	((and (>= x y) (>= x z))
	 (solid:rotation '(0 0 1) 90
			 (solid:box (list y x z) appearance)))
	(else
	 (solid:rotation '(1 0 0) 90
			 (solid:box (list x z y) appearance)))))

;;@args radius height appearance
;;@args radius height
;;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.  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%s"
				   (abs height) (abs radius)
				   (if (negative? radius)
				       " side FALSE"
				       "")
				   (if (negative? height)
				       " bottom FALSE top FALSE"
				       "")))))

;;@args radius thickness appearance
;;@args radius thickness
;;@2 must be a positive real number.  @0 returns a circular disk
;;with dimensions @1 and @2 centered on the origin.  @3 determines the
;;surface properties of the returned object.
(define (solid:disk radius thickness . appearance)
  (solid:node "Shape"
	      (if (null? appearance) "" (string-append (car appearance) " "))
	      "geometry "
	      (solid:node "Cylinder" (sprintf #f "height %g radius %g"
					      thickness radius))))

;;@args radius height appearance
;;@args radius height
;;Returns an isosceles cone with dimensions @1 and @2 centered on
;;the origin.  @3 determines the surface properties of the returned
;;object.
(define (solid:cone radius height . appearance)
  (solid:node "Shape"
	      (if (null? appearance) "" (string-append (car appearance) " "))
	      "geometry "
	      (solid:node "Cone" (sprintf #f "height %g bottomRadius %g"
					  height radius))))

;;@args side height appearance
;;@args side height
;;Returns an isosceles pyramid with dimensions @1 and @2 centered on
;;the origin.  @3 determines the surface properties of the returned
;;object.
(define (solid:pyramid side height . appearance)
  (define si (/ side 2))
  (define hi (/ height 2))
  (solid:node "Shape"
	      (if (null? appearance) "" (string-append (car appearance) " "))
	      "geometry "
	      (solid:node "Extrusion"
			  (sprintf
			   #f "spine [0 -%g 0, 0 %g 0] scale [%g %g, 0 0]"
			   hi hi si si))))

;;@args radius appearance
;;@args radius
;;Returns a sphere of radius @1 centered on the origin.  @2 determines
;;the surface properties of the returned object.
(define (solid:sphere radius . appearance)
  (solid:node "Shape"
	      (if (null? appearance) "" (string-append (car appearance) " "))
	      "geometry "
	      (solid:node "Sphere" (sprintf #f "radius %g" radius))))

;;@args geometry appearance
;;@args geometry
;;@1 must be a number or a list or vector of three numbers.  If @1 is a
;;number, the @0 returns a sphere of diameter @1 centered on the origin.
;;Otherwise, @0 returns an ellipsoid with diameters @1 centered on the
;;origin.  @2 determines the surface properties of the returned object.
(define (solid:ellipsoid geometry . appearance)
  (cond ((number? geometry) (apply solid:sphere (* 2 geometry) appearance))
	((or (list? geometry) (vector? geometry))
	 (solid:scale
	  geometry
	  (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 xz-array y appearance
;;@args xz-array y
;;@1 must be an @var{n}-by-2 array holding a sequence of coordinates
;;tracing a non-intersecting clockwise loop in the x-z plane.  @0 will
;;close the sequence if the first and last coordinates are not the
;;same.
;;
;;@0 returns a capped prism @2 long.
(define (solid:prism xz-array y . appearance)
  (define y/2 (/ y 2))
  (define dims (array-dimensions xz-array))
  ;;(define (sfbool bool) (if bool "TRUE" "FALSE"))
  (if (not (eqv? 2 (cadr dims))) (slib:error 'solid:prism 'dimensions dims))
  (sprintf #f
	   "\
Shape {
      %s
   geometry Extrusion {
      convex FALSE
      endCap TRUE
      beginCap TRUE
      spine [0 %g 0, 0 %g 0]
      crossSection [%s]
   }
}
"
	   (if (null? appearance) "" (car appearance))
	   (- y/2) y/2
	   (do ((str (if (and (= (array-ref xz-array (+ -1 (car dims)) 0)
				 (array-ref xz-array 0 0))
			      (= (array-ref xz-array (+ -1 (car dims)) 1)
				 (array-ref xz-array 0 1)))
			 ""
			 (sprintf #f "%g, %g\n"
				  (array-ref xz-array (+ -1 (car dims)) 0)
				  (array-ref xz-array (+ -1 (car dims)) 1)))
		     (string-append str (sprintf #f "      %g, %g\n"
						 (array-ref xz-array idx 0)
						 (array-ref xz-array idx 1))))
		(idx 0 (+ 1 idx)))
	       ((>= idx (car dims)) str))))

;;@args width height depth colorray appearance
;;@args width height depth appearance
;;@args width height depth
;;One of @1, @2, or @3 must be a 2-dimensional array; the others must
;;be real numbers giving the length of the basrelief in those
;;dimensions.  The rest of this description assumes that @2 is an
;;array of heights.
;;
;;@0 returns a @1 by @3 basrelief solid with heights per array @2 with
;;the buttom surface centered on the origin.
;;
;;If present, @5 determines the surface properties of the returned
;;object.  If present, @4 must be an array of objects of type
;;@ref{Color Data-Type, color}, 24-bit sRGB integers or lists of 3
;;numbers between 0.0 and 1.0.
;;
;;If @4's dimensions match @2, then each element of @4 paints its
;;corresponding vertex of @2.  If @4 has all dimensions one smaller
;;than @2, then each element of @4 paints the corresponding face of
;;@2.  Other dimensions for @4 are in error.
(define (solid:basrelief width height depth . args)
  (cond ((array? height) (solid:bry width height depth args))
	((array? width)
	 (solid:rotation
	  '(0 0 -1) 90 (solid:bry height width depth args)))
	((array? depth)
	 (solid:rotation
	  '(-1 0 0) 90 (solid:bry width depth height args)))))

(define (solid:bry width heights depth args)
  (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
      "Shape"
      (case (length args)
	((2) (cadr args))
	((1) (car args))
	((0) "")
	(else (slib:error 'solid:basrelief 'too-many-args)))
      " geometry "
      (solid:node
       " ElevationGrid"
       " solid FALSE"
       (sprintf #f "  xDimension %g xSpacing %g zDimension %g zSpacing %g\\n"
		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)
	     ((2) (solid:extract-colors heights (car args)))
	     ((1 0) ""))
	   ""))))))

(define (solid:extract-elevations heights dimensions)
  (define zdim (cadr dimensions))
  (define cnt 0)
  (define hts '())
  (define lns '())
  (array-for-each
   (lambda (ht)
     (set! cnt (+ 1 cnt))
     (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 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 hdims)
				      (apply append cdims)))))
	(else (slib:error 'solid:basrelief 'mismatch 'dimensions hdims cdims)))
  (let ((ldim (cadr cdims))
	(cnt 0)
	(sts '())
	(lns '()))
    (array-for-each
     (lambda (clr)
       (set! sts (cons (sprintf #f " %s," (color->vrml-field clr)) sts))
       (set! cnt (+ 1 cnt))
       (cond ((>= cnt ldim)
	      (set! cnt 0)
	      (set! lns (cons (sprintf #f "%s\\n  "
				       (apply string-append (reverse sts)))
			      lns))
	      (set! sts '()))))
     colora)
    (sprintf #f " colorPerVertex %s color Color {color [%s]}\\n"
	     (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
;;@args diffuseColor ambientIntensity specularColor shininess emissiveColor
;;@args diffuseColor ambientIntensity specularColor shininess
;;@args diffuseColor ambientIntensity specularColor
;;@args diffuseColor ambientIntensity
;;@args diffuseColor
;;
;;Returns an @dfn{appearance}, the optical properties of the objects
;;with which it is associated.  @2, @4, and @6 must be numbers between 0
;;and 1.  @1, @3, and @5 are objects of type @ref{Color Data-Type, color},
;;24-bit sRGB integers or lists of 3 numbers between 0.0 and 1.0.
;;If a color argument is omitted or #f, then the default color will be used.
(define (solid:color dc . args)
  (define nargs (length args))
  (set! dc (color->vrml-field dc))
  (let ((ai (and (>= nargs 1) (car args)))
	(sc (and (>= nargs 2) (color->vrml-field (cadr args))))
	(si (and (>= nargs 3) (caddr args)))
	(ec (and (>= nargs 4) (color->vrml-field (cadddr args))))
	(tp (and (>= nargs 5) (list-ref args 4))))
    (sprintf
     #f "appearance Appearance {\\n  material Material {\\n%s%s%s%s%s%s}}"
     (if dc (sprintf #f "    diffuseColor %s\\n"     dc) "")
     (if ai (sprintf #f "    ambientIntensity %g\\n" ai) "")
     (if sc (sprintf #f "    specularColor %s\\n"    sc) "")
     (if si (sprintf #f "    shininess %g\\n"        si) "")
     (if ec (sprintf #f "    emissiveColor %s\\n"    ec) "")
     (if tp (sprintf #f "    transparency %g\\n"     tp) ""))))

;;@args image color scale rotation center translation
;;@args image color scale rotation center
;;@args image color scale rotation
;;@args image color scale
;;@args image color
;;@args image
;;
;;Returns an @dfn{appearance}, the optical properties of the objects
;;with which it is associated.  @1 is a string naming a JPEG or PNG
;;image resource.  @2 is #f, a color, or the string returned by
;;@code{solid:color}.  The rest of the optional arguments specify
;;2-dimensional transforms applying to the @1.
;;
;;@3 must be #f, a number, or list or vector of 2 numbers specifying the
;;scale to apply to @1.  @4 must be #f or the number of degrees to
;;rotate @1.  @5 must be #f or a list or vector of 2 numbers specifying
;;the center of @1 relative to the @1 dimensions.  @6 must be #f or a
;;list or vector of 2 numbers specifying the translation to apply to @1.
(define (solid:texture image . args)
  (define nargs (length args))
  (let ((color       (and (>= nargs 1) (car args)))
	(scale       (and (>= nargs 2) (cadr args)))
	(rotation    (and (>= nargs 3) (caddr args)))
	(center      (and (>= nargs 4) (cadddr args)))
	(translation (and (>= nargs 5) (list-ref args 5))))
    (cond ((not color))
	  ((not (string? color))
	   (set! color (solid:color color))))
    (cond ((not color))
	  ((< (string-length color) 24))
	  ((equal? "appearance Appearance {" (substring color 0 23))
	   (set! color (substring color 23 (+ -1 (string-length color))))))
    (sprintf
     #f "appearance Appearance {%s\\n  texture ImageTexture { url %#a }%s}\\n"
     (or color "")
     image
     (if (< nargs 2)
	 ""
	 (sprintf
	  #f
	  "\\n    textureTransform TextureTransform {%s%s%s%s\\n   }\\n"
	  (if (not scale)
	      ""
	      (sprintf #f "\\n      scale %s" (coordinate2string scale)))
	  (if rotation (sprintf #f "\\n      rotation %g"
				(* pi/180 rotation))
	      "")
	  (if center
	      (sprintf #f "\\n      center %s"
		       (coordinates2string center))
	      "")
	  (if translation
	      (sprintf #f "\\n      translation %s"
		       (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.
(define (solid:center-row-of number solid spacing)
  (define (scale-by lst scaler) (map (lambda (x) (* x scaler)) lst))
  (if (vector? spacing) (set! spacing (vector->list spacing)))
  (do ((idx (quotient (+ 1 number) 2) (+ -1 idx))
       (center (if (odd? number)
		   '(0 0 0)
		   (scale-by spacing .5))
	       (map + spacing center))
       (vrml (if (odd? number)
		 (sprintf #f "%s\\n" solid)
		 "")
	     (string-append (solid:translation (map - center) solid)
			    vrml
			    (solid:translation center solid))))
      ((not (positive? idx)) vrml)))

;;@body Returns @2 rows, @5 apart, of @1 @3 objects @4 apart.
(define (solid:center-array-of number-a number-b solid spacing-a spacing-b)
  (define (scale-by lst scaler) (map (lambda (x) (* x scaler)) lst))
  (define row (solid:center-row-of number-b solid spacing-b))
  (if (vector? spacing-a) (set! spacing-a (vector->list spacing-a)))
  (do ((idx (quotient (+ 1 number-a) 2) (+ -1 idx))
       (center (if (odd? number-a)
		   '(0 0 0)
		   (scale-by spacing-a .5))
	       (map + spacing-a center))
       (vrml (if (odd? number-b)
		 (sprintf #f "%s\\n" row)
		 "")
	     (string-append (solid:translation (map - center) row)
			    vrml
			    (solid:translation center row))))
      ((not (positive? idx)) vrml)))

;;@body Returns @3 planes, @7 apart, of @2 rows, @6 apart, of @1 @4 objects @5 apart.
(define (solid:center-pile-of number-a number-b number-c solid spacing-a spacing-b spacing-c)
  (define (scale-by lst scaler) (map (lambda (x) (* x scaler)) lst))
  (define plane (solid:center-array-of number-b number-c solid spacing-b spacing-c))
  (if (vector? spacing-a) (set! spacing-a (vector->list spacing-a)))
  (do ((idx (quotient (+ 1 number-a) 2) (+ -1 idx))
       (center (if (odd? number-a)
		   '(0 0 0)
		   (scale-by spacing-a .5))
	       (map + spacing-a center))
       (vrml (if (odd? number-b)
		 (sprintf #f "%s\\n" plane)
		 "")
	     (string-append (solid:translation (map - center) plane)
			    vrml
			    (solid:translation center plane))))
      ((not (positive? idx)) vrml)))

;;@args center
;;@1 must be a list or vector of three numbers.  Returns an upward
;;pointing metallic arrow centered at @1.
;;
;;@args
;;Returns an upward pointing metallic arrow centered at the origin.
(define (solid:arrow . location)
  (solid:translation
   (if (null? location) '#(0 0 0) (car location))
   (solid:translation
    '#(0 .17 0)
    (solid:cone .04 .06 (solid:color '#(1 0 0) .2 '#(1 1 1) .8)))
   (solid:cylinder .006 .32 (solid:color #f #f '#(1 .5 .5) .8))
   (solid:sphere .014 (solid:color '#(0 0 1) #f '#(1 1 1) 1))))

;;@subheading Spatial Transformations

;;@body @1 must be a list or vector of three numbers.  @0 Returns an
;;aggregate of @2, @dots{} with their origin moved to @1.
(define (solid:translation center . solids)
  (string-append
   (sprintf #f "Transform {translation %s children [\\n"
	    (coordinates3string center))
   (apply string-append solids)
   (sprintf #f "  ]\\n}\\n")))

;;@body @1 must be a number or a list or vector of three numbers.  @0
;;Returns an aggregate of @2, @dots{} scaled per @1.
(define (solid:scale scale . solids)
  (define scales
    (cond ((number? scale) (list scale scale scale))
	  (else scale)))
  (string-append
   (sprintf #f "Transform {scale %s children [\\n" (coordinate3string scales))
   (apply string-append solids)
   (sprintf #f "  ]\\n}\\n")))

;;@body @1 must be a list or vector of three numbers.  @0 Returns an
;;aggregate of @3, @dots{} rotated @2 degrees around the axis @1.
(define (solid:rotation axis angle . solids)
  (if (vector? axis) (set! axis (vector->list axis)))
  (set! angle (* pi/180 angle))
  (string-append
   (sprintf #f "Transform {rotation %s %g children [\\n"
	    (coordinates3string axis) angle solids)
   (apply string-append solids)
   (sprintf #f "  ]\\n}\\n")))