Mercurial > hg > xemacs

comparison lucid/rooms.el @ 0:107d592c5f4a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
DICE versions, used by pers/common, recursive, I think/hope
author Henry S. Thompson <ht@inf.ed.ac.uk>
date Mon, 08 Feb 2021 11:44:37 +0000
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:107d592c5f4a
1 ;;; rooms facility for gnuemacs
2
3 ;;; Copyright Henry S. Thompson 1990
4
5 ;;; Last edited: Wed Sep 14 08:48:27 1994
6
7 ;;; v19.19 version
8
9 (provide 'rooms)
10 (require 'prompt-for-word)
11
12 (defvar rooms-table nil "a-list of rooms in the form (name . window-specs)")
13
14 (defvar frames-table nil "a-list of room to frame mappings")
15
16 (defvar rooms-map (let ((new (copy-keymap pfw-map)))
17 (define-key new "\C-r" 'minibuffer-complete-and-exit)
18 new)
19 "allow ^R as synonym for CR in prompt-for-word")
20
21 (defmacro room-name (room) (list 'car room))
22 (defmacro room-window-specs (room) (list 'cdr room))
23 (defmacro make-room (name window-specs) (list 'cons name window-specs))
24
25 (defvar current-room nil "the current room")
26
27 (defvar previous-room nil "the previous room")
28
29 ;; a window spec is of the form (buffer-name constitution . edges)
30 (defmacro ws-buffer-name (ws) (list 'car ws))
31 (defmacro ws-constitution (ws) (list 'car (list 'cdr ws)))
32 (defmacro ws-edges (ws) (list 'cdr (list 'cdr ws)))
33 (defmacro make-ws (buffer-name constitution edges)
34 (list 'cons buffer-name
35 (list 'cons constitution edges)))
36
37 (defun rooms-top (redraw)
38 "top level for rooms - prompts for room name and goes there.
39 Prefix arg forces room's frame to its defined contents.
40 Typing overrides initial suggestion, exiting completes. To name a new room
41 exit with ^N
42 To redefine an existing room, exit with ^R"
43 (interactive "PIf prefixed, forces room's frame, if any, to its defined contents")
44 (let ((name (prompt-for-word "Room: " (or (room-name previous-room) "")
45 rooms-table (if rooms-table
46 rooms-map)))
47 (e-o-c last-input-char)
48 room)
49 (cond ((eq e-o-c 18) ; ^R
50 (rooms-redefine-query name))
51 (t
52 (if (setq room (assoc name rooms-table))
53 (rooms-goto room redraw)
54 (rooms-new-query name))))))
55
56 (defun rooms-goto (room &optional redraw) "switch frame to ROOM's config"
57 (let ((room (if (stringp room)
58 (or (assoc room rooms-table)
59 (error "No room named %s" room))
60 room))
61 st-entry)
62 (if (not (eq room current-room))
63 (setq previous-room current-room))
64 (setq current-room room)
65 ;; lazy if mapped to frame and not redraw
66 (if (setq st-entry (assoc (room-name room) frames-table))
67 ;; very tricky -- appears to be the only order that works!
68 (progn
69 ; (focus-frame (cdr st-entry))
70 (select-frame (cdr st-entry))
71 (raise-frame (cdr st-entry)) ; gwm/empty.gwm/emacs-19.28 pblm???
72 (if redraw (establish-room room)))
73 (establish-room room))))
74
75 (defun rooms-new-query (name)
76 "check to see if new room or definition wanted"
77 (if (y-or-n-p (concat "Define a new room named "
78 name
79 "? "))
80 (rooms-new name)
81 (message "")))
82
83 (defun rooms-redefine-query (name) "check to see if new room wanted"
84 (if (y-or-n-p (concat "Redefine the room named "
85 name
86 "? "))
87 (progn (setq rooms-table (delq (or (assoc name rooms-table)
88 (error "shouldnt"))
89 rooms-table))
90 (rooms-new name))
91 (message "")))
92
93 (defun rooms-new (name) "define a new room named NAME as per the current frame"
94 (interactive "sroom name for current frame: ")
95 (let ((here (selected-window))
96 (looping t)
97 spec top-p next all-specs)
98 ;; collect specs for all windows on frame, noting top one
99 (setq next here)
100 (while looping
101 (setq spec (window-edges next))
102 (setq all-specs (cons (make-ws (buffer-name (window-buffer next))
103 nil
104 spec)
105 all-specs))
106 (if (= (car (cdr spec)) 0) ; check for top
107 (progn (setq top-p all-specs)
108 (setq all-specs nil)))
109 (setq next (previous-window next))
110 (if (eq next here)
111 (setq looping nil)))
112 (setq rooms-table
113 (cons
114 (make-room name
115 (nconc top-p
116 all-specs))
117 rooms-table))
118 (message (concat name " defined as current frame configuration"))))
119
120 (global-set-key "\eo" 'rooms-top)
121
122 (defun define-rooms (spec-list) "define rooms from specs"
123 (let ((spp spec-list))
124 (while spp
125 (establish-room (car spp) t)
126 (setq spp (cdr spp)))))
127
128 (defun establish-room (r-spec &optional create) "define room from spec"
129 ;; a room-spec is of the form (name . window-specs)
130 ;; a window spec is of the form (buffer-name constitution . edges)
131 ;; a buffer-name is either a string, in which case the constitution will be
132 ;; left to create it, or (<string>), in which case a new buffer of that name
133 ;; will be generated first.
134 ;; a constitution is either nil, a file name to be visited, or a form
135 ;; to be evaluated
136 ;; if create is nil, buffer is not touched (constitution is ignored)
137 (let ((r-name (room-name r-spec))
138 (w-specs (room-window-specs r-spec))
139 (used -1)
140 w-spec st-entry)
141 (if create
142 (while w-specs
143 (setq w-spec (car w-specs))
144 (let ((buf-name (ws-buffer-name w-spec))
145 (const (ws-constitution w-spec)))
146 ;; initialise the buffer
147 (if (consp buf-name)
148 (set-buffer (generate-new-buffer (car buf-name))))
149 (if const
150 (condition-case foo
151 (if (stringp const)
152 (find-file const)
153 (eval const))
154 (error (message "%s" foo)))))
155 (setq w-specs (cdr w-specs))))
156 (setq w-specs (room-window-specs r-spec))
157 (switch-to-buffer (let ((b-n (ws-buffer-name (car w-specs))))
158 (if (consp b-n)
159 (car b-n)
160 b-n)))
161 (delete-other-windows)
162 (setq w-specs (cdr w-specs))
163 (while w-specs
164 (setq w-spec (car w-specs))
165 (let ((buf-name (ws-buffer-name w-spec))
166 (edges (ws-edges w-spec)))
167 ;; make a window of the right size
168 ;; we assume full-width windows for now, with specs in top-to-bottom
169 (let ((top (1- (car (cdr edges)))))
170 (split-window-vertically (- top used))
171 (setq used top))
172 (other-window 1)
173 (switch-to-buffer (if (consp buf-name)
174 (car buf-name)
175 buf-name)))
176 (setq w-specs (cdr w-specs)))
177 (if create
178 (setq rooms-table (nconc rooms-table (list r-spec))))))
179
180 (defun make-frame-for-room (&optional name xpos ypos ixpos iypos)
181 "prompts for room name and makes a frame for it.
182 Typing overrides initial suggestion, exiting completes."
183 (interactive)
184 (let ((name (or name
185 (prompt-for-word "Room: " (or (room-name previous-room) "")
186 rooms-table (if rooms-table
187 rooms-map))))
188 room)
189 (if (not (setq room (assoc name rooms-table)))
190 (error "no room named %s" name)
191 (let ((last-w-edges (ws-edges (last-element (room-window-specs room))))
192 (st-entry (assoc name frames-table))
193 ;; assume (falsely) that new frame will be like old one
194 (parms (frame-parameters nil))
195 (sys-name (substring (system-name) 0
196 (string-match "\\." (system-name))))
197 frame)
198 (let ((width (car (cdr (cdr last-w-edges))))
199 (height (+
200 (or (cdr (assoc 'menu-bar-lines parms)) 0)
201 1 ; allowing 1 for mode line
202 (if (let ((mb (cdr (assoc 'minibuffer parms))))
203 (or
204 (eq mb t)
205 (and (windowp mb)
206 (eq (window-frame mb)
207 (selected-frame)))))
208 1
209 0)
210 (car (cdr (cdr (cdr last-w-edges))))))
211 (x-slop (+ (* 2 (+ (cdr (assoc 'border-width parms))
212 (cdr (assoc 'internal-border-width parms))))
213 (if (cdr (assoc 'vertical-scroll-bars parms))
214 19
215 0)))
216 (y-slop (+ (* 2 (+ (cdr (assoc 'border-width parms))
217 (cdr (assoc 'internal-border-width parms))))
218 (if (cdr (assoc 'horizontal-scroll-bars parms))
219 19
220 0)
221 16 ; window title bar
222 ))
223 (title
224 (concat name
225 ":" (user-login-name)
226 (concat "@" sys-name)
227 )))
228 (let ((args (list
229 (cons 'width width)
230 (cons 'height height)
231 ;; Note that x-parse-geometry doesn't handle all position cases
232 (cons 'left
233 (if xpos
234 (+ (if (string-match
235 "^[+]" xpos)
236 0
237 (-
238 (x-display-pixel-width)
239 (+ (* (face-width (get-face 'default))
240 width)
241 x-slop)))
242 (car (read-from-string xpos)
243 ))
244 0))
245 (cons 'top
246 (if ypos
247 (+ (if (string-match
248 "^[+]" ypos)
249 0
250 (-
251 (x-display-pixel-height)
252 (+ (* (face-height (get-face 'default))
253 height)
254 y-slop)))
255 (car
256 (read-from-string ypos)))
257 0))
258 (cons 'name title))))
259 (setq frame
260 (make-frame args))))
261 (if st-entry
262 (rplacd st-entry frame)
263 (setq frames-table (cons (cons name frame)
264 frames-table)))
265 (if (or ixpos iypos)
266 (position-frame-icon (or ixpos
267 (car
268 (cdr
269 (assoc 'left
270 (frame-parameters frame)))))
271 (or iypos (car
272 (cdr
273 (assoc 'top
274 (frame-parameters frame)))))
275 frame)))
276 (rooms-goto room t))))
277
278 (defun make-screen-for-room (&optional name xpos ypos ixpos iypos)
279 (make-frame-for-room name xpos ypos ixpos iypos))
280
281 (defun position-frame-icon (x y frame)
282 "fiddle to get the icon for a frame in a specified place"
283 )
284
285 (defun last-element (list)
286 "Return last element of LIST."
287 (let ((last nil))
288 (while list
289 (if (null (cdr list))
290 (setq last (car list)))
291 (setq list (cdr list)))
292 last
293 ))