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

Modified Files: Celtk.lisp demos.lisp load.lisp ltk-kt.lisp ltktest-cells-inside.lisp menu.lisp tk-format.lisp Log Message: Finishing touches getting ltktest demo fully equivalent to original pure LTk version. Added auto-bind of menu accelerator, and improved the hack to get the OK button working sensibly.

--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 18:50:08 1.3 @@ -45,7 +45,7 @@ #:mk-scrolled-list #:listbox-item #:mk-spinbox #:mk-scroller #:mk-menu-entry-cascade-ex #:with-ltk #:tk-format #:send-wish #:value #:.tkw - #:tk-user-queue-handler #:timer)) + #:tk-user-queue-handler #:timer #:make-timer-steps))

(defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -64,6 +64,8 @@

;;; --- timers ----------------------------------------

+(defstruct timer-steps count) + (defmodel timer () ((id :initarg :id :accessor id :initform (c? (bwhen (spawn (^spawn)) @@ -87,6 +89,8 @@ (when (or (zerop (^executions)) (^completed)) (typecase repeat + (timer-steps (when (< (^executions)(timer-steps-count (^repeat))) + (spawn-delayed (^delay)))) (number (when (< (^executions)(^repeat)) (spawn-delayed (^delay)))) (cons (bwhen (delay (nth (^executions) (^repeat))) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 18:50:08 1.3 @@ -23,25 +23,23 @@

(in-package :celtk-user)

-(defun ctk::tk-test () - (cells-reset 'tk-user-queue-handler) +(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (tk-test-class 'ltktest-cells-inside))

-(defparameter *tktest* nil) - (defun tk-test-class (root-class) + (cells-reset 'tk-user-queue-handler) (with-ltk (:debug 0) (send-wish "proc trc2 {cb n1 n2 op} {puts "(:callback \"$cb\" :name1 $n1 :name2 \"$n2\" :op $op)"}") (setf ltk:*debug-tk* nil) (with-integrity () - (time (setf *tktest* (make-instance root-class)))) + (make-instance root-class)) (tk-format `(:fini) "wm deiconify .")))

-(defun tk-test-all ()(tk-test-class 'a-few)) +(defun tk-test-all ()(tk-test-class 'lotsa-widgets)) (defun mk-font-view () (make-instance 'font-view))

-(defmodel a-few (window) +(defmodel lotsa-widgets (window) () (:default-initargs :kids (c? (the-kids @@ -56,7 +54,7 @@ :width 300 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))

- ;;(assorted-canvas-items) + (assorted-canvas-items)

(mk-stack () (mk-text-widget @@ -67,7 +65,7 @@

(spin-package-with-symbols))

- #+nahh (mk-stack () + (mk-stack () (mk-row (:id :radio-ny :selection (c-in 'yes)) (mk-radiobutton-ex ("yes" 'yes)) (mk-radiobutton-ex ("no" 'no)) @@ -79,7 +77,7 @@ (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked")))) (mk-row () (mk-button-ex ("Time now?" (setf (fm!v :push-time) - (get-universal-time)))) + (get-universal-time)))) (mk-label :text (c? (time-of-day (^md-value))) :id :push-time :md-value (c-in (get-universal-time)))) @@ -93,7 +91,7 @@ :id :enter-me) (mk-label :text (c? (conc$ "echo " (fm^v :enter-me))))))

- #+nahh (duelling-scrolled-lists) + (duelling-scrolled-lists) )))))

(defun style-by-edit-menu () --- /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 18:50:08 1.3 @@ -1,13 +1,15 @@ #+eval-this-if-you-do-not-autoload-asdf -(load (make-pathname :device "c" +(load (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" :type "lisp"))

-(push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "0dev" "cells")) asdf:*central-registry*)

-(push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk")) +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "0dev" "Celtk")) asdf:*central-registry*)

#-runtestsuite @@ -22,3 +24,5 @@ #+testceltk (ctk::tk-test)

+#+ortestceltk +(celtk-user::tk-test-class 'celtk-user::lotsa-widgets) \ No newline at end of file --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 18:50:08 1.3 @@ -357,6 +357,7 @@ (defparameter *ewish* nil)

(defun do-execute (program args &optional (wt nil)) + (declare (ignorable wt)) "execute program with args " #+:clisp (declare (ignore wt)) (let ((fullstring program)) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 1.1 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 18:50:08 1.2 @@ -17,18 +17,15 @@ (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") (mk-button-ex ("Start" (setf (repeat (fm^ :moire-1)) t))) - (mk-button-ex ("Stop" (progn (trc "killing running!!!!!!!!!!") - (setf (repeat (fm^ :moire-1)) nil))))) - (mk-button-ex ("Hallo" (format T "Hallo~%"))) - (mk-button-ex ("Welt!" (format T "Welt~%"))) + (mk-button-ex ("Stop" (setf (repeat (fm^ :moire-1)) nil)))) + (mk-button-ex ("Hallo" (format T "~&Hallo"))) + (mk-button-ex ("Welt!" (format T "~&Welt"))) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") - (mk-button-ex ("OK:" (progn ;; I do not like this - (setf (repeat (fm^ :moire-1)) 0) - (setf (repeat (fm^ :moire-1)) 20))))) + (mk-button-ex ("OK:" (setf (repeat (fm^ :moire-1)) (make-timer-steps :count 20))))) (mk-entry :id :entry) - (mk-button-ex ("get!" (format t "~&content of entry: ~A~%" (fm^v :entry)))) + (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry)))) (mk-button-ex ("set!" (setf (fm^v :entry) "test of set"))))))))

(defmodel ltk-test-canvas (canvas) @@ -70,7 +67,7 @@ :timers (c? (when (^repeat) (list (make-instance 'timer :tag :moire - :delay 25 + :delay 1 :repeat (let ((m self)) (c? (repeat m))) :action (lambda (timer) @@ -92,23 +89,24 @@ (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command :label "Load" :command (c? (tk-callback .tkw 'load - (lambda () (format t "~&Load pressed~&"))))) + (lambda () (format t "~&Load pressed")))))

(mk-menu-entry-command :label "Save" :command (c? (tk-callback .tkw 'save - (lambda () (format t "Save pressed~&"))))) + (lambda () (format t "~&Save pressed"))))) (mk-menu-entry-separator) (mk-menu-entry-cascade-ex (:id :export :label "Export...") (mk-menu-entry-command :label "jpeg" :command (c? (tk-callback .tkw 'jpeg - (lambda () (format t "Jpeg pressed~&"))))) + (lambda () (format t "~&Jpeg pressed"))))) (mk-menu-entry-command :label "png" :command (c? (tk-callback .tkw 'png - (lambda () (format t "Png pressed~&")))))) + (lambda () (format t "~&Png pressed")))))) (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :accelerator "Alt Q" + :accelerator "<Alt-q>" + :underline 1 :command "exit"))))))

--- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 18:50:08 1.3 @@ -136,6 +136,13 @@ -compound -font -foreground -hidemargin -image -label -state -underline))

+(defobserver accelerator :around ((self menu-entry-usable)) + (call-next-method) + (with-integrity (:client '(:bind nil)) + (when new-value + (tk-format-now "bind . ~a {~a invoke ~a}" new-value (path (upper self menu)) (index self))))) + + (deftk menu-entry-cascade (selector family menu-entry-usable) () (:tk-spec cascade --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 18:50:08 1.3 @@ -60,12 +60,14 @@ ; ; --- pure debug stuff --- ; - (let ((yes '( "scroll")) ;; '("scroll" "pkg-sym")) + (let ((yes '( "bind" "invoke")) ;; '("scroll" "pkg-sym")) (no '())) (declare (ignorable yes no)) - (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (bwhen (st (search ""Alt Q"" tk$)) + (replace tk$ "{Alt Q}" :start1 st)) + (when (and (find-if (lambda (s) (search s tk$)) yes) (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk[~a] ~a> ~A~%" dbg #+nah cells::*data-pulse-id* defer-info tk$) + (format t "~&tk> ~A~%" #+nah cells::*data-pulse-id* tk$) #+nah (unless (find #" tk$) (break "bad set ~a" tk$)))) (assert (wish-stream *wish*)) ;; when not?? @@ -108,4 +110,3 @@ (defmethod parent-path ((nada null)) "") (defmethod parent-path ((self t)) (^path))

-