/[mcclim]/mcclim/recording.lisp
ViewVC logotype

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Sat Jul 21 03:53:12 2001 UTC (12 years, 8 months ago) by adejneka
Branch: MAIN
Changes since 1.13: +38 -25 lines
* MAKE-MERGED-MEDIUM: Fixed clipping region setting

* DEF-GRECORDING: Fixed clipping region computation

* DRAW-...-OUTPUT-RECORD: Calculating bounding boxes, take into
  account transformation (partially done)
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.4 ;;; (c) copyright 2000 by
5     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6 rouanet 1.11 ;;; (c) copyright 2001 by
7     ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8     ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 mikemac 1.1
10     ;;; This library is free software; you can redistribute it and/or
11     ;;; modify it under the terms of the GNU Library General Public
12     ;;; License as published by the Free Software Foundation; either
13     ;;; version 2 of the License, or (at your option) any later version.
14     ;;;
15     ;;; This library is distributed in the hope that it will be useful,
16     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18     ;;; Library General Public License for more details.
19     ;;;
20     ;;; You should have received a copy of the GNU Library General Public
21     ;;; License along with this library; if not, write to the
22     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23     ;;; Boston, MA 02111-1307 USA.
24    
25     (in-package :CLIM-INTERNALS)
26    
27 rouanet 1.11 (defclass output-record-mixin ()
28 mikemac 1.1 ((x :initarg :x-position
29     :initform 0)
30     (y :initarg :y-position
31     :initform 0)
32     (parent :initarg :parent
33 rouanet 1.11 :initform nil
34     :reader output-record-parent)))
35    
36 rouanet 1.13 (defmethod initialize-instance :after ((record output-record-mixin) &rest args)
37     (declare (ignore args))
38 rouanet 1.11 (with-slots (x1 y1 x2 y2) record
39     (setq x1 0
40     y1 0
41     x2 0
42     y2 0)))
43    
44     (defclass output-record (standard-bounding-rectangle output-record-mixin)
45     ((children :initform nil
46     :reader output-record-children))
47 mikemac 1.1 (:default-initargs :min-x 0 :min-y 0 :max-x 0 :max-y 0))
48    
49     (defun output-record-p (x)
50     (typep x 'output-record))
51    
52 rouanet 1.11 (defclass displayed-output-record (standard-bounding-rectangle output-record-mixin)
53     ((ink :initarg :ink :reader displayed-output-record-ink)))
54 mikemac 1.1
55     (defun displayed-output-record-p (x)
56     (typep x 'displayed-output-record))
57    
58 rouanet 1.11 (defmethod initialize-instance :after ((record output-record) &rest args
59 mikemac 1.1 &key size
60     &allow-other-keys)
61     (declare (ignore args size)))
62    
63 rouanet 1.11 (defmethod output-record-position ((record output-record-mixin))
64 mikemac 1.1 (with-slots (x y) record
65     (values x y)))
66    
67 rouanet 1.11 (defmethod setf*-output-record-position (nx ny (record output-record-mixin))
68 mikemac 1.1 (with-slots (x y) record
69     (setq x nx
70     y ny)))
71    
72 rouanet 1.11 (defmethod setf*-output-record-position :before (nx ny (record output-record))
73     (multiple-value-bind (old-x old-y) (output-record-position record)
74     (loop with dx = (- nx old-x)
75     and dy = (- ny old-y)
76     for child in (output-record-children record)
77     do (multiple-value-bind (x y) (output-record-position child)
78     (setf*-output-record-position (+ x dx) (+ y dy) child)))))
79    
80     (defmethod setf*-output-record-position :around (nx ny (record output-record-mixin))
81     (declare (ignore nx ny))
82     (with-bounding-rectangle* (min-x min-y max-x max-y) record
83     (call-next-method)
84     (recompute-extent-for-changed-child (output-record-parent record) record
85     min-x min-y max-x max-y)))
86    
87 mikemac 1.1 (defmethod output-record-start-cursor-position ((record displayed-output-record))
88     (values nil nil))
89    
90     (defmethod setf*-output-record-start-cursor-position (x y (record displayed-output-record))
91     (declare (ignore x y))
92     nil)
93    
94     (defmethod output-record-end-cursor-position ((record displayed-output-record))
95     (values nil nil))
96    
97     (defmethod setf*-output-record-end-cursor-position (x y (record displayed-output-record))
98     (declare (ignore x y))
99     nil)
100    
101     (defun replay (record stream &optional region)
102 rouanet 1.11 (when (stream-drawing-p stream)
103     (let ((old-record-p (stream-recording-p stream)))
104     (unwind-protect
105     (progn
106     (setf (stream-recording-p stream) nil)
107     (replay-output-record record stream region))
108     (setf (stream-recording-p stream) old-record-p)))))
109 mikemac 1.1
110     (defmethod replay-output-record ((record output-record) stream
111     &optional region x-offset y-offset)
112 rouanet 1.11 (when (null region)
113     (setq region +everywhere+))
114     (map-over-output-records-overlaping-region
115     #'replay-output-record record region x-offset y-offset
116     stream region x-offset y-offset))
117 mikemac 1.1
118     (defmethod erase-output-record ((record output-record) stream)
119     (declare (ignore stream))
120     nil)
121    
122 rouanet 1.11 (defmethod output-record-hit-detection-rectangle* ((record output-record-mixin))
123 mikemac 1.1 (bounding-rectangle* record))
124    
125 rouanet 1.11 (defmethod output-record-refined-sensitivity-test ((record output-record-mixin) x y)
126 rouanet 1.13 (declare (ignore x y))
127     t)
128 mikemac 1.1
129 rouanet 1.11 (defmethod highlight-output-record ((record output-record-mixin) stream state)
130 mikemac 1.1 (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
131     (ecase state
132     (:highlight
133 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +foreground-ink+))
134 mikemac 1.1 (:unhighlight
135 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
136    
137     (defclass standard-sequence-output-record (output-record)
138     (
139     ))
140    
141     (defclass standard-tree-output-record (output-record)
142     (
143     ))
144    
145     (defmethod output-record-children ((output-record output-record))
146     (with-slots (children) output-record
147     (reverse children)))
148 mikemac 1.1
149     (defmethod add-output-record (child (record output-record))
150     (with-slots (children) record
151     (push child children))
152     (with-slots (parent) child
153     (setf parent record)))
154    
155 rouanet 1.11 (defmethod add-output-record :before (child (record output-record))
156     (when (null (output-record-children record))
157     (with-bounding-rectangle* (min-x min-y max-x max-y) child
158     (with-slots (x1 y1 x2 y2) record
159     (setq x1 min-x
160     y1 min-y
161     x2 max-x
162     y2 max-y)))))
163    
164     (defmethod add-output-record :after (child (record output-record))
165     (recompute-extent-for-new-child record child))
166    
167 mikemac 1.1 (defmethod delete-output-record (child (record output-record) &optional (errorp t))
168     (with-slots (children) record
169     (if (and errorp
170     (not (member child children)))
171     (error "~S is not a child of ~S" child record))
172     (setq children (delete child children))))
173    
174 rouanet 1.11 (defmethod delete-output-record :after (child (record output-record) &optional (errorp t))
175     (declare (ignore errorp))
176     (with-bounding-rectangle* (x1 y1 x2 y2) child
177     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
178    
179 mikemac 1.1 (defmethod clear-output-record ((record output-record))
180 cvs 1.3 (with-slots (children x1 y1 x2 y2) record
181 mikemac 1.1 (setq children nil
182 cvs 1.3 x1 0
183     y1 0
184     x2 0
185     y2 0)))
186 mikemac 1.1
187     (defmethod output-record-count ((record output-record))
188     (length (output-record-children record)))
189    
190     (defmethod map-over-output-records-containing-position (function (record output-record) x y
191 rouanet 1.11 &optional (x-offset 0) (y-offset 0)
192     &rest function-args)
193 mikemac 1.1 (declare (dynamic-extent function)
194     (ignore x-offset y-offset))
195     (loop for child in (output-record-children record)
196 rouanet 1.13 when (and (region-contains-position-p
197     (multiple-value-call #'make-bounding-rectangle
198     (output-record-hit-detection-rectangle* child))
199     x y)
200     (output-record-refined-sensitivity-test child x y))
201     do (apply function child function-args)))
202 mikemac 1.1
203     (defmethod map-over-output-records-overlaping-region (function (record output-record) region
204 rouanet 1.11 &optional (x-offset 0) (y-offset 0)
205     &rest function-args)
206 mikemac 1.1 (declare (dynamic-extent function)
207     (ignore x-offset y-offset))
208 rouanet 1.11 (loop for child in (output-record-children record)
209     do (when (region-intersects-region-p region child)
210     (apply function child function-args))))
211 mikemac 1.1
212     (defmethod recompute-extent-for-new-child ((record output-record) child)
213 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
214     (with-slots (parent x1 y1 x2 y2) record
215     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
216     (setq x1 (min x1 x1-child)
217     y1 (min y1 y1-child)
218     x2 (max x2 x2-child)
219     y2 (max y2 y2-child)))
220     (when parent
221     (recompute-extent-for-changed-child parent record old-x1 old-y1 old-x2 old-y2)))))
222 mikemac 1.1
223 rouanet 1.11 (defmethod recompute-extent-for-changed-child :around ((record output-record) child
224     old-min-x old-min-y old-max-x old-max-y)
225     (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
226     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
227     (bounding-rectangle* record))))
228     (call-next-method)
229     (with-slots (parent x1 y1 x2 y2) record
230     (when (and parent
231     (region-equal old-rectangle record))
232     (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
233    
234     (defmethod recompute-extent-for-changed-child ((record output-record) changed-child
235 mikemac 1.1 old-min-x old-min-y old-max-x old-max-y)
236 rouanet 1.11 (with-slots (children x1 y1 x2 y2) record
237     (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) changed-child
238     (setq x1 (min x1 new-x1)
239     y1 (min y1 new-y1)
240     x2 (max x2 new-x2)
241     y2 (max y2 new-y2)))
242     (if (null children)
243     (clear-output-record record)
244     (when (or (coordinate= x1 old-min-x)
245     (coordinate= y1 old-min-y)
246     (coordinate= x2 old-max-x)
247     (coordinate= y2 old-max-y))
248     (with-bounding-rectangle* (left top right bottom) (first children)
249     (loop for child in (rest children)
250     do (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
251     (setq left (min left x1-child)
252     top (min top y1-child)
253     right (max right x2-child)
254     bottom (max bottom y2-child))))
255     (setq x1 left
256     y1 top
257     x2 right
258     y2 bottom))))))
259 mikemac 1.1
260     (defmethod tree-recompute-extent ((record output-record))
261 cvs 1.3 (with-slots (parent children x1 y1 x2 y2) record
262 mikemac 1.1 (if (null children)
263 cvs 1.3 (setq x1 0
264     y1 0
265     x2 0
266     y2 0)
267 mikemac 1.1 (with-bounding-rectangle* (left top right bottom) (first children)
268     (loop for child in (rest children)
269     do (with-bounding-rectangle* (l1 t1 r1 b1) child
270     (setq left (min left l1 r1)
271     top (min top t1 b1)
272     right (max right l1 r1)
273     bottom (max bottom t1 b1))))
274 cvs 1.3 (setq x1 left
275     y1 top
276     x2 right
277     y2 bottom)))
278 mikemac 1.1 (if parent
279 cvs 1.3 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
280 mikemac 1.1
281    
282     ;;; Graphics recording classes
283    
284     (defclass graphics-displayed-output-record (displayed-output-record)
285 adejneka 1.14 ((clip :initarg :clipping-region
286     :documentation "Clipping region in user coordinates.")
287 mikemac 1.1 (transform :initarg :transformation)
288     (line-style :initarg :line-style)
289     (text-style :initarg :text-style)
290     ))
291    
292     (defun graphics-displayed-output-record-p (x)
293     (typep x 'graphics-displayed-output-record))
294    
295    
296     ;;; stream-output-history-mixin class
297    
298     (defclass stream-output-history-mixin ()
299 rouanet 1.11 ())
300    
301     (defclass standard-sequence-output-history (standard-sequence-output-record stream-output-history-mixin)
302     ())
303    
304     (defclass standard-tree-output-history (standard-tree-output-record stream-output-history-mixin)
305     ())
306    
307    
308     ;;; Output-Recording-Stream class
309    
310     (defclass output-recording-stream ()
311     ((recording-p :initform t :accessor stream-recording-p)
312     (drawing-p :initform t :accessor stream-drawing-p)
313     (output-history :initform (make-instance 'standard-tree-output-history)
314     :reader stream-output-history)
315     (current-output-record :accessor stream-current-output-record)))
316    
317     (defun output-recording-stream-p (x)
318     (typep x 'output-recording-stream))
319    
320     (defclass standard-output-recording-stream (output-recording-stream)
321     (
322 mikemac 1.1 ))
323    
324 rouanet 1.11 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
325     (declare (ignore args))
326     (setf (stream-current-output-record stream) (stream-output-history stream)))
327    
328     (defmethod stream-add-output-record ((stream output-recording-stream) record)
329     (add-output-record record (stream-output-history stream)))
330    
331     (defmethod stream-replay ((stream output-recording-stream) &optional region)
332     (replay (stream-output-history stream) stream region))
333    
334 cvs 1.10 (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)
335     (let ((old-record (gensym))
336     (old-draw (gensym)))
337     `(with-slots (recording-p drawing-p) ,stream
338     (let ((,old-record recording-p)
339     (,old-draw drawing-p))
340     (unwind-protect
341     (progn
342     (setq recording-p ,record
343     drawing-p ,draw)
344     ,@body)
345     (setq recording-p ,old-record
346     drawing-p ,old-draw))))))
347    
348 rouanet 1.11 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
349 mikemac 1.1 (declare (ignore dy))
350     (with-output-recording-options (stream :record nil)
351     (call-next-method)))
352    
353 rouanet 1.11 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
354 mikemac 1.1 (declare (ignore dx))
355     (with-output-recording-options (stream :record nil)
356     (call-next-method)))
357    
358 rouanet 1.11 (defmethod repaint-sheet ((stream output-recording-stream) region)
359     (stream-replay stream region))
360 cvs 1.7
361 rouanet 1.11 (defmethod handle-event ((stream output-recording-stream) (event window-repaint-event))
362 rouanet 1.12 (repaint-sheet stream (window-event-region event)))
363 cvs 1.7
364 rouanet 1.11 (defmethod handle-event ((stream output-recording-stream) (event pointer-button-press-event))
365 cvs 1.7 (with-slots (button x y) event
366     (format *debug-io* "button ~D pressed at ~D,~D~%" button x y)))
367    
368 rouanet 1.11 #|
369     (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
370     (highlight-output-record (stream-current-output-record stream) stream :highlight)
371     (highlight-output-record (stream-output-history stream) stream :highlight))
372    
373     (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
374     (highlight-output-record (stream-current-output-record stream) stream :unhighlight)
375     (highlight-output-record (stream-output-history stream) stream :unhighlight))
376     |#
377 mikemac 1.1
378    
379     ;;; graphics and text recording classes
380    
381     (eval-when (compile load eval)
382    
383     (defun compute-class-vars (names)
384     (cons (list 'stream :initarg :stream)
385     (loop for name in names
386 cvs 1.2 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
387 mikemac 1.1
388     (defun compute-arg-list (names)
389     (loop for name in names
390 cvs 1.2 nconcing (list (intern (symbol-name name) :keyword) name)))
391 mikemac 1.1 )
392    
393     (defun make-merged-medium (sheet ink clip transform line-style text-style)
394     (let ((medium (make-medium (port sheet) sheet)))
395     (setf (medium-ink medium) ink)
396 adejneka 1.14 ;; First set transformation, then clipping region!
397     (setf (medium-transformation medium) transform)
398 mikemac 1.1 (setf (medium-clipping-region medium) clip)
399     (setf (medium-line-style medium) line-style)
400     (setf (medium-text-style medium) text-style)
401     medium))
402    
403     (defmacro def-grecording (name (&rest args) &body body)
404     (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
405     (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
406     (old-medium (gensym))
407 rouanet 1.12 (new-medium (gensym))
408     (border (gensym)))
409 cvs 1.10 `(progn
410 mikemac 1.1 (defclass ,class-name (graphics-displayed-output-record)
411     ,(compute-class-vars args))
412     (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
413     (declare (ignore args))
414 cvs 1.3 (with-slots (x1 y1 x2 y2
415 adejneka 1.14 stream ink clipping-region transform
416 mikemac 1.1 line-style text-style
417     ,@args) graphic
418 rouanet 1.12 (let ((,border (1+ (/ (line-style-thickness line-style) 2))))
419     (multiple-value-bind (lf tp rt bt) (progn ,@body)
420     (setq x1 (- lf ,border)
421     y1 (- tp ,border)
422     x2 (+ rt ,border)
423     y2 (+ bt ,border))))))
424 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
425 mikemac 1.1 (with-sheet-medium (medium stream)
426 cvs 1.5 (when (stream-recording-p stream)
427     (let ((record (make-instance ',class-name
428     :stream stream
429     :ink (medium-ink medium)
430     :clipping-region (medium-clipping-region medium)
431     :transformation (medium-transformation medium)
432     :line-style (medium-line-style medium)
433     :text-style (medium-text-style medium)
434     ,@(compute-arg-list args))))
435 rouanet 1.11 (stream-add-output-record stream record)))
436 cvs 1.5 (when (stream-drawing-p stream)
437     (call-next-method))))
438 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
439 rouanet 1.11 &optional (region +everywhere+) x-offset y-offset)
440     (declare (ignore x-offset y-offset))
441 mikemac 1.1 (with-slots (ink clip transform line-style text-style ,@args) record
442     (let ((,old-medium (sheet-medium stream))
443 adejneka 1.14 (,new-medium (make-merged-medium stream ink (region-intersection clip
444     (untransform-region transform region))
445 rouanet 1.11 transform line-style text-style)))
446 adejneka 1.14 (finish-output *error-output*)
447 mikemac 1.1 (unwind-protect
448     (progn
449     (setf (sheet-medium stream) ,new-medium)
450     (setf (medium-sheet ,new-medium) stream)
451     (,method-name ,new-medium ,@args))
452     (setf (sheet-medium stream) ,old-medium))))))))
453    
454 rouanet 1.11 (def-grecording draw-point (point-x point-y)
455 adejneka 1.14 (with-transformed-position (transform point-x point-y)
456     (values point-x point-y point-x point-y)))
457 mikemac 1.1
458     (def-grecording draw-points (coord-seq)
459 adejneka 1.14 (with-transformed-positions (transform coord-seq)
460     (loop for (x y) on coord-seq by #'cddr
461     minimize x into min-x
462     minimize y into min-y
463     maximize x into max-x
464     maximize y into max-y
465     finally (return (values min-x min-y max-x max-y)))))
466 mikemac 1.1
467 rouanet 1.11 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
468 adejneka 1.14 (with-transformed-position (transform point-x1 point-y1)
469     (with-transformed-position (transform point-x2 point-y2)
470     (values (min point-x1 point-x2) (min point-y1 point-y2)
471     (max point-x1 point-x2) (max point-y1 point-y2)))))
472 mikemac 1.1
473     (def-grecording draw-lines (coord-seq)
474 adejneka 1.14 (with-transformed-positions (transform coord-seq)
475     (loop for (x y) on coord-seq by #'cddr
476     minimize x into min-x
477     minimize y into min-y
478     maximize x into max-x
479     maximize y into max-y
480     finally (return (values min-x min-y max-x max-y)))))
481 mikemac 1.1
482     (def-grecording draw-polygon (coord-seq closed filled)
483 adejneka 1.14 (with-transformed-positions (transform coord-seq)
484     (loop for (x y) on coord-seq by #'cddr
485     minimize x into min-x
486     minimize y into min-y
487     maximize x into max-x
488     maximize y into max-y
489     finally (return (values min-x min-y max-x max-y)))))
490 mikemac 1.1
491     (def-grecording draw-rectangle (left top right bottom filled)
492 adejneka 1.14 ;; XXX transformation!!!
493 mikemac 1.1 (values (min left right) (min top bottom) (max left right) (max top bottom)))
494    
495     (def-grecording draw-ellipse (center-x center-y
496     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
497     start-angle end-angle filled)
498 adejneka 1.14 ;; XXX transformation!!!
499 rouanet 1.11 (let ((radius-dx (abs (+ radius-1-dx radius-2-dx)))
500     (radius-dy (abs (+ radius-1-dy radius-2-dy))))
501     (values (- center-x radius-dx) (- center-y radius-dy)
502     (+ center-x radius-dx) (+ center-y radius-dy))))
503    
504     (def-grecording draw-text (string point-x point-y start end
505     align-x align-y toward-x toward-y transform-glyphs)
506 adejneka 1.14 ;; XXX transformation!!!
507 rouanet 1.11 (let* ((width (stream-string-width stream string
508     :start start :end end
509     :text-style text-style))
510     (ascent (text-style-ascent text-style (port (sheet-medium stream))))
511     (descent (text-style-descent text-style (port (sheet-medium stream))))
512     (height (+ ascent descent))
513     left top right bottom)
514     (ecase align-x
515     (:left (setq left point-x
516     right (+ point-x width)))
517     (:right (setq left (- point-x width)
518     right point-x))
519     (:center (setq left (- point-x (round width 2))
520     right (+ point-x (round width 2)))))
521     (ecase align-y
522     (:baseline (setq top (- point-y height)
523     bottom (+ point-y descent)))
524     (:top (setq top point-y
525     bottom (+ point-y height)))
526     (:bottom (setq top (- point-y height)
527     bottom point-y))
528     (:center (setq top (- point-y (floor height 2))
529     bottom (+ point-y (ceiling height 2)))))
530     (values left top right bottom)))
531 mikemac 1.1
532    
533     ;;; Text recording class
534    
535     (defclass text-displayed-output-record (displayed-output-record)
536     ((strings :initform nil)
537     (baseline :initform 0)
538     (max-height :initform 0)
539 cvs 1.6 (start-x :initarg :start-x)
540     (start-y :initarg :start-y)
541 mikemac 1.1 (end-x)
542 cvs 1.8 (end-y)
543     (wrapped :initform nil
544     :accessor text-record-wrapped)))
545 mikemac 1.1
546     (defun text-displayed-output-record-p (x)
547     (typep x 'text-displayed-output-record))
548    
549 cvs 1.8 (defmethod print-object ((self text-displayed-output-record) stream)
550     (print-unreadable-object (self stream :type t :identity t)
551     (if (slot-boundp self 'start-x)
552     (with-slots (start-x start-y strings) self
553     (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
554     (format stream "empty"))))
555 mikemac 1.1
556 cvs 1.9 (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
557     (with-slots (parent start-x start-y end-x end-y x1 y1 x2 y2) text-record
558     (setq x1 start-x
559     x2 end-x
560     y1 start-y
561     y2 end-y)
562     (recompute-extent-for-changed-child parent text-record start-x start-y end-x end-y)))
563    
564 mikemac 1.1 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
565     character text-style width height
566     new-baseline)
567 cvs 1.9 (with-slots (strings baseline max-height start-y end-x end-y) text-record
568 cvs 1.7 (if (and strings (eq (second (first (last strings))) text-style))
569     (vector-push-extend character (third (first (last strings))))
570     (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
571     (setq baseline (max baseline new-baseline)
572 mikemac 1.1 end-x (+ end-x width)
573     max-height (max max-height height)
574 cvs 1.9 end-y (max end-y (+ start-y max-height))
575 cvs 1.6 )
576 cvs 1.9 )
577     (tree-recompute-extent text-record))
578 mikemac 1.1
579     (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)
580     string start end text-style width height
581     new-baseline)
582 cvs 1.7 (setq string (subseq string start end))
583 mikemac 1.1 (with-slots (strings baseline max-height end-x) text-record
584 cvs 1.7 (setq baseline (max baseline new-baseline)
585     strings (nconc strings (list (list end-x text-style (make-array (length string) :initial-contents string :element-type 'character :adjustable t :fill-pointer t))))
586 mikemac 1.1 end-x (+ end-x width)
587     max-height (max max-height height)
588     )))
589    
590     (defmethod replay-output-record ((record text-displayed-output-record) stream
591     &optional region x-offset y-offset)
592     (declare (ignore x-offset y-offset))
593 cvs 1.8 (with-slots (strings baseline max-height start-x start-y wrapped) record
594 cvs 1.7 (let ((old-medium (sheet-medium stream))
595     (new-medium (make-medium (port stream) stream)))
596     (unwind-protect
597     (progn
598     (setf (sheet-medium stream) new-medium)
599     (setf (medium-sheet new-medium) stream)
600     (loop for y = (+ start-y baseline)
601     for (x text-style string) in strings
602     do (setf (medium-text-style new-medium) text-style)
603 rouanet 1.11 (draw-text* (sheet-medium stream) string x y
604 cvs 1.8 :text-style text-style :clipping-region region))
605     (if wrapped
606     (draw-rectangle* (sheet-medium stream)
607     (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
608     :ink +foreground-ink+
609     :filled t)))
610 cvs 1.7 (setf (sheet-medium stream) old-medium)))))
611 mikemac 1.1
612     (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
613     (with-slots (start-x start-y) record
614     (values start-x start-y)))
615    
616     (defmethod output-record-end-cursor-position ((record text-displayed-output-record))
617     (with-slots (end-x end-y) record
618     (values end-x end-y)))
619    
620     (defmethod text-displayed-output-record-string ((record text-displayed-output-record))
621     (with-slots (strings) record
622     (loop for result = ""
623     for s in strings
624     do (setq result (concatenate 'string result (third s)))
625     finally (return result))))
626 cvs 1.5
627    
628    
629     (defmethod get-text-record ((stream output-recording-stream))
630     (let ((trec (stream-current-output-record stream)))
631     (unless (text-displayed-output-record-p trec)
632     (setq trec (make-instance 'text-displayed-output-record))
633 cvs 1.6 (add-output-record trec (stream-output-history stream))
634 cvs 1.8 (setf (stream-current-output-record stream) trec)
635 cvs 1.9 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
636 cvs 1.8 (multiple-value-bind (cx cy) (stream-cursor-position stream)
637     (setq start-x cx
638     start-y (+ cy (stream-vertical-spacing stream))
639     end-x start-x
640 cvs 1.9 end-y start-y
641     x1 start-x
642     x2 end-x
643     y1 start-y
644     y2 end-y))))
645 cvs 1.5 trec))
646    
647     (defmethod stream-write-char :around ((stream output-recording-stream) char)
648     (when (stream-recording-p stream)
649 cvs 1.8 (get-text-record stream))
650     (call-next-method)
651     (when (stream-recording-p stream)
652 cvs 1.6 (cond
653 cvs 1.8 ((not (or (eql char #\return)
654     (eql char #\newline)))
655     (let* ((medium (sheet-medium stream))
656     (text-style (medium-text-style medium))
657     (trec (get-text-record stream))
658     (port (port stream)))
659     (add-character-output-to-text-record
660     trec char text-style
661     (stream-character-width stream char :text-style text-style)
662     (text-style-height text-style port)
663     (text-style-ascent text-style port))))
664     (t
665 cvs 1.6 (let ((trec (make-instance 'text-displayed-output-record)))
666     (add-output-record trec (stream-output-history stream))
667 cvs 1.8 (setf (stream-current-output-record stream) trec)
668 cvs 1.9 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
669 cvs 1.8 (multiple-value-bind (cx cy) (stream-cursor-position stream)
670     (setq start-x cx
671     start-y (+ cy (stream-vertical-spacing stream))
672     end-x start-x
673 cvs 1.9 end-y start-y
674     x1 start-x
675     x2 end-x
676     y1 start-y
677     y2 end-y))))))))
678 cvs 1.5
679 cvs 1.8 (defmethod stream-wrap-line :before ((stream output-recording-stream))
680 cvs 1.5 (when (stream-recording-p stream)
681 cvs 1.10 (setf (text-record-wrapped (get-text-record stream)) (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5