source: trunk/ccl/examples/rubix/rubix.lisp @ 5914

Last change on this file since 5914 was 5914, checked in by gb, 14 years ago

A little bit of cgfloat stuff; there are more/other float-size issues
deeper down in the code.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.4 KB
Line 
1(in-package :cl-user)
2
3
4(defparameter light0 nil)
5(defparameter light0-pos (make-array 3 :initial-contents '(5.0 3.0 0.0) ;; default to distant light source
6                                     :element-type 'single-float))
7(defparameter diffuse0 (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0)
8                                   :element-type 'single-float))
9(defparameter ambient0 (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0)
10                                   :element-type 'single-float))
11(defparameter specular0 (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0)
12                                   :element-type 'single-float))
13
14(defparameter global-ambient (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0) :element-type 'single-float)) ;; really really dim grey light
15
16(defclass rubix-opengl-view (ns:ns-opengl-view)
17  ()
18  (:metaclass ns:+ns-object))
19
20(ccl::define-objc-method ((:void prepare-opengl) rubix-opengl-view)
21  (declare (special *the-origin* *y-axis*))
22  (declare (ignore a-rect))
23  (opengl:with-matrix-mode (#$GL_PROJECTION) ;; default is GL_MODELVIEW
24    (#_glLoadIdentity)
25    (#_glFrustum -0.6d0 0.6d0 -0.6d0 0.6d0 10.0d0 20.0d0))
26  (#_glLoadIdentity)
27  (mylookat *camera-pos* *the-origin* *y-axis*)
28
29  (#_glShadeModel #$GL_SMOOTH)
30  (#_glClearColor 0.05 0.05 0.05 0.0)
31  ;; these next three are all needed to enable the z-buffer
32  (#_glClearDepth 1.0d0)
33  (#_glEnable #$GL_DEPTH_TEST)
34  (#_glDepthFunc #$GL_LEQUAL)
35  (#_glHint #$GL_PERSPECTIVE_CORRECTION_HINT #$GL_NICEST)
36
37  (setf *cube* (make-instance 'rubix-cube))
38
39  (#_glEnable #$GL_LIGHTING)
40
41  (setf light0 (make-instance 'light :lightid #$GL_LIGHT0))
42  (setpointsource light0 t)
43  (setlocation light0 light0-pos)
44  (setdiffuse light0 diffuse0)
45  (setambient light0 ambient0)
46  (setspecular light0 specular0)
47  (on light0)
48
49  (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats
50    (ccl::%copy-ivector-to-ptr global-ambient ; source
51      0     ; offset to first element (alignment padding)
52      foreign-float-vector ; destination
53      0                    ; byte offset in destination
54      (* 4 4))             ; number of bytes to copy
55    (#_glLightModelfv #$GL_LIGHT_MODEL_AMBIENT foreign-float-vector)) ;; <- coersion issue
56
57  (#_glFlush))
58
59(ccl::define-objc-method ((:void :draw-rect (:<NSR>ect a-rect)) rubix-opengl-view)
60  (declare (ignorable a-rect))
61  ;; drawing callback
62  (#_glClear (logior #$GL_COLOR_BUFFER_BIT #$GL_DEPTH_BUFFER_BIT))
63  (render *cube*)
64  (#_glFlush))
65
66;; want to be able to send keystrokes to the rubix cube
67#+ignore
68(ccl::define-objc-method ((:<BOOL> accepts-first-responder) rubix-opengl-view)
69  #$YES)
70
71;; want to be able to click and start dragging (without moving the window)
72(ccl::define-objc-method ((:<BOOL> accepts-first-mouse) rubix-opengl-view)
73  #$YES)
74
75(defparameter *rubix-face-snap* 8.0) ; degrees
76
77(ccl::define-objc-method ((:void :mouse-down the-event) rubix-opengl-view)
78  ;; this makes dragging spin the cube
79  (cond ((zerop (logand #$NSControlKeyMask (ccl::send the-event 'modifier-flags))) ; not ctrl-click
80         (let ((dragging-p t))
81           (rlet ((last-loc :<NSP>oint))
82                 (ccl::send/stret last-loc the-event 'location-in-window)
83                 (loop while dragging-p do
84                       (let ((the-event (ccl::send (ccl::send self 'window)
85                                                   :next-event-matching-mask
86                                                   (logior #$NSLeftMouseUpMask
87                                                           #$NSLeftMouseDraggedMask))))
88                         (rlet ((mouse-loc :<NSP>oint))
89                               (ccl::send/stret mouse-loc the-event 'location-in-window)
90                               (cond ((eq #$NSLeftMouseDragged (ccl::send (the ns:ns-event the-event) 'type))
91                                      (let ((deltax (- (pref mouse-loc :<NSP>oint.x)
92                                                       (pref last-loc :<NSP>oint.x)))
93                                            (deltay (- (pref last-loc :<NSP>oint.y)
94                                                       (pref mouse-loc :<NSP>oint.y)))
95                                            (vert-rot-axis (cross *y-axis* *camera-pos*)))
96                                        (setf (pref last-loc :<NSP>oint.x) (pref mouse-loc :<NSP>oint.x)
97                                              (pref last-loc :<NSP>oint.y) (pref mouse-loc :<NSP>oint.y))
98                                        (rotate-relative *cube*
99                                                         (mulquats (axis-angle->quat vert-rot-axis deltay)
100                                                                   (axis-angle->quat *y-axis* deltax))))
101                                      (ccl::send self :set-needs-display #$YES))
102                                     (t
103                                      (setf dragging-p nil))))))
104                 (ccl::send self :set-needs-display #$YES))))
105        (t ;; ctrl-click, do what right-click does... note that once
106           ;; ctrl-click is done dragging will not require ctrl be held down
107
108         ;; NOTE THE GRATUITOUS CUT-AND-PASTE, debug the right-mouse-down
109         ;; version preferentially and update this one with fixes as needed
110         (rlet ((first-loc :<NSP>oint)
111                (pick-loc :<NSP>oint))
112               (ccl::send/stret first-loc the-event 'location-in-window)
113               (ccl::send/stret pick-loc self :convert-point first-loc :from-view nil)
114               (let ((dragging-p t)
115                     (reference-snap 0))
116                 (setf (turning-face *cube*) (render-for-selection
117                                              *cube*
118                                              (opengl:unproject (pref pick-loc :<NSP>oint.x)
119                                                                (pref pick-loc :<NSP>oint.y)))
120                       (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t)
121                       (face-theta *cube*) 0.0)
122                 (loop while (and dragging-p (face-turning-p *cube*)) do
123                       (let ((the-event (ccl::send (ccl::send self 'window)
124                                                   :next-event-matching-mask
125                                                   (logior #$NSLeftMouseUpMask
126                                                           #$NSLeftMouseDraggedMask))))
127                         (rlet ((mouse-loc :<NSP>oint))
128                               (ccl::send/stret mouse-loc the-event 'location-in-window)
129                               (cond ((eq #$NSLeftMouseDragged (ccl::send (the ns:ns-event the-event) 'type))
130                                      (let ((deltax (- (pref mouse-loc :<NSP>oint.x)
131                                                       (pref first-loc :<NSP>oint.x))))
132                                        (multiple-value-bind (snap-to snap-dist) (round deltax 90.0)
133                                                             (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap
134                                                                    ;; update cube structure
135                                                                    (let ((rotations (- snap-to reference-snap)))
136                                                                      (cond ((zerop rotations) nil)
137                                                                            ((< 0 rotations)
138                                                                             (dotimes (i rotations)
139                                                                               (turnfaceclockwise *cube* (turning-face *cube*)))
140                                                                             (setf reference-snap snap-to))
141                                                                            ((> 0 rotations)
142                                                                             (dotimes (i (abs rotations))
143                                                                               (turnfacecounterclockwise *cube* (turning-face *cube*)))
144                                                                             (setf reference-snap snap-to))))
145                                                                    ;; determine where face will be drawn
146                                                                    (setf (face-theta *cube*) 0.0))
147                                                                   (t ; no snap
148                                                                    (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap))))
149                                                                   )))
150                                      (ccl::send self :set-needs-display #$YES))
151                                     (t
152                                      (setf (face-turning-p *cube*) nil
153                                            (turning-face *cube*) nil
154                                            (face-theta *cube*) nil
155                                            dragging-p nil))))))
156                 (ccl::send self :set-needs-display #$YES)))
157         )))
158
159(ccl::define-objc-method ((:void :right-mouse-down the-event) rubix-opengl-view)
160  ;; this makes dragging left/right turn a face counterclockwise/clockwise
161  ;; ... clicked-on face determines face turned
162  ;; ... with an n-degree "snap"
163  ;; ... with the snap updating the data structure
164  ;; ... releasing the mouse clears rotation angle (face will snap to last position)
165  (rlet ((first-loc :<NSP>oint)
166         (pick-loc :<NSP>oint))
167    (ccl::send/stret first-loc the-event 'location-in-window)
168    (ccl::send/stret pick-loc self :convert-point first-loc :from-view nil)
169    (let ((dragging-p t)
170          (reference-snap 0))
171      (setf (turning-face *cube*) (render-for-selection
172                                 *cube*
173                                 (opengl:unproject (pref pick-loc :<NSP>oint.x)
174                                                   (pref pick-loc :<NSP>oint.y)))
175            (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t)
176            (face-theta *cube*) 0.0)
177      (loop while (and dragging-p (face-turning-p *cube*)) do
178            (let ((the-event (ccl::send (ccl::send self 'window)
179                                        :next-event-matching-mask
180                                        (logior #$NSRightMouseUpMask
181                                                #$NSRightMouseDraggedMask))))
182              (rlet ((mouse-loc :<NSP>oint))
183                (ccl::send/stret mouse-loc the-event 'location-in-window)
184                (cond ((eq #$NSRightMouseDragged (ccl::send (the ns:ns-event the-event) 'type))
185                       (let ((deltax (- (pref mouse-loc :<NSP>oint.x)
186                                        (pref first-loc :<NSP>oint.x))))
187                         (multiple-value-bind (snap-to snap-dist) (round deltax 90.0)
188                           (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap
189                                  ;; update cube structure
190                                  (let ((rotations (- snap-to reference-snap)))
191                                    (cond ((zerop rotations) nil)
192                                          ((< 0 rotations)
193                                           (dotimes (i rotations)
194                                             (turnfaceclockwise *cube* (turning-face *cube*)))
195                                           (setf reference-snap snap-to))
196                                          ((> 0 rotations)
197                                           (dotimes (i (abs rotations))
198                                             (turnfacecounterclockwise *cube* (turning-face *cube*)))
199                                           (setf reference-snap snap-to))))
200                                  ;; determine where face will be drawn
201                                  (setf (face-theta *cube*) 0.0))
202                                 (t ; no snap
203                                  (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap))))
204                                 )))
205                       (ccl::send self :set-needs-display #$YES))
206                      (t
207                       (setf (face-turning-p *cube*) nil
208                             (turning-face *cube*) nil
209                             (face-theta *cube*) nil
210                             dragging-p nil))))))
211      (ccl::send self :set-needs-display #$YES))))
212
213(defclass rubix-window (ns:ns-window)
214  ()
215  (:metaclass ns:+ns-object))
216
217(defparameter *aluminum-margin* 5.0f0)
218
219(defun run-rubix-demo ()
220  (let* ((w (ccl::new-cocoa-window :class (find-class 'rubix-window)
221                                   :title "Rubix Cube"
222                                   :height 250
223                                   :width 250
224                                   :expandable nil))
225         (w-content-view (ccl::send w 'content-view)))
226    ;; Q: why slet here?
227    (ccl::slet ((w-frame (ccl::send w-content-view 'frame)))
228      (ccl::slet ((glview-rect (ccl::ns-make-rect
229                                (float *aluminum-margin* ccl::+cgfloat-zero+)
230                                (float *aluminum-margin* ccl::+cgfloat-zero+)
231                                (- (pref w-frame :<NSR>ect.size.width)
232                                   (* 2 *aluminum-margin*))
233                                (- (pref w-frame :<NSR>ect.size.height)
234                                   *aluminum-margin*))))
235        ;; Q: why make-objc-instance here?
236        (let ((glview (ccl::send (ccl::send (ccl::@class rubix-opengl-view) 'alloc)
237                            :init-with-frame glview-rect
238                            :pixel-format #+ignore
239                                          (ccl::send (ccl::@class ns-opengl-view)
240                                                     'default-pixel-format)
241                                          (opengl:new-pixel-format ;#$NSOpenGLPFADoubleBuffer
242                                                                   #$NSOpenGLPFAAccelerated
243                                                                   #$NSOpenGLPFAColorSize 32
244                                                                   #$NSOpenGLPFADepthSize 32))))
245          (ccl::send w-content-view :add-subview glview)
246          w)))))
Note: See TracBrowser for help on using the repository browser.