This Scheme code was written to give you an idea of the kind of program I wanted you to write for programming assignment #3.
; A demonstration for programming assignment #3.
(define (main)
(setup-menus)
(make-graphic-window)
(initialize-world)
(initCursor)
(kill-all-tasks)
(begin-tasking)
(start-task
(lambda ()
(while #t
(if (not (null? *tasks-to-run*))
(call-without-interrupts
(lambda ()
(let ((task (car *tasks-to-run*)))
(set! *tasks-to-run* (cdr *tasks-to-run*))
(start-task task)))))
(surrender-timeslice))))
#t)
(define *tasks-to-run* '())
(define (enqueue-task task)
(set! *tasks-to-run*
(cons task *tasks-to-run*)))
(define graphic-menu)
(define (setup-menus)
(setup-graphic-menu)
)
(define (setup-graphic-menu)
(let* ((m (make-menu "Graphics")))
(set! graphic-menu m)
(m 'append
"Refresh"
refresh-graphics)
(m 'append
"Transform/T"
repeat-current-transformation)
(m 'append
"-"
(lambda () #t)
(lambda () #f)) ; always disable
(m 'append
"New transformation"
initialize-transformation)
(m 'append
"Scale..."
scale-transformation)
(m 'append
"Rotate about x axis..."
rotate-x-transformation)
(m 'append
"Rotate about y axis..."
rotate-y-transformation)
(m 'append
"Rotate about z axis..."
rotate-z-transformation)
(m 'append
"Translate x..."
translate-x-transformation)
(m 'append
"Translate y..."
translate-y-transformation)
(m 'append
"Translate z..."
translate-z-transformation)
(m 'append
"-"
(lambda () #t)
(lambda () #f)) ; always disable
(m 'append
"Display corners"
display-corners)
(m 'append
"Display edges"
display-edges)
(m 'append
"-"
(lambda () #t)
(lambda () #f)) ; always disable
(m 'append
"Close graphics/Q"
(lambda ()
(enqueue-task
(lambda ()
(end-tasking)
(kill-all-tasks)
(m 'close)
(graphic-window 'close)))))))
; Actions for menu items.
(define (scale-transformation)
(enqueue-task
(lambda ()
(let* ((s (get-input "Type the scale factor"))
(factor (string->number s)))
(if (and (number? factor)
(real? factor)
(positive? factor))
(scale-world factor)
(error-message
(strings "Scale factor must be a positive real."
(string-append s " does not qualify."))))))))
(define (rotate-transformation proc)
(enqueue-task
(lambda ()
(let* ((s (get-input "Type the angle of rotation in degrees"))
(angle (string->number s)))
(if (and (number? angle)
(real? angle))
(proc (/ (* (acos -1) angle) 180.0))
(error-message
(strings "Angle of rotation must be a real."
(string-append s " does not qualify."))))))))
(define (rotate-x-transformation)
(rotate-transformation rotate-world-x))
(define (rotate-y-transformation)
(rotate-transformation rotate-world-y))
(define (rotate-z-transformation)
(rotate-transformation rotate-world-z))
(define (translate-transformation proc)
(enqueue-task
(lambda ()
(let* ((s (get-input "Type the translation distance"))
(d (string->number s)))
(if (and (number? d)
(real? d))
(proc d)
(error-message
(strings "Translation distance must be a real."
(string-append s " does not qualify."))))))))
(define (translate-x-transformation)
(translate-transformation translate-world-x))
(define (translate-y-transformation)
(translate-transformation translate-world-y))
(define (translate-z-transformation)
(translate-transformation translate-world-z))
; Error messages.
(define (strings . args)
(if (null? args)
""
(string-append (car args)
(list->string '(#\newline))
(apply strings (cdr args)))))
(define (error-message msg)
(let ((w (make-window 'text 'title "Error Message")))
(((w 'agent) 'set-textstring) msg)))
; 3-dimensional points, line segments, and rectangles.
(define (point x y z)
(vector x y z 1.0))
(define (point-x p)
(vector-ref p 0))
(define (point-y p)
(vector-ref p 1))
(define (point-z p)
(vector-ref p 2))
(define (linesegment p1 p2)
(cons p1 p2))
(define endpoint1 car)
(define endpoint2 cdr)
(define (rectangle p1 p2 p3 p4)
(vector p1 p2 p3 p4))
(define (rectangle1 r)
(vector-ref r 0))
(define (rectangle2 r)
(vector-ref r 1))
(define (rectangle3 r)
(vector-ref r 2))
(define (rectangle4 r)
(vector-ref r 3))
; 3-dimensional affine transformations using homogeneous coordinates.
; Represented as 4x4 matrices.
(define (matrix a11 a12 a13 a14
a21 a22 a23 a24
a31 a32 a33 a34
a41 a42 a43 a44)
(vector (vector a11 a12 a13 a14)
(vector a21 a22 a23 a24)
(vector a31 a32 a33 a34)
(vector a41 a42 a43 a44)))
(define (matrix-ref m i j)
(vector-ref (vector-ref m (- i 1)) (- j 1)))
(define (matrix-multiplication A B)
(let* ((m (vector-length A))
(n (vector-length B))
(o (vector-length (vector-ref B 0)))
(C (let ((C (make-vector m)))
(do ((i 0 (+ i 1)))
((= i m) C)
(vector-set! C i (make-vector n 0.0))))))
; Returns the inner product of row i of A with column k of B.
(define (ip i k)
(do ((j 1 (+ j 1))
(sum 0.0 (+ sum
(* (matrix-ref A i j)
(matrix-ref B j k)))))
((> j n) sum)))
(do ((i 0 (+ i 1)))
((= i m) C)
(do ((j 0 (+ j 1)))
((= j o))
(vector-set! (vector-ref C i)
j
(ip (+ i 1) (+ j 1)))))))
; Transformations.
(define (apply-transform-to-point transform pt)
(let ((m (matrix-multiplication transform
(list->vector
(map vector (vector->list pt))))))
(point (matrix-ref m 1 1)
(matrix-ref m 2 1)
(matrix-ref m 3 1))))
(define (composition transform1 transform2)
(matrix-multiplication transform1 transform2))
(define (identity-transform)
(matrix 1.0 0.0 0.0 0.0
0.0 1.0 0.0 0.0
0.0 0.0 1.0 0.0
0.0 0.0 0.0 1.0))
(define (uniform-scaling factor)
(matrix factor 0.0 0.0 0.0
0.0 factor 0.0 0.0
0.0 0.0 factor 0.0
0.0 0.0 0.0 1.0))
(define (rotation-x theta)
(matrix 1.0 0.0 0.0 0.0
0.0 (cos theta) (- (sin theta)) 0.0
0.0 (sin theta) (cos theta) 0.0
0.0 0.0 0.0 1.0))
(define (rotation-y theta)
(matrix (cos theta) 0.0 (- (sin theta)) 0.0
0.0 1.0 0.0 0.0
(sin theta) 0.0 (cos theta) 0.0
0.0 0.0 0.0 1.0))
(define (rotation-z theta)
(matrix (cos theta) (- (sin theta)) 0.0 0.0
(sin theta) (cos theta) 0.0 0.0
0.0 0.0 1.0 0.0
0.0 0.0 0.0 1.0))
(define (translation-x d)
(matrix 1.0 0.0 0.0 d
0.0 1.0 0.0 0.0
0.0 0.0 1.0 0.0
0.0 0.0 0.0 1.0))
(define (translation-y d)
(matrix 1.0 0.0 0.0 0.0
0.0 1.0 0.0 d
0.0 0.0 1.0 0.0
0.0 0.0 0.0 1.0))
(define (translation-z d)
(matrix 1.0 0.0 0.0 0.0
0.0 1.0 0.0 0.0
0.0 0.0 1.0 d
0.0 0.0 0.0 1.0))
; The current transformation.
(define current-transform (identity-transform))
(define (initialize-transformation)
(set! current-transform (identity-transform)))
(define (scale-world factor)
(set! current-transform
(composition (uniform-scaling factor)
current-transform)))
(define (rotate-world-x theta)
(set! current-transform
(composition (rotation-x theta)
current-transform)))
(define (rotate-world-y theta)
(set! current-transform
(composition (rotation-y theta)
current-transform)))
(define (rotate-world-z theta)
(set! current-transform
(composition (rotation-z theta)
current-transform)))
(define (translate-world-x d)
(set! current-transform
(composition (translation-x d)
current-transform)))
(define (translate-world-y d)
(set! current-transform
(composition (translation-y d)
current-transform)))
(define (translate-world-z d)
(set! current-transform
(composition (translation-z d)
current-transform)))
; The current scene.
(define the-scene '())
(define (initialize-world)
(set! the-scene
(cons (make-briefcase-object 0.06 0.36 0.24)
the-scene))
(initialize-transformation)
(refresh-graphics))
(define (repeat-current-transformation)
(for-each (lambda (object)
((object 'transform) current-transform))
the-scene)
(refresh-graphics))
(define (refresh-graphics)
(draw-in-window
graphic-window
(lambda ()
(let ((r (make%rect 0 0 32767 32767)))
(EraseRect r)
(disposptr r))))
(for-each (lambda (object)
(object 'display))
the-scene))
(define (display-corners)
(for-each (lambda (object)
(object 'remove-method 'internal-display)
(object 'add-method 'internal-display display:corners))
the-scene))
(define (display-edges)
(for-each (lambda (object)
(object 'remove-method 'internal-display)
(object 'add-method 'internal-display display:edges))
the-scene))
; Briefcase objects.
(define (display:corners)
(lambda (self)
(for-each display-point
(self 'corners))))
(define (display:edges)
(lambda (self)
(for-each display-line
(self 'lines))))
(define (make-briefcase-object height width depth)
(let ((corners (vector (point 0.0 0.0 0.0)
(point 0.0 0.0 depth)
(point 0.0 width 0.0)
(point 0.0 width depth)
(point height 0.0 0.0)
(point height 0.0 depth)
(point height width 0.0)
(point height width depth)))
(bottom 0)
(top 1)
(left 0)
(right 1)
(back 0)
(front 1))
(define (corner i j k)
(vector-ref corners (+ i i i i j j k)))
(define (corner-set! i j k v)
(vector-set! corners (+ i i i i j j k) v))
(%object self
((transform t)
(set! corners
(list->vector
(map (lambda (p)
(apply-transform-to-point t p))
(vector->list corners)))))
((display)
((self 'internal-display) self))
((internal-display)
(display:corners))
((corners)
(vector->list corners))
((lines)
(list
; front edges
(linesegment (corner left bottom front)
(corner right bottom front))
(linesegment (corner right bottom front)
(corner right top front))
(linesegment (corner right top front)
(corner left top front))
(linesegment (corner left top front)
(corner left bottom front))
; back edges
(linesegment (corner left bottom back)
(corner right bottom back))
(linesegment (corner right bottom back)
(corner right top back))
(linesegment (corner right top back)
(corner left top back))
(linesegment (corner left top back)
(corner left bottom back))
; front-to-back edges
(linesegment (corner left bottom front)
(corner left bottom back))
(linesegment (corner right bottom front)
(corner right bottom back))
(linesegment (corner left top front)
(corner left top back))
(linesegment (corner right top front)
(corner right top back))))
((rectangles)
(list
(rectangle (corner left bottom front)
(corner right bottom front)
(corner right top front)
(corner left top front))
(rectangle (corner left bottom back)
(corner right bottom back)
(corner right top back)
(corner left top back))
(rectangle (corner left bottom front)
(corner left bottom back)
(corner left top back)
(corner left top front))
(rectangle (corner right bottom front)
(corner right bottom back)
(corner right top back)
(corner right top front))
(rectangle (corner left bottom front)
(corner left bottom back)
(corner right bottom back)
(corner right bottom front))
(rectangle (corner left top front)
(corner left top back)
(corner right top back)
(corner right top front)))))))
; Display of 3-dimensional points, lines, rectangles.
(define graphic-window)
(define xorigin 0)
(define yorigin 0)
(define (make-graphic-window)
(define (calculate-center)
(set! xorigin (/ (graphic-window 'width) 2.0))
(set! yorigin (/ (graphic-window 'height) 2.0)))
(set! graphic-window (make-window 'title "Graphics" 'bounds 50 50 450 450))
(calculate-center)
; The window can be resized using the mouse.
(let ((original-mousedown-method
((graphic-window 'get-method) 'mousedown)))
((graphic-window 'add-method)
'mousedown
(lambda args
(let ((v (apply original-mousedown-method args)))
(calculate-center)
v)))))
; Converts normalized to display coordinates.
(define (scale-x x)
(inexact->exact (* (+ x 1.0) xorigin)))
(define (scale-y y)
(inexact->exact (* (- 1.0 y) yorigin)))
; Projects 3-dimensional normalized coordinates
; to 2-dimensional display coordinates.
(define (project-x p)
(scale-x (point-x p)))
(define (project-y p)
(scale-y (point-y p)))
(define (display-point p)
(draw-in-window
graphic-window
(lambda ()
(let ((x (project-x p))
(y (project-y p)))
(MoveTo x y)
(LineTo x y)))))
(define (display-line l)
(draw-in-window
graphic-window
(lambda ()
(let ((p1 (endpoint1 l))
(p2 (endpoint2 l)))
(let ((x1 (project-x p1))
(y1 (project-y p1)))
(MoveTo x1 y1)
(LineTo (project-x p2)
(project-y p2)))))))
; Drawing primitives.
(define (draw-in-window w action)
(let ((temp (newptr (%sizeof GrafPtr))))
(call-without-interrupts
(lambda ()
(if (not (w 'closed?))
(begin (GetPort temp)
(SetPort (w 'windowptr))
(action)
(SetPort (peek.long temp))
(disposptr temp)
#t))))))