;;; Copyright (C) 1990  Alan M. Carroll
(provide 'scr-pool)
(require 'cl)
;;;
;;; This file is for use with Epoch, a modified version of GNU Emacs.
;;; Requires Epoch 3.2 or later.
;;;
;;; This code is distributed in the hope that it will be useful,
;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
;;; responsibility to anyone for the consequences of using this code
;;; or for whether it serves any particular purpose or works at all,
;;; unless explicitly stated in a written agreement.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License, except the original author nor his
;;; agents are bound by the License in their use of this code.
;;; (These special rights for the author in no way restrict the rights of
;;;  others given in the License or this prologue)
;;; A copy of this license is supposed to have been given to you along
;;; with Epoch so you can know your rights and responsibilities. 
;;; It should be in a file named COPYING.  Among other things, the
;;; copyright notice and this notice must be preserved on all copies. 
;;;
;;; --------------------------------------------------------------------------
;;; This file contains code to manipulate a set of screens as a pool.
;;; A pool is created by an init call, and then this pool object is passed to
;;; subsequent calls.
;;; --------------------------------------------------------------------------
(defun pool:create (size &optional create-func remove-func)
"Create a pool of screens, with SIZE screens, and optional CREATE-FUNCTION
and CLEANUP-FUNCTION. If a screen is requested and less than SIZE are in the
pool, CREATE-FUNCTION is called with no arguments to create the screen.
When a screen is reused, CLEANUP-FUNCTION is called with the screen as a
an argument first, to do any screen cleanup needed."
  (list size '() create-func remove-func)
)
;;;
(defun pool:delete (pool)
"Delete the pool and all screens in it. The clean-up function is called on
each screen before it is deleted."
  (let ( (cleanup (nth 3 pool)) )
    (dolist (s (nth 1 pool))
      (and cleanup (funcall cleanup s))
      (delete-screen s)
      (setcar (cdr pool) (delq s (nth 1 pool)))	;remove the screen.
    )
  )
)
;;;
(defun pool:mark-screen (pool scr)
"Set the POOL so that SCREEN is recorded as the most recently used"
  (setcar (cdr pool) (cons scr (delq scr (nth 1 pool))))
)
;;;
(defun pool:unmark-screen (pool scr)
"Set the POOL so that SCREEN is recorded as the least recently used"
  (setcar (cdr pool) (nconc (delq scr (nth 1 pool)) (list scr)))
)
;;; --------------------------------------------------------------------------
(defun pool:get-screen (pool)
"Allocate a screen from POOL."
  (let*
    (
      (size (car pool))
      (creator (or (nth 2 pool) 'create-screen))
      (cleaner (nth 3 pool))
      (screens (nth 1 pool))
      (count (length screens))
      (scr nil)
    )
    ;;body
    (while (and (not (screenp scr)) (not (eq scr 'failure)))
      (cond
	((or (null size) (< count size)) ;no limit or not full
	  (setq scr (funcall creator))
	  (if (not (screenp scr)) (setq scr 'failure))
	)
	((> count 0)
	  (setq scr (nth (- count 1) screens))	;get the last
	  (if (get-screen-id scr)
	    (and cleaner (funcall cleaner scr))	;live screen
	    (progn
	      (setq scr nil)		;mark as dead
	      (decf count)		;update count
	      (setcdr (nthcdr (1- count) (nth 1 pool)) nil) ;clip list
	    )
	  )
	)
	(t (error "Malformed pool") )
      )
    )
    (if (screenp scr) (pool:mark-screen pool scr))
    scr					;return result
  )
)
;;; --------------------------------------------------------------------------
(defun pool:get-screen-with-buffer (pool buffer)
"Allocates a screen from POOL. If there is a screen already displaying BUFFER,
then return that screen. The allocated screen is marked as recently used."
  (let*
    (
      (slist (and buffer (screens-of-buffer buffer)))
      (valid (nth 1 pool))
      (scr nil)
    )
    (catch 'outta-here
      (while slist
	(setq scr (car slist))
	(if (memq scr valid) (throw 'outta-here scr))
	(setq slist (cdr slist))
      )
    )
    (if (screenp scr)
      (progn
	(pool:mark-screen pool scr)
	scr
      )
      (pool:get-screen pool)
    )
  )
)
;;; --------------------------------------------------------------------------
;;; Shrink wrap support
;;;
;;; globals for specifying the screen dimensions
(defvar pool::screen-height nil "Pool create screen hook var, specifying the height. NOT FOR EXTERNAL USE.")
(defvar pool::screen-width nil "Pool create screen hook var, specifying the width. NOT FOR EXTERNAL USE.")
;;;
(defun pool::create-screen-hook (alist)
"Screen pool create screen hook function. NOT FOR EXTERNAL USE."
  (let*
    (
      (geom (assq 'geometry alist))
      (spec (cdr geom))
      (loc
	(and pool::screen-width pool::screen-height
	  (format "%dx%d" pool::screen-width pool::screen-height)
	)
      )
      (result alist)
    )
    (if loc
      (cond
	((null geom)
	  (setq result (cons (cons 'geometry loc) alist))
	)
	((stringp spec)
	  (setcdr geom
	    (concat loc
	      (if (string-match "[0-9]+x[0-9]+" spec)
		(substring spec (match-end 0))
		spec
	      )
	    )
	  )
	)
	(t (setcdr geom loc))
      )
    )
    result				;return value
  )
)
(push 'pool::create-screen-hook *create-screen-alist-hook*)
;;;
(defun pool:get-shrink-wrapped-screen (pool buff limits)
"Get a screen from POOL and set it to display BUFF. The screen is
shrunk to fit BUFF, up the sizes specified by LIMITS, a list of (
min-width max-width min-height max-height ).  Using this function will
cause other geometry specifications to be overridden."
  ;;
  (setq buff (get-buffer buff))
  (save-excursion (set-buffer buff)
    (let
      (
	(min-x (or (nth 0 limits) 4)) ;widest line so far
	(max-x (or (nth 1 limits) 150))
	(min-y (or (nth 2 limits) 2))
	(max-y (or (nth 3 limits) 70))
	(line 0)
	max-width
	(here (point))
      )
      (setq max-width min-x)
      (goto-char (point-min))
      (setq max-width (save-excursion (end-of-line) (current-column)))
      (while (and (not (eobp)) (<= (forward-line 1) 0))
	(setq max-width
	  (max max-width
	    (save-excursion (end-of-line) (current-column))
	  )
	)
	(incf line)
      )
      (goto-char here)			;restore point
      ;; we've measured the buffer, now set globals.
      (setq pool::screen-width
	(min max-x (max min-x (+ max-width 1)))
      )
      (setq pool::screen-height (max min-y (min (1+ line) max-y)))
    )
  )
  ;; everything is set, do it!
  (let
    (
      (scr (pool:get-screen-with-buffer pool buff))
    )
    ;; fix the size (if needed) before mapping
    (if
      (or
	(/= (epoch::screen-height scr) pool::screen-height)
	(/= (epoch::screen-width scr) pool::screen-width)
      )
      ;; THEN
      (change-screen-size pool::screen-width pool::screen-height scr)
    )
    ;; disarm the hook.
    (setq pool::screen-width (setq pool::screen-height nil))
    ;; set up the screen
    (select-screen scr)
    (delete-other-windows)		;no other windows
    (set-window-buffer (selected-window) buff)		;display buffer
    (if (screen-mapped-p scr)
      (cursor-to-screen (raise-screen scr))
      (on-map-do (mapraised-screen scr) 'cursor-to-screen)
    )
    ;;
    scr					;return value
  )
)