• Cannon fodder
• User interface for the torus

Problem 1 - Cannon fodder

;;; Problem 4-1

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

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

;; Creation of the sensor.
(define field-sensor (sensor new-SoFieldSensor field-sensor-cb))

;; Attaching the field sensor to the translation field
(-> field-sensor 'attach (-> target-manip 'translation))

;; Make a viewer
(define viewer (examiner root))
;; Set viewing mode
(-> viewer 'setViewing 0)

Problem 2 - User interface for the torus

;;; Problem 4-2

(load "ps3-4")

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

  (let ((self
	 (lambda (message)
	   
	   ;; Methods:
	   
	   (cond
	    ((eq? message 'getGeometry)
	     (lambda (self)
	       root))
	    
	    ;; 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't do this in C++ (without a lot of effort)!
	    ((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
		     (set! current-value new-value) ;; if true already,
		     				    ;; do nothing

		     ;; 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
		 (for-each
		  (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))))))
    ;; Set up dragger callback
    (send dragger 'addMotionCallback (get-scheme-dragger-cb)
	  (void-cast (callback-info (send self 'getValueChangedCallback))))
    self))

;;
;; Torus
;;

(define root (new-SoSeparator))
(send root 'ref)

(define my-torus (new-Torus 10.0 3.0 20 10))
(send root 'addChild (send my-torus 'getGeometry))
(define viewer (examiner root))
(send viewer 'setTitle "Torus Viewer")

;;
;; User Interface for torus
;;

(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"))
(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"))
(send slider-root 'addChild (send minor-radius-slider 'getGeometry))

;; These size parameters were obtained experimentally

;; 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)
;; setCameraType must be called before setSceneGraph
(send slider-viewer 'setCameraType (SoOrthographicCamera::getClassTypeId))
(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 major-radius-slider 'addOutputCallback
      (lambda (new-value)
	(send my-torus 'setMajorRadius new-value)))

;; callback which changes torus' minor radius size
(send minor-radius-slider 'addOutputCallback
      (lambda (new-value)
	(send my-torus 'setMinorRadius new-value)))

$Id: index.html,v 1.7 1997/01/10 18:44:27 kbrussel Exp $