From gbaumann at common-lisp.net  Tue Nov 22 11:40:03 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Tue, 22 Nov 2005 12:40:03 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/transforms.lisp 
Message-ID: <20051122114003.0A61A880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv23878

Modified Files:
	transforms.lisp 
Log Message:
Some times we would build standard-translations, that really
should be the identity transformation.
Date: Tue Nov 22 12:40:02 2005
Author: gbaumann

Index: mcclim/transforms.lisp
diff -u mcclim/transforms.lisp:1.29 mcclim/transforms.lisp:1.30
--- mcclim/transforms.lisp:1.29	Wed Feb  2 11:18:58 2005
+++ mcclim/transforms.lisp	Tue Nov 22 12:40:02 2005
@@ -4,7 +4,7 @@
 ;;;   Created: 1998-09-29
 ;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
 ;;;   License: LGPL (See file COPYING for details).
-;;;       $Id: transforms.lisp,v 1.29 2005/02/02 10:18:58 tmoore Exp $
+;;;       $Id: transforms.lisp,v 1.30 2005/11/22 11:40:02 gbaumann Exp $
 ;;; --------------------------------------------------------------------------------------
 ;;;  (c) copyright 1998,1999,2003 by Gilbert Baumann
 ;;;  (c) copyright 2000 by 
@@ -133,8 +133,11 @@
     (values mxx mxy myx myy tx ty)))
 
 (defun make-translation-transformation (dx dy)
-  (make-instance 'standard-translation
-                 :dx (coordinate dx) :dy (coordinate dy)))
+  (cond ((and (coordinate= dx 0) (coordinate= dy 0))
+         +identity-transformation+)
+        (t
+         (make-instance 'standard-translation
+                        :dx (coordinate dx) :dy (coordinate dy)))))
 
 (defun make-rotation-transformation (angle &optional origin)
   (if origin
@@ -666,9 +669,7 @@
   ;; (compose-transformations A B)x = (A o B)x = ABx
   (with-slots ((dx1 dx) (dy1 dy)) transformation1
     (with-slots ((dx2 dx) (dy2 dy)) transformation2
-      (make-instance 'standard-translation
-                     :dx (+ dx1 dx2)
-                     :dy (+ dy1 dy2)))))
+      (make-translation-transformation (+ dx1 dx2) (+ dy1 dy2)))))
 
 (defmethod compose-transformations (transformation2
                                     (transformation1 standard-identity-transformation))



From mretzlaff at common-lisp.net  Thu Nov 24 18:31:56 2005
From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff)
Date: Thu, 24 Nov 2005 19:31:56 +0100 (CET)
Subject: [mcclim-cvs] CVS update: Directory change: mcclim/Extensions
Message-ID: <20051124183156.60455880D5@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Extensions
In directory common-lisp.net:/tmp/cvs-serv13379/Extensions

Log Message:
Directory /project/mcclim/cvsroot/mcclim/Extensions added to the repository

Date: Thu Nov 24 19:31:55 2005
Author: mretzlaff
New directory mcclim/Extensions added


From mretzlaff at common-lisp.net  Thu Nov 24 18:32:18 2005
From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff)
Date: Thu, 24 Nov 2005 19:32:18 +0100 (CET)
Subject: [mcclim-cvs] CVS update: Directory change:
	mcclim/Extensions/conditional-commands
Message-ID: <20051124183218.2EBBD880D5@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands
In directory common-lisp.net:/tmp/cvs-serv13412/conditional-commands

Log Message:
Directory /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands added to the repository

Date: Thu Nov 24 19:32:17 2005
Author: mretzlaff
New directory mcclim/Extensions/conditional-commands added


From mretzlaff at common-lisp.net  Thu Nov 24 18:35:36 2005
From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff)
Date: Thu, 24 Nov 2005 19:35:36 +0100 (CET)
Subject: [mcclim-cvs] CVS update:
	mcclim/Extensions/conditional-commands/README
	mcclim/Extensions/conditional-commands/command-and-command-table-utilities.lisp
	mcclim/Extensions/conditional-commands/conditional-commands-example.lisp
	mcclim/Extensions/conditional-commands/conditional-commands.asd
	mcclim/Extensions/conditional-commands/creating-assoc.lisp
	mcclim/Extensions/conditional-commands/entity-enabledness-handling.lisp
	mcclim/Extensions/conditional-commands/package.lisp 
Message-ID: <20051124183536.7728B880D5@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands
In directory common-lisp.net:/tmp/cvs-serv13435

Added Files:
	README command-and-command-table-utilities.lisp 
	conditional-commands-example.lisp conditional-commands.asd 
	creating-assoc.lisp entity-enabledness-handling.lisp 
	package.lisp 
Log Message:
Add the Conditional Commands (And Sheets) Extension.

Date: Thu Nov 24 19:35:34 2005
Author: mretzlaff
















From mretzlaff at common-lisp.net  Thu Nov 24 18:37:13 2005
From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff)
Date: Thu, 24 Nov 2005 19:37:13 +0100 (CET)
Subject: [mcclim-cvs] CVS update:
	mcclim/Extensions/conditional-commands/creating-assoc.lisp 
Message-ID: <20051124183713.51722880D5@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands
In directory common-lisp.net:/tmp/cvs-serv13488

Modified Files:
	creating-assoc.lisp 
Log Message:
Remove the old and uncommented versions of CREATING-ASSOC.

Date: Thu Nov 24 19:37:12 2005
Author: mretzlaff

Index: mcclim/Extensions/conditional-commands/creating-assoc.lisp
diff -u mcclim/Extensions/conditional-commands/creating-assoc.lisp:1.1 mcclim/Extensions/conditional-commands/creating-assoc.lisp:1.2
--- mcclim/Extensions/conditional-commands/creating-assoc.lisp:1.1	Thu Nov 24 19:35:34 2005
+++ mcclim/Extensions/conditional-commands/creating-assoc.lisp	Thu Nov 24 19:37:12 2005
@@ -1,80 +1,5 @@
 (in-package :creating-assoc)
 
