From ahefner at common-lisp.net  Wed Jun  3 04:07:48 2009
From: ahefner at common-lisp.net (ahefner)
Date: Wed, 03 Jun 2009 00:07:48 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MBhlU-00015q-Pe@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv4027

Modified Files:
	pixmap.lisp 
Log Message:
Define sheet-direct-mirror on pixmaps (patch from Evgeny M. Zubok)


--- /project/mcclim/cvsroot/mcclim/pixmap.lisp	2003/03/21 21:36:59	1.7
+++ /project/mcclim/cvsroot/mcclim/pixmap.lisp	2009/06/03 04:07:48	1.8
@@ -88,3 +88,6 @@
    (transform-region
     (sheet-device-transformation pixmap)
     (medium-clipping-region (pixmap-medium pixmap)))))
+
+(defmethod sheet-direct-mirror ((pixmap mirrored-pixmap))
+  (port-lookup-mirror (port pixmap) pixmap))




From ahefner at common-lisp.net  Wed Jun  3 20:33:16 2009
From: ahefner at common-lisp.net (ahefner)
Date: Wed, 03 Jun 2009 16:33:16 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MBx9A-00065B-BB@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv19226

Modified Files:
	panes.lisp regions.lisp text-selection.lisp 
Log Message:
Handle selection-notify-events in the text gadget and input editor.
For communicating with the input editor, signal and handle a 
selection-notify condition from the lower level event handler (I can't
think of a better approach to communicating across the layers). Disable
the old default of pasting by synthesizing keypress events, but make it
available via paste-as-keypress-mixin.



--- /project/mcclim/cvsroot/mcclim/panes.lisp	2008/12/19 08:58:14	1.194
+++ /project/mcclim/cvsroot/mcclim/panes.lisp	2009/06/03 20:33:16	1.195
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.194 2008/12/19 08:58:14 ahefner Exp $
+;;; $Id: panes.lisp,v 1.195 2009/06/03 20:33:16 ahefner Exp $
 
 (in-package :clim-internals)
 
@@ -2597,7 +2597,7 @@
       (setf (cursor-position cursor) (values 0 0))))
   (scroll-extent pane 0 0)  
   (change-space-requirements pane :width 0 :height 0))
