Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv4446/celtic

Modified Files: menu.lisp scrolling.lisp widget-item.lisp Log Message:

Date: Tue Jul 6 18:25:41 2004 Author: ktilton

Index: cell-cultures/celtic/menu.lisp diff -u cell-cultures/celtic/menu.lisp:1.1 cell-cultures/celtic/menu.lisp:1.2 --- cell-cultures/celtic/menu.lisp:1.1 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/menu.lisp Tue Jul 6 18:25:41 2004 @@ -79,6 +79,13 @@ (path l))) (read *w*))

+(defmethod tk-eval (form$) + (tk-send + (format nil "puts -nonewline {(};puts -nonewline [~a];puts {)};flush stdout" + form$)) + (loop for value = (read *w* nil :eof) + While (not (eq value :eof)) + collecting value))

Index: cell-cultures/celtic/scrolling.lisp diff -u cell-cultures/celtic/scrolling.lisp:1.1 cell-cultures/celtic/scrolling.lisp:1.2 --- cell-cultures/celtic/scrolling.lisp:1.1 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/scrolling.lisp Tue Jul 6 18:25:41 2004 @@ -30,23 +30,25 @@ -activerelief -command -elementborderwidth -width))

(defmodel scrolled-list (frame-row) - ((list-items :initarg :list-items :accessor list-items :initform nil) + ((list-item-keys :initarg :list-item-keys :accessor list-item-keys :initform nil) + (list-item-factory :initarg :list-item-factory :accessor list-item-factory :initform nil) (list-height :initarg :list-height :accessor list-height :initform nil)) (:default-initargs - :list-height (c? (max 1 (length (^list-items)))) - :kids (c? (list + :list-height (c? (max 1 (length (^list-item-keys)))) + :kids (c? (the-kids (listbox :md-name :list - :kids (c? (list-items .parent)) + :kids (c? (mapcar (list-item-factory .parent) + (list-item-keys .parent))) :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))) - :yscrollcommand (c? (format nil "~a set" (path (nsib))))) + :yscrollcommand (c? (when (enabled .parent) + (format nil "~a set" (path (nsib)))))) (scrollbar :md-name :vscroll - :layout (c? (format nil "pack ~a -side right -fill y" (^path))) - :state (c? (if (enabled .parent) 'normal 'disabled)) - :command (c? (format nil "~a yview" (path (psib)))) - :command-is-callback nil))))) + :layout (c? (format nil "pack ~a -side right -fill y" (^path))) + :command (c? (format nil "~a yview" (path (psib)))) + :command-is-callback nil)))))

(defun scrolled-list (&rest inits) (apply 'make-instance 'scrolled-list inits))

Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.4 cell-cultures/celtic/widget-item.lisp:1.5 --- cell-cultures/celtic/widget-item.lisp:1.4 Mon Jul 5 12:29:53 2004 +++ cell-cultures/celtic/widget-item.lisp Tue Jul 6 18:25:41 2004 @@ -47,8 +47,9 @@ :md-name (create-name)))

(defmethod not-to-be :after ((self widget)) - (trc "whacking true widget" self) - (tk-send (format nil "pack forget ~a" (^path)))) + (trc "not-to-be tk-forgetting true widget" self) + (tk-send (format nil "pack forget ~a" (^path))) + (tk-send (format nil "destroy ~a" (^path))))

(def-c-output command ((self widget)) (when (^command-is-callback) @@ -105,6 +106,7 @@ (apply 'make-instance ',class inits)) ,(when std-factory `(defmethod make-tk-instance ((self ,class)) + (trc nil "!!! tk-creating" self) (tk-send (format nil ,(concatenate 'string (down$ class) " ~A") (path self))))) ,@outputs))))