Computer Graphics Workshop '96 PS4 Solutions | 1/19/96 |
;;; Problem 4-1
(define M_PI 3.14159265358979323846)
;; Same as PS3
(define (compute-point-on-torus major-radius
minor-radius
x-res
y-res
x-index
y-index)
(let* ((theta (* (* 2.0 M_PI) (/ x-index x-res)))
(phi (* (* 2.0 M_PI) (/ y-index y-res)))
(x (* (+ major-radius
(* minor-radius (cos phi)))
(cos theta)))
(y (* minor-radius (sin phi)))
(z (* (+ major-radius
(* minor-radius (cos phi)))
(sin theta))))
(vector x y z)))
;; New function: compute-torus-points
(define (compute-torus-points major-radius
minor-radius
x-res
y-res)
(define (vert-loop vert-step horiz-step)
(if (<= vert-step y-res)
(cons (compute-point-on-torus major-radius
minor-radius
x-res
y-res
horiz-step
vert-step)
(vert-loop (1+ vert-step) horiz-step))
'()))
(define (horiz-loop step)
(if (<= step x-res)
(cons (vert-loop 0 step)
(horiz-loop (1+ step)))
'()))
(let ((slices-list (horiz-loop 0)))
(apply append slices-list)))
;;; SICP-ish simple object system for dealing similarly
;;; with Scheme and C++ objects using "send"
(define (send object message . args)
(if (C++-object? object)
(eval `(-> ,object ',message ,@args))
(let ((method (get-method object message)))
(if (not (no-method? method))
(apply method (cons object args))
(error "No method named" message)))))
(define (get-method object message)
(object message))
(define (no-method method)
'no-method)
(define (no-method? method)
(eq? method 'no-method))
;; Function which creates a new torus ("constructor")
(define (new-Torus major-radius
minor-radius
x-res
y-res)
(define root (new-SoSeparator))
(send root 'ref)
(define hints (new-SoShapeHints))
(send root 'addChild hints)
(send (send hints 'vertexOrdering)
'setValue SoShapeHints::CLOCKWISE)
(send (send hints 'creaseAngle) 'setValue 0.5)
(define coords (new-SoCoordinate3))
(send root 'addChild coords)
(define mat (new-SoMaterial))
(send root 'addChild mat)
(define quad-mesh (new-SoQuadMesh))
(send root 'addChild quad-mesh)
(lambda (message)
(cond ((eq? message 'getGeometry)
(lambda (self)
root))
;; New "generate" method for quad mesh.
((eq? message 'generate)
(lambda (self)
(let* ((points (compute-torus-points major-radius
minor-radius
x-res
y-res))
(num-points (length points)))
(set-mfield-values! (send coords 'point) 0 points)
(send (send coords 'point) 'setNum num-points)
(send (send quad-mesh 'verticesPerRow)
'setValue (1+ y-res))
(send (send quad-mesh 'verticesPerColumn)
'setValue (1+ x-res)))))
((eq? message 'setColor)
(lambda (self r g b)
(send (send mat 'diffuseColor) 'setValue r g b)))
((eq? message 'setCreaseAngle)
(lambda (self new-angle)
(send (send hints 'creaseAngle) 'setValue new-angle)))
((eq? message 'setVertexOrdering)
(lambda (self new-ordering)
(send (send hints 'vertexOrdering)
'setValue new-ordering)))
((eq? message 'setShapeType)
(lambda (self new-type)
(send (send hints 'shapeType) 'setValue new-type)))
((eq? message 'setMajorRadius)
(lambda (self new-major-radius)
(set! major-radius new-major-radius)
(send self 'generate)))
((eq? message 'setMinorRadius)
(lambda (self new-minor-radius)
(set! minor-radius new-minor-radius)
(send self 'generate)))
((eq? message 'setHorizResolution)
(lambda (self new-horiz-res)
(set! x-res new-horiz-res)
(send self 'generate)))
((eq? message 'setVertResolution)
(lambda (self new-vert-res)
(set! y-res new-vert-res)
(send self 'generate)))
(else (no-method message)))))
;;; Problem 4-2
(define viewer (new-SoXtExaminerViewer))
(-> viewer 'show)
(define root (new-SoSeparator))
(-> root 'ref)
(define cannon-sep (new-SoSeparator))
(-> root 'addChild cannon-sep)
(define cannon-base (new-SoCube))
(-> (-> cannon-base 'width) 'setValue 4)
(-> cannon-sep 'addChild cannon-base)
(define cannon-xform (new-SoTransform))
(-> cannon-sep 'addChild cannon-xform)
(-> (-> cannon-xform 'translation) 'setValue 0 4.0 0)
(define cannon-tube (new-SoCylinder))
(-> cannon-sep 'addChild cannon-tube)
(-> (-> cannon-tube 'height) 'setValue 6.0)
(define target-sep (new-SoSeparator))
(-> root 'addChild target-sep)
(define target-manip (new-SoHandleBoxManip))
(-> target-sep 'addChild target-manip)
(-> (-> target-manip 'translation) 'setValue 5 15 2)
(define target-mat (new-SoMaterial))
(-> target-sep 'addChild target-mat)
(define target (new-SoSphere))
(-> (-> target 'radius) 'setValue 0.5)
(-> target-sep 'addChild target)
(-> viewer 'setSceneGraph root)
;; Definition of callback which the field sensor uses.
;; Each time the translation field of the manipulator changes,
;; this function automatically gets called.
(define (field-sensor-cb data sensor)
(let* ((target-translation
(-> (-> target-manip 'translation) 'getValue))
(x (-> target-translation 'operator-brackets 0))
(y (-> target-translation 'operator-brackets 1))
(z (-> target-translation 'operator-brackets 2)))
(if (< y 7.5)
(-> (-> target-mat 'diffuseColor) 'setValue 0.8 0.8 0.8)
(let ((target-dist (sqrt (+ (* x x) (* z z)))))
(if (> target-dist 1.5)
(-> (-> target-mat 'diffuseColor)
'setValue 0.8 0.8 0.8)
(-> (-> target-mat 'diffuseColor)
'setValue 0.8 0.2 0.2))))))
;; Callback information object. This object tells C++ which
;; Scheme function to call (by name) and what argument
;; should go in the user data field. Here we are not using
;; this field, so the contents of it in the above function
;; will be (void *) NULL.
(define callback-info (new-SchemeSoCBInfo))
(-> callback-info 'ref)
(-> (-> callback-info 'callbackName) 'setValue "field-sensor-cb")
;; Creation of the sensor. The C++ callback function (obtained
;; via the call to (get-scheme-sensor-cb)) is the first argument;
;; the data for this function (which tells it which Scheme function
;; to call) is the second argument.
(define field-sensor (new-SoFieldSensor (get-scheme-sensor-cb)
(void-cast callback-info)))
;; Attaching the field sensor to the translation field
(-> field-sensor 'attach (-> target-manip 'translation))
;;; Problem 4-3
(load "ps4-1")
;; Function which creates a new ValueSlider object ("constructor")
(define (new-ValueSlider min-value max-value current-value title)
;; build internal scene graph for ValueSlider
(define root (new-SoSeparator))
(send root 'ref)
;; SoFont node changes size of font used for SoText3
(define font (new-SoFont))
(send root 'addChild font)
(send (send font 'size) 'setValue 0.5)
;; SoText3 node for the text this object will display
(define text (new-SoText3))
(send root 'addChild text)
(send (send text 'justification) 'setValue SoText3::CENTER)
(send (send text 'string) 'set1Value 0 (new-SbString title))
(send (send text 'string) 'set1Value 1
(new-SbString (number->string current-value)))
;; Dragger which this object uses
(define dragger (new-SoTranslate1Dragger))
(send root 'addChild dragger)
(send (send dragger 'translation) 'setValue current-value -1 0)
;; List of functions we will call when slider's value changes
(define callback-list '())
;; Message passing system
(lambda (message)
;; Methods:
(cond
((eq? message 'getGeometry)
(lambda (self)
root))
;; Internal method used by addValueChangedCallback below
((eq? message 'getCallbackInfo)
(lambda (self callback-name)
(define callback-info (new-SchemeSoCBInfo))
(send callback-info 'ref)
(send (send callback-info 'callbackName)
'setValue callback-name)
callback-info))
;; Sets up the Scheme callback which will be called (by name)
;; whenever the slider's value changes. Note that this callback
;; must (currently) be defined in the top-level environment.
((eq? message 'addValueChangedCallback)
(lambda (self callback-name)
(let ((cb-info (send self 'getCallbackInfo callback-name)))
;;; NOTE following two lines commented out.
;;; Inventor 2.0 does not support disabling of
;;; value changed callbacks, and apparently calling
;;; the value changed callback from within itself
;;; causes problems. To avoid this, we use a motion
;;; callback instead of a value changed callback.
;; (send dragger 'addValueChangedCallback
;; (get-scheme-dragger-cb) (void-cast cb-info))
(send dragger 'addMotionCallback (get-scheme-dragger-cb)
(void-cast cb-info))
)))
;; Returns the callback that the dragger will call when its
;; value changes. *NOTE* that because this function is scoped
;; within the method, it has access to the "self" variable. You
;; CAN NOT do this in C++!
((eq? message 'getValueChangedCallback)
(lambda (self)
(lambda (user-data dragger)
(send self 'updateValue))))
;; Function which ultimately gets called
;; whenever the dragger moves.
((eq? message 'updateValue)
(lambda (self)
(let* ((vec (send (send dragger 'translation) 'getValue))
;; Get horizontal component of translation
(new-value (send vec 'operator-brackets 0)))
(if (and (>= new-value min-value)
(<= new-value max-value)) ;; constrain dragger
;; between min and max
;; if true already, do nothing
(set! current-value new-value)
;; NOTE: The first and last of the following 4 steps
;; can only be performed in Inventor 2.1 or above.
;; Because of this, and because of apparent problems
;; with calling the value changed callback from within
;; itself, we are using a motion callback and ignoring
;; steps 1 and 4 in the list below.
;; If dragger is beyond min or max, do the following:
;; 1. Disable value changed callbacks
;; 2. Set the dragger's translation using the setValue
;; method on its translation field
;; 3. Set our internal notion of the current value
;; appropriately
;; 4. Reenable value changed callbacks.
(begin
(if (< new-value min-value)
(begin
(set! current-value min-value)
(send (send dragger 'translation)
'setValue min-value -1 0))
(begin
(set! current-value max-value)
(send (send dragger 'translation)
'setValue max-value -1 0)))))
;; Always update text to our notion of the current value.
(send (send text 'string) 'set1Value 1
(new-SbString (number->string current-value)))
;; call output callbacks
(map
(lambda (callback)
(callback current-value))
callback-list))))
((eq? message 'addOutputCallback)
(lambda (self callback-function)
(set! callback-list (cons callback-function callback-list))))
((eq? message 'getValue)
(lambda (self)
current-value))
(else (no-method message)))))
;; viewer for torus
(define viewer (new-SoXtExaminerViewer))
(send viewer 'show)
(send viewer 'setTitle "Torus Viewer")
(define root (new-SoSeparator))
(send root 'ref)
(define my-torus (new-Torus 10.0 3.0 20 10))
(send my-torus 'generate)
(send root 'addChild (send my-torus 'getGeometry))
(send viewer 'setSceneGraph root)
;; Viewer for torus controls.
;; Note usage of setViewing method to switch to the arrow icon
;; and setCameraType to get an orthographic (no perspective) view.
(define slider-viewer (new-SoXtExaminerViewer))
(send slider-viewer 'show)
(send slider-viewer 'setTitle "Torus Controls")
(send slider-viewer 'setViewing 0)
(send slider-viewer 'setCameraType
(SoOrthographicCamera::getClassTypeId))
(define slider-root (new-SoSeparator))
(send slider-root 'ref)
;; Definition of slider for controlling major radius of torus.
(define major-radius-slider (new-ValueSlider 5 20 10 "Major radius"))
(define major-radius-slider-callback
(send major-radius-slider 'getValueChangedCallback))
(send major-radius-slider
'addValueChangedCallback "major-radius-slider-callback")
(send slider-root 'addChild (send major-radius-slider 'getGeometry))
;; Transformation to keep some space between the sliders.
(define slider-xform1 (new-SoTransform))
(send slider-root 'addChild slider-xform1)
(send (send slider-xform1 'translation) 'setValue 0 -2 0)
;; Slider for controlling minor radius (thickness) of torus
(define minor-radius-slider (new-ValueSlider 0 10 3 "Minor radius"))
(define minor-radius-slider-callback
(send minor-radius-slider 'getValueChangedCallback))
(send minor-radius-slider
'addValueChangedCallback "minor-radius-slider-callback")
(send slider-root 'addChild (send minor-radius-slider 'getGeometry))
;; These size parameters were obtained experimentally
(send slider-viewer 'setSceneGraph slider-root)
(send slider-viewer 'setSize (new-SbVec2s 1092 215))
(send (send (send slider-viewer 'getCamera)
'position)
'setValue 9.72287178039551
-1.46681797504425
7.15330982208252)
(send (send (SoOrthographicCamera-cast
(send slider-viewer 'getCamera))
'height)
'setValue 4.33807563781738)
;; callback which changes torus' major radius size
(define (torus-major-radius-callback new-value)
(send my-torus 'setMajorRadius new-value))
;; adding this callback to the ValueSlider
(send major-radius-slider 'addOutputCallback
torus-major-radius-callback)
;; callback which changes torus' minor radius size
(define (torus-minor-radius-callback new-value)
(send my-torus 'setMinorRadius new-value))
;; adding this callback to the ValueSlider
(send minor-radius-slider 'addOutputCallback
torus-minor-radius-callback)
$Id: index.html,v 1.4 1996/01/23 02:55:51 kbrussel Exp $