GOFAI/cocoa-gears-demo.lisp

## cocoa-gears-demo.lisp
(defpackage :opengl-gears-demo)

(in-package :opengl-gears-demo)

(require 'cl-opengl)
(require 'cl-glu)

;;; needed to run at full resolution in Retina display
(objc:defmethod (#/setWantsBestResolutionOpenGLSurface: :void)
      ((self ns:ns-object) (value :<BOOL>)))

(defconstant +pif+ (coerce pi 'single-float))

;;; borrowed from CCL opengl demo
(defun new-pixel-format (&rest attributes)
  ;; take a list of opengl pixel format attributes (enums and other
  ;; small ints), make an array (character array?), and create and
  ;; return an NSOpenGLPixelFormat
  (let* ((attribute-size (ccl::foreign-size :<NSO>pen<GLP>ixel<F>ormat<A>ttribute :bytes))
         (nattributes (length attributes)))
    (ccl::%stack-block ((objc-attributes (* attribute-size (1+ nattributes))))
      (loop for i from 0 to nattributes
	    for attribute in attributes do
	    (setf (ccl:paref objc-attributes (:* :<NSO>pen<GLP>ixel<F>ormat<A>ttribute) i)
                  attribute) ; <- autocoerced?
	    finally (setf
                     (ccl:paref objc-attributes
                                (:* :<NSO>pen<GLP>ixel<F>ormat<A>ttribute) nattributes) 0))
      (make-instance ns:ns-opengl-pixel-format :with-attributes objc-attributes))))

(defun ns-keypress-to-lisp-char (keypress)
    (let* ((ns-string (#/characters keypress))
           (lisp-string (objc:lisp-string-from-nsstring ns-string)))
      (aref lisp-string 0)))

(defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth)
  "Draw a gear."
  (declare (single-float inner-radius outer-radius width tooth-depth)
           (fixnum n-teeth))
  (let ((r0 inner-radius)
        (r1 (- outer-radius (/ tooth-depth 2.0)))
        (r2 (+ outer-radius (/ tooth-depth 2.0)))
        (da (/ (* 2.0 +pif+) n-teeth 4.0)))
    (gl:shade-model :flat)
    (gl:normal 0 0 1)
    ;; Draw front face.
    (gl:with-primitives :quad-strip
      (dotimes (i (1+ n-teeth))
        (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
          (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
          (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
          (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
          (gl:vertex (* r1 (cos (+ angle (* 3 da))))
                     (* r1 (sin (+ angle (* 3 da))))
                     (* width 0.5)))))
    ;; Draw front sides of teeth.
    (gl:with-primitives :quads
      (dotimes (i n-teeth)
        (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
          (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
          (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
                     (* width 0.5))
          (gl:vertex (* r2 (cos (+ angle (* 2 da))))
                     (* r2 (sin (+ angle (* 2 da))))
                     (* width 0.5))
          (gl:vertex (* r1 (cos (+ angle (* 3 da))))
                     (* r1 (sin (+ angle (* 3 da))))
                     (* width 0.5)))))
    (gl:normal 0 0 -1)
    ;; Draw back face.
    (gl:with-primitives :quad-strip
      (dotimes (i (1+ n-teeth))
        (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
          (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
          (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
          (gl:vertex (* r1 (cos (+ angle (* 3 da))))
                       (* r1 (sin (+ angle (* 3 da))))
                       (* width -0.5))
          (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
    ;; Draw back sides of teeth.
    (gl:with-primitives :quads
      (dotimes (i n-teeth)
        (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
          (gl:vertex (* r1 (cos (+ angle (* 3 da))))
                     (* r1 (sin (+ angle (* 3 da))))
                     (* width -0.5))
          (gl:vertex (* r2 (cos (+ angle (* 2 da))))
                     (* r2 (sin (+ angle (* 2 da))))
                     (* width -0.5))
          (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
                     (* width -0.5))
          (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)))))
    ;; Draw outward faces of teeth.
    (gl:with-primitives :quad-strip
      (dotimes (i n-teeth)
        (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
          (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
          (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
          (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
                 (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
                 (len (sqrt (+ (* u u) (* v v)))))
            (setq u (/ u len))
            (setq v (/ u len))
            (gl:normal v (- u) 0.0)
            (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
                       (* width 0.5))
            (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
                       (* width -0.5))
            (gl:normal (cos angle) (sin angle) 0.0)
            (gl:vertex (* r2 (cos (+ angle (* 2 da))))
                       (* r2 (sin (+ angle (* 2 da))))
                       (* width 0.5))
            (gl:vertex (* r2 (cos (+ angle (* 2 da))))
                       (* r2 (sin (+ angle (* 2 da))))
                       (* width -0.5))
            (setq u (- (* r1 (cos (+ angle (* 3 da))))
                       (* r2 (cos (+ angle (* 2 da))))))
            (setq v (- (* r1 (sin (+ angle (* 3 da))))
                       (* r2 (sin (+ angle (* 2 da))))))
            (gl:normal v (- u) 0.0)
            (gl:vertex (* r1 (cos (+ angle (* 3 da))))
                       (* r1 (sin (+ angle (* 3 da))))
                       (* width 0.5))
            (gl:vertex (* r1 (cos (+ angle (* 3 da))))
                       (* r1 (sin (+ angle (* 3 da))))
                       (* width -0.5))
            (gl:normal (cos angle) (sin angle) 0.0))))
      (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5))
      (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5)))
    ;; Draw inside radius cylinder.
    (gl:shade-model :smooth)
    (gl:with-primitives :quad-strip
      (dotimes (i (1+ n-teeth))
        (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
          (gl:normal (- (cos angle)) (- (sin angle)) 0.0)
          (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
          (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)))))))

(defclass gears-opengl-view (ns:ns-opengl-view)
  ((animation-runloop :foreign-type :id :accessor animation-runloop)
   (animation-timer :foreign-type :id :accessor animation-timer)
   (animation-thread :initform nil :accessor animation-thread)
   (view-rotx :initform 20.0)
   (view-roty :initform 30.0)
   (view-rotz :initform 0.0)
   gear1 gear2 gear3
   (angle :initform 0.0)
   (count :initform 1)
   (t0 :initform 0))
  (:metaclass ns:+ns-object))

(objc:defmethod (#/acceptsFirstResponder :<BOOL>) ((self gears-opengl-view))
  t)

(defun make-opengl-view ()
  (let ((opengl-view (make-instance 'gears-opengl-view)))
    (#/setPixelFormat: opengl-view (new-pixel-format #$NSOpenGLPFADoubleBuffer
                                                     #$NSOpenGLPFAColorSize 32
                                                     #$NSOpenGLPFADepthSize 32)) ; alt
    (#/setWantsBestResolutionOpenGLSurface: opengl-view 1) ; Retina display
    (#/autorelease opengl-view)))

;;; this should specialize on the window to check for visibility

(objc:defmethod (#/rotateGears: :void) ((self gears-opengl-view) timer)
  (declare (ignorable timer))
    (progn
      (incf (slot-value self 'angle) 0.04) ; rotate gears
      (#/setNeedsDisplay: self t))) ; tell Cocoa to redraw gears

(objc:defmethod (#/prepareOpenGL :void) ((self gears-opengl-view))
  (ccl:rlet ((swap-int #>GLint 1))
    (#/setValues:forParameter: (#/openGLContext self) swap-int #$NSOpenGLCPSwapInterval))
  (with-slots (gear1 gear2 gear3) self
    (gl:light :light0 :position #(5.0 5.0 10.0 0.0))
    (gl:enable :cull-face :lighting :light0 :depth-test)
    ;; gear 1
    (setq gear1 (gl:gen-lists 1))
    (gl:with-new-list (gear1 :compile)
      (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) ; red
      (draw-gear 1.0 4.0 1.0 20 0.7))
    ;; gear 2
    (setq gear2 (gl:gen-lists 1))
    (gl:with-new-list (gear2 :compile)
      (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) ; green
      (draw-gear 0.5 2.0 2.0 10 0.7))
    ;; gear 3
    (setq gear3 (gl:gen-lists 1))
    (gl:with-new-list (gear3 :compile)
      (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) ; blue
      (draw-gear 1.3 2.0 0.5 10 0.7))
    (gl:enable :normalize)))

(objc:defmethod (#/drawRect: :void) ((self gears-opengl-view) (rect :<NSR>ect))
  (declare (ignorable rect))
  (with-slots (view-rotx view-roty view-rotz angle gear1 gear2 gear3) self
    (gl:clear :color-buffer :depth-buffer)
    (gl:with-pushed-matrix
        (gl:rotate view-rotx 1 0 0)
      (gl:rotate view-roty 0 1 0)
      (gl:rotate view-rotz 0 0 1)
      (gl:with-pushed-matrix ; gear1
          (gl:translate -3 -2 0)
        (gl:rotate angle 0 0 1)
        (gl:call-list gear1))
      (gl:with-pushed-matrix ; gear2
          (gl:translate 3.1 -2 0)
        (gl:rotate (- (* -2 angle) 9) 0 0 1)
        (gl:call-list gear2))
      (gl:with-pushed-matrix ; gear3
          (gl:translate -3.1 4.2 0.0)
        (gl:rotate (- (* -2 angle) 25) 0 0 1)
        (gl:call-list gear3)))
    (#/flushBuffer (#/openGLContext self)))); maybe?

(objc:defmethod (#/reshape :void) ((gl-view gears-opengl-view))
  (let* ((frame (#/frame gl-view))
         (width (truncate (ns:ns-rect-width frame)))
         (height (truncate (ns:ns-rect-height frame))))
    (gl:viewport 0 0 (* 2 width) (* 2 height)) ; display correctly in Retina display
    (gl:matrix-mode :projection)
    (gl:load-identity)
    (let ((h (/ height width)))
      (gl:frustum -1 1 (- h) h 5 60))
    (gl:matrix-mode :modelview)
    (gl:load-identity)
    (gl:translate 0 0 -40)))

(defclass cocoa-gears-window (ns:ns-window)
  ()
  (:metaclass ns:+ns-object))

(objc:defmethod (#/keyDown: :void) ((self gears-opengl-view) the-event)
  (let ((char (ns-keypress-to-lisp-char the-event)))
    (with-slots (view-rotx view-roty view-rotz) self
      (case char
        (#\Z (incf view-rotz 2.0))
        (#\z (decf view-rotz 2.0))
        (#\U+F700 (incf view-rotx 2.0))
        (#\U+F701 (decf view-rotx 2.0))
        (#\U+F702 (incf view-roty 2.0))
        (#\U+F703 (decf view-roty 2.0)))))
    (#/setNeedsDisplay: self t))

(defmethod animate-gears ((self gears-opengl-view) done)
  (setf (animation-thread self) *current-process*)
  (let* ((runloop (#/currentRunLoop ns:ns-run-loop)))
    (setf (animation-runloop self) runloop)
    (setf (animation-timer self)
          (#/scheduledTimerWithTimeInterval:target:selector:userInfo:repeats:
           ns:ns-timer
           0.001d0 ;~60fps
           self
           (objc:@selector #/rotateGears:)
           +null-ptr+
           t))
    (objc:with-autorelease-pool
        (#/addTimer:forMode: runloop (animation-timer self) #$NSDefaultRunLoopMode)
      (signal-semaphore done)
      (#/run runloop))))

(defmethod start-gears ((self gears-opengl-view))
  (let* ((created (make-semaphore)))
    (process-run-function "Animator" #'animate-gears self created)
    (wait-on-semaphore created)))

(objc:defmethod (#/close :void) ((self cocoa-gears-window))
    (let ((view (#/contentView self)))
      ;; make sure timer is stopped to avoid race condition
       (process-interrupt (animation-thread view)
                       #'(lambda () (#/invalidate (animation-timer view))))
    (process-kill (animation-thread view)))
    (call-next-method))

(defun run-gears-demo ()
  (objc:with-autorelease-pool
      (let* ((w (gui::execute-in-gui
                 #'(lambda () (gui::new-cocoa-window :class (find-class 'cocoa-gears-window)
                                                     :title "Cocoa Gears Window"
                                                     :height 600
                                                     :width 600
                                                     :expandable nil))))
             (v (make-opengl-view)))
        (#/setContentView: w v)
        (start-gears v)
        (list w v))))
	(defpackage :opengl-gears-demo)

	(in-package :opengl-gears-demo)

	(require 'cl-opengl)
	(require 'cl-glu)

	;;; needed to run at full resolution in Retina display
	(objc:defmethod (#/setWantsBestResolutionOpenGLSurface: :void)
	((self ns:ns-object) (value :<BOOL>)))

	(defconstant +pif+ (coerce pi 'single-float))

	;;; borrowed from CCL opengl demo
	(defun new-pixel-format (&rest attributes)
	;; take a list of opengl pixel format attributes (enums and other
	;; small ints), make an array (character array?), and create and
	;; return an NSOpenGLPixelFormat
	(let* ((attribute-size (ccl::foreign-size :<NSO>pen<GLP>ixel<F>ormat<A>ttribute :bytes))
	(nattributes (length attributes)))
	(ccl::%stack-block ((objc-attributes (* attribute-size (1+ nattributes))))
	(loop for i from 0 to nattributes
	for attribute in attributes do
	(setf (ccl:paref objc-attributes (:* :<NSO>pen<GLP>ixel<F>ormat<A>ttribute) i)
	attribute) ; <- autocoerced?
	finally (setf
	(ccl:paref objc-attributes
	(:* :<NSO>pen<GLP>ixel<F>ormat<A>ttribute) nattributes) 0))
	(make-instance ns:ns-opengl-pixel-format :with-attributes objc-attributes))))

	(defun ns-keypress-to-lisp-char (keypress)
	(let* ((ns-string (#/characters keypress))
	(lisp-string (objc:lisp-string-from-nsstring ns-string)))
	(aref lisp-string 0)))

	(defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth)
	"Draw a gear."
	(declare (single-float inner-radius outer-radius width tooth-depth)
	(fixnum n-teeth))
	(let ((r0 inner-radius)
	(r1 (- outer-radius (/ tooth-depth 2.0)))
	(r2 (+ outer-radius (/ tooth-depth 2.0)))
	(da (/ (* 2.0 +pif+) n-teeth 4.0)))
	(gl:shade-model :flat)
	(gl:normal 0 0 1)
	;; Draw front face.
	(gl:with-primitives :quad-strip
	(dotimes (i (1+ n-teeth))
	(let ((angle (/ (* i 2.0 +pif+) n-teeth)))
	(gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
	(gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
	(gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
	(gl:vertex (* r1 (cos (+ angle (* 3 da))))
	(* r1 (sin (+ angle (* 3 da))))
	(* width 0.5)))))
	;; Draw front sides of teeth.
	(gl:with-primitives :quads
	(dotimes (i n-teeth)
	(let ((angle (/ (* i 2.0 +pif+) n-teeth)))
	(gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
	(gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
	(* width 0.5))
	(gl:vertex (* r2 (cos (+ angle (* 2 da))))
	(* r2 (sin (+ angle (* 2 da))))
	(* width 0.5))
	(gl:vertex (* r1 (cos (+ angle (* 3 da))))
	(* r1 (sin (+ angle (* 3 da))))
	(* width 0.5)))))
	(gl:normal 0 0 -1)
	;; Draw back face.
	(gl:with-primitives :quad-strip
	(dotimes (i (1+ n-teeth))
	(let ((angle (/ (* i 2.0 +pif+) n-teeth)))
	(gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
	(gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
	(gl:vertex (* r1 (cos (+ angle (* 3 da))))
	(* r1 (sin (+ angle (* 3 da))))
	(* width -0.5))
	(gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
	;; Draw back sides of teeth.
	(gl:with-primitives :quads
	(dotimes (i n-teeth)
	(let ((angle (/ (* i 2.0 +pif+) n-teeth)))
	(gl:vertex (* r1 (cos (+ angle (* 3 da))))
	(* r1 (sin (+ angle (* 3 da))))
	(* width -0.5))
	(gl:vertex (* r2 (cos (+ angle (* 2 da))))
	(* r2 (sin (+ angle (* 2 da))))
	(* width -0.5))
	(gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
	(* width -0.5))
	(gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)))))
	;; Draw outward faces of teeth.
	(gl:with-primitives :quad-strip
	(dotimes (i n-teeth)
	(let ((angle (/ (* i 2.0 +pif+) n-teeth)))
	(gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
	(gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
	(let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
	(v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
	(len (sqrt (+ (* u u) (* v v)))))
	(setq u (/ u len))
	(setq v (/ u len))
	(gl:normal v (- u) 0.0)
	(gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
	(* width 0.5))
	(gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
	(* width -0.5))
	(gl:normal (cos angle) (sin angle) 0.0)
	(gl:vertex (* r2 (cos (+ angle (* 2 da))))
	(* r2 (sin (+ angle (* 2 da))))
	(* width 0.5))
	(gl:vertex (* r2 (cos (+ angle (* 2 da))))
	(* r2 (sin (+ angle (* 2 da))))
	(* width -0.5))
	(setq u (- (* r1 (cos (+ angle (* 3 da))))
	(* r2 (cos (+ angle (* 2 da))))))
	(setq v (- (* r1 (sin (+ angle (* 3 da))))
	(* r2 (sin (+ angle (* 2 da))))))
	(gl:normal v (- u) 0.0)
	(gl:vertex (* r1 (cos (+ angle (* 3 da))))
	(* r1 (sin (+ angle (* 3 da))))
	(* width 0.5))
	(gl:vertex (* r1 (cos (+ angle (* 3 da))))
	(* r1 (sin (+ angle (* 3 da))))
	(* width -0.5))
	(gl:normal (cos angle) (sin angle) 0.0))))
	(gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5))
	(gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5)))
	;; Draw inside radius cylinder.
	(gl:shade-model :smooth)
	(gl:with-primitives :quad-strip
	(dotimes (i (1+ n-teeth))
	(let ((angle (/ (* i 2.0 +pif+) n-teeth)))
	(gl:normal (- (cos angle)) (- (sin angle)) 0.0)
	(gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
	(gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)))))))

	(defclass gears-opengl-view (ns:ns-opengl-view)
	((animation-runloop :foreign-type :id :accessor animation-runloop)
	(animation-timer :foreign-type :id :accessor animation-timer)
	(animation-thread :initform nil :accessor animation-thread)
	(view-rotx :initform 20.0)
	(view-roty :initform 30.0)
	(view-rotz :initform 0.0)
	gear1 gear2 gear3
	(angle :initform 0.0)
	(count :initform 1)
	(t0 :initform 0))
	(:metaclass ns:+ns-object))

	(objc:defmethod (#/acceptsFirstResponder :<BOOL>) ((self gears-opengl-view))
	t)

	(defun make-opengl-view ()
	(let ((opengl-view (make-instance 'gears-opengl-view)))
	(#/setPixelFormat: opengl-view (new-pixel-format #$NSOpenGLPFADoubleBuffer
	#$NSOpenGLPFAColorSize 32
	#$NSOpenGLPFADepthSize 32)) ; alt
	(#/setWantsBestResolutionOpenGLSurface: opengl-view 1) ; Retina display
	(#/autorelease opengl-view)))

	;;; this should specialize on the window to check for visibility

	(objc:defmethod (#/rotateGears: :void) ((self gears-opengl-view) timer)
	(declare (ignorable timer))
	(progn
	(incf (slot-value self 'angle) 0.04) ; rotate gears
	(#/setNeedsDisplay: self t))) ; tell Cocoa to redraw gears

	(objc:defmethod (#/prepareOpenGL :void) ((self gears-opengl-view))
	(ccl:rlet ((swap-int #>GLint 1))
	(#/setValues:forParameter: (#/openGLContext self) swap-int #$NSOpenGLCPSwapInterval))
	(with-slots (gear1 gear2 gear3) self
	(gl:light :light0 :position #(5.0 5.0 10.0 0.0))
	(gl:enable :cull-face :lighting :light0 :depth-test)
	;; gear 1
	(setq gear1 (gl:gen-lists 1))
	(gl:with-new-list (gear1 :compile)
	(gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) ; red
	(draw-gear 1.0 4.0 1.0 20 0.7))
	;; gear 2
	(setq gear2 (gl:gen-lists 1))
	(gl:with-new-list (gear2 :compile)
	(gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) ; green
	(draw-gear 0.5 2.0 2.0 10 0.7))
	;; gear 3
	(setq gear3 (gl:gen-lists 1))
	(gl:with-new-list (gear3 :compile)
	(gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) ; blue
	(draw-gear 1.3 2.0 0.5 10 0.7))
	(gl:enable :normalize)))

	(objc:defmethod (#/drawRect: :void) ((self gears-opengl-view) (rect :<NSR>ect))
	(declare (ignorable rect))
	(with-slots (view-rotx view-roty view-rotz angle gear1 gear2 gear3) self
	(gl:clear :color-buffer :depth-buffer)
	(gl:with-pushed-matrix
	(gl:rotate view-rotx 1 0 0)
	(gl:rotate view-roty 0 1 0)
	(gl:rotate view-rotz 0 0 1)
	(gl:with-pushed-matrix ; gear1
	(gl:translate -3 -2 0)
	(gl:rotate angle 0 0 1)
	(gl:call-list gear1))
	(gl:with-pushed-matrix ; gear2
	(gl:translate 3.1 -2 0)
	(gl:rotate (- (* -2 angle) 9) 0 0 1)
	(gl:call-list gear2))
	(gl:with-pushed-matrix ; gear3
	(gl:translate -3.1 4.2 0.0)
	(gl:rotate (- (* -2 angle) 25) 0 0 1)
	(gl:call-list gear3)))
	(#/flushBuffer (#/openGLContext self)))); maybe?

	(objc:defmethod (#/reshape :void) ((gl-view gears-opengl-view))
	(let* ((frame (#/frame gl-view))
	(width (truncate (ns:ns-rect-width frame)))
	(height (truncate (ns:ns-rect-height frame))))
	(gl:viewport 0 0 (* 2 width) (* 2 height)) ; display correctly in Retina display
	(gl:matrix-mode :projection)
	(gl:load-identity)
	(let ((h (/ height width)))
	(gl:frustum -1 1 (- h) h 5 60))
	(gl:matrix-mode :modelview)
	(gl:load-identity)
	(gl:translate 0 0 -40)))

	(defclass cocoa-gears-window (ns:ns-window)
	()
	(:metaclass ns:+ns-object))

	(objc:defmethod (#/keyDown: :void) ((self gears-opengl-view) the-event)
	(let ((char (ns-keypress-to-lisp-char the-event)))
	(with-slots (view-rotx view-roty view-rotz) self
	(case char
	(#\Z (incf view-rotz 2.0))
	(#\z (decf view-rotz 2.0))
	(#\U+F700 (incf view-rotx 2.0))
	(#\U+F701 (decf view-rotx 2.0))
	(#\U+F702 (incf view-roty 2.0))
	(#\U+F703 (decf view-roty 2.0)))))
	(#/setNeedsDisplay: self t))

	(defmethod animate-gears ((self gears-opengl-view) done)
	(setf (animation-thread self) current-process)
	(let* ((runloop (#/currentRunLoop ns:ns-run-loop)))
	(setf (animation-runloop self) runloop)
	(setf (animation-timer self)
	(#/scheduledTimerWithTimeInterval:target:selector:userInfo:repeats:
	ns:ns-timer
	0.001d0 ;~60fps
	self
	(objc:@selector #/rotateGears:)
	+null-ptr+
	t))
	(objc:with-autorelease-pool
	(#/addTimer:forMode: runloop (animation-timer self) #$NSDefaultRunLoopMode)
	(signal-semaphore done)
	(#/run runloop))))

	(defmethod start-gears ((self gears-opengl-view))
	(let* ((created (make-semaphore)))
	(process-run-function "Animator" #'animate-gears self created)
	(wait-on-semaphore created)))

	(objc:defmethod (#/close :void) ((self cocoa-gears-window))
	(let ((view (#/contentView self)))
	;; make sure timer is stopped to avoid race condition
	(process-interrupt (animation-thread view)
	#'(lambda () (#/invalidate (animation-timer view))))
	(process-kill (animation-thread view)))
	(call-next-method))

	(defun run-gears-demo ()
	(objc:with-autorelease-pool
	(let* ((w (gui::execute-in-gui
	#'(lambda () (gui::new-cocoa-window :class (find-class 'cocoa-gears-window)
	:title "Cocoa Gears Window"
	:height 600
	:width 600
	:expandable nil))))
	(v (make-opengl-view)))
	(#/setContentView: w v)
	(start-gears v)
	(list w v))))