;;; "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 ;; ;;@end ifset ;;@code{(require 'solid)} ;;@ifset html ;; ;;@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")))