/[mcclim]/mcclim/stream-output.lisp
ViewVC logotype

Contents of /mcclim/stream-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65 - (show annotations)
Sat Aug 1 05:22:51 2009 UTC (4 years, 8 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.64: +2 -2 lines
Removed some tabs at the request of Cyrus Harmon.

There are lots of tabs in McCLIM source code, so I don't think it is
practical to remove them all right away.  Perhaps take the advantage
when there are other modifications as well.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6
7 ;;; This library is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the GNU Library General Public
9 ;;; License as published by the Free Software Foundation; either
10 ;;; version 2 of the License, or (at your option) any later version.
11 ;;;
12 ;;; This library is distributed in the hope that it will be useful,
13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;; Library General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU Library General Public
18 ;;; License along with this library; if not, write to the
19 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 ;;; Boston, MA 02111-1307 USA.
21
22 (in-package :clim-internals)
23
24 ;;; Note: in the methods defined on output streams, I often use
25 ;;; the sheet's medium as the argument to the draw-* routines.
26 ;;; This is so that they don't get recorded if the stream also
27 ;;; happens to be an output-recording-stream. - MikeMac 1/7/99
28
29 ;;; Standard-Output-Stream class
30
31 (defclass standard-output-stream (fundamental-character-output-stream)
32 ())
33
34 (defmethod stream-recording-p ((stream t)) nil)
35 (defmethod stream-drawing-p ((stream t)) t)
36
37 #+ignore(defmethod stream-write-char ((stream standard-output-stream) char)
38 (multiple-value-bind (cx cy) (stream-cursor-position stream)
39 (cond
40 ((eq char #\Newline)
41 (setf (stream-cursor-position stream)
42 (value 0
43 (+ cy
44 (stream-line-height stream)
45 (stream-vertical-spacing stream)))))
46 (t
47 (draw-text* (sheet-medium stream) char cx (+ cy (stream-baseline stream)))
48 (setf (stream-cursor-position stream)
49 (values (+ cx (stream-character-width stream char)) cy))))))
50
51
52 ;;; Cursor class
53
54 (defgeneric* (setf cursor-position) (x y cursor))
55
56 ;;; Cursor-Mixin class
57 (defclass cursor-mixin ()
58 ((sheet :initarg :sheet
59 :reader cursor-sheet)
60 (x :initform 0 :initarg :x-position)
61 (y :initform 0 :initarg :y-position)
62 (width :initform 8)
63 (appearance :type (member :solid :hollow)
64 :initarg :appearance :initform :hollow
65 :accessor cursor-appearance)
66 ;; XXX what does "cursor is active" mean?
67 ;; It means that the sheet (stream) updates the cursor, though
68 ;; currently the cursor appears to be always updated after stream
69 ;; text operations. -- moore
70 (cursor-active :initform nil
71 :accessor cursor-active)
72 (cursor-state :initform nil
73 :accessor cursor-state)))
74
75 (defgeneric cursor-height (cursor))
76
77 (defmethod print-object ((cursor cursor-mixin) stream)
78 (with-slots (x y) cursor
79 (print-unreadable-object (cursor stream :type t :identity t)
80 (format stream "~D ~D " x y))))
81
82 ;;; XXX What to do when we can't draw the cursor immediately (like,
83 ;;; we're not drawing?) The whole flip-screen-cursor idea breaks down.
84
85 (defmethod (setf cursor-state) :around (state (cursor cursor-mixin))
86 (unless (eq state (slot-value cursor 'cursor-state))
87 (flip-screen-cursor cursor))
88 (call-next-method))
89
90 (defun decode-cursor-visibility (visibility)
91 "Given :on, :off, or nil, returns the needed active and state attributes for the cursor."
92 (ecase visibility
93 ((:on t) (values t t))
94 (:off (values t nil))
95 ((nil) (values nil nil))))
96
97 (defmethod cursor-visibility ((cursor cursor-mixin))
98 (let ((a (cursor-active cursor))
99 (s (cursor-state cursor)))
100 (cond ((and a s) :on)
101 ((and a (not s)) :off)
102 (t nil))))
103
104 (defmethod (setf cursor-visibility) (nv (cursor cursor-mixin))
105 (multiple-value-bind (active state)
106 (decode-cursor-visibility nv)
107 (setf (cursor-state cursor) state
108 (cursor-active cursor) active)))
109
110 (defmethod cursor-position ((cursor cursor-mixin))
111 (with-slots (x y) cursor
112 (values x y)))
113
114 (defmethod* (setf cursor-position) (nx ny (cursor cursor-mixin))
115 (with-slots (x y) cursor
116 (letf (((cursor-state cursor) nil))
117 (multiple-value-prog1
118 (setf (values x y) (values nx ny))))
119 (when (and (cursor-active cursor)
120 (output-recording-stream-p (cursor-sheet cursor)))
121 (stream-close-text-output-record (cursor-sheet cursor)))))
122
123 (defmethod flip-screen-cursor ((cursor cursor-mixin))
124 (when (stream-drawing-p (cursor-sheet cursor))
125 (with-slots (x y sheet width) cursor
126 (let ((height (cursor-height cursor)))
127 (draw-rectangle* (sheet-medium (cursor-sheet cursor))
128 x y
129 (+ x width) (+ y height)
130 :filled (ecase (cursor-appearance cursor)
131 (:solid t) (:hollow nil))
132 :ink +flipping-ink+)))))
133
134 (defmethod display-cursor ((cursor cursor-mixin) state)
135 (unless (stream-drawing-p (cursor-sheet cursor))
136 (return-from display-cursor nil))
137 (with-slots (x y sheet width) cursor
138 (let ((height (cursor-height cursor)))
139 (case state
140 (:draw (draw-rectangle* (sheet-medium (cursor-sheet cursor))
141 x y
142 (+ x width) (+ y height)
143 :filled (ecase (cursor-appearance cursor)
144 (:solid t) (:hollow nil))
145 :ink +foreground-ink+
146 ))
147 (:erase
148 ;; This is how I'd like this to work, as painting over with the background
149 ;; ink is repugnant. I leave this disabled because I'm concerned about
150 ;; infinite recursion if replay-output-record calls here (which Goatee
151 ;; does currently). --Hefner
152 #+nil (repaint-sheet (cursor-sheet cursor)
153 (make-bounding-rectangle x y (+ 1 x width)
154 (+ 1 y height)))
155 (draw-rectangle* (sheet-medium (cursor-sheet cursor))
156 x y
157 (+ x width) (+ y height)
158 :filled (ecase (cursor-appearance cursor)
159 (:solid t) (:hollow nil))
160 :ink +background-ink+))))))
161
162 ;;; Standard-Text-Cursor class
163
164 (defclass standard-text-cursor (cursor-mixin cursor)
165 ())
166
167 (defmethod cursor-height ((cursor standard-text-cursor))
168 (slot-value (cursor-sheet cursor) 'height))
169
170
171 ;;; Extended-Output-Stream class
172
173 (defgeneric* (setf stream-cursor-position) (x y stream))
174
175 ;;; Standard-Extended-Output-Stream class
176
177 (defclass standard-extended-output-stream (extended-output-stream
178 standard-output-stream)
179 ((cursor :accessor stream-text-cursor)
180 (foreground :initarg :foreground :reader stream-foreground)
181 (background :initarg :background :reader stream-background)
182 (text-style :initarg :text-style :reader stream-text-style)
183 (vspace :initarg :vertical-spacing :reader stream-vertical-spacing)
184 (margin :initarg :text-margin :writer (setf stream-text-margin))
185 (eol :initarg :end-of-line-action :accessor stream-end-of-line-action)
186 (eop :initarg :end-of-page-action :accessor stream-end-of-page-action)
187 (view :initarg :default-view :accessor stream-default-view)
188 (baseline :initform 0 :reader stream-baseline)
189 ;; What is this? --GB
190 (height :initform 0)
191 ;; When the stream takes part in the space alloction protocol, this
192 ;; remembers our demand:
193 (seos-current-width :initform 0)
194 (seos-current-height :initform 0))
195 (:default-initargs
196 :foreground +black+ :background +white+ :text-style *default-text-style*
197 :vertical-spacing 2 :text-margin nil :end-of-line-action :wrap
198 :end-of-page-action :scroll :default-view +textual-view+))
199
200 (defmethod stream-force-output :after ((stream
201 standard-extended-output-stream))
202 (with-sheet-medium (medium stream)
203 (medium-force-output medium)))
204
205 (defmethod stream-finish-output :after ((stream
206 standard-extended-output-stream))
207 (with-sheet-medium (medium stream)
208 (medium-finish-output medium)))
209
210 (defmethod compose-space ((pane standard-extended-output-stream) &key width height)
211 (declare (ignorable width height))
212
213 (with-slots (seos-current-width seos-current-height) pane
214 (make-space-requirement :width seos-current-width
215 :height seos-current-height)))
216
217 (defmethod initialize-instance :after
218 ((stream standard-extended-output-stream) &rest args)
219 (declare (ignore args))
220 (setf (stream-text-cursor stream)
221 (make-instance 'standard-text-cursor :sheet stream))
222 (setf (cursor-active (stream-text-cursor stream)) t))
223
224
225 (defmethod stream-cursor-position ((stream standard-extended-output-stream))
226 (cursor-position (stream-text-cursor stream)))
227
228 (defmethod* (setf stream-cursor-position) (x y (stream standard-extended-output-stream))
229 (setf (cursor-position (stream-text-cursor stream)) (values x y)))
230
231 (defmethod stream-set-cursor-position ((stream standard-extended-output-stream) x y)
232 (setf (stream-cursor-position stream) (values x y)))
233
234 (defmethod stream-increment-cursor-position ((stream standard-extended-output-stream) dx dy)
235 (multiple-value-bind (x y) (cursor-position (stream-text-cursor stream))
236 (let ((dx (or dx 0))
237 (dy (or dy 0)))
238 (setf (cursor-position (stream-text-cursor stream)) (values (+ x dx) (+ y dy))))))
239
240
241
242 ;;;
243
244 (defmethod handle-repaint :around ((stream standard-extended-output-stream)
245 region)
246 (declare (ignorable region))
247 (let ((cursor (stream-text-cursor stream)))
248 (if (cursor-state cursor)
249 ;; Erase the cursor so that the subsequent flip operation will make a
250 ;; cursor, whether or not the next-method erases the location of the
251 ;; cursor.
252 ;; XXX clip to region? No one else seems to...
253 ;; Sure clip to region! --GB
254 (letf (((cursor-state cursor) nil))
255 (call-next-method))
256 (call-next-method))))
257
258 (defmethod scroll-vertical ((stream standard-extended-output-stream) dy)
259 (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
260 (scroll-extent stream tx (+ ty dy))))
261
262 (defmethod scroll-horizontal ((stream standard-extended-output-stream) dx)
263 (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
264 (scroll-extent stream (+ tx dx) ty)))
265
266 (defmacro with-cursor-off (stream &body body)
267 `(letf (((cursor-visibility (stream-text-cursor ,stream)) nil))
268 ,@body))
269
270 (defmethod stream-wrap-line ((stream standard-extended-output-stream))
271 (let ((margin (stream-text-margin stream)))
272 (multiple-value-bind (cx cy) (stream-cursor-position stream)
273 (declare (ignore cx))
274 (draw-rectangle* (sheet-medium stream) margin cy (+ margin 4) (+ cy (slot-value stream 'height))
275 :ink +foreground-ink+
276 :filled t)))
277 (stream-write-char stream #\newline))
278
279
280
281 (defun seos-write-string (stream string &optional (start 0) end)
282 (let* ((medium (sheet-medium stream))
283 (text-style (medium-text-style medium))
284 (new-baseline (text-style-ascent text-style medium))
285 (new-height (text-style-height text-style medium))
286 (margin (stream-text-margin stream))
287 (end (or end (length string))))
288 (flet ((find-split (delta) ;; FIXME: This can be done smarter.
289 (loop for i from (1+ start) upto end
290 as sub-width = (stream-string-width stream string
291 :start start :end i
292 :text-style text-style)
293 while (<= sub-width delta)
294 finally (return (1- i)))))
295 (when (eql end 0)
296 (return-from seos-write-string))
297
298 (with-slots (baseline height vspace) stream
299 (multiple-value-bind (cx cy) (stream-cursor-position stream)
300 (when (> new-baseline baseline)
301 ;;(when (or (> baseline 0)
302 ;; (> height 0))
303 ;; (scroll-vertical stream (- new-baseline baseline))
304 ;; ) ; the beginning of the line should be moved down, but not the whole stream -- APD, 2002-06-18
305 (setq baseline new-baseline))
306 (if (> new-height height)
307 (setq height new-height))
308 (let ((width (stream-string-width stream string
309 :start start :end end
310 :text-style text-style))
311 (split end))
312 (when (>= (+ cx width) margin)
313 (ecase (stream-end-of-line-action stream)
314 (:wrap
315 ;; Let's prevent infinite recursion if there isn't
316 ;; room for even a single character.
317 (setq split (max (find-split (- margin cx))
318 (1+ start))))
319 (:scroll
320 (scroll-horizontal stream width))
321 (:allow)))
322 (unless (= start split)
323 (stream-write-output stream
324 string
325 nil
326 start split)
327 (setq cx (+ cx width))
328 (with-slots (x y) (stream-text-cursor stream)
329 (setf x cx y cy)))
330 (when (/= split end)
331 (let ((current-baseline baseline))
332 (setf baseline current-baseline))
333 ; (stream-wrap-line stream)
334 ; (multiple-value-bind (new-cx new-cy) (stream-cursor-position stream)
335 ; (setf cx new-cx
336 ; cy new-cy
337 ; baseline current-baseline)
338 ; (setf (stream-cursor-position stream) (values cx cy))))
339 (stream-wrap-line stream)
340 (seos-write-string stream string split end))
341 ))))))
342
343 (defun seos-write-newline (stream)
344 (let ((medium (sheet-medium stream))
345 (%view-height (bounding-rectangle-height
346 (or (pane-viewport stream)
347 stream)))
348 (view-height (bounding-rectangle-height stream)))
349 (with-slots (baseline height vspace) stream
350 (multiple-value-bind (cx cy) (stream-cursor-position stream)
351 (setf height (max height (text-style-height (medium-text-style medium) medium)))
352 (setf cx 0
353 cy (+ cy height vspace))
354 (when (> (+ cy height) view-height)
355 (ecase (stream-end-of-page-action stream)
356 ((:scroll :allow)
357 (change-space-requirements stream
358 :width (bounding-rectangle-width stream)
359 :height (+ cy height))
360 ;;(scroll-vertical stream (+ height vspace))
361 )
362 (:wrap
363 (setq cy 0))))
364 (unless (eq :allow (stream-end-of-page-action stream))
365 (scroll-extent stream 0 (max 0 (- (+ cy height) %view-height))))
366
367 ;; mikemac says that this "erase the new line" behavior is
368 ;; required by the stream text protocol, but I don't see
369 ;; it. I'm happy to put this back in again, but in the
370 ;; meantime it makes debugging of updating-output a bit easier
371 ;; not to have "extra" records laying around. If/When it goes
372 ;; back in... the draw-rectangle has to happen on the stream,
373 ;; not the medium. -- moore
374 #+nil(draw-rectangle* medium cx cy (+ margin 4) (+ cy height)
375 :ink +background-ink+
376 :filled t)
377 (setq baseline 0
378 height 0)
379 (setf (stream-cursor-position stream) (values cx cy))))))
380
381
382
383
384 (defgeneric stream-write-output (stream line string-width &optional start end)
385 (:documentation
386 "Writes the character or string LINE to STREAM. This function produces no
387 more than one line of output i.e., doesn't wrap. If STRING-WIDTH is
388 non-nil, that is used as the width where needed; otherwise
389 STREAM-STRING-WIDTH will be called."))
390
391 ;;; The cursor is in stream coordinates.
392 (defmethod stream-write-output (stream line string-width
393 &optional (start 0) end)
394 (declare (ignore string-width))
395 (with-slots (baseline vspace) stream
396 (multiple-value-bind (cx cy) (stream-cursor-position stream)
397 (draw-text* (sheet-medium stream) line
398 cx (+ cy baseline)
399 :transformation +identity-transformation+
400 :start start :end end))))
401
402 (defmethod stream-write-char ((stream standard-extended-output-stream) char)
403 (with-cursor-off stream
404 (if (char= #\Newline char)
405 (seos-write-newline stream)
406 (seos-write-string stream (string char)))))
407
408 ;;; I added the (subseq string seg-start ...) forms. Under ACL, there is some
409 ;;; wierd interaction with FORMAT. This shows up as overwritten text in the
410 ;;; pointer documentation and in menus. It acts like a shared buffer is being corrupted
411 ;;; but I can't narrow it down. Using SUBSEQ does fix this interaction that's been
412 ;;; here since 4/16/03 - Mikemac 12/6/2003
413 (defmethod stream-write-string ((stream standard-extended-output-stream) string
414 &optional (start 0) end)
415 (let ((seg-start start)
416 (end (or end (length string))))
417 (with-cursor-off stream
418 (loop for i from start below end do
419 (when (char= #\Newline
420 (char string i))
421 (seos-write-string stream (subseq string seg-start i))
422 (seos-write-newline stream)
423 (setq seg-start (1+ i))))
424 (seos-write-string stream (subseq string seg-start end)))))
425
426 ;(defmethod stream-write-string ((stream standard-extended-output-stream) string
427 ; &optional (start 0) end)
428 ; (if (null end)
429 ; (setq end (length string)))
430 ; (with-room-for-line
431 ; (loop for i from start below end
432 ; for char = (aref string i)
433 ; do (do-char))))
434
435 (defmethod stream-character-width ((stream standard-extended-output-stream) char &key (text-style nil))
436 (with-sheet-medium (medium stream)
437 (text-style-character-width (or text-style (medium-text-style medium))
438 medium
439 char)))
440
441 (defmethod stream-string-width ((stream standard-extended-output-stream) string
442 &key (start 0) (end nil) (text-style nil))
443 (with-sheet-medium (medium stream)
444 (if (null text-style)
445 (setq text-style (medium-text-style (sheet-medium stream))))
446 (multiple-value-bind (total-width total-height final-x final-y baseline)
447 (text-size medium string :text-style text-style
448 :start start :end end)
449 (declare (ignore total-height final-y baseline))
450 (values final-x total-width))))
451
452 (defmethod stream-text-margin ((stream standard-extended-output-stream))
453 (with-slots (margin) stream
454 (or margin
455 (- (bounding-rectangle-width (or (pane-viewport stream)
456 stream))
457 (text-size stream "O")))))
458
459 (defmethod stream-line-height ((stream standard-extended-output-stream)
460 &key (text-style nil))
461 (+ (text-style-height (or text-style (medium-text-style (sheet-medium stream)))
462 (sheet-medium stream))
463 (stream-vertical-spacing stream)))
464
465 (defmethod stream-line-column ((stream standard-extended-output-stream))
466 (multiple-value-bind (x y) (stream-cursor-position stream)
467 (declare (ignore y))
468 (floor x (stream-string-width stream " "))))
469
470 (defmethod stream-start-line-p ((stream standard-extended-output-stream))
471 (multiple-value-bind (x y) (stream-cursor-position stream)
472 (declare (ignore y))
473 (zerop x)))
474
475 (defmacro with-room-for-graphics ((&optional (stream t)
476 &rest arguments
477 &key (first-quadrant t)
478 height
479 (move-cursor t)
480 (record-type ''standard-sequence-output-record))
481 &body body)
482 (declare (ignore first-quadrant height move-cursor record-type))
483 (let ((cont (gensym "CONT."))
484 (stream (stream-designator-symbol stream '*standard-output*)))
485 `(labels ((,cont (,stream)
486 ,@body))
487 (declare (dynamic-extent #',cont))
488 (invoke-with-room-for-graphics #',cont ,stream ,@arguments))))
489
490 (defmacro with-end-of-line-action ((stream action) &body body)
491 (when (eq stream t)
492 (setq stream '*standard-output*))
493 (check-type stream symbol)
494 `(letf (((stream-end-of-line-action ,stream) ,action))
495 ,@body))
496
497 (defmacro with-end-of-page-action ((stream action) &body body)
498 (when (eq stream t)
499 (setq stream '*standard-output*))
500 (check-type stream symbol)
501 `(letf (((stream-end-of-page-action ,stream) ,action))
502 ,@body))
503
504 (defmethod beep (&optional medium)
505 (if medium
506 (medium-beep medium)
507 (when (sheetp *standard-output*)
508 (medium-beep (sheet-medium *standard-output*)))))
509
510 (defmethod scroll-quantum ((sheet standard-extended-output-stream))
511 (stream-line-height sheet))

  ViewVC Help
Powered by ViewVC 1.1.5