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 + ,@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 ,@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 + ,@initargs + :kids (c? (the-kids (mk-menu :kids (c? (the-kids ,@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 ,@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))) ,@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"))))))