Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv29619

Modified Files: CELTK.lpr composites.lisp keysym.lisp run.lisp tk-object.lisp togl.lisp Log Message: Sorting out some confusion after commititng from wrong directory (but a recent backup of the real deal so not too bad). But folks might want to rebuild and test to see if anything got messed up.

--- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/17 20:33:57 1.24 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/23 23:47:42 1.25 @@ -114,7 +114,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::test-andy-expander + :on-initialization 'celtk::tk-test :on-restart 'do-default-restart)

;; End of Project Definition --- /project/cells/cvsroot/Celtk/composites.lisp 2008/03/17 20:33:57 1.26 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/03/23 23:47:42 1.27 @@ -117,7 +117,7 @@

(defun app-idle (self) (loop for w in (^kids) - do (when (not (eq :arrow (cursor w))) + do (when (eq :watch (cursor w)) (setf (cursor w) :arrow))) (setf (^app-time) (now)) (loop for task in *app-idle-tasks* @@ -139,18 +139,20 @@ start-up-fn close-fn initial-focus - (focus-state (c-in nil) :documentation "This is about the window having the focus on the desktop, not the key focus. + (focus-state (c-in nil) + :documentation "This is about the window having the focus on the desktop, not the key focus. Actually holds last event code, :focusin or :focusout") on-key-down on-key-up :width (c?n 800) :height (c?n 600))

-(defobserver focus-state ((self window)) - (trc "focus-state" self new-value :old old-value)) +;;;(defobserver focus-state ((self window)) +;;; (trc "focus-state" self new-value :old old-value))

(defmethod (setf cursor) :after (new-value (self window)) (when new-value + (trc nil "configure cursor" self new-value) (tk-format-now ". configure -cursor ~a" (string-downcase (symbol-name new-value)))))

(export! .control-key-p .alt-key-p .shift-key-p focus-state ^focus-state) --- /project/cells/cvsroot/Celtk/keysym.lisp 2008/01/03 20:23:30 1.1 +++ /project/cells/cvsroot/Celtk/keysym.lisp 2008/03/23 23:47:42 1.2 @@ -951,6 +951,85 @@ ;;; (at . #@) ;;; (tab . #\tab)))

+(export! *cursors*) +(defparameter *cursors* + (apply 'vector '(X_cursor + arrow + based_arrow_down + based_arrow_up + boat + bogosity + bottom_left_corner + bottom_right_corner + bottom_side + bottom_tee + box_spiral + center_ptr + circle + clock + coffee_mug + cross + cross_reverse + crosshair + diamond_cross + dot + dotbox + double_arrow + draft_large + draft_small + draped_box + exchange + fleur + gobbler + gumby + hand1 + hand2 + heart + icon + iron_cross + left_ptr + left_side + left_tee + leftbutton + ll_angle + lr_angle + man + middlebutton + mouse + pencil + pirate + plus + question_arrow + right_ptr + right_side + right_tee + rightbutton + rtl_logo + sailboat + sb_down_arrow + sb_h_double_arrow + sb_left_arrow + sb_right_arrow + sb_up_arrow + sb_v_double_arrow + shuttle + sizing + spider + spraycan + star + target + tcross + top_left_arrow + top_left_corner + top_right_corner + top_side + top_tee + trek + ul_angle + umbrella + ur_angle + watch + xterm))) (export! keysym-char keysym-sym minus period asciicircum plus backspace delete bar parenleft parenright bracketleft bracketright braceleft braceright less greater --- /project/cells/cvsroot/Celtk/run.lisp 2008/03/17 20:33:57 1.27 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/03/23 23:47:42 1.28 @@ -18,8 +18,6 @@

(in-package :Celtk)

- - ;;; --- running a Celtk (window class, actually) --------------------------------------

(eval-now! @@ -45,13 +43,6 @@ #-unix ;;(tk-format-now "package require QuickTimeTcl") (tk-format-now "snack::sound s") -;;; (tk-format-now (conc$ "snack::sound s -load " -;;; (snackify-pathname (make-pathname :directory '(:absolute "sounds") -;;; :name "ahem_x" :type "wav") -;;; #+vs (car (directory (make-pathname :directory '(:absolute "sounds"))))))) -;;; (tk-format-now "s play -blocking yes") -;;; (sleep 2) -;;; (tk-format-now "s play")

(tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))

--- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 11:52:56 1.15 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 23:47:42 1.16 @@ -50,34 +50,30 @@

;;; --- deftk --------------------

-(defmacro deftk (class superclasses - (&rest std-slots) - &rest defclass-options) +(defmacro deftk (class superclasses (&rest std-slots) &rest defclass-options) (destructuring-bind (&optional tk-class &rest tk-options) (cdr (find :tk-spec defclass-options :key 'car))

(setf tk-options (tk-options-normalize tk-options))

`(eval-now! - (defmodel ,class ,(or superclasses '(tk-object)) - (,@(append std-slots (loop for (slot-name nil) in tk-options - collecting `(,slot-name :initform nil - :initarg ,(intern (string slot-name) :keyword) - :accessor ,slot-name)))) - ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) - (:default-initargs - ,@(when tk-class `(:tk-class ',tk-class)) - ,@(cdr (find :default-initargs defclass-options :key 'car)))) - (defmethod tk-class-options append ((self ,class)) - ',tk-options) - (export ',class) - (export ',(loop for (slot nil) in tk-options - nconcing (list slot (intern (conc$ "^" slot))))) - (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) - `(make-instance ',',class - :fm-parent *parent* - ,@inits)) - (export ',(intern (conc$ "MK-" (symbol-name class))))))) + (defmodel ,class ,(or superclasses '(tk-object)) + (,@(append std-slots (loop for (slot-name nil) in tk-options + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name)))) + ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) + (:default-initargs + ,@(when tk-class `(:tk-class ',tk-class)) + ,@(cdr (find :default-initargs defclass-options :key 'car)))) + (defmethod tk-class-options append ((self ,class)) + ',tk-options) + (export ',(loop for (slot nil) in tk-options + nconcing (list slot (intern (conc$ "^" slot))))) + (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) + `(make-instance ',',class + :fm-parent *parent* + ,@inits)))))

(defun tk-options-normalize (tk-options) "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))" --- /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 17:07:59 1.29 +++ /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 23:47:42 1.30 @@ -191,6 +191,8 @@ (call-next-method))) (defmethod ,(intern uc$) ((self togl))))))

+ + (def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" togl-ptr ) ;; @@ -199,8 +201,13 @@ ;;(eval-when (:compile-toplevel :execute) ;; (if (member :cello cl-user::*features*) ;; (progn - (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready - (kt-opengl:kt-opengl-reset) + + (when (find-package "CL-FTGL") + (set (find-symbol "*FTGL-OGL*" "CL-FTGL") togl-ptr)) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready + + (when (find-package "KT-OPENGL") + (funcall (symbol-function (find-symbol "KT-OPENGL-RESET" "CL-FTGL")))) + ;;; ^^^^^ above two needed only for cello ^^^^^^ ;;; (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred