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

  ViewVC Help
Powered by ViewVC 1.1.5