March 2007 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS mcclim/Extensions
by ahefner 20 Mar '07

20 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv23102/d Modified Files: tab-layout.lisp Log Message: Pixie tab layout. Slight refactoring of the basic tab layout necessary so that the implementation can be reused. Tweaked space allocation of pixie buttons. --- /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/02/04 14:53:32 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/tab-layout.lisp 2007/03/20 01:51:22 1.3 @@ -273,7 +273,7 @@ :pages (list ,@(mapcar (lambda (spec) `(make-tab-page ,@spec :presentation-type - ,ptypevar)) + ,ptypevar)) body)) ,@initargs)))) @@ -309,26 +309,6 @@ ;;; generic TAB-LAYOUT-PANE implementation -(defclass tab-layout-pane (tab-layout) - ((header-pane :accessor tab-layout-header-pane - :initarg :header-pane)) - (:documentation "A pure-lisp implementation of the tab-layout, this is -the generic implementation chosen by the CLX frame manager automatically. -Users should create panes for type TAB-LAYOUT, not TAB-LAYOUT-PANE, so -that the frame manager can customize the implementation.")) - -(defmethod (setf tab-layout-enabled-page) - (page (parent tab-layout-pane)) - (let ((old-page (tab-layout-enabled-page parent))) - (unless (equal page old-page) - (when old-page - (setf (sheet-enabled-p (tab-page-pane old-page)) nil)) - (when page - (setf (sheet-enabled-p (tab-page-pane page)) t))) - (when page - (setf (sheet-enabled-p (tab-page-pane page)) t))) - (call-next-method)) - (defclass tab-bar-view (gadget-view) ()) @@ -369,33 +349,64 @@ (tab-page-drawing-options tab-page)) (stream-increment-cursor-position stream 10 0)) +(defclass tab-layout-pane (tab-layout) + ((header-pane :accessor tab-layout-header-pane + :initarg :header-pane) + (header-display-function + :accessor header-display-function + :initarg :header-display-function + :initform 'default-display-tab-header)) + (:documentation "A pure-lisp implementation of the tab-layout, this is +the generic implementation chosen by the CLX frame manager automatically. +Users should create panes for type TAB-LAYOUT, not TAB-LAYOUT-PANE, so +that the frame manager can customize the implementation.")) + +(defmethod (setf tab-layout-enabled-page) + (page (parent tab-layout-pane)) + (let ((old-page (tab-layout-enabled-page parent))) + (unless (equal page old-page) + (when old-page + (setf (sheet-enabled-p (tab-page-pane old-page)) nil)) + (when page + (setf (sheet-enabled-p (tab-page-pane page)) t))) + (when page + (setf (sheet-enabled-p (tab-page-pane page)) t))) + (call-next-method)) + +(defun default-display-tab-header (tab-layout pane) + (stream-increment-cursor-position pane 0 3) + (draw-line* pane + 0 + 17 + (slot-value pane 'climi::current-width) + 17 + :ink +black+) + (mapc (lambda (page) + (with-output-as-presentation + (pane (tab-page-pane page) + (tab-page-presentation-type page)) + (present page 'tab-page :stream pane))) + (tab-layout-pages tab-layout))) + +(defclass tab-bar-pane (application-pane) + () + (:default-initargs :default-view +tab-bar-view+)) + +(defmethod compose-space ((pane tab-bar-pane) &key width height) + (declare (ignore width height)) + (make-space-requirement :min-height 22 :height 22 :max-height 22)) + (defmethod initialize-instance :after ((instance tab-layout-pane) &key pages) (let ((current (tab-layout-enabled-page instance))) (dolist (page pages) (setf (sheet-enabled-p (tab-page-pane page)) (eq page current)))) (let ((header - (make-clim-stream-pane - :default-view +tab-bar-view+ + (make-pane 'tab-bar-pane :display-time :command-loop - :scroll-bars nil - :borders nil - :height 22 :display-function (lambda (frame pane) - (declare (ignore frame)) - (stream-increment-cursor-position pane 0 3) - (draw-line* pane - 0 - 17 - (slot-value pane 'climi::current-width) - 17 - :ink +black+) - (mapc (lambda (page) - (with-output-as-presentation - (pane (tab-page-pane page) - (tab-page-presentation-type page)) - (present page 'tab-page :stream pane))) - (tab-layout-pages instance)))))) + (declare (ignore frame)) + (funcall (header-display-function instance) instance pane))))) (setf (tab-layout-header-pane instance) header) (sheet-adopt-child instance header) (setf (sheet-enabled-p header) t))) @@ -430,6 +441,8 @@ (defmethod clim-tab-layout:note-tab-page-changed ((layout tab-layout-pane) page) (redisplay-frame-pane (pane-frame layout) + (tab-layout-header-pane layout) + #+NIL (car (sheet-children (car (sheet-children (tab-layout-header-pane layout)))))

1 0

[mcclim-cvs] CVS mcclim/Looks
by ahefner 20 Mar '07

20 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv23102/Looks Modified Files: pixie.lisp Log Message: Pixie tab layout. Slight refactoring of the basic tab layout necessary so that the implementation can be reused. Tweaked space allocation of pixie buttons. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/02/07 12:44:22 1.20 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/03/20 01:51:22 1.21 @@ -984,6 +984,7 @@ (defmethod compose-space ((gadget pixie-push-button-pane) &key width height) (declare (ignore width height)) + ;; Why does a button have spacing options, anyway? (space-requirement+* (space-requirement+* (compose-label-space gadget) :min-width (* 2 (pane-x-spacing gadget)) :width (* 2 (pane-x-spacing gadget)) @@ -991,12 +992,12 @@ :min-height (* 2 (pane-y-spacing gadget)) :height (* 2 (pane-y-spacing gadget)) :max-height (* 2 (pane-y-spacing gadget))) - :min-width (* 2 *3d-border-thickness*) - :width (* 2 *3d-border-thickness*) - :max-width (* 2 *3d-border-thickness*) - :min-height (* 2 *3d-border-thickness*) - :height (* 2 *3d-border-thickness*) - :max-height (* 2 *3d-border-thickness*))) + :min-width (* 8 *3d-border-thickness*) + :width (* 8 *3d-border-thickness*) + :max-width (* 8 *3d-border-thickness*) + :min-height (* 4 *3d-border-thickness*) + :height (* 4 *3d-border-thickness*) + :max-height (* 4 *3d-border-thickness*))) ; factor out the dragging code into a mixin (defmethod handle-event ((pane pixie-push-button-pane) (event pointer-enter-event)) @@ -1041,8 +1042,8 @@ (y1 (+ y1 1)) (x2 (- x2 1)) (y2 (- y2 1))) - (let ((x2 (- x2 1)) - (y2 (- y2 1))) + (let ((x2 (- x2 1)) ; Removing this magic weirdness slightly uglifies the + (y2 (- y2 1))) ; scroll bar. Not sure why, but FIXME. (cond ((or (not pressedp) (eq dragging :outside)) @@ -1140,3 +1141,130 @@ (defmethod allocate-space ((pane pixie-text-field-pane) w h) (resize-sheet pane w h)) + +;;;; Pixie tab-layout. Reuses implementation of the generic tab-layout-pane. + +(define-pixie-gadget clim-tab-layout:tab-layout pixie-tab-layout-pane) +(define-pixie-gadget clim-tab-layout::tab-bar-pane pixie-tab-bar-pane) + +(defclass pixie-tab-bar-view (gadget-view) + ((selected :initform nil + :initarg :selected + :reader pixie-tab-view-selected-p))) + +(defparameter +pixie-tab-bar-view+ + (make-instance 'pixie-tab-bar-view :selected nil)) + +(defparameter +pixie-selected-tab-bar-view+ + (make-instance 'pixie-tab-bar-view :selected t)) + + + +(defclass pixie-tab-layout-pane (clim-tab-layout:tab-layout-pane) + () + (:default-initargs + :header-display-function 'pixie-display-tab-header)) + +(defclass pixie-tab-bar-pane (application-pane pixie-gadget) + () + (:default-initargs + :default-view +pixie-tab-bar-view+ + :background +gray83+ + :text-style (make-text-style :sans-serif :roman :small))) + +(defmethod compose-space ((pane pixie-tab-bar-pane) &key width height) + (declare (ignore width height)) + (let ((h (+ 6 ; padding on the top + 6 ; padding on the bottom + (text-style-ascent (pane-text-style pane) pane) + (text-style-descent (pane-text-style pane) pane)))) + (make-space-requirement :min-height h :height h :max-height h))) + +(defun draw-pixie-tab-bar-bottom (pane) + (let ((y0 (bounding-rectangle-min-y (sheet-region pane))) + (y1 (bounding-rectangle-max-y (sheet-region pane)))) + (draw-line* pane 0 (- y1 6) +fill+ (- y1 6) :ink *3d-light-color*) + (draw-line* pane 0 (- y1 1) +fill+ (- y1 1) :ink *3d-dark-color*) + #+NIL (draw-line* pane 0 (1- y1) x1 (1- y1) :ink +gray30+))) + +(defmethod draw-output-border-over + ((shape (eql 'pixie-tab-bar-border)) stream record &key &allow-other-keys) + (declare (ignore shape stream record))) + +(defmethod draw-output-border-under + ((shape (eql 'pixie-tab-bar-border)) stream record + &key background enabled &allow-other-keys) + (with-border-edges (stream record) + (declare (ignore bottom)) + (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region stream) + (declare (ignore x0 x1 y0)) + (let ((bottom (- y1 7)) + (left (- left 4 (if enabled 2 0))) + (right (+ right 4 (if enabled 2 0))) + (top (- top 2 #+NIL (if enabled 2 0)))) + (draw-rectangle* stream left top right (+ bottom (if enabled 2 1)) + :filled t :ink background) + (draw-line* stream (1+ left) (1- top) (- right 1) (1- top) :ink +white+) + (draw-point* stream left top :ink +white+) + (draw-line* stream (1- left) bottom (1- left) (1+ top) :ink +white+) + (draw-line* stream right bottom right top :ink +gray66+) + (draw-point* stream right top :ink +gray40+) + (draw-line* stream (1+ right) bottom (1+ right) (1+ top) :ink +gray40+))))) + +(define-default-highlighting-method 'pixie-tab-bar-border) + +(define-presentation-method present + (tab-page (type clim-tab-layout:tab-page) stream (view pixie-tab-bar-view) &key) + (stream-increment-cursor-position stream 5 0) + (surrounding-output-with-border (stream :shape 'pixie-tab-bar-border + :enabled (pixie-tab-view-selected-p view) + :highlight-background +gray94+ + :background +gray83+ + :move-cursor nil) + (apply #'invoke-with-drawing-options stream + (lambda (rest) + (declare (ignore rest)) + (write-string (clim-tab-layout:tab-page-title tab-page) stream)) + (clim-tab-layout:tab-page-drawing-options tab-page))) + (stream-increment-cursor-position stream 6 0)) + +(defun pixie-display-tab-header (tab-layout pane) + (draw-pixie-tab-bar-bottom pane) + (setf (stream-cursor-position pane) + (values 3 (- (bounding-rectangle-height (sheet-region pane)) + 7 + (text-style-descent (pane-text-style pane) pane) + (text-style-ascent (pane-text-style pane) pane)))) + (let ((enabled-page-drawers nil)) + (mapc (lambda (page) + ;; This gets a little silly, but the tabs are laid out simply by + ;; letting the cursor move from left to right. In order to make + ;; the selected tab overlap, we can't draw it until after the other + ;; tabs. We then draw it slightly larger in each direcetion. But the + ;; cursor has to have moved as though it were smaller (so that it + ;; overlaps its neighbors), so draw it initially, note its position, + ;; and redraw a larger version once everything is done. + (let ((enabled (sheet-enabled-p (clim-tab-layout:tab-page-pane page)))) + (when enabled + (multiple-value-bind (x y) (stream-cursor-position pane) + (push (lambda () + (setf (stream-cursor-position pane) + (values x (- y 2))) + (with-output-as-presentation + (pane (clim-tab-layout:tab-page-pane page) + (clim-tab-layout:tab-page-presentation-type page)) + (present page 'clim-tab-layout:tab-page :stream pane + :view +pixie-selected-tab-bar-view+))) + enabled-page-drawers))) + (let ((record + (with-output-as-presentation + (pane (clim-tab-layout:tab-page-pane page) + (clim-tab-layout:tab-page-presentation-type page)) + (present page 'clim-tab-layout:tab-page :stream pane)))) + ;; Because piling the presentations on top of each other confuses + ;; CLIM as to which should be highlighted, erase the smaller one. + ;; The cursor has already been moved, so we don't need it. + (when enabled + (delete-output-record record (output-record-parent record)))))) + (clim-tab-layout:tab-layout-pages tab-layout)) + (mapcar #'funcall enabled-page-drawers)))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 20 Mar '07

20 Mar '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22720 Modified Files: recording.lisp Log Message: Optimize a few cases in recompute-extent-for-changed-child, generalizing an optimization by Robert Strandh. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/02/05 03:06:14 1.130 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/03/20 01:48:38 1.131 @@ -608,10 +608,10 @@ (defmethod clear-output-record ((record basic-output-record)) (error "Cannot clear ~S." record)) -(defmethod clear-output-record :before ((record compound-output-record)) +(defmethod clear-output-record :before ((record compound-output-record)) (let ((sheet (find-output-record-sheet record))) (when sheet - (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)))) + (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)))) (defmethod clear-output-record :after ((record compound-output-record)) ;; XXX banish x and y @@ -774,63 +774,78 @@ (setf (rectangle-edges* record) (values new-x1 new-y1 new-x2 new-y2))))))) - (defmethod recompute-extent-for-changed-child ((record compound-output-record) changed-child old-min-x old-min-y old-max-x old-max-y) (with-bounding-rectangle* (ox1 oy1 ox2 oy2) record (with-bounding-rectangle* (cx1 cy1 cx2 cy2) changed-child - ;; 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. - (multiple-value-bind (nx1 ny1 nx2 ny2) - (cond - ;; The child has been deleted; who knows what the - ;; new bounding box might be. - ((not (output-record-parent changed-child)) - (%tree-recompute-extent* record)) - ;; Only one child of record, and we already have the bounds. - ((eql (output-record-count record) 1) - (values cx1 cy1 cx2 cy2)) - ;; If our record occupied no space (had no children, or had only - ;; children similarly occupying no space, hackishly determined by - ;; null-bounding-rectangle-p), recompute the extent now, otherwise - ;; the next COND clause would, as an optimization, attempt to extend - ;; our current bounding rectangle, which is invalid. - ((null-bounding-rectangle-p record) - (%tree-recompute-extent* record)) - ;; In the following cases, we can grow the new bounding rectangle - ;; from its previous state: - ((or - ;; If the child was originally empty, it should not have affected - ;; previous computation of our bounding rectangle. - ;; This is hackish for reasons similar to the above. - (and (zerop old-min-x) (zerop old-min-y) - (zerop old-max-x) (zerop old-max-y)) - ;; New child bounds contain old child bounds, so use min/max - ;; to extend the already-calculated rectangle. - (and (<= cx1 old-min-x) (<= cy1 old-min-y) - (>= cx2 old-max-x) (>= cy2 old-max-y))) - (values (min cx1 ox1) (min cy1 oy1) - (max cx2 ox2) (max cy2 oy2))) - ;; No shortcuts - we must compute a new bounding box from those of - ;; all our children. We want to avoid this - in worst cases, such as - ;; a toplevel output history, large graph, or table, there may exist - ;; thousands of children. Without the above optimizations, - ;; construction becomes O(N^2) due to bounding rectangle calculation. - (t (%tree-recompute-extent* record))) - ;; XXX banish x, y - (with-slots (x y) - record - (setf x nx1 y ny1) - (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) - (let ((parent (output-record-parent record))) - (unless (or (null parent) - (and (= nx1 ox1) (= ny1 oy1) - (= nx2 ox2) (= nx2 oy2))) - (recompute-extent-for-changed-child parent record - ox1 oy1 ox2 oy2))))))) + (let ((child-was-empty (and (= old-min-x old-min-y) ; =( + (= old-max-x old-max-y)))) + ;; 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. + (multiple-value-bind (nx1 ny1 nx2 ny2) + (cond + ;; The child has been deleted, but none of its edges contribute + ;; to the bounding rectangle of the parent, so the bounding + ;; rectangle cannot be changed by its deletion. + ;; This is also true if the child was empty. + ((or child-was-empty + (and (output-record-parent changed-child) + (> old-min-x ox1) + (> old-min-y oy1) + (< old-max-x ox2) + (< old-max-y oy2))) + (values ox1 oy1 ox2 oy2)) + ;; The child has been deleted; who knows what the + ;; new bounding box might be. + ((not (output-record-parent changed-child)) + (%tree-recompute-extent* record)) + ;; Only one child of record, and we already have the bounds. + ((eql (output-record-count record) 1) + (values cx1 cy1 cx2 cy2)) + ;; If our record occupied no space (had no children, or had only + ;; children similarly occupying no space, hackishly determined by + ;; null-bounding-rectangle-p), recompute the extent now, otherwise + ;; the next COND clause would, as an optimization, attempt to extend + ;; our current bounding rectangle, which is invalid. + ((null-bounding-rectangle-p record) + (%tree-recompute-extent* record)) + ;; In the following cases, we can grow the new bounding rectangle + ;; from its previous state: + ((or + ;; If the child was originally empty, it should not have affected + ;; previous computation of our bounding rectangle. + child-was-empty + ;; No child edge which may have defined the bounding rectangle of + ;; the parent has shrunk inward, so min/max the new child rectangle + ;; against the existing rectangle. Other edges of the child may have + ;; moved, but this can't affect the parent bounding rectangle. + (and (or (> old-min-x ox1) (>= old-min-x cx1)) + (or (> old-min-y oy1) (>= old-min-y cy1)) + (or (< old-max-x ox2) (<= old-max-x cx2)) + (or (< old-max-y oy2) (<= old-max-y cy2)))) + ;; In these cases, we can grow the rectangle using min/max. + (values (min cx1 ox1) (min cy1 oy1) + (max cx2 ox2) (max cy2 oy2))) + ;; No shortcuts - we must compute a new bounding box from those of + ;; all our children. We want to avoid this - in worst cases, such as + ;; a toplevel output history, large graph, or table, there may exist + ;; thousands of children. Without the above optimizations, + ;; construction becomes O(N^2) due to bounding rectangle calculation. + (t (%tree-recompute-extent* record))) + ;; XXX banish x, y + (with-slots (x y) + record + (setf x nx1 y ny1) + (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) + (let ((parent (output-record-parent record))) + (unless (or (null parent) + (and (= nx1 ox1) (= ny1 oy1) + (= nx2 ox2) (= nx2 oy2))) + (recompute-extent-for-changed-child parent record + ox1 oy1 ox2 oy2)))))))) record) ;; There was once an :around method on recompute-extent-for-changed-child here, @@ -1975,9 +1990,9 @@ (with-slots (strings) record (if (= 1 (length strings)) (styled-string-string (first strings)) - (with-output-to-string (result) - (loop for styled-string in strings - do (write-string (styled-string-string styled-string) result)))))) + (with-output-to-string (result) + (loop for styled-string in strings + do (write-string (styled-string-string styled-string) result)))))) ;;; 16.3.4. Top-Level Output Records (defclass stream-output-history-mixin ()

1 0

[mcclim-cvs] CVS mcclim/Examples
by ahefner 20 Mar '07

20 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv22583 Modified Files: clim-fig.lisp fire.lisp Log Message: Cleanup some port-destroying cruft in the examples. --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/12/26 16:44:46 1.31 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2007/03/20 01:46:14 1.32 @@ -160,19 +160,7 @@ (return-from handle-move-object))))) (defun clim-fig () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) - (run-frame-top-level (make-application-frame 'clim-fig)) - ;(setq frame (make-application-frame 'clim-fig)) - ;(setq fm (frame-manager frame)) - ;(setq port (climi::frame-manager-port fm)) - ;(setq pane (first (frame-panes frame))) - ;(setq medium (sheet-medium pane)) - ;(setq graft (graft frame)) - ;(setq vbox (climi::frame-pane frame)) - ;(run-frame-top-level frame) - ) + (run-frame-top-level (make-application-frame 'clim-fig))) (defun make-colored-button (color &key width height) (make-pane 'push-button --- /project/mcclim/cvsroot/mcclim/Examples/fire.lisp 2005/02/02 06:32:32 1.5 +++ /project/mcclim/cvsroot/mcclim/Examples/fire.lisp 2007/03/20 01:46:14 1.6 @@ -92,9 +92,6 @@ ;; test functions (defun fire () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) (run-frame-top-level (make-application-frame 'firelights))) (defmethod fire-frame-top-level ((frame application-frame))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 20 Mar '07

20 Mar '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22184 Modified Files: panes.lisp sheets.lisp Log Message: Small hacks that appear to make output to unadopted sheets work. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/03/04 15:08:00 1.181 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/03/20 01:43:55 1.182 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.181 2007/03/04 15:08:00 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.182 2007/03/20 01:43:55 ahefner Exp $ (in-package :clim-internals) @@ -2548,7 +2548,8 @@ (stream-close-text-output-record pane) (let ((output-history (stream-output-history pane))) (with-bounding-rectangle* (left top right bottom) output-history - (medium-clear-area (sheet-medium pane) left top right bottom)) + (when (sheet-viewable-p pane) + (medium-clear-area (sheet-medium pane) left top right bottom))) (clear-output-record output-history)) (window-erase-viewport pane) (let ((cursor (stream-text-cursor pane))) --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2006/11/09 20:24:20 1.53 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2007/03/20 01:43:55 1.54 @@ -84,7 +84,8 @@ :initform (make-bounding-rectangle 0 0 100 100) :accessor sheet-region) (native-transformation :type (or null transformation) - :initform nil + ;:initform nil + :initform +identity-transformation+ :writer %%set-sheet-native-transformation :reader %%sheet-native-transformation) (native-region :type (or null region) @@ -95,7 +96,7 @@ :initform nil) (pointer-cursor :accessor sheet-pointer-cursor :initarg :pointer-cursor - :initform :default) + :initform :default) (enabled-p :type boolean :initarg :enabled-p :initform t

1 0

[mcclim-cvs] CVS mcclim
by ahefner 20 Mar '07

20 Mar '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20583 Modified Files: bordered-output.lisp medium.lisp Log Message: Merge with medium line style. Eliminated merge-line-styles due to the contraint in the spec that you can't have NIL components in your line style. --- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/03/12 17:36:52 1.16 +++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/03/20 01:41:17 1.17 @@ -173,13 +173,12 @@ (defmacro %%line-style-for-method () `(or line-style - (merge-line-styles - (make-line-style - :unit (or line-unit :point) - :thickness (or line-thickness 1) - :cap-shape (or line-cap-shape :butt) - :dashes line-dashes) - (medium-line-style stream)))) + (let ((mls (medium-line-style stream))) + (make-line-style + :unit (or line-unit (line-style-unit mls)) + :thickness (or line-thickness (line-style-thickness mls)) + :cap-shape (or line-cap-shape (line-style-cap-shape mls)) + :dashes (or line-dashes (line-style-dashes mls)))))) (defmacro %%adjusting-for-padding (&body body) `(let ((left (- left padding-left)) @@ -201,7 +200,7 @@ ;; The Franz User guide implies that &key isn't needed. (pushnew '&key arglist) `(progn - (pushnew ,shape *border-types*) + (pushnew ',shape *border-types*) (defmethod draw-output-border-over ((shape (eql ',shape)) stream record &rest drawing-options) (with-border-edges (stream record) @@ -675,7 +674,7 @@ new-drawing-options) ;; Great, this again.. (queue-repaint stream - (make-instance 'window-repaint-event + (make-instance 'window-repaint-event :sheet stream :region (transform-region (sheet-native-transformation stream) --- /project/mcclim/cvsroot/mcclim/medium.lisp 2007/02/05 02:57:58 1.62 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2007/03/20 01:41:17 1.63 @@ -500,18 +500,6 @@ (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 20 Mar '07

20 Mar '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19266 Modified Files: commands.lisp Log Message: Don't return a value from map-over-command-menu-items (was trickling down to make lookup-keystroke-item return nonsense in the case where lookup failed). --- /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/17 12:09:46 1.70 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2007/03/20 01:39:29 1.71 @@ -403,7 +403,8 @@ menu-name (and (slot-boundp item 'keystroke) keystroke) item))) - (slot-value (find-command-table command-table) 'menu))) + (slot-value (find-command-table command-table) 'menu)) + (values)) ;; At this point we should still see the gesture name as supplied by the ;; programmer in 'gesture'

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by junrue 18 Mar '07

18 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv7676 Modified Files: medium.lisp Log Message: medium-draw-text works better with an explicit call to sync-text-style --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 15:31:56 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/18 17:15:55 1.6 @@ -426,6 +426,9 @@ toward-x toward-y transform-glyphs) #+nil (gfs::debug-format "medium-draw-text: ~d, ~d ~s~%" x y string) (when (target-of medium) + (sync-text-style medium + (merge-text-styles (medium-text-style medium) + (medium-default-text-style medium))) (setf string (normalize-text-data string)) (gfw:with-graphics-context (gc (target-of medium)) (let ((font (font-of medium)))

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by dlichteblau 18 Mar '07

18 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv5295 Modified Files: port.lisp Log Message: No idea why graphic-forms works this way, but get-next-event consistently processed more than one event, all of which were discarded except for the last one. Push the events into a list instead and return them in order. This fixes disappearing pane contents, since most repaint events were lost. * Backends/Graphic-Forms/port.lisp (GRAPHIC-FORMS-PORT): New slot EVENTS, renamed from EVENT. (ENQUEUE): New function. (GET-NEXT-EVENT): Rewritten to pop from EVENTS. (EVENT-CLOSE, EVENT-PAINT, EVENT-MOVE, EVENT-RESIZE, EVENT-SELECT, EVENT-MOUSE-MOVE, EVENT-MOUSE-UP, EVENT-MOUSE-DOWN, EVENT-KEY-DOWN, EVENT-KEY-UP): Use enqueue. --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/16 14:42:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/18 14:29:00 1.5 @@ -103,13 +103,16 @@ (defclass graphic-forms-port (basic-port) ((id) - (event - :accessor event + (events + :accessor events :initform nil) (pointer :accessor port-pointer :initform (make-instance 'gfw-pointer)))) +(defun enqueue (port event) + (push event (events port))) + (defvar *sheet-dispatcher* (make-instance 'sheet-event-dispatcher)) (defvar *pane-dispatcher* (make-instance 'pane-event-dispatcher)) @@ -263,20 +266,17 @@ (defmethod get-next-event ((port graphic-forms-port) &key wait-function (timeout nil)) (declare (ignore wait-function timeout)) ; FIXME - (setf (event port) nil) - (cffi:with-foreign-object (msg-ptr 'gfs::msg) - (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0)) - (event nil)) - (cffi:with-foreign-slots ((gfs::hwnd gfs::message gfs::wparam gfs::lparam - gfs::time gfs::pnt) - msg-ptr gfs::msg) - (unless (gfw::default-message-filter gm msg-ptr) - (if (setf event (event port)) - (setf (slot-value event 'climi::timestamp) gfs::time) - #+nil (gfs::debug-format "unhandled Win32 message ID: #x~x~%" - (gfs::lparam-low-word gfs::message)))) - (setf (event port) nil)) - event))) + (or (pop (events port)) + (cffi:with-foreign-object (msg-ptr 'gfs::msg) + (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) + (cffi:with-foreign-slots ((gfs::hwnd gfs::message gfs::wparam gfs::lparam + gfs::time gfs::pnt) + msg-ptr gfs::msg) + (unless (gfw::default-message-filter gm msg-ptr) + (dolist (event (events port)) + (setf (slot-value event 'climi::timestamp) gfs::time))))) + (setf (events port) (nreverse (events port))) + (pop (events port))))) (defmethod process-next-event :after ((port graphic-forms-port) &key wait-function (timeout nil)) (declare (ignore wait-function timeout)) @@ -406,8 +406,8 @@ (gfs::debug-format "menu item: ~a invoked~%" item)) (defmethod gfw:event-close ((self sheet-event-dispatcher) mirror) - (setf (event (port self)) (make-instance 'window-manager-delete-event - :sheet (sheet mirror)))) + (enqueue (port self) + (make-instance 'window-manager-delete-event :sheet (sheet mirror)))) ;; copy&paste from port.lisp|CLX: (defun sheet-desired-ink (sheet) @@ -434,10 +434,10 @@ (setf (gfg:background-color gc) c (gfg:foreground-color gc) c)) (gfg:draw-filled-rectangle gc rect))) - (setf (event (port self)) - (make-instance 'window-repaint-event - :sheet sheet - :region (translate-rectangle rect))))) + (enqueue (port self) + (make-instance 'window-repaint-event + :sheet sheet + :region (translate-rectangle rect))))) (defun generate-configuration-event (mirror pnt size) (make-instance 'window-configuration-event @@ -448,7 +448,8 @@ :height (gfs:size-height size))) (defmethod gfw:event-move ((self sheet-event-dispatcher) mirror pnt) - (setf (event (port self)) (generate-configuration-event mirror pnt (gfw:client-size mirror)))) + (enqueue (port self) + (generate-configuration-event mirror pnt (gfw:client-size mirror)))) (defmethod gfw:event-resize ((self sheet-event-dispatcher) mirror size type) (declare (ignore type)) @@ -457,21 +458,21 @@ (let ((medium (climi::sheet-medium sheet))) (if (and medium (image-of medium)) (resize-medium-buffer medium size)))) - (setf (event (port self)) - (generate-configuration-event mirror (gfw:location mirror) size)))) + (enqueue (port self) + (generate-configuration-event mirror (gfw:location mirror) size)))) (defclass gadget-event (window-event) ()) (defclass button-pressed-event (gadget-event) ()) (defmethod gfw:event-select ((self pane-event-dispatcher) mirror) - (setf (event (port self)) - (typecase mirror - (gfw-button - (make-instance 'button-pressed-event :sheet (sheet mirror))) - (t - (make-instance 'menu-clicked-event - :sheet (sheet (gfw:owner mirror)) - :item (sheet mirror)))))) + (enqueue (port self) + (typecase mirror + (gfw-button + (make-instance 'button-pressed-event :sheet (sheet mirror))) + (t + (make-instance 'menu-clicked-event + :sheet (sheet (gfw:owner mirror)) + :item (sheet mirror)))))) (defmethod handle-event ((pane push-button) (event button-pressed-event)) (activate-callback pane (gadget-client pane) (gadget-id pane))) @@ -487,49 +488,46 @@ (defmethod gfw:event-mouse-move ((self sheet-event-dispatcher) mirror point button) - (setf (event (port self)) - (make-instance 'pointer-motion-event - :pointer 0 - :sheet (sheet mirror) - :x (gfs:point-x point) - :y (gfs:point-y point) - :button (translate-button-name button) - ;; FIXME: -;;; :timestamp + (enqueue (port self) + (make-instance 'pointer-motion-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: ;;; :graft-x ;;; :graft-y - :modifier-state 0 - ))) + :modifier-state 0 + ))) (defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button) - (setf (event (port self)) - (make-instance 'pointer-button-press-event - :pointer 0 - :sheet (sheet mirror) - :x (gfs:point-x point) - :y (gfs:point-y point) - :button (translate-button-name button) - ;; FIXME: -;;; :timestamp + (enqueue (port self) + (make-instance 'pointer-button-press-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: ;;; :graft-x ;;; :graft-y - :modifier-state 0 - ))) + :modifier-state 0 + ))) (defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button) - (setf (event (port self)) - (make-instance 'pointer-button-release-event - :pointer 0 - :sheet (sheet mirror) - :x (gfs:point-x point) - :y (gfs:point-y point) - :button (translate-button-name button) - ;; FIXME: -;;; :timestamp + (enqueue (port self) + (make-instance 'pointer-button-release-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: ;;; :graft-x ;;; :graft-y - :modifier-state 0 - ))) + :modifier-state 0 + ))) (defun char-to-sym (char) (case char @@ -549,34 +547,32 @@ (#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE))) (defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char) - (setf (event (port self)) - (make-instance 'key-press-event - :key-name (char-to-sym char) - :key-character char - :sheet (sheet mirror) - ;; FIXME: - :x 0 - :y 0 - :modifier-state 0 -;;; :timestamp time + (enqueue (port self) + (make-instance 'key-press-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 ;;; :graft-x root-x ;;; :graft-y root-y - ))) + ))) (defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char) - (setf (event (port self)) - (make-instance 'key-release-event - :key-name (char-to-sym char) - :key-character char - :sheet (sheet mirror) - ;; FIXME: - :x 0 - :y 0 - :modifier-state 0 -;;; :timestamp time + (enqueue (port self) + (make-instance 'key-release-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 ;;; :graft-x root-x ;;; :graft-y root-y - ))) + ))) ;;;

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by junrue 18 Mar '07

18 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv13475 Modified Files: graft.lisp Log Message: fixed a typo in graft-width; revised graft-height to be consistent in how the desktop window size is obtained --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:49:05 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/18 03:02:22 1.4 @@ -26,7 +26,7 @@ (defmethod graft-width ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) - (let ((size (gfs:size window))) + (let ((size (gfw:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-width size)) @@ -37,7 +37,7 @@ (defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) - (let ((size (first (gethash :display-sizes (gfs:obtain-system-metrics))))) + (let ((size (gfw:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size))

1 0