diff options
Diffstat (limited to 'solid.scm')
| -rw-r--r-- | solid.scm | 231 |
1 files changed, 187 insertions, 44 deletions
@@ -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. |