[cello-cvs] CVS cello

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) ,@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))))))