cellogears.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos).
   3 ;;;
   4 ;;; Simple program with rotating 3-D gear wheels.
   5
   6 (in-package :celtk)
   7
   8 (defvar *startx*)
   9 (defvar *starty*)
  10 (defvar *xangle0*)
  11 (defvar *yangle0*)
  12 (defvar *xangle*)
  13 (defvar *yangle*)
  14
  15 (defparameter *vTime* 100)
  16
  17 (defun cellogears () ;; ACL project manager needs a zero-argument function, in project package
  18   (let ((*startx* nil)
  19         (*starty* nil)
  20         (*xangle0* nil)
  21         (*yangle0* nil)
  22         (*xangle* 0.2)
  23         (*yangle* 0.0))
  24     (test-window 'gears-demo)))
  25
  26 (defmodel gears-demo (window)
  27   ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct)
  28    (scale :initform (c-in 1) :accessor scale :initarg :scale))
  29   (:default-initargs
  30       :title$ "Rotating Gear Widget Test"
  31     :kids (c? (the-kids
  32                (mk-stack (:packing (c?pack-self "-side left -fill both"))
  33                  ;
  34                  ; An awful use of GUI...
  35                  ;
  36                  (mk-checkbutton :id :on-off
  37                    :text (c? (if (^value) "Stop" "Start"))
  38                    :value (c-in t))
  39                  ;
  40                  ; The pretty bit...
  41                  ;
  42                  (make-instance 'gears
  43                    :fm-parent *parent*
  44                    :width 400 :height 400
  45                    :timer-interval (c? (let ((n$ "100"))
  46                                          (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0)))))
  47                    :double 1 ;; "yes"
  48                    :event-handler (c? (lambda (self xe)
  49                                         (trc nil "togl event" (tk-event-type (xsv type xe)))
  50
  51                                         (case (tk-event-type (xsv type xe))
  52                                           (:virtualevent
  53                                            (trc nil "canvas virtual" (xsv name xe)))
  54                                           (:buttonpress
  55                                            #+not (RotStart self (xsv x xe) (xsv y xe))
  56                                            (RotStart self (xsv x-root xe) (xsv y-root xe)))
  57                                           (:motionnotify
  58                                            #+not (RotMove self (xsv x xe) (xsv y xe))
  59                                            (RotMove self (xsv x-root xe) (xsv y-root xe)))
  60                                           (:buttonrelease
  61                                            (setf *startx* nil))))))
  62                  (mk-label :text "Click and drag to rotate model"))))))
  63
  64 (defun RotStart (self x y)
  65   (setf *startx* x)
  66   (setf *starty* y)
  67   (setf *xangle0* (rotx self))
  68   (setf *yangle0* (roty self)))
  69
  70 (defun RotMove (self x y)
  71   (when *startx*
  72     (trc nil "rotmove started" x *startx* *xangle0*)
  73     (setf *xangle* (+ *xangle0* (- x *startx*)))
  74     (setf *yangle* (+ *yangle0* (- y *starty*)))
  75     (setf (rotx self) *xangle*)
  76     (setf (roty self) *yangle*)
  77     (togl-post-redisplay (togl-ptr self))))
  78
  79 (defconstant +pif+ (coerce pi 'single-float))
  80
  81 (defun draw-scaled-gear (scale)
  82   (draw-gear 1.0 (* 2.0 scale) 1.0 (* 10 scale) 0.7))
  83
  84 (defmodel gears (togl)
  85   ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx)
  86    (roty :initform (c-in 25) :accessor roty :initarg :roty)
  87    (rotz :initform (c-in 10) :accessor rotz :initarg :rotz)
  88    (gear1 :initarg :gear1 :accessor gear1
  89      :initform (c_? (trc nil "making list!!!!! 1")
  90                  (let ((dl (gl:gen-lists 1)))
  91                    (gl:with-new-list (dl :compile)
  92                      (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0))
  93                      (draw-scaled-gear 2))
  94                    dl)))
  95    (gear2 :initarg :gear2 :accessor gear2
  96      :initform (c_? (let ((dl (gl:gen-lists 1)))
  97                       (gl:with-new-list (dl :compile)
  98                         (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0))
  99                         (draw-scaled-gear 1))
 100                       dl)))
 101    (gear3 :initarg :gear3 :accessor gear3
 102      :initform (c_? (let ((dl (gl:gen-lists 1)))
 103                       (gl:with-new-list (dl :compile)
 104                         (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0))
 105                         (draw-scaled-gear 1))
 106                       dl)))
 107
 108    (angle :initform (c-in 0.0) :accessor angle :initarg :angle)
 109    (frame-count :cell nil :initform 0 :accessor frame-count)
 110    (t0 :cell nil :initform 0 :accessor t0)
 111    ;
 112    (width :initarg :wdith :initform 400 :accessor width)
 113    (height :initarg :wdith :initform 400 :accessor height)))
 114
 115 (defmethod togl-timer-using-class ((self gears))
 116   (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time))
 117   (when (fmv :on-off)
 118     (incf (^angle) 5.0)
 119     (togl-post-redisplay (togl-ptr self)))
 120   ;(loop until (zerop (ctk::Tcl_DoOneEvent 2)))
 121   )
 122
 123 (defmethod togl-create-using-class ((self gears))
 124   (gl:light :light0 :position #(5.0 5.0 10.0 0.0))
 125   (gl:enable :cull-face :lighting :light0 :depth-test)
 126   (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0))
 127   (gl:enable :normalize)
 128   (truc self))
 129
 130 (defmethod togl-reshape-using-class ((self gears))
 131   (trc nil "reshape")
 132   (truc self t)
 133   )
 134
 135 (defun truc (self &optional truly)
 136   (let ((width (Togl-width (togl-ptr self)))
 137         (height (Togl-height (togl-ptr self))))
 138     (trc nil "enter gear reshape" self width (width self))
 139     (gl:viewport 0 (- height (height self)) (width self) (height self))
 140     (unless truly
 141       (gl:matrix-mode :projection)
 142       (gl:load-identity)
 143       (let ((h (/ height width)))
 144         (gl:frustum -1 1 (- h) h 5 60)))
 145     (progn
 146       (gl:matrix-mode :modelview)
 147       (gl:load-identity)
 148       (gl:translate 0 0 -30))))
 149
 150
 151 (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo))))
 152   (declare (ignorable scale))
 153   (trc nil "display angle" (^rotx)(^roty)(^rotz))
 154   (gl:clear-color 0 0 0 1)
 155   (gl:clear :color-buffer-bit :depth-buffer-bit)
 156
 157   (gl:with-pushed-matrix
 158       (gl:rotate (^rotx) 1 0 0)
 159     (gl:rotate (^roty) 0 1 0)
 160     (gl:rotate (^rotz) 0 0 1)
 161
 162     (gl:with-pushed-matrix
 163         (gl:translate -3 -2 0)
 164       (gl:rotate (^angle) 0 0 1)
 165       (gl:call-list (^gear1)))
 166
 167     (gl:with-pushed-matrix
 168         (gl:translate 3.1 -2 0)
 169       (gl:rotate (- (* -2 (^angle)) 9) 0 0 1)
 170       (gl:call-list (^gear2)))
 171
 172     (gl:with-pushed-matrix ; gear3
 173         (gl:translate -3.1 4.2 0.0)
 174       (gl:rotate (- (* -2 (^angle)) 25) 0 0 1)
 175       (gl:call-list (^gear3))))
 176
 177   (Togl-Swap-Buffers (togl-ptr self))
 178
 179   #+shhh (print-frame-rate self))
 180
 181 (defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth)
 182   "Draw a gear."
 183   (declare (single-float inner-radius outer-radius width tooth-depth)
 184            (fixnum n-teeth))
 185   (let ((r0 inner-radius)
 186         (r1 (- outer-radius (/ tooth-depth 2.0)))
 187         (r2 (+ outer-radius (/ tooth-depth 2.0)))
 188         (da (/ (* 2.0 +pif+) n-teeth 4.0)))
 189     (gl:shade-model :flat)
 190     (gl:normal 0 0 1)
 191     ;; Draw front face.
 192     (gl:with-primitives :quad-strip
 193       (dotimes (i (1+ n-teeth))
 194         (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
 195           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
 196           (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
 197           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
 198           (gl:vertex (* r1 (cos (+ angle (* 3 da))))
 199                      (* r1 (sin (+ angle (* 3 da))))
 200                      (* width 0.5)))))
 201     ;; Draw front sides of teeth.
 202     (gl:with-primitives :quads
 203       (dotimes (i n-teeth)
 204         (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
 205           (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
 206           (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
 207                      (* width 0.5))
 208           (gl:vertex (* r2 (cos (+ angle (* 2 da))))
 209                      (* r2 (sin (+ angle (* 2 da))))
 210                      (* width 0.5))
 211           (gl:vertex (* r1 (cos (+ angle (* 3 da))))
 212                      (* r1 (sin (+ angle (* 3 da))))
 213                      (* width 0.5)))))
 214     (gl:normal 0 0 -1)
 215     ;; Draw back face.
 216     (gl:with-primitives :quad-strip
 217       (dotimes (i (1+ n-teeth))
 218         (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
 219           (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
 220           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
 221           (gl:vertex (* r1 (cos (+ angle (* 3 da))))
 222                        (* r1 (sin (+ angle (* 3 da))))
 223                        (* width -0.5))
 224           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
 225     ;; Draw back sides of teeth.
 226     (gl:with-primitives :quads
 227       (dotimes (i n-teeth)
 228         (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
 229           (gl:vertex (* r1 (cos (+ angle (* 3 da))))
 230                      (* r1 (sin (+ angle (* 3 da))))
 231                      (* (- width) 0.5))
 232           (gl:vertex (* r2 (cos (+ angle (* 2 da))))
 233                      (* r2 (sin (+ angle (* 2 da))))
 234                      (* (- width) 0.5))
 235           (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
 236                      (* (- width) 0.5))
 237           (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5)))))
 238     ;; Draw outward faces of teeth.
 239     (gl:with-primitives :quad-strip
 240       (dotimes (i n-teeth)
 241         (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
 242           (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
 243           (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))
 244           (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
 245                  (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
 246                  (len (sqrt (+ (* u u) (* v v)))))
 247             (setq u (/ u len))
 248             (setq v (/ u len))
 249             (gl:normal v (- u) 0.0)
 250             (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
 251                        (* width 0.5))
 252             (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
 253                        (* (- width) 0.5))
 254             (gl:normal (cos angle) (sin angle) 0.0)
 255             (gl:vertex (* r2 (cos (+ angle (* 2 da))))
 256                        (* r2 (sin (+ angle (* 2 da))))
 257                        (* width 0.5))
 258             (gl:vertex (* r2 (cos (+ angle (* 2 da))))
 259                        (* r2 (sin (+ angle (* 2 da))))
 260                        (* (- width) 0.5))
 261             (setq u (- (* r1 (cos (+ angle (* 3 da))))
 262                        (* r2 (cos (+ angle (* 2 da))))))
 263             (setq v (- (* r1 (sin (+ angle (* 3 da))))
 264                        (* r2 (sin (+ angle (* 2 da))))))
 265             (gl:normal v (- u) 0.0)
 266             (gl:vertex (* r1 (cos (+ angle (* 3 da))))
 267                        (* r1 (sin (+ angle (* 3 da))))
 268                        (* width 0.5))
 269             (gl:vertex (* r1 (cos (+ angle (* 3 da))))
 270                        (* r1 (sin (+ angle (* 3 da))))
 271                        (* (- width) 0.5))
 272             (gl:normal (cos angle) (sin angle) 0.0))))
 273       (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5))
 274       (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5)))
 275     ;; Draw inside radius cylinder.
 276     (gl:shade-model :smooth)
 277     (gl:with-primitives :quad-strip
 278       (dotimes (i (1+ n-teeth))
 279         (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
 280           (gl:normal (- (cos angle)) (- (sin angle)) 0.0)
 281           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5))
 282           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)))))))
 283
 284 (defun print-frame-rate (window)
 285   (with-slots (frame-count t0) window
 286     (incf frame-count)
 287     (let ((time (get-internal-real-time)))
 288       (when (= t0 0)
 289         (setq t0 time))
 290       (when (>= (- time t0) (* 5 internal-time-units-per-second))
 291         (let* ((seconds (/ (- time t0) internal-time-units-per-second))
 292                (fps (/ frame-count seconds)))
 293           (declare (ignorable fps))
 294           #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%"
 295                   frame-count seconds fps))
 296         (setq t0 time)
 297         (setq frame-count 0)))))