/[cmucl]/src/hemlock/bit-screen.lisp
ViewVC logotype

Contents of /src/hemlock/bit-screen.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Tue Dec 11 00:56:51 2001 UTC (12 years, 4 months ago) by pmai
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.17: +3 -3 lines
Fix redefinition of constants as special variables via defparameter,
as uncovered by the recent change to detect this.  Folded the larger
constants for MINIMUM-WINDOW-LINES and MINIMUM-WINDOW-COLUMNS into the
original constant definition, and elided the superfluous defparameter
for FONT-MAP-SIZE.  This seems to work for now.
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/bit-screen.lisp,v 1.18 2001/12/11 00:56:51 pmai Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Screen allocation functions.
13 ;;;
14 ;;; This is the screen management and event handlers for Hemlock under X.
15 ;;;
16 ;;; Written by Bill Chiles, Rob MacLachlan, and Blaine Burks.
17 ;;;
18
19 (in-package "HEMLOCK-INTERNALS")
20
21 (export '(make-xwindow-like-hwindow *create-window-hook* *delete-window-hook*
22 *random-typeout-hook* *create-initial-windows-hook*))
23
24
25 (declaim (special *echo-area-window*))
26
27 ;;; We have an internal notion of window groups on bitmap devices. Every
28 ;;; Hemlock window has a hunk slot which holds a structure with information
29 ;;; about physical real-estate on some device. Bitmap-hunks have an X window
30 ;;; and a window-group. The X window is a child of the window-group's window.
31 ;;; The echo area, pop-up display window, and the initial window are all in
32 ;;; their own group.
33 ;;;
34 ;;; MAKE-WINDOW splits the current window which is some child window in a group.
35 ;;; If the user supplied an X window, it becomes the parent window of some new
36 ;;; group, and we make a child for the Hemlock window. If the user supplies
37 ;;; ask-user, we prompt for a group/parent window. We link the hunks for
38 ;;; NEXT-WINDOW and PREVIOUS-WINDOW only within a group, so the group maintains
39 ;;; a stack of windows that always fill the entire group window.
40 ;;;
41
42 ;;; This is the object set for Hemlock windows. All types of incoming
43 ;;; X events on standard editing windows have the same handlers via this set.
44 ;;; We also include the group/parent windows in here, but they only handle
45 ;;; :configure-notify events.
46 ;;;
47 (defvar *hemlock-windows*
48 (system:make-object-set "Hemlock Windows" #'ext:default-clx-event-handler))
49
50
51
52 ;;;; Some window making parameters.
53
54 ;;; These could be parameters, but they have to be set after the display is
55 ;;; opened. These are set in INIT-BITMAP-SCREEN-MANAGER.
56
57 (defvar *default-background-pixel* nil
58 "Default background color. It defaults to white.")
59
60 (defvar *default-foreground-pixel* nil
61 "Default foreground color. It defaults to black.")
62
63 (defvar *foreground-background-xor* nil
64 "The LOGXOR of *default-background-pixel* and *default-foreground-pixel*.")
65
66 (defvar *default-border-pixmap* nil
67 "This is the default color of X window borders. It defaults to a
68 grey pattern.")
69
70 (defvar *highlight-border-pixmap* nil
71 "This is the color of the border of the current window when the mouse
72 cursor is over any Hemlock window.")
73
74
75
76 ;;;; Exposed region handling.
77
78 ;;; :exposure events are sent because we selected them. :graphics-exposure
79 ;;; events are generated because of a slot in our graphics contexts. These are
80 ;;; generated from using XLIB:COPY-AREA when the source could not be generated.
81 ;;; Also, :no-exposure events are sent when a :graphics-exposure event could
82 ;;; have been sent but wasn't.
83 ;;;
84 #|
85 ;;; This is an old handler that doesn't do anything clever about multiple
86 ;;; exposures.
87 (defun hunk-exposed-region (hunk &key y height &allow-other-keys)
88 (if (bitmap-hunk-lock hunk)
89 (setf (bitmap-hunk-trashed hunk) t)
90 (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)))
91 (when liftp (lift-cursor))
92 ;; (hunk-draw-top-border hunk)
93 (let* ((font-family (bitmap-hunk-font-family hunk))
94 (font-height (font-family-height font-family))
95 (co (font-family-cursor-y-offset font-family))
96 (start (truncate (- y hunk-top-border) font-height))
97 (end (ceiling (- (+ y height) hunk-top-border) font-height))
98 (start-bit (+ (* start font-height) co hunk-top-border))
99 (nheight (- (* (- end start) font-height) co))
100 (end-line (bitmap-hunk-end hunk)))
101 (declare (fixnum font-height co start end start-bit nheight))
102 (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit
103 :width (bitmap-hunk-width hunk) :height nheight)
104 (do ((dl (bitmap-hunk-start hunk) (cdr dl))
105 (i 0 (1+ i)))
106 ((or (eq dl end-line) (= i start))
107 (do ((i i (1+ i))
108 (dl dl (cdr dl)))
109 ((or (eq dl end-line) (= i end)))
110 (declare (fixnum i))
111 (hunk-write-line hunk (car dl) i)))
112 (declare (fixnum i)))
113 (when (and (bitmap-hunk-modeline-pos hunk)
114 (>= (the fixnum (+ nheight start-bit))
115 (the fixnum (bitmap-hunk-modeline-pos hunk))))
116 (hunk-replace-modeline hunk)))
117 (when liftp (drop-cursor)))))
118 |#
119
120 ;;; HUNK-EXPOSED-REGION redisplays the appropriate rectangle from the hunk
121 ;;; dis-lines. Don't do anything if the hunk is trashed since redisplay is
122 ;;; probably about to fix everything; specifically, this keeps new windows
123 ;;; from getting drawn twice (once for the exposure and once for being trashed).
124 ;;;
125 ;;; Exposure and graphics-exposure events pass in a different number of
126 ;;; arguments, with some the same but in a different order, so we just bind
127 ;;; and ignore foo, bar, baz, and quux.
128 ;;;
129 (defun hunk-exposed-region (hunk event-key event-window x y width height
130 foo bar &optional baz quux)
131 (declare (ignore event-key event-window x width foo bar baz quux))
132 (unless (bitmap-hunk-trashed hunk)
133 (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))
134 (display (bitmap-device-display (device-hunk-device hunk))))
135 (when liftp (lift-cursor))
136 (multiple-value-bind (y-peek height-peek)
137 (exposed-region-peek-event display
138 (bitmap-hunk-xwindow hunk))
139 (if y-peek
140 (let ((n (coelesce-exposed-regions hunk display
141 y height y-peek height-peek)))
142 (write-n-exposed-regions hunk n))
143 (write-one-exposed-region hunk y height)))
144 (xlib:display-force-output display)
145 (when liftp (drop-cursor)))))
146 ;;;
147 (ext:serve-exposure *hemlock-windows* #'hunk-exposed-region)
148 (ext:serve-graphics-exposure *hemlock-windows* #'hunk-exposed-region)
149
150
151 ;;; HUNK-NO-EXPOSURE handles this bullshit event that gets sent without its
152 ;;; being requested.
153 ;;;
154 (defun hunk-no-exposure (hunk event-key event-window major minor send-event-p)
155 (declare (ignore hunk event-key event-window major minor send-event-p))
156 t)
157 ;;;
158 (ext:serve-no-exposure *hemlock-windows* #'hunk-no-exposure)
159
160
161 ;;; EXPOSED-REGION-PEEK-EVENT returns the position and height of an :exposure
162 ;;; or :graphics-exposure event on win if one exists. If there are none, then
163 ;;; nil and nil are returned.
164 ;;;
165 (defun exposed-region-peek-event (display win)
166 (xlib:display-finish-output display)
167 (let ((result-y nil)
168 (result-height nil))
169 (xlib:process-event
170 display :timeout 0
171 :handler #'(lambda (&key event-key event-window window y height
172 &allow-other-keys)
173 (cond ((and (or (eq event-key :exposure)
174 (eq event-key :graphics-exposure))
175 (or (eq event-window win) (eq window win)))
176 (setf result-y y)
177 (setf result-height height)
178 t)
179 (t nil))))
180 (values result-y result-height)))
181
182 ;;; COELESCE-EXPOSED-REGIONS insert sorts exposed region events from the X
183 ;;; input queue into *coelesce-buffer*. Then the regions are merged into the
184 ;;; same number or fewer regions that are vertically distinct
185 ;;; (non-overlapping). When this function is called, one event has already
186 ;;; been popped from the queue, the first event that caused HUNK-EXPOSED-REGION
187 ;;; to be called. That information is passed in as y1 and height1. There is
188 ;;; a second event that also has already been popped from the queue, the
189 ;;; event resulting from peeking for multiple "exposure" events. That info
190 ;;; is passed in as y2 and height2.
191 ;;;
192 (defun coelesce-exposed-regions (hunk display y1 height1 y2 height2)
193 (let ((len 0))
194 (declare (fixnum len))
195 ;;
196 ;; Insert sort the exposeevents as we pick them off the event queue.
197 (let* ((font-family (bitmap-hunk-font-family hunk))
198 (font-height (font-family-height font-family))
199 (co (font-family-cursor-y-offset font-family))
200 (xwindow (bitmap-hunk-xwindow hunk)))
201 ;;
202 ;; Insert the region the exposedregion handler was called on.
203 (multiple-value-bind (start-line start-bit end-line expanded-height)
204 (exposed-region-bounds y1 height1 co font-height)
205 (setf len
206 (coelesce-buffer-insert start-bit start-line
207 expanded-height end-line len)))
208 ;;
209 ;; Peek for exposedregion events on xwindow, inserting them into
210 ;; the buffer.
211 (let ((y y2)
212 (height height2))
213 (loop
214 (multiple-value-bind (start-line start-bit end-line expanded-height)
215 (exposed-region-bounds y height co font-height)
216 (setf len
217 (coelesce-buffer-insert start-bit start-line
218 expanded-height end-line len)))
219 (multiple-value-setq (y height)
220 (exposed-region-peek-event display xwindow))
221 (unless y (return)))))
222 (coelesce-exposed-regions-merge len)))
223
224 ;;; *coelesce-buffer* is a vector of records used to sort exposure events on a
225 ;;; single hunk, so we can merge them into fewer, larger regions of exposure.
226 ;;; COELESCE-BUFFER-INSERT places elements in this buffer, and each element
227 ;;; is referenced with COELESCE-BUFFER-ELT. Each element of the coelescing
228 ;;; buffer has the following accessors defined:
229 ;;; COELESCE-BUFFER-ELT-START in pixels.
230 ;;; COELESCE-BUFFER-ELT-START-LINE in dis-lines.
231 ;;; COELESCE-BUFFER-ELT-HEIGHT in pixels.
232 ;;; COELESCE-BUFFER-ELT-END-LINE in dis-lines.
233 ;;; These are used by COELESCE-BUFFER-INSERT, COELESCE-EXPOSED-REGIONS-MERGE,
234 ;;; and WRITE-N-EXPOSED-REGIONS.
235
236 (defvar *coelesce-buffer-fill-ptr* 25)
237 (defvar *coelesce-buffer* (make-array *coelesce-buffer-fill-ptr*))
238 (dotimes (i *coelesce-buffer-fill-ptr*)
239 (setf (svref *coelesce-buffer* i) (make-array 4)))
240
241 (defmacro coelesce-buffer-elt-start (elt)
242 `(svref ,elt 0))
243 (defmacro coelesce-buffer-elt-start-line (elt)
244 `(svref ,elt 1))
245 (defmacro coelesce-buffer-elt-height (elt)
246 `(svref ,elt 2))
247 (defmacro coelesce-buffer-elt-end-line (elt)
248 `(svref ,elt 3))
249 (defmacro coelesce-buffer-elt (i)
250 `(svref *coelesce-buffer* ,i))
251
252 ;;; COELESCE-BUFFER-INSERT inserts an exposed region record into
253 ;;; *coelesce-buffer* such that start is less than all successive
254 ;;; elements. Returns the new length of the buffer.
255 ;;;
256 (defun coelesce-buffer-insert (start start-line height end-line len)
257 (declare (fixnum start start-line height end-line len))
258 ;;
259 ;; Add element if len is to fill pointer. If fill pointer is to buffer
260 ;; length, then grow buffer.
261 (when (= len (the fixnum *coelesce-buffer-fill-ptr*))
262 (when (= (the fixnum *coelesce-buffer-fill-ptr*)
263 (the fixnum (length (the simple-vector *coelesce-buffer*))))
264 (let ((new (make-array (ash (length (the simple-vector *coelesce-buffer*))
265 1))))
266 (replace (the simple-vector new) (the simple-vector *coelesce-buffer*)
267 :end1 *coelesce-buffer-fill-ptr*
268 :end2 *coelesce-buffer-fill-ptr*)
269 (setf *coelesce-buffer* new)))
270 (setf (coelesce-buffer-elt len) (make-array 4))
271 (incf *coelesce-buffer-fill-ptr*))
272 ;;
273 ;; Find point to insert record: start, start-line, height, and end-line.
274 (do ((i 0 (1+ i)))
275 ((= i len)
276 ;; Start is greater than all previous starts. Add it to the end.
277 (let ((region (coelesce-buffer-elt len)))
278 (setf (coelesce-buffer-elt-start region) start)
279 (setf (coelesce-buffer-elt-start-line region) start-line)
280 (setf (coelesce-buffer-elt-height region) height)
281 (setf (coelesce-buffer-elt-end-line region) end-line)))
282 (declare (fixnum i))
283 (when (< start (the fixnum
284 (coelesce-buffer-elt-start (coelesce-buffer-elt i))))
285 ;;
286 ;; Insert new element at i, using storage allocated at element len.
287 (let ((last (coelesce-buffer-elt len)))
288 (setf (coelesce-buffer-elt-start last) start)
289 (setf (coelesce-buffer-elt-start-line last) start-line)
290 (setf (coelesce-buffer-elt-height last) height)
291 (setf (coelesce-buffer-elt-end-line last) end-line)
292 ;;
293 ;; Shift elements after i (inclusively) to the right.
294 (do ((j (1- len) (1- j))
295 (k len j)
296 (terminus (1- i)))
297 ((= j terminus))
298 (declare (fixnum j k terminus))
299 (setf (coelesce-buffer-elt k) (coelesce-buffer-elt j)))
300 ;;
301 ;; Stash element to insert at i.
302 (setf (coelesce-buffer-elt i) last))
303 (return)))
304 (1+ len))
305
306
307 ;;; COELESCE-EXPOSED-REGIONS-MERGE merges/coelesces the regions in
308 ;;; *coelesce-buffer*. It takes the number of elements and returns the new
309 ;;; number of elements. The regions are examined one at a time relative to
310 ;;; the current one. The current region remains so, with next advancing
311 ;;; through the buffer, until a next region is found that does not overlap
312 ;;; and is not adjacent. When this happens, the current values are stored
313 ;;; in the current region, and the buffer's element after the current element
314 ;;; becomes current. The next element that was found not to be in contact
315 ;;; the old current element is stored in the new current element by copying
316 ;;; its values there. The buffer's elements always stay in place, and their
317 ;;; storage is re-used. After this process which makes the next region be
318 ;;; the current region, the next pointer is incremented.
319 ;;;
320 (defun coelesce-exposed-regions-merge (len)
321 (let* ((current 0)
322 (next 1)
323 (current-region (coelesce-buffer-elt 0))
324 (current-height (coelesce-buffer-elt-height current-region))
325 (current-end-line (coelesce-buffer-elt-end-line current-region))
326 (current-end-bit (+ (the fixnum
327 (coelesce-buffer-elt-start current-region))
328 current-height)))
329 (declare (fixnum current next current-height
330 current-end-line current-end-bit))
331 (loop
332 (let* ((next-region (coelesce-buffer-elt next))
333 (next-start (coelesce-buffer-elt-start next-region))
334 (next-height (coelesce-buffer-elt-height next-region))
335 (next-end-bit (+ next-start next-height)))
336 (declare (fixnum next-start next-height next-end-bit))
337 (cond ((<= next-start current-end-bit)
338 (let ((extra-height (- next-end-bit current-end-bit)))
339 (declare (fixnum extra-height))
340 ;; Maybe the next region is contained in the current.
341 (when (plusp extra-height)
342 (incf current-height extra-height)
343 (setf current-end-bit next-end-bit)
344 (setf current-end-line
345 (coelesce-buffer-elt-end-line next-region)))))
346 (t
347 ;;
348 ;; Update current record since next does not overlap
349 ;; with current.
350 (setf (coelesce-buffer-elt-height current-region)
351 current-height)
352 (setf (coelesce-buffer-elt-end-line current-region)
353 current-end-line)
354 ;;
355 ;; Move to new distinct region, copying data from next region.
356 (incf current)
357 (setf current-region (coelesce-buffer-elt current))
358 (setf (coelesce-buffer-elt-start current-region) next-start)
359 (setf (coelesce-buffer-elt-start-line current-region)
360 (coelesce-buffer-elt-start-line next-region))
361 (setf current-height next-height)
362 (setf current-end-bit next-end-bit)
363 (setf current-end-line
364 (coelesce-buffer-elt-end-line next-region)))))
365 (incf next)
366 (when (= next len)
367 (setf (coelesce-buffer-elt-height current-region) current-height)
368 (setf (coelesce-buffer-elt-end-line current-region) current-end-line)
369 (return)))
370 (1+ current)))
371
372 ;;; EXPOSED-REGION-BOUNDS returns as multiple values the first line affected,
373 ;;; the first possible bit affected (accounting for the cursor), the end line
374 ;;; affected, and the height of the region.
375 ;;;
376 (defun exposed-region-bounds (y height cursor-offset font-height)
377 (declare (fixnum y height cursor-offset font-height))
378 (let* ((start (truncate (the fixnum (- y hunk-top-border))
379 font-height))
380 (end (ceiling (the fixnum (- (the fixnum (+ y height))
381 hunk-top-border))
382 font-height)))
383 (values
384 start
385 (+ (the fixnum (* start font-height)) cursor-offset hunk-top-border)
386 end
387 (- (the fixnum (* (the fixnum (- end start)) font-height))
388 cursor-offset))))
389
390
391 (defun write-n-exposed-regions (hunk n)
392 (declare (fixnum n))
393 (let* (;; Loop constants.
394 (end-dl (bitmap-hunk-end hunk))
395 (xwindow (bitmap-hunk-xwindow hunk))
396 (hunk-width (bitmap-hunk-width hunk))
397 ;; Loop variables.
398 (dl (bitmap-hunk-start hunk))
399 (i 0)
400 (region (coelesce-buffer-elt 0))
401 (start-line (coelesce-buffer-elt-start-line region))
402 (start (coelesce-buffer-elt-start region))
403 (height (coelesce-buffer-elt-height region))
404 (end-line (coelesce-buffer-elt-end-line region))
405 (region-idx 0))
406 (declare (fixnum i start start-line height end-line region-idx))
407 (loop
408 (xlib:clear-area xwindow :x 0 :y start :width hunk-width :height height)
409 ;; Find this regions first line.
410 (loop
411 (when (or (eq dl end-dl) (= i start-line))
412 (return))
413 (incf i)
414 (setf dl (cdr dl)))
415 ;; Write this region's lines.
416 (loop
417 (when (or (eq dl end-dl) (= i end-line))
418 (return))
419 (hunk-write-line hunk (car dl) i)
420 (incf i)
421 (setf dl (cdr dl)))
422 ;; Get next region unless we're done.
423 (when (= (incf region-idx) n) (return))
424 (setf region (coelesce-buffer-elt region-idx))
425 (setf start (coelesce-buffer-elt-start region))
426 (setf start-line (coelesce-buffer-elt-start-line region))
427 (setf height (coelesce-buffer-elt-height region))
428 (setf end-line (coelesce-buffer-elt-end-line region)))
429 ;;
430 ;; Check for modeline exposure.
431 (setf region (coelesce-buffer-elt (1- n)))
432 (setf start (coelesce-buffer-elt-start region))
433 (setf height (coelesce-buffer-elt-height region))
434 (when (and (bitmap-hunk-modeline-pos hunk)
435 (> (+ start height)
436 (- (bitmap-hunk-modeline-pos hunk)
437 (bitmap-hunk-bottom-border hunk))))
438 (hunk-replace-modeline hunk)
439 (hunk-draw-bottom-border hunk))))
440
441 (defun write-one-exposed-region (hunk y height)
442 (let* ((font-family (bitmap-hunk-font-family hunk))
443 (font-height (font-family-height font-family))
444 (co (font-family-cursor-y-offset font-family))
445 (start-line (truncate (- y hunk-top-border) font-height))
446 (end-line (ceiling (- (+ y height) hunk-top-border) font-height))
447 (start-bit (+ (* start-line font-height) co hunk-top-border))
448 (nheight (- (* (- end-line start-line) font-height) co))
449 (hunk-end-line (bitmap-hunk-end hunk)))
450 (declare (fixnum font-height co start-line end-line start-bit nheight))
451 (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit
452 :width (bitmap-hunk-width hunk) :height nheight)
453 (do ((dl (bitmap-hunk-start hunk) (cdr dl))
454 (i 0 (1+ i)))
455 ((or (eq dl hunk-end-line) (= i start-line))
456 (do ((i i (1+ i))
457 (dl dl (cdr dl)))
458 ((or (eq dl hunk-end-line) (= i end-line)))
459 (declare (fixnum i))
460 (hunk-write-line hunk (car dl) i)))
461 (declare (fixnum i)))
462 (when (and (bitmap-hunk-modeline-pos hunk)
463 (> (+ start-bit nheight)
464 (- (bitmap-hunk-modeline-pos hunk)
465 (bitmap-hunk-bottom-border hunk))))
466 (hunk-replace-modeline hunk)
467 (hunk-draw-bottom-border hunk))))
468
469
470
471 ;;;; Resized window handling.
472
473 ;;; :configure-notify events are sent because we select :structure-notify.
474 ;;; This buys us a lot of events we have to write dummy handlers to ignore.
475 ;;;
476
477 ;;; HUNK-RECONFIGURED -- Internal.
478 ;;;
479 ;;; This must note that the hunk changed to prevent certain redisplay problems
480 ;;; with recentering the window that caused bogus lines to be drawn after the
481 ;;; actual visible text in the window. We must also indicate the hunk is
482 ;;; trashed to eliminate exposure event handling that comes after resizing.
483 ;;; This also causes a full redisplay on the window which is the easiest and
484 ;;; generally best looking thing.
485 ;;;
486 (defun hunk-reconfigured (object event-key event-window window x y width
487 height border-width above-sibling
488 override-redirect-p send-event-p)
489 (declare (ignore event-key event-window window x y border-width
490 above-sibling override-redirect-p send-event-p))
491 (typecase object
492 (bitmap-hunk
493 (when (or (/= width (bitmap-hunk-width object))
494 (/= height (bitmap-hunk-height object)))
495 (hunk-changed object width height nil)
496 ;; Under X11, don't redisplay since an exposure event is coming next.
497 (setf (bitmap-hunk-trashed object) t)))
498 (window-group
499 (let ((old-width (window-group-width object))
500 (old-height (window-group-height object)))
501 (when (or (/= width old-width) (/= height old-height))
502 (window-group-changed object width height))))))
503 ;;;
504 (ext:serve-configure-notify *hemlock-windows* #'hunk-reconfigured)
505
506
507 ;;; HUNK-IGNORE-EVENT ignores the following unrequested events. They all take
508 ;;; at least five arguments, but then there are up to four more optional.
509 ;;;
510 (defun hunk-ignore-event (hunk event-key event-window window one
511 &optional two three four five)
512 (declare (ignore hunk event-key event-window window one two three four five))
513 t)
514 ;;;
515 (ext:serve-destroy-notify *hemlock-windows* #'hunk-ignore-event)
516 (ext:serve-unmap-notify *hemlock-windows* #'hunk-ignore-event)
517 (ext:serve-map-notify *hemlock-windows* #'hunk-ignore-event)
518 (ext:serve-reparent-notify *hemlock-windows* #'hunk-ignore-event)
519 (ext:serve-gravity-notify *hemlock-windows* #'hunk-ignore-event)
520 (ext:serve-circulate-notify *hemlock-windows* #'hunk-ignore-event)
521 (ext:serve-client-message *hemlock-windows* #'hunk-ignore-event)
522
523
524 ;;;; Interface to X input events.
525
526 ;;; HUNK-KEY-INPUT and HUNK-MOUSE-INPUT.
527 ;;; Each key and mouse event is turned into a character via
528 ;;; EXT:TRANSLATE-CHARACTER or EXT:TRANSLATE-MOUSE-CHARACTER, either of which
529 ;;; may return nil. Nil is returned for input that is considered uninteresting
530 ;;; input; for example, shift and control.
531 ;;;
532
533 (defun hunk-key-input (hunk event-key event-window root child same-screen-p x y
534 root-x root-y modifiers time key-code send-event-p)
535 (declare (ignore event-key event-window root child same-screen-p root-x
536 root-y time send-event-p))
537 (hunk-process-input hunk
538 (ext:translate-key-event
539 (bitmap-device-display (device-hunk-device hunk))
540 key-code modifiers)
541 x y))
542 ;;;
543 (ext:serve-key-press *hemlock-windows* #'hunk-key-input)
544
545 (defun hunk-mouse-input (hunk event-key event-window root child same-screen-p x y
546 root-x root-y modifiers time key-code send-event-p)
547 (declare (ignore event-window root child same-screen-p root-x root-y
548 time send-event-p))
549 (hunk-process-input hunk
550 (ext:translate-mouse-key-event key-code modifiers
551 event-key)
552 x y))
553 ;;;
554 (ext:serve-button-press *hemlock-windows* #'hunk-mouse-input)
555 (ext:serve-button-release *hemlock-windows* #'hunk-mouse-input)
556
557 (defun hunk-process-input (hunk char x y)
558 (when char
559 (let* ((font-family (bitmap-hunk-font-family hunk))
560 (font-width (font-family-width font-family))
561 (font-height (font-family-height font-family))
562 (ml-pos (bitmap-hunk-modeline-pos hunk))
563 (height (bitmap-hunk-height hunk))
564 (width (bitmap-hunk-width hunk))
565 (handler (bitmap-hunk-input-handler hunk))
566 (char-width (bitmap-hunk-char-width hunk)))
567 (cond ((not (and (< -1 x width) (< -1 y height)))
568 (funcall handler hunk char nil nil))
569 ((and ml-pos (> y (- ml-pos (bitmap-hunk-bottom-border hunk))))
570 (funcall handler hunk char
571 ;; (/ width x) doesn't handle ends of thumb bar
572 ;; and eob right, so do a bunch of truncating.
573 (min (truncate x (truncate width char-width))
574 (1- char-width))
575 nil))
576 (t
577 (let* ((cx (truncate (- x hunk-left-border) font-width))
578 (temp (truncate (- y hunk-top-border) font-height))
579 (char-height (bitmap-hunk-char-height hunk))
580 ;; Extra bits below bottom line and above modeline and
581 ;; thumb bar are considered part of the bottom line since
582 ;; we have already picked off the y=nil case.
583 (cy (if (< temp char-height) temp (1- char-height))))
584 (if (and (< -1 cx char-width)
585 (< -1 cy))
586 (funcall handler hunk char cx cy)
587 (funcall handler hunk char nil nil))))))))
588
589
590
591 ;;;; Handling boundary crossing events.
592
593 ;;; Entering and leaving a window are handled basically the same except that it
594 ;;; is possible to get an entering event under X without getting an exiting
595 ;;; event; specifically, when the mouse is in a Hemlock window that is over
596 ;;; another window, and someone buries the top window, Hemlock only gets an
597 ;;; entering event on the lower window (no exiting event for the buried
598 ;;; window).
599 ;;;
600 ;;; :enter-notify and :leave-notify events are sent because we select
601 ;;; :enter-window and :leave-window events.
602 ;;;
603
604 (defun hunk-mouse-entered (hunk event-key event-window root child same-screen-p
605 x y root-x root-y state time mode kind send-event-p)
606 (declare (ignore event-key event-window child root same-screen-p
607 x y root-x root-y state time mode kind send-event-p))
608 (when (and *cursor-dropped* (not *hemlock-listener*))
609 (cursor-invert-center))
610 (setf *hemlock-listener* t)
611 (let ((current-hunk (window-hunk (current-window))))
612 (unless (and *current-highlighted-border*
613 (eq *current-highlighted-border* current-hunk))
614 (setf (xlib:window-border (window-group-xparent
615 (bitmap-hunk-window-group current-hunk)))
616 *highlight-border-pixmap*)
617 (xlib:display-force-output
618 (bitmap-device-display (device-hunk-device current-hunk)))
619 (setf *current-highlighted-border* current-hunk)))
620 (let ((window (bitmap-hunk-window hunk)))
621 (when window (invoke-hook ed::enter-window-hook window))))
622 ;;;
623 (ext:serve-enter-notify *hemlock-windows* #'hunk-mouse-entered)
624
625 (defun hunk-mouse-left (hunk event-key event-window root child same-screen-p
626 x y root-x root-y state time mode kind send-event-p)
627 (declare (ignore event-key event-window child root same-screen-p
628 x y root-x root-y state time mode kind send-event-p))
629 (setf *hemlock-listener* nil)
630 (when *cursor-dropped* (cursor-invert-center))
631 (when *current-highlighted-border*
632 (setf (xlib:window-border (window-group-xparent
633 (bitmap-hunk-window-group
634 *current-highlighted-border*)))
635 *default-border-pixmap*)
636 (xlib:display-force-output
637 (bitmap-device-display (device-hunk-device *current-highlighted-border*)))
638 (setf *current-highlighted-border* nil))
639 (let ((window (bitmap-hunk-window hunk)))
640 (when window (invoke-hook ed::exit-window-hook window))))
641 ;;;
642 (ext:serve-leave-notify *hemlock-windows* #'hunk-mouse-left)
643
644
645
646 ;;;; Making a Window.
647
648 (defparameter minimum-window-height 100
649 "If the window created by splitting a window would be shorter than this,
650 then we create an overlapped window the same size instead.")
651
652 ;;; The width must be that of a tab for the screen image builder, and the
653 ;;; height must be one line (two with a modeline).
654 ;;;
655 (defconstant minimum-window-lines 2
656 "Windows must have at least this many lines.")
657 (defconstant minimum-window-columns 10
658 "Windows must be at least this many characters wide.")
659
660 (eval-when (compile eval load)
661 (defconstant xwindow-border-width 2 "X border around X windows")
662 (defconstant xwindow-border-width*2 (* xwindow-border-width 2))
663 ); eval-when
664
665 ;;; We must name windows (set the "name" property) to get around a bug in
666 ;;; awm and twm. They will not handle menu clicks without a window having
667 ;;; a name. We set the name to this silly thing.
668 ;;;
669 (defvar *hemlock-window-count* 0)
670 ;;;
671 (defun new-hemlock-window-name ()
672 (let ((*print-base* 10))
673 (format nil "Hemlock ~S" (incf *hemlock-window-count*))))
674
675 (declaim (inline surplus-window-height surplus-window-height-w/-modeline))
676 ;;;
677 (defun surplus-window-height (thumb-bar-p)
678 (+ hunk-top-border (if thumb-bar-p
679 hunk-thumb-bar-bottom-border
680 hunk-bottom-border)))
681 ;;;
682 (defun surplus-window-height-w/-modeline (thumb-bar-p)
683 (+ (surplus-window-height thumb-bar-p)
684 hunk-modeline-top
685 hunk-modeline-bottom))
686
687
688 ;;; DEFAULT-CREATE-WINDOW-HOOK -- Internal.
689 ;;;
690 ;;; This is the default value for *create-window-hook*. It makes an X window
691 ;;; for a new group/parent on the given display possibly prompting the user.
692 ;;;
693 (defun default-create-window-hook (display x y width height name font-family
694 &optional modelinep thumb-bar-p)
695 (maybe-prompt-user-for-window
696 (xlib:screen-root (xlib:display-default-screen display))
697 x y width height font-family modelinep thumb-bar-p name))
698
699 ;;; MAYBE-PROMPT-USER-FOR-WINDOW -- Internal.
700 ;;;
701 ;;; This makes an X window and sets its standard properties according to
702 ;;; supplied values. When some of these are nil, the window manager should
703 ;;; prompt the user for those missing values when the window gets mapped. We
704 ;;; use this when making new group/parent windows. Returns the window without
705 ;;; mapping it.
706 ;;;
707 (defun maybe-prompt-user-for-window (root x y width height font-family
708 modelinep thumb-bar-p icon-name)
709 (let ((font-height (font-family-height font-family))
710 (font-width (font-family-width font-family))
711 (extra-y (surplus-window-height thumb-bar-p))
712 (extra-y-w/-modeline (surplus-window-height-w/-modeline thumb-bar-p)))
713 (create-window-with-properties
714 root x y
715 (if width (+ (* width font-width) hunk-left-border))
716 (if height
717 (if modelinep
718 (+ (* (1+ height) font-height) extra-y-w/-modeline)
719 (+ (* height font-height) extra-y)))
720 font-width font-height icon-name
721 (+ (* minimum-window-columns font-width) hunk-left-border)
722 (if modelinep
723 (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline)
724 (+ (* minimum-window-lines font-height) extra-y))
725 t)))
726
727 (defvar *create-window-hook* #'default-create-window-hook
728 "Hemlock calls this function when it makes a new X window for a new group.
729 It passes as arguments the X display, x (from MAKE-WINDOW), y (from
730 MAKE-WINDOW), width (from MAKE-WINDOW), height (from MAKE-WINDOW), a name
731 for the window's icon-name, font-family (from MAKE-WINDOW), modelinep (from
732 MAKE-WINDOW), and whether the window will have a thumb-bar meter. The
733 function returns a window or nil.")
734
735 ;;; BITMAP-MAKE-WINDOW -- Internal.
736 ;;;
737 (defun bitmap-make-window (device start modelinep window font-family
738 ask-user x y width-arg height-arg proportion)
739 (let* ((display (bitmap-device-display device))
740 (thumb-bar-p (value ed::thumb-bar-meter))
741 (hunk (make-bitmap-hunk
742 :font-family font-family
743 :end the-sentinel :trashed t
744 :input-handler #'window-input-handler
745 :device device
746 :thumb-bar-p (and modelinep thumb-bar-p))))
747 (multiple-value-bind
748 (xparent xwindow)
749 (maybe-make-x-window-and-parent window display start ask-user x y
750 width-arg height-arg font-family
751 modelinep thumb-bar-p proportion)
752 (unless xwindow (return-from bitmap-make-window nil))
753 (let ((window-group (make-window-group xparent
754 (xlib:drawable-width xparent)
755 (xlib:drawable-height xparent))))
756 (setf (bitmap-hunk-xwindow hunk) xwindow)
757 (setf (bitmap-hunk-window-group hunk) window-group)
758 (setf (bitmap-hunk-gcontext hunk)
759 (default-gcontext xwindow font-family))
760 ;;
761 ;; Select input and enable event service before showing the window.
762 (setf (xlib:window-event-mask xwindow) child-interesting-xevents-mask)
763 (setf (xlib:window-event-mask xparent) group-interesting-xevents-mask)
764 (add-xwindow-object xwindow hunk *hemlock-windows*)
765 (add-xwindow-object xparent window-group *hemlock-windows*))
766 (when xparent (xlib:map-window xparent))
767 (xlib:map-window xwindow)
768 (xlib:display-finish-output display)
769 ;; A window is not really mapped until it is viewable. It is said to be
770 ;; mapped if a map request has been sent whether it is handled or not.
771 (loop (when (and (eq (xlib:window-map-state xwindow) :viewable)
772 (eq (xlib:window-map-state xparent) :viewable))
773 (return)))
774 ;;
775 ;; Find out how big it is...
776 (xlib:with-state (xwindow)
777 (set-hunk-size hunk (xlib:drawable-width xwindow)
778 (xlib:drawable-height xwindow) modelinep)))
779 (setf (bitmap-hunk-window hunk)
780 (window-for-hunk hunk start modelinep))
781 ;; If window is non-nil, then it is a new group/parent window, so don't
782 ;; link it into the current window's group. When ask-user is non-nil,
783 ;; we make a new group too.
784 (cond ((or window ask-user)
785 ;; This occurs when we make the world's first Hemlock window.
786 (unless *current-window*
787 (setq *current-window* (bitmap-hunk-window hunk)))
788 (setf (bitmap-hunk-previous hunk) hunk)
789 (setf (bitmap-hunk-next hunk) hunk))
790 (t
791 (let ((h (window-hunk *current-window*)))
792 (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk)
793 (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk)
794 (setf (bitmap-hunk-previous hunk) h))))
795 (push hunk (device-hunks device))
796 (bitmap-hunk-window hunk)))
797
798 ;;; MAYBE-MAKE-X-WINDOW-AND-PARENT -- Internal.
799 ;;;
800 ;;; BITMAP-MAKE-WINDOW calls this. If xparent is non-nil, we clear it and
801 ;;; return it with a child that fills it. If xparent is nil, and ask-user is
802 ;;; non-nil, then we invoke *create-window-hook* to get a parent window and
803 ;;; return it with a child that fills it. By default, we make a child in the
804 ;;; CURRENT-WINDOW's parent.
805 ;;;
806 (defun maybe-make-x-window-and-parent (xparent display start ask-user x y width
807 height font-family modelinep thumb-p
808 proportion)
809 (let ((icon-name (buffer-name (line-buffer (mark-line start)))))
810 (cond (xparent
811 (check-type xparent xlib:window)
812 (let ((width (xlib:drawable-width xparent))
813 (height (xlib:drawable-height xparent)))
814 (xlib:clear-area xparent :width width :height height)
815 (modify-parent-properties :set xparent modelinep thumb-p
816 (font-family-width font-family)
817 (font-family-height font-family))
818 (values xparent (xwindow-for-xparent xparent icon-name))))
819 (ask-user
820 (let ((xparent (funcall *create-window-hook*
821 display x y width height icon-name
822 font-family modelinep thumb-p)))
823 (values xparent (xwindow-for-xparent xparent icon-name))))
824 (t
825 (let ((xparent (window-group-xparent
826 (bitmap-hunk-window-group
827 (window-hunk (current-window))))))
828 (values xparent
829 (create-window-from-current
830 proportion font-family modelinep thumb-p xparent
831 icon-name)))))))
832
833 ;;; XWINDOW-FOR-XPARENT -- Internal.
834 ;;;
835 ;;; This returns a child of xparent that completely fills that parent window.
836 ;;; We supply the font-width and font-height as nil because these are useless
837 ;;; for child windows.
838 ;;;
839 (defun xwindow-for-xparent (xparent icon-name)
840 (xlib:with-state (xparent)
841 (create-window-with-properties xparent 0 0
842 (xlib:drawable-width xparent)
843 (xlib:drawable-height xparent)
844 nil nil icon-name)))
845
846 ;;; CREATE-WINDOW-FROM-CURRENT -- Internal.
847 ;;;
848 ;;; This makes a child window on parent by splitting the current window. If
849 ;;; the result will be too small, this returns nil. If the current window's
850 ;;; height is odd, the extra pixel stays with it, and the new window is one
851 ;;; pixel smaller.
852 ;;;
853 (defun create-window-from-current (proportion font-family modelinep thumb-p
854 parent icon-name)
855 (let* ((cur-hunk (window-hunk *current-window*))
856 (cwin (bitmap-hunk-xwindow cur-hunk)))
857 ;; Compute current window's height and take a proportion of it.
858 (xlib:with-state (cwin)
859 (let* ((cw (xlib:drawable-width cwin))
860 (ch (xlib:drawable-height cwin))
861 (cy (xlib:drawable-y cwin))
862 (new-ch (truncate (* ch (- 1 proportion))))
863 (font-height (font-family-height font-family))
864 (font-width (font-family-width font-family))
865 (cwin-min (minimum-window-height
866 (font-family-height
867 (bitmap-hunk-font-family cur-hunk))
868 (bitmap-hunk-modeline-pos cur-hunk)
869 (bitmap-hunk-thumb-bar-p cur-hunk)))
870 (new-min (minimum-window-height font-height modelinep
871 thumb-p)))
872 (declare (fixnum cw cy ch new-ch))
873 ;; See if we have room for a new window. This should really
874 ;; check the current window and the new one against their
875 ;; relative fonts and the minimal window columns and line
876 ;; (including whether there is a modeline).
877 (if (and (> new-ch cwin-min)
878 (> (- ch new-ch) new-min))
879 (let ((win (create-window-with-properties
880 parent 0 (+ cy new-ch)
881 cw (- ch new-ch) font-width font-height
882 icon-name)))
883 ;; No need to reshape current Hemlock window structure here
884 ;; since this call will send an appropriate event.
885 (setf (xlib:drawable-height cwin) new-ch)
886 ;; Set hints on parent, so the user can't resize it to be
887 ;; smaller than what will hold the current number of
888 ;; children.
889 (modify-parent-properties :add parent modelinep
890 thumb-p
891 (font-family-width font-family)
892 font-height)
893 win)
894 nil)))))
895
896
897 ;;; MAKE-XWINDOW-LIKE-HWINDOW -- Interface.
898 ;;;
899 ;;; The window name is set to get around an awm and twm bug that inhibits menu
900 ;;; clicks unless the window has a name; this could be used better.
901 ;;;
902 (defun make-xwindow-like-hwindow (window)
903 "This returns an group/parent xwindow with dimensions suitable for making a
904 Hemlock window like the argument window. The new window's position should
905 be the same as the argument window's position relative to the root. When
906 setting standard properties, we set x, y, width, and height to tell window
907 managers to put the window where we intend without querying the user."
908 (let* ((hunk (window-hunk window))
909 (font-family (bitmap-hunk-font-family hunk))
910 (xwin (bitmap-hunk-xwindow hunk)))
911 (multiple-value-bind (x y)
912 (window-root-xy xwin)
913 (create-window-with-properties
914 (xlib:screen-root (xlib:display-default-screen
915 (bitmap-device-display (device-hunk-device hunk))))
916 x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk)
917 (font-family-width font-family)
918 (font-family-height font-family)
919 (buffer-name (window-buffer window))
920 ;; When the user hands this window to MAKE-WINDOW, it will set the
921 ;; minimum width and height properties.
922 nil nil
923 t))))
924
925
926
927 ;;;; Deleting a window.
928
929 ;;; DEFAULT-DELETE-WINDOW-HOOK -- Internal.
930 ;;;
931 (defun default-delete-window-hook (xparent)
932 (xlib:destroy-window xparent))
933 ;;;
934 (defvar *delete-window-hook* #'default-delete-window-hook
935 "Hemlock calls this function to delete an X group/parent window. It passes
936 the X window as an argument.")
937
938
939 ;;; BITMAP-DELETE-WINDOW -- Internal
940 ;;;
941 ;;;
942 (defun bitmap-delete-window (window)
943 (let* ((hunk (window-hunk window))
944 (xwindow (bitmap-hunk-xwindow hunk))
945 (xparent (window-group-xparent (bitmap-hunk-window-group hunk)))
946 (display (bitmap-device-display (device-hunk-device hunk))))
947 (remove-xwindow-object xwindow)
948 (setq *window-list* (delete window *window-list*))
949 (when (eq *current-highlighted-border* hunk)
950 (setf *current-highlighted-border* nil))
951 (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor))
952 (xlib:display-force-output display)
953 (bitmap-delete-and-reclaim-window-space xwindow window)
954 (loop (unless (deleting-window-drop-event display xwindow) (return)))
955 (let ((device (device-hunk-device hunk)))
956 (setf (device-hunks device) (delete hunk (device-hunks device))))
957 (cond ((eq hunk (bitmap-hunk-next hunk))
958 ;; Is this the last window in the group?
959 (remove-xwindow-object xparent)
960 (xlib:display-force-output display)
961 (funcall *delete-window-hook* xparent)
962 (loop (unless (deleting-window-drop-event display xparent)
963 (return)))
964 (let ((window (find-if-not #'(lambda (window)
965 (eq window *echo-area-window*))
966 *window-list*)))
967 (setf (current-buffer) (window-buffer window)
968 (current-window) window)))
969 (t
970 (modify-parent-properties :delete xparent
971 (bitmap-hunk-modeline-pos hunk)
972 (bitmap-hunk-thumb-bar-p hunk)
973 (font-family-width
974 (bitmap-hunk-font-family hunk))
975 (font-family-height
976 (bitmap-hunk-font-family hunk)))
977 (let ((next (bitmap-hunk-next hunk))
978 (prev (bitmap-hunk-previous hunk)))
979 (setf (bitmap-hunk-next prev) next)
980 (setf (bitmap-hunk-previous next) prev))))
981 (let ((buffer (window-buffer window)))
982 (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))))
983 nil)
984
985 ;;; BITMAP-DELETE-AND-RECLAIM-WINDOW-SPACE -- Internal.
986 ;;;
987 ;;; This destroys the X window after obtaining its necessary state information.
988 ;;; If the previous or next window (in that order) is "stacked" over or under
989 ;;; the target window, then it is grown to fill in the newly opened space. We
990 ;;; fetch all the necessary configuration data up front, so we don't have to
991 ;;; call XLIB:DESTROY-WINDOW while in the XLIB:WITH-STATE.
992 ;;;
993 (defun bitmap-delete-and-reclaim-window-space (xwindow hwindow)
994 (multiple-value-bind (y height)
995 (xlib:with-state (xwindow)
996 (values (xlib:drawable-y xwindow)
997 (xlib:drawable-height xwindow)))
998 (xlib:destroy-window xwindow)
999 (let ((hunk (window-hunk hwindow)))
1000 (xlib:free-gcontext (bitmap-hunk-gcontext hunk))
1001 (unless (eq hunk (bitmap-hunk-next hunk))
1002 (unless (maybe-merge-with-previous-window hunk y height)
1003 (merge-with-next-window hunk y height))))))
1004
1005 ;;; MAYBE-MERGE-WITH-PREVIOUS-WINDOW -- Internal.
1006 ;;;
1007 ;;; This returns non-nil when it grows the previous hunk to include the
1008 ;;; argument hunk's screen space.
1009 ;;;
1010 (defun maybe-merge-with-previous-window (hunk y h)
1011 (declare (fixnum y h))
1012 (let* ((prev (bitmap-hunk-previous hunk))
1013 (prev-xwin (bitmap-hunk-xwindow prev)))
1014 (xlib:with-state (prev-xwin)
1015 (if (< (xlib:drawable-y prev-xwin) y)
1016 (incf (xlib:drawable-height prev-xwin) h)))))
1017
1018 ;;; MERGE-WITH-NEXT-WINDOW -- Internal.
1019 ;;;
1020 ;;; This trys to grow the next hunk's window to make use of the space created
1021 ;;; by deleting hunk's window. If this is possible, then we must also move the
1022 ;;; next window up to where hunk's window was.
1023 ;;;
1024 ;;; When we reconfigure the window, we must set the hunk trashed. This is a
1025 ;;; hack since twm is broken again and is sending exposure events before
1026 ;;; reconfigure notifications. Hemlock relies on the protocol's statement that
1027 ;;; reconfigures come before exposures to set the hunk trashed before getting
1028 ;;; the exposure. For now, we'll do it here too.
1029 ;;;
1030 (defun merge-with-next-window (hunk y h)
1031 (declare (fixnum y h))
1032 (let* ((next (bitmap-hunk-next hunk))
1033 (next-xwin (bitmap-hunk-xwindow next)))
1034 ;; Fetch height before setting y to save an extra round trip to the X
1035 ;; server.
1036 (let ((next-h (xlib:drawable-height next-xwin)))
1037 (setf (xlib:drawable-y next-xwin) y)
1038 (setf (xlib:drawable-height next-xwin) (+ next-h h)))
1039 (setf (bitmap-hunk-trashed next) t)
1040 (let ((hints (xlib:wm-normal-hints next-xwin)))
1041 (setf (xlib:wm-size-hints-y hints) y)
1042 (setf (xlib:wm-normal-hints next-xwin) hints))))
1043
1044
1045 ;;; DELETING-WINDOW-DROP-EVENT -- Internal.
1046 ;;;
1047 ;;; This checks for any events on win. If there is one, remove it from the
1048 ;;; queue and return t. Otherwise, return nil.
1049 ;;;
1050 (defun deleting-window-drop-event (display win)
1051 (xlib:display-finish-output display)
1052 (let ((result nil))
1053 (xlib:process-event
1054 display :timeout 0
1055 :handler #'(lambda (&key event-window window &allow-other-keys)
1056 (if (or (eq event-window win) (eq window win))
1057 (setf result t)
1058 nil)))
1059 result))
1060
1061
1062 ;;; MODIFY-PARENT-PROPERTIES -- Internal.
1063 ;;;
1064 ;;; This adds or deletes from xparent's min-height and min-width hints, so the
1065 ;;; window manager will hopefully prevent users from making a window group too
1066 ;;; small to hold all the windows in it. We add to the height when we split
1067 ;;; windows making additional ones, and we delete from it when we delete a
1068 ;;; window.
1069 ;;;
1070 ;;; NOTE, THIS FAILS TO MAINTAIN THE WIDTH CORRECTLY. We need to maintain the
1071 ;;; width as the MAX of all the windows' minimal widths. A window's minimal
1072 ;;; width is its font's width multiplied by minimum-window-columns.
1073 ;;;
1074 (defun modify-parent-properties (type xparent modelinep thumb-p
1075 font-width font-height)
1076 (let ((hints (xlib:wm-normal-hints xparent)))
1077 (xlib:set-wm-properties
1078 xparent
1079 :resource-name "Hemlock"
1080 :x (xlib:wm-size-hints-x hints)
1081 :y (xlib:wm-size-hints-y hints)
1082 :width (xlib:drawable-width xparent)
1083 :height (xlib:drawable-height xparent)
1084 :user-specified-position-p t
1085 :user-specified-size-p t
1086 :width-inc (xlib:wm-size-hints-width-inc hints)
1087 :height-inc (xlib:wm-size-hints-height-inc hints)
1088 :min-width (or (xlib:wm-size-hints-min-width hints)
1089 (+ (* minimum-window-columns font-width) hunk-left-border))
1090 :min-height
1091 (let ((delta (minimum-window-height font-height modelinep thumb-p)))
1092 (ecase type
1093 (:delete (- (xlib:wm-size-hints-min-height hints) delta))
1094 (:add (+ (or (xlib:wm-size-hints-min-height hints) 0)
1095 delta))
1096 (:set delta))))))
1097
1098 ;;; MINIMUM-WINDOW-HEIGHT -- Internal.
1099 ;;;
1100 ;;; This returns the minimum height necessary for a window given some of its
1101 ;;; parameters. This is the number of lines times font-height plus any extra
1102 ;;; pixels for aesthetics.
1103 ;;;
1104 (defun minimum-window-height (font-height modelinep thumb-p)
1105 (if modelinep
1106 (+ (* (1+ minimum-window-lines) font-height)
1107 (surplus-window-height-w/-modeline thumb-p))
1108 (+ (* minimum-window-lines font-height)
1109 (surplus-window-height thumb-p))))
1110
1111
1112
1113 ;;;; Next and Previous windows.
1114
1115 (defun bitmap-next-window (window)
1116 "Return the next window after Window, wrapping around if Window is the
1117 bottom window."
1118 (check-type window window)
1119 (bitmap-hunk-window (bitmap-hunk-next (window-hunk window))))
1120
1121 (defun bitmap-previous-window (window)
1122 "Return the previous window after Window, wrapping around if Window is the
1123 top window."
1124 (check-type window window)
1125 (bitmap-hunk-window (bitmap-hunk-previous (window-hunk window))))
1126
1127
1128
1129 ;;;; Setting window width and height.
1130
1131 ;;; %SET-WINDOW-WIDTH -- Internal
1132 ;;;
1133 ;;; Since we don't support non-full-width windows, this does nothing.
1134 ;;;
1135 (defun %set-window-width (window new-value)
1136 (declare (ignore window))
1137 new-value)
1138
1139 ;;; %SET-WINDOW-HEIGHT -- Internal
1140 ;;;
1141 ;;; Can't change window height either.
1142 ;;;
1143 (defun %set-window-height (window new-value)
1144 (declare (ignore window))
1145 new-value)
1146
1147
1148
1149 ;;;; Random Typeout
1150
1151 ;;; Random typeout is done to a bitmap-hunk-output-stream
1152 ;;; (Bitmap-Hunk-Stream.Lisp). These streams have an associated hunk
1153 ;;; that is used for its font-family, foreground and background color,
1154 ;;; and X window pointer. The hunk is not associated with any Hemlock
1155 ;;; window, and the low level painting routines that use hunk dimensions
1156 ;;; are not used for output. The X window is resized as necessary with
1157 ;;; each use, but the hunk is only registered for input and boundary
1158 ;;; crossing event service; therefore, it never gets exposure or changed
1159 ;;; notifications.
1160
1161 ;;; These are set in INIT-BITMAP-SCREEN-MANAGER.
1162 ;;;
1163 (defvar *random-typeout-start-x* 0
1164 "Where we put the the random typeout window.")
1165 (defvar *random-typeout-start-y* 0
1166 "Where we put the the random typeout window.")
1167 (defvar *random-typeout-start-width* 0
1168 "How wide the random typeout window is.")
1169
1170
1171 ;;; DEFAULT-RANDOM-TYPEOUT-HOOK -- Internal
1172 ;;;
1173 ;;; The default hook-function for random typeout. Nothing very fancy
1174 ;;; for now. If not given a window, makes one on top of the initial
1175 ;;; Hemlock window using specials set in INIT-BITMAP-SCREEN-MANAGER. If
1176 ;;; given a window, we will change the height subject to the constraint
1177 ;;; that the bottom won't be off the screen. Any resulting window has
1178 ;;; input and boundary crossing events selected, a hemlock cursor defined,
1179 ;;; and is mapped.
1180 ;;;
1181 (defun default-random-typeout-hook (device window height)
1182 (declare (fixnum height))
1183 (let* ((display (bitmap-device-display device))
1184 (root (xlib:screen-root (xlib:display-default-screen display)))
1185 (full-height (xlib:drawable-height root))
1186 (actual-height (if window
1187 (multiple-value-bind (x y) (window-root-xy window)
1188 (declare (ignore x) (fixnum y))
1189 (min (- full-height y xwindow-border-width*2)
1190 height))
1191 (min (- full-height *random-typeout-start-y*
1192 xwindow-border-width*2)
1193 height)))
1194 (win (cond (window
1195 (setf (xlib:drawable-height window) actual-height)
1196 window)
1197 (t
1198 (let ((win (xlib:create-window
1199 :parent root
1200 :x *random-typeout-start-x*
1201 :y *random-typeout-start-y*
1202 :width *random-typeout-start-width*
1203 :height actual-height
1204 :background *default-background-pixel*
1205 :border-width xwindow-border-width
1206 :border *default-border-pixmap*
1207 :event-mask random-typeout-xevents-mask
1208 :override-redirect :on :class :input-output
1209 :cursor *hemlock-cursor*)))
1210 (xlib:set-wm-properties
1211 win :name "Pop-up Display" :icon-name "Pop-up Display"
1212 :resource-name "Hemlock"
1213 :x *random-typeout-start-x*
1214 :y *random-typeout-start-y*
1215 :width *random-typeout-start-width*
1216 :height actual-height
1217 :user-specified-position-p t :user-specified-size-p t
1218 ;; Tell OpenLook pseudo-X11 server we want input.
1219 :input :on)
1220 win))))
1221 (gcontext (if (not window) (default-gcontext win))))
1222 (values win gcontext)))
1223
1224 (defvar *random-typeout-hook* #'default-random-typeout-hook
1225 "This function is called when a window is needed to display random typeout.
1226 It is called with the Hemlock device, a pre-existing window or NIL, and the
1227 number of pixels needed to display the number of lines requested in
1228 WITH-RANDOM-TYPEOUT. It should return a window, and if a new window was
1229 created, then a gcontext must be returned as the second value.")
1230
1231 ;;; BITMAP-RANDOM-TYPEOUT-SETUP -- Internal
1232 ;;;
1233 ;;; This function is called by the with-random-typeout macro to
1234 ;;; to set things up. It calls the *Random-Typeout-Hook* to get a window
1235 ;;; to work with, and then adjusts the random typeout stream's data-structures
1236 ;;; to match.
1237 ;;;
1238 (defun bitmap-random-typeout-setup (device stream height)
1239 (let* ((*more-prompt-action* :empty)
1240 (hwin-exists-p (random-typeout-stream-window stream))
1241 (hwindow (if hwin-exists-p
1242 (change-bitmap-random-typeout-window hwin-exists-p height)
1243 (setf (random-typeout-stream-window stream)
1244 (make-bitmap-random-typeout-window
1245 device
1246 (buffer-start-mark
1247 (line-buffer
1248 (mark-line (random-typeout-stream-mark stream))))
1249 height)))))
1250 (let ((xwindow (bitmap-hunk-xwindow (window-hunk hwindow)))
1251 (display (bitmap-device-display device)))
1252 (xlib:display-finish-output display)
1253 (loop
1254 (unless (xlib:event-case (display :timeout 0)
1255 (:exposure (event-window)
1256 (eq event-window xwindow))
1257 (t () nil))
1258 (return))))))
1259
1260 (defun change-bitmap-random-typeout-window (hwindow height)
1261 (update-modeline-field (window-buffer hwindow) hwindow :more-prompt)
1262 (let* ((hunk (window-hunk hwindow))
1263 (xwin (bitmap-hunk-xwindow hunk)))
1264 ;;
1265 ;; *random-typeout-hook* sets the window's height to the right value.
1266 (funcall *random-typeout-hook* (device-hunk-device hunk) xwin
1267 (+ (* height (font-family-height (bitmap-hunk-font-family hunk)))
1268 hunk-top-border (bitmap-hunk-bottom-border hunk)
1269 hunk-modeline-top hunk-modeline-bottom))
1270 (xlib:with-state (xwin)
1271 (hunk-changed hunk (xlib:drawable-width xwin) (xlib:drawable-height xwin)
1272 nil))
1273 ;;
1274 ;; We push this on here because we took it out the last time we cleaned up.
1275 (push hwindow (buffer-windows (window-buffer hwindow)))
1276 (setf (bitmap-hunk-trashed hunk) t)
1277 (xlib:map-window xwin)
1278 (setf (xlib:window-priority xwin) :above))
1279 hwindow)
1280
1281 (defun make-bitmap-random-typeout-window (device mark height)
1282 (let* ((display (bitmap-device-display device))
1283 (hunk (make-bitmap-hunk
1284 :font-family *default-font-family*
1285 :end the-sentinel :trashed t
1286 :input-handler #'window-input-handler
1287 :device device :thumb-bar-p nil)))
1288 (multiple-value-bind
1289 (xwindow gcontext)
1290 (funcall *random-typeout-hook*
1291 device (bitmap-hunk-xwindow hunk)
1292 (+ (* height (font-family-height *default-font-family*))
1293 hunk-top-border (bitmap-hunk-bottom-border hunk)
1294 hunk-modeline-top hunk-modeline-bottom))
1295 ;;
1296 ;; When gcontext, we just made the window, so tie some stuff together.
1297 (when gcontext
1298 (setf (xlib:gcontext-font gcontext)
1299 (svref (font-family-map *default-font-family*) 0))
1300 (setf (bitmap-hunk-xwindow hunk) xwindow)
1301 (setf (bitmap-hunk-gcontext hunk) gcontext)
1302 ;;
1303 ;; Select input and enable event service before showing the window.
1304 (setf (xlib:window-event-mask xwindow) random-typeout-xevents-mask)
1305 (add-xwindow-object xwindow hunk *hemlock-windows*))
1306 ;;
1307 ;; Put the window on the screen so it's visible and we can know the size.
1308 (xlib:map-window xwindow)
1309 (xlib:display-finish-output display)
1310 ;; A window is not really mapped until it is viewable (not visible).
1311 ;; It is said to be mapped if a map request has been sent whether it
1312 ;; is handled or not.
1313 (loop (when (eq (xlib:window-map-state xwindow) :viewable)
1314 (return)))
1315 (xlib:with-state (xwindow)
1316 (set-hunk-size hunk (xlib:drawable-width xwindow)
1317 (xlib:drawable-height xwindow) t))
1318 ;;
1319 ;; Get a Hemlock window and hide it from the rest of Hemlock.
1320 (let ((hwin (window-for-hunk hunk mark *random-typeout-ml-fields*)))
1321 (update-modeline-field (window-buffer hwin) hwin :more-prompt)
1322 (setf (bitmap-hunk-window hunk) hwin)
1323 (setf *window-list* (delete hwin *window-list*))
1324 hwin))))
1325
1326
1327 ;;; RANDOM-TYPEOUT-CLEANUP -- Internal
1328 ;;;
1329 ;;; Clean up after random typeout. This just removes the window from
1330 ;;; the screen and sets the more-prompt action back to normal.
1331 ;;;
1332 (defun bitmap-random-typeout-cleanup (stream degree)
1333 (when degree
1334 (xlib:unmap-window (bitmap-hunk-xwindow
1335 (window-hunk (random-typeout-stream-window stream))))))
1336
1337
1338
1339 ;;;; Initialization.
1340
1341 ;;; DEFAULT-CREATE-INITIAL-WINDOWS-HOOK makes the initial windows, main and
1342 ;;; echo. The main window is made according to "Default Initial Window X",
1343 ;;; "Default Initial Window Y", "Default Initial Window Width", and "Default
1344 ;;; Initial Window Height", prompting the user for any unspecified components.
1345 ;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO is called to return the location and
1346 ;;; size of the echo area including how big its font is, and the main xwindow
1347 ;;; is potentially modified by this function. The window name is set to get
1348 ;;; around an awm and twm bug that inhibits menu clicks unless the window has a
1349 ;;; name; this could be used better.
1350 ;;;
1351 (defun default-create-initial-windows-hook (device)
1352 (let ((root (xlib:screen-root (xlib:display-default-screen
1353 (bitmap-device-display device)))))
1354 (let* ((xwindow (maybe-prompt-user-for-window
1355 root
1356 (value ed::default-initial-window-x)
1357 (value ed::default-initial-window-y)
1358 (value ed::default-initial-window-width)
1359 (value ed::default-initial-window-height)
1360 *default-font-family*
1361 t ;modelinep
1362 (value ed::thumb-bar-meter)
1363 "Hemlock")))
1364 (setf (xlib:window-border xwindow) *highlight-border-pixmap*)
1365 (let ((main-win (make-window (buffer-start-mark *current-buffer*)
1366 :device device
1367 :window xwindow)))
1368 (multiple-value-bind
1369 (echo-x echo-y echo-width echo-height)
1370 (default-create-initial-windows-echo
1371 (xlib:drawable-height root)
1372 (window-hunk main-win))
1373 (let ((echo-xwin (make-echo-xwindow root echo-x echo-y echo-width
1374 echo-height)))
1375 (setf *echo-area-window*
1376 (hlet ((ed::thumb-bar-meter nil))
1377 (make-window
1378 (buffer-start-mark *echo-area-buffer*)
1379 :device device :modelinep t
1380 :window echo-xwin)))))
1381 (setf *current-window* main-win)))))
1382
1383 ;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as
1384 ;;; the main window and places it directly under it. If the echo area does not
1385 ;;; fit on the screen, we change the main window to make it fit. There is
1386 ;;; a problem in computing main-xwin's x and y relative to the root window
1387 ;;; which is where we line up the echo and main windows. Some losing window
1388 ;;; managers (awm and twm) reparent the window, so we have to make sure
1389 ;;; main-xwin's x and y are relative to the root and not some false parent.
1390 ;;;
1391 (defun default-create-initial-windows-echo (full-height hunk)
1392 (declare (fixnum full-height))
1393 (let ((font-family (bitmap-hunk-font-family hunk))
1394 (xwindow (bitmap-hunk-xwindow hunk))
1395 (xparent (window-group-xparent (bitmap-hunk-window-group hunk))))
1396 (xlib:with-state (xwindow)
1397 (let ((w (xlib:drawable-width xwindow))
1398 (h (xlib:drawable-height xwindow)))
1399 (declare (fixnum w h))
1400 (multiple-value-bind (x y)
1401 (window-root-xy xwindow
1402 (xlib:drawable-x xwindow)
1403 (xlib:drawable-y xwindow))
1404 (declare (fixnum x y))
1405 (let* ((ff-height (font-family-height font-family))
1406 (ff-width (font-family-width font-family))
1407 (echo-height (+ (* ff-height 4)
1408 hunk-top-border hunk-bottom-border
1409 hunk-modeline-top hunk-modeline-bottom)))
1410 (declare (fixnum echo-height))
1411 (if (<= (+ y h echo-height xwindow-border-width*2) full-height)
1412 (values x (+ y h xwindow-border-width*2)
1413 w echo-height ff-width ff-height)
1414 (let* ((newh (- full-height y echo-height xwindow-border-width*2
1415 ;; Since y is really the outside y, subtract
1416 ;; two more borders, so the echo area's borders
1417 ;; both appear on the screen.
1418 xwindow-border-width*2)))
1419 (setf (xlib:drawable-height xparent) newh)
1420 (values x (+ y newh xwindow-border-width*2)
1421 w echo-height ff-width ff-height)))))))))
1422
1423 (defvar *create-initial-windows-hook* #'default-create-initial-windows-hook
1424 "Hemlock uses this function when it initializes the screen manager to make
1425 the first windows, typically the main and echo area windows. It takes a
1426 Hemlock device as a required argument. It sets *current-window* and
1427 *echo-area-window*.")
1428
1429 (defun make-echo-xwindow (root x y width height)
1430 (let* ((font-width (font-family-width *default-font-family*))
1431 (font-height (font-family-height *default-font-family*)))
1432 (create-window-with-properties root x y width height
1433 font-width font-height
1434 "Echo Area" nil nil t)))
1435
1436 (defun init-bitmap-screen-manager (display)
1437 ;;
1438 ;; Setup stuff for X interaction.
1439 (cond ((value ed::reverse-video)
1440 (setf *default-background-pixel*
1441 (xlib:screen-black-pixel (xlib:display-default-screen display)))
1442 (setf *default-foreground-pixel*
1443 (xlib:screen-white-pixel (xlib:display-default-screen display)))
1444 (setf *cursor-background-color* (make-black-color))
1445 (setf *cursor-foreground-color* (make-white-color))
1446 (setf *hack-hunk-replace-line* nil))
1447 (t (setf *default-background-pixel*
1448 (xlib:screen-white-pixel (xlib:display-default-screen display)))
1449 (setf *default-foreground-pixel*
1450 (xlib:screen-black-pixel (xlib:display-default-screen display)))
1451 (setf *cursor-background-color* (make-white-color))
1452 (setf *cursor-foreground-color* (make-black-color))))
1453 (setf *foreground-background-xor*
1454 (logxor *default-foreground-pixel* *default-background-pixel*))
1455 (setf *highlight-border-pixmap* *default-foreground-pixel*)
1456 (setf *default-border-pixmap* (get-hemlock-grey-pixmap display))
1457 (get-hemlock-cursor display)
1458 (add-hook ed::make-window-hook 'define-window-cursor)
1459 ;;
1460 ;; Make the device for the rest of initialization.
1461 (let ((device (make-default-bitmap-device display)))
1462 ;;
1463 ;; Create initial windows.
1464 (funcall *create-initial-windows-hook* device)
1465 ;;
1466 ;; Setup random typeout over the user's main window.
1467 (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*))))
1468 (xlib:with-state (xwindow)
1469 (multiple-value-bind (x y)
1470 (window-root-xy xwindow (xlib:drawable-x xwindow)
1471 (xlib:drawable-y xwindow))
1472 (setf *random-typeout-start-x* x)
1473 (setf *random-typeout-start-y* y))
1474 (setf *random-typeout-start-width* (xlib:drawable-width xwindow)))))
1475 (add-hook ed::window-buffer-hook 'set-window-name-for-window-buffer)
1476 (add-hook ed::buffer-name-hook 'set-window-name-for-buffer-name)
1477 (add-hook ed::set-window-hook 'set-window-hook-raise-fun)
1478 (add-hook ed::buffer-modified-hook 'raise-echo-area-when-modified))
1479
1480 (defun make-default-bitmap-device (display)
1481 (make-bitmap-device
1482 :name "Windowed Bitmap Device"
1483 :init #'init-bitmap-device
1484 :exit #'exit-bitmap-device
1485 :smart-redisplay #'smart-window-redisplay
1486 :dumb-redisplay #'dumb-window-redisplay
1487 :after-redisplay #'bitmap-after-redisplay
1488 :clear nil
1489 :note-read-wait #'frob-cursor
1490 :put-cursor #'hunk-show-cursor
1491 :show-mark #'bitmap-show-mark
1492 :next-window #'bitmap-next-window
1493 :previous-window #'bitmap-previous-window
1494 :make-window #'bitmap-make-window
1495 :delete-window #'bitmap-delete-window
1496 :force-output #'bitmap-force-output
1497 :finish-output #'bitmap-finish-output
1498 :random-typeout-setup #'bitmap-random-typeout-setup
1499 :random-typeout-cleanup #'bitmap-random-typeout-cleanup
1500 :random-typeout-full-more #'do-bitmap-full-more
1501 :random-typeout-line-more #'update-bitmap-line-buffered-stream
1502 :beep #'bitmap-beep
1503 :display display))
1504
1505 (defun init-bitmap-device (device)
1506 (let ((display (bitmap-device-display device)))
1507 (ext:flush-display-events display)
1508 (hemlock-window display t)))
1509
1510 (defun exit-bitmap-device (device)
1511 (hemlock-window (bitmap-device-display device) nil))
1512
1513 (defun bitmap-finish-output (device window)
1514 (declare (ignore window))
1515 (xlib:display-finish-output (bitmap-device-display device)))
1516
1517 (defun bitmap-force-output ()
1518 (xlib:display-force-output
1519 (bitmap-device-display (device-hunk-device (window-hunk (current-window))))))
1520
1521 (defun bitmap-after-redisplay (device)
1522 (let ((display (bitmap-device-display device)))
1523 (loop (unless (ext:object-set-event-handler display) (return)))))
1524
1525
1526
1527 ;;;; Miscellaneous.
1528
1529 ;;; HUNK-RESET is called in redisplay to make sure the hunk is up to date.
1530 ;;; If the size is wrong, or it is trashed due to font changes, then we
1531 ;;; call HUNK-CHANGED. We also clear the hunk.
1532 ;;;
1533 (defun hunk-reset (hunk)
1534 (let ((xwindow (bitmap-hunk-xwindow hunk))
1535 (trashed (bitmap-hunk-trashed hunk)))
1536 (when trashed
1537 (setf (bitmap-hunk-trashed hunk) nil)
1538 (xlib:with-state (xwindow)
1539 (let ((w (xlib:drawable-width xwindow))
1540 (h (xlib:drawable-height xwindow)))
1541 (when (or (/= w (bitmap-hunk-width hunk))
1542 (/= h (bitmap-hunk-height hunk))
1543 (eq trashed :font-change))
1544 (hunk-changed hunk w h nil)))))
1545 (xlib:clear-area xwindow :width (bitmap-hunk-width hunk)
1546 :height (bitmap-hunk-height hunk))
1547 (hunk-draw-bottom-border hunk)))
1548
1549 ;;; HUNK-CHANGED -- Internal.
1550 ;;;
1551 ;;; HUNK-RESET and the changed window handler call this. Don't go through
1552 ;;; REDISPLAY-WINDOW-ALL since the window changed handler updates the window
1553 ;;; image.
1554 ;;;
1555 (defun hunk-changed (hunk new-width new-height redisplay)
1556 (set-hunk-size hunk new-width new-height)
1557 (funcall (bitmap-hunk-changed-handler hunk) hunk)
1558 (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk))))
1559
1560 ;;; WINDOW-GROUP-CHANGED -- Internal.
1561 ;;;
1562 ;;; HUNK-RECONFIGURED calls this when the hunk was a window-group. This finds
1563 ;;; the windows in the changed group, sorts them by their vertical stacking
1564 ;;; order, and tries to resize the windows proportioned by their old sizes
1565 ;;; relative to the old group size. If that fails, this tries to make all the
1566 ;;; windows the same size, dividing up the new group's size.
1567 ;;;
1568 (defun window-group-changed (window-group new-width new-height)
1569 (let ((xparent (window-group-xparent window-group))
1570 (affected-windows nil)
1571 (count 0)
1572 (old-xparent-height (window-group-height window-group)))
1573 (setf (window-group-width window-group) new-width)
1574 (setf (window-group-height window-group) new-height)
1575 (dolist (window *window-list*)
1576 (let ((test (window-group-xparent (bitmap-hunk-window-group
1577 (window-hunk window)))))
1578 (when (eq test xparent)
1579 (push window affected-windows)
1580 (incf count))))
1581 ;; Probably shoulds insertion sort them, but I'm lame.
1582 ;;
1583 (xlib:with-state (xparent)
1584 (sort affected-windows #'<
1585 :key #'(lambda (window)
1586 (xlib:drawable-y
1587 (bitmap-hunk-xwindow (window-hunk window))))))
1588 (let ((start 0))
1589 (declare (fixnum start))
1590 (do ((windows affected-windows (cdr windows)))
1591 ((endp windows))
1592 (let* ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows))))
1593 (new-child-height (round
1594 (* new-height
1595 (/ (xlib:drawable-height xwindow)
1596 old-xparent-height))))
1597 (hunk (window-hunk (car windows))))
1598 ;; If there is not enough room for one of the windows, space them out
1599 ;; evenly so there will be room.
1600 ;;
1601 (when (< new-child-height (minimum-window-height
1602 (font-family-height
1603 (bitmap-hunk-font-family hunk))
1604 (bitmap-hunk-modeline-pos hunk)
1605 (bitmap-hunk-thumb-bar-p hunk)))
1606 (reconfigure-windows-evenly affected-windows new-width new-height)
1607 (return))
1608 (xlib:with-state (xwindow)
1609 (setf (xlib:drawable-y xwindow) start
1610 ;; Make the last window absorb or lose the number of pixels
1611 ;; lost in rounding.
1612 ;;
1613 (xlib:drawable-height xwindow) (if (cdr windows)
1614 new-child-height
1615 (- new-height start))
1616 (xlib:drawable-width xwindow) new-width
1617 start (+ start new-child-height 1))))))))
1618
1619 (defun reconfigure-windows-evenly (affected-windows new-width new-height)
1620 (let ((count (length affected-windows)))
1621 (multiple-value-bind
1622 (pixels-per-window remainder)
1623 (truncate new-height count)
1624 (let ((count-1 (1- count)))
1625 (do ((windows affected-windows (cdr windows))
1626 (i 0 (1+ i)))
1627 ((endp windows))
1628 (let ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows)))))
1629 (setf (xlib:drawable-y xwindow) (* i pixels-per-window))
1630 (setf (xlib:drawable-width xwindow) new-width)
1631 (if (= i count-1)
1632 (return (setf (xlib:drawable-height
1633 (bitmap-hunk-xwindow
1634 (window-hunk (car windows))))
1635 (+ pixels-per-window remainder)))
1636 (setf (xlib:drawable-height xwindow) pixels-per-window))))))))
1637
1638 ;;; SET-HUNK-SIZE -- Internal
1639 ;;;
1640 ;;; Given a pixel size for a bitmap hunk, set the char size. If the window
1641 ;;; is too small, we refuse to admit it; if the user makes unreasonably small
1642 ;;; windows, our only responsibity is to not blow up. X will clip any stuff
1643 ;;; that doesn't fit.
1644 ;;;
1645 (defun set-hunk-size (hunk w h &optional modelinep)
1646 (let* ((font-family (bitmap-hunk-font-family hunk))
1647 (font-width (font-family-width font-family))
1648 (font-height (font-family-height font-family)))
1649 (setf (bitmap-hunk-height hunk) h)
1650 (setf (bitmap-hunk-width hunk) w)
1651 (setf (bitmap-hunk-char-width hunk)
1652 (max (truncate (- w hunk-left-border) font-width)
1653 minimum-window-columns))
1654 (let* ((h-minus-borders (- h hunk-top-border
1655 (bitmap-hunk-bottom-border hunk)))
1656 (hwin (bitmap-hunk-window hunk))
1657 (modelinep (or modelinep (and hwin (window-modeline-buffer hwin)))))
1658 (setf (bitmap-hunk-char-height hunk)
1659 (max (if modelinep
1660 (1- (truncate (- h-minus-borders
1661 hunk-modeline-top hunk-modeline-bottom)
1662 font-height))
1663 (truncate h-minus-borders font-height))
1664 minimum-window-lines))
1665 (setf (bitmap-hunk-modeline-pos hunk)
1666 (if modelinep (- h font-height
1667 hunk-modeline-top hunk-modeline-bottom))))))
1668
1669 ;;; BITMAP-HUNK-BOTTOM-BORDER -- Internal.
1670 ;;;
1671 (defun bitmap-hunk-bottom-border (hunk)
1672 (if (bitmap-hunk-thumb-bar-p hunk)
1673 hunk-thumb-bar-bottom-border
1674 hunk-bottom-border))
1675
1676
1677 ;;; DEFAULT-GCONTEXT is used when making hunks.
1678 ;;;
1679 (defun default-gcontext (drawable &optional font-family)
1680 (xlib:create-gcontext
1681 :drawable drawable
1682 :foreground *default-foreground-pixel*
1683 :background *default-background-pixel*
1684 :font (if font-family (svref (font-family-map font-family) 0))))
1685
1686
1687 ;;; WINDOW-ROOT-XY returns the x and y coordinates for a window relative to
1688 ;;; its root. Some window managers reparent Hemlock's window, so we have
1689 ;;; to mess around possibly to get this right. If x and y are supplied, they
1690 ;;; are relative to xwin's parent.
1691 ;;;
1692 (defun window-root-xy (xwin &optional x y)
1693 (multiple-value-bind (children parent root)
1694 (xlib:query-tree xwin)
1695 (declare (ignore children))
1696 (if (eq parent root)
1697 (if (and x y)
1698 (values x y)
1699 (xlib:with-state (xwin)
1700 (values (xlib:drawable-x xwin) (xlib:drawable-y xwin))))
1701 (multiple-value-bind
1702 (tx ty)
1703 (if (and x y)
1704 (xlib:translate-coordinates parent x y root)
1705 (xlib:with-state (xwin)
1706 (xlib:translate-coordinates
1707 parent (xlib:drawable-x xwin) (xlib:drawable-y xwin) root)))
1708 (values (- tx xwindow-border-width)
1709 (- ty xwindow-border-width))))))
1710
1711 ;;; CREATE-WINDOW-WITH-PROPERTIES makes an X window with parent. X, y, w, and
1712 ;;; h are possibly nil, so we supply zero in this case. This would be used
1713 ;;; for prompting the user. Some standard properties are set to keep window
1714 ;;; managers in line. We name all windows because awm and twm window managers
1715 ;;; refuse to honor menu clicks over windows without names. Min-width and
1716 ;;; min-height are optional and only used for prompting the user for a window.
1717 ;;;
1718 (defun create-window-with-properties (parent x y w h font-width font-height
1719 icon-name
1720 &optional min-width min-height
1721 window-group-p)
1722 (let* ((win (xlib:create-window
1723 :parent parent :x (or x 0) :y (or y 0)
1724 :width (or w 0) :height (or h 0)
1725 :background (if window-group-p :none *default-background-pixel*)
1726 :border-width (if window-group-p xwindow-border-width 0)
1727 :border (if window-group-p *default-border-pixmap* nil)
1728 :class :input-output)))
1729 (xlib:set-wm-properties
1730 win :name (new-hemlock-window-name) :icon-name icon-name
1731 :resource-name "Hemlock"
1732 :x x :y y :width w :height h
1733 :user-specified-position-p t :user-specified-size-p t
1734 :width-inc font-width :height-inc font-height
1735 :min-width min-width :min-height min-height
1736 ;; Tell OpenLook pseudo-X11 server we want input.
1737 :input :on)
1738 win))
1739
1740
1741 ;;; SET-WINDOW-HOOK-RAISE-FUN is a "Set Window Hook" function controlled by
1742 ;;; "Set Window Autoraise". When autoraising, check that it isn't only the
1743 ;;; echo area window that we autoraise; if it is only the echo area window,
1744 ;;; then see if window is the echo area window.
1745 ;;;
1746 (defun set-window-hook-raise-fun (window)
1747 (let ((auto (value ed::set-window-autoraise)))
1748 (when (and auto
1749 (or (not (eq auto :echo-only))
1750 (eq window *echo-area-window*)))
1751 (let* ((hunk (window-hunk window))
1752 (win (window-group-xparent (bitmap-hunk-window-group hunk))))
1753 (xlib:map-window win)
1754 (setf (xlib:window-priority win) :above)
1755 (xlib:display-force-output
1756 (bitmap-device-display (device-hunk-device hunk)))))))
1757
1758
1759 ;;; REVERSE-VIDEO-HOOK-FUN is called when the variable "Reverse Video" is set.
1760 ;;; If we are running on a windowed bitmap, we first setup the default
1761 ;;; foregrounds and backgrounds. Having done that, we get a new cursor. Then
1762 ;;; we do over all the hunks, updating their graphics contexts, cursors, and
1763 ;;; backgrounds. The current window's border is given the new highlight pixmap.
1764 ;;; Lastly, we update the random typeout hunk and redisplay everything.
1765 ;;;
1766 (defun reverse-video-hook-fun (name kind where new-value)
1767 (declare (ignore name kind where))
1768 (when (windowed-monitor-p)
1769 (let* ((current-window (current-window))
1770 (current-hunk (window-hunk current-window))
1771 (device (device-hunk-device current-hunk))
1772 (display (bitmap-device-display device)))
1773 (cond
1774 (new-value
1775 (setf *default-background-pixel*
1776 (xlib:screen-black-pixel (xlib:display-default-screen display)))
1777 (setf *default-foreground-pixel*
1778 (xlib:screen-white-pixel (xlib:display-default-screen display)))
1779 (setf *cursor-background-color* (make-black-color))
1780 (setf *cursor-foreground-color* (make-white-color))
1781 (setf *hack-hunk-replace-line* nil))
1782 (t (setf *default-background-pixel*
1783 (xlib:screen-white-pixel (xlib:display-default-screen display)))
1784 (setf *default-foreground-pixel*
1785 (xlib:screen-black-pixel (xlib:display-default-screen display)))
1786 (setf *cursor-background-color* (make-white-color))
1787 (setf *cursor-foreground-color* (make-black-color))))
1788 (setf *highlight-border-pixmap* *default-foreground-pixel*)
1789 (get-hemlock-cursor display)
1790 (dolist (hunk (device-hunks device))
1791 (reverse-video-frob-hunk hunk))
1792 (dolist (rt-info *random-typeout-buffers*)
1793 (reverse-video-frob-hunk
1794 (window-hunk (random-typeout-stream-window (cdr rt-info)))))
1795 (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk))
1796 *highlight-border-pixmap*))
1797 (redisplay-all)))
1798
1799 (defun reverse-video-frob-hunk (hunk)
1800 (let ((gcontext (bitmap-hunk-gcontext hunk)))
1801 (setf (xlib:gcontext-foreground gcontext) *default-foreground-pixel*)
1802 (setf (xlib:gcontext-background gcontext) *default-background-pixel*))
1803 (let ((xwin (bitmap-hunk-xwindow hunk)))
1804 (setf (xlib:window-cursor xwin) *hemlock-cursor*)
1805 (setf (xlib:window-background xwin) *default-background-pixel*)))

  ViewVC Help
Powered by ViewVC 1.1.5