-;;; Doesn't work:
-;;;
-;;; (defun creating-assoc (item alist)
-;;;   "assoc that creates the requested alist item on-the-fly if not yet existing"
-;;;   (let ((item-assoc (assoc item alist)))
-;;;     (unless item-assoc
-;;;       (let ((new-item (list item)))
-;;;         (push new-item alist)
-;;;         (setf item-assoc new-item)))))
-
-;;; Doesn't work:
-;;;
-;;; (defmacro creating-assoc (item alist)
-;;;   "assoc that creates the requested alist item on-the-fly if not yet existing"
-;;;   (let ((entry (gensym "entry-"))
-;;;         (new-item (gensym "new-item-"))
-;;;         (the-item (gensym "the-item-"))
-;;;         (the-alist (gensym "the-alist-")))
-;;;     `(let* ((,the-item ,item)
-;;;             (,the-alist ,alist)
-;;;             (,entry (assoc ,the-item ,the-alist)))
-;;;        (unless ,entry
-;;;          (let ((,new-item (list ,the-item)))
-;;;            (push ,new-item ,the-alist)
-;;;            (setf ,entry ,new-item))))))
-
-;;; Does work, but ALIST will be evaluated twice:
-;;;
-;;; (defmacro creating-assoc (item alist)
-;;;   "assoc that creates the requested alist item on-the-fly if not yet existing"
-;;;   (let ((entry (gensym "entry-"))
-;;;         (new-item (gensym "new-item-"))
-;;;         (the-item (gensym "the-item-")))
-;;;     `(let* ((,the-item ,item)
-;;;             (,entry (assoc ,the-item ,alist)))
-;;;        (unless ,entry
-;;;          (let ((,new-item (list ,the-item)))
-;;;            (push ,new-item ,alist)
-;;;            (setf ,entry ,new-item))))))
-
-;;; From SBCL source, uses GET-SETF-METHOD, a relic from pre-ANSI Common Lisp:
-;;;
-;;; (defmacro-mundanely push (obj place &environment env)
-;;;   #!+sb-doc
-;;;   "Takes an object and a location holding a list. Conses the object onto
-;;;   the list, returning the modified list. OBJ is evaluated before PLACE."
-;;;   (multiple-value-bind (dummies vals newval setter getter)
-;;;       (get-setf-method place env)
-;;;     (let ((g (gensym)))
-;;;       `(let* ((,g ,obj)
-;;;               ,@(mapcar #'list dummies vals)
-;;;               (,(car newval) (cons ,g ,getter)))
-;;;          ,setter))))
-
-;;; Example CLHS page on GET-SETF-EXPANSION:
-;;; (Notice that there is an error, "(if (cdr new)" should be replaced by "(if (cdr ,(car new))".)
-;;;
-;;;  (defmacro xpop (place &environment env)
-;;;    (multiple-value-bind (dummies vals new setter getter)
-;;;                         (get-setf-expansion place env)
-;;;       `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
-;;;          (if (cdr new) (error "Can't expand this."))
-;;;          (prog1 (car ,(car new))
-;;;                 (setq ,(car new) (cdr ,(car new)))
-;;;                 ,setter))))
-
-;;; New version, still does not work:
-;;;
-;;; (defun creating-assoc (item alist)
-;;;   "assoc that creates the requested alist item on-the-fly if not yet existing"
-;;;   (or (assoc item alist)
-;;;       (first (push (list item) alist))))
-
-;;; Macro based on the new (not-working) defun, works and is nice:
-;;;
 (defmacro creating-assoc (item alist &environment env)
   "assoc that creates the requested alist item on-the-fly if not yet existing"
    (multiple-value-bind (dummies vals new setter getter)



From gbaumann at common-lisp.net  Mon Nov 28 11:53:42 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 12:53:42 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp 
Message-ID: <20051128115342.03403880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv20807

Modified Files:
	medium.lisp 
Log Message:
TEXT-SIZE, CLIMI::TEXT-BOUNDING-RECTANGLE*
        end argument was not handled properly in case of multi-line strings

Date: Mon Nov 28 12:53:42 2005
Author: gbaumann

Index: mcclim/Backends/CLX/medium.lisp
diff -u mcclim/Backends/CLX/medium.lisp:1.68 mcclim/Backends/CLX/medium.lisp:1.69
--- mcclim/Backends/CLX/medium.lisp:1.68	Thu Oct 27 03:21:35 2005
+++ mcclim/Backends/CLX/medium.lisp	Mon Nov 28 12:53:41 2005
@@ -795,7 +795,7 @@
     (cond ((= start end)
            (values 0 0 0 0 0))
           (t
-           (let ((position-newline (position #\newline string :start start)))
+           (let ((position-newline (position #\newline string :start start :end end)))
              (cond ((not (null position-newline))
                     (multiple-value-bind (width ascent descent left right
                                                 font-ascent font-descent direction
@@ -834,7 +834,7 @@
     (cond ((= start end)
            (values 0 0 0 0))
           (t
-           (let ((position-newline (position #\newline string :start start)))
+           (let ((position-newline (position #\newline string :start start :end end)))
              (cond ((not (null position-newline))
                     (multiple-value-bind (width ascent descent left right
                                                 font-ascent font-descent direction
@@ -875,7 +875,7 @@
     (cond ((= start end)
            (values 0 0 0 0 0))
           (t
-           (let ((position-newline (position #\newline string :start start)))
+           (let ((position-newline (position #\newline string :start start :end end)))
              (cond ((not (null position-newline))
                     (multiple-value-bind (width ascent descent left right
                                                 font-ascent font-descent direction



From gbaumann at common-lisp.net  Mon Nov 28 12:58:18 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 13:58:18 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp 
Message-ID: <20051128125818.DB101880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv25198

Modified Files:
	port.lisp 
Log Message:
SEND-SELECTION:
        selection slot of ;selection-notify event now matches
        selection event.

Date: Mon Nov 28 13:58:18 2005
Author: gbaumann

Index: mcclim/Backends/CLX/port.lisp
diff -u mcclim/Backends/CLX/port.lisp:1.112 mcclim/Backends/CLX/port.lisp:1.113
--- mcclim/Backends/CLX/port.lisp:1.112	Thu Jun 16 11:27:49 2005
+++ mcclim/Backends/CLX/port.lisp	Mon Nov 28 13:58:18 2005
@@ -1431,8 +1431,7 @@
 ;;; TODO: INCR property?
 ;;;
 ;;; FIXME: per ICCCM we MUST support :MULTIPLE
-(defmethod send-selection
-    ((port clx-port) (event clx-selection-request-event) string)
+(defmethod send-selection ((port clx-port) (event clx-selection-request-event) string)
   (let ((requestor (selection-event-requestor event))
         (property  (selection-event-property event))
         (target    (selection-event-target event))
@@ -1447,17 +1446,17 @@
 	     ;; debugging output, but the KDE Klipper client turns out
 	     ;; to poll other clients for selection, which means it
 	     ;; would be bad to print at every request.
-	     #+nil
+             #+nil
              (format *trace-output*
-                     "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A.~%"
+                     "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A. time ~S~%"
                      (selection-event-target event)
                      target
-                     property)
+                     property time)
              (xlib:send-event requestor
 			      :selection-notify nil
 			      :window requestor
 			      :event-window requestor
-			      :selection :primary
+			      :selection (climi::selection-event-selection event)
 			      :target target
 			      :property property
 			      :time time)))



From gbaumann at common-lisp.net  Mon Nov 28 13:02:00 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 14:02:00 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp 
Message-ID: <20051128130200.1DFCC880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv26265

Modified Files:
	medium.lisp 
Log Message:
MEDIUM-COPY-AREA (CLX-MEDIUM T T T T CLX-MEDIUM T T):
    - we transform width and height too now.

Date: Mon Nov 28 14:01:59 2005
Author: gbaumann

Index: mcclim/Backends/CLX/medium.lisp
diff -u mcclim/Backends/CLX/medium.lisp:1.69 mcclim/Backends/CLX/medium.lisp:1.70
--- mcclim/Backends/CLX/medium.lisp:1.69	Mon Nov 28 12:53:41 2005
+++ mcclim/Backends/CLX/medium.lisp	Mon Nov 28 14:01:59 2005
@@ -359,12 +359,14 @@
                               from-x from-y)
     (with-transformed-position ((sheet-native-transformation (medium-sheet to-drawable))
                                 to-x to-y)
-      (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable))
-                      (medium-gcontext from-drawable +background-ink+)
-                      (round-coordinate from-x) (round-coordinate from-y)
-		      (round width) (round height)
-                      (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable)))
-                      (round-coordinate to-x) (round-coordinate to-y)))))
+      (multiple-value-bind (width height) (transform-distance (medium-transformation from-drawable)
+                                                              width height)
+        (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable))
+                        (medium-gcontext from-drawable +background-ink+)
+                        (round-coordinate from-x) (round-coordinate from-y)
+                        (round width) (round height)
+                        (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable)))
+                        (round-coordinate to-x) (round-coordinate to-y))))))
 
 (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height
                              (to-drawable pixmap) to-x to-y)



From gbaumann at common-lisp.net  Mon Nov 28 13:04:55 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 14:04:55 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/text-selection.lisp 
Message-ID: <20051128130455.BE43D880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv26311

Modified Files:
	text-selection.lisp 
Log Message:
FETCH-SELECTION:
    - We pad out selection we get from tables and similar things with
      spaces now.


Date: Mon Nov 28 14:04:55 2005
Author: gbaumann

Index: mcclim/text-selection.lisp
diff -u mcclim/text-selection.lisp:1.6 mcclim/text-selection.lisp:1.7
--- mcclim/text-selection.lisp:1.6	Tue Mar 22 13:31:18 2005
+++ mcclim/text-selection.lisp	Mon Nov 28 14:04:55 2005
@@ -403,18 +403,27 @@
 
 ;; FIXME: Non-text target conversions.. (?)
 (defun fetch-selection (pane)
-  (let (old-y2)
+  (let (old-y2 old-x2)
     (with-output-to-string (bag)
-;    (let ((bag *trace-output*))
       (map nil
            (lambda (m)
              (with-slots (record styled-string start end) m
-	       (with-standard-rectangle* (:y1 y1 :y2 y2) record
-                 (if (and old-y2 (>= y1 old-y2))
-                     (progn
-                       (setf old-y2 nil)
-                       (terpri bag))
-                   (setf old-y2 (max y2 (or old-y2 y2)))))
-               (princ (subseq (styled-string-string styled-string) start end) bag)))
+               (with-standard-rectangle*
+                   (:x1 x1 :x2 x2 :y1 y1 :y2 y2) record
+                   (cond ((and old-y2 (>= y1 old-y2))
+                          (setf old-y2 nil
+                                old-x2 0 ;<-- ### we should use the minimum of all x1 coordinates.
+                                )
+                          (terpri bag))
+                         (t
+                          (setf old-y2 (max y2 (or old-y2 y2)))))
+                   (when old-x2
+                     (loop repeat (round
+                                   (- x1 old-x2)
+                                   (text-style-width (slot-value styled-string 'text-style)
+                                                     pane))
+                       do
+                       (princ " " bag)))
+                   (setf old-x2 x2)
+                   (princ (subseq (styled-string-string styled-string) start end) bag))))
            (slot-value pane 'markings)))))
-



From gbaumann at common-lisp.net  Mon Nov 28 13:23:57 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 14:23:57 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051128132357.CD941880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv27504

Modified Files:
	panes.lisp 
Log Message:
TABLE-PANE
    The table pane now recognizes x-spacing and y-spacing, but units
    are not tested.


Date: Mon Nov 28 14:23:55 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.156 mcclim/panes.lisp:1.157
--- mcclim/panes.lisp:1.156	Thu Oct 27 03:21:33 2005
+++ mcclim/panes.lisp	Mon Nov 28 14:23:53 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.156 2005/10/27 01:21:33 rstrandh Exp $
+;;; $Id: panes.lisp,v 1.157 2005/11/28 13:23:53 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -1471,59 +1471,67 @@
 
 (defmethod compose-space ((pane table-pane) &key width height)
   (declare (ignore width height))
-  (with-slots (array) pane
+  (with-slots (array x-spacing y-spacing) pane
     ; ---v our problem is here.
+    ; Which problem? --GB
     (let ((rsrs (loop for i from 0 below (array-dimension array 0) 
                     collect (table-pane-row-space-requirement pane i)))
           (csrs (loop for j from 0 below (array-dimension array 1) 
-                    collect (table-pane-col-space-requirement pane j))))
+                    collect (table-pane-col-space-requirement pane j)))
+          (xs (* x-spacing (1- (array-dimension array 1))))
+          (ys (* y-spacing (1- (array-dimension array 0)))))
       (let ((r (stack-space-requirements-vertically rsrs))
             (c (stack-space-requirements-horizontally csrs)))
         (let ((res
                (make-space-requirement
-                :width      (space-requirement-width r)
-                :min-width  (space-requirement-min-width r)
-                :max-width  (space-requirement-max-width r)
-                :height     (space-requirement-height c)
-                :min-height (space-requirement-min-height c)
-                :max-height (space-requirement-max-height c))))
+                :width      (+ (space-requirement-width r) xs)
+                :min-width  (+ (space-requirement-min-width r) xs)
+                :max-width  (+ (space-requirement-max-width r) xs)
+                :height     (+ (space-requirement-height c) ys)
+                :min-height (+ (space-requirement-min-height c) ys)
+                :max-height (+ (space-requirement-max-height c) ys))))
           #+nil
           (format *trace-output* "~%;;; TABLE-PANE sr = ~S." res)
           res)))))
 
-(defmethod allocate-space ((pane table-pane) width height &aux rsrs csrs)
-  (declare (ignorable rsrs csrs))
-  (with-slots (array) pane
-    ;; allot rows
-    (let ((rows (allot-space-vertically
-                 (setq rsrs (loop for i from 0 below (array-dimension array 0)
-                                collect (table-pane-row-space-requirement pane i)))
-                 height))
-          (cols (allot-space-horizontally
-                 (setq csrs (loop for j from 0 below (array-dimension array 1)
-                                collect (table-pane-col-space-requirement pane j)))
-                 width)))
-      #+nil
-      (progn
-        (format T "~&;; row space requirements = ~S." rsrs)
-        (format T "~&;; col space requirements = ~S." csrs)
-        (format T "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows))
-        (format T "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols))
-        (format T "~&;; align-x = ~S, align-y ~S~%"
-                (pane-align-x pane)
-                (pane-align-y pane)))
-      ;; now finally layout each child
-      (loop
-          for y = 0 then (+ y h)
-          for h in rows
-          for i from 0
-          do (loop
-                 for x = 0 then (+ x w)
-                 for w in cols
-                 for j from 0
-                 do (layout-child (aref array i j) (pane-align-x pane) (pane-align-y pane)
-                                  x y w h))))))
-
+(defmethod allocate-space ((pane table-pane) width height)
+  (let (rsrs csrs)
+    (declare (ignorable rsrs csrs))
+    (with-slots (array x-spacing y-spacing) pane
+      ;; allot rows
+      (let* ((xs (* x-spacing (1- (array-dimension array 1))))
+             (ys (* y-spacing (1- (array-dimension array 0))))
+             (rows (allot-space-vertically
+                    (setq rsrs (loop for i from 0 below (array-dimension array 0)
+                                     collect (table-pane-row-space-requirement pane i)))
+                    (- height ys)))
+             (cols (allot-space-horizontally
+                    (setq csrs (loop for j from 0 below (array-dimension array 1)
+                                     collect (table-pane-col-space-requirement pane j)))
+                    (- width xs))))
+        #+nil
+        (progn
+          (format T "~&;; row space requirements = ~S." rsrs)
+          (format T "~&;; col space requirements = ~S." csrs)
+          (format T "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows))
+          (format T "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols))
+          (format T "~&;; align-x = ~S, align-y ~S~%"
+                  (pane-align-x pane)
+                  (pane-align-y pane)))
+        ;; now finally layout each child
+        (loop
+            for y = 0 then (+ y h y-spacing)
+            for h in rows
+            for i from 0
+            do (loop
+                   for x = 0 then (+ x w x-spacing)
+                   for w in cols
+                   for j from 0
+                   do (let ((child (aref array i j)))
+                        (layout-child child
+                                      (pane-align-x pane)
+                                      (pane-align-y pane)
+                                      x y w h))))))))
 
 (defun table-pane-p (pane)
   (typep pane 'table-pane))



From gbaumann at common-lisp.net  Mon Nov 28 13:51:07 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 14:51:07 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/frames.lisp 
Message-ID: <20051128135107.90B72880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv29697

Modified Files:
	frames.lisp 
Log Message:
EXECUTE-FRAME-COMMAND

    When called from another process, pass command as
    EXECUTE-COMMAND-EVENT to the frame. So that commands are always
    executed in sync with the command loop.

    However, my method to check for being in frame process is far from
    perfect.

Date: Mon Nov 28 14:51:06 2005
Author: gbaumann

Index: mcclim/frames.lisp
diff -u mcclim/frames.lisp:1.109 mcclim/frames.lisp:1.110
--- mcclim/frames.lisp:1.109	Thu Oct 27 03:21:33 2005
+++ mcclim/frames.lisp	Mon Nov 28 14:51:05 2005
@@ -588,8 +588,25 @@
   #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream)
   (read-command (frame-command-table frame) :use-keystrokes t :stream stream))
 
+(defclass execute-command-event (window-manager-event)
+  ((sheet :initarg :sheet :reader event-sheet)
+   (command :initarg :command :reader execute-command-event-command)))
+
 (defmethod execute-frame-command ((frame application-frame) command)
-  (apply (command-name command) (command-arguments command)))
+  ;; ### FIXME: I'd like a different method than checking for
+  ;; *application-frame* to decide, which process processes which
+  ;; frames command loop. Perhaps looking ath the process slot?
+  ;; --GB 2005-11-28
+  (cond ((eq *application-frame* frame)
+         (apply (command-name command) (command-arguments command)))
+        (t
+         (let ((eq (sheet-event-queue (frame-top-level-sheet frame))))
+           (event-queue-append eq (make-instance 'execute-command-event
+                                                  :sheet frame
+                                                  :command command))))))
+
+(defmethod handle-event ((frame application-frame) (event execute-command-event))
+  (execute-frame-command frame (execute-command-event-command event)))
 
 (defmethod command-enabled (command-name (frame standard-application-frame))
   (and (command-accessible-in-command-table-p command-name



From gbaumann at common-lisp.net  Mon Nov 28 14:21:46 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 15:21:46 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp 
Message-ID: <20051128142146.4A3FD880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv31917

Modified Files:
	port.lisp 
Log Message:
EVENT-HANDLER
    We also deliver :graphics-exposure events as CLIM repaint events.


Date: Mon Nov 28 15:21:45 2005
Author: gbaumann

Index: mcclim/Backends/CLX/port.lisp
diff -u mcclim/Backends/CLX/port.lisp:1.113 mcclim/Backends/CLX/port.lisp:1.114
--- mcclim/Backends/CLX/port.lisp:1.113	Mon Nov 28 13:58:18 2005
+++ mcclim/Backends/CLX/port.lisp	Mon Nov 28 15:21:45 2005
@@ -766,7 +766,7 @@
 				:modifier-state modifier-state
 				:timestamp time)))))
         ;;
-	((:exposure :display)
+	((:exposure :display :graphics-exposure)
          ;; Notes:
          ;; . Do not compare count with 0 here, last rectangle in an
          ;;   :exposure event sequence does not cover the whole region. 



From gbaumann at common-lisp.net  Mon Nov 28 15:17:30 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 16:17:30 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051128151730.5C185880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv4084

Modified Files:
	panes.lisp 
Log Message:
HBOX, VBOX, HRACK, VRACK
    - We layout proportional content more to the application
      programmer's expectations.

    - When composing space, we maximize the max-minor space
      requirement of children now, instead of minimizing. This avoids
      the effect, that something becomes fixed size as soon as a child
      is fixed sized. The behavior now is, that a box pane is fixed
      size only if every child is fixed size too.

    - children are aligned according to their align-x and align-y
      options.

Date: Mon Nov 28 16:17:28 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.157 mcclim/panes.lisp:1.158
--- mcclim/panes.lisp:1.157	Mon Nov 28 14:23:53 2005
+++ mcclim/panes.lisp	Mon Nov 28 16:17:28 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.157 2005/11/28 13:23:53 gbaumann Exp $
+;;; $Id: panes.lisp,v 1.158 2005/11/28 15:17:28 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -1107,6 +1107,41 @@
              (t
               sr) ))))
 
+ (defmethod xically-content-sr*** ((pane box-layout-mixin) client major)
+   (let (p)
+     (let ((sr (if (box-client-pane client)
+                   (compose-space (box-client-pane client))
+                   (make-space-requirement :width 0 :min-width 0 :max-width 0
+                                           :height 0 :min-height 0 :max-height 0))))
+       (cond ((box-client-fillp client)
+              (make-space-requirement
+               :major     (space-requirement-major sr)
+               :min-major (space-requirement-min-major sr)
+               :max-major +fill+
+               :minor     (space-requirement-minor sr)
+               :min-minor (space-requirement-min-minor sr)
+               :max-minor (space-requirement-max-minor sr)))
+             ((setq p (box-client-fixed-size client))
+              (make-space-requirement
+               :major     p
+               :min-major p
+               :max-major p
+               :minor     (if sr (space-requirement-minor sr) 0)
+               :min-minor (if sr (space-requirement-min-minor sr) 0)
+               :max-minor (if sr (space-requirement-max-minor sr) 0)))
+             ((setq p (box-client-proportion client))
+              (make-space-requirement
+               :major     (clamp (* p major)
+                                 (space-requirement-min-major sr)
+                                 (space-requirement-max-major sr))
+               :min-major (space-requirement-min-major sr)
+               :max-major (space-requirement-max-major sr)
+               :minor     (if sr (space-requirement-minor sr) 0)
+               :min-minor (if sr (space-requirement-min-minor sr) 0)
+               :max-minor (if sr (space-requirement-max-minor sr) 0)))
+             (t
+              sr) ))))
+
  (defmethod box-layout-mixin/xically-compose-space ((pane box-layout-mixin))
    (let ((n (length (sheet-enabled-children pane))))
      (with-slots (major-spacing) pane
@@ -1118,7 +1153,7 @@
            sum (space-requirement-max-major sr) into max-major
            maximize (space-requirement-minor sr) into minor
            maximize (space-requirement-min-minor sr) into min-minor
-           minimize (space-requirement-max-minor sr) into max-minor
+           maximize (space-requirement-max-minor sr) into max-minor
            finally
              (return
                (space-requirement+*
@@ -1140,7 +1175,7 @@
    (declare (ignorable width height))
    (let ((children (reverse (sheet-enabled-children box))))
      (with-slots (major-spacing) box
-       (let* ((content-srs (mapcar #'(lambda (c) (xically-content-sr** box c))
+       (let* ((content-srs (mapcar #'(lambda (c) (xically-content-sr*** box c major))
                                    (box-layout-mixin-clients box)))
               (allot       (mapcar #'ceiling (mapcar #'space-requirement-major content-srs)))
               (wanted      (reduce #'+ allot))
@@ -1154,25 +1189,21 @@
 
          (let ((qvector
                 (mapcar
-                 (lambda (c &aux p)
+                 (lambda (c)
                    (cond
                      ((box-client-fillp c)
                       (vector 1 0 0))
-                     ((setq p (box-client-proportion c))
-                      (vector 0 p 0))
                      (t
                       (vector 0 0
                               (abs (- (if (> excess 0)
-                                          (space-requirement-max-major
-                                           (xically-content-sr** box c))
-                                          (space-requirement-min-major
-                                           (xically-content-sr** box c)))
-                                      (space-requirement-major
-                                       (xically-content-sr** box c))))))))
+                                          (space-requirement-max-major (xically-content-sr*** box c major))
+                                          (space-requirement-min-major (xically-content-sr*** box c major)))
+                                      (space-requirement-major (xically-content-sr*** box c major))))))))
                  (box-layout-mixin-clients box))))
            ;;
            (when *dump-allocate-space*
              (format *trace-output* "~&;;   old allotment = ~S.~%" allot)
+             (format *trace-output* "~&;;   qvector = ~S.~%" qvector)
              (format *trace-output* "~&;;   qvector 0 = ~S.~%" (mapcar #'(lambda (x) (elt x 0)) qvector))
              (format *trace-output* "~&;;   qvector 1 = ~S.~%" (mapcar #'(lambda (x) (elt x 1)) qvector))
              (format *trace-output* "~&;;   qvector 2 = ~S.~%" (mapcar #'(lambda (x) (elt x 2)) qvector)))
@@ -1189,8 +1220,7 @@
                                      (+ allot delta))))
                                allot qvector))
 		 (when *dump-allocate-space*
-		   (format *trace-output* "~&;;   new excess = ~F, allotment = ~S.~%" excess allot))
-                 )))
+		   (format *trace-output* "~&;;   new excess = ~F, allotment = ~S.~%" excess allot)) )))
            ;;
 	   (when *dump-allocate-space*
 	     (format *trace-output* "~&;;   excess = ~F.~%" excess)
@@ -1205,9 +1235,10 @@
      (values majors
              (mapcar (lambda (x) x minor) minors))))
 
- (defmethod box-layout-mixin/xically-allocate-space ((pane box-layout-mixin) width height)
+  (defmethod box-layout-mixin/xically-allocate-space ((pane box-layout-mixin) real-width real-height)
    (with-slots (major-spacing) pane
-     (multiple-value-bind (majors minors) (box-layout-mixin/xically-allocate-space-aux* pane width height)
+     (multiple-value-bind (majors minors)
+         (box-layout-mixin/xically-allocate-space-aux* pane real-width real-height)
        ;; now actually layout the children
        (let ((x 0))
          (loop
@@ -1215,15 +1246,21 @@
              for major in majors
              for minor in minors
              do
-               #+nil (format *trace-output* "~&;;   child ~S at 0, ~D ~D x ~D~%" child x width height)
-               (when (box-client-pane child)
-                 (move-sheet (box-client-pane child)
+             (when (box-client-pane child)
+               #+NIL
+               (format *trace-output* "~&;;   child ~S at 0, ~D ~D x ~D(~D)~%;;       ~S~%"
+                       (box-client-pane child)
+                       x width height real-height
+                       (compose-space (box-client-pane child)))
+               (layout-child (box-client-pane child)
+                             (pane-align-x (box-client-pane child))
+                             (pane-align-y (box-client-pane child))
                              ((lambda (major minor) height width) x 0)
-                             ((lambda (major minor) width height) x 0))
-                 (allocate-space (box-client-pane child)
-                                 width height))
-               (incf x major)
-               (incf x major-spacing)))))))
+                             ((lambda (major minor) width height) x 0)
+                             ((lambda (major minor) height width) width real-width)
+                             ((lambda (major minor) height width) real-height height)))
+             (incf x major)
+             (incf x major-spacing)))))) )
 
 ;; #+nil
 (defmethod note-sheet-enabled :before ((pane pane))



From gbaumann at common-lisp.net  Mon Nov 28 15:22:07 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 16:22:07 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051128152207.D10B3880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv4133

Modified Files:
	panes.lisp 
Log Message:
TABLE-PANE
    As for HBOX and friends, children are now aligned according to
    their align options.


Date: Mon Nov 28 16:22:07 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.158 mcclim/panes.lisp:1.159
--- mcclim/panes.lisp:1.158	Mon Nov 28 16:17:28 2005
+++ mcclim/panes.lisp	Mon Nov 28 16:22:06 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.158 2005/11/28 15:17:28 gbaumann Exp $
+;;; $Id: panes.lisp,v 1.159 2005/11/28 15:22:06 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -1566,8 +1566,8 @@
                    for j from 0
                    do (let ((child (aref array i j)))
                         (layout-child child
-                                      (pane-align-x pane)
-                                      (pane-align-y pane)
+                                      (pane-align-x child)
+                                      (pane-align-y child)
                                       x y w h))))))))
 
 (defun table-pane-p (pane)



From gbaumann at common-lisp.net  Mon Nov 28 15:24:38 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 16:24:38 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051128152438.285A18855E@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv4180

Modified Files:
	panes.lisp 
Log Message:
LABEL-PANE
    We border is now drawn in groove style.

Date: Mon Nov 28 16:24:37 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.159 mcclim/panes.lisp:1.160
--- mcclim/panes.lisp:1.159	Mon Nov 28 16:22:06 2005
+++ mcclim/panes.lisp	Mon Nov 28 16:24:37 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.159 2005/11/28 15:22:06 gbaumann Exp $
+;;; $Id: panes.lisp,v 1.160 2005/11/28 15:24:37 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -2207,34 +2207,34 @@
         (tw (text-size pane (label-pane-label pane))))
     (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)
       (multiple-value-bind (iright itop ileft ibottom
-                            bright btop bleft bbottom)
+                                   bright btop bleft bbottom)
           (label-pane-margins pane)
         (declare (ignorable iright itop ileft ibottom))
         (multiple-value-bind (tx ty)
             (values (ecase (pane-align-x pane)
                       (:left (+ x1 m0 (if (sheet-children pane)
                                           (+ a m0 m0 d)
-                                        0)))
+                                          0)))
                       (:right (- x2 m0 (if (sheet-children pane)
                                            (+ a m0 m0 d)
-                                         0)
-                                 tw))
+                                           0)
+                               tw))
                       (:center (- (/ (- x2 x1) 2) (/ tw 2))))
                     (ecase (label-pane-label-alignment pane)
                       (:top (+ y1 m0 a))
                       (:bottom (- y2 m0 d))))
           (draw-text* pane (label-pane-label pane)
                       tx ty)
+          ;;;
           (when (sheet-children pane)
-            (draw-design pane
-                         (region-difference
-                          (make-polyline* (list
-                                           (+ x1 bleft) (+ y1 btop)
-                                           (+ x1 bleft) (- y2 bbottom)
-                                           (- x2 bright) (- y2 bbottom)
-                                           (- x2 bright) (+ y1 btop))
-                                          :closed t)
-                          (make-rectangle* (- tx m0) (- ty a) (+ tx tw m0) (+ ty d)))) ))))))
+            (with-drawing-options (pane
+                                   :clipping-region
+                                   (region-difference
+                                    (sheet-region pane)
+                                    (make-rectangle* (- tx m0) (- ty a) (+ tx tw m0) (+ ty d))))
+              (draw-bordered-rectangle* pane (+ x1 bleft) (+ y1 btop) (- x2 bright) (- y2 bbottom) 
+                                        :style :groove))))))))
+
 
 (defmethod initialize-instance :after ((pane label-pane) &key contents &allow-other-keys)
   (when contents



From gbaumann at common-lisp.net  Mon Nov 28 15:31:00 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 16:31:00 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/keysymdef.lisp 
Message-ID: <20051128153100.54E45880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv4687

Modified Files:
	keysymdef.lisp 
Log Message:
Some keysyms, most notable the :DEAD-<something> keysym, featured a
double dash. fixed.


Date: Mon Nov 28 16:30:59 2005
Author: gbaumann

Index: mcclim/Backends/CLX/keysymdef.lisp
diff -u mcclim/Backends/CLX/keysymdef.lisp:1.6 mcclim/Backends/CLX/keysymdef.lisp:1.7
--- mcclim/Backends/CLX/keysymdef.lisp:1.6	Wed Jan  7 06:05:07 2004
+++ mcclim/Backends/CLX/keysymdef.lisp	Mon Nov 28 16:30:59 2005
@@ -271,19 +271,19 @@
 (define-keysym :ISO-EMPHASIZE #xfe32)
 (define-keysym :ISO-CENTER-OBJECT #xfe33)
 (define-keysym :ISO-ENTER #xfe34)
-(define-keysym :DEAD--GRAVE #xfe50)
-(define-keysym :DEAD--ACUTE #xfe51)
-(define-keysym :DEAD--CIRCUMFLEX #xfe52)
-(define-keysym :DEAD--TILDE #xfe53)
-(define-keysym :DEAD--MACRON #xfe54)
-(define-keysym :DEAD--BREVE #xfe55)
-(define-keysym :DEAD--ABOVEDOT #xfe56)
-(define-keysym :DEAD--DIAERESIS #xfe57)
+(define-keysym :DEAD-GRAVE #xfe50)
+(define-keysym :DEAD-ACUTE #xfe51)
+(define-keysym :DEAD-CIRCUMFLEX #xfe52)
+(define-keysym :DEAD-TILDE #xfe53)
+(define-keysym :DEAD-MACRON #xfe54)
+(define-keysym :DEAD-BREVE #xfe55)
+(define-keysym :DEAD-ABOVEDOT #xfe56)
+(define-keysym :DEAD-DIAERESIS #xfe57)
 (define-keysym :DEAD-ABOVE-RING #xfe58)
-(define-keysym :DEAD--DOUBLEACUTE #xfe59)
-(define-keysym :DEAD--CARON #xfe5a)
-(define-keysym :DEAD--CEDILLA #xfe5b)
-(define-keysym :DEAD--OGONEK #xfe5c)
+(define-keysym :DEAD-DOUBLEACUTE #xfe59)
+(define-keysym :DEAD-CARON #xfe5a)
+(define-keysym :DEAD-CEDILLA #xfe5b)
+(define-keysym :DEAD-OGONEK #xfe5c)
 (define-keysym :DEAD-IOTA #xfe5d)
 (define-keysym :DEAD-VOICED-SOUND #xfe5e)
 (define-keysym :DEAD-SEMIVOICED-SOUND #xfe5f)
@@ -1480,13 +1480,13 @@
 ;; * DEC private keysyms
 ;; * (29th bit set)
 ;; */
-(define-keysym :D-RING--ACCENT #x1000feb0)
-(define-keysym :D-CIRCUMFLEX--ACCENT #x1000fe5e)
-(define-keysym :D-CEDILLA--ACCENT #x1000fe2c)
-(define-keysym :D-ACUTE--ACCENT #x1000fe27)
-(define-keysym :D-GRAVE--ACCENT #x1000fe60)
-(define-keysym :D--TILDE #x1000fe7e)
-(define-keysym :D--DIAERESIS #x1000fe22)
+(define-keysym :D-RING-ACCENT #x1000feb0)
+(define-keysym :D-CIRCUMFLEX-ACCENT #x1000fe5e)
+(define-keysym :D-CEDILLA-ACCENT #x1000fe2c)
+(define-keysym :D-ACUTE-ACCENT #x1000fe27)
+(define-keysym :D-GRAVE-ACCENT #x1000fe60)
+(define-keysym :D-TILDE #x1000fe7e)
+(define-keysym :D-DIAERESIS #x1000fe22)
 (define-keysym :D-REMOVE #x1000ff00)
 ;;/*
 ;;
@@ -1558,10 +1558,10 @@
 (define-keysym :HP-RESET #x1000ff6c)
 (define-keysym :HP-SYSTEM #x1000ff6d)
 (define-keysym :HP-USER #x1000ff6e)
-(define-keysym :HP-MUTE--ACUTE #x100000a8)
-(define-keysym :HP-MUTE--GRAVE #x100000a9)
+(define-keysym :HP-MUTE-ACUTE #x100000a8)
+(define-keysym :HP-MUTE-GRAVE #x100000a9)
 (define-keysym :HP-MUTE-ASCIICIRCUM #x100000aa)
-(define-keysym :HP-MUTE--DIAERESIS #x100000ab)
+(define-keysym :HP-MUTE-DIAERESIS #x100000ab)
 (define-keysym :HP-MUTE-ASCII-TILDE #x100000ac)
 (define-keysym :HP-LIRA #x100000af)
 (define-keysym :HP-GUILDER #x100000be)
@@ -1625,10 +1625,10 @@
 (define-keysym :KP-BACK-TAB #x1000ff75)
 (define-keysym :EXT16BIT-L #x1000ff76)
 (define-keysym :EXT16BIT-R #x1000ff77)
-(define-keysym :MUTE--ACUTE #x100000a8)
-(define-keysym :MUTE--GRAVE #x100000a9)
+(define-keysym :MUTE-ACUTE #x100000a8)
+(define-keysym :MUTE-GRAVE #x100000a9)
 (define-keysym :MUTE-ASCIICIRCUM #x100000aa)
-(define-keysym :MUTE--DIAERESIS #x100000ab)
+(define-keysym :MUTE-DIAERESIS #x100000ab)
 (define-keysym :MUTE-ASCII-TILDE #x100000ac)
 (define-keysym :LIRA #x100000af)
 (define-keysym :GUILDER #x100000be)



From gbaumann at common-lisp.net  Mon Nov 28 17:00:34 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 28 Nov 2005 18:00:34 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/gadgets.lisp 
Message-ID: <20051128170034.12187880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv10998

Modified Files:
	gadgets.lisp 
Log Message:
SCROLL-BAR-PANE
    Complete overhaul:

    - The blitter hack now works, because we round coordinates to
      integers, COPY-AREA was fixed for case we work under a
      transformation and finally because we get :graphcis-exposure 
      events.

    - We use poor man's incremental redisplay for updating the scroll
      bar display. So now, when changing the value of a scroll bar
      without actually changing it, we don't have a flickering display
      anymore.

    - The thumb bed is drawn in *3D-INNER-COLOR*, which is slightly
      darker than the background of the thumb itself. This leads to
      more clearly visible thumb.

    - The thumb won't get smaller than +MINIMUM-THUMB-SIZE-IN-PIXELS+,
      so a really large stream pane, won't cause such an usability 
      problem anymore.


Date: Mon Nov 28 18:00:33 2005
Author: gbaumann

Index: mcclim/gadgets.lisp
diff -u mcclim/gadgets.lisp:1.91 mcclim/gadgets.lisp:1.92
--- mcclim/gadgets.lisp:1.91	Wed Oct 12 16:22:27 2005
+++ mcclim/gadgets.lisp	Mon Nov 28 18:00:32 2005
@@ -1286,17 +1286,25 @@
 ;;; ------------------------------------------------------------------------------------------
 ;;;  30.4.4 The concrete scroll-bar Gadget
 
-(defclass scroll-bar-pane (sheet-multiple-child-mixin
-                           3D-border-mixin
-                           scroll-bar
-                           )
+(defclass scroll-bar-pane (3D-border-mixin
+                           scroll-bar)
   ((event-state :initform nil)
    (drag-dy :initform nil)
-   (inhibit-redraw-p
-    :initform nil
-    :documentation "Hack, when set to non-NIL changing something does not trigger redrawing.")
-   (thumb :initform nil)
-   )
+   ;;; poor man's incremental redisplay
+   ;; drawn state
+   (up-state :initform nil)
+   (dn-state :initform nil)
+   (tb-state :initform nil)
+   (tb-y1    :initform nil)
+   (tb-y2    :initform nil)
+   ;; old drawn state
+   (old-up-state :initform nil)
+   (old-dn-state :initform nil)
+   (old-tb-state :initform nil)
+   (old-tb-y1    :initform nil)
+   (old-tb-y2    :initform nil)
+   ;;
+   (all-new-p    :initform t) )
   (:default-initargs :value 0
                      :min-value 0
                      :max-value 1
@@ -1317,95 +1325,115 @@
 			      :min-width (* 3 *scrollbar-thickness*)
 			      :width (* 4 *scrollbar-thickness*))))
 
-;;; The thumb of a scroll bar
+;;;; Redisplay
 
-;; work in progress --GB
+(defun scroll-bar/update-display (scroll-bar)
+  (with-slots (up-state dn-state tb-state tb-y1 tb-y2
+               old-up-state old-dn-state old-tb-state old-tb-y1 old-tb-y2
+               all-new-p)
+      scroll-bar
+    ;;
+    (scroll-bar/compute-display scroll-bar)
+    ;; redraw up arrow
+    (unless (and (not all-new-p) (eql up-state old-up-state))
+      (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
+        (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-up-region scroll-bar)
+          (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*)
+          (let ((pg (list (make-point (/ (+ x1 x2) 2) y1)
+                          (make-point x1 y2)
+                          (make-point x2 y2))))
+            (case up-state
+              (:armed
+               (draw-polygon scroll-bar pg :ink *3d-inner-color*)
+               (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2))
+              (otherwise
+               (draw-polygon scroll-bar pg :ink *3d-normal-color*)
+               (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2) ))))) )
+    ;; redraw dn arrow
+    (unless (and (not all-new-p) (eql dn-state old-dn-state))
+      (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
+        (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-down-region scroll-bar)
+          (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*)
+          (let ((pg (list (make-point (/ (+ x1 x2) 2) y2)
+                          (make-point x1 y1)
+                          (make-point x2 y1))))
+            (case dn-state
+              (:armed
+               (draw-polygon scroll-bar pg :ink *3d-inner-color*)
+               (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2))
+              (otherwise
+               (draw-polygon scroll-bar pg :ink *3d-normal-color*)
+               (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2)))))))
+    ;; thumb
+    (unless (and (not all-new-p)
+                 (and (eql tb-state old-tb-state)
+                      (eql tb-y1 old-tb-y1)
+                      (eql tb-y2 old-tb-y2)))
+      (cond ((and (not all-new-p)
+                  (eql tb-state old-tb-state)
+                  (numberp tb-y1) (numberp old-tb-y1)
+                  (numberp tb-y2) (numberp old-tb-y2)
+                  (= (- tb-y2 tb-y1) (- old-tb-y2 old-tb-y1)))
+             ;; Thumb is just moving, compute old and new region
+             (multiple-value-bind (x1 ignore.1 x2 ignore.2)
+                 (bounding-rectangle* (scroll-bar-thumb-bed-region scroll-bar))
+               (declare (ignore ignore.1 ignore.2))
+               ;; compute new and old region
+               (with-sheet-medium (medium scroll-bar)
+                 (with-drawing-options (medium :transformation (scroll-bar-transformation scroll-bar))
+                   (multiple-value-bind (ox1 oy1 ox2 oy2) (values x1 old-tb-y1 x2 old-tb-y2)
+                     (multiple-value-bind (nx1 ny1 nx2 ny2) (values x1 tb-y1 x2 tb-y2)
+                       (declare (ignore nx2))
+                       (copy-area medium ox1 oy1 (- ox2 ox1) (- oy2 oy1) nx1 ny1)
+                       ;; clear left-overs from the old region
+                       (if (< oy1 ny1)
+                           (draw-rectangle* medium ox1 oy1 ox2 ny1 :ink *3d-inner-color*)
+                           (draw-rectangle* medium ox1 oy2 ox2 ny2 :ink *3d-inner-color*)))) ))))
+             (t
+              ;; redraw whole thumb bed and thumb all anew
+              (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
+                  (with-bounding-rectangle* (bx1 by1 bx2 by2) (scroll-bar-thumb-bed-region scroll-bar)
+                    (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar)
+                      (draw-rectangle* scroll-bar bx1 by1 bx2 y1 :ink *3d-inner-color*)
+                      (draw-rectangle* scroll-bar bx1 y2 bx2 by2 :ink *3d-inner-color*)
+                      (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-normal-color*)
+                      (draw-bordered-polygon scroll-bar
+                                             (polygon-points (make-rectangle* x1 y1 x2 y2))
+                                             :style :outset
+                                             :border-width 2)
+                    ;;;;;;
+                      (let ((y (/ (+ y1 y2) 2)))
+                        (draw-bordered-polygon scroll-bar
+                                               (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1)))
+                                               :style :inset
+                                               :border-width 1)
+                        (draw-bordered-polygon scroll-bar
+                                               (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2)))
+                                               :style :inset
+                                               :border-width 1)
+                        (draw-bordered-polygon scroll-bar
+                                               (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2)))
+                                               :style :inset
+                                               :border-width 1))))))))
+    (setf old-up-state up-state
+          old-dn-state dn-state
+          old-tb-state tb-state
+          old-tb-y1 tb-y1
+          old-tb-y2 tb-y2
+          all-new-p nil) ))
+
+(defun scroll-bar/compute-display (scroll-bar)
+  (with-slots (up-state dn-state tb-state tb-y1 tb-y2
+                        event-state) scroll-bar
+    (setf up-state (if (eq event-state :up-armed) :armed nil))
+    (setf dn-state (if (eq event-state :dn-armed) :armed nil))
+    (setf tb-state nil)                 ;we have no armed display yet
+    (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar)
+      (declare (ignore x1 x2))
+      (setf tb-y1 y1
+            tb-y2 y2))))
 
-#||
-(defclass scroll-bar-thumb-pane (arm/disarm-repaint-mixin
-                                 basic-gadget)
-  ((tr :initform nil)
-   (allowed-region :initarg :allowed-region))
-  (:default-initargs
-      :background *3d-normal-color*))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-enter-event))
-  (declare (ignoreable event))
-  (with-slots (armed) pane
-    (arm-gadget pane (adjoin :have-mouse armed))))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-exit-event))
-  (declare (ignoreable event))
-  (with-slots (armed) pane
-    (arm-gadget pane (remove :have-mouse armed))))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-button-press-event))
-  (with-slots (tr armed) pane
-    (arm-gadget pane (adjoin :dragging armed))
-    (setf tr (compose-transformations
-              (make-scaling-transformation 1 1)
-              (compose-transformations
-              (compose-transformations
-               (make-translation-transformation (- (pointer-event-x event)) (- (pointer-event-y event)))
-               (invert-transformation (sheet-delta-transformation (sheet-parent pane) (graft pane))))
-              (invert-transformation (sheet-native-transformation (graft pane)))))) ))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-button-release-event))
-  (with-slots (tr armed) pane
-    (arm-gadget pane (remove :dragging armed))
-    (setf tr nil)) )
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-motion-event))
-  (with-slots (tr allowed-region) pane
-    (when tr
-      (multiple-value-bind (nx ny) (transform-position tr
-                                                       (pointer-event-native-graft-x event)
-                                                       (pointer-event-native-graft-y event))
-        (with-bounding-rectangle* (x1 y1 x2 y2) allowed-region
-          (move-sheet pane
-                      (clamp nx x1 x2)
-                      (clamp ny y1 y2)))))))
-
-(defmethod handle-repaint ((pane scroll-bar-thumb-pane) region)
-  (with-bounding-rectangle* (x1 y1 x2 y2) pane
-    (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane))
-    (draw-bordered-polygon pane
-                           (polygon-points (make-rectangle* x1 y1 x2 y2))
-                           :style :outset
-                           :border-width 2)
-    (let ((y (/ (+ y1 y2) 2)))
-      (draw-bordered-polygon pane
-                             (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1)))
-                             :style :inset
-                             :border-width 1)
-      (draw-bordered-polygon pane
-                             (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2)))
-                             :style :inset
-                             :border-width 1)
-      (draw-bordered-polygon pane
-                             (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2)))
-                             :style :inset
-                             :border-width 1))))
-
-;;;
-
-(defmethod sheet-adopt-child :after (sheet (scroll-bar scroll-bar-pane))
-  ;; create a sheet for the thumb
-  '(with-slots (thumb) scroll-bar
-    (setf thumb (make-pane 'scroll-bar-thumb-pane
-                           :allowed-region (make-rectangle* 2 15 14 340)
-                           ))
-    (setf (sheet-region thumb)
-          (make-rectangle* 0 0 12 50))
-    (setf (sheet-transformation thumb)
-          (compose-transformations
-           (make-transformation 1 0 0 1 0 0)
-           (make-translation-transformation 2 0)))
-    (sheet-adopt-child scroll-bar thumb)))
-
-||#
-
-;;; Utilities
+;;;; Utilities
 
 ;; We think all scroll bars as vertically oriented, therefore we have
 ;; SCROLL-BAR-TRANSFORMATION, which should make every scroll bar
@@ -1419,26 +1447,31 @@
 (defun translate-range-value (a mina maxa mino maxo)
   "When \arg{a} is some value in the range from \arg{mina} to \arg{maxa},
    proportionally translate the value into the range \arg{mino} to \arg{maxo}."
-  (+ mino (* (/ (- a mina) (- maxa mina)) (- maxo mino))))
+  (+ mino (* (/ (- a mina)
+                (- maxa mina))          ;### avoid divide by zero here.
+             (- maxo mino))))
+
+;;;; SETF :after methods
 
-;;; Scroll-bar's sub-regions
+(defmethod (setf gadget-min-value) :after (new-value (pane scroll-bar-pane))
+  (declare (ignore new-value))
+  (scroll-bar/update-display pane))
+
+(defmethod (setf gadget-max-value) :after (new-value (pane scroll-bar-pane))
+  (declare (ignore new-value))
+  (scroll-bar/update-display pane))
 
-(defmethod (setf scroll-bar-thumb-size) :after (new-value (sb scroll-bar-pane))
+(defmethod (setf scroll-bar-thumb-size) :after (new-value (pane scroll-bar-pane))
   (declare (ignore new-value))
-  (with-slots (inhibit-redraw-p thumb) sb
-    #||
-    ;;work in progress
-    (setf (sheet-region thumb)
-          (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
-            (multiple-value-bind (minv maxv) (gadget-range* sb)
-              (multiple-value-bind (v) (gadget-value sb)
-                (let ((ts (scroll-bar-thumb-size sb)))
-                  (let ((ya (translate-range-value v minv (+ maxv ts) y1 y2))
-                        (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2)))
-                    (make-rectangle* 0 0 (- x2 x1) (- yb ya))))))))
-    ||#
-    (unless inhibit-redraw-p
-      (dispatch-repaint sb +everywhere+)))) ;arg...
+  (scroll-bar/update-display pane))
+
+(defmethod (setf gadget-value) :after (new-value (pane scroll-bar-pane) &key invoke-callback)
+  (declare (ignore new-value invoke-callback))
+  (scroll-bar/update-display pane))
+
+;;;; geometry
+
+(defparameter +minimum-thumb-size-in-pixels+ 30)
 
 (defmethod scroll-bar-up-region ((sb scroll-bar-pane))
   (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
@@ -1454,70 +1487,57 @@
     (make-rectangle* minx (- maxy (- maxx minx))
                      maxx maxy)))
 
-(defmethod scroll-bar-thumb-bed-region ((sb scroll-bar-pane))
+(defun scroll-bar/thumb-bed* (sb)
+  ;; -> y1 y2 y3
   (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
                                                                     (pane-inner-region sb))
-    (make-rectangle* minx (+ miny (- maxx minx) 1)
-                     maxx (- maxy (- maxx minx) 1))))
-
-(defmethod scroll-bar-thumb-region ((sb scroll-bar-pane))
-  (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
-    (multiple-value-bind (minv maxv) (gadget-range* sb)
-      (multiple-value-bind (v) (gadget-value sb)
-        (let ((ts (scroll-bar-thumb-size sb)))
-          (let ((ya (translate-range-value v minv (+ maxv ts) y1 y2))
-                (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2)))
-            (make-rectangle* x1 ya x2 yb)))))))
-
-#||
-;; alternative:
-
-(defmethod scroll-bar-up-region ((sb scroll-bar-pane))
-  (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
-                                                                    (sheet-region sb))
-    (make-rectangle* (+ minx 2) (- (- maxy (* 2 (- maxx minx))) 2)
-                     (- maxx 2) (- (- maxy (- maxx minx)) 2))))
-
-(defmethod scroll-bar-down-region ((sb scroll-bar-pane))
-  (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
-                                                                    (sheet-region sb))
-    (make-rectangle* (+ minx 2) (+ (- maxy (- maxx minx)) 2)
-                     (- maxx 2) (-  maxy 2))))
+    (let ((y1 (+ miny (- maxx minx) 1))
+          (y3 (- maxy (- maxx minx) 1)))
+      (let ((ts (scroll-bar-thumb-size sb)))
+        ;; This is the right spot to handle ts = :none or perhaps NIL
+        (multiple-value-bind (range) (gadget-range sb)
+          (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (+ range ts)))))) ;### range + ts = 0?
+            (setf ts-in-pixels (min (- y3 y1) ;thumb can't be larger than the thumb bed
+                                    (max +minimum-thumb-size-in-pixels+ ;but shouldn't be smaller than this.
+                                         ts-in-pixels)))
+            (values
+             y1
+             (- y3 ts-in-pixels)
+             y3)))))))
 
 (defmethod scroll-bar-thumb-bed-region ((sb scroll-bar-pane))
   (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
-                                                                    (sheet-region sb))
-    (make-rectangle* (+ minx 2) (+ miny 2 )
-                     (- maxx 2) (- maxy 2 (* 2 (- maxx minx)) 2))))
+                                                                    (pane-inner-region sb))
+    (declare (ignore miny maxy))
+    (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+      (declare (ignore y2))
+      (make-rectangle* minx y1
+                       maxx y3))))
+
+(defun scroll-bar/map-coordinate-to-value (sb y)
+  (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+    (declare (ignore y3))
+    (multiple-value-bind (minv maxv) (gadget-range* sb)
+      (if (= y1 y2)             ;### fix this in translate-range-value
+          minv
+          (translate-range-value y y1 y2 minv maxv)))))
+
+(defun scroll-bar/map-value-to-coordinate (sb v)
+  (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+    (declare (ignore y3))
+    (multiple-value-bind (minv maxv) (gadget-range* sb)
+      ;; oops, if the range is empty we lose!
+      (if (= minv maxv)         ;### fix this in translate-range-value
+          y1
+          (round (translate-range-value v minv maxv y1 y2))))))
 
 (defmethod scroll-bar-thumb-region ((sb scroll-bar-pane))
   (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
-    (multiple-value-bind (minv maxv) (gadget-range* sb)
-      (multiple-value-bind (v) (gadget-value sb)
-        (let ((ts (scroll-bar-thumb-size sb)))
-          (let ((ya (translate-range-value v minv (+ maxv ts) y1 y2))
-                (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2)))
-            (make-rectangle* x1 ya x2 yb)))))))
-||#
-
-
-;;; Event handlers
-
-#||
-(defmethod handle-event ((sb scroll-bar-pane) (event pointer-enter-event))
-  (declare (ignorable event))
-  (with-slots (armed) sb
-     (unless armed
-       (setf armed t)
-       (armed-callback sb (gadget-client sb) (gadget-id sb)))))
-
-(defmethod handle-event ((sb scroll-bar-pane) (event pointer-exit-event))
-  (declare (ignorable event))
-  (with-slots (armed) sb
-     (when armed
-       (setf armed nil)
-       (disarmed-callback sb (gadget-client sb) (gadget-id sb)))))
-||#
+    (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+      (let ((y4 (scroll-bar/map-value-to-coordinate sb (gadget-value sb))))
+        (make-rectangle* x1 y4 x2 (+ y4 (- y3 y2)))))))
+
+;;;; event handler
 
 (defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-press-event))
   (multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb)
@@ -1526,14 +1546,16 @@
       (cond ((region-contains-position-p (scroll-bar-up-region sb) x y)
              (scroll-up-line-callback sb (gadget-client sb) (gadget-id sb))
              (setf event-state :up-armed)
-             (dispatch-repaint sb +everywhere+))
+             (scroll-bar/update-display sb))
             ((region-contains-position-p (scroll-bar-down-region sb) x y)
              (scroll-down-line-callback sb (gadget-client sb) (gadget-id sb))
              (setf event-state :dn-armed)
-             (dispatch-repaint sb +everywhere+))
+             (scroll-bar/update-display sb))
+            ;;
             ((region-contains-position-p (scroll-bar-thumb-region sb) x y)
              (setf event-state :dragging
                    drag-dy (- y (bounding-rectangle-min-y (scroll-bar-thumb-region sb)))))
+            ;;
             ((region-contains-position-p (scroll-bar-thumb-bed-region sb) x y)
              (if (< y (bounding-rectangle-min-y (scroll-bar-thumb-region sb)))
                  (scroll-up-page-callback sb (gadget-client sb) (gadget-id sb))
@@ -1541,109 +1563,36 @@
             (t
              nil)))))
 
-(defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-release-event))
-  (with-slots (event-state) sb
-    (case event-state
-      (:up-armed (setf event-state nil))
-      (:dn-armed (setf event-state nil))
-      (otherwise
-       (setf event-state nil) )))
-  (dispatch-repaint sb +everywhere+) )
-
 (defmethod handle-event ((sb scroll-bar-pane) (event pointer-motion-event))
   (multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb)
                                                  (pointer-event-x event) (pointer-event-y event))
     (declare (ignore x))
-    (with-slots (event-state drag-dy inhibit-redraw-p) sb
+    (with-slots (event-state drag-dy) sb
       (case event-state
         (:dragging
          (let* ((y-new-thumb-top (- y drag-dy))
-                (ts (scroll-bar-thumb-size sb))
-                (new-value (min (gadget-max-value sb)
-                                (max (gadget-min-value sb)
-                                     (translate-range-value y-new-thumb-top
-                                                            (bounding-rectangle-min-y (scroll-bar-thumb-bed-region sb))
-                                                            (bounding-rectangle-max-y (scroll-bar-thumb-bed-region sb))
-                                                            (gadget-min-value sb)
-                                                            (+ (gadget-max-value sb) ts))))))
-           ;; Blitter hack:
-           #-nil
-           (with-drawing-options (sb :transformation (scroll-bar-transformation sb))
-             (with-bounding-rectangle* (ox1 oy1 ox2 oy2) (scroll-bar-thumb-region sb)
-               (setf (gadget-value sb) new-value)
-               (with-bounding-rectangle* (nx1 ny1 nx2 ny2) (scroll-bar-thumb-region sb)
-		 (declare (ignore nx2))
-                 (copy-area sb ox1 oy1 (- ox2 ox1) (- oy2 oy1) nx1 ny1)
-                 (if (< oy1 ny1)
-                     (draw-rectangle* sb ox1 oy1 ox2 ny1 :ink *3d-normal-color*)
-                     (draw-rectangle* sb ox1 oy2 ox2 ny2 :ink *3d-normal-color*)))))
-           #+nil
-           (dispatch-repaint sb +everywhere+)
-           (unwind-protect
-                (progn
-                  (setf inhibit-redraw-p t)
-                  (setf (gadget-value sb) new-value)
-                  (drag-callback sb (gadget-client sb) (gadget-id sb)
-                                 new-value))
-             (setf inhibit-redraw-p nil))
-           ))))))
-
-;;; Repaint
-
-(defmethod handle-repaint ((sb scroll-bar-pane) region)
-  (declare (ignore region))
-  (with-special-choices (sb)
-    (let ((tr (scroll-bar-transformation sb)))
-      (with-bounding-rectangle* (minx miny maxx maxy) (transform-region tr (sheet-region sb))
-        (with-drawing-options (sb :transformation tr)
-          (draw-rectangle* sb minx miny maxx maxy :filled t
-                           :ink *3d-normal-color*)
-          ;; draw up arrow
-          (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-up-region sb)
-            (let ((pg (list (make-point (/ (+ x1 x2) 2) y1)
-                            (make-point x1 y2)
-                            (make-point x2 y2))))
-              (case (slot-value sb  'event-state)
-                (:up-armed
-                 (draw-polygon sb pg :ink *3d-inner-color*)
-                 (draw-bordered-polygon sb pg :style :inset :border-width 2))
-                (otherwise
-                 (draw-polygon sb pg :ink *3d-normal-color*)
-                 (draw-bordered-polygon sb pg :style :outset :border-width 2) ))))
-
-          ;; draw down arrow
-          (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-down-region sb)
-            (let ((pg (list (make-point (/ (+ x1 x2) 2) y2)
-                            (make-point x1 y1)
-                            (make-point x2 y1))))
-              (case (slot-value sb 'event-state)
-                (:dn-armed
-                 (draw-polygon sb pg :ink *3d-inner-color*)
-                 (draw-bordered-polygon sb pg :style :inset :border-width 2))
-                (otherwise
-                 (draw-polygon sb pg :ink *3d-normal-color*)
-                 (draw-bordered-polygon sb pg :style :outset :border-width 2)))))
-          ;; draw thumb
-          (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region sb)
-            (draw-rectangle* sb x1 y1 x2 y2 :ink *3d-normal-color*)
-            (draw-bordered-polygon sb
-                                   (polygon-points (make-rectangle* x1 y1 x2 y2))
-                                   :style :outset
-                                   :border-width 2)
-            (let ((y (/ (+ y1 y2) 2)))
-              (draw-bordered-polygon sb
-                                     (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1)))
-                                     :style :inset
-                                     :border-width 1)
-              (draw-bordered-polygon sb
-                                     (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2)))
-                                     :style :inset
-                                     :border-width 1)
-              (draw-bordered-polygon sb
-                                     (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2)))
-                                     :style :inset
-                                     :border-width 1))) )))))
+                (new-value
+                 (min (gadget-max-value sb)
+                      (max (gadget-min-value sb)
+                           (scroll-bar/map-coordinate-to-value sb y-new-thumb-top)))) )
+           ;; ### when dragging value shouldn't be immediately updated
+           (setf (gadget-value sb #|:invoke-callback nil|#)
+                 new-value)
+           (drag-callback sb (gadget-client sb) (gadget-id sb) new-value)) )))))
+
+(defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-release-event))
+  (with-slots (event-state) sb
+    (case event-state
+      (:up-armed (setf event-state nil))
+      (:dn-armed (setf event-state nil))
+      (otherwise
+       (setf event-state nil) )))
+  (scroll-bar/update-display sb) )
 
+(defmethod handle-repaint ((pane scroll-bar-pane) region)
+  (with-slots (all-new-p) pane
+    (setf all-new-p t)
+    (scroll-bar/update-display pane)))
 
 ;;; ------------------------------------------------------------------------------------------
 ;;;  30.4.5 The concrete slider Gadget



From gbaumann at common-lisp.net  Tue Nov 29 10:42:00 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Tue, 29 Nov 2005 11:42:00 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051129104200.E0D9F880D7@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv26678

Modified Files:
	panes.lisp 
Log Message:
SCROLLER-PANE
    The SCROLL-BAR initarg now also takes NIL.

Date: Tue Nov 29 11:41:59 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.160 mcclim/panes.lisp:1.161
--- mcclim/panes.lisp:1.160	Mon Nov 28 16:24:37 2005
+++ mcclim/panes.lisp	Tue Nov 29 11:41:59 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.160 2005/11/28 15:24:37 gbaumann Exp $
+;;; $Id: panes.lisp,v 1.161 2005/11/29 10:41:59 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -1824,10 +1824,23 @@
 (defparameter *scrollbar-thickness* 17)
 
 (defclass scroller-pane (composite-pane)
-  ((scroll-bar :type (member t :vertical :horizontal)
-	       :initform t
-	       :initarg :scroll-bar
-	       :accessor scroller-pane-scroll-bar)
+  ((scroll-bar :type (member t :vertical :horizontal nil)
+               ;; ### Note: I added NIL here, so that the application
+               ;; programmer can switch off scroll bars alltogether. 
+               ;; The spec though has it neither in the description of
+               ;; SCROLLER-PANE, nor in the description of
+               ;; MAKE-CLIM-STREAM-PANE, but in OPEN-WINDOW-STREAM.
+               ;;
+               ;; One might argue that in case of no scroll-bars the
+               ;; application programmer can just skip the scroller
+               ;; pane altogether. But I think that the then needed
+               ;; special casing on having a scroller pane or a bare
+               ;; viewport at hand is an extra burden, that can be
+               ;; avoided.
+               ;; --GB 2005-11-29
+               :initform t
+               :initarg :scroll-bar
+               :accessor scroller-pane-scroll-bar)
    (viewport   :initform nil)
    (vscrollbar :initform nil)
    (hscrollbar :initform nil)
@@ -1983,7 +1996,7 @@
   (sheet-adopt-child pane (first contents))
   (with-slots (scroll-bar viewport vscrollbar hscrollbar) pane
     (setq viewport (first (sheet-children pane)))
-    (when (not (eq scroll-bar :horizontal))
+    (when (member scroll-bar '(:vertical t))
       (setq vscrollbar
             (make-pane 'scroll-bar-pane
                        :orientation :vertical
@@ -2009,7 +2022,7 @@
                        :min-value 0
                        :max-value 1))
       (sheet-adopt-child pane vscrollbar))
-    (when (not (eq scroll-bar :vertical))
+    (when (member scroll-bar '(:horizontal t))
       (setq hscrollbar
             (make-pane 'scroll-bar-pane
                        :orientation :horizontal



From gbaumann at common-lisp.net  Tue Nov 29 13:04:17 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Tue, 29 Nov 2005 14:04:17 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/gadgets.lisp 
Message-ID: <20051129130417.C185D88554@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv5799

Modified Files:
	gadgets.lisp 
Log Message:
Some attempts to make the different gadget classes match look.

PUSH-BUTTON-PANE, TOGGLE-BUTTON-PANE:
    Changed default spacing initargs to get a better match in look.

GENERIC-OPTION-PANE:
    - Space is computed a little different now to match the look of
      the push button.
    - The widget size now is always square and matched to the overall
      height of the optione pane.
    - We circmumvent the flawed behavior of DRAW-TEXT* and compute the
      base line on our own.

Date: Tue Nov 29 14:04:16 2005
Author: gbaumann

Index: mcclim/gadgets.lisp
diff -u mcclim/gadgets.lisp:1.92 mcclim/gadgets.lisp:1.93
--- mcclim/gadgets.lisp:1.92	Mon Nov 28 18:00:32 2005
+++ mcclim/gadgets.lisp	Tue Nov 29 14:04:16 2005
@@ -1090,7 +1090,7 @@
     :align-x :center
     :align-y :center
     :x-spacing 4
-    :y-spacing 4))
+    :y-spacing 2))
 
 (defmethod compose-space ((gadget push-button-pane) &key width height)
   (declare (ignore width height))
@@ -1161,8 +1161,8 @@
    :text-style (make-text-style :sans-serif nil nil)
     :align-x :left
     :align-y :center
-    :x-spacing 3
-    :y-spacing 3
+    :x-spacing 2
+    :y-spacing 2
     :background *3d-normal-color*))
 
 (defmethod compose-space ((pane toggle-button-pane) &key width height)
@@ -2257,8 +2257,9 @@
         (generic-option-pane-compute-label-from-value gadget new-value)))
 
 (defmethod generic-option-pane-widget-size (pane)
-  (declare (ignore pane))
-  (values 22 16))
+  ;; We now always make the widget occupying a square.
+  (let ((h (bounding-rectangle-height pane)))
+    (values h h)))
 
 (defun draw-engraved-vertical-separator (pane x y0 y1 highlight-color shadow-color)
   (draw-line* pane (1+ x) (1+ y0) (1+ x) (1- y1) :ink highlight-color)
@@ -2297,20 +2298,22 @@
 
 (defmethod compose-space ((pane generic-option-pane) &key width height)
   (declare (ignore width height))
-  (multiple-value-bind (w-width w-height)
-      (generic-option-pane-widget-size pane)
-    (let* ((horizontal-padding 20)
-           (vertical-padding   10)
-           (l-width  (generic-option-pane-compute-max-label-width pane))
-           (l-height (text-style-height (pane-text-style pane) (sheet-medium pane)))
-           (total-width (+ horizontal-padding l-width w-width))
-           (total-height (+ vertical-padding (max l-height w-height))))
-      (make-space-requirement :min-width total-width
-                              :width total-width
-                              :max-width +fill+
-                              :min-height total-height
-                              :height total-height
-                              :max-height total-height))))
+  (let* ((horizontal-padding 8)         ;### 2px border + 2px padding each side
+         (vertical-padding   8)         ;### this should perhaps be computed from
+                                        ;### border-width and spacing.
+         (l-width  (generic-option-pane-compute-max-label-width pane))
+         (l-height (text-style-height (pane-text-style pane) (sheet-medium pane)))
+         (total-width (+ horizontal-padding l-width
+                         ;; widget width
+                         l-height
+                         8))
+         (total-height (+ vertical-padding l-height)))
+    (make-space-requirement :min-width total-width
+                            :width total-width
+                            :max-width +fill+
+                            :min-height total-height
+                            :height total-height
+                            :max-height total-height)))
 
 (defmethod generic-option-pane-draw-widget (pane)
   (with-bounding-rectangle* (x0 y0 x1 y1) pane
@@ -2519,8 +2522,14 @@
       (declare (ignore widget-height))
       (draw-rectangle* pane x0 y0 x1 y1 :ink (effective-gadget-background pane))
       (let* ((tx1 (- x1 widget-width)))
-        (draw-text* pane (slot-value pane 'current-label) (/ (- tx1 x0) 2) (/ (- y1 y0) 2)
-                    :align-x :center :align-y :center))
+        (draw-text* pane (slot-value pane 'current-label)
+                    (/ (- tx1 x0) 2)
+                    (/ (+ (- y1 y0)
+                           (- (text-style-ascent (pane-text-style pane) pane)
+                              (text-style-descent (pane-text-style pane) pane)))
+                        2)
+                    :align-x :center
+                    :align-y :baseline))
       (generic-option-pane-draw-widget pane))))
         
 



From gbaumann at common-lisp.net  Tue Nov 29 13:18:29 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Tue, 29 Nov 2005 14:18:29 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051129131829.24A0688554@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv6907

Modified Files:
	panes.lisp 
Log Message:
LOWERED-PANE
    border-width defaults to 2 now.

LABEL-PANE
    align-y defaults to :center now.

Date: Tue Nov 29 14:18:28 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.161 mcclim/panes.lisp:1.162
--- mcclim/panes.lisp:1.161	Tue Nov 29 11:41:59 2005
+++ mcclim/panes.lisp	Tue Nov 29 14:18:28 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.161 2005/11/29 10:41:59 gbaumann Exp $
+;;; $Id: panes.lisp,v 1.162 2005/11/29 13:18:28 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -1736,7 +1736,10 @@
 
 ;;; LOWERED PANE
 
-(defclass lowered-pane (border-pane permanent-medium-sheet-output-mixin) ())
+(defclass lowered-pane (border-pane permanent-medium-sheet-output-mixin)
+  ()
+  (:default-initargs
+   :border-width 2))
 
 (defmacro lowering ((&rest options) &body contents)
   `(make-pane 'lowered-pane , at options :contents (list , at contents)))
@@ -2133,9 +2136,9 @@
               :initform :top
               :initarg :label-alignment
               :reader label-pane-label-alignment)
-   (background :initform *3d-normal-color*)
-   )
+   (background :initform *3d-normal-color*))
   (:default-initargs
+   :align-y    :center
    :text-style (make-text-style :sans-serif nil nil))
   (:documentation ""))
 



From gbaumann at common-lisp.net  Tue Nov 29 14:46:57 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Tue, 29 Nov 2005 15:46:57 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051129144657.9087088554@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv13495

Modified Files:
	panes.lisp 
Log Message:
SCROLLER-PANE
    We now interpret the x-spacing and y-spacing options as extra
    space to put around the viewport. The default for that is now 4 to
    reading what is in a stream pane easier.

Date: Tue Nov 29 15:46:54 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.162 mcclim/panes.lisp:1.163
--- mcclim/panes.lisp:1.162	Tue Nov 29 14:18:28 2005
+++ mcclim/panes.lisp	Tue Nov 29 15:46:53 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.162 2005/11/29 13:18:28 gbaumann Exp $
+;;; $Id: panes.lisp,v 1.163 2005/11/29 14:46:53 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -1848,7 +1848,10 @@
    (vscrollbar :initform nil)
    (hscrollbar :initform nil)
    (suggested-width  :initform 300 :initarg :suggested-width)
-   (suggested-height :initform 300 :initarg :suggested-height)))
+   (suggested-height :initform 300 :initarg :suggested-height))
+  (:default-initargs
+   :x-spacing 4
+   :y-spacing 4))
 
 (defmacro scrolling ((&rest options) &body contents)
   `(let ((viewport (make-pane 'viewport-pane :contents (list , at contents))))
@@ -1889,7 +1892,7 @@
         (make-space-requirement))))
 
 (defmethod allocate-space ((pane scroller-pane) width height)
-  (with-slots (viewport vscrollbar hscrollbar) pane
+  (with-slots (viewport vscrollbar hscrollbar x-spacing y-spacing) pane
     (let ((viewport-width  (if vscrollbar (- width  *scrollbar-thickness*) width))
           (viewport-height (if hscrollbar (- height *scrollbar-thickness*) height)))
       
@@ -1946,10 +1949,11 @@
       (when viewport
         (setf (sheet-transformation viewport)
               (make-translation-transformation
-                   (if vscrollbar *scrollbar-thickness* 0) 0))
+                   (+ x-spacing (if vscrollbar *scrollbar-thickness* 0))
+                   (+ y-spacing 0)))
         (allocate-space viewport
-                        viewport-width
-                        viewport-height)))))
+                        (- viewport-width (* 2 x-spacing))
+                        (- viewport-height (* 2 y-spacing)))))))
 
 ;;;; Initialization
 
@@ -1999,6 +2003,12 @@
   (sheet-adopt-child pane (first contents))
   (with-slots (scroll-bar viewport vscrollbar hscrollbar) pane
     (setq viewport (first (sheet-children pane)))
+    ;; make the background of the viewport match the background of the
+    ;; things scrolled.
+    (when (first (sheet-children viewport))
+      (setf (slot-value pane 'background)  ;### hmm ...
+            (pane-background (first (sheet-children viewport)))))
+    ;;
     (when (member scroll-bar '(:vertical t))
       (setq vscrollbar
             (make-pane 'scroll-bar-pane



From gbaumann at common-lisp.net  Wed Nov 30 10:30:56 2005
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Wed, 30 Nov 2005 11:30:56 +0100 (CET)
Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp 
Message-ID: <20051130103056.209F388599@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv5424

Modified Files:
	panes.lisp 
Log Message:
HRACK-PANE, VRACK-PANE
    These panes are back to their old behavior to force the minor
    dimension of their children to their own minor dimension.

SCROLLER-PANE
    If there are no scroll bars, we allow the scroll-pane to shrink up
    until its spacing.

Date: Wed Nov 30 11:30:54 2005
Author: gbaumann

Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.163 mcclim/panes.lisp:1.164
--- mcclim/panes.lisp:1.163	Tue Nov 29 15:46:53 2005
+++ mcclim/panes.lisp	Wed Nov 30 11:30:50 2005
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.163 2005/11/29 14:46:53 gbaumann Exp $
+;;; $Id: panes.lisp,v 1.164 2005/11/30 10:30:50 gbaumann Exp $
 
 (in-package :clim-internals)
 
@@ -461,24 +461,34 @@
    align-x, align-y name the desired child alignment.
    If the child does not have enough strechability to cover all of the
    given area, it is aligned within that area according to the given
-   options."
+   options.
+
+   As a special option we allow align-x or align-y be :expand, which
+   means that the child wouldn't be aligned in that direction but its
+   size would be forced."
   (let* ((sr           (compose-space child))
          ;; The child's dimension is clamped within its min/max space requirement
-         (child-width  (clamp width
-                              (space-requirement-min-width sr)
-                              (space-requirement-max-width sr)))
-         (child-height (clamp height
-                              (space-requirement-min-height sr)
-                              (space-requirement-max-height sr)))
+         (child-width  (if (eql :expand align-x)
+                           width
+                           (clamp width
+                                  (space-requirement-min-width sr)
+                                  (space-requirement-max-width sr))))
+         (child-height (if (eql :expand align-y)
+                           height
+                           (clamp height
+                                  (space-requirement-min-height sr)
+                                  (space-requirement-max-height sr))))
          ;; Align the child within the available area
          (child-x      (ecase align-x
                          ((:left)   x)
                          ((:center) (+ x (/ (- width child-width) 2)))
-                         ((:right)  (+ x (- width child-width)))))
+                         ((:right)  (+ x (- width child-width)))
+                         ((:expand)  x) ))
          (child-y      (ecase align-y
                          ((:top)    y)
                          ((:center) (+ y (/ (- height child-height) 2)))
-                         ((:bottom) (+ y (- height child-height))))))
+                         ((:bottom) (+ y (- height child-height)))
+                         ((:expand)  y) )))
     ;; Actually layout the child
     (move-sheet child child-x child-y)
     (resize-sheet child child-width child-height)
@@ -1235,11 +1245,17 @@
      (values majors
              (mapcar (lambda (x) x minor) minors))))
 
-  (defmethod box-layout-mixin/xically-allocate-space ((pane box-layout-mixin) real-width real-height)
+ ;; Now actually layout the children
+ ;;
+ ;; A rack pane would force the minor dimension of the child. A
+ ;; box pane would just align the child according to the
+ ;; alignment option. We do the same with the minor dimension.
+ ;;
+ 
+ (defmethod box-layout-mixin/xically-allocate-space ((pane box-layout-mixin) real-width real-height)
    (with-slots (major-spacing) pane
      (multiple-value-bind (majors minors)
          (box-layout-mixin/xically-allocate-space-aux* pane real-width real-height)
-       ;; now actually layout the children
        (let ((x 0))
          (loop
              for child in (box-layout-mixin-clients pane)
@@ -1258,9 +1274,35 @@
                              ((lambda (major minor) height width) x 0)
                              ((lambda (major minor) width height) x 0)
                              ((lambda (major minor) height width) width real-width)
-                             ((lambda (major minor) height width) real-height height)))
+                             ((lambda (major minor) height width) real-height height) ))
              (incf x major)
-             (incf x major-spacing)))))) )
+             (incf x major-spacing))))))
+
+ (defmethod box-layout-mixin/xically-allocate-space ((pane rack-layout-mixin) real-width real-height)
+   (with-slots (major-spacing) pane
+     (multiple-value-bind (majors minors)
+         (box-layout-mixin/xically-allocate-space-aux* pane real-width real-height)
+       (let ((x 0))
+         (loop
+             for child in (box-layout-mixin-clients pane)
+             for major in majors
+             for minor in minors
+             do
+             (when (box-client-pane child)
+               #+NIL
+               (format *trace-output* "~&;;   child ~S at 0, ~D ~D x ~D(~D)~%;;       ~S~%"
+                       (box-client-pane child)
+                       x width height real-height
+                       (compose-space (box-client-pane child)))
+               (layout-child (box-client-pane child)
+                             :expand
+                             :expand
+                             ((lambda (major minor) height width) x 0)
+                             ((lambda (major minor) width height) x 0)
+                             ((lambda (major minor) height width) width real-width)
+                             ((lambda (major minor) height width) real-height height) ))
+             (incf x major)
+             (incf x major-spacing)))))))
 
 ;; #+nil
 (defmethod note-sheet-enabled :before ((pane pane))
@@ -1861,15 +1903,17 @@
 
 (defmethod compose-space ((pane scroller-pane) &key width height)
   (declare (ignore width height))
-  (with-slots (viewport vscrollbar hscrollbar suggested-width suggested-height) pane
+  (with-slots (viewport vscrollbar hscrollbar suggested-width suggested-height
+               x-spacing y-spacing scroll-bar)
+      pane
     (if viewport
         (let ((req
                ; v-- where does this requirement come from?
                ;     a: just an arbitrary default
 		(make-space-requirement
                 :width suggested-width :height suggested-height :max-width +fill+ :max-height +fill+
-                :min-width 30
-                :min-height 30)
+                :min-width  (max (* 2 x-spacing) (if (null scroll-bar) 0 30))
+                :min-height (max (* 2 y-spacing) (if (null scroll-bar) 0 30)))
 		#+nil
 		(make-space-requirement :height +fill+ :width +fill+)))
           (when vscrollbar