23 Sep
2007
23 Sep
'07
12:06 a.m.
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:
- 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.
- 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.
- 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://%7Cim:asf@%7Cmailto: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)