[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sun Mar 23 23:47:43 UTC 2008
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*
- , at 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*
+ , at 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
More information about the Cells-cvs
mailing list