[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Wed Mar 22 05:26:22 UTC 2006
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv5809
Modified Files:
CELTK.lpr Celtk.asd Celtk.lisp composites.lisp demos.lisp
load.lisp ltk-kt.lisp menu.lisp textual.lisp tk-format.lisp
widgets.lisp
Added Files:
ltktest-cells-inside.lisp
Log Message:
--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/22 05:26:21 1.2
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -6,15 +6,16 @@
(define-project :name :celtk
:modules (list (make-instance 'module :name "ltk-kt.lisp")
- (make-instance 'module :name "notes.lisp")
(make-instance 'module :name "Celtk.lisp")
(make-instance 'module :name "tk-format.lisp")
(make-instance 'module :name "menu.lisp")
- (make-instance 'module :name "composites.lisp")
(make-instance 'module :name "textual.lisp")
(make-instance 'module :name "widgets.lisp")
(make-instance 'module :name "canvas.lisp")
- (make-instance 'module :name "demos.lisp"))
+ (make-instance 'module :name "composites.lisp")
+ (make-instance 'module :name "demos.lisp")
+ (make-instance 'module :name
+ "ltktest-cells-inside.lisp"))
:projects (list (make-instance 'project-module :name
"..\\cells\\cells"))
:libraries nil
--- /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/22 05:26:21 1.2
@@ -18,8 +18,10 @@
(:file "Celtk")
(:file "tk-format")
(:file "menu")
- (:file "composites")
(:file "textual")
(:file "widgets")
(:file "canvas")
- (:file "demos")))
+ (:file "composites")
+ (:file "demos")
+ (:file "ltktest-cells-inside")))
+
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 05:26:21 1.2
@@ -24,25 +24,28 @@
(:use :common-lisp :utils-kt :cells)
(:import-from #:ltk
- #:wish-stream #:*wish* #:*ewish* "*DEBUG-TK*"
- #:peek-char-no-hang #:read-data
- #:send-wish #:tkescape
+ #:wish-stream #:*wish* #:*ewish*
+ #:peek-char-no-hang #:read-data #:event-root-x #:event-root-y
+ #:send-wish #:tkescape #:after #:after-cancel #:bind
#:with-ltk #:do-execute #:add-callback)
- (:export #:window #:panedwindow #:mk-row #:pack-self #:mk-stack #:mk-text-widget
+ (:export
+ #:pop-up #:event-root-x #:event-root-y
+ #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget
#:mk-panedwindow
#:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector
- #:mk-checkbutton #:mk-button #:mk-button-ex #:mk-entry
- #:frame-stack #:mk-frame-stack #:pack-layout? #:path
+ #:mk-checkbutton #:mk-button #:mk-button-ex #:mk-entry #:text
+ #:frame-stack #:mk-frame-stack #:path #:^path
#:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton
#:mk-menu-radio-group #:mk-menu-entry-separator
- #:mk-menu-entry-command #:tk-callback #:mk-menu #:mk-menu-entry-cascade #:mk-menubar
+ #:mk-menu-entry-command #:tk-callback #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar
#:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton
- #:mk-polygon #:mk-oval #:mk-line #:mk-arc #:mk-text-item
- #:mk-rectangle #:mk-bitmap #:mk-canvas #:mk-frame-row
+ #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-tem #:mk-text-item
+ #:rectangle #:mk-rectangle #:bitmap #:mk-bitmap #:canvas #:mk-canvas #:mk-frame-row
#: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))
+ #:tk-user-queue-handler #:timer))
(defpackage :celtk-user
(:use :common-lisp :utils-kt :cells :celtk))
@@ -51,13 +54,49 @@
(defmodel tk-object (model)
((.md-name :cell nil :initform (gentemp "TK") :initarg :id)
- (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class)))
+ (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class)
+ (timers :initarg :timers :accessor timers :initform nil)))
(defmethod md-awaken :before ((self tk-object))
(make-tk-instance self))
(define-symbol-macro .tkw (nearest self window))
+;;; --- timers ----------------------------------------
+
+(defmodel timer ()
+ ((id :initarg :id :accessor id
+ :initform (c? (bwhen (spawn (^spawn))
+ (apply 'after spawn))))
+ (tag :cell nil :initarg :tag :accessor tag :initform :anon)
+ (action :initform nil :initarg :action :accessor action)
+ (delay :initform 0 :initarg :delay :accessor delay)
+ (repeat :initform 1 :initarg :repeat :accessor repeat)
+ (completed :cell :ephemeral :initform (c-in nil) :initarg :completed :accessor completed)
+ (executions :initarg :executions :accessor executions
+ :initform (c? (+ (or .cache 0)
+ (if (^completed) 1 0))))
+ (spawn :initarg :spawn :accessor spawn
+ :initform (c? (if (not (^action))
+ (trc "Warning: timer with no associated action" self)
+ (flet ((spawn-delayed (n)
+ (list n (lambda ()
+ (funcall (^action) self)
+ (setf (^completed) t)))))
+ (bwhen (repeat (^repeat))
+ (when (or (zerop (^executions))
+ (^completed))
+ (typecase repeat
+ (number (when (< (^executions)(^repeat))
+ (spawn-delayed (^delay))))
+ (cons (bwhen (delay (nth (^executions) (^repeat)))
+ (spawn-delayed delay)))
+ (otherwise (spawn-delayed (^delay))))))))))))
+
+(defobserver timers ((self tk-object) new-value old-value)
+ (dolist (k (set-difference old-value new-value))
+ (after-cancel (id k)))) ;; causes tk error if not outstanding?
+
;;; --- widget -----------------------------------------
@@ -67,9 +106,11 @@
(format nil "~(~a.~a~)"
(parent-path (fm-parent self))
(md-name self))))
- (layout :reader layout :initarg :layout :initform nil)
+ (packing :reader packing :initarg :packing :initform nil)
+ (gridding :reader gridding :initarg :gridding :initform nil)
(enabled :reader enabled :initarg :enabled :initform t)
(bindings :reader bindings :initarg :bindings :initform nil)
+ (menus :reader menus :initarg :menus :initform nil)
(image-files :reader image-files :initarg :image-files :initform nil)
(selector :reader selector :initarg :selector
:initform (c? (upper self selector))))
@@ -82,33 +123,38 @@
(tk-format `(:make-tk ,self) "~(~a~) ~a ~{~(~a~) ~a~^ ~}"
(tk-class self) (path self)(tk-configurations self)) :stdfctry))
-;;;(defmethod md-awaken :before ((self widget))
-;;; (loop for (name file-pathname) in (^image-files)
-;;; do (tk-format "image create photo ~(~a.~a~) -file ~a"
-;;; (^path) name (tkescape (namestring file-pathname)))))
+(defmethod tk-configure ((self widget) option value)
+ (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value)))
-(defobserver image-files ()
+(defmethod not-to-be :after ((self widget))
+ (trc nil "not-to-be tk-forgetting true widget" self)
+ (tk-format `(:forget ,self) "pack forget ~a" (^path))
+ (tk-format `(:destroy ,self) "destroy ~a" (^path)))
+
+;;; --- bindings ------------------------------------------------------------
+
+(defobserver bindings () ;;; (w widget) event fun)
;
- ; I do not know how to create the photo for X before X exists
- ; though it seems to work. <g> perhaps Tk understands it does not need to
- ; place the image in a tree and lets the undefined path go? If so,
- ; just add :pre-make-kt before :make-kt in the sort list
+ ; when we get dynamic with this cell we will have to do the kids
+ ; thing and worry about extant new-values, de-bind lost old-values
;
- (loop for (name file-pathname) in (set-difference new-value old-value :key 'car)
- do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a"
- (^path) name (tkescape (namestring file-pathname)))))
+ (with-integrity (:client `(:bind ,self))
+ (dolist (bspec new-value)
+ (if (eql (length bspec) 3) ;; getting wierd here
+ (destructuring-bind (event fmt fn) bspec
+ (let ((name (gentemp "BNDG")))
+ (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}"
+ (^path) event (format nil fmt (register-callback self name fn)))))
+ (destructuring-bind (event fn) bspec
+ (bind (^path) event fn))))))
-(defobserver bindings () ;;; (w widget) event fun)
- (loop for (event fmt fn) in new-value
- for name = (gentemp "BNDG")
- do (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}"
- (^path) event (format nil fmt (register-callback self name fn)))))
+;;; --- packing ---------------------------------------------------------
-(defobserver layout ((self widget))
+(defobserver packing ((self widget))
(when new-value
- (assert (null (kids-layout .parent)) ()
- "Do not specify layout (here for ~a) unless parent leaves kids-layout unspecified.
-This parent is ~a, kids-layout ~a" self (list .parent (type-of .parent)) (kids-layout .parent)))
+ (assert (null (kids-packing .parent)) ()
+ "Do not specify packing (here for ~a) unless parent leaves kids-packing unspecified.
+This parent is ~a, kids-packing ~a" self (list .parent (type-of .parent)) (kids-packing .parent)))
;
; This use next of the parent instead of self is pretty tricky. It has to do with getting
; the pack commands out nested widgets before parents. The pack command issued on behalf
@@ -122,17 +168,27 @@
(when (and new-value (not (typep .parent 'panedwindow)))
(tk-format `(:pack ,(fm-parent self)) new-value)))
-(defun pack-self ()
- (c? (format nil "pack ~a" (path self))))
+(defmacro c?pack-self (&optional (modifier$ ""))
+ `(c? (format nil "pack ~a ~a" (path self) ,modifier$)))
-(defmethod tk-configure ((self widget) option value)
- (tk-format `(:configure ,self ,option) "~A configure ~(~a~) ~a" (path self) option (tk-send-value value)))
+;;; --- grids -------------------------------------------------------------------------
-(defmethod not-to-be :after ((self widget))
- (trc nil "not-to-be tk-forgetting true widget" self)
- (tk-format `(:forget ,self) "pack forget ~a" (^path))
- (tk-format `(:destroy ,self) "destroy ~a" (^path)))
+(defmodel grid-manager ()())
+(defobserver gridding ((self grid-manager))
+ (when new-value
+ (loop for k in (^kids)
+ when (gridding k)
+ do (tk-format `(:grid ,k) (format nil "grid ~a ~a" (path k) (gridding k))))
+ (destructuring-bind (&key columns rows) new-value
+ (when columns
+ (loop for config in columns
+ for idx upfrom 0
+ do (tk-format `(:grid ,self) (format nil "grid columnconfigure ~a ~a ~a" (^path) idx config))))
+ (when columns
+ (loop for config in rows
+ for idx upfrom 0
+ do (tk-format `(:grid ,self) (format nil "grid rowconfigure ~a ~a ~a" (^path) idx config)))))))
;;; --- items -----------------------------------------------------------------------
@@ -230,7 +286,7 @@
(defun tk-callback (self id-suffix fn &optional command)
(declare (ignorable command))
(let ((id (register-callback self id-suffix fn)))
- (trc nil "tk-callback" self id command)
+ (trc nil "tk-callback" self id)
(list 'callback id)))
(defun tk-callbackstring (self id-suffix tk-token fn)
@@ -291,3 +347,21 @@
(tk-variable self)
(tk-send-value new-value))))
+;;; --- images -------------------------------------------------------
+
+(defobserver image-files ()
+ ;
+ ; I do not know how to create the photo for X before X exists
+ ; though it seems to work. <g> perhaps Tk understands it does not need to
+ ; place the image in a tree and lets the undefined path go? If so,
+ ; just add :pre-make-kt before :make-kt in the sort list
+ ;
+ (loop for (name file-pathname) in (set-difference new-value old-value :key 'car)
+ do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a"
+ (^path) name (tkescape (namestring file-pathname)))))
+
+
+;;; --- menus ---------------------------------
+
+(defun pop-up (menu x y)
+ (tk-format-now "tk_popup ~A ~A ~A" (path menu) x y))
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/22 05:26:21 1.2
@@ -51,7 +51,7 @@
-showhandle)
(:default-initargs
:id (gentemp "PW")
- :layout nil))
+ :packing nil))
(defmethod make-tk-instance ((self panedwindow))
(tk-format `(:make-tk ,self) "panedwindow ~a -orient ~(~a~)"
@@ -67,7 +67,10 @@
; --------------------------------------------------------
-(defmodel window (family)
+(defmodel composite-widget (widget)
+ ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil)))
+
+(defmodel window (composite-widget)
((wish :initarg :wish :accessor wish
:initform (wish-stream *wish*)
#+(or) (c? (do-execute "wish84 -name testwindow"
@@ -82,47 +85,46 @@
(defmethod path ((self window)) ".")
(defmethod parent-path ((self window)) "")
-(defmethod kids-layout ((self window)) nil)
;--- group geometry -----------------------------------------
-(defmodel inline-mixin ()
- ((kids-layout :initarg :kids-layout :accessor kids-layout :initform nil)
- (padx :initarg :padx :accessor padx :initform 0)
+(defmodel inline-mixin (composite-widget)
+ ((padx :initarg :padx :accessor padx :initform 0)
(pady :initarg :pady :accessor pady :initform 0)
- (layout-side :initarg :layout-side :accessor layout-side :initform 'left)
+ (packing-side :initarg :packing-side :accessor packing-side :initform 'left)
(layout-anchor :initarg :layout-anchor :accessor layout-anchor :initform 'nw))
(:default-initargs
:kid-slots (lambda (self)
(declare (ignore self))
(list
- (mk-kid-slot (layout :if-missing t)
+ (mk-kid-slot (packing :if-missing t)
nil))) ;; suppress default
- :kids-layout (c? (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a"
- (mapcar 'path (^kids))
- (down$ (^layout-side))
- (down$ (^layout-anchor))
- (^padx)(^pady)))))
+ :kids-packing (c? (when (^kids)
+ (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a"
+ (mapcar 'path (^kids))
+ (down$ (^packing-side))
+ (down$ (^layout-anchor))
+ (^padx)(^pady))))))
-(defobserver kids-layout ()
+(defobserver kids-packing ()
(when new-value
- (tk-format `(:pack ,self kids-layout) new-value)))
+ (tk-format `(:pack ,self kids-packing) new-value)))
(defmodel row-mixin (inline-mixin)
()
(:default-initargs
- :layout-side 'left))
+ :packing-side 'left))
(defmodel stack-mixin (inline-mixin)
()
(:default-initargs
- :layout-side 'top))
+ :packing-side 'top))
;--- f r a m e --------------------------------------------------
-(deftk frame ()
+(deftk frame (composite-widget)
()
(:tk-spec frame -borderwidth -cursor -highlightbackground -highlightcolor
-highlightthickness -padx -pady -relief
@@ -168,3 +170,38 @@
(def-mk-inline mk-row (frame-row labelframe-row))
(def-mk-inline mk-stack (frame-stack labelframe-stack))
+
+;--- scroller (of canvas; need to generalize this) ----------
+
+(defmodel scroller (grid-manager frame)
+ ((canvas :initarg :canvas :accessor canvas :initform nil))
+ (:default-initargs
+ :id :cv-scroller
+ :kids-packing nil
+ :gridding '(:columns ("-weight {1}" "-weight {0}")
+ :rows ("-weight {1}" "-weight {0}"))
+ :kids (c? (the-kids
+ (^canvas)
+ (mk-scrollbar :id :hscroll
+ :orient "horizontal"
+ :gridding "-row 1 -column 0 -sticky we"
+ :command (c? (format nil "~a xview" (path (kid1 .parent)))))
+ (mk-scrollbar :id :vscroll
+ :orient "vertical"
+ :gridding "-row 0 -column 1 -sticky ns"
+ :command (c? (format nil "~a yview" (path (kid1 .parent)))))))))
+
+(defmacro mk-scroller (&rest iargs)
+ `(make-instance 'scroller
+ :fm-parent self
+ , at iargs))
+
+(defmethod initialize-instance :after ((self scroller) &key)
+ ;
+ ; Tk does not do late binding on widget refs, so the canvas cannot mention the scrollbars
+ ; in x/y scrollcommands since the canvas gets made first
+ ;
+ (with-integrity (:client `(:post-make-tk ,self))
+ (setf (xscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :hscroll))))
+ (setf (yscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :vscroll))))))
+
--- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 05:26:21 1.2
@@ -20,22 +20,22 @@
|#
+
(in-package :celtk-user)
(defun ctk::tk-test ()
- (tk-test-class 'a-few))
+ (cells-reset 'tk-user-queue-handler)
+ (tk-test-class 'ltktest-cells-inside))
(defparameter *tktest* nil)
(defun tk-test-class (root-class)
- (cells-reset 'tk-user-queue-handler)
- (setf ctk::*tk-send-ct* 0)
(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)
- (time (setf *tktest* (make-instance root-class)))
- (tk-format `(:fini) "wm deiconify .")
- ))
+ (setf ltk:*debug-tk* nil)
+ (with-integrity ()
+ (time (setf *tktest* (make-instance root-class))))
+ (tk-format `(:fini) "wm deiconify .")))
(defun tk-test-all ()(tk-test-class 'a-few))
(defun mk-font-view ()
@@ -47,7 +47,7 @@
:kids (c? (the-kids
(demo-all-menubar)
- (mk-row (:layout (pack-self))
+ (mk-row (:packing (c?pack-self))
(mk-label :text "aaa"
:image-files (list (list 'kt (make-pathname #+lispworks :host #-lispworks :device "c"
:directory '(:absolute "0dev" "Celtk")
@@ -56,7 +56,7 @@
:width 300
:image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))
- (assorted-canvas-items)
+ ;;(assorted-canvas-items)
(mk-stack ()
(mk-text-widget
@@ -65,9 +65,9 @@
:height 8
:width 25)
- (spin-package-with-symbols))
+ (spin-package-with-symbols))
- (mk-stack ()
+ #+nahh (mk-stack ()
(mk-row (:id :radio-ny :selection (c-in 'yes))
(mk-radiobutton-ex ("yes" 'yes))
(mk-radiobutton-ex ("no" 'no))
@@ -93,7 +93,7 @@
:id :enter-me)
(mk-label :text (c? (conc$ "echo " (fm^v :enter-me))))))
- (duelling-scrolled-lists)
+ #+nahh (duelling-scrolled-lists)
)))))
(defun style-by-edit-menu ()
@@ -124,8 +124,11 @@
(item (when spinner (md-value spinner)))
(pkg (find-package (string-upcase item))))
(when pkg
- (loop for sym being the present-symbols in pkg
- collecting sym))))
+ (loop for sym being the symbols in pkg
+ counting sym into symct
+ collecting sym into syms
+ finally (trc "syms found !!!" symct)
+ (return syms)))))
:list-item-factory (lambda (sym)
(make-instance 'listbox-item
:fm-parent *parent*
@@ -191,7 +194,7 @@
(defun style-by-widgets ()
(mk-stack ("Style by Widgets" :id :widstyle)
(mk-row (:id :stywid
- :layout-side 'left
+ :packing-side 'left
:layout-anchor 'sw)
(mk-popup-menubutton
:id :font-face
@@ -277,7 +280,7 @@
(:default-initargs
:kids (c? (the-kids
(mk-panedwindow
- :layout (pack-self)
+ :packing (c?pack-self)
:orient 'vertical
:kids (c? (the-kids
(loop repeat 2
@@ -288,9 +291,8 @@
(:default-initargs
:md-value (c? (tk-eval-list self "font families"))
:pady 2 :padx 4
- :layout-side 'left
+ :packing-side 'left
:layout-anchor 'nw
- ;;:kids-layout (pack-layout? "-side left -fill both -expand 1 -anchor nw")
:kids (c? (the-kids
(mk-spinbox :id :font-face
:md-value (c-in (car (^md-value)))
@@ -311,14 +313,7 @@
;;; ---- toplevel --------------------------------
-(defmodel tl-popper (frame-stack)
- ()
- (:default-initargs
- :pady 2 :padx 4
- :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw")
- :kids (c? (the-kids
- (mk-button-ex ("Open" (make-instance 'file-open))
- :underline 0)))))
+
(defmodel file-open (toplevel)
--- /project/cells/cvsroot/Celtk/load.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 05:26:21 1.2
@@ -1,3 +1,4 @@
+#+eval-this-if-you-do-not-autoload-asdf
(load (make-pathname :device "c"
:directory '(:absolute "0dev" "cells")
:name "asdf"
@@ -7,10 +8,17 @@
asdf:*central-registry*)
(push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk"))
- asdf:*central-registry*)
+ asdf:*central-registry*)
+
+#-runtestsuite
+(ASDF:OOS 'ASDF:LOAD-OP :CELLS)
+
+#+runtestsuite
+(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST)
-(ASDF:OOS 'ASDF:LOAD-OP :Celtk :force t)
+#+checkoutceltk
+(ASDF:OOS 'ASDF:LOAD-OP :CELTK)
-#+gratuitousfeature
+#+testceltk
(ctk::tk-test)
--- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 05:26:22 1.2
@@ -517,26 +517,26 @@
;;; start wish and set (wish-stream *wish*)
(defun start-wish (&rest keys &key handle-errors handle-warnings (debugger t)
- stream)
+ stream)
(declare (ignore handle-errors handle-warnings debugger))
;; open subprocess
(if (null (wish-stream *wish*))
(progn
- (setf (wish-stream *wish*) (or stream (do-execute *wish-pathname* *wish-args*))
- (wish-call-with-condition-handlers-function *wish*)
- (apply #'make-condition-handler-function keys))
- ;; perform tcl initialisations
+ (setf (wish-stream *wish*) (or stream (do-execute *wish-pathname* *wish-args*))
+ (wish-call-with-condition-handlers-function *wish*)
+ (apply #'make-condition-handler-function keys))
+ ;; perform tcl initialisations
(with-ltk-handlers ()
(init-wish)))
- ;; By default, we don't automatically create a new connection, because the
- ;; user may have simply been careless and doesn't want to push the old
- ;; connection aside. The NEW-WISH restart makes it easy to start another.
- (restart-case (ltk-error "There is already an inferior wish.")
- (new-wish ()
- :report "Create an additional inferior wish."
- (push *wish* *wish-connections*)
- (setf *wish* (make-ltk-connection))
- (apply #'start-wish keys)))))
+ ;; By default, we don't automatically create a new connection, because the
+ ;; user may have simply been careless and doesn't want to push the old
+ ;; connection aside. The NEW-WISH restart makes it easy to start another.
+ (restart-case (ltk-error "There is already an inferior wish.")
+ (new-wish ()
+ :report "Create an additional inferior wish."
+ (push *wish* *wish-connections*)
+ (setf *wish* (make-ltk-connection))
+ (apply #'start-wish keys)))))
(defun exit-wish ()
(with-ltk-handlers ()
@@ -619,7 +619,7 @@
(handler-case
(or
(let ((event (pop (wish-event-queue *wish*))))
- (when event (ukt:trc "read-event > popq" event))
+ ;; (when event (ukt:trc "read-event > popq" event))
event)
(if (or blocking (can-read (wish-stream *wish*)))
--- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 05:26:22 1.2
@@ -57,6 +57,9 @@
:grandpar (fm-parent .parent) (type-of (fm-parent .parent)))
(tk-format `(:make-tk ,self) "menu ~a -tearoff 0" (^path)))
+(defmacro mk-menu-ex (&rest submenus)
+ `(mk-menu :kids (c? (the-kids , at submenus))))
+
(defmethod make-tk-instance :after ((self menu))
(trc nil "make-tk-instance > traversing menu" self)
(fm-menu-traverse self
@@ -140,6 +143,11 @@
(:default-initargs
:menu (c? (path (kid1 self)))))
+(defmacro mk-menu-entry-cascade-ex ((&rest initargs) &rest submenus)
+ `(mk-menu-entry-cascade
+ , at initargs
+ :kids (c? (the-kids (mk-menu :kids (c? (the-kids , at submenus)))))))
+
(defmethod path ((self menu-entry-cascade))
(format nil "~(~a.~a~)" (path .parent) (md-name self)))
--- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/22 05:26:22 1.2
@@ -70,16 +70,13 @@
:textvariable (c? (^path))
:md-value (c-in "<your string here>")))
-;;;(defmethod make-tk-instance ((self entry))
-;;; (setf (gethash (^path) (dictionary .tkw)) self)
-;;; (tk-format "entry ~a -textvariable ~a" (path self)(path self)))
-
(defmethod md-awaken :after ((self entry))
(tk-format `(:trace ,self) "trace add variable ~a write \"trc2 ~a\""
(^path)
(register-callback self 'tracewrite
(lambda (&key name1 name2 op)
(declare (ignorable name1 name2 op))
+ (trc nil "tracewrite BINGO!!!!" (^path) (tk-eval-var (^path)))
(let ((new-value (tk-eval-var (^path))))
(unless (string= new-value (^md-value))
(setf (^md-value) new-value)))))))
--- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 05:26:22 1.2
@@ -25,11 +25,9 @@
; --- tk-format --- talking to wish/Tk -----------------------------------------------------
-(defparameter *tk-send-ct* 0)
-
(defun tk-user-queue-sort (task1 task2)
"Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly."
- (let ((priority '(:destroy :pre-make-tk :make-tk :post-make-tk :variable :bind :selection :trace :configure :pack :fini)))
+ (let ((priority '(:destroy :pre-make-tk :make-tk :post-make-tk :variable :bind :selection :trace :configure :grid :pack :fini)))
(destructuring-bind (type1 self1 &rest dbg) task1
(declare (ignorable dbg))
(assert type1)
@@ -58,45 +56,39 @@
(trc nil "!!! --- tk-user-queue-handler dispatching" defer-info)
(funcall task)))
-(defun tk-format (defer-info fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args)))
+(defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args)))
+ ;
+ ; --- pure debug stuff ---
+ ;
+ (let ((yes '( "scroll")) ;; '("scroll" "pkg-sym"))
+ (no '()))
+ (declare (ignorable yes no))
+ (when nil #+not (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$)
+ #+nah (unless (find #\" tk$)
+ (break "bad set ~a" tk$))))
+ (assert (wish-stream *wish*)) ;; when not??
+ ;
+ ; --- serious stuff ---
+ ;
+ (format (wish-stream *wish*) "~A~%" tk$)
+ (force-output (wish-stream *wish*)))
+
+(defun tk-format (defer-info fmt$ &rest fmt-args)
"Format then send to wish (via user queue)"
(assert (or (eq defer-info :grouped)
- (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue" tk$)
-
- ;; sigh, it can happen outside a path (assert (not (search "nil" tk$)) () "What is NIL doing in TK message ~a?" tk$)
+ (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue"
+ (apply 'format nil fmt$ fmt-args))
(when (eq defer-info :grouped)
(setf defer-info nil))
-
- (flet ((core (dbg)
- (declare (ignorable dbg))
- ;
- ; --- pure debug stuff ---
- ;
- (let ((yes '("font-face"))
- (no '("pkg-sym-list")))
- (declare (ignorable yes no))
- (when nil #+bzzt (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$)
- #+nah (unless (find #\" tk$)
- (break "bad set ~a" tk$))))
- (assert (wish-stream *wish*)) ;; when not??
- ;
- ; --- serious stuff ---
- ;
- (format (wish-stream *wish*) "~A~%" tk$)
- (force-output (wish-stream *wish*))
- ;
- ; --- mo better debug -----------------
- ;
- #+sighh (loop
- while (peek-char-no-hang *ewish*)
- do (break "ewish!!!!!!!> ~a" (read-line defun*ewish* nil nil)))))
+ (flet ((do-it ()
+ (apply 'tk-format-now fmt$ fmt-args)))
(if defer-info
(with-integrity (:client defer-info)
- (core :wi))
- (core :im))))
+ (do-it))
+ (do-it))))
(defmethod tk-send-value ((s string))
(format nil "~s" #+not "{~a}" s))
@@ -113,9 +105,6 @@
(defmethod tk-send-value ((values list))
(format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values)))
-(defmacro pack-layout? (fmt$ &rest args)
- `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list , at args))))
-
(defmethod parent-path ((nada null)) "")
(defmethod parent-path ((self t)) (^path))
--- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/16 05:15:14 1.1
+++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/22 05:26:22 1.2
@@ -42,8 +42,8 @@
`(make-instance 'button
:fm-parent *parent*
:text ,text
- :command (tk-callback self 'cmd
- (lambda () ,command))
+ :command (c? (tk-callback self 'cmd
+ (lambda () ,command)))
, at initargs))
; --- checkbutton ---------------------------------------------
@@ -196,9 +196,9 @@
(defobserver initial-value ((self spinbox))
(when new-value
- (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value)
-
- (setf (^md-value) new-value)))
+ (with-integrity (:change)
+ (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value)
+ (setf (^md-value) new-value))))
; --- scroll bars ----------------------------------------
@@ -223,7 +223,7 @@
(list-height :initarg :list-height :accessor list-height :initform nil))
(:default-initargs
:list-height (c? (max 1 (length (^list-item-keys))))
- :kids-layout nil
+ :kids-packing nil
:kids (c? (the-kids
(mk-listbox :id :list-me
:kids (c? (the-kids
@@ -232,11 +232,11 @@
:font '(courier 9)
:state (c? (if (enabled .parent) 'normal 'disabled))
:height (c? (list-height .parent))
- :layout (c? (format nil "pack ~a -side left -fill both -expand 1" (^path)))
+ :packing (c? (format nil "pack ~a -side left -fill both -expand 1" (^path)))
:yscrollcommand (c? (when (enabled .parent)
(format nil "~a set" (path (nsib))))))
(mk-scrollbar :id :vscroll
- :layout (c? (format nil "pack ~a -side right -fill y" (^path)))
+ :packing (c?pack-self "-side right -fill y")
:command (c? (format nil "~a yview" (path (psib)))))))))
(defmethod tk-output-selection :after ((self scrolled-list) new-value old-value old-value-boundp)
--- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 NONE
+++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 1.1
(in-package :celtk-user)
#+test-ltktest
(progn
(cells-reset 'tk-user-queue-handler)
(tk-test-class 'ltktest-cells-inside))
(defmodel ltktest-cells-inside (window)
((elapsed :initarg :elapsed :accessor elapsed :initform (c-in 0)))
(:default-initargs
:kids (c? (the-kids
(ltk-test-menus)
(mk-scroller
:packing (c?pack-self "-side top -fill both -expand 1")
:canvas (c? (make-kid 'ltk-test-canvas)))
(mk-row (:packing (c?pack-self "-side bottom"))
(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-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-entry :id :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)
()
(:default-initargs
:id :test-canvas
:scroll-region '(0 0 500 400)
:gridding "-row 0 -column 0 -sticky news"
:xscrollcommand (c-in nil) ;; see initialize-instance of canvas for gory details
:yscrollcommand (c-in nil)
:bindings (c? (list (list "<1>" (lambda (event)
(pop-up (car (^menus))
(event-root-x event)
(event-root-y event))))))
:menus (c? (the-kids (mk-menu
:kids (c? (the-kids
(mapcar (lambda (spec)
(destructuring-bind (lbl . out$) spec
(mk-menu-entry-command
:label lbl
:command (c? (tk-callback .tkw (gentemp "MNU")
(lambda ()
(format t "~&~a" out$)))))))
(list (cons "Option 1" "Popup 1")
(cons "Option 2" "Popup 2")
(cons "Option 3" "Popup 3"))))))))
:kids (c? (the-kids
(mk-text-item
:coords (list 10 10)
:anchor "nw"
:text "Ltk Demonstration")
(make-kid 'moire :id :moire-1)))))
(defmodel moire (line)
((rotx :initarg :rotx :accessor rotx :initform (c-in 0))
(repeat :initarg :repeat :accessor repeat :initform (c-in nil)))
(:default-initargs
:timers (c? (when (^repeat)
(list (make-instance 'timer
:tag :moire
:delay 25
:repeat (let ((m self))
(c? (repeat m)))
:action (lambda (timer)
(declare (ignore timer))
(incf (^rotx)))))))
:coords (c? (let* ((angle (* 0.1 (^rotx)))
(angle2 (* 0.3 angle))
(wx (sin (* 0.1 angle))))
(loop for i below 100
for w = (+ angle (* i 2.8001))
for x = (+ (* 50 (sin angle2)) 250 (* 150 (sin w) (1+ wx)))
for y = (+ (* 50 (cos angle2)) 200 (* 150 (cos w)))
nconcing (list x y))))))
(defun ltk-test-menus ()
(mk-menubar
:kids (c? (the-kids
(mk-menu-entry-cascade-ex (:label "File")
(mk-menu-entry-command :label "Load"
:command (c? (tk-callback .tkw 'load
(lambda () (format t "~&Load pressed~&")))))
(mk-menu-entry-command :label "Save"
:command (c? (tk-callback .tkw 'save
(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~&")))))
(mk-menu-entry-command
:label "png"
:command (c? (tk-callback .tkw 'png
(lambda () (format t "Png pressed~&"))))))
(mk-menu-entry-separator)
(mk-menu-entry-command :label "Quit"
:accelerator "Alt Q"
:command "exit"))))))
More information about the Cells-cvs
mailing list