/[mcclim]/mcclim/incremental-redisplay.lisp
ViewVC logotype

Contents of /mcclim/incremental-redisplay.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.66 - (show annotations)
Sat Aug 1 16:10:32 2009 UTC (4 years, 8 months ago) by gbaumann
Branch: MAIN
CVS Tags: HEAD
Changes since 1.65: +2 -2 lines
Use force-output instead of finish-output as the latter implies
waiting for an answer from the display server, which is something
we really do not want to do.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2002-2004 by Tim Moore (moore@bricoworks.com)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 (in-package :clim-internals)
22
23 #|
24 Incremental Redisplay Theory of Operation
25
26 Incremental redisplay compares the tree of output records before and after
27 calling REDISPLAY and updates those parts of the screen that are different.
28 UPDATING-OUTPUT forms in the code create UPDATING-OUTPUT-RECORDs in the record
29 tree. These records hold the before and after snapshots of the tree. When the
30 display code is first run, the bodies of all the UPDATING-OUTPUT forms are
31 captured as closures. Usually only the closure in the top-level output record
32 will ever get called, but the programmer can call REDISPLAY on any
33 updating output record, so we have to be prepared for that.
34
35 Redisplay proceeds thus:
36
37 All the updating output records are visited. Their state is changed to
38 :UPDATING and the OLD-CHILDREN slot is set to the current children.
39
40 The closure of the root updating output record is called. None of the
41 closures the child updating output records are called because any free
42 variables captured in the UPDATING-OUTPUT forms need to see the fresh bindings
43 from this run of the code.As UPDATING-OUTPUT forms are encountered, several
44 things can happen:
45
46 * The cache value of the form compares to the value stored in the record. The
47 record, and all the updating output records below it, are marked :clean. The
48 body of UPDATING-OUTPUT isn't run.
49
50 * The cache value doesn't compare. The record is marked :UPDATED, and the body
51 is run.
52
53 * There isn't an existing UPDATING-OUTPUT-RECORD for this UPDATING-OUTPUT
54 form. One is created in state :UPDATED. The body is run.
55
56 Before the top level UPDATING-OUTPUT closure returns, various output records
57 in the history tree might be mutated e.g., be moved. The most common case of
58 this is in table layout, where the records for each cell are first created and
59 then assigned a final location based on the dimensions of the table. But these
60 nodes may be children of an updating output record that has been marked
61 :CLEAN. Therefore, they have to be treated specially so that the rest of
62 incremental redisplay will consider them and not leave the screen in a trashed
63 state. An around method on (SETF OUTPUT-RECORD-POSITION) for display records
64 checks if incremental redisplay is in progress; if so, it stores the mutated
65 record in its closest parent UPDATING-OUTPUT record (if any). If that parent
66 is :CLEAN then it and any other clean parent updating output records are
67 marked as :UPDATED.
68
69
70 Next, COMPUTE-DIFFERENCE-SET compares the old and new trees. New output
71 records that aren't in the old tree need to be drawn. Old records not in the
72 new tree need to be erased. Display records that were moved need are erased
73 and redrawn. COMPUTE-DIFFERENCE-SET only compares display output records that
74 are direct descendents (i.e., no intervening UPDATING-OUTPUT record) of an
75 updating output record; Compute-difference-set is called recursively on any
76 children updating output records.
77
78 As an optimization, COMPUTE-DIFFERENCE-SET ignores records that are outside of
79 the pane's visible regin.
80
81 Finally, the old tree is walked. All updating output records in state
82 :UPDATING were not visited at all and thus are deleted from their parent
83 caches.
84
85
86 Problems / Future work
87
88 The complete traversals of the output history tree could be avoided by keeping
89 a generation number in the updating output record and updating that everytime
90 the node is visited.
91
92 The search for equal display nodes is expensive in part because we have no
93 spatially organized data structure.
94
95 |#
96
97 ;;; The map from unique values to output records. Unfortunately the :ID-TEST
98 ;;; is specified in the child updating output records, not in the record that
99 ;;; holds the cache! So, the map lookup code jumps through some hoops to use a
100 ;;; hash table if the child id tests allow that and if there enough records in
101 ;;; the map to make that worthwhile.
102
103 (defclass updating-output-map-mixin ()
104 ((id-map :accessor id-map :initform nil)
105 (id-counter :accessor id-counter
106 :documentation "The counter used to assign unique ids to
107 updating output records without one.")
108 (tester-function :accessor tester-function :initform 'none
109 :documentation "The function used to lookup
110 updating output records in this map if unique; otherwise, :mismatch.")
111 (element-count :accessor element-count :initform 0)))
112
113 ;;; Complete guess...
114 (defparameter *updating-map-threshold* 10
115 "The limit at which the id map in an updating output record switches to a
116 hash table.")
117
118 ;;; ((eq map-test-func :mismatch)
119 ;;; nil)
120 (defun function-matches-p (map func)
121 (let ((map-test-func (tester-function map)))
122 (cond ((eq map-test-func func)
123 t)
124 ((and (symbolp map-test-func) (symbolp func)) ; not eq
125 nil)
126 ((and (symbolp map-test-func) (fboundp map-test-func))
127 (eq (symbol-function map-test-func) func))
128 ((and (symbolp func) (fboundp func))
129 (eq map-test-func (symbol-function func)))
130 (t nil))))
131
132 (defun ensure-test (map test)
133 (unless (function-matches-p map test)
134 (explode-map-hash map)
135 (setf (tester-function map) :mismatch)))
136
137 (defgeneric clear-map (map))
138
139 (defmethod clear-map ((map updating-output-map-mixin))
140 (setf (id-map map) nil)
141 (setf (id-counter map) 0)
142 (setf (element-count map) 0))
143
144 ;;; Perhaps these should be generic functions, but in the name of premature
145 ;;; optimization they're not :)
146 (defun get-from-map (map value test)
147 (when (eq (tester-function map) 'none)
148 (return-from get-from-map nil))
149 (ensure-test map test)
150 (let ((map (id-map map)))
151 (if (hash-table-p map)
152 (gethash value map)
153 (cdr (assoc value map :test test)))))
154
155
156 (defun maybe-convert-to-hash (map)
157 (let ((test (tester-function map)))
158 (when (and (not (eq test :mismatch))
159 (> (element-count map) *updating-map-threshold*)
160 (or (case test
161 ((eq eql equal equalp) t))
162 (eq test #'eq)
163 (eq test #'eql)
164 (eq test #'equal)
165 (eq test #'equalp)))
166 (let ((new-map (make-hash-table :test test)))
167 (loop
168 for (key . value) in (id-map map)
169 do (setf (gethash key new-map) value))
170 (setf (id-map map) new-map)))))
171
172 (defun explode-map-hash (map)
173 (let ((hash-map (id-map map)))
174 (when (hash-table-p hash-map)
175 (loop
176 for key being each hash-key of hash-map using (hash-value record)
177 collect (cons key record) into alist
178 finally (setf (id-map map) alist)))))
179
180 (defun add-to-map (map record value test replace)
181 (if (eq (tester-function map) 'none)
182 (setf (tester-function map) test)
183 (ensure-test map test))
184 (let ((val-map (id-map map)))
185 (if (hash-table-p val-map)
186 (multiple-value-bind (existing-value in-table)
187 (if replace
188 (gethash value val-map)
189 (values nil nil))
190 (declare (ignore existing-value))
191 (setf (gethash value val-map) record)
192 (unless in-table
193 (incf (element-count map))))
194 (let ((val-cons (if replace
195 (assoc value val-map :test test)
196 nil)))
197 (if val-cons
198 (setf (cdr val-cons) record)
199 (progn
200 (setf (id-map map) (acons value record val-map))
201 (incf (element-count map))
202 (maybe-convert-to-hash map)))))))
203
204 (defun delete-from-map (map value test)
205 (ensure-test map test)
206 (let ((val-map (id-map map))
207 (deleted nil))
208 (if (hash-table-p val-map)
209 (setf deleted (remhash value val-map))
210 (setf (values (id-map map) deleted)
211 (delete-1 value val-map :test test :key #'car)))
212 (when deleted
213 (decf (element-count map)))))
214
215 ;;; Reset the ID counter so that updating output records without explicit IDs
216 ;;; can be assigned one during a run of the code. I'm not sure about using
217 ;;; reinitialize-instance for this...
218 (defmethod shared-initialize :after ((obj updating-output-map-mixin) slot-names
219 &key)
220 (declare (ignore slot-names))
221 (setf (id-counter obj) 0))
222
223 ;;; Should this have a more complete CPL, to pull in the fact that it needs a
224 ;;; medium for graphics state?
225 (defclass updating-output-stream-mixin (updating-output-map-mixin
226 extended-output-stream)
227 ((redisplaying-p :reader stream-redisplaying-p :initform nil)
228 (do-note-output-record :accessor do-note-output-record :initform t)
229 (incremental-redisplay :initform nil
230 :initarg :incremental-redisplay
231 :accessor pane-incremental-redisplay)
232 (updating-record :accessor updating-record
233 :initarg :updating-record :initform nil
234 :documentation "For incremental output, holds the
235 top level updating-output-record.")))
236
237 (defgeneric redisplayable-stream-p (stream))
238
239 (defmethod redisplayable-stream-p ((stream t))
240 nil)
241
242 (defmethod redisplayable-stream-p ((stream updating-output-stream-mixin))
243 t)
244
245 (defmethod pane-needs-redisplay :around ((pane updating-output-stream-mixin))
246 (let ((redisplayp (call-next-method)))
247 (values redisplayp (and (not (eq redisplayp :no-clear))
248 (not (pane-incremental-redisplay pane))))))
249
250 (defmethod window-clear :after ((pane updating-output-stream-mixin))
251 "Get rid of any updating output records stored in the stream; they're gone
252 from the screen."
253 (clear-map pane))
254
255 ;;; INCREMENTAL-DISPLAY takes as input the difference set computed by
256 ;;; COMPUTE-DIFFERENCE-SET and updates the screen. The 5 kinds of updates are
257 ;;; not very well defined in the spec. I understand their semantics thus:
258 ;;;
259 ;;; Erases, moves, and draws refer to records that don't overlap *with other
260 ;;; records that survive in the current rendering*. In other words, they don't
261 ;;; overlap with records that were not considered by COMPUTE-DIFFRENCE-SET,
262 ;;; either because they are children of a clean updating output node or they
263 ;;; are in another part of the output history that is not being
264 ;;; redisplayed. Also, moves and draws can not overlap each other. It is fine
265 ;;; for erases and draws to overlap. Another way to think about erases, moves
266 ;;; and draws is in terms of a possible implementation: they could be handled
267 ;;; using only operations on the screen itself. First all the erase regions
268 ;;; would be erased, the moves would be blitted, and then the individual draws
269 ;;; records would be redisplayed.
270 ;;;
271 ;;; Records in erase-overlapping and move-overlapping might overlap with any
272 ;;; other record. They need to be implemented by erasing their region on the
273 ;;; screen and then replaying the output history for that region. Thus, any
274 ;;; ordering issues implied by overlapping records is handled correctly. Note
275 ;;; that draw records that overlap are included in erase-overlapping; the draw
276 ;;; operation itself occurs when the screen is refreshed from the output
277 ;;; history. -- moore
278
279 (defgeneric incremental-redisplay
280 (stream position erases moves draws erase-overlapping move-overlapping))
281
282 (defmethod incremental-redisplay ((stream updating-output-stream-mixin) position
283 erases moves draws erase-overlapping move-overlapping)
284 (declare (ignore position))
285 (let ((history (stream-output-history stream)))
286 (with-output-recording-options (stream :record nil :draw t)
287 (loop
288 for (nil br) in erases
289 do (erase-rectangle stream br))
290 (loop
291 for (nil old-bounding) in moves
292 do (erase-rectangle stream old-bounding))
293 (loop
294 for (nil br) in erase-overlapping
295 do (erase-rectangle stream br))
296 (loop
297 for (nil old-bounding) in move-overlapping
298 do (erase-rectangle stream old-bounding)))
299 (loop
300 for (r) in moves
301 do (replay r stream))
302 (loop
303 for (r) in draws
304 do (replay r stream))
305 (let ((res +nowhere+))
306 (loop for (r) in erase-overlapping do (setf res (region-union res r)))
307 (loop for (r) in move-overlapping do (setf res (region-union res r)))
308 (replay history stream res))))
309
310 ;;; FIXME: although this inherits from COMPLETE-MEDIUM-STATE, in fact
311 ;;; it needn't, as we only ever call SET-MEDIUM-CURSOR-POSITION on it.
312 ;;; Until 2006-05-28, we did also use the various medium attributes,
313 ;;; but with the reworking of REPLAY-OUTPUT-RECORD
314 ;;; (STANDARD-DISPLAYED-OUTPUT-RECORD) to use around methods and
315 ;;; WITH-DRAWING-OPTIONS, they are no longer necessary.
316 (defclass updating-stream-state (complete-medium-state)
317 ((cursor-x :accessor cursor-x :initarg :cursor-x :initform 0)
318 (cursor-y :accessor cursor-y :initarg :cursor-y :initform 0)))
319
320 (defmethod initialize-instance :after ((obj updating-stream-state)
321 &key (stream nil))
322 (when stream
323 (setf (values (slot-value obj 'cursor-x) (slot-value obj 'cursor-y))
324 (stream-cursor-position stream))))
325
326 (defmethod match-output-records-1 and ((state updating-stream-state)
327 &key (cursor-x 0 x-supplied-p)
328 (cursor-y 0 y-supplied-p))
329 (and (or (not x-supplied-p)
330 (coordinate= (slot-value state 'cursor-x) cursor-x))
331 (or (not y-supplied-p)
332 (coordinate= (slot-value state 'cursor-y) cursor-y))))
333
334 (defmethod set-medium-cursor-position
335 ((state updating-stream-state) (stream updating-output-stream-mixin))
336 (setf (stream-cursor-position stream)
337 (values (cursor-x state) (cursor-y state))))
338
339 (defmethod medium-graphics-state ((stream updating-output-stream-mixin)
340 &optional state)
341 (if (and state (subtypep state 'updating-stream-state))
342 (reinitialize-instance state :stream stream)
343 (make-instance 'updating-stream-state :stream stream)))
344
345 ;;; XXX Add to values we test, obviously.
346 ;;;
347 ;;;Well, maybe not. The goal is to support output records that have moved
348 ;;;but that are otherwise clean. I.e., some previous part of the output has
349 ;;;changed (lines added or deleted, for example). If the stream cursor
350 ;;;position is different, I'm not sure now that the code for the updating
351 ;;;output record needs to be rerun; I think we could use only the difference
352 ;;;in cursor position to move the record. Any other graphics state change --
353 ;;;like a different foreground color -- should probably be handled by the
354 ;;;programmer forcing all new output.
355
356 (defun state-matches-stream-p (state stream)
357 (multiple-value-bind (cx cy) (stream-cursor-position stream)
358 (with-sheet-medium (medium stream)
359 ;; Note: We don't match the y coordinate.
360 (declare (ignore cy))
361 (match-output-records state :cursor-x cx))))
362
363 (defclass updating-output-record-mixin (updating-output-map-mixin
364 standard-sequence-output-record)
365 ((unique-id :reader output-record-unique-id :initarg :unique-id)
366 (id-test :reader output-record-id-test :initarg :id-test
367 :initform #'eql)
368 (cache-value :reader output-record-cache-value :initarg :cache-value)
369 (cache-test :reader output-record-cache-test :initarg :cache-test
370 :initform #'eql)
371 (fixed-position :reader output-record-fixed-position
372 :initarg :fixed-position :initform nil)
373 (displayer :reader output-record-displayer :initarg :displayer)
374 ;; Start and end cursor
375 (start-graphics-state :accessor start-graphics-state
376 :initarg :start-graphics-state
377 :documentation "Graphics state needed to
378 render record")
379 (end-graphics-state :accessor end-graphics-state
380 :initarg :end-graphics-state
381 :documentation "Graphics state after rendering
382 record; used to render non updating-output-records that follow")
383 (old-children :accessor old-children
384 :documentation "Contains the output record tree for the
385 current display.")
386 (output-record-dirty :accessor output-record-dirty :initform :updating
387 :documentation
388 ":updating
389 :updated
390 :clean")
391 (parent-cache :accessor parent-cache :initarg :parent-cache
392 :documentation "The parent cache in which this updating output
393 record is stored.")
394 (stream :accessor updating-output-stream :initarg :stream :initform nil
395 :documentation "Capture the screen in order to restrict update to
396 visible records")
397 (parent-updating-output :accessor parent-updating-output
398 :initarg :parent-updating-output :initform nil
399 :documentation "A backlink to the
400 updating-output-parent above this one in the tree.")
401 ;; Results of (setf output-record-position) while updating
402 (explicit-moves :accessor explicit-moves)
403 (old-bounds :accessor old-bounds
404 :initform (make-bounding-rectangle 0.0d0 0.0d0 0.0d0 0.0d0)
405 :documentation "Holds the old bounds of an updating output
406 record if that can no longer be determined from the old-children.")
407 ;; on-screen state?
408 ))
409
410 (defgeneric sub-record (record)
411 (:method ((record updating-output-record-mixin))
412 (let ((children (output-record-children record)))
413 (if (zerop (length children))
414 nil
415 (aref children 0)))))
416
417 (defmethod shared-initialize :after
418 ((obj updating-output-record-mixin) slot-names
419 &key (x-position 0.0d0) (y-position 0.0d0))
420 (declare (ignore x-position y-position))
421 (declare (ignore slot-names))
422 (setf (explicit-moves obj) nil))
423
424 (defmethod output-record-start-cursor-position
425 ((record updating-output-record-mixin))
426 (let ((state (start-graphics-state record)))
427 (values (cursor-x state) (cursor-y state))))
428
429 (defmethod* (setf output-record-start-cursor-position)
430 (x y (record updating-output-record-mixin))
431 (let ((state (start-graphics-state record)))
432 (setf (values (cursor-x state) (cursor-y state)) (values x y))))
433
434 (defmethod output-record-end-cursor-position
435 ((record updating-output-record-mixin))
436 (let ((state (end-graphics-state record)))
437 (values (cursor-x state) (cursor-y state))))
438
439 (defmethod* (setf output-record-end-cursor-position)
440 (x y (record updating-output-record-mixin))
441 (let ((state (end-graphics-state record)))
442 (setf (values (cursor-x state) (cursor-y state)) (values x y))))
443
444 ;;; Prevent deleted output records from coming back from the dead.
445 (defmethod delete-output-record :after ((child updating-output-record-mixin)
446 record
447 &optional errorp)
448 (declare (ignore record errorp))
449 (let ((pcache (parent-cache child)))
450 (delete-from-map pcache
451 (output-record-unique-id child)
452 (output-record-id-test child))))
453
454
455 (defclass standard-updating-output-record (updating-output-record-mixin
456 updating-output-record)
457 ())
458
459 (defmethod print-object ((obj standard-updating-output-record) stream)
460 (print-unreadable-object (obj stream :type t :identity t)
461 (with-standard-rectangle (x1 y1 x2 y2)
462 obj
463 (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2))
464 (when (slot-boundp obj 'unique-id)
465 (let ((*print-length* 10)
466 (*print-level* 3))
467 (format stream " ~S" (output-record-unique-id obj))))))
468
469 ;;; Helper function for visiting updating-output records in a tree
470
471 (defgeneric map-over-updating-output (function root use-old-records))
472
473 (defmethod map-over-updating-output (function
474 (record standard-updating-output-record)
475 use-old-records)
476 (funcall function record)
477 (let ((children (cond (use-old-records
478 (when (slot-boundp record 'old-children)
479 (old-children record)))
480 (t (sub-record record)))))
481 (when children
482 (map-over-updating-output function children use-old-records))))
483
484
485 (defmethod map-over-updating-output
486 (function (record compound-output-record) use-old-records)
487 (flet ((mapper (r)
488 (map-over-updating-output function r use-old-records)))
489 (declare (dynamic-extent #'mapper))
490 (map-over-output-records #'mapper record)))
491
492 (defmethod map-over-updating-output (function record use-old-records)
493 (declare (ignore function record use-old-records))
494 nil)
495 ;;;
496 (defvar *current-updating-output* nil)
497
498 (defgeneric compute-new-output-records (record stream))
499
500 (defgeneric compute-new-output-records-1 (record stream displayer)
501 (:documentation "Like compute-new-output-records with an explicit
502 displayer function."))
503
504 (defmethod compute-new-output-records ((record standard-updating-output-record)
505 stream)
506 (with-output-recording-options (stream :record t :draw nil)
507 (map-over-updating-output
508 #'(lambda (r)
509 (let ((sub-record (sub-record r)))
510 (setf (old-children r) sub-record)
511 (setf (output-record-dirty r) :updating)
512 (setf (rectangle-edges* (old-bounds r))
513 (rectangle-edges* sub-record))))
514 record
515 nil)
516 (force-output stream)
517 ;; Why is this binding here? We need the "environment" in this call that
518 ;; computes the new records of an outer updating output record to resemble
519 ;; that when a record's contents are computed in invoke-updating-output.
520 (letf (((stream-current-output-record stream)
521 (output-record-parent record)))
522 (compute-new-output-records-1 record
523 stream
524 (output-record-displayer record)))))
525
526 ;;; Create the sub-record that holds the new contents of the updating output
527 ;;; record.
528 (defun %invoke-updating (record stream displayer)
529 (letf (((stream-current-output-record stream) record))
530 (with-new-output-record (stream)
531 (funcall displayer stream))))
532
533 (defmethod compute-new-output-records-1
534 ((record standard-updating-output-record) stream displayer)
535 (multiple-value-bind (x y)
536 (output-record-position record)
537 (let ((sub-record (sub-record record)))
538 (when sub-record
539 (delete-output-record sub-record record)))
540 ;; Don't add this record repeatedly to a parent updating-output-record.
541 (unless (eq (output-record-parent record)
542 (stream-current-output-record stream))
543 (setf (output-record-parent record) nil)
544 (add-output-record record (stream-current-output-record stream)))
545 (reinitialize-instance record :x-position x :y-position y))
546 (%invoke-updating record stream displayer)
547 (setf (output-record-dirty record) :updated))
548
549 (defgeneric find-child-output-record (record use-old-elements record-type
550 &rest initargs
551 &key unique-id unique-id-test))
552
553 (defgeneric map-over-displayed-output-records
554 (function root use-old-elements clean clip-region)
555 (:documentation "Call function on all displayed-output-records in ROOT's
556 tree. If USE-OLD-ELEMENTS is true, descend the old branch of
557 updating output records. If CLEAN is true, descend into clean updating output
558 records. "))
559
560 (defmethod map-over-displayed-output-records :around
561 (function root use-old-elements clean (clip-rectangle bounding-rectangle))
562 (declare (ignore function use-old-elements clean))
563 (when (region-intersects-region-p root clip-rectangle)
564 (call-next-method)))
565
566 (defmethod map-over-displayed-output-records (function
567 (root standard-updating-output-record)
568 use-old-elements
569 clean
570 clip-rectangle)
571 (cond ((and (not clean) (eq (output-record-dirty root) :clean))
572 nil)
573 ((and use-old-elements (slot-boundp root 'old-children))
574 (map-over-displayed-output-records function
575 (old-children root)
576 use-old-elements
577 clean
578 clip-rectangle))
579 ((not use-old-elements)
580 (map-over-displayed-output-records function
581 (sub-record root)
582 use-old-elements
583 clean
584 clip-rectangle))
585 (t nil)))
586
587 (defmethod map-over-displayed-output-records (function
588 (root compound-output-record)
589 use-old-elements
590 clean
591 clip-rectangle)
592 (flet ((mapper (record)
593 (map-over-displayed-output-records function
594 record
595 use-old-elements
596 clean
597 clip-rectangle)))
598 (declare (dynamic-extent #'mapper))
599 (map-over-output-records #'mapper root)))
600
601 (defmethod map-over-displayed-output-records (function
602 (root displayed-output-record)
603 use-old-elements
604 clean
605 clip-rectangle)
606 (declare (ignore clean use-old-elements clip-rectangle))
607 (funcall function root))
608
609 (defgeneric compute-difference-set (record &optional check-overlapping
610 offset-x offset-y
611 old-offset-x old-offset-y))
612
613 ;;; Helper functions for visiting only the highest level updating
614 ;;; output records in a tree and only those display records that are
615 ;;; not under updating output records. Do not pass these the parent
616 ;;; updating output record; pass sub-record or old-children
617
618 (defgeneric map-over-child-updating-output (function record clip-rectangle)
619 (:documentation "Apply FUNCTION to updating-output records that are
620 children of record, but don't recurse into them.")
621 (:method (function (record standard-updating-output-record) clip-rectangle)
622 (declare (ignore clip-rectangle))
623 (funcall function record))
624 (:method (function (record compound-output-record) clip-rectangle)
625 (flet ((mapper (r)
626 (map-over-child-updating-output function r clip-rectangle)))
627 (declare (dynamic-extent #'mapper))
628 (map-over-output-records #'mapper record)))
629 (:method (function record clip-rectangle)
630 (declare (ignore function record clip-rectangle))
631 nil)
632 (:method :around (function record (clip-rectangle bounding-rectangle))
633 (declare (ignore function))
634 (when (region-intersects-region-p record clip-rectangle)
635 (call-next-method))))
636
637 (defgeneric map-over-child-display (function record clip-rectangle)
638 (:documentation "Apply function to display records in RECORD's tree that are
639 not under updating-output records")
640 (:method (function (record displayed-output-record) clip-rectangle)
641 (declare (ignore clip-rectangle))
642 (funcall function record))
643 (:method (function (record compound-output-record) clip-rectangle)
644 (flet ((mapper (r)
645 (map-over-child-display function r clip-rectangle)))
646 (declare (dynamic-extent #'mapper))
647 (map-over-output-records #'mapper record)))
648 (:method (function (record standard-updating-output-record) clip-rectangle)
649 (declare (ignore function record clip-rectangle))
650 nil)
651 (:method (function record clip-rectangle)
652 (declare (ignore function record clip-rectangle))
653 nil)
654 (:method :around (function record (clip-rectangle bounding-rectangle))
655 (declare (ignore function))
656 (when (region-intersects-region-p record clip-rectangle)
657 (call-next-method))))
658
659 ;;; Variation on a theme. Refactor, refactor...
660
661 (defgeneric map-over-obsolete-display (function record clip-rectangle)
662 (:method (function (record displayed-output-record) clip-rectangle)
663 (declare (ignore clip-rectangle))
664 (funcall function record))
665 (:method (function (record compound-output-record) clip-rectangle)
666 (flet ((mapper (r)
667 (map-over-obsolete-display function r clip-rectangle)))
668 (declare (dynamic-extent #'mapper))
669 (map-over-output-records #'mapper record)))
670 (:method (function (record standard-updating-output-record) clip-rectangle)
671 (when (eq (output-record-dirty record) :updating)
672 (map-over-obsolete-display function (sub-record record) clip-rectangle)))
673 (:method (function record clip-rectangle)
674 (declare (ignore function record clip-rectangle))
675 nil)
676 (:method :around (function record (clip-rectangle bounding-rectangle))
677 (declare (ignore function))
678 (when (region-intersects-region-p record clip-rectangle)
679 (call-next-method))))
680
681 (defun find-existing-record (display-record root visible-region)
682 "Returns a display record that is output-record-equal to display-record
683 within visible-region and not under an updating-output record"
684 (map-over-child-display #'(lambda (r)
685 (when (output-record-equal display-record r)
686 (return-from find-existing-record r)))
687 root
688 visible-region)
689 nil)
690
691 (defun copy-bounding-rectange (rect)
692 (with-bounding-rectangle* (min-x min-y max-x max-y)
693 rect
694 (make-bounding-rectangle min-x min-y max-x max-y)))
695
696 ;;; work in progress
697 (defvar *existing-output-records* nil)
698
699 ;;;
700 (defgeneric output-record-hash (record)
701 (:documentation "Produce a value that can be used to hash the output record
702 in an equalp hash table"))
703
704 (defmethod output-record-hash ((record standard-bounding-rectangle))
705 (slot-value record 'coordinates))
706
707 (defconstant +fixnum-bits+ (integer-length most-positive-fixnum))
708
709 (declaim (inline hash-coords))
710 (defun hash-coords (x1 y1 x2 y2)
711 (declare (type coordinate x1 y1 x2 y2))
712 (let ((hash-val 0))
713 (declare (type fixnum hash-val))
714 (labels ((rot4 (val)
715 (dpb (ldb (byte 4 0) val)
716 (byte 4 (- +fixnum-bits+ 4 1))
717 (ash val -4)))
718 (mix-it-in (val)
719 (let ((xval (sxhash val)))
720 (declare (type fixnum xval))
721 (when (minusp val)
722 (setq xval (rot4 xval)))
723 (setq hash-val (logxor (rot4 hash-val) xval)))))
724 (declare (inline rot4 mix-it-in))
725 (mix-it-in x1)
726 (mix-it-in y1)
727 (mix-it-in x2)
728 (mix-it-in y2)
729 hash-val)))
730
731 (defmethod output-record-hash ((record output-record))
732 (with-bounding-rectangle* (x1 y1 x2 y2)
733 record
734 (hash-coords x1 y1 x2 y2)))
735
736 (defmethod compute-difference-set ((record standard-updating-output-record)
737 &optional (check-overlapping t)
738 offset-x offset-y
739 old-offset-x old-offset-y)
740 (declare (ignore offset-x offset-y old-offset-x old-offset-y))
741 ;; (declare (values erases moves draws erase-overlapping move-overlapping))
742 (let (was
743 is
744 stay
745 come
746 (everywhere (or +everywhere+
747 (pane-viewport-region (updating-output-stream record))))
748 (was-table (make-hash-table :test #'equalp))
749 (is-table (make-hash-table :test #'equalp)))
750
751 (labels ((collect-1-was (record)
752 (push record was)
753 (push record (gethash (output-record-hash record) was-table)))
754 (collect-1-is (record)
755 (push record is)
756 (push record (gethash (output-record-hash record) is-table))
757 ;; come = is \ was
758 ;; stay = is ^ was
759 (cond ((updating-output-record-p record)
760 (if (eq :clean (output-record-dirty record))
761 (push record stay)
762 (push record come)))
763 (t
764 (let ((q (gethash (output-record-hash record) was-table)))
765 (if (some #'(lambda (x) (output-record-equal record x)) q)
766 (push record stay)
767 (push record come)))))))
768 ;; Collect what was there
769 (labels ((gather-was (record)
770 (cond ((displayed-output-record-p record)
771 (collect-1-was record))
772 ((updating-output-record-p record)
773 (cond ((eq :clean (output-record-dirty record))
774 (collect-1-was record))
775 ((eq :moved (output-record-dirty record))
776 (collect-1-was (slot-value record 'old-bounds)))
777 (t
778 (map-over-output-records-overlapping-region #'gather-was
779 (old-children record)
780 everywhere))))
781 (t
782 (map-over-output-records-overlapping-region #'gather-was record everywhere)))))
783 (gather-was record))
784 ;; Collect what still is there
785 (labels ((gather-is (record)
786 (cond ((displayed-output-record-p record)
787 (collect-1-is record))
788 ((updating-output-record-p record)
789 (cond ((eq :clean (output-record-dirty record))
790 (collect-1-is record))
791 ((eq :moved (output-record-dirty record))
792 (collect-1-is record))
793 (t
794 (map-over-output-records-overlapping-region #'gather-is
795 (sub-record record)
796 everywhere))))
797 (t
798 (map-over-output-records-overlapping-region #'gather-is record everywhere) ))))
799 (gather-is record)))
800 ;;
801 (let (gone)
802 ;; gone = was \ is
803 (loop for w in was do
804 (cond ((updating-output-record-p w)
805 (unless (eq :clean (output-record-dirty w))
806 (push (old-children w) gone)))
807 (t
808 (let ((q (gethash (output-record-hash w) is-table)))
809 (unless (some #'(lambda (x) (output-record-equal w x)) q)
810 (push w gone))))))
811 ;; Now we essentially want 'gone', 'stay', 'come'
812 (let ((gone-overlap nil)
813 (come-overlap nil))
814 (when check-overlapping
815 (setf (values gone gone-overlap)
816 (loop for k in gone
817 if (some (lambda (x) (region-intersects-region-p k x))
818 stay)
819 collect (list k k) into gone-overlap*
820 else collect (list k k) into gone*
821 finally (return (values gone* gone-overlap*))))
822 (setf (values come come-overlap)
823 (loop for k in come
824 if (some (lambda (x) (region-intersects-region-p k x))
825 stay)
826 collect (list k k) into come-overlap*
827 else collect (list k k) into come*
828 finally (return (values come* come-overlap*)))))
829 ;; Hmm, we somehow miss come-overlap ...
830 (values
831 ;; erases
832 gone
833 ;; moves
834 nil
835 ;; draws
836 come
837 ;; erase overlapping
838 (append gone-overlap come-overlap)
839 ;; move overlapping
840 nil)))))
841
842 (defvar *trace-updating-output* nil)
843
844 (defvar *no-unique-id* (cons nil nil))
845
846 (defun move-output-record (record dx dy)
847 (multiple-value-bind (sx sy) (output-record-start-cursor-position record)
848 (multiple-value-bind (ex ey) (output-record-end-cursor-position record)
849 (setf (output-record-position record)
850 (values (+ (nth-value 0 (output-record-position record)) dx)
851 (+ (nth-value 1 (output-record-position record)) dy)))
852 (setf (output-record-start-cursor-position record)
853 (values (+ sx dx) (+ sy dy)))
854 (setf (output-record-end-cursor-position record)
855 (values (+ ex dx) (+ ey dy))))))
856
857 (defmethod invoke-updating-output ((stream updating-output-stream-mixin)
858 continuation
859 record-type
860 unique-id id-test cache-value cache-test
861 &key (fixed-position nil) (all-new nil)
862 (parent-cache nil))
863 (force-output stream)
864 (let ((parent-cache (or parent-cache *current-updating-output* stream)))
865 (when (eq unique-id *no-unique-id*)
866 (setq unique-id (incf (id-counter parent-cache))))
867 (let* ((record (get-from-map parent-cache unique-id id-test))
868 ;; For debugging
869 state-mismatch)
870 (cond ((or all-new (null record))
871 ;; This case covers the outermost updating-output too.
872 (with-new-output-record (stream
873 record-type
874 *current-updating-output*
875 :unique-id unique-id
876 :id-test id-test
877 :cache-value cache-value
878 :cache-test cache-test
879 :fixed-position fixed-position
880 :displayer continuation
881 :parent-cache parent-cache
882 :stream stream
883 :parent-updating-output
884 *current-updating-output*)
885 (setq record *current-updating-output*)
886 (when *trace-updating-output*
887 (format *trace-output* "Creating ~S~%" record))
888 (setf (start-graphics-state record)
889 (medium-graphics-state stream))
890 (%invoke-updating record stream continuation)
891 (setf (end-graphics-state record)
892 (medium-graphics-state stream))
893 (add-to-map parent-cache record unique-id id-test all-new)))
894 ((or (setq state-mismatch (not (state-matches-stream-p (start-graphics-state record) stream)))
895 (not (funcall cache-test cache-value (output-record-cache-value record))))
896 (when *trace-updating-output*
897 (format *trace-output* "~:[cache test~;stream state~] ~S~%" state-mismatch record))
898 (let ((*current-updating-output* record))
899 (setf (start-graphics-state record)
900 (medium-graphics-state stream))
901 (compute-new-output-records-1 record stream continuation)
902 (setf (slot-value record 'cache-value) cache-value)
903 (setf (end-graphics-state record)
904 (medium-graphics-state stream))
905 (setf (parent-cache record) parent-cache)))
906 (t
907 ;; It doesn't need to be updated, but it does go into the
908 ;; parent's sequence of records
909 ;;
910 (multiple-value-bind (cx cy) (stream-cursor-position stream)
911 (multiple-value-bind (sx sy) (output-record-start-cursor-position record)
912 (let ((dx (- cx sx))
913 (dy (- cy sy)))
914 (unless (zerop dy)
915 (move-output-record record dx dy) )
916 (let ((tag (cond
917 ((= dx dy 0)
918 (when *trace-updating-output*
919 (format *trace-output* "clean ~S~%" record))
920 :clean)
921 (t
922 (when *trace-updating-output*
923 (format *trace-output* "moved ~S~%" record))
924 :moved))))
925 (setf (output-record-dirty record) tag)
926 (setf (output-record-parent record) nil)
927 (map-over-updating-output #'(lambda (r)
928 (unless (eq r record)
929 (incf (slot-value (start-graphics-state r) 'cursor-x) dx)
930 (incf (slot-value (start-graphics-state r) 'cursor-y) dy)
931 (incf (slot-value (end-graphics-state r) 'cursor-x) dx)
932 (incf (slot-value (end-graphics-state r) 'cursor-y) dy))
933 (setf (output-record-dirty r) tag))
934 record
935 nil)
936 (add-output-record record (stream-current-output-record stream))
937 (set-medium-cursor-position (end-graphics-state record) stream)
938 (setf (parent-cache record) parent-cache) )) ))))
939 record)))
940
941 ;;; The Franz user guide says that updating-output does
942 ;;; &allow-other-keys, and some code I've encountered does mention
943 ;;; other magical arguments, so we'll do the same. -- moore
944 (defun force-update-cache-test (a b)
945 (declare (ignore a b))
946 nil)
947
948 (defmacro updating-output
949 ((stream
950 &key (unique-id '*no-unique-id*) (id-test '#'eql)
951 (cache-value ''no-cache-value cache-value-supplied-p)
952 (cache-test '#'eql)
953 (fixed-position nil fixed-position-p)
954 (all-new nil all-new-p)
955 (parent-cache nil parent-cache-p)
956 (record-type ''standard-updating-output-record)
957 &allow-other-keys)
958 &body body)
959 (when (eq stream t)
960 (setq stream '*standard-output*))
961 (unless cache-value-supplied-p
962 (setq cache-test '#'force-update-cache-test))
963 (let ((func (gensym "UPDATING-OUTPUT-CONTINUATION")))
964 `(flet ((,func (,stream)
965 (declare (ignorable ,stream))
966 ,@body))
967 (invoke-updating-output ,stream #',func ,record-type ,unique-id
968 ,id-test ,cache-value ,cache-test
969 ,@ (and fixed-position-p
970 `(:fixed-position ,fixed-position))
971 ,@(and all-new-p `(:all-new ,all-new))
972 ,@(and parent-cache-p
973 `(:parent-cache ,parent-cache))))))
974
975 (defun redisplay (record stream &key (check-overlapping t))
976 (redisplay-output-record record stream check-overlapping))
977
978 ;;; Take the spec at its word that the x/y and parent-x/parent-y arguments are
979 ;;; "entirely bogus."
980
981 (defvar *dump-updating-output* nil)
982
983 (defgeneric redisplay-output-record (record stream
984 &optional check-overlapping))
985
986 (defmethod redisplay-output-record ((record updating-output-record)
987 (stream updating-output-stream-mixin)
988 &optional (check-overlapping t))
989 (letf (((slot-value stream 'redisplaying-p) t))
990 (let ((*current-updating-output* record)
991 (current-graphics-state (medium-graphics-state stream)))
992 (unwind-protect
993 (progn
994 (letf (((do-note-output-record stream) nil))
995 (set-medium-cursor-position (start-graphics-state record) stream)
996 (compute-new-output-records record stream)
997 (when *dump-updating-output*
998 (dump-updating record :both *trace-output*)))
999 (multiple-value-bind
1000 (erases moves draws erase-overlapping move-overlapping)
1001 (compute-difference-set record check-overlapping)
1002 (when *trace-updating-output*
1003 (let ((*print-pretty* t))
1004 (format *trace-output*
1005 "erases: ~S~%moves: ~S~%draws: ~S~%erase ~
1006 overlapping: ~S~%move overlapping: ~S~%"
1007 erases moves draws
1008 erase-overlapping move-overlapping)))
1009 (incremental-redisplay stream nil erases moves draws
1010 erase-overlapping move-overlapping))
1011 (delete-stale-updating-output record))
1012 (set-medium-cursor-position current-graphics-state stream)))))
1013
1014 (defun erase-rectangle (stream bounding)
1015 (with-bounding-rectangle* (x1 y1 x2 y2)
1016 bounding
1017 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+)))
1018
1019 (defun clear-moved-record (stream new-bounding old-bounding)
1020 (with-bounding-rectangle* (x1 y1 x2 y2)
1021 new-bounding
1022 (draw-rectangle* stream x1 y1 x2 y2
1023 :ink +background-ink+))
1024 (with-bounding-rectangle* (x1 y1 x2 y2)
1025 old-bounding
1026 (draw-rectangle* stream x1 y1 x2 y2
1027 :ink +background-ink+)))
1028
1029 ;;; Suppress the got-sheet/lost-sheet notices during redisplay.
1030
1031 (defmethod note-output-record-lost-sheet :around
1032 (record (sheet updating-output-stream-mixin))
1033 (declare (ignore record))
1034 (when (do-note-output-record sheet)
1035 (call-next-method)))
1036
1037 (defmethod note-output-record-got-sheet :around
1038 (record (sheet updating-output-stream-mixin))
1039 (declare (ignore record))
1040 (when (do-note-output-record sheet)
1041 (call-next-method)))
1042
1043 (defun delete-stale-updating-output (record)
1044 (map-over-updating-output
1045 #'(lambda (r)
1046 (when (eq (output-record-dirty r) :updating)
1047 (delete-from-map (parent-cache r)
1048 (output-record-unique-id r)
1049 (output-record-id-test r))))
1050 record
1051 t))
1052
1053 (defun convert-from-relative-to-absolute-coordinates (stream record)
1054 (declare (ignore stream record))
1055 "This compatibility function returns offsets that are suitable for
1056 drawing records that are the children of `record'. In McCLIM this is
1057 a noop because output records are kept in stream coordinates."
1058 (values 0 0))
1059
1060
1061 ;;; Support for explicitly changing output records
1062
1063 (defun mark-updating-output-changed (record)
1064 (let ((state (output-record-dirty record)))
1065 (cond ((or (eq record *current-updating-output*)
1066 (eq state :updated)
1067 (eq state :updating))
1068 nil)
1069 ((eq state :clean)
1070 (setf (output-record-dirty record) :updated)
1071 (let ((parent (parent-updating-output record)))
1072 (if (null parent)
1073 (error "parent of ~S null" record)
1074 (mark-updating-output-changed parent))))
1075 (t nil))))
1076
1077 (defgeneric propagate-to-updating-output
1078 (record child mode old-bounding-rectangle)
1079 (:method
1080 ((record updating-output-record-mixin) child mode old-bounding-rectangle)
1081 (when (eq (output-record-dirty record) :clean)
1082 (case mode
1083 (:move
1084 (push (list child old-bounding-rectangle nil) (explicit-moves record))
1085 (mark-updating-output-changed record)))))
1086 (:method
1087 ((record output-record) child mode old-bounding-rectangle)
1088 (let ((parent (output-record-parent record)))
1089 (when parent
1090 (propagate-to-updating-output
1091 parent child mode old-bounding-rectangle)))))
1092
1093 (defgeneric note-output-record-child-changed
1094 (record child mode old-position old-bounding-rectangle stream
1095 &optional erases moves draws erase-overlapping move-overlapping
1096 &key check-overlapping))
1097
1098 ;;; The default - do nothing
1099
1100 (defmethod note-output-record-child-changed
1101 (record child mode old-position old-bounding-rectangle stream
1102 &optional erases moves draws erase-overlapping move-overlapping
1103 &key check-overlapping)
1104 (declare (ignore record child mode old-position old-bounding-rectangle stream
1105 erases moves draws erase-overlapping move-overlapping
1106 check-overlapping))
1107 nil)
1108
1109 (defmethod note-output-record-child-changed
1110 (record (child displayed-output-record) (mode (eql :move))
1111 old-position old-bounding-rectangle
1112 (stream updating-output-stream-mixin)
1113 &optional erases moves draws erase-overlapping move-overlapping
1114 &key (check-overlapping t))
1115 (declare (ignore old-position erases moves draws erase-overlapping
1116 move-overlapping
1117 check-overlapping))
1118 (when (stream-redisplaying-p stream)
1119 (propagate-to-updating-output record child mode old-bounding-rectangle)))
1120
1121 (defmethod* (setf output-record-position) :around
1122 (nx ny (record displayed-output-record))
1123 (with-bounding-rectangle* (x y max-x max-y)
1124 record
1125 (multiple-value-prog1
1126 (call-next-method)
1127 ;; coordinate= here instead?
1128 (unless (and (= x nx) (= y ny))
1129 (let ((stream (and (slot-exists-p record 'stream)
1130 (slot-value record 'stream)))
1131 (parent (output-record-parent record)))
1132 (when (and stream parent)
1133 (note-output-record-child-changed
1134 parent record :move
1135 (make-point x y) (make-bounding-rectangle x y max-x max-y)
1136 stream)))))))
1137
1138 ;;; Debugging hacks
1139 (defun dump-updating (record old-records &optional (stream *standard-output*))
1140 (let ((*print-circle* t)
1141 (*print-pretty* t))
1142 (fresh-line stream)
1143 (dump-updating-aux record old-records stream)))
1144
1145 (defgeneric dump-updating-aux (record old-records stream))
1146
1147 (defmethod dump-updating-aux ((record standard-updating-output-record)
1148 old-records
1149 stream)
1150 (pprint-logical-block (stream nil)
1151 (print-unreadable-object (record stream :type t)
1152 (let ((old-printed nil))
1153 (format stream "~S " (output-record-dirty record))
1154 (pprint-indent :block 2 stream)
1155 (pprint-newline :linear stream)
1156 (when (and (or (eq old-records :old)
1157 (eq old-records :both))
1158 (slot-boundp record 'old-children))
1159 (format stream ":old ~@_")
1160 (dump-updating-aux (old-children record) old-records stream)
1161 (setq old-printed t))
1162 (when (or (eq old-records :new)
1163 (eq old-records :both)
1164 (not old-records))
1165 (when old-printed
1166 (pprint-newline :linear stream))
1167 (format stream ":new ~@_")
1168 (dump-updating-aux (sub-record record) old-records stream))))))
1169
1170
1171 (defmethod dump-updating-aux ((record compound-output-record)
1172 old-records
1173 stream)
1174 (pprint-logical-block (stream nil)
1175 (print-unreadable-object (record stream :type t)
1176 (write-char #\Space stream)
1177 (pprint-newline :linear stream)
1178 (pprint-indent :block 2 stream)
1179 (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
1180 (loop with children = (output-record-children record)
1181 for i from 1 below (length children)
1182 for child across children
1183 do (progn
1184 (pprint-pop)
1185 (dump-updating-aux child old-records stream)
1186 (write-char #\Space stream)
1187 (pprint-newline :fill stream))
1188 finally (when (> (length children) 0)
1189 (pprint-pop)
1190 (dump-updating-aux (elt children (1- i))
1191 old-records
1192 stream)))))))
1193
1194 (defmethod dump-updating-aux (record old-records stream)
1195 (declare (ignore old-records))
1196 (write record :stream stream))
1197
1198 (defmethod redisplay-frame-pane
1199 ((frame application-frame) (pane updating-output-stream-mixin) &key force-p)
1200 (setf (id-counter pane) 0)
1201 (let ((incremental-redisplay (pane-incremental-redisplay pane)))
1202 (cond ((not incremental-redisplay)
1203 (call-next-method))
1204 ((or (null (updating-record pane))
1205 force-p)
1206 (setf (updating-record pane)
1207 (updating-output (pane :unique-id 'top-level)
1208 (call-next-method frame pane :force-p force-p))))
1209 ;; Implements the extension to the :incremental-redisplay
1210 ;; pane argument found in the Franz User Guide.
1211 (t (let ((record (updating-record pane)))
1212 (if (consp incremental-redisplay)
1213 (apply #'redisplay record pane incremental-redisplay)
1214 (redisplay record pane))) ))))

  ViewVC Help
Powered by ViewVC 1.1.5