## 1/19/96

Problems
Problem 1 - Making a faster torus

```;;; Problem 4-1

(define M_PI 3.14159265358979323846)

;; Same as PS3

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

x-res
y-res)
(define (vert-loop vert-step horiz-step)
(if (<= vert-step y-res)
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")

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)
(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
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)))

(send self 'generate)))

(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 2 - Cannon fodder

```;;; 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 3 - User interface for the torus

```;;; Problem 4-3

;; 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.

(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))))

(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"))

;; 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"))

;; 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
(send my-torus 'setMajorRadius new-value))
;; adding this callback to the ValueSlider