/[cmucl]/src/hemlock/hunk-draw.lisp
ViewVC logotype

Contents of /src/hemlock/hunk-draw.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Wed Aug 25 02:09:04 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.3: +2 -2 lines
Fix compiler warnings.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/hunk-draw.lisp,v 1.4 1993/08/25 02:09:04 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Written by Bill Chiles and Rob MacLachlan.
15 ;;;
16 ;;; Hemlock screen painting routines for the IBM RT running X.
17 ;;;
18 (in-package "HEMLOCK"-internals)
19
20
21 (defparameter hunk-height-limit 80 "Maximum possible height for any hunk.")
22 (defparameter hunk-width-limit 200 "Maximum possible width for any hunk.")
23 (defparameter hunk-top-border 2 "Clear area at beginning.")
24 (defparameter hunk-left-border 1 "Clear area before first character.")
25 (defparameter hunk-bottom-border 3 "Minimum Clear area at end.")
26 (defparameter hunk-thumb-bar-bottom-border 10
27 "Minimum Clear area at end including room for thumb bar." )
28 (defparameter hunk-modeline-top 2 "Extra black pixels above modeline chars.")
29 (defparameter hunk-modeline-bottom 2 "Extra black pixels below modeline chars.")
30
31
32
33 ;;;; Character translations for CLX
34
35 ;;; HEMLOCK-TRANSLATE-DEFAULT.
36 ;;;
37 ;;; CLX glyph drawing routines allow for a character translation function. The
38 ;;; default one takes a string (any kind) or a vector of numbers and slams them
39 ;;; into the outgoing request buffer. When the argument is a string, it stops
40 ;;; processing if it sees a character that is not GRAPHIC-CHAR-P. For each
41 ;;; graphical character, the function ultimately calls CHAR-CODE.
42 ;;;
43 ;;; Hemlock only passes simple-strings in, and these can only contain graphical
44 ;;; characters because of the line image builder, except for one case --
45 ;;; *line-wrap-char* which anyone can set. Those who want to do evil things
46 ;;; with this should know what they are doing: if they want a funny glyph as
47 ;;; a line wrap char, then they should use CODE-CHAR on the font index. This
48 ;;; allows the following function to translate everything with CHAR-CODE, and
49 ;;; everybody's happy.
50 ;;;
51 ;;; Actually, Hemlock can passes the line string when doing random-typeout which
52 ;;; does contain ^L's, tabs, etc. Under X10 these came out as funny glyphs,
53 ;;; and under X11 the output is aborted without this function.
54 ;;;
55 (defun hemlock-translate-default (src src-start src-end font dst dst-start)
56 (declare (simple-string src)
57 (fixnum src-start src-end dst-start)
58 (vector dst)
59 (ignore font))
60 (do ((i src-start (1+ i))
61 (j dst-start (1+ j)))
62 ((>= i src-end) i)
63 (declare (fixnum i j))
64 (setf (aref dst j) (char-code (schar src i)))))
65
66 (defvar *glyph-translate-function* #'xlib:translate-default)
67
68
69
70 ;;;; Drawing a line.
71
72 (eval-when (compile eval)
73
74 ;;; HUNK-PUT-STRING takes a character (x,y) pair and computes at which pixel
75 ;;; coordinate to draw string with font from start to end. This macros assumes
76 ;;; hunk and font-family to be bound by the caller.
77 ;;;
78 (defmacro hunk-put-string (x y font string start end)
79 (let ((gcontext (gensym)))
80 `(let ((,gcontext (bitmap-hunk-gcontext hunk)))
81 (xlib:with-gcontext (,gcontext :font ,font)
82 (xlib:draw-image-glyphs
83 (bitmap-hunk-xwindow hunk) ,gcontext
84 (+ hunk-left-border (* ,x (font-family-width font-family)))
85 (+ hunk-top-border (* ,y (font-family-height font-family))
86 (font-family-baseline font-family))
87 ,string :start ,start :end ,end
88 :translate *glyph-translate-function*)))))
89
90 ); eval-when (compile eval)
91
92
93 ;;; Hunk-Write-String -- Internal
94 ;;;
95 ;;; A historical vestige used by bitmap hunk streams. Use default font (0),
96 ;;; and bind font-family for HUNK-PUT-STRING.
97 ;;;
98 (defun hunk-write-string (hunk x y string start end)
99 (let* ((font-family (bitmap-hunk-font-family hunk))
100 (font (svref (font-family-map font-family) 0)))
101 (hunk-put-string x y font string start end)))
102
103
104 ;;; Hunk-Write-Line -- Internal
105 ;;;
106 ;;; Paint a dis-line on a hunk, taking font-changes into consideration.
107 ;;; The area of the hunk drawn on is assumed to be cleared. If supplied,
108 ;;; the line is written at Position, and the position in the dis-line
109 ;;; is ignored.
110 ;;;
111 (defun hunk-write-line (hunk dl &optional
112 (position (dis-line-position dl)))
113 (let* ((font-family (bitmap-hunk-font-family hunk))
114 (map (font-family-map font-family))
115 (chars (dis-line-chars dl))
116 (length (dis-line-length dl)))
117 (let ((last 0)
118 (last-font (svref map 0)))
119 (do ((change (dis-line-font-changes dl) (font-change-next change)))
120 ((null change)
121 (hunk-put-string last position last-font chars last length))
122 (let ((x (font-change-x change)))
123 (hunk-put-string last position last-font chars last x)
124 (setq last x last-font (svref map (font-change-font change))))))))
125
126
127 ;;; We hack this since the X11 server's aren't clever about DRAW-IMAGE-GLYPHS;
128 ;;; that is, they literally clear the line, and then blast the new glyphs.
129 ;;; We don't hack replacing the line when reverse video is turned on because
130 ;;; this doesn't seem to work too well. Also, hacking replace line on the
131 ;;; color Megapel display is SLOW!
132 ;;;
133 (defvar *hack-hunk-replace-line* t)
134
135 ;;; Hunk-Replace-Line -- Internal
136 ;;;
137 ;;; Similar to Hunk-Write-Line, but the line need not be clear.
138 ;;;
139 (defun hunk-replace-line (hunk dl &optional
140 (position (dis-line-position dl)))
141 (if *hack-hunk-replace-line*
142 (hunk-replace-line-on-a-pixmap hunk dl position)
143 (old-hunk-replace-line hunk dl position)))
144
145 (defun old-hunk-replace-line (hunk dl &optional
146 (position (dis-line-position dl)))
147 (let* ((font-family (bitmap-hunk-font-family hunk))
148 (map (font-family-map font-family))
149 (chars (dis-line-chars dl))
150 (length (dis-line-length dl))
151 (height (font-family-height font-family)))
152 (let ((last 0)
153 (last-font (svref map 0)))
154 (do ((change (dis-line-font-changes dl) (font-change-next change)))
155 ((null change)
156 (hunk-put-string last position last-font chars last length)
157 (let ((dx (+ hunk-left-border
158 (* (font-family-width font-family) length))))
159 (xlib:clear-area (bitmap-hunk-xwindow hunk)
160 :x dx
161 :y (+ hunk-top-border (* position height))
162 :width (- (bitmap-hunk-width hunk) dx)
163 :height height)))
164 (let ((x (font-change-x change)))
165 (hunk-put-string last position last-font chars last x)
166 (setq last x last-font (svref map (font-change-font change))))))))
167
168 (defvar *hunk-replace-line-pixmap* nil)
169
170 (defun hunk-replace-line-pixmap ()
171 (if *hunk-replace-line-pixmap*
172 *hunk-replace-line-pixmap*
173 (let* ((hunk (window-hunk *current-window*))
174 (gcontext (bitmap-hunk-gcontext hunk))
175 (screen (xlib:display-default-screen
176 (bitmap-device-display (device-hunk-device hunk))))
177 (height (font-family-height *default-font-family*))
178 (pixmap (xlib:create-pixmap
179 :width (* hunk-width-limit
180 (font-family-width *default-font-family*))
181 :height height :depth (xlib:screen-root-depth screen)
182 :drawable (xlib:screen-root screen))))
183 (xlib:with-gcontext (gcontext :function boole-1
184 :foreground *default-background-pixel*)
185 (xlib:draw-rectangle pixmap gcontext 0 0 hunk-left-border height t))
186 (setf *hunk-replace-line-pixmap* pixmap))))
187
188
189 (eval-when (compile eval)
190
191 ;;; HUNK-REPLACE-LINE-STRING takes a character (x,y) pair and computes at which
192 ;;; pixel coordinate to draw string with font from start to end. This macros
193 ;;; assumes hunk and font-family to be bound by the caller. We draw the text
194 ;;; on a pixmap and later blast it out to avoid line flicker since server on
195 ;;; the RT is not very clever; it clears the entire line before drawing text.
196 ;;;
197 (defmacro hunk-replace-line-string (x y font string start end)
198 (declare (ignore y))
199 `(xlib:with-gcontext (gcontext :font ,font)
200 (xlib:draw-image-glyphs
201 (hunk-replace-line-pixmap) gcontext
202 (+ hunk-left-border (* ,x (font-family-width font-family)))
203 (font-family-baseline font-family)
204 ,string :start ,start :end ,end
205 :translate *glyph-translate-function*)))
206 ) ;eval-when
207
208 (defun hunk-replace-line-on-a-pixmap (hunk dl position)
209 (let* ((font-family (bitmap-hunk-font-family hunk))
210 (map (font-family-map font-family))
211 (chars (dis-line-chars dl))
212 (length (dis-line-length dl))
213 (height (font-family-height font-family))
214 (last 0)
215 (last-font (svref map 0))
216 (gcontext (bitmap-hunk-gcontext hunk)))
217 (do ((change (dis-line-font-changes dl) (font-change-next change)))
218 ((null change)
219 (hunk-replace-line-string last position last-font chars last length)
220 (let* ((dx (+ hunk-left-border
221 (* (font-family-width font-family) length)))
222 (dy (+ hunk-top-border (* position height)))
223 (xwin (bitmap-hunk-xwindow hunk)))
224 (xlib:with-gcontext (gcontext :exposures nil)
225 (xlib:copy-area (hunk-replace-line-pixmap) gcontext
226 0 0 dx height xwin 0 dy))
227 (xlib:clear-area xwin :x dx :y dy
228 :width (- (bitmap-hunk-width hunk) dx)
229 :height height)))
230 (let ((x (font-change-x change)))
231 (hunk-replace-line-string last position last-font chars last x)
232 (setq last x last-font (svref map (font-change-font change)))))))
233
234
235 ;;; HUNK-REPLACE-MODELINE sets the entire mode line to the the foreground
236 ;;; color, so the initial bits where no characters go also is highlighted.
237 ;;; Then the text is drawn background on foreground (hightlighted). This
238 ;;; function assumes that BITMAP-HUNK-MODELINE-POS will not return nil;
239 ;;; that is, there is a modeline. This function should assume the gcontext's
240 ;;; font is the default font of the hunk. We must LET bind the foreground and
241 ;;; background values before entering XLIB:WITH-GCONTEXT due to a non-obvious
242 ;;; or incorrect implementation.
243 ;;;
244 (defun hunk-replace-modeline (hunk)
245 (let* ((dl (bitmap-hunk-modeline-dis-line hunk))
246 (font-family (bitmap-hunk-font-family hunk))
247 (default-font (svref (font-family-map font-family) 0))
248 (modeline-pos (bitmap-hunk-modeline-pos hunk))
249 (xwindow (bitmap-hunk-xwindow hunk))
250 (gcontext (bitmap-hunk-gcontext hunk)))
251 (xlib:draw-rectangle xwindow gcontext 0 modeline-pos
252 (bitmap-hunk-width hunk)
253 (+ hunk-modeline-top hunk-modeline-bottom
254 (font-family-height font-family))
255 t)
256 (xlib:with-gcontext (gcontext :foreground
257 (xlib:gcontext-background gcontext)
258 :background
259 (xlib:gcontext-foreground gcontext)
260 :font default-font)
261 (xlib:draw-image-glyphs xwindow gcontext hunk-left-border
262 (+ modeline-pos hunk-modeline-top
263 (font-family-baseline font-family))
264 (dis-line-chars dl)
265 :end (dis-line-length dl)
266 :translate *glyph-translate-function*))))
267 #|
268 (defun hunk-replace-modeline (hunk)
269 (let* ((dl (bitmap-hunk-modeline-dis-line hunk))
270 (font-family (bitmap-hunk-font-family hunk))
271 (default-font (svref (font-family-map font-family) 0))
272 (modeline-pos (bitmap-hunk-modeline-pos hunk))
273 (xwindow (bitmap-hunk-xwindow hunk))
274 (gcontext (bitmap-hunk-gcontext hunk)))
275 (xlib:draw-rectangle xwindow gcontext 0 modeline-pos
276 (bitmap-hunk-width hunk)
277 (+ hunk-modeline-top hunk-modeline-bottom
278 (font-family-height font-family))
279 t)
280 (let ((foreground (xlib:gcontext-background gcontext))
281 (background (xlib:gcontext-foreground gcontext)))
282 (xlib:with-gcontext (gcontext :foreground foreground
283 :background background
284 :font default-font)
285 (xlib:draw-image-glyphs xwindow gcontext hunk-left-border
286 (+ modeline-pos hunk-modeline-top
287 (font-family-baseline font-family))
288 (dis-line-chars dl)
289 :end (dis-line-length dl)
290 :translate *glyph-translate-function*)))))
291 |#
292
293
294 ;;;; Cursor/Border color manipulation.
295
296 ;;; *hemlock-listener* is set to t by default because we can't know from X
297 ;;; whether we come up with the pointer in our window. There is no initial
298 ;;; :enter-window event. Defaulting this to nil causes the cursor to be hollow
299 ;;; when the window comes up under the mouse, and you have to know how to fix
300 ;;; it. Defaulting it to t causes the cursor to always come up full, as if
301 ;;; Hemlock is the X listener, but this recovers naturally as you move into the
302 ;;; window. This also coincides with Hemlock's border coming up highlighted,
303 ;;; even when Hemlock is not the listener.
304 ;;;
305 (defvar *hemlock-listener* t
306 "Highlight border when the cursor is dropped and Hemlock can receive input.")
307 (defvar *current-highlighted-border* nil
308 "When non-nil, the bitmap-hunk with the highlighted border.")
309
310 (defvar *hunk-cursor-x* 0 "The current cursor X position in pixels.")
311 (defvar *hunk-cursor-y* 0 "The current cursor Y position in pixels.")
312 (defvar *cursor-hunk* nil "Hunk the cursor is displayed on.")
313 (defvar *cursor-dropped* nil) ; True if the cursor is currently displayed.
314
315 ;;; HUNK-SHOW-CURSOR locates the cursor at character position (x,y) in hunk.
316 ;;; If the cursor is currently displayed somewhere, then lift it, and display
317 ;;; it at its new location.
318 ;;;
319 (defun hunk-show-cursor (hunk x y)
320 (unless (and (= x *hunk-cursor-x*)
321 (= y *hunk-cursor-y*)
322 (eq hunk *cursor-hunk*))
323 (let ((cursor-down *cursor-dropped*))
324 (when cursor-down (lift-cursor))
325 (setf *hunk-cursor-x* x)
326 (setf *hunk-cursor-y* y)
327 (setf *cursor-hunk* hunk)
328 (when cursor-down (drop-cursor)))))
329
330 ;;; FROB-CURSOR is the note-read-wait method for bitmap redisplay. We
331 ;;; show a cursor and highlight the listening window's border when waiting
332 ;;; for input.
333 ;;;
334 (defun frob-cursor (on)
335 (if on (drop-cursor) (lift-cursor)))
336
337 (proclaim '(special *default-border-pixmap* *highlight-border-pixmap*))
338
339 ;;; DROP-CURSOR and LIFT-CURSOR are separate functions from FROB-CURSOR
340 ;;; because they are called a couple places (e.g., HUNK-EXPOSED-REGION
341 ;;; and SMART-WINDOW-REDISPLAY). When the cursor is being dropped, since
342 ;;; this means Hemlock is listening in the *cursor-hunk*, make sure the
343 ;;; border of the window is highlighted as well.
344 ;;;
345 (defun drop-cursor ()
346 (unless *cursor-dropped*
347 (unless *hemlock-listener* (cursor-invert-center))
348 (cursor-invert)
349 (when *hemlock-listener*
350 (cond (*current-highlighted-border*
351 (unless (eq *current-highlighted-border* *cursor-hunk*)
352 (setf (xlib:window-border
353 (window-group-xparent
354 (bitmap-hunk-window-group *current-highlighted-border*)))
355 *default-border-pixmap*)
356 (setf (xlib:window-border
357 (window-group-xparent
358 (bitmap-hunk-window-group *cursor-hunk*)))
359 *highlight-border-pixmap*)
360 ;; For complete gratuitous pseudo-generality, should force
361 ;; output on *current-highlighted-border* device too.
362 (xlib:display-force-output
363 (bitmap-device-display (device-hunk-device *cursor-hunk*)))))
364 (t (setf (xlib:window-border
365 (window-group-xparent
366 (bitmap-hunk-window-group *cursor-hunk*)))
367 *highlight-border-pixmap*)
368 (xlib:display-force-output
369 (bitmap-device-display (device-hunk-device *cursor-hunk*)))))
370 (setf *current-highlighted-border* *cursor-hunk*))
371 (setq *cursor-dropped* t)))
372
373 ;;;
374 (defun lift-cursor ()
375 (when *cursor-dropped*
376 (unless *hemlock-listener* (cursor-invert-center))
377 (cursor-invert)
378 (setq *cursor-dropped* nil)))
379
380
381 (defun cursor-invert-center ()
382 (let ((family (bitmap-hunk-font-family *cursor-hunk*))
383 (gcontext (bitmap-hunk-gcontext *cursor-hunk*)))
384 (xlib:with-gcontext (gcontext :function boole-xor
385 :foreground *foreground-background-xor*)
386 (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*)
387 gcontext
388 (+ hunk-left-border
389 (* *hunk-cursor-x* (font-family-width family))
390 (font-family-cursor-x-offset family)
391 1)
392 (+ hunk-top-border
393 (* *hunk-cursor-y* (font-family-height family))
394 (font-family-cursor-y-offset family)
395 1)
396 (- (font-family-cursor-width family) 2)
397 (- (font-family-cursor-height family) 2)
398 t)))
399 (xlib:display-force-output
400 (bitmap-device-display (device-hunk-device *cursor-hunk*))))
401
402 (defun cursor-invert ()
403 (let ((family (bitmap-hunk-font-family *cursor-hunk*))
404 (gcontext (bitmap-hunk-gcontext *cursor-hunk*)))
405 (xlib:with-gcontext (gcontext :function boole-xor
406 :foreground *foreground-background-xor*)
407 (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*)
408 gcontext
409 (+ hunk-left-border
410 (* *hunk-cursor-x* (font-family-width family))
411 (font-family-cursor-x-offset family))
412 (+ hunk-top-border
413 (* *hunk-cursor-y* (font-family-height family))
414 (font-family-cursor-y-offset family))
415 (font-family-cursor-width family)
416 (font-family-cursor-height family)
417 t)))
418 (xlib:display-force-output
419 (bitmap-device-display (device-hunk-device *cursor-hunk*))))
420
421
422
423 ;;;; Clearing and Copying Lines.
424
425 (defun hunk-clear-lines (hunk start count)
426 (let ((height (font-family-height (bitmap-hunk-font-family hunk))))
427 (xlib:clear-area (bitmap-hunk-xwindow hunk)
428 :x 0 :y (+ hunk-top-border (* start height))
429 :width (bitmap-hunk-width hunk)
430 :height (* count height))))
431
432 (defun hunk-copy-lines (hunk src dst count)
433 (let ((height (font-family-height (bitmap-hunk-font-family hunk)))
434 (xwindow (bitmap-hunk-xwindow hunk)))
435 (xlib:copy-area xwindow (bitmap-hunk-gcontext hunk)
436 0 (+ hunk-top-border (* src height))
437 (bitmap-hunk-width hunk) (* height count)
438 xwindow 0 (+ hunk-top-border (* dst height)))))
439
440
441
442 ;;;; Drawing bottom border meter.
443
444 ;;; HUNK-DRAW-BOTTOM-BORDER assumes eight-character-space tabs. The LOGAND
445 ;;; calls in the loop are testing for no remainder when dividing by 8, 4,
446 ;;; and other. This lets us quickly draw longer notches at tab stops and
447 ;;; half way in between. This function assumes that
448 ;;; BITMAP-HUNK-MODELINE-POS will not return nil; that is, that there is a
449 ;;; modeline.
450 ;;;
451 (defun hunk-draw-bottom-border (hunk)
452 (when (bitmap-hunk-thumb-bar-p hunk)
453 (let* ((xwindow (bitmap-hunk-xwindow hunk))
454 (gcontext (bitmap-hunk-gcontext hunk))
455 (modeline-pos (bitmap-hunk-modeline-pos hunk))
456 (font-family (bitmap-hunk-font-family hunk))
457 (font-width (font-family-width font-family)))
458 (xlib:clear-area xwindow :x 0 :y (- modeline-pos
459 hunk-thumb-bar-bottom-border)
460 :width (bitmap-hunk-width hunk)
461 :height hunk-bottom-border)
462 (let ((x (+ hunk-left-border (ash font-width -1)))
463 (y7 (- modeline-pos 7))
464 (y5 (- modeline-pos 5))
465 (y3 (- modeline-pos 3)))
466 (dotimes (i (bitmap-hunk-char-width hunk))
467 (cond ((zerop (logand i 7))
468 (xlib:draw-rectangle xwindow gcontext
469 x y7 (if (= i 80) 2 1) 7 t))
470 ((zerop (logand i 3))
471 (xlib:draw-rectangle xwindow gcontext x y5 1 5 t))
472 (t
473 (xlib:draw-rectangle xwindow gcontext x y3 1 3 t)))
474 (incf x font-width))))))

  ViewVC Help
Powered by ViewVC 1.1.5