[cello-cvs] CVS cello
ktilton
ktilton at common-lisp.net
Sat Jun 3 12:05:54 UTC 2006
Update of /project/cello/cvsroot/cello
In directory clnet:/tmp/cvs-serv8832
Modified Files:
NeHe-06.lpr application.lisp cello-ftgl.lisp cello.lisp
cello.lpr control.lisp ctl-drag.lisp ctl-markbox.lisp
ctl-selectable.lisp frame.lisp image.lisp ix-layer-expand.lisp
ix-styled.lisp ix-text.lisp mouse-click.lisp nehe-06.lisp
nehe-14x.lisp pick.lisp window-callbacks.lisp
window-utilities.lisp window.lisp wm-mouse.lisp
Log Message:
Somewhat resurrected; clean compile anyway
--- /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 1.1
+++ /project/cello/cvsroot/cello/NeHe-06.lpr 2006/06/03 12:05:54 1.2
@@ -87,7 +87,7 @@
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
- :on-initialization 'nehe-06::nehe-06
+ :on-initialization 'nehe-06::nehe-14
:on-restart 'do-default-restart)
;; End of Project Definition
--- /project/cello/cvsroot/cello/application.lisp 2006/05/17 16:14:27 1.2
+++ /project/cello/cvsroot/cello/application.lisp 2006/06/03 12:05:54 1.3
@@ -30,7 +30,7 @@
(ffx-reset)
(cells-reset 'tk-client-queue-handler)
(when system-type
- (setf *sys* (to-be (make-instance system-type :md-name 'mgsys))))
+ (setf *sys* (make-instance system-type :md-name 'mgsys)))
(values))
(defmodel mg-system (family)
@@ -48,7 +48,7 @@
(sys-time *sys*))
(defmethod initialize-instance :after ((self mg-system) &key)
- (setf (mouse self) (cells::make-be 'mouse)))
+ (setf (mouse self) (cells::make-instance 'mouse))) ;; 2006-06-01 was make-be
(defmethod sys-close (other)
(declare (ignore other)))
--- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/05/17 16:14:27 1.2
+++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/06/03 12:05:54 1.3
@@ -104,11 +104,11 @@
(run-window (make-instance 'ftgl-window)
(lambda ()
;;; -- not sure how much of this new reset stuff is necessary ---
- (cl-opengl-init)
+ (kt-opengl-init)
(cl-ftgl-reset)
(cl-ftgl-init))))))
-(defmodel ftgl-window (window)
+(defmodel ftgl-window (cello-window)
()
(:default-initargs
:idler nil
@@ -144,7 +144,7 @@
(ftgl-test)
(defun ftgl-test ()
- (setq ftgl::*ftgl-dll* nil)
+ (cl-ftgl-init)
(let ((fns (mapcar (lambda (p)
(pathname-name p))
(butlast (directory *font-directory-path*) 0)))
--- /project/cello/cvsroot/cello/cello.lisp 2006/05/26 22:08:55 1.3
+++ /project/cello/cvsroot/cello/cello.lisp 2006/06/03 12:05:54 1.4
@@ -30,11 +30,14 @@
#:utils-kt
#:cells
#:ffx
- #:cl-opengl
+ #:kt-opengl
#:cl-openal
#:cl-ftgl
- #:cl-magick
- #:celtk)
- (:shadowing-import-from #:celtk #:window))
+ #:cl-magick))
+
+;;; in step one we will just have Celtk playing the part of Freeglut
+;;;
+;;; #:celtk)
+;;; (:shadowing-import-from #:celtk #:window))
(in-package :cello)
--- /project/cello/cvsroot/cello/cello.lpr 2006/05/26 22:08:55 1.3
+++ /project/cello/cvsroot/cello/cello.lpr 2006/06/03 12:05:54 1.4
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -27,7 +27,7 @@
(make-instance 'module :name "focus-utilities.lisp")
(make-instance 'module :name "ix-styled.lisp")
(make-instance 'module :name "ix-text.lisp")
- (make-instance 'module :name "window.lisp")
+ (make-instance 'module :name "ix-togl.lisp")
(make-instance 'module :name "window-callbacks.lisp")
(make-instance 'module :name "lighting.lisp")
(make-instance 'module :name "ctl-toggle.lisp")
@@ -41,17 +41,15 @@
(make-instance 'module :name "pick.lisp")
(make-instance 'module :name "ix-render.lisp")
(make-instance 'module :name "ix-polygon.lisp")
- (make-instance 'module :name "ct-scroll-pane.lisp")
- (make-instance 'module :name "ct-scroll-bar.lisp")
(make-instance 'module :name "cello-ftgl.lisp")
(make-instance 'module :name "cello-magick.lisp")
(make-instance 'module :name "cello-openal.lisp"))
:projects (list (make-instance 'project-module :name
"..\\Celtk\\CELTK")
(make-instance 'project-module :name
- "hello-cffi\\hello-cffi")
+ "cffi-extender\\cffi-extender")
(make-instance 'project-module :name
- "cl-opengl\\cl-opengl")
+ "kt-opengl\\kt-opengl")
(make-instance 'project-module :name
"cl-magick\\cl-magick")
(make-instance 'project-module :name
--- /project/cello/cvsroot/cello/control.lisp 2006/05/17 16:14:27 1.2
+++ /project/cello/cvsroot/cello/control.lisp 2006/06/03 12:05:54 1.3
@@ -31,7 +31,7 @@
(click-repeat-p :initarg :click-repeat-p :initform nil :reader click-repeat-p)
(click-repeat-event :initarg :click-repeat-event
:accessor click-repeat-event
- :initform (c? (break "wire tk") #+not (bwhen (c (^click-evt))
+ :initform (c? (bwhen (c (^click-evt))
(let ((age (f-sensitivity :age (0.1)
(click-age c ))))
(when (> age 0.5) age)))))
@@ -58,7 +58,7 @@
(defmethod enabled (other)(assert other) nil)
-(defmethod do-keydown ((self control) k event)
+(defmethod do-cello-keydown ((self control) k event)
(declare (ignorable event))
(when (control-triggered-by self k event)
(funcall (ct-action self) self event)
@@ -66,7 +66,7 @@
; ----------------------------------------------------------
-(defmethod do-keydown :around (self key-char event)
+(defmethod do-cello-keydown :around (self key-char event)
(declare (ignorable key-char))
(typecase self
(null)
@@ -75,7 +75,7 @@
(otherwise
(when (ctl-notify-keydown .parent self key-char event)
(unless (call-next-method)
- (do-keydown .parent key-char event))))))
+ (do-cello-keydown .parent key-char event))))))
(defmethod ctl-notify-keydown (self target key-char click)
(ctl-notify-keydown (fm-parent self) target key-char click))
--- /project/cello/cvsroot/cello/ctl-drag.lisp 2006/05/17 16:14:27 1.2
+++ /project/cello/cvsroot/cello/ctl-drag.lisp 2006/06/03 12:05:54 1.3
@@ -62,13 +62,6 @@
(div-safe dv rh)))))
(trc "no dragr for ctdrag?" self new-value))))
-;;;(defmethod context-cursor ((self CTDrag) kbdModifiers)
-;;; (declare (ignore kbdmodifiers))
-;;; (ecase (dragdirection self)
-;;; (:horizontal GLUT_CURSOR_LEFT_RIGHT)
-;;; (:vertical GLUT_CURSOR_UP_DOWN)
-;;; (:horizontal-vt GLUT_CURSOR_CROSSHAIR)))
-
(defmodel ct-poly-drag (ct-drag ix-polygon)())
(defmodel tab-bar-tracker ()
--- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/05/17 16:14:27 1.2
+++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/06/03 12:05:54 1.3
@@ -64,14 +64,6 @@
(gl-vertex3f bl bb 0)(gl-vertex3f br bt 0))
(ogl::glec :f3d)))))
-;----------------------------
-
-(defmethod context-cursor ((self ct-mark-box) kbd-modifiers)
- (declare (ignore kbd-modifiers))
- (if (enabled self)
- glut_cursor_crosshair
- glut_cursor_destroy))
-
; ----- radios -------------------------------
(defmodel ct-radio-item (ct-toggle)
--- /project/cello/cvsroot/cello/ctl-selectable.lisp 2005/05/31 14:39:44 1.1
+++ /project/cello/cvsroot/cello/ctl-selectable.lisp 2006/06/03 12:05:54 1.2
@@ -78,17 +78,6 @@
(member (^md-value) (selection selector))))
:reader selectedp))
(:default-initargs
-;;; nah, no image behavior here. put in mixin if desired
-;;; :bkg-color (c? (if (^enabled)
-;;; (if (^hilited)
-;;; +blue+
-;;; (if (^selectedp)
-;;; +yellow+
-;;; +white+))
-;;; +lt-gray+))
-;;; :pre-layer (with-layers (:rgba (^bkg-color))
-;;; :fill
-;;; +black+)
:ct-action (lambda (self event
&aux
(buttons (evt-buttons event))
--- /project/cello/cvsroot/cello/frame.lisp 2005/05/31 14:39:44 1.1
+++ /project/cello/cvsroot/cello/frame.lisp 2006/06/03 12:05:54 1.2
@@ -169,6 +169,7 @@
(render)
(ogl::glec :f3d))))))))
+#|
(defclass cone3d (frame-3d)())
(defmethod ix-render-layer ((self cone3d) lbox)
@@ -194,4 +195,6 @@
(gl-translatef 0 0 1000)
(gl-scalef 1.1 1.1 1.1)
(glut-solid-sphere (* 100 r) 9 1)
- (ogl::glec :f3d)))
\ No newline at end of file
+ (ogl::glec :f3d)))
+
+|#
\ No newline at end of file
--- /project/cello/cvsroot/cello/image.lisp 2006/05/17 16:14:27 1.2
+++ /project/cello/cvsroot/cello/image.lisp 2006/06/03 12:05:54 1.3
@@ -181,14 +181,19 @@
(defmethod ogl-dsp-list-prep progn ((self wand-texture))
(texture-name self))
-
+(defmacro uskin ()
+ `(labels ((usk (self)
+ (when (typep self 'image)
+ (or (skin self)
+ (usk .parent)))))
+ (usk self)))
;------------------------------
(defobserver mouse-over-p ()
(bwhen (p .parent)
(when (typep p 'image)
- (with-deference
- (setf (mouse-over-p p) new-value)))))
+ (with-integrity(:change)
+ (setf (mouse-over-p p) new-value)))))
(defmethod ix-selectable ((self image)) nil)
--- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/06/03 12:05:54 1.3
@@ -186,6 +186,8 @@
(round (hypotenuse (r-width lbox)(r-height lbox)) 2)
slices stacks)))
+(defun hypotenuse (a b)
+ (sqrt (+ (* a a)(* b b))))
(defun ogl-vertex-normaling (e xyn x y z)
(multiple-value-bind (xn yn zn)
--- /project/cello/cvsroot/cello/ix-styled.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/ix-styled.lisp 2006/06/03 12:05:54 1.3
@@ -109,7 +109,7 @@
(ftgl-extruded
(unless (ftgl::ftgl-disp-ready-p font)
(setf (ftgl::ftgl-disp-ready-p font) t)
- (fgc-set-face-size (ftgl-ensure-ifont font)
+ (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font)
(ftgl::ftgl-size font) (ftgl::ftgl-target-res font)))
(ix-string-width self (display-text$ self))))) ;; ugh. make better. subclass must have display-text$
--- /project/cello/cvsroot/cello/ix-text.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/ix-text.lisp 2006/06/03 12:05:54 1.3
@@ -77,7 +77,7 @@
(ftgl-extruded
(unless (ftgl::ftgl-disp-ready-p font)
(setf (ftgl::ftgl-disp-ready-p font) t)
- (fgc-set-face-size (ftgl-ensure-ifont font)
+ (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font)
(ftgl::ftgl-size font) (ftgl::ftgl-target-res font)))
(ix-string-width self (^display-text$)))))
--- /project/cello/cvsroot/cello/mouse-click.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/mouse-click.lisp 2006/06/03 12:05:54 1.3
@@ -73,7 +73,7 @@
(unless (control-key-down (evt-buttons (os-event self))) ;; lame debugging enabler; make better
(focus-navigate (focus (click-window self)) (clickee self))))
- (to-be self) ;; unnecessary? 2301kt just moved this from after next line
+ ;;;20060601 (to-be self) ;; unnecessary? 2301kt just moved this from after next line
(trc nil "echo click set self clickee" self (clickee self))
(when (clickee self)
--- /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 1.1
+++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/03 12:05:54 1.2
@@ -62,7 +62,7 @@
(defmethod togl-timer-using-class ((self nehe06))
(trc nil "enter nehe-06 timer" self (togl-ptr self) (get-internal-real-time))
- (Togl_PostRedisplay (togl-ptr self))
+ (togl-post-redisplay (togl-ptr self))
(if (shoot-me self)
(unless (cl-openal::al-source-playing-p (shoot-me self))
(cl-openal::al-source-play (shoot-me self)))
@@ -70,8 +70,8 @@
(cl-openal::wav-play-start "/0dev/cello/user/sounds/spinning.wav"))))
(defmethod togl-reshape-using-class ((self nehe06))
- (let ((width (Togl_width (togl-ptr self)))
- (height (Togl_height (togl-ptr self))))
+ (let ((width (togl-width (togl-ptr self)))
+ (height (togl-height (togl-ptr self))))
(trc "enter nh6 reshape" self width height)
(unless (or (zerop width) (zerop height))
@@ -82,6 +82,7 @@
(gl-matrix-mode gl_modelview)
(gl-load-identity))))
+
(defparameter *jmc-font* (ftgl-make :texture 'sylfaen 48 96 18))
(defmethod togl-display-using-class ((self nehe06))
@@ -160,7 +161,7 @@
)
)
- (Togl_SwapBuffers (togl-ptr self))
+ (togl-swap-buffers (togl-ptr self))
#+shhh (print-frame-rate self))
(defmethod togl-create-using-class ((self nehe06))
--- /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 1.1
+++ /project/cello/cvsroot/cello/nehe-14x.lisp 2006/06/03 12:05:54 1.2
@@ -50,11 +50,11 @@
(defmethod togl-timer-using-class ((self nehe14))
(trc nil "enter nehe-14 timer" self (togl-ptr self) (get-internal-real-time))
- (Togl_PostRedisplay (togl-ptr self)))
+ (togl-post-redisplay (togl-ptr self)))
(defmethod togl-reshape-using-class ((self nehe14))
- (let ((width (Togl_width (togl-ptr self)))
- (height (Togl_height (togl-ptr self))))
+ (let ((width (togl-width (togl-ptr self)))
+ (height (togl-height (togl-ptr self))))
(trc "reshape" width height)
(unless (or (zerop width) (zerop height))
(trc "reshape" width height)
@@ -124,7 +124,7 @@
(ftgl-render (test-font :bitmap) "NeHe 14 bitmap")
(gl-pop-matrix)
- (Togl_SwapBuffers (togl-ptr self))
+ (togl-swap-buffers (togl-ptr self))
(incf g_rot 0.4f0))
--- /project/cello/cvsroot/cello/pick.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/pick.lisp 2006/06/03 12:05:54 1.3
@@ -23,7 +23,7 @@
(defun buffy (y)
(cffi:mem-aref *ix-select-buffer* 'gluint) y)
-(defun ix-select (pos tolerance &key (select :nearest) (target *tkw*))
+(defun ix-select (pos tolerance &key (select :nearest) (target ctk::*tkw*))
(declare (ignorable select pos tolerance))
(gl-get-integerv gl_viewport *ix-select-r*)
--- /project/cello/cvsroot/cello/window-callbacks.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/03 12:05:54 1.3
@@ -22,134 +22,38 @@
(in-package :cello)
-(defmacro def-window-callback (fn-name args &body body)
- `(ff-defun-callable :cdecl :void ,fn-name ,args
- (window-callback ',fn-name
- (lambda ,(mapcar 'car args) , at body)
- ,@(mapcar 'car args))))
-
-(defun window-callback (fn-name callback &rest args)
- (declare (ignorable fn-name))
- (with-metrics (nil nil "window-callback" fn-name)
- (unless (c-stopped)
- ;;
- ;; this next bit makes sense because no cell rule evaluation could
- ;; depend on something touched during a callback, but then no cell
- ;; rule should dynamically encompass a callback, so...why reset
- ;; the calculators (dependents) global? it is necessary
- ;; because, when an error occurs, error-handling can cause
- ;; re-entrance and, if a cell rule was being evaluated, suddenly
- ;; the programmer is looking at an error about "too many dependencies"
- ;; instead of the original error. there is probably a better way to handle
- ;; all this, but for now... 2003-04-05kwt
- ;;
- (let* (cells::*c-calculators*
- (*w* (mg-window-current)))
- (if *w*
- (prog2
- (setf (redisplayp *w*) nil)
- (apply callback args)
- (when (redisplayp *w*)
- (w-post-redisplay *w*)))
- (apply callback args))))))
-
-(def-window-callback mgwkey ((k :int)(x :int)(y :int))
- (trc "mgwkey" k x y (glutgetwindow))
- (bwhen (w *w*)
- (trc nil "mgwkey" k x y w)
- (let ((mods (glut-get-modifiers))
- (tgt (or (focus w) w)))
- ;;(print (list :keyboard k mods x y (code-char (logand k #xff)) (focus w)))
- (do-keydown tgt
- (code-char (logand k #xff))
- (mk-os-event mods (mkv2 x y))))))
-
-(def-window-callback mgw-special ((k :int)(x :int)(y :int))
- (trc nil "mgwspecial" k x y (glutgetwindow))
- (bwhen (w *w*)
- (trc nil "mgwspecial" k x y w)
- (let ((mods (glut-get-modifiers)))
- (do-specialkeydown (or (focus w) w)
- k
- (mk-os-event mods (mkv2 x y))))))
-
-(defmethod do-specialkeydown ((w window) k event)
- (declare (ignorable k event)))
-
-(defmethod ix-idle ((w window))
- ;(PRINT `(IDLING ,(now)))
- (setf (sys-time *sys*) (now)))
-
-(def-window-callback mg-glut-idle ()
- ;; (print 'mg-glut-idle)
- (unless (c-stopped)
- (bwhen (w (mg-window-current))
- (ix-idle w))))
+(defmethod ctk::togl-display-using-class ((self ix-togl))
+ (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox
+ (c-stopped))
+ (with-metrics (nil nil "ctk::togl-display-using-class")
+ (bif (dl (dsp-list self))
+ (progn
+ (trc nil "window using disp list")
+ (gl-call-list (dsp-list self)))
+ (ix-paint self)))
+ (incf (frame-ct self))))
-(def-window-callback mg-glut-display ()
+(defmethod ctk::togl-timer-using-class ((self ix-togl))
(unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox
- (c-stopped) (null *w*))
- (with-metrics (nil nil "mg-glut-display")
- (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow))
- (window-display *w*))))
-
-(defmethod window-display ((self window))
-
- (bif (dl (dsp-list self))
- (progn
- (trc nil "window using disp list")
- (gl-call-list (dsp-list self)))
- (ix-paint self))
-
- (glut-swap-buffers)
-
- (trc nil "window-display > rendered w " self (glutgetwindow))
- (incf (frame-ct self))
- #+(or) (when (display-continuous self)
+ (c-stopped))
+ (with-metrics (nil nil "ctk::togl-display-using-class")
+ (when (display-continuous self)
(trc nil "window-display > continuous specified so posting redisplay" self)
- (glut-post-redisplay)))
-
-
-(def-window-callback mg-glut-close ()
- (trc "bingo close ID" (glut-get-window))
- (when *w*
- ;; knowing about a window CLO has forgotten
-
- (c-assert (fm-includes *sys* *w*))
- (trc "closing ~a" *w*)
- (setf (kids *sys*) (remove *w* (kids *sys*)))
- (trc nil "closed ~a" *w*)))
-
-(def-window-callback mg-glut-reshape ((x :int)(y :int))
- (unless (or (null *w*)(zerop x) (zerop y)(self-sizing *w*))
- (trc nil "mg-glut-reshape entry" (mg-window-current t) x y)
- (mg-window-reshape *w* x y)))
-
-(defmethod do-menu-command ((w window) (cmd (eql :menu-file-close)))
- (trc "destroying window" w (glutw w))
- (glut-destroy-window (glutw w)))
-
-
+ (ctk:togl-post-redisplay (ctk:togl-ptr self))))))
-(defmethod do-keydown ((w window) k event)
- (case k
- (#\escape (if (shift-key-down (evt-buttons event))
- (break "user break on window ~a" (mg-window-current))
- (progn
- (trc "destroying window" (glutgetwindow) :out-of
- (mapcar #'glutw (kids *sys*)))
- (glut-destroy-window (glutgetwindow))
- (setf (kids *sys*) (remove w (kids *sys*))))))
- ))
+(defmethod ctk::do-on-key-down ((self ix-togl) &rest args &aux (keysym (car args)))
+ (funcall (if (schar keysym 1) 'do-cello-special-keydown 'do-cello-keydown)
+ (or (focus self) self)
+ (mk-os-event (kbd-modifiers ctk::.tkw) (mkv2 0 0))))
-(defmethod do-keydown (self k event)
+(defmethod do-cello-keydown (self k event)
(declare (ignorable self k event)))
-(defmethod do-specialkeydown :around (self k event)
+(defmethod do-cello-special-keydown :around (self k event)
(when self
(unless (call-next-method)
- (do-specialkeydown .parent k event))))
+ (do-cello-special-keydown .parent k event))))
-(defmethod do-specialkeydown (self k event)
+(defmethod do-cello-special-keydown (self k event)
(declare (ignorable self k event)))
--- /project/cello/cvsroot/cello/window-utilities.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/03 12:05:54 1.3
@@ -41,13 +41,13 @@
(print (list :pxy (cons (px i)(py i)) :lt (lt i) :lb (lb i)))
(geo-dump (fm-parent i))))
-(defmethod wm-rbuttondown ((w window) buttons mouse-pos)
+(defmethod wm-rbuttondown ((w cello-window) buttons mouse-pos)
(declare (ignorable buttons mouse-pos))
(bwhen (i (find-ix-under w mouse-pos))
(trc "mpos ix=" i)
(unless (do-right-button i buttons mouse-pos)
(cond
- ((logtest glut_active_ctrl buttons) (geo-dump i))
+ ((control-key-down buttons) (geo-dump i))
(t (print `(inspecting ,i))
;;(c-stop :inspecting)
(inspect i)))))
@@ -78,7 +78,7 @@
; --------------- geometry -------------------------------
-(defmethod g-offset ((ap window) &optional (accum-h 0) (accum-v 0))
+(defmethod g-offset ((self cello-window) &optional (accum-h 0) (accum-v 0))
(mkv2 accum-h accum-v))
(defun point-in-box (pt box)
--- /project/cello/cvsroot/cello/window.lisp 2006/05/26 22:08:55 1.3
+++ /project/cello/cvsroot/cello/window.lisp 2006/06/03 12:05:54 1.4
@@ -98,17 +98,65 @@
:tick-count (c-in (os-tickcount))
:clipped t
+ :event-handler 'cello-window-event-handler
))
+
+
+(defun cello-window-event-handler (self xe)
+ (TRC "cello-window-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) )
+ (case (ctk::tk-event-type (ctk::xsv type xe))
+ (:virtualevent )
+ (:KeyPress )
+ (:KeyRelease )
+ (:ButtonPress )
+ (:ButtonRelease )
+ (:MotionNotify )
+ (:EnterNotify )
+ (:LeaveNotify )
+ (:FocusIn )
+ (:FocusOut )
+ (:KeymapNotify )
+ (:Expose )
+ (:GraphicsExpose )
+ (:NoExpose )
+ (:VisibilityNotify )
+ (:CreateNotify )
+ (:DestroyNotify )
+ (:UnmapNotify )
+ (:MapNotify )
+ (:MapRequest )
+ (:ReparentNotify )
+ (:ConfigureNotify )
+ (:ConfigureRequest )
+ (:GravityNotify )
+ (:ResizeRequest )
+ (:CirculateNotify )
+ (:CirculateRequest )
+ (:PropertyNotify )
+ (:SelectionClear )
+ (:SelectionRequest )
+ (:SelectionNotify )
+ (:ColormapNotify )
+ (:ClientMessage )
+ (:MappingNotify )
+ (:ActivateNotify )
+ (:DeactivateNotify )
+ (:MouseWheelEvent)))
+
(defobserver lights ()
(dolist (light new-value)
(to-be light)))
-(defmethod ogl-node-window ((self window))
+(defmethod ogl-dsp-list-prep progn ((self cello-window))
+ (glutw self))
+
+(defmethod ogl-node-window ((self cello-window))
self)
-(defmethod ogl-shared-resource-tender ((self window))
+(defmethod ogl-shared-resource-tender ((self cello-window))
self)
+
(defun window-menus-basic ()
(list
(list "File"
@@ -123,22 +171,67 @@
(cons "Paste" :menu-edit-paste)
(cons "Delete" :menu-edit-delete))))
-(defmethod ctl-notify-mouse-click ((self window) clickee click)
+(defmethod ctl-notify-mouse-click ((self cello-window) clickee click)
(declare (ignore clickee click))
t)
-(defmethod ctl-notify-keydown ((self window) target key-char event)
+(defmethod ctl-notify-keydown ((self cello-window) target key-char event)
(declare (ignore target event key-char))
t)
-(defmethod set-doubleclick? ((self window) click)
+(defmethod set-doubleclick? ((self cello-window) click)
(setf (double-click? self) click))
(defmethod context-cursor (other kbd-modifiers)
(if (and other (fm-parent other))
(context-cursor (fm-parent other) kbd-modifiers)
- glut_cursor_left_arrow))
+ (cello-cursor :arrow)))
+(defun cello-cursor (cursor-id)
+ (ecase cursor-id
+ (:crosshair #+celtk 'crosshair #+glut GLUT_CURSOR_CROSSHAIR)
+ (:arrow #+celtk 'arrow #+glut GLUT_CURSOR_LEFT_ARROW)
+ (:i-beam #+celtk 'ibeam #+glut (break))
+ (:watch #+celtk 'watch #+glut (break))))
+
+
+;; tk native cursors mac and win32: watch xterm
+
+(defobserver glut-lbox ()
+ (when (self-sizing self) ;; we drive os window
+ (with-glutw (self)
+ (let ((w (log2scr (l-width self)))
+ (h (log2scr (l-height self))))
+ (gl-viewport 0 0 w h)
+ (trc "reshaping window #" self (glut-get-window) w h)
+ (glut-reshape-window w h)))))
+
+(defun buttons-shifted (buttons)
+ #+glut (logtest buttons glut_active_shift)
+ (find :shift-key buttons)
+ )
+
+(defun shift-key-down (buttons)
+ #+glut (logtest buttons glut_active_shift)
+ (find :shift-key buttons)
+ )
+
+
+(defun control-key-down (buttons)
+ #+glut (logtest buttons glut_active_ctrl)
+ (find :control-key buttons))
+
+(defun alt-key-down (buttons)
+ #+glut (logtest buttons glut_active_alt)
+ (find :alt-key buttons))
+
+(defun control-shift-key-down (buttons)
+ (and (shift-key-down buttons)
+ (control-key-down buttons)))
+
+(defun shift-key-only? (buttons)
+ #+glut (eql glut_active_shift buttons)
+ (equal '(:shift-key) buttons))
;------------------------------------------
@@ -180,6 +273,97 @@
(defparameter *mgw-near* 1500)
(defparameter *mgw-far* -1500)
+(define-symbol-macro .kg
+ (progn
+ (c-stop :user)
+ (glut-leave-main-loop)))
+
+(defmethod glutw-create ((self cello-window))
+ (when *gw* (c-break "gwcre-renetered"))
+ (let ((*gw* t))
+ #-darwin
+ (glut-set-option glut_action_on_window_close glut_action_glutmainloop_returns)
+ (glut-init-display-mode (+ glut_rgb glut_double))
+
+ (let ((glutw (bif (w (upper self cello-window))
+ (progn
+ (glut-init-window-position
+ (log2scr (v2-h (glut-xy self)))
+ (log2scr (v2-v (glut-xy self))))
+
+ (apply 'glut-init-window-size
+ (if (self-sizing self)
+ (list 100 100)
+ (list (log2scr (l-width self))
+ (log2scr (l-height self)))))
+
+ (apply #'glut-create-sub-window (glutw w)
+ (v2-h (glut-xy self)) (v2-v (glut-xy self))
+ (if (self-sizing self)
+ (list 100 100)
+ (list (log2scr (l-width self))
+ (log2scr (l-height self))))))
+ (progn
+ (if (self-sizing self)
+ (glut-init-window-size 100 100)
+ (glut-init-window-size (log2scr (l-width self))
+ (log2scr (l-height self))))
+
+ (let ((key (or (title$ self) "Untitled")))
+ (uffi:with-cstring (key-native key)
+ (glut-create-window key-native)))))))
+
+ (setf (gl-name self) glutw)
+
+ (trc nil "glutw-create setting gl-name" self :to (gl-name self) :glutw glutw
+ :glut-get-w (glut-get-window))
+
+ (cello-gl-init) ;; clear errors
+
+ #+profile (macrolet ((glm (param num)
+ (declare (ignore num))
+ `(trc ,(symbol-name param) (ogl-get-int ,param))))
+ (glm gl_max_list_nesting 0)
+ (glm gl_max_eval_order #X0000)
+ (glm gl_max_lights #x3377 )
+ (glm gl_max_clip_planes #x3378 )
+ (glm gl_max_texture_size #x3379 )
+ (glm gl_max_pixel_map_table #x3380 )
+ (glm gl_max_attrib_stack_depth #x3381 )
+ (glm gl_max_model-view_stack_depth #x3382 )
+ (glm gl_max_name_stack_depth #x3383 )
+ (glm gl_max_projection_stack_depth #x3384 )
+ (glm gl_max_texture_stack_depth #x3385 )
+ (glm gl_max_viewport_dims #x3386 )
+ )
+
+ (trc "glutw-create'd window XY" (glut-get-window) self :from (glut-xy self) :to
+ (list (glut-get glut_window_x)(glut-get glut_window_y)
+ (glut-get glut_window_width)(glut-get glut_window_height)))
+
+
+ (gl-disable +gl-texture-2d+)
+ (gl-shade-model gl_smooth) ;; Enable Smooth Shading
+ (gl-clear-depth 1.0f0) ;; Depth Buffer Setup
+ (gl-enable gl_depth_test) ;; Enables Depth Testing
+ (gl-depth-func gl_lequal) ;; The Type Of Depth Testing To Do
+ (gl-hint gl_perspective_correction_hint gl_nicest)
+
+ ;(gl-enable gl_cull_face)
+ ;(gl-cull-face gl_back)
+
+ (glut-callbacks-set
+ :idle (idler self)
+ :keyboard 'mgwkey
+ :special 'mgw-special
+ :close 'mg-glut-close
+ :display 'mg-glut-display
+ :mouse 'mg-mouse-callback
+ :passive-motion 'mg-passive-motion-callback
+ :motion 'mg-motion-callback
+ :reshape 'mg-glut-reshape)
+ (trc "just created glutw" glutw)
+ glutw)))
(defun cello-gl-init (&aux (ct 0))
(trc nil "clearing gl errors....")
@@ -190,8 +374,36 @@
#+lispworks (return-from cello-gl-init))
(trc "clearing gl error" e)))
-(defmethod ix-selectable ((self window)) t)
+(defmethod ix-selectable ((self cello-window)) t)
+(defun w-post-redisplay (self)
+ (when (slot-value self 'glutw) ;; not until ready, and use backdoor else reenter creation
+ (let ((w (glut-get-window))
+ (gw (glutw self)))
+ (trc nil "w-post-redisplay sees old w" w gw)
+ (c-assert gw)
+ (glut-set-window gw)
+ (count-it :post-redisplay)
+ (trc nil "posting redisplay" self (glutw self) :currentw w)
+ (glut-post-redisplay)
+ (c-assert w)
+ (glut-set-window w))))
+
+(defun mg-window-current (&optional must-find-p)
+ (unless (c-stopped)
+ (let ((gw (glut-get-window)))
+ (if (zerop gw)
+ (when must-find-p
+ (c-break "cannot find current window"))
+ (or (find gw (kids *sys*) :key 'glutw)
+ (catch 'mg-window-current
+ (fm-traverse *sys* (lambda (node)
+ (when (and (typep node 'window)
+ (eql gw (glutw node)))
+ (throw 'mg-window-current node)))
+ :skip-tree nil))
+ (when must-find-p
+ (c-break "no mgw matches glutw ~d" gw)))))))
(defmethod mg-window-reshape (self width height)
(trc nil "mg-window-reshape" self width height)
@@ -208,8 +420,15 @@
(setf (lr self) (+ (ll self) (scr2log width)))
(setf (lb self) (- (lt self) (scr2log height))))
+(defun run-window (new-window-class &optional run-init-func)
+ (assert (symbolp new-window))
+ (when run-init-func
+ (funcall run-init-func))
+ (ctk::run-window new-window-class))
+
+
#+save
-(defmethod ix-paint :around ((self window))
+(defmethod ix-paint :around ((self cello-window))
(flet ((projection ()
(gl-matrix-mode gl_projection)
(gl-load-identity)
--- /project/cello/cvsroot/cello/wm-mouse.lisp 2006/05/17 16:14:28 1.2
+++ /project/cello/cvsroot/cello/wm-mouse.lisp 2006/06/03 12:05:54 1.3
@@ -22,22 +22,6 @@
(in-package :cello)
-
-;-------------------- resize window ---------------------------
-;
-
-
-;;;(defparameter *resizers* nil)
-
-
-(defmethod wm-lbuttondown ((w window) buttons mouse-pos)
- (trc nil "WM_LBUTTONDOWN " buttons mouse-pos)
- (setf (mouse-pos w) mouse-pos) ; trigger mouseImage recalc
- (setf (mouse-down-evt w) (make-os-event
- :modifiers buttons
- :where mouse-pos
- :realtime (now))))
-
(defmethod do-click :around (self os-event)
(declare (ignorable os-event))
(when self
@@ -59,10 +43,6 @@
where
realtime)
-(defun now ()
- (/ (get-internal-real-time)
- internal-time-units-per-second))
-
(defun mk-os-event (modifiers where)
(make-os-event :modifiers modifiers
:where where
@@ -86,85 +66,15 @@
(declare (optimize (speed 3) (safety 0) (debug 0)))
(v2-v (evt-where os-event)))
-(defmethod wm-lbuttonup ((w window) modifiers mouse-pos)
+(defmethod wm-lbuttonup ((w cello-window) modifiers mouse-pos)
(with-metrics (nil nil "win:WM_LBUTTONUP " w modifiers mouse-pos)
- (setf (mouse-up-evt w) (make-os-event
- :modifiers modifiers
- :where mouse-pos
- :realtime (now)))))
+ (setf (mouse-up-evt w) (mk-os-event modifiers mouse-pos))))
(defparameter *mouse-move-occupado* nil
"Vestigial? Under CG/Win32 mouse move could be received during mouse move")
(defparameter *mouse-where* nil)
-(def-window-callback mg-motion-callback ((x :int)(y :int))
- (let ((w (mg-window-current t))
- (where (mkv2 (scr2log x)
- (scr2log (- y)))))
- (setf *mouse-where* where)
- (trc nil "motion callback" w x y where *mouse-move-occupado*)
- (unless (and *mouse-move-occupado*
- (mouse-pos w))
- (let ((*mouse-move-occupado* t)
- #+(or) (mtr (zerop (mod (get-internal-real-time) 10))))
- (c-assert where)
- (with-metrics (nil nil () "Setf mousepos")
- (trc nil "setting mouse pos" where (mod (get-internal-real-time)
- (* 10 internal-time-units-per-second)))
- (setf (mouse-pos w) where)
- (glutpostredisplay)
- )))))
-
-
-(def-window-callback mg-passive-motion-callback ((x :int)(y :int))
- (let ((w (mg-window-current t)))
- (let ((where (mkv2 (scr2log x)
- (scr2log (- y)))))
- (setf *mouse-where* where)
- (trc nil "passive motion callback" w x y where *mouse-move-occupado*)
- (unless (and *mouse-move-occupado*
- (mouse-pos w))
- (let ((*mouse-move-occupado* t)
- (mtr nil #+(or) (zerop (mod (get-internal-real-time) 10))))
- (declare (ignorable mtr))
- (c-assert where)
- (with-metrics (nil nil () "Setf mousepos")
- ;;(ix-select nil (mkv2 10 10))
- (setf (mouse-pos w) where)))))))
-
-
-(def-window-callback mg-mouse-callback ((button :int)(up-or-down :int)(x :int)(y :int))
- (trc nil "mouse callback entry" button up-or-down x y)
- (let ((w (mg-window-current t))
- (mp (mkv2 (scr2log x)
- (scr2log (- y))))
- (modifiers (glut-get-modifiers)))
- (trc nil "mg-mouse-callback" w button x y)
- (cond
- ((eql button glut_left_button)
- (setf (leftb (mouse *sys*)) (if (eql up-or-down glut_down) :down :up))
- (funcall (if (eql up-or-down glut_down)
- #'wm-lbuttondown #'wm-lbuttonup)
- w modifiers mp))
-
- ((eql button glut_middle_button)
- (setf (middleb (mouse *sys*)) (if (eql up-or-down glut_down) :down :up)))
-
- ((eql button glut_right_button)
- (setf (rightb (mouse *sys*)) (if (eql up-or-down glut_down) :down :up))
- (when (eql up-or-down glut_up)
- (wm-rbuttondown w modifiers mp)))
-
- ((eql button glut_mouse_wheel_click)
- (trc "mouse wheel click>" button up-or-down x y))
-
- ((eql button glut_mouse_wheel_back)
- (trc "mouse wheel back>" button up-or-down x y))
-
- ((eql button glut_mouse_wheel_fwd)
- (trc "mouse wheel>" button up-or-down x y))
- (t (trc "unhandled button" (list button up-or-down x y))))))
More information about the Cello-cvs
mailing list