source: trunk/ccl/hemlock/src/bit-screen.lisp @ 56

Last change on this file since 56 was 56, checked in by gb, 16 years ago

Use asterisks in (more) special variable names.

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