source: branches/1.8-appstore/source/cocoa-ide/hemlock/unused/archive/bit-screen.lisp

Last change on this file was 6567, checked in by Gary Byers, 18 years ago

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