[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp

[Kenny Tilton]

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos
In directory common-lisp.net:/tmp/cvs-serv705/clyde/visual-apropos

Modified Files:
	visual-apropos.lisp 
Log Message:

Date: Wed Jul 21 04:49:40 2004
Author: ktilton

Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.5
--- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4	Thu Jul  8 20:53:05 2004
+++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp	Wed Jul 21 04:49:39 2004
@@ -24,44 +24,42 @@
 ;; -------------------
 ;; to run, enter following in repl:
 ;;
-;;    (tk-test 'vis-apropos)
+;;    (tk-test 'visual-apropos)
 ;;
 
-(defun vis-apropos ()
-  (make-be 'visual-apropos
-    :sub-symbol (c-in 'padding)))
-
-(defmodel visual-apropos (frame-stack)
+(defmodel visual-apropos (window)
   ((symbols :initarg :symbols :initform nil :accessor symbols)
-   (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol))
+   (sub-symbol :initarg :sub-symbol :initform 'thread :accessor sub-symbol))
   (:default-initargs
     :symbols (c-in nil)
-    :pady 2
-    :padx 4
-    :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw")
     :kids  (c? (list
-                (search-for-symbol)
-                (mk-frame-row
-                 :padx 8
-                 :layout (pack-layout? "-side left -fill x")
+                (mk-frame-stack
+                 :pady 2
+                 :padx 4
+                 :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw")
                  :kids (c? (list
-                            (mk-frame-stack
+                            (search-for-symbol)
+                            (mk-frame-row
+                             :padx 8
                              :kids (c? (list
-                                        (mk-checkbutton :md-name :exported-only
-                                          :text "Exported Only"
-                                          :underline 1
-                                          :md-value (c-in nil)
-                                          :command (lambda (self)
-                                                     (setf (^md-value) (not (^md-value)))))
-                                        (show-which-symbols))))
-                            (package-filtering))))
-                (symbol-list)))))
+                                        (mk-frame-stack
+                                         :kids (c? (list
+                                                    (mk-checkbutton :md-name :exported-only
+                                                      :text "Exported Only"
+                                                      :underline 1
+                                                      :md-value (c-in nil)
+                                                      :command (c? (Tk-callback self 'cmd
+                                                                     (lambda (self key &rest args)
+                                                                       (declare (ignore key args))
+                                                                       (setf (^md-value) (not (^md-value)))))))
+                                                    (show-which-symbols))))
+                                        (package-filtering))))
+                            (symbol-list))))))))
 
 (defun search-for-symbol ()
   (mk-frame-row
    :relief 'ridge
    :padx 8
-   :layout (pack-layout? "-side left -fill x -anchor nw")
    :kids-layout (c? (format nil
                         "pack ~a -side left; pack ~a -side left -expand 1 -fill x; pack ~a -side right"
                       (path (kid1 self))
@@ -74,16 +72,18 @@
                  :width 64)
                (mk-button :text "Search"
                  :underline 0
-                 :command (lambda (self)
-                            (setf (symbols (upper self visual-apropos))
-                              (apropos-list (text (fm^ :search-string))))))))))
+                 :command (c? (Tk-callback self 'cmd
+                                (lambda (self key &rest args)
+                                  (declare (ignore key args))
+                                  (setf (symbols (upper self visual-apropos))
+                                    (apropos-list (text (fm^ :search-string))))))))))))
 
 ; --- symbol package filtering -------------------------------
 
 (defun package-filtering ()
   (mk-labelframe-row
    :text "Package(s) to Search"
-   :layout (pack-layout? "-side left -fill x -expand 1")
+   ;;:layout (pack-layout? "-side left -fill x -expand 1")
    :kids (c? (list
               (mk-checkbutton :md-name :all-pkgs
                 :text "All"
@@ -125,7 +125,7 @@
 
 (defun symbol-list ()
   (mk-frame-stack :md-name :symbol-list
-    :layout (pack-layout? "-side top -expand 1 -fill both")
+    ;;:layout (pack-layout? "-side top -expand 1 -fill both")
     :width 64
     :background 'red
     :kids (c? (list
@@ -208,13 +208,15 @@
 (defmodel va-sorter (sort-button)
   ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn))
   (:default-initargs
-      :command (lambda (self)
-                 (let* ((ss (fm^ :sym-sort)))
-                   (if (eq self (or (md-value ss) (kid1 ss)))
-                       (setf (sort-button-predicate self)
-                         (if (eq (sort-button-predicate self) 'va-string<)
-                             'va-string> 'va-string<))
-                     (setf (md-value ss) self))))
+      :command (c? (Tk-callback self 'cmd
+                     (lambda (self key &rest args)
+                       (declare (ignore key args))
+                       (let* ((ss (fm^ :sym-sort)))
+                         (if (eq self (or (md-value ss) (kid1 ss)))
+                             (setf (sort-button-predicate self)
+                               (if (eq (sort-button-predicate self) 'va-string<)
+                                   'va-string> 'va-string<))
+                           (setf (md-value ss) self))))))
       :sort-button-predicate (c-in 'va-string<)
       :sort-button-key (c? (lambda (si)
                              (funcall (^sort-string-fn)