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

  ViewVC Help
Powered by ViewVC 1.1.5