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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Sat Nov 23 21:48:32 1991 UTC (22 years, 4 months ago) by chiles
Branch: MAIN
Changes since 1.12: +25 -27 lines
Added wm-hints for pop-up display windows.  This will be necessary to receive
input in OpenLook windowing systems, but we also thought this might be be MWM
bug that prevents pop-up windows from receiving input.  It was unlikely this
was the problem since other Hemlock windows could receive input without the new
wm-hint we set to get input in OpenLook windowing systems.

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

  ViewVC Help
Powered by ViewVC 1.1.5