February 2007 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7529 Modified Files: regions.lisp Log Message: Added internal helper, with-grown-rectangle*. --- /project/mcclim/cvsroot/mcclim/regions.lisp 2006/05/05 10:24:02 1.33 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2007/02/05 03:07:22 1.34 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.33 2006/05/05 10:24:02 crhodes Exp $ +;;; $Id: regions.lisp,v 1.34 2007/02/05 03:07:22 ahefner Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet(a)emi.u-bordeaux.fr) @@ -2378,3 +2378,23 @@ ;; (and (<= u1 x2) (<= x1 u2) ;; (<= v1 y2) (<= y1 v2)))) ) + +;;; Internal helpers + +(defmacro with-grown-rectangle* (((out-x1 out-y1 out-x2 out-y2) + (in-x1 in-y1 in-x2 in-y2) + &key + radius + (radius-x radius) + (radius-y radius) + (radius-left radius-x) + (radius-right radius-x) + (radius-top radius-y) + (radius-bottom radius-y)) + &body body) + `(multiple-value-bind (,out-x1 ,out-y1 ,out-x2 ,out-y2) + (values (- ,in-x1 ,radius-left) + (- ,in-y1 ,radius-top) + (+ ,in-x2 ,radius-right) + (+ ,in-y2 ,radius-bottom)) + ,@body))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7304 Modified Files: recording.lisp presentation-defs.lisp Log Message: Introduce a new function, highlight-output-record-tree, so that records can control how highlighting recurses into their children. Revise definition of null output records to include any record whose upper-left and lower-right coordinates are equal. This is necessary when an empty record is transformed (such as by with-room-for-graphics). --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/11/22 06:26:48 1.129 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/02/05 03:06:14 1.130 @@ -504,13 +504,26 @@ (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record) (ecase state - (:highlight + (:highlight (draw-rectangle* (sheet-medium stream) x1 y1 (1- x2) (1- y2) :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+? (:unhighlight ;; FIXME: repaint the hit detection rectangle. It could be bigger than - ;;; the bounding rectangle. - (repaint-sheet stream record)))))) + ;; the bounding rectangle. + (repaint-sheet stream record) + + ;; Using queue-repaint should be faster in apps (such as clouseau) that + ;; highlight/unhighlight many bounding rectangles at once. The event + ;; code should merge these into a single larger repaint. Unfortunately, + ;; since an enqueued repaint does not occur immediately, and highlight + ;; rectangles are not recorded, newer highlighting gets wiped out + ;; shortly after being drawn. So, we aren't ready for this yet. + #+NIL + (queue-repaint stream (make-instance 'window-repaint-event + :sheet stream + :region (transform-region + (sheet-native-transformation stream) + record)))))))) ;;; XXX Should this only be defined on recording streams? (defmethod highlight-output-record ((record output-record) stream state) @@ -676,8 +689,8 @@ ;;; not affect bounding rectangles. -- Hefner (defun null-bounding-rectangle-p (bbox) (with-bounding-rectangle* (x1 y1 x2 y2) bbox - (and (zerop x1) (zerop y1) - (zerop x2) (zerop y2)))) + (and (= x1 x2) + (= y1 y2)))) ;;; 16.2.3. Output Record Change Notification Protocol (defmethod recompute-extent-for-new-child @@ -770,7 +783,7 @@ ;; If record is currently empty, use the child's bbox directly. Else.. ;; Does the new rectangle of the child contain the original rectangle? ;; If so, we can use min/max to grow record's current rectangle. - ;; If not, the child has shrunk, and we need to fully recompute. + ;; If not, the child has shrunk, and we need to fully recompute. (multiple-value-bind (nx1 ny1 nx2 ny2) (cond ;; The child has been deleted; who knows what the --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/14 19:59:07 1.69 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/02/05 03:06:14 1.70 @@ -1206,21 +1206,28 @@ stream state))) +(defgeneric highlight-output-record-tree (record stream state)) + +(defmethod highlight-output-record-tree (record stream state) + (declare (ignore record stream state)) + (values)) + +(defmethod highlight-output-record-tree ((record compound-output-record) stream state) + (map-over-output-records + (lambda (record) + (highlight-output-record-tree record stream state)) + record)) + +(defmethod highlight-output-record-tree ((record displayed-output-record) stream state) + (highlight-output-record record stream state)) + (define-default-presentation-method highlight-presentation (type record stream state) (declare (ignore type)) (if (or (eq (presentation-single-box record) t) (eq (presentation-single-box record) :highlighting)) - (highlight-output-record-rectangle record stream state) - (labels ((highlighter (record) - (typecase record - (displayed-output-record - (highlight-output-record record stream state)) - (compound-output-record - (map-over-output-records #'highlighter record)) - (t nil)))) - (highlighter record)))) - + (highlight-output-record record stream state) + (highlight-output-record-tree record stream state))) (define-default-presentation-method present (object type stream (view textual-view) &key acceptably for-context-type)

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7169 Modified Files: panes.lisp Log Message: For mouse wheel scrolling, search upward through the pane hierarchy for a viewport to scroll. This fixes mouse wheel scrolling in Clouseau. Assorted other minor changes. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/01/23 07:51:10 1.178 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/02/05 03:02:59 1.179 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.178 2007/01/23 07:51:10 ahefner Exp $ +;;; $Id: panes.lisp,v 1.179 2007/02/05 03:02:59 ahefner Exp $ (in-package :clim-internals) @@ -496,7 +496,7 @@ ((:bottom) (+ y (- height child-height))) ((:expand) y) ))) ;; Actually layout the child - (move-sheet child child-x child-y) + (move-sheet child child-x child-y) (resize-sheet child child-width child-height) (allocate-space child child-width child-height))) @@ -720,8 +720,8 @@ ;; call change-space-requirements on parent pane ;; call note-space-requirements-changed ;; -;; This is splitted into :before, primary and :after method to allow -;; for easy overriding of change-space-requirements without needing to +;; This is split into :before, primary and :after method to allow for +;; easy overriding of change-space-requirements without needing to ;; know the details of the space requirement cache and the ;; note-space-requirements-changed notifications. ;; @@ -1197,10 +1197,10 @@ (wanted (reduce #'+ allot)) (excess (- major wanted (* (1- (length children)) major-spacing)))) - (when *dump-allocate-space* - (format *trace-output* "~&;; ~S ~S~%" - 'box-layout-mixin/xically-allocate-space-aux* box) - (format *trace-output* "~&;; major = ~D, wanted = ~D, excess = ~D, allot = ~D.~%" + (when *dump-allocate-space* + (format *trace-output* "~&;; ~S ~S~%" + 'box-layout-mixin/xically-allocate-space-aux* box) + (format *trace-output* "~&;; major = ~D, wanted = ~D, excess = ~D, allot = ~D.~%" major wanted excess allot)) (let ((qvector @@ -1731,11 +1731,12 @@ (defmethod allocate-space ((pane spacing-pane) width height) (with-slots (border-width) pane - (let ((child (first (sheet-children pane)))) + (let ((child (first (sheet-children pane))) + (new-width (- width border-width border-width)) + (new-height (- height border-width border-width))) (layout-child child (pane-align-x pane) (pane-align-y pane) border-width border-width - (- width border-width border-width) - (- height border-width border-width))))) + new-width new-height)))) ;;; OUTLINED PANE @@ -2167,17 +2168,15 @@ ;;;; Accounting for changed space requirements (defmethod change-space-requirements ((pane clim-extensions:viewport-pane) &rest ignore) - (declare (ignore ignore)) - (let ((client (first (sheet-children pane)))) - (resize-sheet client (max (bounding-rectangle-width pane) - (space-requirement-width (compose-space client))) - (max (bounding-rectangle-height pane) - (space-requirement-height (compose-space client)))) - (allocate-space client - (max (bounding-rectangle-width pane) - (space-requirement-width (compose-space client))) - (max (bounding-rectangle-height pane) - (space-requirement-height (compose-space client)))) + (declare (ignore ignore)) + (let* ((client (first (sheet-children pane))) + (sr (compose-space client)) + (width (max (bounding-rectangle-width pane) + (space-requirement-width sr))) + (height (max (bounding-rectangle-height pane) + (space-requirement-height sr)))) + (resize-sheet client width height) + (allocate-space client width height) (scroller-pane/update-scroll-bars (sheet-parent pane)))) ;;;; @@ -2381,25 +2380,37 @@ (:documentation "Returns the number of pixels respresenting a 'line', used to computed distance to scroll in response to mouse wheel events.")) -(defmethod scroll-quantum (pane) 10) +(defmethod scroll-quantum (pane) 10) ; TODO: Connect this with the scroller-pane motion + +(defun find-viewport-for-scroll (pane) + "Find a viewport in the chain of parents which contains 'pane', + returning this viewport and the sheet immediately contained within." + (cond ((not (typep pane 'basic-pane)) + (values nil nil)) + ((pane-viewport pane) (values (pane-viewport pane) pane)) + (t (find-viewport-for-scroll (sheet-parent pane))))) (defun scroll-sheet (sheet vertical horizontal) - (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) - (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) - (let ((viewport-height (- vy1 vy0)) - (viewport-width (- vx1 vx0)) - (delta (* *mouse-scroll-distance* - (scroll-quantum sheet)))) - ;; The coordinates (x,y) of the new upper-left corner of the viewport - ;; must be "sx0 < x < sx1 - viewport-width" and - ;; "sy0 < y < sy1 - viewport-height" - (scroll-extent sheet - (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) - (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical))))))))) + (multiple-value-bind (viewport sheet) + (find-viewport-for-scroll sheet) + (declare (ignore viewport)) + (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) + (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) + (let ((viewport-height (- vy1 vy0)) + (viewport-width (- vx1 vx0)) + (delta (* *mouse-scroll-distance* + (scroll-quantum sheet)))) + ;; The coordinates (x,y) of the new upper-left corner of the viewport + ;; must be "sx0 < x < sx1 - viewport-width" and + ;; "sy0 < y < sy1 - viewport-height" + (scroll-extent sheet + (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) + (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical)))))))))) +;; Note that handling this from dispatch-event is evil, and we shouldn't. (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin) (event pointer-button-press-event)) - (if (pane-viewport sheet) + (if (find-viewport-for-scroll sheet) (let ((button (pointer-event-button event))) (cond ((eq button +pointer-wheel-up+) (scroll-sheet sheet -1 0)) @@ -2862,5 +2873,6 @@ ; timer-event convenience (defmethod schedule-timer-event ((pane pane) token delay) + (warn "Are you sure you want to use schedule-timer-event? It probably doesn't work.") (schedule-event pane (make-instance 'timer-event :token token :sheet pane) delay))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5398 Modified Files: menu-choose.lisp Log Message: If we're going to stick with these rather unorthodox menus, at least wrap in a 3D border to make them less jarring. Changed color to use the default 3D gadget background, and made less sensitive to the exact hierarchy of gadgets in the menu frame. --- /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2006/08/05 19:54:31 1.19 +++ /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2007/02/05 03:00:54 1.20 @@ -180,15 +180,16 @@ (fm (frame-manager associated-frame))) (with-look-and-feel-realization (fm associated-frame) ; hmm... checkme (let* ((menu-stream (make-pane-1 fm associated-frame 'clim-stream-pane - :background +gray80+)) + :background *3d-normal-color* #+NIL +gray80+)) (container (scrolling (:scroll-bar scroll-bars) menu-stream)) - (frame (make-menu-frame (if label - (labelling (:label label - :label-alignment :top - :background +gray80+) - container) - container) + (frame (make-menu-frame (raising () + (if label + (labelling (:label label + :name 'label + :label-alignment :top) + container) + container)) :left nil :top nil))) (adopt-frame fm frame) @@ -316,12 +317,11 @@ :resize-frame t))) ;; Modify the size and location of the frame as well. - (let* ((label-pane (sheet-parent (pane-scroller menu))) - (top-level-pane (sheet-parent label-pane))) - (when (not (typep label-pane 'label-pane)) - ;; Oops, we have no label. Rebind... - (setf top-level-pane label-pane) - (setf label-pane nil)) + (let* ((top-level-pane (labels ((searching (pane) + (if (typep pane 'top-level-sheet-pane) + pane + (searching (sheet-parent pane))))) + (searching menu)))) (multiple-value-bind (frame-width frame-height) (menu-size top-level-pane *application-frame*) (multiple-value-bind (res-max-x res-max-y) (max-x-y *application-frame*)

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5329 Modified Files: graphics.lisp Log Message: Added draw-rounded-rectangle* function. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/12/23 11:41:23 1.56 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2007/02/05 02:58:46 1.57 @@ -651,10 +651,12 @@ (with-medium-options (sheet args) (if (coordinate<= y-radius x-radius) (let ((x1 (- center-x x-radius)) (x2 (+ center-x x-radius)) - (y1 (- center-y y-radius)) (y2 (+ center-y y-radius))) + (y1 (- center-y y-radius)) (y2 (+ center-y y-radius))) (if filled - (draw-rectangle* sheet x1 y1 x2 y2) - (draw-lines* sheet (list x1 y1 x2 y1 x1 y2 x2 y2))) + ;; Kludge coordinates, sometimes due to rounding the lines don't connect. + (draw-rectangle* sheet (floor x1) y1 (ceiling x2) y2) + (draw-lines* sheet (list (floor x1) y1 (ceiling x2) y1 + (floor x1) y2 (ceiling x2) y2))) (draw-circle* sheet x1 center-y y-radius :filled filled :start-angle (* pi 0.5) @@ -1023,3 +1025,72 @@ :ink (transform-region (make-translation-transformation x y) pattern)))))) + +(defun draw-rounded-rectangle* (sheet x1 y1 x2 y2 + &rest args &key + (radius 7) + (radius-x radius) + (radius-y radius) + (radius-left radius-x) + (radius-right radius-x) + (radius-top radius-y) + (radius-bottom radius-y) + filled &allow-other-keys) + "Draw a rectangle with rounded corners" + + (apply #'invoke-with-drawing-options sheet + (lambda (medium) + (declare (ignore medium)) + (let ((medium sheet)) + (if (not (and (>= (- x2 x1) (* 2 radius-x)) + (>= (- y2 y1) (* 2 radius-y)))) + (draw-rectangle* medium x1 y1 x2 y2) + (with-grown-rectangle* ((ix1 iy1 ix2 iy2) (x1 y1 x2 y2) + :radius-left (- radius-left) + :radius-right (- radius-right) + :radius-top (- radius-top) + :radius-bottom (- radius-bottom)) + (let ((zl (zerop radius-left)) + (zr (zerop radius-right)) + (zt (zerop radius-top)) + (zb (zerop radius-bottom))) + (if filled + (progn ; Filled + (unless (or zl zt) + (draw-ellipse* medium ix1 iy1 radius-left 0 0 radius-top :filled t)) + (unless (or zr zt) + (draw-ellipse* medium ix2 iy1 radius-right 0 0 radius-top :filled t)) + (unless (or zl zb) + (draw-ellipse* medium ix1 iy2 radius-left 0 0 radius-bottom :filled t)) + (unless (or zr zb) + (draw-ellipse* medium ix2 iy2 radius-right 0 0 radius-bottom :filled t)) + (draw-rectangle* medium x1 iy1 x2 iy2 :filled t) + (draw-rectangle* medium ix1 y1 ix2 iy1 :filled t) + (draw-rectangle* medium ix1 iy2 ix2 y2 :filled t)) + (progn ; Unfilled + (unless (or zl zt) + (draw-ellipse* medium ix1 iy1 (- radius-left) 0 0 (- radius-top) + :start-angle (/ pi 2) :end-angle pi + :filled nil)) + (unless (or zr zt) + (draw-ellipse* medium ix2 iy1 (- radius-right) 0 0 (- radius-top) + :start-angle 0 :end-angle (/ pi 2) + :filled nil)) + (unless (or zl zb) + (draw-ellipse* medium ix1 iy2 (- radius-left) 0 0 (- radius-bottom) + :start-angle pi :end-angle (* 3/2 pi) + :filled nil)) + (unless (or zr zb) + (draw-ellipse* medium ix2 iy2 (- radius-right) 0 0 (- radius-bottom) + :start-angle (* 3/2 pi) + :filled nil)) + (labels ((fx (y p x1a x2a x1b x2b) (draw-line* medium (if p x1a x1b) y (if p x2a x2b) y)) + (fy (x p y1a y2a y1b y2b) (draw-line* medium x (if p y1a y1b) x (if p y2a y2b)))) + (fx y1 zt x1 x2 ix1 ix2) + (fy x1 zl y1 y2 iy1 iy2) + (fx y2 zb x1 x2 ix1 ix2) + (fy x2 zr y1 y2 iy1 iy2))))))))) + (with-keywords-removed (args '(:radius :radius-x :radius-y + :radius-left :radius-right + :radius-top :radius-bottom)) + args)))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5296 Modified Files: medium.lisp Log Message: Added merge-line-styles function. --- /project/mcclim/cvsroot/mcclim/medium.lisp 2006/12/24 14:27:43 1.61 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2007/02/05 02:57:58 1.62 @@ -499,6 +499,19 @@ (eql (line-style-joint-shape style1) (line-style-joint-shape style2)) (eql (line-style-cap-shape style1) (line-style-cap-shape style2)) (eql (line-style-dashes style1) (line-style-dashes style2)))) + +(defun merge-line-styles (a b) + (make-line-style :unit (or (line-style-unit a) + (line-style-unit b)) + :thickness (or (line-style-thickness a) + (line-style-thickness b)) + :joint-shape (or (line-style-joint-shape a) + (line-style-joint-shape b)) + :cap-shape (or (line-style-cap-shape a) + (line-style-cap-shape b)) + :dashes (or (line-style-dashes a) + (line-style-dashes b)))) + ;;; Misc ops

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5246 Modified Files: gadgets.lisp Log Message: Trivial changes (change :max-height of push-button-pane to +fill+, move functions around). --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/27 14:47:23 1.103 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/02/05 02:57:18 1.104 @@ -203,13 +203,9 @@ ;; immediate-sheet-input-mixin ;; immediate-repainting-mixin basic-pane - gadget - ) - ;; Half-baked attempt to be compatible with Lispworks. ??? -moore - ;; Inherited from basic-pane with different defaults. - ((foreground :initform +black+) - #+IGNORE (background :initform +white+) ; This is evil.. -Hefner - )) + gadget) + ()) + ;; Where is this standard-gadget from? --GB @@ -701,8 +697,8 @@ (defclass enter/exit-arms/disarms-mixin () () (:documentation - "Mixin class for gadgets, which will be armed, when the mouse enters and - disarmed, when the mouse leaves.")) + "Mixin class for gadgets which are armed when the mouse enters and + disarmed when the mouse leaves.")) (defmethod handle-event :before ((pane enter/exit-arms/disarms-mixin) (event pointer-enter-event)) (declare (ignorable event)) @@ -737,7 +733,12 @@ (declare (ignorable client)) (disarm-gadget gadget)) -;; +;;;; ------------------------------------------------------------------------------------------ +;;;; +;;;; Drawing Utilities for Concrete Gadgets +;;;; + +;;; Labels (defmethod compose-label-space ((gadget labelled-gadget-mixin) &key (wider 0) (higher 0)) (with-slots (label align-x align-y) gadget @@ -769,11 +770,6 @@ :text-style (pane-text-style pane) :ink ink)))) -;;;; ------------------------------------------------------------------------------------------ -;;;; -;;;; Drawing Utilities for Concrete Gadgets -;;;; - ;;; 3D-ish Look ;; DRAW-BORDERED-POLYGON medium point-seq &key border-width style @@ -950,7 +946,10 @@ medium (polygon-points (make-rectangle* x1 y1 x2 y2)) options)) - + +(defun draw-engraved-label* (pane x1 y1 x2 y2) + (draw-label* pane (1+ x1) (1+ y1) (1+ x2) (1+ y2) :ink *3d-light-color*) + (draw-label* pane x1 y1 x2 y2 :ink *3d-dark-color*)) ;;;; ;;;; 3D-BORDER-MIXIN Class @@ -1040,7 +1039,7 @@ :initarg :show-as-default-p :accessor push-button-show-as-default-p)) (:default-initargs - :text-style (make-text-style :sans-serif nil nil) + :text-style (make-text-style :sans-serif nil nil) :background *3d-normal-color* :align-x :center :align-y :center @@ -1076,10 +1075,6 @@ (setf pressedp nil) (dispatch-repaint pane +everywhere+)))) -(defun draw-engraved-label* (pane x1 y1 x2 y2) - (draw-label* pane (1+ x1) (1+ y1) (1+ x2) (1+ y2) :ink *3d-light-color*) - (draw-label* pane x1 y1 x2 y2 :ink *3d-dark-color*)) - (defmethod handle-repaint ((pane push-button-pane) region) (declare (ignore region)) (with-slots (armed pressedp) pane @@ -2044,7 +2039,7 @@ (h (* n (generic-list-pane-item-height pane)))) (make-space-requirement :width w :height h :min-width w :min-height h - :max-width +fill+ :max-height h))) + :max-width +fill+ :max-height +fill+))) (defmethod allocate-space ((pane generic-list-pane) w h) (resize-sheet pane w h))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5175 Modified Files: frames.lisp Log Message: Make :default-initargs work as a parameter to define-application-frame. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2007/01/04 09:13:25 1.123 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2007/02/05 02:55:29 1.124 @@ -238,8 +238,9 @@ (defmethod layout-frame ((frame application-frame) &optional width height) (let ((pane (frame-panes frame))) - (if (and width (not height)) - (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither")) + (when (and (or width height) + (not (and width height))) + (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither")) (if (and (null width) (null height)) (let ((space (compose-space pane))) ;I guess, this might be wrong. --GB 2004-06-01 (setq width (space-requirement-width space)) @@ -600,7 +601,7 @@ #+clim-mp (event-queue (sheet-event-queue t-l-s))) (setf (slot-value frame 'top-level-sheet) t-l-s) (generate-panes fm frame) - (setf (slot-value frame 'state) :disabled) + (setf (slot-value frame 'state) :disabled) #+clim-mp (when (typep event-queue 'port-event-queue) (setf (event-queue-port event-queue) @@ -795,6 +796,7 @@ (others nil) (pointer-documentation nil) (geometry nil) + (user-default-initargs nil) (frame-arg (gensym "FRAME-ARG"))) (loop for (prop . values) in options do (case prop @@ -810,6 +812,7 @@ (:top-level (setq top-level (first values))) (:pointer-documentation (setq pointer-documentation (car values))) (:geometry (setq geometry values)) + (:default-initargs (setq user-default-initargs values)) (t (push (cons prop values) others)))) (when (eq command-definer t) (setf command-definer @@ -838,7 +841,8 @@ :top-level (list ',(car top-level) ,@(cdr top-level)) :top-level-lambda (lambda (,frame-arg) (,(car top-level) ,frame-arg - ,@(cdr top-level)))) + ,@(cdr top-level))) + ,@user-default-initargs) ,@others) ;; We alway set the frame class default geometry, so that the ;; user can undo the effect of a specified :geometry option. @@ -943,11 +947,14 @@ (graft :initform nil :accessor graft) (manager :initform nil :accessor frame-manager))) +(defclass menu-unmanaged-top-level-sheet-pane (unmanaged-top-level-sheet-pane) + ()) + (defmethod adopt-frame ((fm frame-manager) (frame menu-frame)) (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames))) (setf (frame-manager frame) fm) (let* ((t-l-s (make-pane-1 fm *application-frame* - 'unmanaged-top-level-sheet-pane + 'menu-unmanaged-top-level-sheet-pane :name 'top-level-sheet))) (setf (slot-value frame 'top-level-sheet) t-l-s) (sheet-adopt-child t-l-s (frame-panes frame))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 05 Feb '07

05 Feb '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5009 Modified Files: design.lisp Log Message: Added highlight-shade helper function. --- /project/mcclim/cvsroot/mcclim/design.lisp 2006/03/10 21:58:12 1.25 +++ /project/mcclim/cvsroot/mcclim/design.lisp 2007/02/05 02:54:20 1.26 @@ -856,3 +856,29 @@ (and (= r1 r2) (= g1 g2) (= b1 b2))))) + +;;; Color utilities + +(defgeneric highlight-shade (ink) + (:documentation + "Produce an alternate shade of the given ink for the purpose of highlighting. + Typically the ink will be brightened, but very light inks may be darkened.")) + +(defmethod highlight-shade (ink) ink) + +(defmethod highlight-shade ((ink (eql +background-ink+))) + +foreground-ink+) + +(defmethod highlight-shade ((ink (eql +foreground-ink+))) + +background-ink+) + +(defmethod highlight-shade ((ink standard-color)) + (let ((brighten-factor 0.5) + (darken-factor 0.15)) + (multiple-value-bind (r g b) (color-rgb ink) + (multiple-value-bind (blend-ink factor) + (if (> (- 3.0 r g b) 0.2) + (values +white+ brighten-factor) + (values +black+ darken-factor)) + (compose-over (compose-in blend-ink (make-opacity factor)) + ink)))))

1 0

[mcclim-cvs] CVS mcclim/Extensions
by dlichteblau 04 Feb '07

04 Feb '07

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv27996 Modified Files: tab-layout.lisp Log Message: force redisplay of the tab header bar * Extensions/tab-layout.lisp (clim-tab-layout:note-tab-page-changed): New method. --- /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 12:55:45 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 14:53:32 1.2 @@ -329,10 +329,6 @@ (setf (sheet-enabled-p (tab-page-pane page)) t))) (call-next-method)) -;;;; -;;;; Beginning of original MGR source code -- license not confirmed -;;;; - (defclass tab-bar-view (gadget-view) ()) @@ -404,10 +400,6 @@ (sheet-adopt-child instance header) (setf (sheet-enabled-p header) t))) -;;;; -;;;; End of original MGR source code -;;;; - (defmethod compose-space ((pane tab-layout-pane) &key width height) (declare (ignore width height)) (let ((q (compose-space (tab-layout-header-pane pane)))) @@ -434,3 +426,11 @@ (defmethod internal-child-p (child (parent tab-layout-pane)) (eq child (tab-layout-header-pane parent))) + +(defmethod clim-tab-layout:note-tab-page-changed + ((layout tab-layout-pane) page) + (redisplay-frame-pane (pane-frame layout) + (car (sheet-children + (car (sheet-children + (tab-layout-header-pane layout))))) + :force-p t))

1 0