--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lucid/rooms.el	Mon Feb 08 11:44:37 2021 +0000
@@ -0,0 +1,293 @@
+;;; rooms facility for gnuemacs
+
+;;; Copyright Henry S. Thompson 1990
+
+;;; Last edited: Wed Sep 14 08:48:27 1994
+
+;;; v19.19 version
+
+(provide 'rooms)
+(require 'prompt-for-word)
+
+(defvar rooms-table nil "a-list of rooms in the form (name . window-specs)")
+
+(defvar frames-table nil "a-list of room to frame mappings")
+
+(defvar rooms-map (let ((new (copy-keymap pfw-map)))
+		    (define-key new "\C-r" 'minibuffer-complete-and-exit)
+		    new)
+  "allow ^R as synonym for CR in prompt-for-word")
+
+(defmacro room-name (room) (list 'car room))
+(defmacro room-window-specs (room) (list 'cdr room))
+(defmacro make-room (name window-specs) (list 'cons name window-specs))
+
+(defvar current-room nil "the current room")
+
+(defvar previous-room nil "the previous room")
+
+;; a window spec is of the form (buffer-name constitution . edges)
+(defmacro ws-buffer-name (ws) (list 'car ws))
+(defmacro ws-constitution (ws) (list 'car (list 'cdr ws)))
+(defmacro ws-edges (ws) (list 'cdr (list 'cdr ws)))
+(defmacro make-ws (buffer-name constitution edges)
+  (list 'cons buffer-name
+	(list 'cons constitution edges)))
+
+(defun rooms-top (redraw)
+  "top level for rooms - prompts for room name and goes there.
+Prefix arg forces room's frame to its defined contents.
+Typing overrides initial suggestion, exiting completes.  To name a new room
+exit with ^N
+To redefine an existing room, exit with ^R"
+  (interactive "PIf prefixed, forces room's frame, if any, to its defined contents")
+  (let ((name (prompt-for-word "Room: " (or (room-name previous-room) "")
+			       rooms-table (if rooms-table
+					       rooms-map)))
+	(e-o-c last-input-char)
+	room)
+    (cond ((eq e-o-c 18)		; ^R
+	   (rooms-redefine-query name))
+	  (t
+	   (if (setq room (assoc name rooms-table))
+	       (rooms-goto room redraw)
+	     (rooms-new-query name))))))
+
+(defun rooms-goto (room &optional redraw) "switch frame to ROOM's config"
+  (let ((room (if (stringp room)
+		  (or (assoc room rooms-table)
+		      (error "No room named %s" room))
+		room))
+	st-entry)
+    (if (not (eq room current-room))
+	(setq previous-room current-room))
+    (setq current-room room)
+    ;; lazy if mapped to frame and not redraw
+    (if (setq st-entry (assoc (room-name room) frames-table))
+	;; very tricky -- appears to be the only order that works!
+	(progn 
+;	  (focus-frame (cdr st-entry))
+	  (select-frame (cdr st-entry))
+	  (raise-frame (cdr st-entry)) ; gwm/empty.gwm/emacs-19.28 pblm???
+	  (if redraw (establish-room room)))
+      (establish-room room))))
+
+(defun rooms-new-query (name)
+  "check to see if new room or definition wanted"
+  (if (y-or-n-p (concat "Define a new room named "
+			name
+			"? "))
+      (rooms-new name)
+    (message "")))
+
+(defun rooms-redefine-query (name) "check to see if new room wanted"
+  (if (y-or-n-p (concat "Redefine the room named "
+			name
+			"? "))
+      (progn (setq rooms-table (delq (or (assoc name rooms-table)
+					 (error "shouldnt"))
+				     rooms-table))
+	     (rooms-new name))
+    (message "")))
+
+(defun rooms-new (name) "define a new room named NAME as per the current frame"
+  (interactive "sroom name for current frame: ")
+  (let ((here (selected-window))
+	(looping t)
+	spec top-p next all-specs)
+    ;; collect specs for all windows on frame, noting top one
+    (setq next here)
+    (while looping
+      (setq spec (window-edges next))
+      (setq all-specs (cons (make-ws (buffer-name (window-buffer next))
+				     nil
+				     spec)
+			    all-specs))
+      (if (= (car (cdr spec)) 0)	; check for top
+	  (progn (setq top-p all-specs)
+		 (setq all-specs nil)))
+      (setq next (previous-window next))
+      (if (eq next here)
+	  (setq looping nil)))
+    (setq rooms-table
+	  (cons
+	   (make-room name
+		      (nconc top-p
+			     all-specs))
+	   rooms-table))
+    (message (concat name " defined as current frame configuration"))))
+
+(global-set-key "\eo" 'rooms-top)
+
+(defun define-rooms (spec-list) "define rooms from specs"
+  (let ((spp spec-list))
+    (while spp
+      (establish-room (car spp) t)
+      (setq spp (cdr spp)))))
+
+(defun establish-room (r-spec &optional create) "define room from spec"
+  ;; a room-spec is of the form (name . window-specs)
+  ;; a window spec is of the form (buffer-name constitution . edges)
+  ;; a buffer-name is either a string, in which case the constitution will be
+  ;; left to create it, or (<string>), in which case a new buffer of that name
+  ;; will be generated first.
+  ;; a constitution is either nil, a file name to be visited, or a form
+  ;; to be evaluated
+  ;; if create is nil, buffer is not touched (constitution is ignored)
+  (let ((r-name (room-name r-spec))
+	(w-specs (room-window-specs r-spec))
+	(used -1)
+	w-spec st-entry)
+    (if create
+	(while w-specs
+	  (setq w-spec (car w-specs))
+	  (let ((buf-name (ws-buffer-name w-spec))
+		(const (ws-constitution w-spec)))
+	    ;; initialise the buffer
+	    (if (consp buf-name)
+		(set-buffer (generate-new-buffer (car buf-name))))
+	    (if const
+		(condition-case foo
+		    (if (stringp const)
+			(find-file const)
+		      (eval const))
+		  (error (message "%s" foo)))))
+	  (setq w-specs (cdr w-specs))))
+    (setq w-specs (room-window-specs r-spec))
+    (switch-to-buffer (let ((b-n (ws-buffer-name (car w-specs))))
+			(if (consp b-n)
+			    (car b-n)
+			  b-n)))
+    (delete-other-windows)
+    (setq w-specs (cdr w-specs))
+    (while w-specs
+      (setq w-spec (car w-specs))
+      (let ((buf-name (ws-buffer-name w-spec))
+	    (edges (ws-edges w-spec)))
+	;; make a window of the right size
+	;; we assume full-width windows for now, with specs in top-to-bottom
+	(let ((top (1- (car (cdr edges)))))
+	  (split-window-vertically (- top used))
+	  (setq used top))
+	(other-window 1)
+	(switch-to-buffer (if (consp buf-name)
+			      (car buf-name)
+			    buf-name)))
+      (setq w-specs (cdr w-specs)))
+    (if create
+	(setq rooms-table (nconc rooms-table (list r-spec))))))
+
+(defun make-frame-for-room (&optional name xpos ypos ixpos iypos)
+  "prompts for room name and makes a frame for it.
+Typing overrides initial suggestion, exiting completes."
+  (interactive)
+  (let ((name (or name
+		  (prompt-for-word "Room: " (or (room-name previous-room) "")
+				   rooms-table (if rooms-table
+						   rooms-map))))
+	room)
+    (if (not (setq room (assoc name rooms-table)))
+	(error "no room named %s" name)
+      (let ((last-w-edges (ws-edges (last-element (room-window-specs room))))
+	    (st-entry (assoc name frames-table))
+	    ;; assume (falsely) that new frame will be like old one
+	    (parms (frame-parameters nil))
+	    (sys-name (substring (system-name) 0
+				 (string-match "\\." (system-name))))
+	    frame)
+	(let ((width (car (cdr (cdr last-w-edges))))
+	      (height (+
+		       (or (cdr (assoc 'menu-bar-lines parms)) 0)
+		       1		; allowing 1 for mode line
+		       (if (let ((mb (cdr (assoc 'minibuffer parms))))
+			       (or
+				(eq mb t)
+				(and (windowp mb)
+				     (eq (window-frame mb)
+					 (selected-frame)))))
+			     1
+			   0)
+		       (car (cdr (cdr (cdr last-w-edges))))))
+	      (x-slop (+ (* 2 (+ (cdr (assoc 'border-width parms))
+				 (cdr (assoc 'internal-border-width parms))))
+			 (if (cdr (assoc 'vertical-scroll-bars parms))
+			     19
+			   0)))
+	      (y-slop (+ (* 2 (+ (cdr (assoc 'border-width parms))
+				 (cdr (assoc 'internal-border-width parms))))
+			 (if (cdr (assoc 'horizontal-scroll-bars parms))
+			     19
+			   0)
+			 16		; window title bar
+			 ))
+	      (title
+	       (concat name
+		       ":" (user-login-name)
+		       (concat "@" sys-name)
+		       )))
+	  (let ((args (list
+		       (cons 'width width)
+		       (cons 'height height)
+		;; Note that x-parse-geometry doesn't handle all position cases
+		       (cons 'left
+			     (if xpos
+				 (+ (if (string-match
+					 "^[+]" xpos)
+					0
+				      (-
+				       (x-display-pixel-width)
+				       (+ (* (face-width (get-face 'default))
+					     width)
+					  x-slop)))
+				    (car (read-from-string xpos)
+					 ))
+			       0))
+		       (cons 'top
+			     (if ypos
+				 (+ (if (string-match
+					 "^[+]" ypos)
+					0
+				      (-
+				       (x-display-pixel-height)
+				       (+ (* (face-height (get-face 'default))
+					     height)
+					  y-slop)))
+				     (car
+				      (read-from-string ypos)))
+			       0))
+		      (cons 'name title))))
+	    (setq frame
+		  (make-frame args))))
+	(if st-entry
+	    (rplacd st-entry frame)
+	  (setq frames-table (cons (cons name frame)
+				   frames-table)))
+	(if (or ixpos iypos)
+	    (position-frame-icon (or ixpos
+				     (car
+				      (cdr
+				       (assoc 'left
+					      (frame-parameters frame)))))
+				 (or iypos (car
+					    (cdr
+					     (assoc 'top
+						    (frame-parameters frame)))))
+				 frame)))
+      (rooms-goto room t))))
+
+(defun make-screen-for-room (&optional name xpos ypos ixpos iypos)
+  (make-frame-for-room  name xpos ypos ixpos iypos))
+
+(defun position-frame-icon (x y frame)
+  "fiddle to get the icon for a frame in a specified place"
+)
+
+(defun last-element (list)
+  "Return last element of LIST."
+  (let ((last nil))
+    (while list
+      (if (null (cdr list))
+	  (setq last (car list)))
+      (setq list (cdr list)))
+    last
+    ))