-  
+
 
 (defmethod window-refresh ((pane clim-stream-pane))
   (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)    
@@ -2684,9 +2684,9 @@
 
 ;;; INTERACTOR PANES
 
-(defclass interactor-pane (clim-stream-pane 
-                           cut-and-paste-mixin
-                           mouse-wheel-scroll-mixin)
+(defclass interactor-pane (cut-and-paste-mixin
+                           mouse-wheel-scroll-mixin
+                           clim-stream-pane)
   ()
   (:default-initargs :display-time nil
                      :end-of-line-action :scroll
@@ -2714,9 +2714,9 @@
 
 ;;; APPLICATION PANES
 
-(defclass application-pane (clim-stream-pane 
-                            cut-and-paste-mixin
-                            mouse-wheel-scroll-mixin)
+(defclass application-pane (cut-and-paste-mixin
+                            mouse-wheel-scroll-mixin
+                            clim-stream-pane)
   ()
   (:default-initargs :display-time :command-loop
                      :scroll-bars t))
@@ -2838,9 +2838,9 @@
 
 ;;; 29.4.5 Creating a Standalone CLIM Window
 
-(defclass window-stream (clim-stream-pane
-                         cut-and-paste-mixin
-                         mouse-wheel-scroll-mixin)
+(defclass window-stream (cut-and-paste-mixin
+                         mouse-wheel-scroll-mixin
+                         clim-stream-pane)
   ())
 
 (defmethod close ((stream window-stream)
--- /project/mcclim/cvsroot/mcclim/regions.lisp	2008/01/23 22:37:08	1.38
+++ /project/mcclim/cvsroot/mcclim/regions.lisp	2009/06/03 20:33:16	1.39
@@ -4,7 +4,7 @@
 ;;;   Created: 1998-12-02 19:26
 ;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
 ;;;   License: LGPL (See file COPYING for details).
-;;;       $Id: regions.lisp,v 1.38 2008/01/23 22:37:08 thenriksen Exp $
+;;;       $Id: regions.lisp,v 1.39 2009/06/03 20:33:16 ahefner Exp $
 ;;; --------------------------------------------------------------------------------------
 ;;;  (c) copyright 1998,1999,2001 by Gilbert Baumann
 ;;;  (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr)
@@ -89,6 +89,9 @@
 (defvar +everywhere+ (make-instance 'everywhere-region))
 (defvar +nowhere+ (make-instance 'nowhere-region))
 
+(defmethod bounding-rectangle* ((x nowhere-region))
+  (values 0 0 0 0))
+
 ;; 2.5.1.1 Region Predicates in CLIM
 
 (defgeneric region-equal (region1 region2))
--- /project/mcclim/cvsroot/mcclim/text-selection.lisp	2005/11/28 13:04:55	1.7
+++ /project/mcclim/cvsroot/mcclim/text-selection.lisp	2009/06/03 20:33:16	1.8
@@ -60,7 +60,7 @@
   "Background ink to use for marked stuff.")
 
 
-;;;; Text Selection "Protocol"
+;;;; Text Selection Protocol
 
 (defgeneric release-selection (port &optional time)
   (:documentation "Relinquish ownership of the selection."))
@@ -153,7 +153,12 @@
    (point-1-y  :initform nil)
    (point-2-x  :initform nil)
    (point-2-y  :initform nil)
-   (dragging-p :initform nil) ))
+   (dragging-p :initform nil)))
+
+(defclass paste-as-keypress-mixin ()
+  ()
+  (:documentation "Implements the old McCLIM behavior of pasting via a
+  sequence of key press events. You couldn't possibly want this."))
 
 (defmethod handle-repaint :around ((pane cut-and-paste-mixin) region)
   (with-slots (markings) pane
@@ -174,29 +179,23 @@
                           ((medium-background medium) *marked-background*))
                      (call-next-method pane R))))))))))
 
-
-(defmethod bounding-rectangle* ((x (eql +nowhere+)))
-  (values 0 0 0 0))
-
-
-(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#)
+(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
                            (event pointer-button-press-event))  
   (if (eql (event-modifier-state event) +shift-key+)
       (eos/shift-click pane event)
       (call-next-method)))
 
-(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#)
+(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
                            (event pointer-button-release-event))
   (if (eql (event-modifier-state event) +shift-key+)
       (eos/shift-release pane event)
       (call-next-method)))
 
-(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#)
+(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
                            (event pointer-motion-event))
   (with-slots (point-1-x dragging-p) pane
     (if (and (eql (event-modifier-state event) +shift-key+))
-        (when dragging-p
-          (eos/shift-drag pane event))
+        (when dragging-p (eos/shift-drag pane event))
         (call-next-method))))
 
 
@@ -283,7 +282,7 @@
     (rotatef bx1 bx2))
   (let ((*lines* nil)
         (*all-lines* nil))
-    (map-over-text record ;(stream-output-history stream)
+    (map-over-text record
                    (lambda (x y string ts record full-record)
                      (let ((q (assoc y *lines*)))
                        (unless q
@@ -311,7 +310,6 @@
     (let ((start-i 0)
           (start-record (fifth (cadar *lines*)))
           (end-i 0)
-         ; end-record
           (end-record (fifth (cadar (last *lines*)))))
       
       (loop for chunk in (cdr (first *lines*)) do
@@ -323,8 +321,10 @@
               (setf start-i i
                     start-record record)))))
 
-      ;; Finally in the last line find the index farthest to the left which still is greater than bx2.
-      ;; Or put differently: Search from the left and while we are still in bounds maintain end-i and end-record.
+      ;; Finally in the last line find the index farthest to the left
+      ;; which still is greater than bx2.  Or put differently: Search
+      ;; from the left and while we are still in bounds maintain end-i
+      ;; and end-record.
       (loop for chunk in (cdr (car (last *lines*))) do
         (destructuring-bind (x y string ts record full-record) chunk
           (declare (ignorable x y string ts record full-record))
@@ -375,21 +375,24 @@
 
 ;;;; Selections Events
 
-(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#)
+(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
                                    (event selection-clear-event))  
   (pane-clear-markings pane (event-timestamp event)))
 
-(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#)
+(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
                                    (event selection-request-event))  
   (send-selection (port pane) event (fetch-selection pane)))
 
+(define-condition selection-notify ()
+  ((event :reader event-of :initarg :event)))
 
+(defmethod handle-event ((pane cut-and-paste-mixin)
+                         (event selection-notify-event))
+  (signal 'selection-notify :event event))
 
-(defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#)
+(defmethod dispatch-event :around ((pane paste-as-keypress-mixin)
                                    (event selection-notify-event))
   (let ((matter (get-selection-from-event (port pane) event)))
-    #+NIL
-    (format *trace-output* "Got ~S.~%" matter)
     (loop for c across matter do
          (dispatch-event pane
                          (make-instance 'key-press-event




From ahefner at common-lisp.net  Wed Jun  3 20:33:16 2009
From: ahefner at common-lisp.net (ahefner)
Date: Wed, 03 Jun 2009 16:33:16 -0400
Subject: [mcclim-cvs] CVS mcclim/Drei
Message-ID: <E1MBx9A-00065U-Ne@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Drei
In directory cl-net:/tmp/cvs-serv19226/Drei

Modified Files:
	drei-clim.lisp input-editor.lisp 
Log Message:
Handle selection-notify-events in the text gadget and input editor.
For communicating with the input editor, signal and handle a 
selection-notify condition from the lower level event handler (I can't
think of a better approach to communicating across the layers). Disable
the old default of pasting by synthesizing keypress events, but make it
available via paste-as-keypress-mixin.



--- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp	2008/10/23 20:47:57	1.46
+++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp	2009/06/03 20:33:16	1.47
@@ -292,6 +292,15 @@
 gesture is, for example, one that is not simply a click on a
 modifier key."))
 
+(defun propagate-changed-value (drei)
+  (when (modified-p (view drei))
+    (when (gadget-value-changed-callback drei)
+      (value-changed-callback drei
+                              (gadget-client drei)
+                              (gadget-id drei)
+                              (gadget-value drei)))
+    (setf (modified-p (view drei)) nil)))
+
 (defmethod handle-gesture ((drei drei-gadget-pane) gesture)
   (let ((*command-processor* drei)
         (*abort-gestures* *esa-abort-gestures*)
@@ -303,13 +312,7 @@
         (abort-gesture ()
           (display-message "Aborted")))
       (display-drei drei :redisplay-minibuffer t)
-      (when (modified-p (view drei))
-        (when (gadget-value-changed-callback drei)
-          (value-changed-callback drei
-                                  (gadget-client drei)
-                                  (gadget-id drei)
-                                  (gadget-value drei)))
-        (setf (modified-p (view drei)) nil)))))
+      (propagate-changed-value drei))))
 
 ;;; This is the method that functions as the entry point for all Drei
 ;;; gadget logic.
@@ -321,6 +324,16 @@
           (with-bound-drei-special-variables (gadget :prompt (format nil "~A " (gesture-name gesture)))
             (handle-gesture gadget gesture)))))))
 
+(defmethod handle-event ((gadget drei-gadget-pane)
+                         (event clim-backend:selection-notify-event))
+  ;; Cargo-culted from above:
+  (unless (and (currently-processing-p gadget) (directly-processing-p gadget))
+    (letf (((currently-processing-p gadget) t))
+      (insert-sequence (point (view gadget)) 
+                       (clim-backend:get-selection-from-event (port gadget) event))
+      (display-drei gadget :redisplay-minibuffer t)
+      (propagate-changed-value gadget))))
+
 (defmethod handle-event :before 
     ((gadget drei-gadget-pane) (event pointer-button-press-event))
   (let ((previous (stream-set-input-focus gadget)))
--- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp	2008/06/29 23:36:27	1.49
+++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp	2009/06/03 20:33:16	1.50
@@ -586,6 +586,13 @@
                                                       finally (return 0))
                                                 t t)
                  (handler-case (process-gestures-or-command drei)
+                   (climi::selection-notify (c)
+                     (let* ((event (climi::event-of c))
+                            (sheet (event-sheet event))
+                            (port  (port sheet)))
+                       (when (eq *standard-input* sheet)
+                         (insert-sequence (point (view drei))
+                                          (clim-backend:get-selection-from-event port event)))))
                    (unbound-gesture-sequence (c)
                      (display-message "~A is unbound" (gesture-name (gestures c))))
                    (abort-gesture (c)




From ahefner at common-lisp.net  Wed Jun  3 20:38:17 2009
From: ahefner at common-lisp.net (ahefner)
Date: Wed, 03 Jun 2009 16:38:17 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MBxE1-0006YK-KG@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv24386

Modified Files:
	medium.lisp 
Log Message:
Change *default-text-style* to a sans-serif face.


--- /project/mcclim/cvsroot/mcclim/medium.lisp	2008/01/21 01:26:42	1.64
+++ /project/mcclim/cvsroot/mcclim/medium.lisp	2009/06/03 20:38:15	1.65
@@ -158,7 +158,7 @@
        (equal (text-style-face style1) (text-style-face style2))
        (eql (text-style-size style1) (text-style-size style2))))
 
-(defconstant *default-text-style* (make-text-style :fix :roman :normal))
+(defconstant *default-text-style* (make-text-style :sans-serif :roman :normal))
 (defconstant *undefined-text-style* *default-text-style*)
 
 (defconstant *smaller-sizes* '(:huge :very-large :large :normal




From rstrandh at common-lisp.net  Sun Jun  7 06:56:50 2009
From: rstrandh at common-lisp.net (rstrandh)
Date: Sun, 07 Jun 2009 02:56:50 -0400
Subject: [mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats
Message-ID: <E1MDCJG-0000aj-BT@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats
In directory cl-net:/tmp/cvs-serv2246

Modified Files:
	jpeg.lisp 
Log Message:
Patch from Cyrus Harmon to make it possible to read grayscale jpeg
files.


--- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp	2008/04/14 16:46:30	1.1
+++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp	2009/06/07 06:56:49	1.2
@@ -23,22 +23,32 @@
 (in-package :clim-internals)
 
 (define-bitmap-file-reader :jpeg (pathname)
-  (with-open-file (stream pathname :direction :input)
-    (multiple-value-bind (rgb height width)
-        (jpeg::decode-image stream)
-      (let* ((array (make-array (list height width)
-                     :element-type '(unsigned-byte 32))))
-        (dotimes (x width)
-          (dotimes (y height)
-            (let ((blue (aref rgb (+ (* x 3) (* y width 3))))
-                  (green (aref rgb (+ (* x 3) (* y width 3) 1)))
-                  (red (aref rgb (+ (* x 3) (* y width 3) 2))))
-              (setf (aref array y x)
-                    (dpb red (byte 8 0)
-                         (dpb green (byte 8 8)
-                              (dpb blue (byte 8 16)
-                                   (dpb (- 255 0) (byte 8 24) 0))))))))
-        array))))
+  (multiple-value-bind (rgb height width ncomp)
+      (jpeg:decode-image pathname)
+    (let* ((array (make-array (list height width)
+                              :element-type '(unsigned-byte 32))))
+      (case ncomp
+        (3
+         (dotimes (x width)
+           (dotimes (y height)
+             (let ((blue (aref rgb (+ (* x 3) (* y width 3))))
+                   (green (aref rgb (+ (* x 3) (* y width 3) 1)))
+                   (red (aref rgb (+ (* x 3) (* y width 3) 2))))
+               (setf (aref array y x)
+                     (dpb red (byte 8 0)
+                          (dpb green (byte 8 8)
+                               (dpb blue (byte 8 16)
+                                    (dpb (- 255 0) (byte 8 24) 0)))))))))
+        (1
+         (dotimes (x width)
+           (dotimes (y height)
+             (let ((gray (aref rgb (+ x (* y width)))))
+               (setf (aref array y x)
+                     (dpb gray (byte 8 0)
+                          (dpb gray (byte 8 8)
+                               (dpb gray (byte 8 16)
+                                    (dpb (- 255 0) (byte 8 24) 0))))))))))
+      array)))
 
 (define-bitmap-file-reader :jpg (pathname)
   (read-bitmap-file pathname :format :jpeg))




From ahefner at common-lisp.net  Sun Jun  7 08:47:43 2009
From: ahefner at common-lisp.net (ahefner)
Date: Sun, 07 Jun 2009 04:47:43 -0400
Subject: [mcclim-cvs] CVS mcclim/Apps/Listener
Message-ID: <E1MDE2Z-0008O1-1M@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory cl-net:/tmp/cvs-serv32228

Modified Files:
	dev-commands.lisp listener.lisp package.lisp 
Added Files:
	asdf.lisp 
Log Message:
ASDF commands for the listener.



--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp	2009/04/14 07:36:42	1.66
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp	2009/06/07 08:47:39	1.67
@@ -24,7 +24,9 @@
 (define-command-table application-commands)
 
 (define-command-table lisp-dev-commands :inherit-from nil) ;; Translators live here
-(define-command-table lisp-commands :inherit-from (lisp-dev-commands))
+(define-command-table lisp-commands 
+    :inherit-from (lisp-dev-commands)
+    :menu (("ASDF" :menu asdf-commands)))
 
 (define-command-table show-commands :inherit-from (lisp-dev-commands))
 
@@ -34,7 +36,6 @@
 
 (define-command-table directory-stack-commands)
 
-
 ;;; Presentation types
 
 (define-presentation-type specializer () :inherit-from 'expression)
@@ -1241,11 +1242,6 @@
           "Load"
           (format nil "Load ~A" pathname)))
 
-(defmethod mime-type-to-command ((mime-type text/x-lisp-system) pathname)
-  (values `(com-load-file ,pathname)
-          "Load System"
-          (format nil "Load System ~A" pathname)))
-
 ;; I've taken to doing translator documentation exactly opposite of how the CLIM
 ;; spec seems to intend. The spec says that the pointer-documentation should be
 ;; short and quickly computed, and the documentation should be longer and more
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp	2008/12/07 20:24:44	1.44
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp	2009/06/07 08:47:40	1.45
@@ -96,11 +96,15 @@
                                 :display-time :command-loop :end-of-line-action :allow)))
   (:top-level (default-frame-top-level :prompt 'print-listener-prompt))
   (:command-table (listener
-                   :inherit-from (application-commands lisp-commands filesystem-commands show-commands)
-                   :menu (("Application" :menu application-commands)
-                          ("Lisp"        :menu lisp-commands)
-                          ("Filesystem"  :menu filesystem-commands)
-                          ("Show"        :menu show-commands))))
+                   :inherit-from (application-commands
+                                  lisp-commands
+                                  asdf-commands
+                                  filesystem-commands
+                                  show-commands)
+                   :menu (("Listener"   :menu application-commands)
+                          ("Lisp"       :menu lisp-commands)
+                          ("Filesystem" :menu filesystem-commands)
+                          ("Show"       :menu show-commands))))
   (:disabled-commands com-pop-directory com-drop-directory com-swap-directory)
   (:menu-bar t)
   (:layouts (default
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp	2008/04/26 21:19:59	1.4
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp	2009/06/07 08:47:40	1.5
@@ -8,7 +8,7 @@
 (in-package :clim-listener)
 
 (eval-when (:load-toplevel)
-;  (format t "~&~%!@#%^!@#!@ ... ~A~%~%" *load-truename*)
-  (defparameter *icon-path* (merge-pathnames
-                             #P"icons/"
-                             (load-time-value (or #.*compile-file-pathname* *load-pathname*)))))
+  (defparameter *icon-path* 
+    (merge-pathnames
+     #P"icons/"
+     (load-time-value (or #.*compile-file-pathname* *load-pathname*)))))

--- /project/mcclim/cvsroot/mcclim/Apps/Listener/asdf.lisp	2009/06/07 08:47:43	NONE
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/asdf.lisp	2009/06/07 08:47:43	1.1
;;; This is a lisp listener.

;;; (C) Copyright 2009 by Andy Hefner (ahefner at gmail.com)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :clim-listener)

;;;; CLIM defintions for interacting with ASDF

(define-command-table asdf-commands :inherit-from nil)

(define-presentation-type asdf-system ())
(define-presentation-type asdf-system-definition () :inherit-from 'pathname)

(defclass asdf-attribute-view (textual-view)
  ((ignorable-attributes :reader ignorable-attributes
                         :initform nil :initarg :ignore)
   (note-unloaded :reader note-unloaded :initform nil :initarg :note-unloaded)
   (default-label :reader default-attr-label :initform "" :initarg :default)))

(defmethod ignorable-attributes (view) nil)
(defmethod note-unloaded (view) nil)
(defmethod default-attr-label (view) "")

(defun asdf-loaded-systems ()
  "Retrieve a list of loaded systems from ASDF"
  (let (systems)
    (maphash
     (lambda (name foo.system)
       (declare (ignore name))
       (push (cdr foo.system) systems))
     asdf::*defined-systems*)
    systems))

(defun asdf-get-central-registry ()
  asdf::*central-registry*)

(defun asdf-registry-system-files ()
  "Retrieve the list of unique pathnames contained within the ASDF registry folders"
  (remove-duplicates
   (remove-if-not #'pathname-name 
                  (apply #'concatenate 'list
                         (mapcar 
                          (lambda (form)
                            (list-directory
                             (merge-pathnames (eval form) #p"*.asd")))
                          (asdf-get-central-registry))))
   :test #'equal))

(defun asdf-system-name (system)
  (slot-value system 'asdf::name))

(defun asdf-operation-pretty-name (op)
  (case op
    (asdf:compile-op "compiled")
    (asdf:load-op    "loaded")
    (:unloaded       "unloaded")
    (otherwise   (prin1-to-string op))))

(defun asdf-system-history (system)
  (let (history)
    (maphash (lambda (operation time)
               (declare (ignore time))
               (push operation history))
             (slot-value system 'asdf::operation-times))
    (nreverse history)))

(define-presentation-method presentation-typep (object (type asdf-system))
  (typep object 'asdf:system))

(define-presentation-method present (object (type asdf-system) stream
                                            (view textual-view)
                                            &key acceptably)
  (if acceptably
      (princ (asdf-system-name object) stream )
      (let* ((history (asdf-system-history object))
             (loaded-p (find 'asdf:load-op history))
             (eff-history (set-difference history (ignorable-attributes view))))
        (when (and (note-unloaded view) (not loaded-p))
          (push :unloaded eff-history))
        (format stream "~A~A"
                (asdf-system-name object)
                (if (null eff-history)
                    (default-attr-label view)
                    (format nil " (~{~a~^, ~})"
                            (mapcar 'asdf-operation-pretty-name eff-history)))))))
  
(define-presentation-method accept ((type asdf-system) stream
                                    (view textual-view) &key)
  (multiple-value-bind (object success)
      (completing-from-suggestions (stream)
        (dolist (system (asdf-loaded-systems))
          (suggest (asdf-system-name system) system)))
    (if success
        object
        (simple-parse-error "Unknown system"))))

(define-command (com-list-systems :name "List Systems"
                                  :command-table asdf-commands
                                  :menu t)
    ()
  (format-items 
   (asdf-loaded-systems)
   :printer (lambda (item stream)
              (present item 'asdf-system
                       :stream stream
                       :view (make-instance 'asdf-attribute-view
                                            :note-unloaded t
                                            :ignore '(asdf:compile-op asdf:load-op))))
   :presentation-type 'asdf-system))

(define-command (com-show-available-systems :name "Show System Files"
                                            :command-table asdf-commands
                                            :menu t)
    ()
  (format-items (asdf-registry-system-files)                
                :presentation-type 'asdf-system-definition))

(define-command (com-operate-on-system :name "Operate On System"
                                       :command-table asdf-commands
                                       :menu t)
    ((system '(type-or-string asdf-system) :prompt "system")
     (operation '(member asdf::compile-op asdf::load-op)
                :default 'asdf::load-op
                :prompt "operation"))
  (asdf:oos operation system))

(define-command (com-load-system :name "Load System"
                                 :command-table asdf-commands
                                 :menu t)
    ((system '(type-or-string asdf-system) :prompt "system"))
  (asdf:oos 'asdf:compile-op system)
  (asdf:oos 'asdf:load-op system))

(defmethod mime-type-to-command ((mime-type text/x-lisp-system) pathname)  
  (values `(com-load-system ,pathname)
          "Load System"
          (format nil "Load System ~A" pathname)))



From ahefner at common-lisp.net  Sun Jun  7 08:48:02 2009
From: ahefner at common-lisp.net (ahefner)
Date: Sun, 07 Jun 2009 04:48:02 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MDE2r-0008P3-5r@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv32296

Modified Files:
	clim-listener.asd 
Log Message:
ASDF commands for the listener.



--- /project/mcclim/cvsroot/mcclim/clim-listener.asd	2008/10/22 23:26:58	1.5
+++ /project/mcclim/cvsroot/mcclim/clim-listener.asd	2009/06/07 08:48:00	1.6
@@ -16,8 +16,11 @@
                (: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" "appearance" "icons" "file-types" "util"))
+               (:file "asdf" :depends-on ("package"))
+               (:file "dev-commands" 
+                      :depends-on ("package" "appearance" "icons" "file-types" "util" "asdf"))
                (:file "wholine" :depends-on ("package" "dev-commands" "util"))
-               (:file "listener" :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util"))
+               (:file "listener"
+                      :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util"))
                #+CMU (:file "cmu-hacks" :depends-on ("package"))))))
 




From rstrandh at common-lisp.net  Sun Jun  7 10:32:19 2009
From: rstrandh at common-lisp.net (rstrandh)
Date: Sun, 07 Jun 2009 06:32:19 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MDFfn-0006y1-2s@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv26737

Modified Files:
	mcclim-gif-bitmaps.asd mcclim-jpeg-bitmaps.asd 
Log Message:
Patch from Cyrus Harmon that removes two unnecessary packages, and which
fixes a typo in mcclim-jpeg-bitmaps. 



--- /project/mcclim/cvsroot/mcclim/mcclim-gif-bitmaps.asd	2008/04/14 16:46:37	1.1
+++ /project/mcclim/cvsroot/mcclim/mcclim-gif-bitmaps.asd	2009/06/07 10:32:18	1.2
@@ -18,12 +18,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
 ;;; Boston, MA  02111-1307  USA.
 
-(cl:defpackage :mcclim-gif-bitmaps.system
-  (:use :asdf :cl))
-
-(cl:in-package :mcclim-gif-bitmaps.system)
-
-(defsystem :mcclim-gif-bitmaps
-           :description "Support for GIF images in McCLIM bitmap reading functions."
-           :depends-on (:mcclim :skippy)
-           :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/gif")))
+(asdf:defsystem :mcclim-gif-bitmaps
+  :description "Support for GIF images in McCLIM bitmap reading functions."
+  :depends-on (:mcclim :skippy)
+  :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/gif")))
--- /project/mcclim/cvsroot/mcclim/mcclim-jpeg-bitmaps.asd	2008/04/14 16:46:37	1.1
+++ /project/mcclim/cvsroot/mcclim/mcclim-jpeg-bitmaps.asd	2009/06/07 10:32:18	1.2
@@ -18,12 +18,8 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
 ;;; Boston, MA  02111-1307  USA.
 
-(cl:defpackage :mcclim-gif-bitmaps.system
-  (:use :asdf :cl))
+(asdf:defsystem :mcclim-jpeg-bitmaps
+  :description "Support for JPEG images in McCLIM bitmap reading functions."
+  :depends-on (:mcclim :cl-jpeg)
+  :components ((:file "jpeg" :pathname #P"Extensions/Bitmap-formats/jpeg")))
 
-(cl:in-package :mcclim-gif-bitmaps.system)
-
-(defsystem :mcclim-jpeg-bitmaps
-           :description "Support for JPEG images in McCLIM bitmap reading functions."
-           :depends-on (:mcclim :cl-jpeg)
-           :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/jpeg")))




From rstrandh at common-lisp.net  Mon Jun  8 14:39:57 2009
From: rstrandh at common-lisp.net (rstrandh)
Date: Mon, 08 Jun 2009 10:39:57 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MDg0z-0006uo-4N@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv26572

Added Files:
	mcclim-tiff-bitmaps.asd 
Log Message:
Tiff bitmap formats from Cyrus Harmon.



--- /project/mcclim/cvsroot/mcclim/mcclim-tiff-bitmaps.asd	2009/06/08 14:39:57	NONE
+++ /project/mcclim/cvsroot/mcclim/mcclim-tiff-bitmaps.asd	2009/06/08 14:39:57	1.1
;;; -*- Mode: Lisp -*-

;;;  (c) copyright 2009 by 
;;;           Cyrus Harmon (ch-lisp at bobobeach.com)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(asdf:defsystem :mcclim-tiff-bitmaps
           :description "Support for TIFF images in McCLIM bitmap reading functions."
           :depends-on (:mcclim :retrospectiff)
           :components ((:file "tiff" :pathname #P"Extensions/Bitmap-formats/tiff")))



From rstrandh at common-lisp.net  Mon Jun  8 14:39:57 2009
From: rstrandh at common-lisp.net (rstrandh)
Date: Mon, 08 Jun 2009 10:39:57 -0400
Subject: [mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats
Message-ID: <E1MDg0z-0006ux-9N@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats
In directory cl-net:/tmp/cvs-serv26572/Extensions/Bitmap-formats

Added Files:
	tiff.lisp 
Log Message:
Tiff bitmap formats from Cyrus Harmon.



--- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/tiff.lisp	2009/06/08 14:39:57	NONE
+++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/tiff.lisp	2009/06/08 14:39:57	1.1
;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*-

;;;  (c) copyright 2009 by 
;;;           Cyrus Harmon (ch-lisp at bobobeach.com)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

(in-package :clim-internals)

(define-bitmap-file-reader :tiff (pathname)
  (let ((tiff-image (tiff:read-tiff-file pathname)))
    (with-accessors ((height tiff:tiff-image-length)
                     (width tiff:tiff-image-width)
                     (ncomp tiff:tiff-image-samples-per-pixel)
                     (data tiff:tiff-image-data))
        tiff-image
      (let* ((array (make-array (list height width)
                                :element-type '(unsigned-byte 32))))
        (case ncomp
          (3
           (dotimes (x width)
             (dotimes (y height)
               (let ((red (aref data (+ (* x 3) (* y width 3))))
                     (green (aref data (+ (* x 3) (* y width 3) 1)))
                     (blue (aref data (+ (* x 3) (* y width 3) 2))))
                 (setf (aref array y x)
                       (dpb red (byte 8 0)
                            (dpb green (byte 8 8)
                                 (dpb blue (byte 8 16)
                                      (dpb (- 255 0) (byte 8 24) 0)))))))))
          (1
           (dotimes (x width)
             (dotimes (y height)
               (let ((gray (aref data (+ x (* y width)))))
                 (setf (aref array y x)
                       (dpb gray (byte 8 0)
                            (dpb gray (byte 8 8)
                                 (dpb gray (byte 8 16)
                                      (dpb (- 255 0) (byte 8 24) 0))))))))))
        array))))

(define-bitmap-file-reader :tif (pathname)
  (read-bitmap-file pathname :format :tiff))



From ahefner at common-lisp.net  Sun Jun 14 18:33:47 2009
From: ahefner at common-lisp.net (ahefner)
Date: Sun, 14 Jun 2009 14:33:47 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MFuWY-0000sb-HI@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv3360

Modified Files:
	text-editor-gadget.lisp 
Log Message:
Fix :fixed text style choice.


--- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp	2008/11/09 19:52:44	1.12
+++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp	2009/06/14 18:33:45	1.13
@@ -40,7 +40,7 @@
 ;;; are defined here.
 
 (defparameter *default-text-field-text-style*
-  (make-text-style :fixed :roman :normal))
+  (make-text-style :fix :roman :normal))
 
 (defclass editor-substrate-mixin (value-gadget)
   ((activation-gestures :reader activation-gestures




From ahefner at common-lisp.net  Sun Jun 14 18:37:39 2009
From: ahefner at common-lisp.net (ahefner)
Date: Sun, 14 Jun 2009 14:37:39 -0400
Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype
Message-ID: <E1MFuaJ-0000vm-BU@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype
In directory cl-net:/tmp/cvs-serv3498

Modified Files:
	xrender-fonts.lisp 
Log Message:
Transform :fixed to :fix during font lookup. Apparently necessary to run
on a machine without fontconfig.


--- /project/mcclim/cvsroot/mcclim/Experimental/freetype/xrender-fonts.lisp	2008/01/31 08:58:20	1.1
+++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/xrender-fonts.lisp	2009/06/14 18:37:39	1.2
@@ -439,6 +439,7 @@
                  (setf face (or face :roman))
                  (setf family (or family :fix))
                  (setf size (or size :normal))
+                 (when (eq family :fixed) (setf family :fix))                   
                  (cond (size
                         (setf size (getf *sizes* size size))
                         (let ((val (gethash (list display family face size) *display-face-hash*)))




From ahefner at common-lisp.net  Tue Jun 16 05:15:37 2009
From: ahefner at common-lisp.net (ahefner)
Date: Tue, 16 Jun 2009 01:15:37 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MGR1F-0001zh-58@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv7646

Modified Files:
	recording.lisp 
Log Message:
Fix bounding rectangle computation for open polygons. 



--- /project/mcclim/cvsroot/mcclim/recording.lisp	2008/08/19 15:56:50	1.142
+++ /project/mcclim/cvsroot/mcclim/recording.lisp	2009/06/16 05:15:35	1.143
@@ -1508,8 +1508,7 @@
 				 (if (eql i final-index)
 				     (values final-xn final-yn)
 				     (values (svref coord-seq (+ i 2))
-					     (svref coord-seq (+ i
-								 3)))))
+					     (svref coord-seq (+ i 3)))))
 			   (multiple-value-bind (ex1 ey1)
 			       (normalize-coords (- x xp) (- y yp))
 			     (multiple-value-bind (ex2 ey2)
@@ -1559,8 +1558,8 @@
 				 (maxf max-y (+ y ny))))))))
 	       (unless closed
 		 (multiple-value-bind (x y)
-		     (values (svref coord-seq final-index)
-			     (svref coord-seq (1+ final-index)))
+		     (values (svref coord-seq (- len 2))
+			     (svref coord-seq (- len 1)))
 		   (minf min-x (- x border))
 		   (minf min-y (- y border))
 		   (maxf max-x (+ x border))