[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
Kenny Tilton
ktilton at common-lisp.net
Wed Jul 7 01:25:41 UTC 2004
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))
More information about the Cells-cvs
mailing list