[mcclim-cvs] CVS mcclim/Apps/Listener
ahefner
ahefner at common-lisp.net
Mon Oct 20 17:04:30 UTC 2008
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 at umbc.edu)
+;;; (C) Copyright 2003,2008 by Andy Hefner (ahefner at gmail.com)
;;; (C) Copyright 2004 by Paolo Amoroso (amoroso at 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 , at 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))
More information about the Mcclim-cvs
mailing list