From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:29 -0800 Subject: Import Upstream version 3a1 --- solid.scm | 943 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 943 insertions(+) create mode 100644 solid.scm (limited to 'solid.scm') 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 +;; +;;@end ifset +;;@code{(require 'solid)} +;;@ifset html +;; +;;@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"))) -- cgit v1.2.3