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

Last change on this file since 13474 was 12674, checked in by gb, 10 years ago

rubix.lisp: suppress a compiler warning
loader.lisp: commented-out call needs to run on the event thread in Cocotron

(and it may be a good idea to do that in Cocoa, as well.)

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