mcclim-cvs

Download

mcclim-cvs@common-lisp.net

October 2008

2 participants
11 discussions

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 20 Oct '08

20 Oct '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory cl-net:/tmp/cvs-serv21009 Modified Files: dev-commands.lisp util.lisp Added Files: appearance.lisp Log Message: Commit work in progress on various listener cleanups, since the effort has for the moment stalled, and it all works for me. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/07/29 13:39:25 1.61 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/20 17:04:29 1.62 @@ -1,6 +1,6 @@ (in-package :clim-listener) -;;; (C) Copyright 2003 by Andy Hefner (hefner1(a)umbc.edu) +;;; (C) Copyright 2003,2008 by Andy Hefner (ahefner(a)gmail.com) ;;; (C) Copyright 2004 by Paolo Amoroso (amoroso(a)mclink.it) ;;; This library is free software; you can redistribute it and/or @@ -79,6 +79,12 @@ (define-presentation-method presentation-typep (object (type package-name)) (find-package object)) +;;; Views + +(defclass fancy-view (textual-view) + ((icon-size :initarg :icon-size :initform 16) + (base-path :initform nil :initarg :base-path))) + ;;; Presentation methods (define-presentation-method present (object (type standard-method) @@ -233,9 +239,6 @@ () (window-clear *standard-output*)) -;; You have to seperate command arguments with commas.. -;; Need to find a better way to input these. - ;; McCLIM fixme: Shouldn't we be able to activate before the (args) prompt ;; since defaults are defined? ;; FIXME: Disabled input, as it usually seems to hang. @@ -272,19 +275,11 @@ () (frame-exit *application-frame*)) - - -;;; Commands related to Lisp development -;;; ------------------------------------ +;;;; Commands relating to the Lisp environment (defvar *apropos-list* nil "The apropos command stores its output here.") -(defparameter *apropos-symbol-unbound-family* :fix) -(defparameter *apropos-symbol-unbound-face* :roman) -(defparameter *apropos-symbol-bound-family* :fix) -(defparameter *apropos-symbol-bound-face* :roman) - ;; FIXME: Make this a present method specialzed on a view? (defun apropos-present-symbol (symbol &optional (stream *standard-output*) show-package) @@ -459,9 +454,6 @@ ;;; CLOS introspection commands -(defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) -(defparameter *graph-text-style* (make-text-style :fix :roman :normal)) - (defun class-grapher (stream class inferior-fun &key (orientation :horizontal)) "Does the graphing for Show Class Superclasses and Subclasses commands" (let ((normal-ink +foreground-ink+) @@ -525,27 +517,14 @@ (note "~A is not a defined class." class-spec)))) -; Lookup direct slots from along the CPL given a class and a slot name. -; Returns them in an order parallel with the CPL. -; Need this to find readers/writers, which exist in the direct slot -; definitions, not the effective slot definitions. (ouch) (defun direct-slot-definitions (class slot-name) - (let ((cpl (reverse (clim-mop:class-precedence-list class))) - (direct-slots nil)) - (dolist (foo cpl) ; rewrite this - (let ((dslots (clim-mop:class-direct-slots foo))) - (dolist (slot dslots) - (when (eq slot-name (clim-mop:slot-definition-name slot)) - (push slot direct-slots))))) - direct-slots)) - -(defparameter *slot-name-ink* +black+) -(defparameter *slot-type-ink* +gray50+) -(defparameter *slot-initargs-ink* +red+) -(defparameter *slot-initform-ink* +goldenrod3+) -(defparameter *slot-readers-ink* +black+) -(defparameter *slot-writers-ink* +black+) -(defparameter *slot-documentation-ink* +turquoise4+) + "Given a class and a slot name, returns a list of the direct slot + definitions for this slot in the order they occur along the CPL." + (mapcan (lambda (cpl-class) + (copy-list + (remove slot-name (clim-mop:class-direct-slots cpl-class) + :key #'clim-mop:slot-definition-name :test-not #'eql))) + (clim-mop:class-precedence-list class))) (defun present-slot (slot class &key (stream *standard-output*)) "Formats a slot definition into a table row." @@ -583,19 +562,6 @@ (format t "~W" initform) (note "No initform"))) - #+NIL ; argh, shouldn't this work? - (formatting-cell () - (formatting-table () - (formatting-column () - (fcell (readers :center) - (if readers - (dolist (reader readers) (format T "~A~%" reader)) - (note "No readers"))) - (fcell (writers :center) - (if writers - (dolist (writer writers) (format T "~A~%" writer)) - (note "No writers")))))) - (formatting-cell (t :align-x :left) (if (not (or readers writers)) (note "No accessors") @@ -614,8 +580,7 @@ (note "No writers")))))) (fcell (documentation :left) - (when documentation (with-text-family (t :serif) (princ documentation)))) -))) + (when documentation (with-text-family (t :serif) (princ documentation)))) ))) (defun earliest-slot-definer (slot class) @@ -708,7 +673,8 @@ (not (typep c 'standard-class)))) classes)) -(defun x-specializer-direct-generic-functions (specializer) ;; FIXME - move to CLIM-MOP +(defun x-specializer-direct-generic-functions (specializer) + ;; This still belongs in CLIM-MOP. #+PCL (pcl::specializer-direct-generic-functions specializer) #+SBCL (sb-pcl::specializer-direct-generic-functions specializer) #+clisp (clos:specializer-direct-generic-functions specializer) @@ -716,13 +682,16 @@ (openmcl-mop:specializer-direct-generic-functions specializer) #+scl (clos:specializer-direct-generic-functions specializer) #-(or PCL SBCL scl clisp openmcl-partial-mop) - (error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this.")) + (error "Sorry, not supported in your CL implementation. +See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION +if you are interested in fixing this.")) (defun class-funcs (class) (remove-duplicates - (mapcan (lambda (class) - (copy-list (x-specializer-direct-generic-functions class))) - (remove-ignorable-classes (clim-mop:class-precedence-list class))))) + (mapcan + (lambda (class) + (copy-list (x-specializer-direct-generic-functions class))) + (remove-ignorable-classes (clim-mop:class-precedence-list class))))) (defun slot-name-sortp (a b) (flet ((slot-name-symbol (x) @@ -752,13 +721,13 @@ (let ((class (frob-to-class class-spec))) (if (null class) (note "~A is not a defined class." class-spec) - (let ((funcs (sort (class-funcs class) (lambda (a b) - (slot-name-sortp (clim-mop:generic-function-name a) - (clim-mop:generic-function-name b)))))) + (let ((funcs (sort (class-funcs class) #'slot-name-sortp + :key #'clim-mop:generic-function-name))) (with-text-size (t :small) - (format-items funcs :printer (lambda (item stream) - (present item 'generic-function :stream stream)) - :move-cursor t)))))) + (format-items funcs + :printer (lambda (item stream) + (present item 'generic-function :stream stream)) + :move-cursor t)))))) (defun method-applicable-to-args-p (method args arg-types) (loop @@ -1060,29 +1029,28 @@ ;;; Filesystem Commands ;;; ------------------- -(defun pathname-printing-name (pathname long-name) - (if long-name - (princ-to-string (namestring pathname)) - (if (directoryp pathname) - (format nil "~A/" (first (last (pathname-directory pathname)))) - (namestring (make-pathname :name (pathname-name pathname) - :type (pathname-type pathname) - :version (pathname-version pathname)))))) - -(defun pretty-pretty-pathname (pathname stream &key (long-name t)) - (with-output-as-presentation (stream pathname 'clim:pathname - :single-box t) +(defun pathname-printing-name (pathname &optional relative-to) + (if relative-to + (native-enough-namestring pathname relative-to) + (native-namestring pathname))) + +(defun pretty-pretty-pathname (pathname stream &optional (relative-to nil)) + (with-output-as-presentation (stream pathname 'clim:pathname :single-box t) (let ((icon (icon-of pathname))) - (when icon (draw-icon stream icon :extra-spacing 3))) - (princ (pathname-printing-name pathname long-name) stream)) + (when icon (draw-icon stream icon :extra-spacing 3))) + (princ (pathname-printing-name pathname relative-to) stream)) (terpri stream)) +(defun actual-name (pathname) + (if (directoryp pathname) + (if (stringp (car (last (pathname-directory pathname)))) + (car (last (pathname-directory pathname))) + (directory-namestring pathname)) + (native-namestring (file-namestring pathname)))) + (defun sort-pathnames (list sort-by) (case sort-by ; <--- FIXME - ('name (sort list #'string-lessp - :key (lambda (pathname) - (or (file-namestring pathname) - (first (last (pathname-directory pathname))))))) + ('name (sort list #'string-lessp :key #'actual-name)) (t list))) (defun split-sort-pathnames (list group-dirs sort-by) @@ -1100,16 +1068,24 @@ (and (char= first #\#) (char= last #\#)))))) -(defun hidden-name-p (name) - (when (> (length name) 1) - (char= (elt name 0) #\.))) +(defun hidden-name-p (name) + (and (> (length name) 1) (char= (elt name 0) #\.))) (defun filter-garbage-pathnames (seq show-hidden hide-garbage) - (delete-if (lambda (p) - (let ((name (pathname-printing-name p nil))) - (or (and (not show-hidden) (hidden-name-p name)) - (and hide-garbage (garbage-name-p name))))) - seq)) + (remove-if (lambda (name) + (or (and (not show-hidden) (hidden-name-p name)) + (and hide-garbage (garbage-name-p name)))) + seq :key #'actual-name)) + +(defun show-directory-pathnames (pathname) + "Convert the pathname entered by the user into a query pathname + (the pathname which will be passed to cl:directory, potentially a + wild pathname), and a base pathname (which directory entries may + be printed relative to in the fashion of enough-namestring)." + (values (if (wild-pathname-p pathname) + pathname + (gen-wild-pathname pathname)) + (strip-filespec pathname))) ;; Change to using an :ICONIC view for pathnames? @@ -1128,42 +1104,58 @@ (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) - (let* ((pathname - ;; helpfully fix things if trailing slash wasn't entered - (directorify-pathname pathname)) - (wild-pathname (gen-wild-pathname pathname)) - (dir (if list-all-direct-subdirectories - (list-directory-with-all-direct-subdirectories wild-pathname) - (list-directory wild-pathname)))) + (multiple-value-bind (query-pathname base-pathname) + (show-directory-pathnames pathname) + + (let ((dir (if list-all-direct-subdirectories + (list-directory-with-all-direct-subdirectories query-pathname) + (list-directory query-pathname)))) - (with-text-family (t :sans-serif) + (with-text-family (t :sans-serif) (invoke-as-heading - (lambda () - (format t "Contents of ") - (present (directory-namestring pathname) 'pathname) - (when (pathname-type pathname) - (format t " (only files of type ~a)" (pathname-type pathname))))) - + (lambda () + (cond + ((wild-pathname-p pathname) + (format t "Files matching ") + (present query-pathname 'pathname)) + (t + (format t "Contents of ") + (present (directory-namestring query-pathname) 'pathname))))) + (when (parent-directory pathname) - (with-output-as-presentation (t (parent-directory pathname) 'clim:pathname :single-box t) - (draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3) - (format t "Parent Directory~%"))) + (with-output-as-presentation (t (parent-directory pathname) + 'clim:pathname :single-box t) + ;; Workaround new mcclim-images draw-icon silliness using + ;; table formatter + (formatting-table (t :move-cursor nil) + (formatting-row () + (formatting-cell () + (draw-icon t (standard-icon "up-folder.xpm") + :extra-spacing 3) + (format t "Parent Directory"))))) + ;; Note that the above leaves the cursor positioned at the end + ;; of the "Parent Directory" line. + (terpri)) + + (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all (setf group (filter-garbage-pathnames group show-hidden hide-garbage))) (ecase style (:items - (abbreviating-format-items group :row-wise nil :x-spacing " " :y-spacing 1 - :printer (lambda (x stream) - (pretty-pretty-pathname x stream - :long-name full-names))) + (abbreviating-format-items + group + :row-wise nil :x-spacing " " :y-spacing 1 + :printer (lambda (x stream) + (pretty-pretty-pathname x stream (if full-names + nil + base-pathname)))) (multiple-value-bind (x y) (stream-cursor-position *standard-output*) (setf (stream-cursor-position *standard-output*) (values 0 y)))) (:list (dolist (ent group) - (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) - ;; And breaks some things for SBCL.. (mgr) - (pretty-pretty-pathname ent *standard-output* :long-name full-names))))))))) + (let ((ent (merge-pathnames ent pathname))) + (pretty-pretty-pathname ent *standard-output* :long-name full-names)))))))))) #+nil ; OBSOLETE (define-presentation-to-command-translator show-directory-translator @@ -1307,7 +1299,13 @@ (setf (command-enabled 'com-drop-directory frame) state (command-enabled 'com-pop-directory frame) state (command-enabled 'com-swap-directory frame) state))) - + +(defmacro with-directory-stack (() &body body) + `(prog1 + (if *directory-stack* + (progn ,@body) + (note "The directory stack is empty.")) + (compute-dirstack-command-eligibility *application-frame*))) (define-command (com-push-directory :name "Push Directory" :menu t @@ -1326,59 +1324,48 @@ (format t "~&The top of the directory stack is now ") (present (truename (first *directory-stack*))) (terpri)) - (format t "~&The directory stack is now empty.~%"))) + (format "~&The directory stack is now empty.~%"))) (define-command (com-pop-directory :name "Pop Directory" :menu t :command-table directory-stack-commands) () - (if (null *directory-stack*) - (note "The directory stack is empty!") - (progn - (com-change-directory (pop *directory-stack*)) - (italic (t) (comment-on-dir-stack)))) - (compute-dirstack-command-eligibility *application-frame*)) + (with-directory-stack () + (com-change-directory (pop *directory-stack*)) + (comment-on-dir-stack))) (define-command (com-drop-directory :name "Drop Directory" :menu t :command-table directory-stack-commands) () - (italic (t) - (if (null *directory-stack*) - (format t "~&The directory stack is empty!~%") - (progn - (setf *directory-stack* (rest *directory-stack*)) - (comment-on-dir-stack)))) - (compute-dirstack-command-eligibility *application-frame*)) + (with-directory-stack () + (setf *directory-stack* (rest *directory-stack*)) + (comment-on-dir-stack))) + (define-command (com-swap-directory :name "Swap Directory" :menu t :command-table directory-stack-commands) () - (italic (t) [33 lines skipped] --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/02/04 03:17:39 1.25 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/20 17:04:29 1.26 @@ -20,7 +20,7 @@ ;;; Boston, MA 02111-1307 USA. -;(defmacro multiple-value-prog2 (&body body) `(progn ,(first body) (multiple-value-prog1 ,@(rest body)))) + ;; multiple-value-or, ugh. Normal OR drops values except from the last form. (defmacro mv-or (&rest forms) @@ -29,14 +29,15 @@ `(let ((,tmp (multiple-value-list ,(first forms)))) (if (first ,tmp) (values-list ,tmp) (mv-or ,@(rest forms))))))) -; There has to be a better way.. -(defun directoryp (pathname) - "Returns pathname when supplied with a directory, otherwise nil" +(defun directoryp (path) + "Determine if PATH designates a directory" #+allegro (excl:file-directory-p pathname) - #-allegro - (if (or (pathname-name pathname) (pathname-type pathname)) + #-allegro + (flet ((f (x) (if (eq x :unspecific) nil x))) + (if (or (f (pathname-name path)) + (f (pathname-type path))) nil - pathname)) + path))) (defun getenv (var) (or @@ -61,16 +62,22 @@ default (or desi default))) -;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function, which really doesn't -;;; do what I'd like (resolves symbolic links, tends to be horribly buggy, etc.) +;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function. Work +;;; around various issues which may arise, such as: + +;;; * Don't error in response to broken symlinks (as cl:truename might) +;;; * Ideally, don't return truenames at all. +;;; * Don't error in response to garbage filenames not conforming to +;;; the preferred encoding for filenames -#+(or CMU scl) +#+(or cmu scl) (defun list-directory (pathname) (directory pathname :truenamep nil)) -#+SBCL +#+sbcl (defun list-directory (pathname) - ;; Wow. When did SBCL's cl:directory become sane? This is great news! + ;; Sooner or later, I'm putting all the sb-posix junk back in. + ;; I *really* don't like truenames. (directory pathname)) #+openmcl @@ -82,7 +89,7 @@ (directory pathname :directories-are-files nil)) ;; Fallback to ANSI CL -#-(OR CMU scl SBCL OPENMCL ALLEGRO) +#-(or cmu scl sbcl openmcl allegro) (defun list-directory (pathname) (directory pathname)) @@ -96,10 +103,21 @@ (delete-if (lambda (directory) (member directory file-list :test #'equal)) (delete-if-not #'directoryp - (list-directory (gen-wild-pathname - (strip-filespec pathname)))))) + (list-directory (gen-wild-pathname + (strip-filespec pathname)))))) file-list))) +;;; Native namestring. cl:namestring is allowed to do anything it wants to +;;; the filename, and some lisps do (CCL, for instance). +(defun native-namestring (pathname-designator) + #+sbcl (sb-ext:native-namestring pathname-designator) + #+openmcl (ccl::native-untranslated-namestring pathname-designator) + #-(or sbcl openmcl) (namestring pathname-designator)) + +(defun native-enough-namestring (pathname &optional + (defaults *default-pathname-defaults*)) + (native-namestring (enough-namestring pathname defaults))) + ;;; A farce of a "portable" run-program, which grows as I need options from ;;; the CMUCL run-program. ;;; This ought to change the current directory to *default-pathname-defaults*.. @@ -117,7 +135,6 @@ :output-stream output :wait wait) #+clisp (ext:run-program program :arguments args :wait wait) - #-(or CMU scl SBCL lispworks clisp) (format t "~&Sorry, don't know how to run programs in your CL.~%")) @@ -153,14 +170,19 @@ (stream-increment-cursor-position stream 0 (truncate (/ (text-style-ascent (medium-text-style stream) stream) fraction)))) -(defun invoke-as-heading (cont &optional ink) - (with-drawing-options (t :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) +(defun invoke-as-heading (cont &optional (ink +royal-blue+)) + (with-drawing-options (t :ink ink :text-style (make-text-style :sans-serif :bold nil)) (fresh-line) (underlining (t) (funcall cont)) (fresh-line) (vertical-gap t))) +(defun heading (control-string &rest args) + (invoke-as-heading + (lambda () + (apply 'format t control-string args)))) + (defun indent-to (stream x &optional (spacing 0) ) "Advances cursor horizontally to coordinate X. If the cursor is already past this point, increment it by SPACING, which defaults to zero." @@ -206,7 +228,8 @@ (defun parent-directory (pathname) "Returns a pathname designating the directory 'up' from PATHNAME" - (let ((dir (pathname-directory (truename pathname)))) + (let ((dir (pathname-directory pathname ))) ;(if (probe-file pathname) + ; pathname (when (and (eq (first dir) :absolute) (rest dir)) ;; merge-pathnames merges :back, but not :up @@ -214,20 +237,23 @@ (merge-pathnames (make-pathname :directory '(:relative :back)) (truename pathname)))))) -(defun directorify-pathname (pathname) +(defun coerce-to-directory (pathname) "Convert a pathname with name/version into a pathname with a similarly-named last directory component. Used for user input that lacks the final #\\/." (if (directoryp pathname) pathname - ;; doing this the primitive way instead of trying to grok name, - ;; type, version and trying to reconstruct what the user - ;; actually typed. I think I'm going to hell for this one. - (pathname (concatenate 'string (namestring pathname) "/")))) + (merge-pathnames + (make-pathname + :directory (if (pathname-name pathname) + (list :relative (file-namestring pathname)) + '(:relative))) + (strip-filespec pathname)))) ;;;; Abbreviating item formatter -;;; FIXME: This would work a lot better if the +;;; Doesn't work as well as I'd like, due to the table formatter not sizing +;;; columns as anticipated. (defparameter *abbreviating-minimum-items* 6 "Minimum number of items needed to invoke abbreviation. This must be at least one.") @@ -363,7 +389,6 @@ ;;; An attempt at integrating RUN-PROGRAM closer with lisp. -;;; That is, close enough to make it less of a pain in the ass. ;;; This code creates a macro on the #! character sequence which expands ;;; to a lambda closed over a call to RUN-PROGRAM invoked the program @@ -373,8 +398,7 @@ ;; TODO: -;; * Evil environment variable hack (scan some package for variables prefixed -;; with '$', build the environment variables from that) +;; * Environment variables? ;; * Figure out what to do with the input/output streams ;; * Ability to pipe programs together, input/output redirection. ;; * Utilities for getting data in and out of unix programs through streams @@ -419,7 +443,6 @@ (dolist (arg args) (setf list (nconc list (multiple-value-list (transform-program-arg arg))))) list)) -; (mapcar #'transform-program-arg args) (defun program-wrapper (name) "Returns a closure which invokes the NAMEd program through the operating system, @@ -446,6 +469,8 @@ (write-char c out)) stream))) +;;; Don't install this by default, because no one uses it. +#+NIL (set-dispatch-macro-character #\# #\! #'(lambda (stream char p) (declare (ignore char p)) @@ -453,3 +478,58 @@ `(lambda (&rest args) (apply (program-wrapper ,name) args))))) +;;;; Graphing and various helpers + +(defparameter *min-x* -7) +(defparameter *max-x* 7) +(defparameter *min-y* -7) +(defparameter *max-y* 7) +(defparameter *graph-size* 600) +(defparameter *graph-width* nil) +(defparameter *graph-height* nil) +(defparameter *graph-ink* +black+) + +(defun draw-thin-bar-graph-1 (medium function scale min max dx) + (loop for i from 0 below (floor (- max min) dx) + for x = min then (+ x dx) + do (draw-line* medium i 0 i (* scale (funcall function x))))) + +(defun draw-vector-bar-graph + (vector &key (stream *standard-output*) (scale-y 1) (ink +black+) + (key 'identity) (start 0) (end nil)) + (let ((range (- (reduce 'max vector :start start :end end :key key) + 0 #+NIL (reduce 'min vector :start start :end end :key key)))) ; totally wrong + + (with-room-for-graphics (stream :first-quadrant t) + (with-new-output-record (stream) + (with-drawing-options (stream :ink ink) + (unless (zerop range) + (when (eql t scale-y) + (setf scale-y (/ 250 range)) + #+NIL (hef:debugf scale-y)) + (draw-thin-bar-graph-1 + stream + (lambda (i) (funcall key (aref vector i))) + scale-y start (or end (length vector)) 1))))))) + +;(defun draw-coordinate-labels (stream value-min val-max stream-min stream-max) +; +; (text-size stream (format nil "~4F" value) + +;; Broken - min-y/max-y aren't, in the sense that it won't clip to +;; those values. +(defun draw-function-filled-graph + (function &key (stream *standard-output*) + (min-x *min-x*) (max-x *max-x*) + (min-y *min-y*) (max-y *max-y*) + size + (width (or size *graph-width* *graph-size*)) + (height (or size *graph-height* *graph-size*)) + (ink *graph-ink*)) + (with-room-for-graphics (stream :first-quadrant t) + (with-new-output-record (stream) + (with-drawing-options (stream :ink ink) + (draw-thin-bar-graph-1 stream function + (float (/ height (- max-y min-y)) 0.0f0) + min-x max-x + (/ (- max-x min-x) width)))))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/appearance.lisp 2008/10/20 17:04:30 NONE +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/appearance.lisp 2008/10/20 17:04:30 1.1 (in-package :clim-listener) ;;; Apropos (defparameter *apropos-symbol-unbound-family* :fix) (defparameter *apropos-symbol-unbound-face* :roman) (defparameter *apropos-symbol-bound-family* :fix) (defparameter *apropos-symbol-bound-face* :roman) ;;; Show Class Slots (defparameter *slot-name-ink* +black+) (defparameter *slot-type-ink* +gray50+) (defparameter *slot-initargs-ink* +red+) (defparameter *slot-initform-ink* +goldenrod3+) (defparameter *slot-readers-ink* +black+) (defparameter *slot-writers-ink* +black+) (defparameter *slot-documentation-ink* +turquoise4+) ;;; Graphing (classes and packages) (defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) (defparameter *graph-text-style* (make-text-style :fix :roman :normal))

1 0