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

Modified Files: visual-apropos.lisp Log Message:

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

Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.2 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.3 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.2 Sun Jul 4 11:59:45 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Tue Jul 6 18:25:41 2004 @@ -19,15 +19,9 @@

|#

-#| do list - -at least show search in entry - -|# - (in-package :celtic)

-;; +;; ------------------- ;; to run, enter following in repl: ;; ;; (tk-test 'vis-apropos) @@ -35,13 +29,13 @@

(defun vis-apropos () (make-be 'visual-apropos - :sub-symbol 'padding)) + :sub-symbol (c-in 'padding)))

(defmodel visual-apropos (frame-stack) ((symbols :initarg :symbols :initform nil :accessor symbols) (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) (:default-initargs - :symbols (c? (apropos-list (^sub-symbol))) + :symbols (c-in nil) :pady 2 :padx 4 :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") @@ -61,9 +55,6 @@ (setf (^md-value) (not (^md-value))))) (show-which-symbols)))) (package-filtering)))) - (label :text (c? (format nil "Symbols containing ~a" - (sub-symbol .parent))) - :underline 4) (symbol-list)))))

(defun search-for-symbol () @@ -84,8 +75,8 @@ (button :text "Search" :underline 0 :command (lambda (self) - (setf (md-value (upper self visual-apropos)) - (md-value (fm^ :search-string))))))))) + (setf (symbols (upper self visual-apropos)) + (apropos-list (text (fm^ :search-string))))))))))

; --- symbol package filtering -------------------------------

@@ -104,11 +95,13 @@ :md-name :in-package :list-height 4 :layout (pack-layout? "-side left -fill x -expand 1") - :enabled (c? (not (md-value (psib)))) - :list-items (c? (loop for p in (list-all-packages) - collecting (make-instance 'listbox-item - :md-value p - :item-text (down$ (package-name p)))))))))) + :enabled (c? (when (not (md-value (psib))) + (setf *dbg* t))) + :list-item-keys (list-all-packages) + :list-item-factory (lambda (pkg) + (make-instance 'listbox-item + :md-value pkg + :item-text (down$ (package-name pkg)))))))))

; --- symbol binding filtering ---------------------------------------

@@ -124,13 +117,13 @@ (^kids)))) :selection (c-in :any) :kids (c? (flet ((rb (n) - (radiobutton :md-name n - :text (string-capitalize (string n)) - :tk-variable (tk-variable self) - :value n - :layout nil - :underline 0))) - (list (rb :any)(rb :functions)(rb :variables)(rb :classes)))))) + (radiobutton :md-name n + :text (string-capitalize (string n)) + :tk-variable (tk-variable self) + :value n + :layout nil + :underline 0))) + (list (rb :any)(rb :functions)(rb :variables)(rb :classes))))))

(defun symbol-list () (frame-stack :md-name :symbol-list @@ -183,21 +176,37 @@ (if (constantp s) "con" "var")) (find-class s nil) (exported-p s))))) - :list-items (c? (let ((sorter (let ((ss (fm^ :sym-sort))) - (or (md-value (fm^ :sym-sort)) - (kid1 ss))))) - (sort (loop for si in (^md-value) - collect (make-instance 'va-symbol-info - :md-value si)) - (sort-button-predicate sorter) - :key (sort-button-key sorter))))))))) + :list-item-keys (c? (let ((sorter (let ((ss (fm^ :sym-sort))) + (or (md-value (fm^ :sym-sort)) + (kid1 ss))))) + (sort (copy-list (^md-value)) + (sort-button-predicate sorter) + :key (sort-button-key sorter)))) + :list-item-factory (lambda (symbol-info) + (make-instance 'va-symbol-info + :md-value symbol-info)))))))

(defmodel sort-button (button) ((sort-button-predicate :initarg :sort-button-predicate :accessor sort-button-predicate - :initform #'string<) + :initform #'va-string<) (sort-button-key :initarg :sort-button-key :accessor sort-button-key :initform #'identity)))

+(defun va-string< (v1 v2) + (flet ((blank (v) (or (null v)(equal v "")))) + (unless (equal v1 v2) + (unless (blank v1) ;; arrange for blanks to appear last + (or (blank v2) + (string< v1 v2)))))) + +(defun va-string> (v1 v2) + (flet ((blank (v) (or (null v)(equal v "")))) + (unless (equal v1 v2) + (if (blank v1) ;; arrange for blanks to appear last + (not (blank v2)) + (and (not (blank v2)) + (string> v1 v2)))))) + (defmodel va-sorter (sort-button) ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn)) (:default-initargs @@ -205,13 +214,13 @@ (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) 'string<) - 'string> 'string<)) + (if (eq (sort-button-predicate self) 'va-string<) + 'va-string> 'va-string<)) (setf (md-value ss) self)))) - :sort-button-predicate (c-in 'string<) + :sort-button-predicate (c-in 'va-string<) :sort-button-key (c? (lambda (si) (funcall (^sort-string-fn) - (elt (md-value si) (kid-no self))))))) + (elt si (kid-no self)))))))

(defmodel va-symbol-info (listbox-item) () @@ -249,7 +258,7 @@ (unless (or (md-value (fm^ :all-pkgs)) (bIf (sel (selection (fm^ :in-package))) (eq (symbol-package symbol) - (md-value (elt (list-items (fm^ :in-package)) sel))) + (elt (list-item-keys (fm^ :in-package)) sel)) t)) (return-from va-show-symbol-p nil))