[cells-cvs] CVS update: cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/widget-item.lisp

[Kenny Tilton]

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)))))
            , at outputs))))