[mcclim-devel] output-record-count and postscript new-page
Hi, The following code produces an unexpected result in current McCLIM HEAD: (in-package :clim-user) (with-open-file (ps "/tmp/foo.ps" :direction :output :if-exists :supersede) (with-output-to-postscript-stream (s ps) (draw-rectangle* s 10 10 20 20) (new-page s) (draw-rectangle* s 30 30 40 40))) The reason is that the new-page output record is no longer contributing to the bounding rectangle of the stream output history, so that when the history is replayed (to actually write the postscript file) the new-page output records are not replayed. If instead the code is (with-open-file (ps "/tmp/foo.ps" :direction :output :if-exists :supersede) (with-output-to-postscript-stream (s ps) (draw-rectangle* s 10 10 20 20) (new-page s) (draw-rectangle* s 30 30 40 40) (new-page s) (draw-rectangle* s -5 -5 5 5))) You get the expected three pages (rather than the one you get when there is no drawn content around 0,0). This problem can be worked around by defining a method on output-record-count for tree output records which always returns 0: which suggests that the cases testing for output-record-count being eql to 1 (and then doing some optimized path) in recompute-extent-for-{new,changed}-child are optimized to the point of being wrong... Any ideas? Cheers, Christophe
My thoughts, attempting to be brief: 1. The current bounding rectangle behavior is correct and desirable (or if for some reason not correct, desirable anyway). 2. new-page-record is odd in that it exists in the output history but does not represent or contain any geometry. It does not exist in space. The tree output record doesn't really accommodate this, and any current semblance of working is accidental. I don't think the designers of CLIM considered such things either. I'm not sure it's a good idea, as it raises various issues.. 3. Though it doesn't affect this bug, map-over-output-records on tree output records is arguably broken at present. I would expect it to include new-page-records, but currently it does not. The -containing-position and -overlapping-region variants are correct to not include it (as these are spatial queries, and IMHO should not report empty, positionless objects). 4. Considering the above, and that replay uses map-over-output-records-overlapping-region, replay of new-page-records shouldn't be expected to work. Also, the constraints on order are too weak (records are only required by the spec to be reported in order of creation when they overlap - anyone know what our current behavior is here?). There are two ways I can imagine a hardcopy stream with pages working - either have a compound page-output-record class into which drawing for an individual page is contained, or take the approach implied by the CLIM spec, which is to force the generation of postscript when new-page is called, then clear the output history, so only one page at a time exists in the output history at a time. An alternative to using replay would be to traverse the output-record-children list directly, which is guaranteed to be in order. On 9/18/07, Christophe Rhodes <csr21@cantab.net> wrote:
This problem can be worked around by defining a method on output-record-count for tree output records which always returns 0: which suggests that the cases testing for output-record-count being eql to 1 (and then doing some optimized path) in recompute-extent-for-{new,changed}-child are optimized to the point of being wrong...
I think the current behavior is correct, and (due to output-record-count lying to us) the previous answer was wrong. I haven't yet worked through exactly what was happening, why it didn't occur more often, and if it is the bug I note in recording.lisp.
To get at the promised-by-Krystof beverages tomorrow, I've hacked up a patch for tree ORs that should fix things again. Andy Hefner wrote:
2. new-page-record is odd in that it exists in the output history but does not represent or contain any geometry. It does not exist in space. The tree output record doesn't really accommodate this, and any current semblance of working is accidental. I don't think the designers of CLIM considered such things either. I'm not sure it's a good idea, as it raises various issues..
Agreed.
3. Though it doesn't affect this bug, map-over-output-records on tree output records is arguably broken at present. I would expect it to include new-page-records, but currently it does not. The -containing-position and -overlapping-region variants are correct to not include it (as these are spatial queries, and IMHO should not report empty, positionless objects).
Right.
4. Considering the above, and that replay uses map-over-output-records-overlapping-region, replay of new-page-records shouldn't be expected to work. Also, the constraints on order are too weak (records are only required by the spec to be reported in order of creation when they overlap - anyone know what our current behavior is here?).
I agree, but to get something working, I've made a compromise: To consider null-BR children when +everywhere+ is queried. That is, to interpret questions about everywhere as questions about nowhere as well. The attached patch implements this, and yields the expected two pages of output from Christophe's first example. It runs the examples, but I can't say anything about its performance (-:
There are two ways I can imagine a hardcopy stream with pages working - either have a compound page-output-record class into which drawing for an individual page is contained, or take the approach implied by the CLIM spec, which is to force the generation of postscript when new-page is called, then clear the output history, so only one page at a time exists in the output history at a time.
That sounds enormously sensible. I would go with this. Cheers, -- Andreas Fuchs, (http://|im:asf@|mailto:asf@)boinkor.net, antifuchs ? .DS_Store ? gtkairo.tgz ? patch-case1 ? patch-case2.bz2 ? patch-color-case ? Backends/Null/frame-manager.fasl ? Backends/Null/graft.fasl ? Backends/Null/medium.fasl ? Backends/Null/package.fasl ? Backends/Null/port.fasl ? Doc/docstrings ? Doc/Guided-Tour/guided-tour.aux ? Doc/Guided-Tour/guided-tour.log ? Doc/Guided-Tour/guided-tour.pdf ? Drei/abbrev.fasl ? Drei/base.fasl ? Drei/basic-commands.fasl ? Drei/buffer.fasl ? Drei/core-commands.fasl ? Drei/core.fasl ? Drei/delegating-buffer.fasl ? Drei/drei-clim.fasl ? Drei/drei-redisplay.fasl ? Drei/drei.fasl ? Drei/editing.fasl ? Drei/fundamental-syntax.fasl ? Drei/input-editor.fasl ? Drei/kill-ring.fasl ? Drei/lisp-syntax-commands.fasl ? Drei/lisp-syntax-swank.fasl ? Drei/lisp-syntax-swine.fasl ? Drei/lisp-syntax.fasl ? Drei/misc-commands.fasl ? Drei/motion.fasl ? Drei/packages.fasl ? Drei/rectangle.fasl ? Drei/search-commands.fasl ? Drei/syntax.fasl ? Drei/undo.fasl ? Drei/unicode-commands.fasl ? Drei/Persistent/binseq-package.fasl ? Drei/Persistent/binseq.fasl ? Drei/Persistent/binseq2.fasl ? Drei/Persistent/obinseq.fasl ? Drei/Persistent/persistent-buffer.fasl ? Drei/Persistent/persistent-undo.fasl ? Drei/cl-automaton/automaton-package.fasl ? Drei/cl-automaton/automaton.fasl ? Drei/cl-automaton/eqv-hash.fasl ? Drei/cl-automaton/regexp.fasl ? Drei/cl-automaton/state-and-transition.fasl ? ESA/colors.fasl ? ESA/esa-buffer.fasl ? ESA/esa-command-parser.fasl ? ESA/esa-io.fasl ? ESA/esa.fasl ? ESA/packages.fasl ? ESA/utils.fasl ? Extensions/rgb-image.fasl Index: recording.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/recording.lisp,v retrieving revision 1.135 diff -u -r1.135 recording.lisp --- recording.lisp 7 Sep 2007 16:49:11 -0000 1.135 +++ recording.lisp 23 Sep 2007 00:03:19 -0000 @@ -970,6 +970,9 @@ (defclass standard-tree-output-record (compound-output-record) ((children :initform (%make-tree-output-record-tree) :accessor %tree-record-children) + (ungeometric-children :initform (make-hash-table :test #'eql) + :accessor %tree-record-ungeometric-children + :documentation "Container for children that have null bounding rectangles. (I.e. output-historic, not geometric things.)") (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache) (child-count :initform 0) (last-insertion-nr :initform 0 :accessor last-insertion-nr))) @@ -983,29 +986,44 @@ (defun %remove-entry-from-children-cache (record entry) (remhash entry (%tree-record-children-cache record))) +(defmethod output-record-count ((record standard-tree-output-record)) + (slot-value record 'child-count)) + (defmethod output-record-children ((record standard-tree-output-record)) - (map 'list - #'tree-output-record-entry-record - (spatial-trees:search (%record-to-spatial-tree-rectangle record) - (%tree-record-children record)))) + (nconc + (loop for child being the hash-key in (%tree-record-ungeometric-children record) + collect child) + (map 'list + #'tree-output-record-entry-record + (spatial-trees:search (%record-to-spatial-tree-rectangle record) + (%tree-record-children record))))) (defmethod add-output-record (child (record standard-tree-output-record)) - (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record))))) - (spatial-trees:insert entry (%tree-record-children record)) - (setf (output-record-parent child) record) - (setf (%entry-in-children-cache record child) entry)) + (if (null-bounding-rectangle-p record) + (setf (gethash child (%tree-record-ungeometric-children record)) + (make-tree-output-record-entry child (incf (last-insertion-nr record)))) + (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record))))) + (spatial-trees:insert entry (%tree-record-children record)) + (setf (output-record-parent child) record) + (setf (%entry-in-children-cache record child) entry))) (incf (slot-value record 'child-count)) (values)) (defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t)) - (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child) - (%tree-record-children record)) - :key #'tree-output-record-entry-record))) - (decf (slot-value record 'child-count)) + (let (entry) + (cond ((null-bounding-rectangle-p child) + (setf entry (gethash child (%tree-record-ungeometric-children record))) + (remhash child (%tree-record-ungeometric-children record))) + (t + (setf entry + (find child (spatial-trees:search (%entry-in-children-cache record child) + (%tree-record-children record)) + :key #'tree-output-record-entry-record)) + (spatial-trees:delete entry (%tree-record-children record)))) (cond ((not (null entry)) - (spatial-trees:delete entry (%tree-record-children record)) (%remove-entry-from-children-cache record child) + (decf (slot-value record 'child-count)) (setf (output-record-parent child) nil)) (errorp (error "~S is not a child of ~S" child record))))) @@ -1015,14 +1033,17 @@ (%remove-entry-from-children-cache record child)) (output-record-children record)) (setf (slot-value record 'child-count) 0) - (setf (%tree-record-children record) (%make-tree-output-record-tree))) - -(defmethod output-record-count ((record standard-tree-output-record)) - (slot-value record 'child-count)) + (setf (%tree-record-children record) (%make-tree-output-record-tree)) + (clrhash (%tree-record-children record))) -(defun map-over-tree-output-records (function record rectangle sort-order function-args) - (dolist (child (sort (spatial-trees:search rectangle - (%tree-record-children record)) +(defun map-over-tree-output-records (function record rectangle everywhere-p sort-order function-args) + (dolist (child (sort (concatenate 'list + (when everywhere-p + (loop for entry being the hash-values + of (%tree-record-ungeometric-children record) + collect entry)) + (spatial-trees:search rectangle + (%tree-record-children record))) (ecase sort-order (:most-recent-first #'>) (:most-recent-last #'<)) @@ -1030,12 +1051,13 @@ (apply function (tree-output-record-entry-record child) function-args))) (defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args) - (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last + (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) t :most-recent-last function-args)) (defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args) (declare (ignore x-offset y-offset)) - (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first + (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) + nil :most-recent-first function-args)) (defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args) @@ -1048,11 +1070,12 @@ (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child)) region) (apply function child function-args))) - record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last - nil)))) + record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) + (region-equal region +everywhere+) :most-recent-last nil)))) (defmethod recompute-extent-for-changed-child :around ((record standard-tree-output-record) child old-min-x old-min-y old-max-x old-max-y) - (when (eql record (output-record-parent child)) + (when (and (not (null-bounding-rectangle-p child)) + (eql record (output-record-parent child))) (let ((entry (%entry-in-children-cache record child))) (spatial-trees:delete entry (%tree-record-children record)) (setf (tree-output-record-entry-cached-rectangle entry) nil)
Andreas Fuchs <asf@boinkor.net> writes:
To get at the promised-by-Krystof beverages tomorrow, I've hacked up a patch for tree ORs that should fix things again.
Andreas and I met up last night, and we agreed that he didn't deserve a beer, because although his patch gets my page postscript test case right, it also causes every clim application we tested to deadlock on startup. Oh well :-) Cheers, Christophe
participants (3)
-
Andreas Fuchs -
Andy Hefner -
Christophe Rhodes