source: branches/objc-gf/ccl/examples/rubix/rubix.lisp @ 6167

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

Convert to the new order.
Try to isolate CGFLOAT issues by making the "deltax" and "deltay"
variables SINGLE-FLOATS, which is what the supporting GL code
seems to expect.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.8 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(objc:defmethod (#/prepareOpenGL :void) ((self 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(objc:defmethod (#/drawRect: :void) ((self rubix-opengl-view) (a-rect :ns-rect))
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(objc:defmethod (#/acceptsFirstResponder :<BOOL>) ((self rubix-opengl-view))
69  t)
70
71;; want to be able to click and start dragging (without moving the window)
72(objc:defmethod (#/acceptsFirstMouse: :<BOOL>) ((self rubix-opengl-view)
73                                                event)
74  (declare (ignore event))
75  t)
76
77
78(defparameter *rubix-face-snap* 8.0) ; degrees
79
80(objc:defmethod (#/mouseDown: :void) ((self rubix-opengl-view) the-event)
81  ;; this makes dragging spin the cube
82  (cond ((zerop (logand #$NSControlKeyMask (#/modifierFlags the-event))) ; not ctrl-click
83         (let ((dragging-p t))
84           (let ((last-loc (#/locationInWindow the-event)))
85             (loop while dragging-p do
86                   (let ((the-event (#/nextEventMatchingMask:
87                                     (#/window self)
88                                     (logior #$NSLeftMouseUpMask
89                                             #$NSLeftMouseDraggedMask))))
90                     (let ((mouse-loc (#/locationInWindow the-event)))
91                       (cond ((eq #$NSLeftMouseDragged (#/type the-event))
92                              (let ((deltax (float
93                                             (- (pref mouse-loc :<NSP>oint.x)
94                                                (pref last-loc :<NSP>oint.x))
95                                             0.0f0))
96                                    (deltay (float
97                                             (- (pref last-loc :<NSP>oint.y)
98                                                (pref mouse-loc :<NSP>oint.y))
99                                             0.0f0))
100                                    (vert-rot-axis (cross *y-axis* *camera-pos*)))
101                                (setf (pref last-loc :<NSP>oint.x) (pref mouse-loc :<NSP>oint.x)
102                                      (pref last-loc :<NSP>oint.y) (pref mouse-loc :<NSP>oint.y))
103                                (rotate-relative *cube*
104                                                 (mulquats (axis-angle->quat vert-rot-axis deltay)
105                                                           (axis-angle->quat *y-axis* deltax))))
106                              (#/setNeedsDisplay: self t))
107                             (t
108                              (setf dragging-p nil))))))
109             (#/setNeedsDisplay: self t))))
110        (t;; ctrl-click, do what right-click does... note that once
111         ;; ctrl-click is done dragging will not require ctrl be held down
112
113         ;; NOTE THE GRATUITOUS CUT-AND-PASTE, debug the right-mouse-down
114         ;; version preferentially and update this one with fixes as needed
115         (let* ((first-loc (#/locationInWindow the-event))
116                (pick-loc (#/convertPoint:fromView: self first-loc +null-ptr+)))
117           (let ((dragging-p t)
118                 (reference-snap 0))
119             (setf (turning-face *cube*) (render-for-selection
120                                          *cube*
121                                          (opengl:unproject (pref pick-loc :<NSP>oint.x)
122                                                            (pref pick-loc :<NSP>oint.y)))
123                   (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t)
124                   (face-theta *cube*) 0.0)
125             (loop while (and dragging-p (face-turning-p *cube*)) do
126                   (let ((the-event (#/nextEventMatchingMask:
127                                               (#/window self)
128                                               (logior #$NSLeftMouseUpMask
129                                                       #$NSLeftMouseDraggedMask))))
130                     (let ((mouse-loc (#/locationInWindow the-event)))
131                       (cond ((eq #$NSLeftMouseDragged (#/type the-event))
132                              (let ((deltax (float
133                                             (- (ns:ns-point-x mouse-loc)
134                                                (ns:ns-point-x first-loc))
135                                             0.0f0)))
136                                (multiple-value-bind (snap-to snap-dist) (round deltax 90.0)
137                                  (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap
138                                         ;; update cube structure
139                                         (let ((rotations (- snap-to reference-snap)))
140                                           (cond ((zerop rotations) nil)
141                                                 ((< 0 rotations)
142                                                  (dotimes (i rotations)
143                                                    (turnfaceclockwise *cube* (turning-face *cube*)))
144                                                  (setf reference-snap snap-to))
145                                                 ((> 0 rotations)
146                                                  (dotimes (i (abs rotations))
147                                                    (turnfacecounterclockwise *cube* (turning-face *cube*)))
148                                                  (setf reference-snap snap-to))))
149                                         ;; determine where face will be drawn
150                                         (setf (face-theta *cube*) 0.0))
151                                        (t ; no snap
152                                         (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap))))
153                                        )))
154                              (#/setNeedsDisplay: self t))
155                             (t
156                              (setf (face-turning-p *cube*) nil
157                                    (turning-face *cube*) nil
158                                    (face-theta *cube*) nil
159                                    dragging-p nil))))))
160             (#/setNeedsDisplay: self t)))
161         )))
162
163(objc:defmethod (#/rightMouseDown: :void) ((self rubix-opengl-view) the-event)
164  ;; this makes dragging left/right turn a face counterclockwise/clockwise
165  ;; ... clicked-on face determines face turned
166  ;; ... with an n-degree "snap"
167  ;; ... with the snap updating the data structure
168  ;; ... releasing the mouse clears rotation angle (face will snap to last position)
169  (let* ((first-loc (#/locationInWindow the-event))
170         (pick-loc (#/convertPoint:fromView: self first-loc +null-ptr+)))
171    (let ((dragging-p t)
172          (reference-snap 0))
173      (setf (turning-face *cube*) (render-for-selection
174                                   *cube*
175                                   (opengl:unproject (pref pick-loc :<NSP>oint.x)
176                                                     (pref pick-loc :<NSP>oint.y)))
177            (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t)
178            (face-theta *cube*) 0.0)
179      (loop while (and dragging-p (face-turning-p *cube*)) do
180            (let ((the-event (#/nextEventMatchingMask:
181                              (#/window self)
182                              (logior #$NSRightMouseUpMask
183                                      #$NSRightMouseDraggedMask))))
184              (let ((mouse-loc (#/locationInWindow the-event)))
185                (cond ((eq #$NSRightMouseDragged (#/type the-event))
186                       (let ((deltax (float
187                                      (- (pref mouse-loc :<NSP>oint.x)
188                                         (pref first-loc :<NSP>oint.x))
189                                      0.0f0)))
190                         (multiple-value-bind (snap-to snap-dist) (round deltax 90.0)
191                           (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap
192                                  ;; update cube structure
193                                  (let ((rotations (- snap-to reference-snap)))
194                                    (cond ((zerop rotations) nil)
195                                          ((< 0 rotations)
196                                           (dotimes (i rotations)
197                                             (turnfaceclockwise *cube* (turning-face *cube*)))
198                                           (setf reference-snap snap-to))
199                                          ((> 0 rotations)
200                                           (dotimes (i (abs rotations))
201                                             (turnfacecounterclockwise *cube* (turning-face *cube*)))
202                                           (setf reference-snap snap-to))))
203                                  ;; determine where face will be drawn
204                                  (setf (face-theta *cube*) 0.0))
205                                 (t     ; no snap
206                                  (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap))))
207                                 )))
208                       (#/setNeedsDisplay: self t))
209                      (t
210                       (setf (face-turning-p *cube*) nil
211                             (turning-face *cube*) nil
212                             (face-theta *cube*) nil
213                             dragging-p nil))))))
214      (#/setNeedsDisplay: self t))))
215
216(defclass rubix-window (ns:ns-window)
217  ()
218  (:metaclass ns:+ns-object))
219
220(defparameter *aluminum-margin* 5.0f0)
221
222(defun run-rubix-demo ()
223  (let* ((w (ccl::new-cocoa-window :class (find-class 'rubix-window)
224                                   :title "Rubix Cube"
225                                   :height 250
226                                   :width 250
227                                   :expandable nil))
228         (w-content-view (#/contentView w)))
229    (let ((w-frame (#/frame w-content-view)))
230      (ns:with-ns-rect (glview-rect *aluminum-margin*
231                                    *aluminum-margin*
232                                    (- (pref w-frame :<NSR>ect.size.width)
233                                       (* 2 *aluminum-margin*))
234                                    (- (pref w-frame :<NSR>ect.size.height)
235                                       *aluminum-margin*))
236        ;; Q: why make-objc-instance here?
237        (let ((glview (make-instance 'rubix-opengl-view
238                            :with-frame glview-rect
239                            :pixel-format #+ignore
240                                          (#/defaultPixelFormat nsLns-opengl-view)
241                                          (opengl:new-pixel-format ;#$NSOpenGLPFADoubleBuffer
242                                                                   #$NSOpenGLPFAAccelerated
243                                                                   #$NSOpenGLPFAColorSize 32
244                                                                   #$NSOpenGLPFADepthSize 32))))
245          (#/addSubview: w-content-view glview)
246          w)))))
Note: See TracBrowser for help on using the repository browser.