/[cello]/cello/ix-togl.lisp
ViewVC logotype

Contents of /cello/ix-togl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Mon Jun 16 12:39:21 2008 UTC (5 years, 10 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.18: +33 -24 lines
nothing special
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 (eval-now!
20 (export '(ix-togl-event-handler)))
21
22 ;------------- Window ---------------
23 ;
24
25 (export! mouse-view-tracker mouse-view ^mouse-view mouse-pos ^mouse-pos
26 mouse-control ^mouse-control mouse-down-evt ^mouse-down-evt
27 mouse-still ^mouse-still)
28
29 (defmd mouse-view-tracker ()
30 (mouse-view :initarg :mouse-view :accessor mouse-view
31 :initform (c? (let ((pos (mouse-pos .og.)))
32 (trc nil "mouseview sees pos" .w. pos)
33 (when pos
34 (eko (nil "ix-togl mouseview >" self)
35 (without-c-dependency
36 (find-ix-under self pos)))))))
37 (:documentation "Mixin to have mouse view tracked in a subtree of the window, mostly so other GUI layout can depend on
38 the sub-tree layout without creating a cyclic dependency, as would happen iof the whole window were watched."))
39
40 (defmd ix-togl (mouse-view-tracker #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view)
41 (redisplayp nil :cell nil)
42 display-continuous
43 (frame-ct :initarg :frame-ct :initform (c-in 0) :accessor frame-ct)
44 activep
45 (mouse-pos :initform (c-in nil)) ;logical coords. Try to maintain for now.
46 (mouse-still (let (last-pos last-pos-time)
47 (c? (bwhen (mp (^mouse-pos))
48 (if (and last-pos (v2= mp last-pos))
49 (- .time last-pos-time)
50 (progn
51 (setf last-pos mp last-pos-time .time)
52 0))))))
53
54 (mouse-control (c? (bwhen (node (^mouse-view))
55 (eko (nil "possible mousecontrol" node)
56 (fm-ascendant-if node #'fully-enabled)))))
57
58 (mouse-up-evt (c-in nil) :cell :ephemeral)
59 (mouse-down-evt (c-in nil) :cell :ephemeral)
60 (double-click-evt (c-in nil) :cell :ephemeral)
61
62 (tick-count (c-in nil))
63 (tick-fine (c-in nil))
64 :px 0 :py 0
65 :gl-name (c-in nil)
66 :activep (c-in nil)
67 :clear-rgba (list 0 0 0 1)
68
69 :ll 0 :lt 0
70 :lr (c-in (scr2log 1400))
71 :lb (c-in (scr2log -800))
72 :tick-count (c-in (os-tickcount))
73 :clipped t
74 :event-handler 'ix-togl-event-handler
75 :cb-destroy (lambda (self)
76 ;(trc "IX-TOGL being destoyed!!!!!!!!!!" self)
77 (setf (togl-ptr self) nil) ;; new 2007-04-13 to avoid togl.c line 1039 crash closing window
78 ;; bad idea to do it this way, gotta get *istack* bound first: (setf cells::*c-debug* t)
79 ))
80
81 (defmethod ctk::do-on-double-click-1 :before ((self ix-togl) &rest args)
82 (trc "IX-togl do-on-double-click-1 before" self (mouse-control self))
83 (bif (mi (mouse-control self))
84 (do-double-click mi )
85 (do-double-click self )))
86
87 ;;;(defobserver mouse-pos ((self ix-togl))
88 ;;; #+nah (when new-value
89 ;;; (let ((x (min (floor (v2-h new-value) 10)
90 ;;; (1- (length *cursors*)))))
91 ;;; (trc "new cursor" x (aref *cursors* x))
92 ;;; (setf (cursor .tkw)
93 ;;; (aref *cursors* x)))))
94
95 (defmethod ctk::togl-display-using-class :around ((self ix-togl))
96 (if (not (togl-ptr self))
97 (print :not-togl-displaying!!)
98 (call-next-method)))
99
100 (defmethod focus ((self ix-togl)) .focus) ;; 2007-04 ugliness occasioned by ix-togl pretending to be window incompletely (not a focuser as you see above)
101
102 (defmethod ctk::togl-create-using-class :around ((self ix-togl))
103 (setf cl-ftgl:*ftgl-ogl* (togl-ptr self)) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
104 (kt-opengl:kt-opengl-reset)
105 (call-next-method))
106
107 (defmethod ctk::togl-display-using-class ((self ix-togl))
108 (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox
109 (c-stopped))
110 (with-metrics (nil nil "ctk::togl-display-using-class")
111 (bif (dl (dsp-list self))
112 (progn
113 (trc "togl display using disp list !!!!" self)
114 (gl-call-list (dsp-list self)))
115 (ix-paint self)))))
116
117 (defmethod ctk::togl-timer-using-class ((self ix-togl))
118 (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox
119 (c-stopped))
120 (with-metrics (nil nil "ctk::ctk::togl-timer-using-class")
121 (when (display-continuous self)
122 (trc nil "window-display > continuous specified so posting redisplay" self)
123 .retog.))))
124
125
126
127 (defmethod ix-togl-event-handler (self xe)
128 "Tk does not go inside Togl OpenGL-land, so Cello Classic effectively begins here"
129 (TRC nil "ix-togl-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) )
130 (case (ctk::tk-event-type (ctk::xsv type xe))
131 (:virtualevent )
132 (:KeyPress )
133 (:KeyRelease )
134 (:ButtonPress
135 (case (xbe-button xe)
136 (1 (setf (mouse-pos self) (mkv2 (xbe-x xe)
137 (- (xbe-y xe)))) ; trigger mouseview recalc
138 (setf (mouse-down-evt self) (eko (nil "mousedown!!!" (ctk::xbe button xe))
139 (make-os-event
140 :modifiers (keyboard-modifiers .tkw)
141 :where (mouse-pos self)
142 :realtime (now)
143 :c-event xe))))
144 (3 (when (^mouse-view)
145 (inspect (^mouse-view))))))
146
147 (:ButtonRelease
148 (case (xbe-button xe)
149 (1 (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe)
150 (- (ctk::xbe-y xe)))) ; trigger mouseview recalc
151 (with-metrics (nil nil "mouse up evt")
152 (setf (mouse-up-evt self) (eko (nil "mouse up!!!")
153 (make-os-event
154 :modifiers (keyboard-modifiers .tkw)
155 :where (mouse-pos self)
156 :realtime (now)
157 :c-event xe)))))))
158
159 (:MotionNotify
160 (trc nil "setting mouse pos!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe)))
161 (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe)
162 (- (ctk::xbe-y xe)))))
163 (:EnterNotify )
164 (:LeaveNotify )
165 (:FocusIn )
166 (:FocusOut )
167 (:KeymapNotify )
168 (:Expose )
169 (:GraphicsExpose )
170 (:NoExpose )
171 (:VisibilityNotify )
172 (:CreateNotify )
173 (:DestroyNotify )
174 (:UnmapNotify )
175 (:MapNotify )
176 (:MapRequest )
177 (:ReparentNotify )
178 (:ConfigureNotify )
179 (:ConfigureRequest )
180 (:GravityNotify )
181 (:ResizeRequest )
182 (:CirculateNotify )
183 (:CirculateRequest )
184 (:PropertyNotify )
185 (:SelectionClear )
186 (:SelectionRequest )
187 (:SelectionNotify )
188 (:ColormapNotify )
189 (:ClientMessage )
190 (:MappingNotify )
191 (:ActivateNotify )
192 (:DeactivateNotify )
193 (:MouseWheelEvent)))
194
195 (defobserver lights ()
196 (dolist (light new-value)
197 (md-awaken light)))
198
199 (defmethod ogl-node-window ((self ix-togl))
200 self)
201
202 (defmethod ogl-shared-resource-tender ((self ix-togl))
203 self)
204
205 (defmethod ctl-notify-mouse-click ((self ix-togl) clickee click)
206 (declare (ignore clickee click))
207 t)
208
209 (defmethod ctl-notify-keydown ((self ix-togl) target key-char event)
210 (declare (ignore target event key-char))
211 t)
212
213 (defun buttons-shifted (buttons)
214 #+glut (logtest buttons glut_active_shift)
215 (find :shift-key buttons))
216
217 (defun shift-key-down (buttons)
218 #+glut (logtest buttons glut_active_shift)
219 (find :shift-key buttons))
220
221 (defun control-key-down (buttons)
222 #+glut (logtest buttons glut_active_ctrl)
223 (find :control-key buttons))
224
225 (defun alt-key-down (buttons)
226 #+glut (logtest buttons glut_active_alt)
227 (find :alt-key buttons))
228
229 (defun control-shift-key-down (buttons)
230 (and (shift-key-down buttons)
231 (control-key-down buttons)))
232
233 (defun shift-key-only? (buttons)
234 #+glut (eql glut_active_shift buttons)
235 (equal '(:shift-key) buttons))
236
237 ;------------------------------------------
238
239 (defun v2-log-to-scr (xy)
240 (mkv2 (log2scr (v2-h xy)) (log2scr (v2-v xy))))
241
242 (defobserver mouse-view ()
243 (when old-value
244 (with-integrity (:change 'mview-lost)
245 (trc nil "mouseover lost by" old-value (.window-cache old-value))
246 (setf (mouse-over? old-value) nil)))
247 (when new-value
248 (with-integrity (:change 'mview-gained)
249 (trc nil "mouseover gained by" new-value (.window-cache new-value))
250 (setf (mouse-over? new-value) t)))
251 (with-cc :mouse-view-set-cursor
252 (setf (cursor .tkw)
253 (or (when new-value
254 (cdr (assoc :over (cursors new-value))))
255 :arrow))))
256
257 (defobserver mouse-down-evt (self m-down)
258 .retog.
259 (when m-down
260 #+x (trcx mousedown self m-down (mouse-control self))
261 (bwhen (clickee (mouse-control self))
262 (trc nil "mousedown clickee, clickw" clickee self)
263 (mk-part :click (mouse-click) ;; wow, a free-floating part
264 :click-window self
265 :clickee clickee
266 :os-event m-down
267 :clickee-pxy (mkv2 (px (ct-proxy clickee)) (py (ct-proxy clickee)))))))
268
269 (defobserver mouse-up-evt (self up)
270 .retog.
271 (when up ;; should be since this is ephemeral, but still..
272 (trc nil "mouseup" self up (mouse-control self))
273 (bwhen (clickee (mouse-control self))
274 (bwhen (upper (mouse-up-handler clickee))
275 (trc nil "mouseup clickee, clickw" clickee self)
276 (funcall upper clickee up)))))
277
278 (defparameter *gw* nil)
279 (defparameter *mgw-near* 1500)
280 (defparameter *mgw-far* -1500)
281
282 (defmethod ctk:togl-create-using-class ((self ix-togl))
283 (setf (gl-name self) (gl-gen-lists 1))
284 (cello-gl-init)
285 (gl-disable gl_texture_2d)
286 (gl-shade-model gl_smooth) ;; Enable Smooth Shading
287 (gl-clear-depth 1.0f0) ;; Depth Buffer Setup
288 (gl-enable gl_depth_test) ;; Enables Depth Testing
289 (gl-depth-func gl_lequal) ;; The Type Of Depth Testing To Do
290 (gl-hint gl_perspective_correction_hint gl_nicest))
291
292 (defun cello-gl-init ()
293 (trc nil "clearing gl errors....")
294 (loop for ct upfrom 0
295 until (zerop (eko (nil "cleared gl errorr")
296 (glGetError)))
297 when (> ct 10)
298 do #-lispworks (c-break "gl-init")
299 #+lispworks (return-from cello-gl-init))
300
301 #+shhh (macrolet ((glm (param num)
302 (declare (ignore num))
303 `(trc ,(symbol-name param) (ogl-get-int ,param))))
304 (glm gl_max_list_nesting 0)
305 (glm gl_max_eval_order #X0000)
306 (glm gl_max_lights #x3377 )
307 (glm gl_max_clip_planes #x3378 )
308 (glm gl_max_texture_size #x3379 )
309 (glm gl_max_pixel_map_table #x3380 )
310 (glm gl_max_attrib_stack_depth #x3381 )
311 (glm gl_max_model-view_stack_depth #x3382 )
312 (glm gl_max_name_stack_depth #x3383 )
313 (glm gl_max_projection_stack_depth #x3384 )
314 (glm gl_max_texture_stack_depth #x3385 )
315 (glm gl_max_viewport_dims #x3386 )))
316
317 (defmethod ix-selectable ((self ix-togl)) t)
318
319 (defmethod togl-reshape-using-class ((self ix-togl) &aux (width (ctk::togl-width (ctk::togl-ptr self)))
320 (height (ctk::togl-height (ctk::togl-ptr self))))
321 (let ((ctk::*tki* (ctk::togl-interp (ctk::togl-ptr self))))
322 (trc "mg-window-reshape" self width height)
323 (gl-viewport 0 0 width height)
324
325 (gl-matrix-mode gl_projection)
326 (gl-load-identity)
327
328 (trc "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*)
329 (gl-ortho 0 width (- height) 0 *mgw-near* *mgw-far*)
330 (trc nil "mg-window-reshape > new window wid,hei:" self width height)
331
332 ;;; (gl-load-identity)
333 (setf (lr self) (+ (ll self) (scr2log width)))
334 (setf (lb self) (- (lt self) (scr2log height)))))
335
336 (defun run-cello-window (new-window-class &optional run-init-func)
337 (assert (symbolp new-window-class))
338 (when run-init-func
339 (funcall run-init-func))
340 (ctk::run-window new-window-class))
341
342
343 #+save
344 (defmethod ix-paint :around ((self ix-togl))
345 (flet ((projection ()
346 (gl-matrix-mode gl_projection)
347 (gl-load-identity)
348 (trc nil "paint> win ortho! l r b t n f:"
349 (ll self)(lr self)
350 (lb self)(lt self)
351 *mgw-near* *mgw-far*)
352 (gl-ortho (ll self)
353 (lr self) (lb self)
354 (lt self)
355 *mgw-near*
356 *mgw-far*
357 )))
358 (projection)
359 (gl-matrix-mode gl_modelview)
360 (gl-load-identity)
361 (gl-light-modeli gl_light_model_two_side 0)
362
363 (with-bitmap-shifted (0 (ups (l-height self)))
364 (trc nil "with initial window shift, rasterpos now" (ogl-raster-pos-get))
365 (when (clear-rgba self)
366 (apply #'gl-clear-color (clear-rgba self)))
367
368 (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit))
369 (with-metrics (nil nil "ix-paint window call next")
370 (call-next-method)))))
371
372 (defun w-quadric-ensure (ogl-resource-tender key)
373 (or (cdr (assoc key (quadrics ogl-resource-tender)))
374 (cdar (push (cons key (glu-new-quadric))
375 (quadrics ogl-resource-tender)))))

  ViewVC Help
Powered by ViewVC 1.1.5