[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Wed Mar 22 18:50:08 UTC 2006
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))
-
More information about the Cells-cvs
mailing list