summaryrefslogtreecommitdiffstats
path: root/solid.scm
diff options
context:
space:
mode:
Diffstat (limited to 'solid.scm')
-rw-r--r--solid.scm943
1 files changed, 943 insertions, 0 deletions
diff --git a/solid.scm b/solid.scm
new file mode 100644
index 0000000..8b0ea56
--- /dev/null
+++ b/solid.scm
@@ -0,0 +1,943 @@
+;;; "solid.scm" Solid Modeling with VRML97
+; Copyright 2001 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://swissnet.ai.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 backgroud
+;;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 backgroud 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 backgroud 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-xyz (sunlight-CIEXYZ turbidity (car theta_s)))
+ (sun-color (and sun-xyz (CIEXYZ->color sun-xyz))))
+ (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-xyz (sunlight-CIEXYZ turbidity (car theta_s)))
+ (sun-color (and sun-xyz (CIEXYZ->color sun-xyz)))
+ (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 ((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)))
+
+;;@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)))
+ (attenuation (and (>= nargs 3) (cadr (caddr args))))
+ (radius (and (>= nargs 3) (caddr (caddr args)))))
+ (replicate-for-strength
+ (or intensity 1)
+ (lambda (inten)
+ (sprintf #f
+ "PointLight {location %s color %s intensity %g attenuation %s radius %g}\\n"
+ (coordinates3string location)
+ color intensity 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 {\\n
+ location %s direction %s beamWidth %g cutOffAngle %g\\n
+ color %s intensity %s attenuation %s radius %g}\\n"
+ (coordinates3string location)
+ direction
+ color
+ intensity
+ (and beamwidth (* pi/180 beamwidth))
+ (and cutoffangle (* 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)))))
+
+;;@args radius height appearance
+;;@args radius height
+;;Returns a right cylinder with dimensions @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
+;;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
+ (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 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 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))
+ (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 xdim) zdim (/ depth 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 shape)
+ (define zdim (- (cadar shape) (caar shape) -1))
+ (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 '()))))
+ 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))
+ (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))
+ (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? hshape cshape) "TRUE" "FALSE")
+ (apply string-append (reverse lns)))))
+
+;;@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))
+ ""))))))
+
+;;@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")))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:03:44 +0000