Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 512 lines (437 sloc) 20.318 kB
3cb03ba Initial check-in
Mike McDonald authored
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
705babf updated copyright dates for me
Mike McDonald authored
3 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
24f916e * LETFifyed
Alexey Dejneka authored
4 ;;; (c) copyright 2000 by
c462d4a Added copyright notice to reflect modifications.
CVS pserver daemon authored
5 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
3cb03ba Initial check-in
Mike McDonald authored
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
24f916e * LETFifyed
Alexey Dejneka authored
18 ;;; License along with this library; if not, write to the
19 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3cb03ba Initial check-in
Mike McDonald authored
20 ;;; Boston, MA 02111-1307 USA.
21
95dff8a make all of the package names passed to in-package be lowercase keywo…
Mike McDonald authored
22 (in-package :clim-internals)
3cb03ba Initial check-in
Mike McDonald authored
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)
6350fb6 Many more generic function defgenerics in decls.lisp
Christophe Rhodes authored
32 ())
3cb03ba Initial check-in
Mike McDonald authored
33
411ef66 reworking output history - doesn't handle CR correct yet
CVS pserver daemon authored
34 (defmethod stream-recording-p ((stream t)) nil)
35 (defmethod stream-drawing-p ((stream t)) t)
36
3cb03ba Initial check-in
Mike McDonald authored
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)
7d91c1f Modified the code to make use of the newly implemented setf* facility.
Arnaud Rouanet authored
41 (setf (stream-cursor-position stream)
42 (value 0
43 (+ cy
44 (stream-line-height stream)
45 (stream-vertical-spacing stream)))))
3cb03ba Initial check-in
Mike McDonald authored
46 (t
28e1c18 Partially rewrote Output Recording to conform to specification.
Arnaud Rouanet authored
47 (draw-text* (sheet-medium stream) char cx (+ cy (stream-baseline stream)))
7d91c1f Modified the code to make use of the newly implemented setf* facility.
Arnaud Rouanet authored
48 (setf (stream-cursor-position stream)
49 (values (+ cx (stream-character-width stream char)) cy))))))
3cb03ba Initial check-in
Mike McDonald authored
50
51
52 ;;; Cursor class
53
24f916e * LETFifyed
Alexey Dejneka authored
54 (defgeneric* (setf cursor-position) (x y cursor))
55
56 ;;; Cursor-Mixin class
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
57 (defclass cursor-mixin ()
58 ((sheet :initarg :sheet
59 :reader cursor-sheet)
0bd9f60 Many bug fixes in Goatee. Rewrote buffer functions in terms of a
Timothy Moore authored
60 (x :initform 0 :initarg :x-position)
61 (y :initform 0 :initarg :y-position)
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
62 (width :initform 8)
bdf871e Draw hollow or filled cursor in text-field gadget, depending on
Rudi Schlatte authored
63 (appearance :type (member :solid :hollow)
64 :initarg :appearance :initform :hollow
65 :accessor cursor-appearance)
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
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
fed4930 Minor rewriting of the cursor attribute functions to conform more clo…
Andy Hefner authored
71 :accessor cursor-active)
72 (cursor-state :initform nil
73 :accessor cursor-state)))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
74
75 (defgeneric cursor-height (cursor))
76
77 (defmethod print-object ((cursor cursor-mixin) stream)
a9ed88d more output history work -- still not right but closer
CVS pserver daemon authored
78 (with-slots (x y) cursor
79 (print-unreadable-object (cursor stream :type t :identity t)
80 (format stream "~D ~D " x y))))
81
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
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
fed4930 Minor rewriting of the cursor attribute functions to conform more clo…
Andy Hefner authored
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
165956b Take out dependencies on case in symbol names. This makes McCLIM sort
Timothy Moore authored
93 ((:on t) (values t t))
94 (:off (values t nil))
fed4930 Minor rewriting of the cursor attribute functions to conform more clo…
Andy Hefner authored
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)
165956b Take out dependencies on case in symbol names. This makes McCLIM sort
Timothy Moore authored
102 (t nil))))
fed4930 Minor rewriting of the cursor attribute functions to conform more clo…
Andy Hefner authored
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)))
3cb03ba Initial check-in
Mike McDonald authored
109
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
110 (defmethod cursor-position ((cursor cursor-mixin))
3cb03ba Initial check-in
Mike McDonald authored
111 (with-slots (x y) cursor
112 (values x y)))
113
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
114 (defmethod* (setf cursor-position) (nx ny (cursor cursor-mixin))
6f5647d Accepting-values. It's ugly and has some cursor glitches but
Timothy Moore authored
115 (with-slots (x y) cursor
116 (letf (((cursor-state cursor) nil))
117 (multiple-value-prog1
118 (setf (values x y) (values nx ny))))
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
119 (when (and (cursor-active cursor)
120 (output-recording-stream-p (cursor-sheet cursor)))
121 (stream-close-text-output-record (cursor-sheet cursor)))))
6746b17 Implement +flipping-ink+. Make the cursor code use it so the cursor …
Timothy Moore authored
122
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
123 (defmethod flip-screen-cursor ((cursor cursor-mixin))
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
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)
bdf871e Draw hollow or filled cursor in text-field gadget, depending on
Rudi Schlatte authored
130 :filled (ecase (cursor-appearance cursor)
131 (:solid t) (:hollow nil))
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
132 :ink +flipping-ink+)))))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
133
134 (defmethod display-cursor ((cursor cursor-mixin) state)
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
135 (unless (stream-drawing-p (cursor-sheet cursor))
136 (return-from display-cursor nil))
3cb03ba Initial check-in
Mike McDonald authored
137 (with-slots (x y sheet width) cursor
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
138 (let ((height (cursor-height cursor)))
3cb03ba Initial check-in
Mike McDonald authored
139 (case state
140 (:draw (draw-rectangle* (sheet-medium (cursor-sheet cursor))
141 x y
142 (+ x width) (+ y height)
bdf871e Draw hollow or filled cursor in text-field gadget, depending on
Rudi Schlatte authored
143 :filled (ecase (cursor-appearance cursor)
144 (:solid t) (:hollow nil))
3cb03ba Initial check-in
Mike McDonald authored
145 :ink +foreground-ink+
fed4930 Minor rewriting of the cursor attribute functions to conform more clo…
Andy Hefner authored
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)
bdf871e Draw hollow or filled cursor in text-field gadget, depending on
Rudi Schlatte authored
158 :filled (ecase (cursor-appearance cursor)
159 (:solid t) (:hollow nil))
fed4930 Minor rewriting of the cursor attribute functions to conform more clo…
Andy Hefner authored
160 :ink +background-ink+))))))
3cb03ba Initial check-in
Mike McDonald authored
161
162 ;;; Standard-Text-Cursor class
163
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
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))
3cb03ba Initial check-in
Mike McDonald authored
169
170
171 ;;; Extended-Output-Stream class
172
24f916e * LETFifyed
Alexey Dejneka authored
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)
3cb03ba Initial check-in
Mike McDonald authored
179 ((cursor :accessor stream-text-cursor)
14d76c2 Changes to turn off, and then turn on again, presentation highlighting
Timothy Moore authored
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)
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
189 ;; What is this? --GB
3cb03ba Initial check-in
Mike McDonald authored
190 (height :initform 0)
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
191 ;; When the stream takes part in the space alloction protocol, this
192 ;; remembers our demand:
193 (seos-current-width :initform 0)
14d76c2 Changes to turn off, and then turn on again, presentation highlighting
Timothy Moore authored
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+))
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
199
7875193 stream-force-output should call medium-force-output
Timothy Moore authored
200 (defmethod stream-force-output :after ((stream
ff2096c Removed some tabs at the request of Cyrus Harmon.
Robert Strandh authored
201 standard-extended-output-stream))
7875193 stream-force-output should call medium-force-output
Timothy Moore authored
202 (with-sheet-medium (medium stream)
203 (medium-force-output medium)))
204
e12a40d Patch from Nikodemus Siivola adding an :after method on
Robert Strandh authored
205 (defmethod stream-finish-output :after ((stream
ff2096c Removed some tabs at the request of Cyrus Harmon.
Robert Strandh authored
206 standard-extended-output-stream))
e12a40d Patch from Nikodemus Siivola adding an :after method on
Robert Strandh authored
207 (with-sheet-medium (medium stream)
208 (medium-finish-output medium)))
209
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
210 (defmethod compose-space ((pane standard-extended-output-stream) &key width height)
cb78750 Rearranging of seos-current-width/height slots: they are now set in an
Andy Hefner authored
211 (declare (ignorable width height))
212
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
213 (with-slots (seos-current-width seos-current-height) pane
214 (make-space-requirement :width seos-current-width
215 :height seos-current-height)))
3cb03ba Initial check-in
Mike McDonald authored
216
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
217 (defmethod initialize-instance :after
218 ((stream standard-extended-output-stream) &rest args)
3cb03ba Initial check-in
Mike McDonald authored
219 (declare (ignore args))
45da96f Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
Timothy Moore authored
220 (setf (stream-text-cursor stream)
221 (make-instance 'standard-text-cursor :sheet stream))
222 (setf (cursor-active (stream-text-cursor stream)) t))
223
3cb03ba Initial check-in
Mike McDonald authored
224
94de86a character width/line height fixes
Mike McDonald authored
225 (defmethod stream-cursor-position ((stream standard-extended-output-stream))
3cb03ba Initial check-in
Mike McDonald authored
226 (cursor-position (stream-text-cursor stream)))
227
94de86a character width/line height fixes
Mike McDonald authored
228 (defmethod* (setf stream-cursor-position) (x y (stream standard-extended-output-stream))
7d91c1f Modified the code to make use of the newly implemented setf* facility.
Arnaud Rouanet authored
229 (setf (cursor-position (stream-text-cursor stream)) (values x y)))
230
1dd4363 Made `stream-set-cursor-position' a generic function and exported it,
Troels Henriksen authored
231 (defmethod stream-set-cursor-position ((stream standard-extended-output-stream) x y)
22e824d spec say "A compatibility function will be provided."
Mike McDonald authored
232 (setf (stream-cursor-position stream) (values x y)))
233
94de86a character width/line height fixes
Mike McDonald authored
234 (defmethod stream-increment-cursor-position ((stream standard-extended-output-stream) dx dy)
3cb03ba Initial check-in
Mike McDonald authored
235 (multiple-value-bind (x y) (cursor-position (stream-text-cursor stream))
cc178bf Implemented indenting-output. Also, encapsulating stream hackery,
Andy Hefner authored
236 (let ((dx (or dx 0))
237 (dy (or dy 0)))
238 (setf (cursor-position (stream-text-cursor stream)) (values (+ x dx) (+ y dy))))))
3cb03ba Initial check-in
Mike McDonald authored
239
b547b9b Fix to (setf CURSOR-POSITION) - if the cursor's sheet is a recording …
Andy Hefner authored
240
241
6746b17 Implement +flipping-ink+. Make the cursor code use it so the cursor …
Timothy Moore authored
242 ;;;
243
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
244 (defmethod handle-repaint :around ((stream standard-extended-output-stream)
245 region)
536ebe3 clean up a bunch of ACL compiler warnings
Mike McDonald authored
246 (declare (ignorable region))
6746b17 Implement +flipping-ink+. Make the cursor code use it so the cursor …
Timothy Moore authored
247 (let ((cursor (stream-text-cursor stream)))
fed4930 Minor rewriting of the cursor attribute functions to conform more clo…
Andy Hefner authored
248 (if (cursor-state cursor)
6f5647d Accepting-values. It's ugly and has some cursor glitches but
Timothy Moore authored
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))
6746b17 Implement +flipping-ink+. Make the cursor code use it so the cursor …
Timothy Moore authored
256 (call-next-method))))
257
94de86a character width/line height fixes
Mike McDonald authored
258 (defmethod scroll-vertical ((stream standard-extended-output-stream) dy)
e412d64 use the region position for scrolling
CVS pserver daemon authored
259 (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
260 (scroll-extent stream tx (+ ty dy))))
3cb03ba Initial check-in
Mike McDonald authored
261
94de86a character width/line height fixes
Mike McDonald authored
262 (defmethod scroll-horizontal ((stream standard-extended-output-stream) dx)
e412d64 use the region position for scrolling
CVS pserver daemon authored
263 (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
264 (scroll-extent stream (+ tx dx) ty)))
265
266 (defmacro with-cursor-off (stream &body body)
24f916e * LETFifyed
Alexey Dejneka authored
267 `(letf (((cursor-visibility (stream-text-cursor ,stream)) nil))
268 ,@body))
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
269
94de86a character width/line height fixes
Mike McDonald authored
270 (defmethod stream-wrap-line ((stream standard-extended-output-stream))
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
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))
3cb03ba Initial check-in
Mike McDonald authored
278
42e6179 * Two new methods, STREAM-WRITE-LINE and
Alexey Dejneka authored
279
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
280
281 (defun seos-write-string (stream string &optional (start 0) end)
282 (let* ((medium (sheet-medium stream))
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
283 (text-style (medium-text-style medium))
4d66a51 Redefined text-style-{ascent,descent,height,width} to conform to
Robert Strandh authored
284 (new-baseline (text-style-ascent text-style medium))
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
285 (new-height (text-style-height text-style medium))
286 (margin (stream-text-margin stream))
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
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)))))
565c52f SEOS-WRITE-STRING fix wrt. zero-length strings from Mike Watters.
Troels Henriksen authored
295 (when (eql end 0)
296 (return-from seos-write-string))
297
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
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))
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
312 (when (>= (+ cx width) margin)
313 (ecase (stream-end-of-line-action stream)
3cb03ba Initial check-in
Mike McDonald authored
314 (:wrap
6bf8c66 Fixed output bug where :end-of-line-action is :wrap and there isn't r…
Troels Henriksen authored
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))))
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
319 (:scroll
320 (scroll-horizontal stream width))
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
321 (:allow)))
322 (unless (= start split)
ade86a3 Change invoke-with-new-output-record and invoke-with-output-to-output…
Timothy Moore authored
323 (stream-write-output stream
324 string
b6cee85 Commit working version of text-bounding-rectangle* stuff, as trailed on
Christophe Rhodes authored
325 nil
ade86a3 Change invoke-with-new-output-record and invoke-with-output-to-output…
Timothy Moore authored
326 start split)
530bbdf stream-output.lisp:
Andy Hefner authored
327 (setq cx (+ cx width))
328 (with-slots (x y) (stream-text-cursor stream)
329 (setf x cx y cy)))
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
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)
cb78750 Rearranging of seos-current-width/height slots: they are now set in an
Andy Hefner authored
357 (change-space-requirements stream
358 :width (bounding-rectangle-width stream)
359 :height (+ cy height))
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
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
cb78750 Rearranging of seos-current-width/height slots: they are now set in an
Andy Hefner authored
378 height 0)
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
379 (setf (stream-cursor-position stream) (values cx cy))))))
380
381
382
383
ade86a3 Change invoke-with-new-output-record and invoke-with-output-to-output…
Timothy Moore authored
384 (defgeneric stream-write-output (stream line string-width &optional start end)
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
385 (:documentation
386 "Writes the character or string LINE to STREAM. This function produces no
ade86a3 Change invoke-with-new-output-record and invoke-with-output-to-output…
Timothy Moore authored
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
9a1668c Hammered on with-room-for-graphics. It should now leave the cursor in
Timothy Moore authored
391 ;;; The cursor is in stream coordinates.
ade86a3 Change invoke-with-new-output-record and invoke-with-output-to-output…
Timothy Moore authored
392 (defmethod stream-write-output (stream line string-width
393 &optional (start 0) end)
394 (declare (ignore string-width))
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
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)
9a1668c Hammered on with-room-for-graphics. It should now leave the cursor in
Timothy Moore authored
399 :transformation +identity-transformation+
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
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)))))
3cb03ba Initial check-in
Mike McDonald authored
407
c02a937 kludge to work around long standing ACL output corruption
Mike McDonald authored
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
94de86a character width/line height fixes
Mike McDonald authored
413 (defmethod stream-write-string ((stream standard-extended-output-stream) string
3cb03ba Initial check-in
Mike McDonald authored
414 &optional (start 0) end)
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
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))
c02a937 kludge to work around long standing ACL output corruption
Mike McDonald authored
421 (seos-write-string stream (subseq string seg-start i))
b516575 Reworked stream functions to make string output the basic mode of ope…
Andy Hefner authored
422 (seos-write-newline stream)
423 (setq seg-start (1+ i))))
c02a937 kludge to work around long standing ACL output corruption
Mike McDonald authored
424 (seos-write-string stream (subseq string seg-start end)))))
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
425
94de86a character width/line height fixes
Mike McDonald authored
426 ;(defmethod stream-write-string ((stream standard-extended-output-stream) string
6b78580 Rewrote stream-write-char and output recording of text. It seems to…
CVS pserver daemon authored
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))))
3cb03ba Initial check-in
Mike McDonald authored
434
94de86a character width/line height fixes
Mike McDonald authored
435 (defmethod stream-character-width ((stream standard-extended-output-stream) char &key (text-style nil))
24f916e * LETFifyed
Alexey Dejneka authored
436 (with-sheet-medium (medium stream)
437 (text-style-character-width (or text-style (medium-text-style medium))
438 medium
439 char)))
3cb03ba Initial check-in
Mike McDonald authored
440
94de86a character width/line height fixes
Mike McDonald authored
441 (defmethod stream-string-width ((stream standard-extended-output-stream) string
3cb03ba Initial check-in
Mike McDonald authored
442 &key (start 0) (end nil) (text-style nil))
3dc303b * STREAM-STRING-WIDTH: implemented via TEXT-SIZE.
Alexey Dejneka authored
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))))
3cb03ba Initial check-in
Mike McDonald authored
451
94de86a character width/line height fixes
Mike McDonald authored
452 (defmethod stream-text-margin ((stream standard-extended-output-stream))
3cb03ba Initial check-in
Mike McDonald authored
453 (with-slots (margin) stream
454 (or margin
a10d377 Scrolling Work Part II, the extended output stream ...
Gilbert Baumann authored
455 (- (bounding-rectangle-width (or (pane-viewport stream)
456 stream))
37205bb Squashed a "magic fudge factor".
Andy Hefner authored
457 (text-size stream "O")))))
3cb03ba Initial check-in
Mike McDonald authored
458
37205bb Squashed a "magic fudge factor".
Andy Hefner authored
459 (defmethod stream-line-height ((stream standard-extended-output-stream)
460 &key (text-style nil))
94de86a character width/line height fixes
Mike McDonald authored
461 (+ (text-style-height (or text-style (medium-text-style (sheet-medium stream)))
462 (sheet-medium stream))
463 (stream-vertical-spacing stream)))
3cb03ba Initial check-in
Mike McDonald authored
464
94de86a character width/line height fixes
Mike McDonald authored
465 (defmethod stream-line-column ((stream standard-extended-output-stream))
af48a15 Changed order of arguments to text-style- functions to conform to
CVS pserver daemon authored
466 (multiple-value-bind (x y) (stream-cursor-position stream)
467 (declare (ignore y))
468 (floor x (stream-string-width stream " "))))
469
94de86a character width/line height fixes
Mike McDonald authored
470 (defmethod stream-start-line-p ((stream standard-extended-output-stream))
af48a15 Changed order of arguments to text-style- functions to conform to
CVS pserver daemon authored
471 (multiple-value-bind (x y) (stream-cursor-position stream)
c498610 remove compiler warnings for ACL
Mike McDonald authored
472 (declare (ignore y))
af48a15 Changed order of arguments to text-style- functions to conform to
CVS pserver daemon authored
473 (zerop x)))
474
3cb03ba Initial check-in
Mike McDonald authored
475 (defmacro with-room-for-graphics ((&optional (stream t)
3b6b883 WITH-ROOM-FOR-GRAPHICS now has an implementation.
Gilbert Baumann authored
476 &rest arguments
477 &key (first-quadrant t)
478 height
479 (move-cursor t)
480 (record-type ''standard-sequence-output-record))
481 &body body)
4ad90e5 Added a few "ignore" declarations to avoid compiler notes.
Robert Strandh authored
482 (declare (ignore first-quadrant height move-cursor record-type))
3b6b883 WITH-ROOM-FOR-GRAPHICS now has an implementation.
Gilbert Baumann authored
483 (let ((cont (gensym "CONT."))
7945407 Changed STREAM-DESIGNATOR-SYMBOL to take a default value
Timothy Moore authored
484 (stream (stream-designator-symbol stream '*standard-output*)))
3b6b883 WITH-ROOM-FOR-GRAPHICS now has an implementation.
Gilbert Baumann authored
485 `(labels ((,cont (,stream)
486 ,@body))
487 (declare (dynamic-extent #',cont))
488 (invoke-with-room-for-graphics #',cont ,stream ,@arguments))))
3cb03ba Initial check-in
Mike McDonald authored
489
490 (defmacro with-end-of-line-action ((stream action) &body body)
ec113e1 * WITH-ROOM-FOR-GRAPHICS, WITH-END-OF-LINE-ACTION,
Alexey Dejneka authored
491 (when (eq stream t)
492 (setq stream '*standard-output*))
24f916e * LETFifyed
Alexey Dejneka authored
493 (check-type stream symbol)
494 `(letf (((stream-end-of-line-action ,stream) ,action))
495 ,@body))
3cb03ba Initial check-in
Mike McDonald authored
496
497 (defmacro with-end-of-page-action ((stream action) &body body)
ec113e1 * WITH-ROOM-FOR-GRAPHICS, WITH-END-OF-LINE-ACTION,
Alexey Dejneka authored
498 (when (eq stream t)
499 (setq stream '*standard-output*))
24f916e * LETFifyed
Alexey Dejneka authored
500 (check-type stream symbol)
501 `(letf (((stream-end-of-page-action ,stream) ,action))
502 ,@body))
3cb03ba Initial check-in
Mike McDonald authored
503
a7d19dd Added the new medium-specific output functions:
Arnaud Rouanet authored
504 (defmethod beep (&optional medium)
a03545d Fix assumption in BEEP function that standard output must be a CLIM s…
Andy Hefner authored
505 (if medium
506 (medium-beep medium)
507 (when (sheetp *standard-output*)
508 (medium-beep (sheet-medium *standard-output*)))))
509
78b6067 In tracking-pointer, don't discard the event when calling the handler.
Andy Hefner authored
510 (defmethod scroll-quantum ((sheet standard-extended-output-stream))
511 (stream-line-height sheet))
Something went wrong with that request. Please try again.