/[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.7 - (show annotations)
Tue Mar 13 15:49:52 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.6: +2 -2 lines
Change toplevel PROCLAIMs to DECLAIMs.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/hunk-draw.lisp,v 1.7 2001/03/13 15:49:52 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Bill Chiles and Rob MacLachlan.
13 ;;;
14 ;;; Hemlock screen painting routines for the IBM RT running X.
15 ;;;
16 (in-package "HEMLOCK-INTERNALS")
17
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 (declaim (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 (window-group-xparent
352 (bitmap-hunk-window-group *current-highlighted-border*)))
353 *default-border-pixmap*)
354 (setf (xlib:window-border
355 (window-group-xparent
356 (bitmap-hunk-window-group *cursor-hunk*)))
357 *highlight-border-pixmap*)
358 ;; For complete gratuitous pseudo-generality, should force
359 ;; output on *current-highlighted-border* device too.
360 (xlib:display-force-output
361 (bitmap-device-display (device-hunk-device *cursor-hunk*)))))
362 (t (setf (xlib:window-border
363 (window-group-xparent
364 (bitmap-hunk-window-group *cursor-hunk*)))
365 *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