Computer Graphics Workshop '96 PS4 Solutions

1/19/96

Problems
Problem 1 - Making a faster torus

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

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

Back to the CGW '96 home page

$Id: index.html,v 1.4 1996/01/23 02:55:51 kbrussel Exp $