From ahefner at common-lisp.net Mon Oct 20 17:04:30 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 20 Oct 2008 17:04:30 +0000 Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: 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)) From ahefner at common-lisp.net Mon Oct 20 17:31:42 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 20 Oct 2008 17:31:42 +0000 Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv28749 Modified Files: port.lisp Log Message: Fix off by one error in CLX button decoding, based on patch by Mike Watters. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/05/13 03:04:39 1.134 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/10/20 17:31:41 1.135 @@ -617,7 +617,7 @@ +pointer-wheel-left+ +pointer-wheel-right+))) (and (> code 0) - (<= code (1+ (length button-mapping))) + (<= code (length button-mapping)) (aref button-mapping (1- code))))) ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1, From ahefner at common-lisp.net Wed Oct 22 23:26:58 2008 From: ahefner at common-lisp.net (ahefner) Date: Wed, 22 Oct 2008 23:26:58 +0000 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv1885 Modified Files: clim-listener.asd Log Message: Oops, do load appearance.lisp in clim-listener system. --- /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/04/14 16:46:37 1.4 +++ /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/10/22 23:26:58 1.5 @@ -12,11 +12,12 @@ :pathname #.(make-pathname :directory '(:relative "Apps" "Listener")) :components ((:file "package") + (:file "appearance" :depends-on ("package")) (:file "util" :depends-on ("package")) (:file "icons" :depends-on ("package" "util")) (:file "file-types" :depends-on ("package" "icons" "util")) - (:file "dev-commands" :depends-on ("package" "icons" "file-types" "util")) + (:file "dev-commands" :depends-on ("package" "appearance" "icons" "file-types" "util")) (:file "wholine" :depends-on ("package" "dev-commands" "util")) (:file "listener" :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util")) - #+CMU (:file "cmu-hacks" :depends-on ("package")))))) + From ahefner at common-lisp.net Wed Oct 22 23:58:14 2008 From: ahefner at common-lisp.net (ahefner) Date: Wed, 22 Oct 2008 23:58:14 +0000 Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory cl-net:/tmp/cvs-serv8102 Modified Files: dev-commands.lisp util.lisp Log Message: Fix a couple careless oversights, and add a backdoor variable to disable threaded evaluation. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/20 17:04:29 1.62 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/22 23:58:12 1.63 @@ -1155,7 +1155,7 @@ (setf (stream-cursor-position *standard-output*) (values 0 y)))) (:list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) - (pretty-pretty-pathname ent *standard-output* :long-name full-names)))))))))) + (pretty-pretty-pathname ent *standard-output* full-names)))))))))) #+nil ; OBSOLETE (define-presentation-to-command-translator show-directory-translator @@ -1175,7 +1175,7 @@ ((pathname 'pathname :prompt "pathname")) (let ((pathname (merge-pathnames ;; helpfully fix things if trailing slash wasn't entered - (directorify-pathname pathname)))) + (coerce-to-directory pathname)))) (if (not (probe-file pathname)) (note "~A does not exist.~%" pathname) (change-directory pathname)))) @@ -1311,7 +1311,7 @@ :menu t :command-table directory-stack-commands) ((pathname 'pathname :prompt "directory")) - (let ((pathname (merge-pathnames (directorify-pathname pathname)))) + (let ((pathname (merge-pathnames (coerce-to-directory pathname)))) (if (not (probe-file pathname)) (note "~A does not exist.~%" pathname) (progn (push *default-pathname-defaults* *directory-stack*) @@ -1324,7 +1324,7 @@ (format t "~&The top of the directory stack is now ") (present (truename (first *directory-stack*))) (terpri)) - (format "~&The directory stack is now empty.~%"))) + (format t "~&The directory stack is now empty.~%"))) (define-command (com-pop-directory :name "Pop Directory" :menu t @@ -1504,6 +1504,13 @@ ** * * (first values))) +;;; The background evaluation feature is neat, but some people (namely +;;; myself) sometimes need a backdoor to disable it when evaluating +;;; code which does a lot of graphics in the listener, due to thread +;;; safety issues with concurrent access to a CLIM stream. +(defparameter *use-background-eval* t + "Perform evaluation in a background thread, which can be interrupted.") + (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) (let ((standard-output *standard-output*) @@ -1527,7 +1534,7 @@ ;; interrupt it. (let ((start-time (get-internal-real-time))) (destructuring-bind (result . value) - (if clim-sys:*multiprocessing-p* + (if (and *use-background-eval* clim-sys:*multiprocessing-p*) (catch 'done (let* ((orig-process (clim-sys:current-process)) (evaluating t) @@ -1571,7 +1578,7 @@ :command-table show-commands) ((table 'clim:command-table :prompt "command table") &key - (locally 'boolean :default nil :mentioned-default t) + ;;(locally 'boolean :default nil :mentioned-default t) (show-commands 'boolean :default t)) (let ((our-tables nil) (processed-commands (make-hash-table :test #'eq))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/20 17:04:29 1.26 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/22 23:58:12 1.27 @@ -505,8 +505,7 @@ (with-drawing-options (stream :ink ink) (unless (zerop range) (when (eql t scale-y) - (setf scale-y (/ 250 range)) - #+NIL (hef:debugf scale-y)) + (setf scale-y (/ 250 range))) (draw-thin-bar-graph-1 stream (lambda (i) (funcall key (aref vector i))) @@ -533,3 +532,4 @@ (float (/ height (- max-y min-y)) 0.0f0) min-x max-x (/ (- max-x min-x) width)))))) + From ahefner at common-lisp.net Thu Oct 23 00:23:06 2008 From: ahefner at common-lisp.net (ahefner) Date: Thu, 23 Oct 2008 00:23:06 +0000 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv22219 Modified Files: graphics.lisp Log Message: make-pattern-from-bitmap-file: Fix width/height - image matrices are row-major. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/04/14 16:46:37 1.61 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/10/23 00:23:06 1.62 @@ -1016,7 +1016,8 @@ (medium (design rgb-image-design) &rest options &key (x 0) (y 0) &allow-other-keys) (with-medium-options (medium options) - (medium-draw-image-design* medium design x y))) + (medium-draw-image-design* medium design x y)) + (values)) ;;;; @@ -1203,8 +1204,8 @@ (if read-designs (make-pattern res (or designs read-designs)) (make-instance 'rgb-pattern :image (make-instance 'rgb-image - :width (array-dimension res 0) - :height (array-dimension res 1) + :width (array-dimension res 1) + :height (array-dimension res 0) :data res))))) (define-bitmap-file-reader :xpm (pathname) From thenriksen at common-lisp.net Thu Oct 23 20:47:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Oct 2008 20:47:57 +0000 Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: Update of /project/mcclim/cvsroot/mcclim/Drei In directory cl-net:/tmp/cvs-serv10588/Drei Modified Files: drei-clim.lisp Log Message: Spelling fixes from Mike Watters. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/05/01 06:48:21 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/10/23 20:47:57 1.46 @@ -57,10 +57,10 @@ ;;; though. ;;; Cursors are output records. After a cursor is created, The owning -;;; Drei instance instnace should add it to the output stream. The -;;; owner of the cursor (a Drei instance) is responsible for removing -;;; the cursor once it is done with it. Cursors can be active/inactive -;;; and enabled/disabled and have the same activity-status as their +;;; Drei instance should add it to the output stream. The owner of the +;;; cursor (a Drei instance) is responsible for removing the cursor +;;; once it is done with it. Cursors can be active/inactive and +;;; enabled/disabled and have the same activity-status as their ;;; associated view. (defclass drei-cursor (standard-sequence-output-record) ((%view :reader view From thenriksen at common-lisp.net Thu Oct 23 20:47:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Oct 2008 20:47:57 +0000 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv10588 Modified Files: input-editing.lisp Log Message: Spelling fixes from Mike Watters. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/07 20:20:04 1.74 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/10/23 20:47:57 1.75 @@ -28,7 +28,7 @@ (in-package :clim-internals) (defvar *use-goatee* nil - "I true, use the Goatee editing component instead of Drei. The + "If true, use the Goatee editing component instead of Drei. The Goatee component is faster and more mature than Drei.") (defvar *activation-gestures* nil From thenriksen at common-lisp.net Thu Oct 23 20:49:13 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Oct 2008 20:49:13 +0000 Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv10847/Backends/CLX Modified Files: port.lisp Log Message: `decode-x-button-code' fix from Mike Watters. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/10/20 17:31:41 1.135 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/10/23 20:49:12 1.136 @@ -615,10 +615,11 @@ +pointer-wheel-up+ +pointer-wheel-down+ +pointer-wheel-left+ - +pointer-wheel-right+))) - (and (> code 0) - (<= code (length button-mapping)) - (aref button-mapping (1- code))))) + +pointer-wheel-right+)) + (code (1- code))) + (when (and (>= code 0) + (< code (length button-mapping))) + (aref button-mapping code)))) ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1, ;; section 4.1.5: From thenriksen at common-lisp.net Thu Oct 23 20:49:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Oct 2008 20:49:41 +0000 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv10938 Modified Files: commands.lisp Log Message: MAP-OVER-COMMAND-TABLE-TRANSLATORS and ADD-ACTUAL-PRESENTATION-TRANSLATOR-TO-COMMAND-TABLE from Mike Watters. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/20 07:19:10 1.79 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/10/23 20:49:41 1.80 @@ -480,6 +480,39 @@ (map-over-command-table-menu-items function table)))) (values))) +(defun map-over-command-table-translators + (function command-table &key (inherited t)) + (flet ((map-func (table) + (maphash #'(lambda (k v) + (declare (ignore k)) + (funcall function v)) + (slot-value + (presentation-translators table) + 'translators)))) + (let ((command-table (find-command-table command-table))) + (if inherited + (apply-with-command-table-inheritance #'map-func command-table) + (map-func command-table))))) + +;(defun add-presentation-translator-to-command-table +; (command-table translator-name &key (errorp t))) +; - fixme; spec says this fun is given a translator name, but that +; find-presentation-translator needs a translator name and a command +; table designator +(defun add-actual-presentation-translator-to-command-table + (command-table translator &key (errorp t)) + (let ((translators + (presentation-translators + (find-command-table command-table)))) + (when (and errorp + (second + (multiple-value-list + (gethash (name translator) + (slot-value translators 'translators))))) + (error 'command-already-present + :command-table-name command-table)) + (add-translator translators translator))) + ;; At this point we should still see the gesture name as supplied by the ;; programmer in 'gesture' (defun %add-keystroke-item (command-table gesture item errorp) From thenriksen at common-lisp.net Thu Oct 23 20:49:58 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Oct 2008 20:49:58 +0000 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv11017 Modified Files: stream-output.lisp Log Message: SEOS-WRITE-STRING fix wrt. zero-length strings from Mike Watters. --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2008/04/15 19:28:04 1.62 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2008/10/23 20:49:58 1.63 @@ -287,7 +287,9 @@ :text-style text-style) while (<= sub-width delta) finally (return (1- i))))) - + (when (eql end 0) + (return-from seos-write-string)) + (with-slots (baseline height vspace) stream (multiple-value-bind (cx cy) (stream-cursor-position stream) (when (> new-baseline baseline) From ahefner at common-lisp.net Thu Oct 23 20:54:54 2008 From: ahefner at common-lisp.net (ahefner) Date: Thu, 23 Oct 2008 20:54:54 +0000 Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory cl-net:/tmp/cvs-serv11848 Modified Files: dev-commands.lisp util.lisp Log Message: Listener fixes from Willem Broekema. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/22 23:58:12 1.63 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/23 20:54:53 1.64 @@ -681,6 +681,7 @@ #+openmcl-partial-mop (openmcl-mop:specializer-direct-generic-functions specializer) #+scl (clos:specializer-direct-generic-functions specializer) + #+allegro (mop: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 --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/22 23:58:12 1.27 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/23 20:54:54 1.28 @@ -31,7 +31,7 @@ (defun directoryp (path) "Determine if PATH designates a directory" - #+allegro (excl:file-directory-p pathname) + #+allegro (excl:file-directory-p path) #-allegro (flet ((f (x) (if (eq x :unspecific) nil x))) (if (or (f (pathname-name path))