mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim
by thenriksen 27 Apr '07

27 Apr '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19364 Modified Files: mcclim.asd Log Message: Merged splittist's work on splitting the general parts of the Lisp syntax's LR parser into an abstract syntax type. Also some supporting (mostly package) fixes needed to make it all still roll. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/03/14 23:33:24 1.55 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/04/27 21:37:14 1.56 @@ -311,7 +311,8 @@ (:file "misc-commands" :depends-on ("basic-commands")) (:file "unicode-commands" :depends-on ("core" "drei-clim")) (:file "search-commands" :depends-on ("core" "drei-clim")) - (:file "lisp-syntax" :depends-on ("motion" "fundamental-syntax" "core")) + (:file "lr-syntax" :depends-on ("fundamental-syntax" "core")) + (:file "lisp-syntax" :depends-on ("lr-syntax" "motion" "core")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) #+#.(mcclim.system::ifswank) (:file "lisp-syntax-swank" :depends-on ("lisp-syntax")))))) @@ -341,7 +342,7 @@ (:file "buffer-streams-tests" :depends-on ("testing")) (:file "rectangle-tests" :depends-on ("testing")) (:file "undo-tests" :depends-on ("testing")) - (:file "lisp-syntax-tests" :depends-on ("testing")))))) + (:file "lisp-syntax-tests" :depends-on ("testing" "motion-tests")))))) (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 09 Apr '07

09 Apr '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13770 Modified Files: lisp-syntax.lisp Log Message: Fixed issue in `expression-at-mark' that made it select the wrong form (often). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 22:59:28 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 23:06:55 1.27 @@ -1626,7 +1626,7 @@ "Return the form closest to `mark-or-offset'." (as-offsets ((offset mark-or-offset)) (flet ((distance (form) - (max (abs (- (start-offset form) mark-or-offset)) + (min (abs (- (start-offset form) mark-or-offset)) (abs (- (end-offset form) mark-or-offset))))) (reduce #'(lambda (form1 form2) (cond ((null form1) form2)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 09 Apr '07

09 Apr '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11562 Modified Files: lisp-syntax.lisp Log Message: Fixed issue about deleting parts of (in-package) forms at end of buffer. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/19 00:13:05 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 22:59:28 1.26 @@ -1461,8 +1461,8 @@ do (return t)) (loop for (offset . nil) in (package-list syntax) - unless (let ((form (form-around syntax offset))) - (form-list-p form)) + unless (and (>= (size buffer) offset) + (form-list-p (form-around syntax offset))) do (return t))))))) (defun update-package-list (buffer syntax)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 06 Apr '07

06 Apr '07

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26975 Modified Files: base.lisp Log Message: Extended our `constituentp' function to also accept #\#. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/02/06 09:25:43 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/04/06 23:54:48 1.6 @@ -332,7 +332,7 @@ (or (alphanumericp obj) (member obj '(#\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\: #\< #\= #\> #\? #\@ #\^ #\~ #\_ - #\{ #\} #\[ #\] ))))) + #\{ #\} #\[ #\] #\#))))) (defun buffer-whitespacep (obj) "Return T if `obj' is a basic whitespace character. This

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by dlichteblau 01 Apr '07

01 Apr '07

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24182/Backends/CLX Modified Files: clim-extensions.lisp Log Message: Added an extension function SHEET-RGB-IMAGE, which "screenshots" a sheet into an RGB-IMAGE; basically the opposite of MEDIUM-DRAW-RGB-IMAGE. Implemented only for CLIM-CLX and only for true color visuals. * Backends/CLX/clim-extensions.lisp (ZIMAGE-TO-RGB): New helper function. (SHEET-RGB-DATA): New method. * Extensions/rgb-image.lisp (SHEET-RGB-IMAGE): New extension function. (SHEET-RGB-DATA): New backend protocol function. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/clim-extensions.lisp 2003/11/11 03:24:56 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/clim-extensions.lisp 2007/04/01 17:24:04 1.9 @@ -400,3 +400,43 @@ :clipping-region (sheet-region pane) :transformation (make-translation-transformation tx ty))))) ||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; retrieve image + +(defun zimage-to-rgb (zimage) + (unless (eql (xlib:image-depth zimage) 24) + (error "sorry, only true color images supported in zimage-to-rgb")) + (let* ((data (xlib:image-z-pixarray zimage)) + (w (xlib:image-width zimage)) + (h (xlib:image-height zimage)) + (rbyte (mask->byte (xlib:image-red-mask zimage))) + (gbyte (mask->byte (xlib:image-green-mask zimage))) + (bbyte (mask->byte (xlib:image-blue-mask zimage))) + (result (make-array (list h w) + :element-type '(unsigned-byte 32)))) + (dotimes (y h) + (dotimes (x w) + (setf (aref result y x) + (let ((pixel (aref data y x))) + (dpb (the (unsigned-byte 8) (ldb rbyte pixel)) + (byte 8 0) + (dpb (the (unsigned-byte 8) (ldb gbyte pixel)) + (byte 8 8) + (dpb (the (unsigned-byte 8) (ldb bbyte pixel)) + (byte 8 16) + 0))))))) + result)) + +(defmethod climi::sheet-rgb-data ((port clx-port) sheet &key x y width height) + (let ((window (port-lookup-mirror port sheet))) + (values + (zimage-to-rgb + (xlib:get-image window + :format :z-pixmap + :x (or x 0) + :y (or y 0) + :width (or width (xlib:drawable-width window)) + :height (or height (xlib:drawable-height window)))) + nil)))

1 0

[mcclim-cvs] CVS mcclim/Extensions
by dlichteblau 01 Apr '07

01 Apr '07

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv24182/Extensions Modified Files: rgb-image.lisp Log Message: Added an extension function SHEET-RGB-IMAGE, which "screenshots" a sheet into an RGB-IMAGE; basically the opposite of MEDIUM-DRAW-RGB-IMAGE. Implemented only for CLIM-CLX and only for true color visuals. * Backends/CLX/clim-extensions.lisp (ZIMAGE-TO-RGB): New helper function. (SHEET-RGB-DATA): New method. * Extensions/rgb-image.lisp (SHEET-RGB-IMAGE): New extension function. (SHEET-RGB-DATA): New backend protocol function. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/01/07 19:32:29 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/04/01 17:24:04 1.2 @@ -67,3 +67,24 @@ (defmethod medium-draw-image-design* :before (medium design x y) (assert (eq medium (slot-value design 'medium)))) + + +;;; Fetching protocol + +(defun sheet-rgb-image (sheet &key x y width height) + (multiple-value-bind (data alphap) + (sheet-rgb-data (port sheet) + sheet + :x x + :y y + :width width + :height height) + (destructuring-bind (height width) + (array-dimensions data) + (make-instance 'rgb-image + :width width + :height height + :data data + :alphap alphap)))) + +(defgeneric sheet-rgb-data (port sheet &key x y width height))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by dlichteblau 01 Apr '07

01 Apr '07

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24118 Modified Files: medium.lisp Log Message: Fixed typo in rgb-image code. * Backends/CLX/medium.lisp (medium-draw-image-design*): s/height/width/ --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/01/07 19:32:28 1.79 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/04/01 17:23:22 1.80 @@ -1159,7 +1159,7 @@ ((medium clx-medium) (design climi::rgb-image-design) x y) (let* ((da (sheet-direct-mirror (medium-sheet medium))) (image (slot-value design 'climi::image)) - (width (climi::image-height image)) + (width (climi::image-width image)) (height (climi::image-height image))) (destructuring-bind (&optional pixmap mask) (slot-value design 'climi::medium-data)

1 0

[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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs