source: trunk/source/examples/rubix/blocks.lisp @ 13474

Last change on this file since 13474 was 6230, checked in by gb, 13 years ago

Use new syntax: OBJC:DEFMETHOD, #/, MAKE-INSTANCE.

Handle CGFLOAT issues in mouse event handlers.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.2 KB
Line 
1(in-package :cl-user)
2
3(defparameter *cube* nil)
4
5(defparameter *camera-pos* #(10.0 5.0 12.0))
6
7(defparameter *selection-buffer-size* 256)
8
9;; some things have no scale or rotation, such as point light sources
10;; (note lights use a 4d vector to hold both positoin and pointsourceness)
11(defclass positioned-object ()
12  ((location :initform nil :initarg :location :accessor location))
13  (:default-initargs :location (make-array 3 :initial-element 0.0)))
14
15(defmethod move-relative ((obj positioned-object) v)
16  (add-vectors (location obj) v (location obj))
17  (location obj))
18(defmethod move-relative-3 ((obj positioned-object) dx dy dz)
19  (incf (elt (location obj) 0) dx)
20  (incf (elt (location obj) 1) dy)
21  (incf (elt (location obj) 2) dz)
22  (location obj))
23(defmethod move-absolute ((obj positioned-object) p)
24  (dotimes (i 3) (setf (elt (location obj) i) (elt p i)))
25  (location obj))
26(defmethod move-absolute-3 ((obj positioned-object) x y z)
27  (setf (elt (location obj) 0) x
28        (elt (location obj) 1) y
29        (elt (location obj) 2) z)
30  (location obj))
31
32(defmethod gl-translate ((obj positioned-object))
33  (#_glTranslatef (elt (location obj) 0)
34                  (elt (location obj) 1)
35                  (elt (location obj) 2)))
36
37(defclass rotated-object ()
38  ((quaternion :initform nil :initarg :quaternion :accessor quaternion))
39  (:default-initargs :quaternion (make-instance 'quaternion)))
40
41(defmethod rotate-relative ((obj rotated-object) quaternion)
42  ;; recall mulquats applies q2's rotation first...
43  (mulquats quaternion (quaternion obj) (quaternion obj))
44  (quaternion obj))
45(defmethod rotate-absolute ((obj rotated-object) quaternion)
46  (setf (w (quaternion obj)) (w quaternion))
47  (dotimes (i 3)
48    (setf (elt (xyz (quaternion obj)) i) (elt quaternion i)))
49  (quaternion obj))
50
51(defmethod gl-rotate ((obj rotated-object))
52  (let ((axis-angle (quat->axis-angle (quaternion obj))))
53    (#_glRotatef (cdr axis-angle)
54                 (elt (car axis-angle) 0)
55                 (elt (car axis-angle) 1)
56                 (elt (car axis-angle) 2))))
57
58(defclass scaled-object ()
59  ((dilation :initform nil :initarg :dilation :accessor dilation))
60  (:default-initargs :dilation (make-array 3 :initial-element 1.0)))
61
62(defmethod gl-scale ((obj scaled-object))
63  (#_glScalef (elt (dilation obj) 0)
64              (elt (dilation obj) 1)
65              (elt (dilation obj) 2)))
66
67(defclass transformed-object (positioned-object
68                              rotated-object
69                              scaled-object)
70  ())
71
72(defmacro with-transformation ((transformed-object) &body body)
73  (let ((tobj-sym (gensym)))
74    `(let ((,tobj-sym ,transformed-object))
75       (#_glPushMatrix)
76       (gl-translate ,tobj-sym)
77       (gl-rotate ,tobj-sym)
78       (gl-scale ,tobj-sym)
79       ,@body
80       (#_glPopMatrix))))
81
82(defmethod render ((obj transformed-object)) ; should this be on something else?
83  (#_glMatrixMode #$GL_MODELVIEW)
84  (with-transformation (obj)
85    (render-children obj)))
86
87(defclass block (transformed-object)
88  (;; need to generate matrices of this form so that copy-ivector-etc will work
89   (vertices :initform (coerce
90                        (list (make-array 3 :initial-contents '(-0.5 -0.5  0.5)
91                                          :element-type 'single-float)
92                              (make-array 3 :initial-contents '( 0.5 -0.5  0.5)
93                                          :element-type 'single-float)
94                              (make-array 3 :initial-contents '( 0.5  0.5  0.5)
95                                          :element-type 'single-float)
96                              (make-array 3 :initial-contents '(-0.5  0.5  0.5)
97                                          :element-type 'single-float)
98                              (make-array 3 :initial-contents '(-0.5 -0.5 -0.5)
99                                          :element-type 'single-float)
100                              (make-array 3 :initial-contents '( 0.5 -0.5 -0.5)
101                                          :element-type 'single-float)
102                              (make-array 3 :initial-contents '( 0.5  0.5 -0.5)
103                                          :element-type 'single-float)
104                              (make-array 3 :initial-contents '(-0.5  0.5 -0.5)
105                                          :element-type 'single-float))
106                        'vector)
107             :initarg :vertices :accessor vertices
108             ;; :allocation :class
109             )))
110
111;; I expect that especially with the FFI overhead, one call to render
112;; a static object's prefabbed display list will beat out a lot of
113;; calls to render the various portions... this will be an interesting
114;; conversionn and test going from code to DL, and good prep for
115;; moving from DL-creating code to DL file readers
116#+ignore
117(defmethod render-children ((obj block))
118  (let ((curve-radius 0.1)) ; 90-degree curve in 3 sections for edges and for corners
119    ;; strip for faces 0134 and their edges
120    ;; strip for face 2 and edges to 0 and 3
121    ;; strip for face 5 and edges to 0 and 3
122    ;; edges 15, 54, 42, and 21
123    ;; corner
124    ))
125
126(defmethod render-children ((obj block))
127  (flet ((norm (axis) (#_glNormal3f (aref axis 0) (aref axis 1) (aref axis 2)))
128         (material (color)
129           (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 double-floats
130             (ccl::%copy-ivector-to-ptr color
131               0 ; offset to first element (alignment padding)
132               foreign-float-vector ; destination
133               0 ; byte offset in destination
134               (* 4 4)) ; number of bytes to copy
135             (#_glMaterialfv #$GL_FRONT_AND_BACK
136                             #$GL_AMBIENT_AND_DIFFUSE
137                             foreign-float-vector)))
138         (quad (a b c d)
139           (ccl::%stack-block ((ffv (* 4 3)))
140             (ccl::%copy-ivector-to-ptr (aref (vertices obj) a) 0 ffv 0 (* 4 3))
141             (#_glVertex3fv ffv))
142           (ccl::%stack-block ((ffv (* 4 3)))
143             (ccl::%copy-ivector-to-ptr (aref (vertices obj) b) 0 ffv 0 (* 4 3))
144             (#_glVertex3fv ffv))
145           (ccl::%stack-block ((ffv (* 4 3)))
146             (ccl::%copy-ivector-to-ptr (aref (vertices obj) c) 0 ffv 0 (* 4 3))
147             (#_glVertex3fv ffv))
148           (ccl::%stack-block ((ffv (* 4 3)))
149             (ccl::%copy-ivector-to-ptr (aref (vertices obj) d) 0 ffv 0 (* 4 3))
150             (#_glVertex3fv ffv))
151           t))
152    (opengl:with-gl (#$GL_QUADS)
153      (norm *x-axis*)     (material *hel-orange*) (quad 1 2 6 5)
154      (norm *y-axis*)     (material *hel-yellow*) (quad 2 3 7 6)
155      (norm *z-axis*)     (material *hel-green*)  (quad 0 3 2 1)
156      (norm *neg-x-axis*) (material *hel-red*)    (quad 0 4 7 3)
157      (norm *neg-y-axis*) (material *hel-white*)  (quad 0 1 5 4)
158      (norm *neg-z-axis*) (material *hel-blue*)   (quad 4 5 6 7))))
159
160(defclass rubix-cube (transformed-object)
161  ((blocks :initform nil :initarg :blocks :accessor blocks)
162   (faces :initform nil :initarg :faces :accessor faces)
163   (faces-axes :initform (coerce (list *neg-x-axis* *neg-y-axis* *neg-z-axis*
164                                       *x-axis* *y-axis* *z-axis*) 'vector)
165               :initarg :faces-axes :reader faces-axes
166               ;; :allocation :class
167               )
168   (face-turning-p :initform nil :initarg :face-turning-p :accessor face-turning-p)
169   (turning-face :initform nil :initarg :turning-face :accessor turning-face)
170   (face-theta :initform nil :initarg :face-theta :accessor face-theta)
171   ;; vertices for rendering full cube's faces for selection
172   (vertices :initform (coerce
173                        (list (make-array 3 :initial-contents '(-0.5 -0.5  0.5)
174                                          :element-type 'single-float)
175                              (make-array 3 :initial-contents '( 0.5 -0.5  0.5)
176                                          :element-type 'single-float)
177                              (make-array 3 :initial-contents '( 0.5  0.5  0.5)
178                                          :element-type 'single-float)
179                              (make-array 3 :initial-contents '(-0.5  0.5  0.5)
180                                          :element-type 'single-float)
181                              (make-array 3 :initial-contents '(-0.5 -0.5 -0.5)
182                                          :element-type 'single-float)
183                              (make-array 3 :initial-contents '( 0.5 -0.5 -0.5)
184                                          :element-type 'single-float)
185                              (make-array 3 :initial-contents '( 0.5  0.5 -0.5)
186                                          :element-type 'single-float)
187                              (make-array 3 :initial-contents '(-0.5  0.5 -0.5)
188                                          :element-type 'single-float))
189                        'vector)
190             :initarg :vertices :reader vertices
191             ;; :allocation :class
192             ))
193  (:default-initargs
194      :blocks (let ((list nil))
195                (loop for x from -1.0 to 1.0 do
196                     (loop for y from -1.0 to 1.0 do
197                          (loop for z from -1.0 to 1.0 do
198                               (push (make-instance 'block
199                                       :location (coerce (list (/ x 3.0)
200                                                               (/ y 3.0)
201                                                               (/ z 3.0)) 'vector)
202                                       :dilation (coerce (list (/ 1.0 3.0)
203                                                               (/ 1.0 3.0)
204                                                               (/ 1.0 3.0)) 'vector))
205                                     list))))
206                (coerce list 'vector))))
207
208(defparameter *child-positions* (let ((list nil))
209                                  (loop for x from -1.0 to 1.0 do
210                                        (loop for y from -1.0 to 1.0 do
211                                              (loop for z from -1.0 to 1.0 do
212                                                    (push (coerce (list (/ x 3.0)
213                                                                        (/ y 3.0)
214                                                                        (/ z 3.0)) 'vector)
215                                                          list))))
216                                  (coerce list 'vector)))
217
218;; blocks in faces start at a corner, go clockwise around the face,
219;; and finish in the center; blocks in the cube are numbered to
220;; correspond to *child-positions*; faces that share blocks are
221;; associated in faces-neighbors -- all 3 of these variables depend on
222;; each other
223(defparameter *initial-blocks-in-faces* #2a((0 1 2 5 8 7 6 3 4)
224                                            (0 9 18 19 20 11 2 1 10)
225                                            (0 3 6 15 24 21 18 9 12)
226                                            (26 23 20 19 18 21 24 25 22)
227                                            (26 25 24 15 6 7 8 17 16)
228                                            (26 17 8 5 2 11 20 23 14)))
229
230(defmethod shared-initialize :after ((obj rubix-cube) slot-names &key)
231  (declare (ignore slot-names))
232  (setf (faces obj) (make-array (list 6 9)))
233  (dotimes (face 6)
234    (dotimes (blok 9)
235      (setf (aref (faces obj) face blok)
236            (aref (blocks obj) (aref *initial-blocks-in-faces* face blok))))))
237
238(let ((faces-neighbors #2a((1 5 4 2)
239                           (2 3 5 0)
240                           (0 4 3 1)
241                           (5 1 2 4)
242                           (3 2 0 5)
243                           (4 0 1 3))))
244  (defun faces-neighbor (face neighbor)
245    (aref faces-neighbors face neighbor))
246  (defun faces-index-from-neighbor (face neighbor)
247    (loop for i from 0 to 3 do
248      (when (= face (faces-neighbor (faces-neighbor face neighbor) i))
249        (return i))))
250  )
251
252(defmethod turnfaceclockwise ((cube rubix-cube) face &aux temp)
253  (with-slots (faces) cube
254    ;; rotate blocks through adjacent faces
255    (dotimes (neighbor 4)
256      (let* ((neighbors-face (faces-neighbor face neighbor))
257             (my-index (faces-index-from-neighbor face neighbor))
258             (my-block-index (* 2 my-index))
259             (his-new-block-index (* 2 (mod (+ neighbor 3) 4))))
260        (setf (aref faces neighbors-face (mod my-block-index 8))
261              (aref faces face (mod (+ 2 his-new-block-index) 8)))
262        (setf (aref faces neighbors-face (mod (1+ my-block-index) 8))
263              (aref faces face (mod (1+ his-new-block-index) 8)))
264        (setf (aref faces neighbors-face (mod (+ 2 my-block-index) 8))
265              (aref faces face (mod his-new-block-index 8)))))
266    ;; rotate blocks in this face
267    (setf temp (aref faces face 0)
268          (aref faces face 0) (aref faces face 6)
269          (aref faces face 6) (aref faces face 4)
270          (aref faces face 4) (aref faces face 2)
271          (aref faces face 2) temp
272          temp (aref faces face 1)
273          (aref faces face 1) (aref faces face 7)
274          (aref faces face 7) (aref faces face 5)
275          (aref faces face 5) (aref faces face 3)
276          (aref faces face 3) temp)
277    ;; update positions and orientation of blocks in this face
278    (dotimes (i 9)
279      (move-absolute (aref faces face i)
280                     (elt *child-positions* (aref *initial-blocks-in-faces* face i)))
281      (rotate-relative (aref faces face i)
282                       (axis-angle->quat (aref (faces-axes cube) face)
283                                         90.0)))
284    ))
285
286(defmethod turnfacecounterclockwise ((cube rubix-cube) face &aux temp)
287  (with-slots (faces) cube
288    ;; rotate blocks through adjacent faces
289    (dotimes (neighbor 4)
290      (let* ((neighbors-face (faces-neighbor face neighbor))
291             (my-index (faces-index-from-neighbor face neighbor))
292             (my-block-index (* 2 my-index))
293             (his-new-block-index (* 2 (mod (+ neighbor 1) 4))))
294        (setf (aref faces neighbors-face (mod my-block-index 8))
295              (aref faces face (mod (+ 2 his-new-block-index) 8)))
296        (setf (aref faces neighbors-face (mod (1+ my-block-index) 8))
297              (aref faces face (mod (1+ his-new-block-index) 8)))
298        (setf (aref faces neighbors-face (mod (+ 2 my-block-index) 8))
299              (aref faces face (mod his-new-block-index 8)))))
300    ;; rotate blocks in this face
301    (setf temp (aref faces face 0)
302          (aref faces face 0) (aref faces face 2)
303          (aref faces face 2) (aref faces face 4)
304          (aref faces face 4) (aref faces face 6)
305          (aref faces face 6) temp
306          temp (aref faces face 1)
307          (aref faces face 1) (aref faces face 3)
308          (aref faces face 3) (aref faces face 5)
309          (aref faces face 5) (aref faces face 7)
310          (aref faces face 7) temp)
311    ;; update positions and orientation of blocks in this face
312    (dotimes (i 9)
313      (move-absolute (aref faces face i)
314                     (elt *child-positions* (aref *initial-blocks-in-faces* face i)))
315      (rotate-relative (aref faces face i)
316                       (axis-angle->quat (aref (faces-axes cube) face)
317                                         -90.0)))
318    ))
319
320(defmethod render-children ((obj rubix-cube))
321  (flet ((in-face-p (face blok)
322           (dotimes (i 9)
323             (when (eq (aref (blocks obj) blok)
324                       (aref (faces obj) face i))
325               (return t)))))
326    (cond ((not (face-turning-p obj))
327           (dotimes (blok 27)
328             (render (aref (blocks obj) blok))))
329          (t
330           (dotimes (blok 27)
331             (unless (in-face-p (turning-face obj) blok)
332               (render (aref (blocks obj) blok))))
333           (opengl:with-rotation ((face-theta obj)
334                                  (aref (faces-axes obj) (turning-face obj)))
335             (dotimes (blok 9)
336               (render (aref (faces obj) (turning-face obj) blok))))))))
337
338
339(defmethod render-for-selection ((objc rubix-cube) picked-point)
340  (let ((gl-uint-size (ccl::foreign-size :<GL>uint :bytes)) ; 4, as it turns out...
341        (selection-buffer-size 256))
342    (ccl::%stack-block ((selection-buffer (* gl-uint-size selection-buffer-size)))
343      (#_glSelectBuffer selection-buffer-size selection-buffer)
344      (let (;; FYI - this loses a lot of structure and becomes a lot
345            ;; longer in C++ for lack of macros
346            (hits (opengl:with-render-mode (#$GL_SELECT)
347                    (#_glInitNames)
348                    (#_glPushName 0)
349                    (opengl:with-culling (#$GL_FRONT)
350                      ;; set up the modified camera looking around the mouse's region
351                      (opengl:with-matrix-mode (#$GL_PROJECTION)
352                        (opengl:with-matrix (t)
353                          (#_glFrustum -0.01d0 0.01d0 -0.01d0 0.01d0 10.0d0 20.0d0)
354                          (opengl:with-matrix-mode (#$GL_MODELVIEW)
355                            (opengl:with-matrix (t)
356                              (mylookat *camera-pos* picked-point *y-axis*)
357                              ;; NOW render the cube like we were doing before
358                              (opengl:with-matrix-mode (#$GL_MODELVIEW)
359                                (with-transformation (objc)
360                                  (render-children-for-selection objc)))))))
361                      (#_glFlush)))))
362        (when (and (numberp hits)
363                   (< 0 hits))
364          ;; the first hit name is at selectBuf[3], though i don't recall why
365          (ccl::%get-unsigned-long selection-buffer (* 3 4)))))))
366
367(defmethod render-children-for-selection ((objc rubix-cube))
368  (flet ((norm (axis) (#_glNormal3f (aref axis 0) (aref axis 1) (aref axis 2)))
369         (material (color)
370           (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats
371             (ccl::%copy-ivector-to-ptr color
372               0 ; offset to first element (alignment padding)
373               foreign-float-vector ; destination
374               0 ; byte offset in destination
375               (* 4 4)) ; number of bytes to copy
376             (#_glMaterialfv #$GL_FRONT_AND_BACK
377                             #$GL_AMBIENT_AND_DIFFUSE
378                             foreign-float-vector)))
379         (quad (a b c d)
380           (ccl::%stack-block ((ffv (* 4 3)))
381             (ccl::%copy-ivector-to-ptr (aref (vertices objc) a) 0 ffv 0 (* 4 3))
382             (#_glVertex3fv ffv))
383           (ccl::%stack-block ((ffv (* 4 3)))
384             (ccl::%copy-ivector-to-ptr (aref (vertices objc) b) 0 ffv 0 (* 4 3))
385             (#_glVertex3fv ffv))
386           (ccl::%stack-block ((ffv (* 4 3)))
387             (ccl::%copy-ivector-to-ptr (aref (vertices objc) c) 0 ffv 0 (* 4 3))
388             (#_glVertex3fv ffv))
389           (ccl::%stack-block ((ffv (* 4 3)))
390             (ccl::%copy-ivector-to-ptr (aref (vertices objc) d) 0 ffv 0 (* 4 3))
391             (#_glVertex3fv ffv))
392           t))
393    (#_glLoadName 0)
394    (opengl:with-gl (#$GL_QUADS)
395      (norm *x-axis*)     (material *hel-orange*) (quad 1 2 6 5))
396    (#_glLoadName 1)
397    (opengl:with-gl (#$GL_QUADS)
398      (norm *y-axis*)     (material *hel-yellow*) (quad 2 3 7 6))
399    (#_glLoadName 2)
400    (opengl:with-gl (#$GL_QUADS)
401      (norm *z-axis*)     (material *hel-green*)  (quad 0 3 2 1))
402    (#_glLoadName 3)
403    (opengl:with-gl (#$GL_QUADS)
404      (norm *neg-x-axis*) (material *hel-red*)    (quad 0 4 7 3))
405    (#_glLoadName 4)
406    (opengl:with-gl (#$GL_QUADS)
407      (norm *neg-y-axis*) (material *hel-white*)  (quad 0 1 5 4))
408    (#_glLoadName 5)
409    (opengl:with-gl (#$GL_QUADS)
410      (norm *neg-z-axis*) (material *hel-blue*)   (quad 4 5 6 7))))
Note: See TracBrowser for help on using the repository browser.