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

  ViewVC Help
Powered by ViewVC 1.1.5