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