November 2005 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 30 Nov '05

30 Nov '05

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

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 29 Nov '05

29 Nov '05

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 ,@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

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 29 Nov '05

29 Nov '05

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 ,@options :contents (list ,@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 ""))

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by gbaumann＠common-lisp.net 29 Nov '05

29 Nov '05

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))))

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 29 Nov '05

29 Nov '05

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

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

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

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/keysymdef.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

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)

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

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

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

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)

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

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))

1 0