/[cells]/Celtk/cellogears.lisp
ViewVC logotype

Contents of /Celtk/cellogears.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Thu Jan 3 20:23:30 2008 UTC (6 years, 3 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +21 -6 lines
*** empty log message ***
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)))))

  ViewVC Help
Powered by ViewVC 1.1.5