/[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.3 - (hide annotations)
Fri Nov 9 22:50:11 1990 UTC (23 years, 5 months ago) by wlott
Branch: MAIN
Changes since 1.2: +4 -0 lines
Added an eval-when (compile load eval) around some defconstants, 'cause
their value is needed at compile time.
,
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 ram 1.2 (ext:translate-key-event
513 ram 1.1 (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 ram 1.2 (ext:translate-mouse-key-event key-code modifiers
525 ram 1.1 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 wlott 1.3 (eval-when (compile load eval)
654    
655 ram 1.1 (defconstant xwindow-border-width 2 "X border around X windows")
656     (defconstant xwindow-border-width*2 (* xwindow-border-width 2))
657 wlott 1.3
658     ); eval-when
659 ram 1.1
660     ;;; We must name windows (set the "name" property) to get around a bug in
661     ;;; awm and twm. They will not handle menu clicks without a window having
662     ;;; a name. We set the name to this silly thing.
663     ;;;
664     (defvar *hemlock-window-count* 0)
665     ;;;
666     (defun new-hemlock-window-name ()
667     (let ((*print-base* 10))
668     (format nil "Hemlock ~S" (incf *hemlock-window-count*))))
669    
670    
671     ;;; DEFAULT-CREATE-WINDOW-HOOK is the default value for *create-window-hook*.
672     ;;; It makes an X window on the given display. Start is a mark into a buffer
673     ;;; for which some Hemlock window is being made for which this X window will
674     ;;; be used. When ask-user is non-nil, we supply x, y, width, and height as
675     ;;; standard properties for the X window which guides the window manager in
676     ;;; prompting the user for a window. When ask-user is nil, and there is a
677     ;;; current window, use it to guide making the new one. As a last resort,
678     ;;; which is only used for creating the initial Hemlock window, create a window
679     ;;; according to some variables, prompting the user when all the variables
680     ;;; aren't there.
681     ;;;
682     (defun default-create-window-hook (display start ask-user x y width height
683     &optional modelinep thumb-bar-p)
684     (let ((name (buffer-name (line-buffer (mark-line start))))
685     (root (xlib:screen-root (xlib:display-default-screen display))))
686     (cond (ask-user
687     (maybe-prompt-user-for-window root x y width height
688     modelinep thumb-bar-p name))
689     (*current-window*
690     (default-create-window-from-current root name))
691     (t
692     (maybe-prompt-user-for-window
693     root
694     (value ed::default-initial-window-x)
695     (value ed::default-initial-window-y)
696     (value ed::default-initial-window-width)
697     (value ed::default-initial-window-height)
698     modelinep thumb-bar-p name)))))
699    
700     ;;; MAYBE-PROMPT-USER-FOR-WINDOW makes an X window and sets its standard
701     ;;; properties according to supplied values. When some of these are nil, the
702     ;;; window manager should prompt the user for those missing values when the
703     ;;; window gets mapped. Returns the window without mapping it.
704     ;;;
705     (defun maybe-prompt-user-for-window (parent x y width height
706     modelinep thumb-bar-p icon-name)
707     (let* ((extra-y (+ hunk-top-border (if thumb-bar-p
708     hunk-thumb-bar-bottom-border
709     hunk-bottom-border)))
710     (font-height (font-family-height *default-font-family*))
711     (font-width (font-family-width *default-font-family*))
712     (extra-y-w/-modeline (+ extra-y hunk-modeline-top
713     hunk-modeline-bottom)))
714     (create-window-with-properties
715     parent x y
716     (if width (+ (* width font-width) hunk-left-border))
717     (if height
718     (if modelinep
719     (+ (* (1+ height) font-height) extra-y-w/-modeline)
720     (+ (* height font-height) extra-y)))
721     font-width font-height icon-name
722     (+ (* minimum-window-columns font-width) hunk-left-border)
723     (if modelinep
724     (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline)
725     (+ (* minimum-window-lines font-height) extra-y)))))
726    
727    
728     ;;; DEFAULT-CREATE-WINDOW-FROM-CURRENT makes a window on the given parent window
729     ;;; according to the current window. We split the current window unless the
730     ;;; result would be too small, in which case we create an overlapped window.
731     ;;; When setting standard properties, we set x, y, width, and height to tell
732     ;;; window managers to put the window where we intend without querying the user.
733     ;;; The window name is set to get around an awm and twm bug that inhibits
734     ;;; menu clicks unless the window has a name; this could be used better.
735     ;;;
736     (defun default-create-window-from-current (parent icon-name)
737     (let ((cwin (bitmap-hunk-xwindow (window-hunk *current-window*))))
738     (xlib:with-state (cwin)
739     (let ((cw (xlib:drawable-width cwin))
740     (ch (xlib:drawable-height cwin)))
741     (declare (fixnum cw ch))
742     (multiple-value-bind (cx cy)
743     (window-root-xy cwin (xlib:drawable-x cwin)
744     (xlib:drawable-y cwin))
745     (declare (fixnum cx cy))
746     (multiple-value-bind (ch/2 rem) (truncate ch 2)
747     (declare (fixnum ch/2 rem))
748     (let ((newh (- ch/2 xwindow-border-width))
749     (font-height (font-family-height *default-font-family*))
750     (font-width (font-family-width *default-font-family*)))
751     (declare (fixnum newh))
752     (cond
753     ((>= newh minimum-window-height)
754     (let ((win (create-window-with-properties
755     parent cx (+ cy ch/2 rem xwindow-border-width)
756     cw newh font-width font-height
757     icon-name)))
758     ;; No need to reshape current Hemlock window structure
759     ;; here since this call will send an appropriate event.
760     (setf (xlib:drawable-height cwin) (+ newh rem))
761     win))
762     ((> (+ cy window-y-offset)
763     (- (xlib:drawable-height parent) minimum-y-above-root-bottom))
764     nil)
765     (t
766     (create-window-with-properties parent cx (+ cy window-y-offset)
767     cw ch font-width font-height
768     icon-name))))))))))
769    
770     (defvar *create-window-hook* #'default-create-window-hook
771     "This function is called by MAKE-WINDOW when it wants to make a new
772     X window. Hemlock passes as arguments the starting mark, ask-user, default,
773     and modelinep arguments given to MAKE-WINDOW. The function should return a
774     window.")
775    
776     (defun bitmap-make-window (device start modelinep window font-family
777     ask-user x y width-arg height-arg)
778     (let* ((display (bitmap-device-display device))
779     (thumb-bar-p (value ed::thumb-bar-meter))
780     (hunk (make-bitmap-hunk
781     :font-family font-family
782     :end the-sentinel :trashed t
783     :input-handler #'window-input-handler
784     :device device
785     :thumb-bar-p (and modelinep thumb-bar-p))))
786     (multiple-value-bind (window width height)
787     (maybe-make-x-window window display start ask-user
788     x y width-arg height-arg
789     modelinep thumb-bar-p)
790     (unless window (return-from bitmap-make-window nil))
791     (setf (bitmap-hunk-xwindow hunk) window)
792     (setf (bitmap-hunk-gcontext hunk)
793     (default-gcontext window font-family))
794     ;;
795     ;; Select input and enable event service before showing the window.
796     (setf (xlib:window-event-mask window) interesting-xevents-mask)
797     (add-xwindow-object window hunk *hemlock-windows*)
798     (xlib:map-window window)
799     (xlib:display-finish-output display)
800     ;; A window is not really mapped until it is viewable (not visible).
801     ;; It is said to be mapped if a map request has been sent whether it
802     ;; is handled or not.
803     (loop (when (eq (xlib:window-map-state window) :viewable)
804     (return)))
805     ;;
806     ;; Find out how big it is...
807     (if width
808     (set-hunk-size hunk width height modelinep)
809     (xlib:with-state (window)
810     (set-hunk-size hunk (xlib:drawable-width window)
811     (xlib:drawable-height window) modelinep)))
812     (setf (bitmap-hunk-window hunk)
813     (window-for-hunk hunk start modelinep))
814     ;;
815     ;; If there is a current window, link this in after it, otherwise
816     ;; make this circularly linked, and set *current-window* to it.
817     (cond (*current-window*
818     (let ((h (window-hunk *current-window*)))
819     (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk)
820     (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk)
821     (setf (bitmap-hunk-previous hunk) h)))
822     (t
823     (setq *current-window* (bitmap-hunk-window hunk))
824     (setf (bitmap-hunk-previous hunk) hunk)
825     (setf (bitmap-hunk-next hunk) hunk)))
826     (push hunk (device-hunks device))
827     (bitmap-hunk-window hunk))))
828    
829     ;;; MAYBE-MAKE-X-WINDOW is called by BITMAP-MAKE-WINDOW. If window is an X
830     ;;; window, we clear it and return the window with its width and height.
831     ;;; Otherwise, we call *create-window-hook* on the other arguments passed in,
832     ;;; returning the created window and nil for the width and height. When a
833     ;;; window is created, it may not be mapped, and, therefore, it's width and
834     ;;; height would not be known.
835     ;;;
836     (defun maybe-make-x-window (window display start ask-user x y width height
837     modelinep thumb-bar-p)
838     (cond (window
839     (check-type window xlib:window)
840     (xlib:with-state (window)
841     (let ((width (xlib:drawable-width window))
842     (height (xlib:drawable-height window)))
843     (xlib:clear-area window :width width :height height)
844     (values window width height))))
845     (t
846     (let ((window (funcall *create-window-hook*
847     display start ask-user x y width height
848     modelinep thumb-bar-p)))
849     (values window nil nil)))))
850    
851     ;;; MAKE-XWINDOW-LIKE-HWINDOW makes a new X window that overlays the supplied
852     ;;; Hemlock window. When setting standard properties, we set x, y, width, and
853     ;;; height to tell window managers to put the window where we intend without
854     ;;; querying the user. The window name is set to get around an awm and twm bug
855     ;;; that inhibits menu clicks unless the window has a name; this could be used
856     ;;; better.
857     ;;;
858     (defun make-xwindow-like-hwindow (window)
859     (let* ((hunk (window-hunk window))
860     (xwin (bitmap-hunk-xwindow hunk)))
861     (multiple-value-bind (x y)
862     (window-root-xy xwin)
863     (create-window-with-properties
864     (xlib:screen-root (xlib:display-default-screen
865     (bitmap-device-display (device-hunk-device hunk))))
866     x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk)
867     (font-family-width *default-font-family*)
868     (font-family-height *default-font-family*)
869     (buffer-name (window-buffer window))))))
870    
871    
872    
873     ;;;; Deleting a window.
874    
875     ;;; DEFAULT-DELETE-WINDOW-HOOK destroys the X window after obtaining its
876     ;;; necessary state information. If the previous or next window (in that
877     ;;; order) is "stacked" over or under the target window, then it is grown to
878     ;;; fill in the newly opened space. We fetch all the necessary configuration
879     ;;; data up front, so we don't have to call XLIB:DESTROY-WINDOW while in the
880     ;;; XLIB:WITH-STATE.
881     ;;;
882     (defun default-delete-window-hook (xwin hwin)
883     (multiple-value-bind (h x y)
884     (xlib:with-state (xwin)
885     (multiple-value-bind
886     (x y)
887     (window-root-xy xwin (xlib:drawable-x xwin)
888     (xlib:drawable-y xwin))
889     (values (xlib:drawable-height xwin) x y)))
890     (xlib:destroy-window xwin)
891     (let ((hunk (window-hunk hwin)))
892     (xlib:free-gcontext (bitmap-hunk-gcontext hunk))
893     (unless (default-delete-window-hook-prev-merge hunk x y h)
894     (default-delete-window-hook-next-merge hunk x y h)))))
895     ;;;
896     (defvar *delete-window-hook* #'default-delete-window-hook
897     "This function is called by DELETE-WINDOW when it wants to delete an X
898     window. It is passed the X window and the Hemlock window as arguments.")
899    
900     ;;; DEFAULT-DELETE-WINDOW-HOOK-PREV-MERGE returns non-nil when the previous
901     ;;; hunk to hunk is grown to take up hunk's space on the screen.
902     ;;;
903     (defun default-delete-window-hook-prev-merge (hunk x y h)
904     (declare (fixnum x y h))
905     (let* ((prev (bitmap-hunk-previous hunk))
906     (prev-xwin (bitmap-hunk-xwindow prev)))
907     (xlib:with-state (prev-xwin)
908     (let ((ph (xlib:drawable-height prev-xwin)))
909     (declare (fixnum ph))
910     (multiple-value-bind (px py)
911     (window-root-xy prev-xwin
912     (xlib:drawable-x prev-xwin)
913     (xlib:drawable-y prev-xwin))
914     (declare (fixnum px py))
915     (if (and (= x px)
916     (= y (the fixnum (+ py ph xwindow-border-width*2))))
917     (setf (xlib:drawable-height prev-xwin)
918     (the fixnum (+ ph xwindow-border-width*2 h)))))))))
919    
920     ;;; DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE trys to grow the next hunk's window
921     ;;; to make use of the space created by deleting hunk's window. If this is
922     ;;; possible, then we must also move the next window up to where hunk's window
923     ;;; was.
924     ;;;
925     ;;; When we reconfigure the window, we must set the hunk trashed. This is a
926     ;;; hack since twm is broken again and is sending exposure events before
927     ;;; reconfigure notifications. Hemlock relies on the protocol's statement that
928     ;;; reconfigures come before exposures to set the hunk trashed before getting
929     ;;; the exposure. For now, we'll do it here too.
930     ;;;
931     (defun default-delete-window-hook-next-merge (hunk x y h)
932     (declare (fixnum x y h))
933     (let* ((next (bitmap-hunk-next hunk))
934     (next-xwin (bitmap-hunk-xwindow next))
935     (newy
936     (xlib:with-state (next-xwin)
937     (multiple-value-bind (nx ny)
938     (window-root-xy next-xwin
939     (xlib:drawable-x next-xwin)
940     (xlib:drawable-y next-xwin))
941     (declare (fixnum nx ny))
942     (when (and (= x nx)
943     (= ny (the fixnum (+ y h xwindow-border-width*2))))
944     ;; Fetch height before setting y to save one extra round trip to
945     ;; the X server.
946     (let ((nh (xlib:drawable-height next-xwin)))
947     (declare (fixnum nh))
948     (setf (xlib:drawable-y next-xwin) y)
949     (setf (xlib:drawable-height next-xwin)
950     (the fixnum (+ h xwindow-border-width*2 nh))))
951     y)))))
952     (when newy
953     (setf (bitmap-hunk-trashed next) t)
954     (let ((hints (xlib:wm-normal-hints next-xwin)))
955     (setf (xlib:wm-size-hints-y hints) newy)
956     (setf (xlib:wm-normal-hints next-xwin) hints)))))
957    
958     #|
959     ;;; DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE ... Hack!
960     ;;;
961     ;;; This version works when window managers refuse to allow clients to
962     ;;; reposition windows. What we do instead is to delete the next hunk's X
963     ;;; window, making a new one in the place of hunk's window that fills the empty
964     ;;; space created by deleting both windows. Some code from the default window
965     ;;; creation hook and BITMAP-MAKE-WINDOW is duplicated here. Also, there is
966     ;;; is a funny issue over whether to invoke the "Make Window Hook" even though
967     ;;; we didn't really make a new Hemlock window.
968     ;;;
969     (defun default-delete-window-hook-next-merge (hunk x y h)
970     (let* ((next (bitmap-hunk-next hunk))
971     (next-hwin (device-hunk-window next))
972     (next-xwin (bitmap-hunk-xwindow next)))
973     (multiple-value-bind
974     (nx ny nh)
975     (xlib:with-state (next-xwin)
976     (multiple-value-bind (nx ny)
977     (window-root-xy next-xwin
978     (xlib:drawable-x next-xwin)
979     (xlib:drawable-y next-xwin))
980     (declare (fixnum nx ny))
981     (when (and (= x nx)
982     (= ny (the fixnum (+ y h xwindow-border-width*2))))
983     (values x y (the fixnum (+ h xwindow-border-width*2
984     (xlib:drawable-height next-xwin)))))))
985     (when nx
986     (let* ((font-family (bitmap-hunk-font-family next))
987     (display (bitmap-device-display (device-hunk-device next)))
988     (nwin (create-window-with-properties
989     (xlib:screen-root (xlib:display-default-screen display))
990     nx ny (bitmap-hunk-width next) nh
991     (font-family-width font-family)
992     (font-family-height font-family)
993     (buffer-name (window-buffer next-hwin)))))
994     ;;
995     ;; Delete next's X window.
996     (remove-xwindow-object next-xwin)
997     (when (eq *current-highlighted-border* next)
998     (setf *current-highlighted-border* nil))
999     (when (and (eq *cursor-hunk* next) *cursor-dropped*) (lift-cursor))
1000     (xlib:display-force-output display)
1001     (xlib:destroy-window next-xwin)
1002     (xlib:free-gcontext (bitmap-hunk-gcontext next))
1003     (loop (unless (deleting-window-drop-event display next-xwin)
1004     (return)))
1005     ;;
1006     ;; Install new X window.
1007     (setf (bitmap-hunk-xwindow next) nwin)
1008     (setf (xlib:window-event-mask nwin) interesting-xevents-mask)
1009     (add-xwindow-object nwin next *hemlock-windows*)
1010     (xlib:map-window nwin)
1011     (xlib:display-finish-output display)
1012     (loop (when (eq (xlib:window-map-state nwin) :viewable)
1013     (return)))
1014     (xlib:with-state (nwin)
1015     (hunk-changed next (xlib:drawable-width nwin)
1016     (xlib:drawable-height nwin) nil))
1017     ;; This normally occurs as a result of "Make Window Hook". Other
1018     ;; problems may occur if users are using this hook to do things to
1019     ;; their X windows. Invoking this hook here could be bad too since
1020     ;; we didn't really create a new Hemlock window.
1021     (define-window-cursor next-hwin))))))
1022     |#
1023    
1024     ;;; DELETING-WINDOW-DROP-EVENT checks for any events on win. If there is one,
1025     ;;; it is removed from the queue, and t is returned. Otherwise, returns nil.
1026     ;;;
1027     (defun deleting-window-drop-event (display win)
1028     (xlib:display-finish-output display)
1029     (let ((result nil))
1030     (xlib:process-event
1031     display :timeout 0
1032     :handler #'(lambda (&key event-window window &allow-other-keys)
1033     (if (or (eq event-window win) (eq window win))
1034     (setf result t)
1035     nil)))
1036     result))
1037    
1038    
1039     ;;; BITMAP-DELETE-WINDOW -- Internal
1040     ;;;
1041     ;;;
1042     (defun bitmap-delete-window (window)
1043     (let* ((hunk (window-hunk window))
1044     (xwindow (bitmap-hunk-xwindow hunk))
1045     (display (bitmap-device-display (device-hunk-device hunk))))
1046     (remove-xwindow-object xwindow)
1047     (setq *window-list* (delete window *window-list*))
1048     (when (eq *current-highlighted-border* hunk)
1049     (setf *current-highlighted-border* nil))
1050     (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor))
1051     (xlib:display-force-output display)
1052     (funcall *delete-window-hook* xwindow window)
1053     (loop (unless (deleting-window-drop-event display xwindow) (return)))
1054     (let ((device (device-hunk-device hunk)))
1055     (setf (device-hunks device) (delete hunk (device-hunks device))))
1056     (let ((next (bitmap-hunk-next hunk))
1057     (prev (bitmap-hunk-previous hunk)))
1058     (setf (bitmap-hunk-next prev) next)
1059     (setf (bitmap-hunk-previous next) prev)
1060     (let ((buffer (window-buffer window)))
1061     (setf (buffer-windows buffer) (delete window (buffer-windows buffer))))))
1062     nil)
1063    
1064    
1065    
1066     ;;;; Next and Previous windows.
1067    
1068     (defun bitmap-next-window (window)
1069     "Return the next window after Window, wrapping around if Window is the
1070     bottom window."
1071     (check-type window window)
1072     (bitmap-hunk-window (bitmap-hunk-next (window-hunk window))))
1073    
1074     (defun bitmap-previous-window (window)
1075     "Return the previous window after Window, wrapping around if Window is the
1076     top window."
1077     (check-type window window)
1078     (bitmap-hunk-window (bitmap-hunk-previous (window-hunk window))))
1079    
1080    
1081    
1082     ;;;; Setting window width and height.
1083    
1084     ;;; %SET-WINDOW-WIDTH -- Internal
1085     ;;;
1086     ;;; Since we don't support non-full-width windows, this does nothing.
1087     ;;;
1088     (defun %set-window-width (window new-value)
1089     (declare (ignore window))
1090     new-value)
1091    
1092     ;;; %SET-WINDOW-HEIGHT -- Internal
1093     ;;;
1094     ;;; Can't change window height either.
1095     ;;;
1096     (defun %set-window-height (window new-value)
1097     (declare (ignore window))
1098     new-value)
1099    
1100    
1101    
1102     ;;;; Random Typeout
1103    
1104     ;;; Random typeout is done to a bitmap-hunk-output-stream
1105     ;;; (Bitmap-Hunk-Stream.Lisp). These streams have an associated hunk
1106     ;;; that is used for its font-family, foreground and background color,
1107     ;;; and X window pointer. The hunk is not associated with any Hemlock
1108     ;;; window, and the low level painting routines that use hunk dimensions
1109     ;;; are not used for output. The X window is resized as necessary with
1110     ;;; each use, but the hunk is only registered for input and boundary
1111     ;;; crossing event service; therefore, it never gets exposure or changed
1112     ;;; notifications.
1113    
1114     ;;; These are set in INIT-BITMAP-SCREEN-MANAGER.
1115     ;;;
1116     (defvar *random-typeout-start-x* 0
1117     "Where we put the the random typeout window.")
1118     (defvar *random-typeout-start-y* 0
1119     "Where we put the the random typeout window.")
1120     (defvar *random-typeout-start-width* 0
1121     "How wide the random typeout window is.")
1122    
1123    
1124     ;;; DEFAULT-RANDOM-TYPEOUT-HOOK -- Internal
1125     ;;;
1126     ;;; The default hook-function for random typeout. Nothing very fancy
1127     ;;; for now. If not given a window, makes one on top of the initial
1128     ;;; Hemlock window using specials set in INIT-BITMAP-SCREEN-MANAGER. If
1129     ;;; given a window, we will change the height subject to the constraint
1130     ;;; that the bottom won't be off the screen. Any resulting window has
1131     ;;; input and boundary crossing events selected, a hemlock cursor defined,
1132     ;;; and is mapped.
1133     ;;;
1134     (defun default-random-typeout-hook (device window height)
1135     (declare (fixnum height))
1136     (let* ((display (bitmap-device-display device))
1137     (root (xlib:screen-root (xlib:display-default-screen display)))
1138     (full-height (xlib:drawable-height root))
1139     (actual-height (if window
1140     (multiple-value-bind (x y) (window-root-xy window)
1141     (declare (ignore x) (fixnum y))
1142     (min (- full-height y xwindow-border-width*2)
1143     height))
1144     (min (- full-height *random-typeout-start-y*
1145     xwindow-border-width*2)
1146     height)))
1147     (win (cond (window
1148     (setf (xlib:drawable-height window) actual-height)
1149     window)
1150     ((xlib:create-window
1151     :parent root
1152     :x *random-typeout-start-x*
1153     :y *random-typeout-start-y*
1154     :width *random-typeout-start-width*
1155     :height actual-height
1156     :background *default-background-pixel*
1157     :border-width xwindow-border-width
1158     :border *default-border-pixmap*
1159     :event-mask random-typeout-xevents-mask
1160     :override-redirect :on :class :input-output))))
1161     (gcontext (if (not window) (default-gcontext win))))
1162     (unless window
1163     (xlib:with-state (win)
1164     (setf (xlib:window-event-mask win) random-typeout-xevents-mask)
1165     (setf (xlib:window-cursor win) *hemlock-cursor*)))
1166     (values win gcontext)))
1167    
1168     (defvar *random-typeout-hook* #'default-random-typeout-hook
1169     "This function is called when a window is needed to display random typeout.
1170     It is called with the Hemlock device, a pre-existing window or NIL, and the
1171     number of pixels needed to display the number of lines requested in
1172     WITH-RANDOM-TYPEOUT. It should return a window, and if a new window was
1173     created, then a gcontext must be returned as the second value.")
1174    
1175     ;;; BITMAP-RANDOM-TYPEOUT-SETUP -- Internal
1176     ;;;
1177     ;;; This function is called by the with-random-typeout macro to
1178     ;;; to set things up. It calls the *Random-Typeout-Hook* to get a window
1179     ;;; to work with, and then adjusts the random typeout stream's data-structures
1180     ;;; to match.
1181     ;;;
1182     (defun bitmap-random-typeout-setup (device stream height)
1183     (let* ((*more-prompt-action* :empty)
1184     (hwin-exists-p (random-typeout-stream-window stream))
1185     (hwindow (if hwin-exists-p
1186     (change-bitmap-random-typeout-window hwin-exists-p height)
1187     (setf (random-typeout-stream-window stream)
1188     (make-bitmap-random-typeout-window
1189     device
1190     (buffer-start-mark
1191     (line-buffer
1192     (mark-line (random-typeout-stream-mark stream))))
1193     height)))))
1194     (let ((xwindow (bitmap-hunk-xwindow (window-hunk hwindow)))
1195     (display (bitmap-device-display device)))
1196     (xlib:display-finish-output display)
1197     (loop
1198     (unless (xlib:event-case (display :timeout 0)
1199     (:exposure (event-window)
1200     (eq event-window xwindow))
1201     (t () nil))
1202     (return))))))
1203    
1204     (defun change-bitmap-random-typeout-window (hwindow height)
1205     (update-modeline-field (window-buffer hwindow) hwindow :more-prompt)
1206     (let* ((hunk (window-hunk hwindow))
1207     (xwin (bitmap-hunk-xwindow hunk)))
1208     ;;
1209     ;; *random-typeout-hook* sets the window's height to the right value.
1210     (funcall *random-typeout-hook* (device-hunk-device hunk) xwin
1211     (+ (* height (font-family-height (bitmap-hunk-font-family hunk)))
1212     hunk-top-border (bitmap-hunk-bottom-border hunk)
1213     hunk-modeline-top hunk-modeline-bottom))
1214     (xlib:with-state (xwin)
1215     (hunk-changed hunk (xlib:drawable-width xwin) (xlib:drawable-height xwin)
1216     nil))
1217     ;;
1218     ;; We push this on here because we took it out the last time we cleaned up.
1219     (push hwindow (buffer-windows (window-buffer hwindow)))
1220     (setf (bitmap-hunk-trashed hunk) t)
1221     (xlib:map-window xwin)
1222     (setf (xlib:window-priority xwin) :above))
1223     hwindow)
1224    
1225     (defun make-bitmap-random-typeout-window (device mark height)
1226     (let* ((display (bitmap-device-display device))
1227     (hunk (make-bitmap-hunk
1228     :font-family *default-font-family*
1229     :end the-sentinel :trashed t
1230     :input-handler #'window-input-handler
1231     :device device :thumb-bar-p nil)))
1232     (multiple-value-bind
1233     (xwindow gcontext)
1234     (funcall *random-typeout-hook*
1235     device (bitmap-hunk-xwindow hunk)
1236     (+ (* height (font-family-height *default-font-family*))
1237     hunk-top-border (bitmap-hunk-bottom-border hunk)
1238     hunk-modeline-top hunk-modeline-bottom))
1239     ;;
1240     ;; When gcontext, we just made the window, so tie some stuff together.
1241     (when gcontext
1242     (setf (xlib:gcontext-font gcontext)
1243     (svref (font-family-map *default-font-family*) 0))
1244     (setf (bitmap-hunk-xwindow hunk) xwindow)
1245     (setf (bitmap-hunk-gcontext hunk) gcontext)
1246     ;;
1247     ;; Select input and enable event service before showing the window.
1248     (setf (xlib:window-event-mask xwindow) random-typeout-xevents-mask)
1249     (add-xwindow-object xwindow hunk *hemlock-windows*))
1250     ;;
1251     ;; Put the window on the screen so it's visible and we can know the size.
1252     (xlib:map-window xwindow)
1253     (xlib:display-finish-output display)
1254     ;; A window is not really mapped until it is viewable (not visible).
1255     ;; It is said to be mapped if a map request has been sent whether it
1256     ;; is handled or not.
1257     (loop (when (eq (xlib:window-map-state xwindow) :viewable)
1258     (return)))
1259     (xlib:with-state (xwindow)
1260     (set-hunk-size hunk (xlib:drawable-width xwindow)
1261     (xlib:drawable-height xwindow) t))
1262     ;;
1263     ;; Get a Hemlock window and hide it from the rest of Hemlock.
1264     (let ((hwin (window-for-hunk hunk mark *random-typeout-ml-fields*)))
1265     (update-modeline-field (window-buffer hwin) hwin :more-prompt)
1266     (setf (bitmap-hunk-window hunk) hwin)
1267     (setf *window-list* (delete hwin *window-list*))
1268     hwin))))
1269    
1270    
1271     ;;; RANDOM-TYPEOUT-CLEANUP -- Internal
1272     ;;;
1273     ;;; Clean up after random typeout. This just removes the window from
1274     ;;; the screen and sets the more-prompt action back to normal.
1275     ;;;
1276     (defun bitmap-random-typeout-cleanup (stream degree)
1277     (when degree
1278     (xlib:unmap-window (bitmap-hunk-xwindow
1279     (window-hunk (random-typeout-stream-window stream))))))
1280    
1281    
1282    
1283     ;;;; Initialization.
1284    
1285     ;;; DEFAULT-CREATE-INITIAL-WINDOWS-HOOK makes the initial windows, main and
1286     ;;; echo. The main window is made according to "Default Initial Window X",
1287     ;;; "Default Initial Window Y", "Default Initial Window Width", and "Default
1288     ;;; Initial Window Height", prompting the user for any unspecified components.
1289     ;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO is called to return the location and
1290     ;;; size of the echo area including how big its font is, and the main xwindow
1291     ;;; is potentially modified by this function. The window name is set to get
1292     ;;; around an awm and twm bug that inhibits menu clicks unless the window has a
1293     ;;; name; this could be used better.
1294     ;;;
1295     (defun default-create-initial-windows-hook (device)
1296     (let* ((main-win (make-window (buffer-start-mark *current-buffer*)
1297     :device device))
1298     (main-xwin (bitmap-hunk-xwindow (window-hunk main-win)))
1299     (root (xlib:screen-root (xlib:display-default-screen
1300     (bitmap-device-display device)))))
1301     (multiple-value-bind
1302     (echo-x echo-y echo-width echo-height f-width f-height)
1303     (default-create-initial-windows-echo
1304     (xlib:drawable-height root)
1305     (bitmap-hunk-font-family (window-hunk main-win))
1306     main-xwin)
1307     (let ((echo-win (create-window-with-properties
1308     root echo-x echo-y echo-width echo-height
1309     f-width f-height "Echo Area")))
1310     (setf *echo-area-window*
1311     (hlet ((ed::thumb-bar-meter nil))
1312     (make-window
1313     (buffer-start-mark *echo-area-buffer*)
1314     :device device :window echo-win
1315     :modelinep t)))))
1316     (setf *current-window* main-win)
1317     (setf (xlib:window-border main-xwin) *highlight-border-pixmap*)))
1318    
1319     ;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as
1320     ;;; the main window and places it directly under it. If the echo area does not
1321     ;;; fit on the screen, we change the main window to make it fit. There is
1322     ;;; a problem in computing main-xwin's x and y relative to the root window
1323     ;;; which is where we line up the echo and main windows. Some losing window
1324     ;;; managers (awm and twm) reparent the window, so we have to make sure
1325     ;;; main-xwin's x and y are relative to the root and not some false parent.
1326     ;;;
1327     (defun default-create-initial-windows-echo (full-height font-family main-xwin)
1328     (declare (fixnum full-height))
1329     (xlib:with-state (main-xwin)
1330     (let ((w (xlib:drawable-width main-xwin))
1331     (h (xlib:drawable-height main-xwin)))
1332     (declare (fixnum w h))
1333     (multiple-value-bind (x y)
1334     (window-root-xy main-xwin
1335     (xlib:drawable-x main-xwin)
1336     (xlib:drawable-y main-xwin))
1337     (declare (fixnum x y))
1338     (let* ((ff-height (font-family-height font-family))
1339     (ff-width (font-family-width font-family))
1340     (echo-height (+ (* ff-height 4)
1341     hunk-top-border hunk-bottom-border
1342     hunk-modeline-top hunk-modeline-bottom)))
1343     (declare (fixnum echo-height))
1344     (if (<= (+ y h echo-height xwindow-border-width*2) full-height)
1345     (values x (+ y h xwindow-border-width*2)
1346     w echo-height ff-width ff-height)
1347     (let* ((newh (- full-height y echo-height xwindow-border-width*2
1348     ;; Since y is really the outside y, subtract
1349     ;; two more borders, so the echo area's borders
1350     ;; both appear on the screen.
1351     xwindow-border-width*2)))
1352     (setf (xlib:drawable-height main-xwin) newh)
1353     (values x (+ y newh xwindow-border-width*2)
1354     w echo-height ff-width ff-height))))))))
1355    
1356     (defvar *create-initial-windows-hook* #'default-create-initial-windows-hook
1357     "This function is used when the screen manager is initialized to make the
1358     first windows, typically the main and echo area windows. It takes a
1359     Hemlock device as a required argument. It sets *current-window* and
1360     *echo-area-window*.")
1361    
1362     (defun init-bitmap-screen-manager (display)
1363     ;;
1364     ;; Setup stuff for X interaction.
1365     (cond ((value ed::reverse-video)
1366     (setf *default-background-pixel*
1367     (xlib:screen-black-pixel (xlib:display-default-screen display)))
1368     (setf *default-foreground-pixel*
1369     (xlib:screen-white-pixel (xlib:display-default-screen display)))
1370     (setf *cursor-background-color* (make-black-color))
1371     (setf *cursor-foreground-color* (make-white-color))
1372     (setf *hack-hunk-replace-line* nil))
1373     (t (setf *default-background-pixel*
1374     (xlib:screen-white-pixel (xlib:display-default-screen display)))
1375     (setf *default-foreground-pixel*
1376     (xlib:screen-black-pixel (xlib:display-default-screen display)))
1377     (setf *cursor-background-color* (make-white-color))
1378     (setf *cursor-foreground-color* (make-black-color))
1379     (setf *hack-hunk-replace-line* t)))
1380     (setf *foreground-background-xor*
1381     (logxor *default-foreground-pixel* *default-background-pixel*))
1382     (setf *highlight-border-pixmap* *default-foreground-pixel*)
1383     (setf *default-border-pixmap* (get-hemlock-grey-pixmap display))
1384     (get-hemlock-cursor display)
1385     (add-hook ed::make-window-hook 'define-window-cursor)
1386     ;;
1387     ;; Make the device for the rest of initialization.
1388     (let ((device (make-default-bitmap-device display)))
1389     ;;
1390     ;; Create initial windows.
1391     (funcall *create-initial-windows-hook* device)
1392     ;;
1393     ;; Unlink the echo area window from the next/prev list.
1394     (let* ((hunk (window-hunk *echo-area-window*))
1395     (next (bitmap-hunk-next hunk))
1396     (prev (bitmap-hunk-previous hunk)))
1397     (setf (bitmap-hunk-next prev) next)
1398     (setf (bitmap-hunk-previous next) prev)
1399     (setf (bitmap-hunk-previous hunk) hunk)
1400     (setf (bitmap-hunk-next hunk) hunk)
1401     (setf (bitmap-hunk-thumb-bar-p hunk) nil))
1402     ;;
1403     ;; Setup random typeout over the user's main window.
1404     (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*))))
1405     (xlib:with-state (xwindow)
1406     (multiple-value-bind (x y)
1407     (window-root-xy xwindow (xlib:drawable-x xwindow)
1408     (xlib:drawable-y xwindow))
1409     (setf *random-typeout-start-x* x)
1410     (setf *random-typeout-start-y* y))
1411     (setf *random-typeout-start-width* (xlib:drawable-width xwindow)))))
1412     (add-hook ed::window-buffer-hook 'set-window-name-for-window-buffer)
1413     (add-hook ed::buffer-name-hook 'set-window-name-for-buffer-name)
1414     (add-hook ed::set-window-hook 'set-window-hook-raise-fun))
1415    
1416     (defun make-default-bitmap-device (display)
1417     (make-bitmap-device
1418     :name "Windowed Bitmap Device"
1419     :init #'init-bitmap-device
1420     :exit #'exit-bitmap-device
1421     :smart-redisplay #'smart-window-redisplay
1422     :dumb-redisplay #'dumb-window-redisplay
1423     :after-redisplay #'bitmap-after-redisplay
1424     :clear nil
1425     :note-read-wait #'frob-cursor
1426     :put-cursor #'hunk-show-cursor
1427     :show-mark #'bitmap-show-mark
1428     :next-window #'bitmap-next-window
1429     :previous-window #'bitmap-previous-window
1430     :make-window #'bitmap-make-window
1431     :delete-window #'bitmap-delete-window
1432     :force-output #'bitmap-force-output
1433     :finish-output #'bitmap-finish-output
1434     :random-typeout-setup #'bitmap-random-typeout-setup
1435     :random-typeout-cleanup #'bitmap-random-typeout-cleanup
1436     :random-typeout-full-more #'do-bitmap-full-more
1437     :random-typeout-line-more #'update-bitmap-line-buffered-stream
1438     :beep #'bitmap-beep
1439     :display display))
1440    
1441     (defun init-bitmap-device (device)
1442     (let ((display (bitmap-device-display device)))
1443     (ext:flush-display-events display)
1444     (hemlock-window display t)))
1445    
1446     (defun exit-bitmap-device (device)
1447     (hemlock-window (bitmap-device-display device) nil))
1448    
1449     (defun bitmap-finish-output (device window)
1450     (declare (ignore window))
1451     (xlib:display-finish-output (bitmap-device-display device)))
1452    
1453     (defun bitmap-force-output ()
1454     (xlib:display-force-output
1455     (bitmap-device-display (device-hunk-device (window-hunk (current-window))))))
1456    
1457     (defun bitmap-after-redisplay (device)
1458     (let ((display (bitmap-device-display device)))
1459     (loop (unless (ext:object-set-event-handler display) (return)))))
1460    
1461    
1462    
1463     ;;;; Miscellaneous.
1464    
1465     ;;; HUNK-RESET is called in redisplay to make sure the hunk is up to date.
1466     ;;; If the size is wrong, or it is trashed due to font changes, then we
1467     ;;; call HUNK-CHANGED. We also clear the hunk.
1468     ;;;
1469     (defun hunk-reset (hunk)
1470     (let ((xwindow (bitmap-hunk-xwindow hunk))
1471     (trashed (bitmap-hunk-trashed hunk)))
1472     (when trashed
1473     (setf (bitmap-hunk-trashed hunk) nil)
1474     (xlib:with-state (xwindow)
1475     (let ((w (xlib:drawable-width xwindow))
1476     (h (xlib:drawable-height xwindow)))
1477     (when (or (/= w (bitmap-hunk-width hunk))
1478     (/= h (bitmap-hunk-height hunk))
1479     (eq trashed :font-change))
1480     (hunk-changed hunk w h nil)))))
1481     (xlib:clear-area xwindow :width (bitmap-hunk-width hunk)
1482     :height (bitmap-hunk-height hunk))
1483     (hunk-draw-bottom-border hunk)))
1484    
1485     ;;; HUNK-CHANGED is called from the changed window handler and HUNK-RESET.
1486     ;;; Don't go through REDISPLAY-WINDOW-ALL since the window changed handler
1487     ;;; updates the window image.
1488     ;;;
1489     (defun hunk-changed (hunk new-width new-height redisplay)
1490     (set-hunk-size hunk new-width new-height)
1491     (funcall (bitmap-hunk-changed-handler hunk) hunk)
1492     (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk))))
1493    
1494    
1495     ;;; SET-HUNK-SIZE -- Internal
1496     ;;;
1497     ;;; Given a pixel size for a bitmap hunk, set the char size. If the window
1498     ;;; is too small, we refuse to admit it; if the user makes unreasonably small
1499     ;;; windows, our only responsibity is to not blow up. X will clip any stuff
1500     ;;; that doesn't fit.
1501     ;;;
1502     (defun set-hunk-size (hunk w h &optional modelinep)
1503     (let* ((font-family (bitmap-hunk-font-family hunk))
1504     (font-width (font-family-width font-family))
1505     (font-height (font-family-height font-family)))
1506     (setf (bitmap-hunk-height hunk) h)
1507     (setf (bitmap-hunk-width hunk) w)
1508     (setf (bitmap-hunk-char-width hunk)
1509     (max (truncate (- w hunk-left-border) font-width)
1510     minimum-window-columns))
1511     (let* ((h-minus-borders (- h hunk-top-border
1512     (bitmap-hunk-bottom-border hunk)))
1513     (hwin (bitmap-hunk-window hunk))
1514     (modelinep (or modelinep (and hwin (window-modeline-buffer hwin)))))
1515     (setf (bitmap-hunk-char-height hunk)
1516     (max (if modelinep
1517     (1- (truncate (- h-minus-borders
1518     hunk-modeline-top hunk-modeline-bottom)
1519     font-height))
1520     (truncate h-minus-borders font-height))
1521     minimum-window-lines))
1522     (setf (bitmap-hunk-modeline-pos hunk)
1523     (if modelinep (- h font-height
1524     hunk-modeline-top hunk-modeline-bottom))))))
1525    
1526     (defun bitmap-hunk-bottom-border (hunk)
1527     (if (bitmap-hunk-thumb-bar-p hunk)
1528     hunk-thumb-bar-bottom-border
1529     hunk-bottom-border))
1530    
1531    
1532     ;;; DEFAULT-GCONTEXT is used when making hunks.
1533     ;;;
1534     (defun default-gcontext (drawable &optional font-family)
1535     (xlib:create-gcontext
1536     :drawable drawable
1537     :foreground *default-foreground-pixel*
1538     :background *default-background-pixel*
1539     :font (if font-family (svref (font-family-map font-family) 0))))
1540    
1541    
1542     ;;; WINDOW-ROOT-XY returns the x and y coordinates for a window relative to
1543     ;;; its root. Some window managers reparent Hemlock's window, so we have
1544     ;;; to mess around possibly to get this right. If x and y are supplied, they
1545     ;;; are relative to xwin's parent.
1546     ;;;
1547     (defun window-root-xy (xwin &optional x y)
1548     (multiple-value-bind (children parent root)
1549     (xlib:query-tree xwin)
1550     (declare (ignore children))
1551     (if (eq parent root)
1552     (if (and x y)
1553     (values x y)
1554     (xlib:with-state (xwin)
1555     (values (xlib:drawable-x xwin) (xlib:drawable-y xwin))))
1556     (multiple-value-bind
1557     (tx ty)
1558     (if (and x y)
1559     (xlib:translate-coordinates parent x y root)
1560     (xlib:with-state (xwin)
1561     (xlib:translate-coordinates
1562     parent (xlib:drawable-x xwin) (xlib:drawable-y xwin) root)))
1563     (values (- tx xwindow-border-width)
1564     (- ty xwindow-border-width))))))
1565    
1566     ;;; CREATE-WINDOW-WITH-PROPERTIES makes an X window with parent. X, y, w, and
1567     ;;; h are possibly nil, so we supply zero in this case. This would be used
1568     ;;; for prompting the user. Some standard properties are set to keep window
1569     ;;; managers in line. We name all windows because awm and twm window managers
1570     ;;; refuse to honor menu clicks over windows without names. Min-width and
1571     ;;; min-height are optional and only used for prompting the user for a window.
1572     ;;;
1573     (defun create-window-with-properties (parent x y w h font-width font-height
1574     icon-name &optional min-width min-height)
1575     (let ((win (xlib:create-window
1576     :parent parent :x (or x 0) :y (or y 0)
1577     :width (or w 0) :height (or h 0)
1578     :background *default-background-pixel*
1579     :border-width xwindow-border-width
1580     :border *default-border-pixmap*
1581     :class :input-output)))
1582     (xlib:set-wm-properties
1583     win :name (new-hemlock-window-name) :icon-name icon-name
1584     :resource-name "Hemlock"
1585     :x x :y y :width w :height h
1586     :user-specified-position-p t :user-specified-size-p t
1587     :width-inc font-width :height-inc font-height
1588     :min-width min-width :min-height min-height)
1589     win))
1590    
1591     #|
1592     ;;; SET-WINDOW-ROOT-Y moves xwin to the y position relative to the root. Some
1593     ;;; window managers reparent Hemlock's window, so we have to mess around
1594     ;;; possibly to get this right. In this case we want to move the parent to the
1595     ;;; root y position less how far down our window is inside this new parent.
1596     ;;;
1597     (defun set-window-root-y (xwin y)
1598     (multiple-value-bind (children parent root)
1599     (xlib:query-tree xwin)
1600     (declare (ignore children))
1601     (if (eq parent root)
1602     (setf (xlib:drawable-y xwin) y)
1603     (setf (xlib:drawable-y parent) (- y (xlib:drawable-y xwin))))))
1604     |#
1605    
1606     ;;; SET-WINDOW-HOOK-RAISE-FUN is a "Set Window Hook" function controlled by
1607     ;;; "Set Window Autoraise". When autoraising, check that it isn't only the
1608     ;;; echo area window that we autoraise; if it is only the echo area window,
1609     ;;; then see if window is the echo area window.
1610     ;;;
1611     (defun set-window-hook-raise-fun (window)
1612     (let ((auto (value ed::set-window-autoraise)))
1613     (when (and auto
1614     (or (not (eq auto :echo-only))
1615     (eq window *echo-area-window*)))
1616     (let* ((hunk (window-hunk window))
1617     (win (bitmap-hunk-xwindow hunk)))
1618     (xlib:map-window win)
1619     (setf (xlib:window-priority win) :above)
1620     (xlib:display-force-output
1621     (bitmap-device-display (device-hunk-device hunk)))))))
1622    
1623    
1624     ;;; REVERSE-VIDEO-HOOK-FUN is called when the variable "Reverse Video" is set.
1625     ;;; If we are running on a windowed bitmap, we first setup the default
1626     ;;; foregrounds and backgrounds. Having done that, we get a new cursor. Then
1627     ;;; we do over all the hunks, updating their graphics contexts, cursors, and
1628     ;;; backgrounds. The current window's border is given the new highlight pixmap.
1629     ;;; Lastly, we update the random typeout hunk and redisplay everything.
1630     ;;;
1631     (defun reverse-video-hook-fun (name kind where new-value)
1632     (declare (ignore name kind where))
1633     (when (windowed-monitor-p)
1634     (let* ((current-window (current-window))
1635     (current-hunk (window-hunk current-window))
1636     (device (device-hunk-device current-hunk))
1637     (display (bitmap-device-display device)))
1638     (cond
1639     (new-value
1640     (setf *default-background-pixel*
1641     (xlib:screen-black-pixel (xlib:display-default-screen display)))
1642     (setf *default-foreground-pixel*
1643     (xlib:screen-white-pixel (xlib:display-default-screen display)))
1644     (setf *cursor-background-color* (make-black-color))
1645     (setf *cursor-foreground-color* (make-white-color))
1646     (setf *hack-hunk-replace-line* nil))
1647     (t (setf *default-background-pixel*
1648     (xlib:screen-white-pixel (xlib:display-default-screen display)))
1649     (setf *default-foreground-pixel*
1650     (xlib:screen-black-pixel (xlib:display-default-screen display)))
1651     (setf *cursor-background-color* (make-white-color))
1652     (setf *cursor-foreground-color* (make-black-color))
1653     (setf *hack-hunk-replace-line* t)))
1654     (setf *highlight-border-pixmap* *default-foreground-pixel*)
1655     (get-hemlock-cursor display)
1656     (dolist (hunk (device-hunks device))
1657     (reverse-video-frob-hunk hunk))
1658     (dolist (rt-info *random-typeout-buffers*)
1659     (reverse-video-frob-hunk
1660     (window-hunk (random-typeout-stream-window (cdr rt-info)))))
1661     (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk))
1662     *highlight-border-pixmap*))
1663     (redisplay-all)))
1664    
1665     (defun reverse-video-frob-hunk (hunk)
1666     (let ((gcontext (bitmap-hunk-gcontext hunk)))
1667     (setf (xlib:gcontext-foreground gcontext) *default-foreground-pixel*)
1668     (setf (xlib:gcontext-background gcontext) *default-background-pixel*))
1669     (let ((xwin (bitmap-hunk-xwindow hunk)))
1670     (setf (xlib:window-cursor xwin) *hemlock-cursor*)
1671     (setf (xlib:window-background xwin) *default-background-pixel*)))

  ViewVC Help
Powered by ViewVC 1.1.5