;;; 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
    ))