;;;
;;; Talk item groups.
;;;
;;; ----------------------------------------------------------------------
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; ----------------------------------------------------------------------
;;;
;;; Name prefixes:
;;;
;;; tm		General prefix for Talk Mode mode identifiers.
;;;

(require 'talk-struct)

(if emacs19p
    (require 'talk-groups19)
  (require 'talk-groups18))


;; Global variables
;; ----------------
;;

(defvar tm:group-pointer "> "
  "String used to mark the current element in a group buffer.")

(defvar tm:group-pointer-len (length tm:group-pointer)
  "Length of tm:group-pointer")

(defvar tm:group-non-pointer (make-string tm:group-pointer-len ? )
  "String used to mark a non-current element in a group buffer.")


;; Buffer specific variables
;; -------------------------
;;

(defvar tml:buffer-group ()
  "If the buffer is displaying a group, contains that group,
otherwise ().")


;; Item structure
;; --------------
;;
;; An item is a group's element.
;;

(tm:defstruct tm:item ()
  ())


;; Groups structure
;; ----------------
;;
;; A group is a list of items, with a currently pointed item, which can
;; be edited in a buffer.
;;

(tm:defstruct tm:group ()
   ((index default: 0)
    ;; Current index in the items
    (items default: ())
    ;; List of items (in reverse order)
    (buffer default: ())
    ;; If the group has an associated buffer, this buffer.
    (modifiedp default: ())
    ;; True if an item was added or deleted since last buffer refresh. The
    ;; value of this field can be:
    ;; - deleted: an item was deleted
    ;; - added: an item was added at the end of the group
    ;; - moved: the index has moved
    ;; - (modified . <item>): the <item> must be redisplayed
    ;; - header: the header must be redisplayed.
    )
   (generic: tm:group-print-header (self))
   ;; To print in the current buffer the group's header.
   (generic: tm:group-print-item (self item))
   ;; To print in the current buffer an external form of the item.
   (generic: tm:group-remove-item-hook (self item))
   ;; Function called after an item is removed.
   (generic: tm:group-deselect-item-hook (self item))
   ;; Function called before ITEM is deselected.
   (generic: tm:group-select-item-hook (self item))
   ;; Function called after ITEM is selected.
   (generic: tm:group-delete-hook (self))
   ;; Function called before the group is deleted. If if returns (), the
   ;; group is not deleted.
   (generic: tm:group-item-selectable-p (self item))
   ;; Return T if ITEM can be selected as current.
   (generic: tm:group-attach-buffer-hook (self))
   ;; Hook called in a newly created group buffer
   (generic: tm:group-buffer-print-help (self))
   ;; Function called to print a group's buffer help
   (method: tm:group-print-header)
   (method: tm:group-delete-hook)
   (method: tm:group-remove-item-hook)
   (method: tm:group-deselect-item-hook)
   (method: tm:group-select-item-hook)
   (method: tm:group-item-selectable-p)
   (method: tm:group-attach-buffer-hook)
   (method: tm:group-buffer-print-help)
)

(tm:defmethod tm:group-print-header ((group tm:group))
  "Default method --- do nothing"
  ())

(tm:defmethod tm:group-delete-hook ((group tm:group))
  "Default method --- do nothing"
  t)

(tm:defmethod tm:group-remove-item-hook ((group tm:group) item)
  "Default method --- do nothing"
  ())

(tm:defmethod tm:group-deselect-item-hook ((group tm:group) item)
  "Default method --- do nothing"
  ())
  
(tm:defmethod tm:group-select-item-hook ((group tm:group) item)
  "Default method --- do nothing"
  ())

(tm:defmethod tm:group-item-selectable-p ((group tm:group) item)
  "Default method --- return T"
  t)


;; Groups internal operations
;; --------------------------
;;
;; The following operations don't do any buffer refresh or item highlighting.
;; Don't use them directly.
;; 

(defun tm:group-following-item (group direction)
  "Moves the current item index of GROUP according to DIRECTION, which
is either -1 or 1. In case of overflow, stay on the same position and
return ()."
  (if (> direction 0)
      (tm:group-next-item group)
    (tm:group-previous-item group)))

(defun tm:group-next-item (group)
  "Move the current item index of GROUP to the next item."
  (let* ((items (tm:group-items group))
	 (len (length items)))
    (if (= len 0)
	()
      (let* ((index (tm:group-index group))
	     (new-index (1- index)))
	(if (< new-index 0)
	    ()
	  (tm:set-group-index group new-index)
	  (tm:set-group-modifiedp group 'moved)
	  t)))))

(defun tm:group-previous-item (group)
  "Move the current item index of GROUP to the previous item."
  (let* ((items (tm:group-items group))
	 (len (length items)))
    (if (= len 0)
	()
      (let* ((index (tm:group-index group))
	     (new-index (1+ index)))
	(if (>= new-index len)
	    ()
	  (tm:set-group-index group new-index)
	  (tm:set-group-modifiedp group 'moved)
	  t)))))


;; Groups high-level operations
;; ----------------------------
;;
;; These operations properly refresh the buffer and call the hook
;; functions.
;;

(defun tm:group-clear (group)
  "Clear GROUP, ie delete all its items, but do not change any other field
nor delete its buffer. The buffer is refreshed."
  (let ((items (tm:group-items group)))
    (while items
      (tm:group-remove-item-hook group (car items))
      (setq items (cdr items)))
    (tm:set-group-index group 0)
    (tm:set-group-items group ())
    (tm:set-group-modifiedp group 'deleted)
    (tm:group-refresh-buffer group)))

(defun tm:group-delete (group)
  "Remove all the items from GROUP and delete it. If GROUP has an associated
buffer, kill that buffer."
  (if (tm:group-delete-hook group)
      (progn
	(tm:group-pre-delete group)
	(tm:kill-group-buffer group))))

(defun tm:group-pre-delete (group)
  "Delete the group without killing its buffer"
  (let ((items (tm:group-items group))
	(buffer (tm:group-buffer group)))
    (while items
      (tm:group-remove-item-hook group (car items))
      (setq items (cdr items)))
    (if (and buffer (buffer-name buffer))
	(save-excursion
	  (set-buffer buffer)
	  (setq tml:buffer-group ())))))

(defun tm:group-remove-item (group item)
  "Remove from GROUP the item ITEM."
  (let* ((items (tm:group-items group))
	 (i (tm:index item items)))
    (if i
	(progn
	  (tm:set-group-items group (delq item items))
	  (tm:group-remove-item-hook group item)
	  (if (null (tm:group-items group))
	      (tm:set-group-index group 0)
	    (let ((index (tm:group-index group)))
	      (if (and (> index 0) (>= index i))
		  (tm:set-group-index group (1- index))))
	    (let ((current-item (tm:group-current-item group)))
	      (if current-item
		  (tm:group-select-item-hook group current-item))))
	  (tm:set-group-modifiedp group 'deleted)
	  (tm:group-refresh-buffer group)))))

(defun tm:group-current-item (group)
  "Return the GROUP current item, or () if there is none."
  (let* ((index (tm:group-index group))
	 (items (tm:group-items group)))
    (nth index items)))

(defun tm:group-last-item (group)
  "Return the GROUP current item, or () if there is none."
  (let* ((items (tm:group-items group)))
    (if (null items)
	()
      (car items))))

(defun tm:group-nth-item (group index)
  "Return the GROUP item indexed by INDEX, or () if there is none."
  (let ((items (tm:group-items group)))
    (nth index items)))

(defun tm:group-add-item (group item selectp)
  "Add to GROUP the item ITEM. If SELECTP is true and there is no currently 
selected item, the new item is selected as current."
  (let* ((curr-index (tm:group-index group))
	 (items (tm:group-items group)))

    (tm:set-group-items group (cons item items))
    (tm:set-group-modifiedp group 'added)
    (if (and selectp (= curr-index (length items)))
	(tm:group-select-item-hook group item)
      (tm:set-group-index group (1+ curr-index)))
    (tm:group-refresh-buffer group)))

(defun tm:set-group-current-item (group item)
  "Make the current index of GROUP point to ITEM."
  (let* ((items (tm:group-items group))
	 (i (tm:index item items)))
    (if (and i (not (= i (tm:group-index group))))
	(let ((prev-item (tm:group-current-item group)))
	  (if prev-item
	      (tm:group-deselect-item-hook group prev-item))
	  (tm:group-select-item-hook group item)
	  (tm:set-group-index group i)
	  (tm:set-group-modifiedp group 'moved)
	  (tm:group-refresh-buffer group)))))

(defun tm:group-following-selectable-item (group direction)
  "Move the current item index of GROUP according to DIRECTION, which
is either -1 or 1, to the next selectable item."
  (let ((index (tm:group-index group))
	(found ()))
    (while (and (not found) (tm:group-following-item group direction))
      (setq found (tm:group-item-selectable-p
		   group
		   (tm:group-current-item group))))
    (if found
	(let ((prev-item (tm:group-nth-item group index)))
	  (if prev-item (tm:group-deselect-item-hook group prev-item))
	  (tm:group-select-item-hook group (tm:group-current-item group))
	  (tm:group-refresh-buffer group)
	  t)
      (tm:set-group-index group index)
      ())))

(defun tm:group-next-selectable-item (group)
  "Move the current item index of GROUP to the next item."
  (tm:group-following-selectable-item group 1))

(defun tm:group-previous-selectable-item (group)
  "Move the current item index of GROUP to the previous item."
  (tm:group-following-selectable-item group -1))

(defun tm:group-item-modified (group item)
  "Function called to signal that ITEM has be changed in GROUP."
  (tm:set-group-modifiedp group (cons 'modified item))
  (tm:group-refresh-buffer group))


;; Group buffer
;; ------------
;;

(defvar tm:group-buffer-map ()
  "Group buffer keymap.")

(if tm:group-buffer-map
    ()
  (setq tm:group-buffer-map (make-keymap))
  (suppress-keymap tm:group-buffer-map t)
  (define-key tm:group-buffer-map "q" 'tmg:quit-buffer)
  (define-key tm:group-buffer-map "k" 'tmg:kill-group)
  (define-key tm:group-buffer-map "n" 'tmg:next-item)
  (define-key tm:group-buffer-map "p" 'tmg:previous-item)
  (define-key tm:group-buffer-map " " 'tmg:select-item)
  (define-key tm:group-buffer-map "d" 'tmg:delete-item)
  (define-key tm:group-buffer-map "\C-l" 'tmg:redisplay)
  (define-key tm:group-buffer-map "?" 'tmg:help)
  (tm:group-buffer-map-specific))

(defun tm:group-has-buffer-p (group)
  "If GROUP has an associated buffer, return it; otherwise, return ()."
  (let ((buffer (tm:group-buffer group)))
    (if (and buffer (buffer-name buffer))
	buffer
      ())))

(tm:defmethod tm:group-attach-buffer-hook ((group tm:group))
  "Default method --- do nothing"
  ())

(defun tm:group-attach-buffer (group format killp)
  "Attach a buffer whose name is computed with FORMAT to GROUP, and
display GROUP in this buffer. GROUP must not already have a buffer. 
If KILLP is (), then a new buffer name is computed from FORMAT. Otherwise,
a canonical buffer name is computed from FORMAT and, if the buffer
already contains a group, this group is detached from the buffer and killed."
  (if (tm:group-has-buffer-p group)
      (error "group already has a buffer")
      (let* ((name (if killp
		       (tm:formatted-buffer-name format 0)
		     (tm:new-buffer-name format)))
	     (buffer (get-buffer-create name)))
	(save-excursion
	  (set-buffer buffer)
	  (if tml:buffer-group
	      (let ((buffer-read-only ()))
		(erase-buffer)
		(tm:set-group-buffer tml:buffer-group ())
		(tm:group-delete tml:buffer-group)))
	  (kill-all-local-variables)
	  (make-local-variable 'truncate-lines)
	  (setq truncate-lines t)
	  (make-local-variable 'tml:buffer-group)
	  (setq buffer-read-only t)
	  (setq buffer-auto-save-file-name ())
	  (buffer-flush-undo buffer)
	  (use-local-map tm:group-buffer-map)
	  (setq major-mod 'group-buffer-mode)
	  (setq mode-name "Group")
	  (make-local-variable 'tmg:item-marks)
	  (make-local-variable 'tmg:current-item-mark)
	  (setq tml:buffer-group group)
	  (if (null (tm:group-current-item group))
	      (tm:group-next-selectable-item group))
	  (tmg:group-buffer-specific)
	  (tm:group-attach-buffer-hook group)
	  (tmg:display-group)
	  (tm:set-group-buffer group buffer)
	  buffer))))

(defun tm:group-show-buffer (group &optional gotop)
  "Show GROUP's buffer if it has one. If optional GOTOP is true, also
select the buffer. Return the buffer's window, or ()."
  (let ((buffer (tm:group-has-buffer-p group)))
    (if (null buffer)
	()
      (let ((window (tm:show-buffer buffer () gotop)))
	(let ((previous-buffer (current-buffer)))
	  (set-buffer buffer)
	  (if tmg:current-item-mark
	      (set-window-point window tmg:current-item-mark)
	    (set-window-point window (point-max)))
	  (set-buffer previous-buffer))
	window))))

(defun tm:group-show-buffer-attach (group format killp &optional gotop)
  "If GROUP has a buffer, show it; otherwise, create it with name
computed with FORMAT."
  (or (tm:group-show-buffer group gotop)
      (progn
	(tm:group-attach-buffer group format killp)
	(tm:group-show-buffer group gotop))))

(defun tm:in-group-buffer-p (group)
  "Return T if we are in a group's buffer."
  (eq tml:buffer-group group))

(defun tmg:display-group ()
  "Display the current in the buffer."
  (let ((here (point))
	(buffer-read-only ())
	(group tml:buffer-group))
    (erase-buffer)
    (tm:group-print-header group)
    (setq tmg:item-marks ())
    (setq tmg:current-item-mark ())
    (let ((current-item (tm:group-current-item group))
	  (items (reverse (tm:group-items group))))
      (while items
	(newline)
	(let* ((item (car items))
	       (mark (point-marker)))
	  (setq tmg:item-marks (cons (cons item mark) tmg:item-marks))
	  (if (not (eq item current-item))
	      (insert tm:group-non-pointer)
	    (insert tm:group-pointer)
	    (setq tmg:current-item-mark mark))
	  (tm:group-print-item group item))
	(setq items (cdr items)))
      (goto-char here))))

(defun tmg:display-item-at-end (item)
  "Display a new item ITEM at the end of the buffer."
  (let ((here (point))
	(buffer-read-only ())
	(group tml:buffer-group))
    (goto-char (point-max))
    (newline)
    (let ((mark (point-marker)))
      (setq tmg:item-marks (cons (cons item mark) tmg:item-marks))
      (if (not (eq item (tm:group-current-item group)))
	  (insert tm:group-non-pointer)
	(insert tm:group-pointer)
	(setq tmg:current-item-mark mark))
      (tm:group-print-item group item)
      (goto-char here))))

(defun tmg:redisplay-item (item)
  "Redisplay ITEM."
  (let* ((here (point))
	 (buffer-read-only ())
	 (group tml:buffer-group)
	 (marks tmg:item-marks)
	 (pair ())
	 (next ()))
    (while (and marks (not (eq (car (setq pair (car marks))) item)))
      (setq marks (cdr marks))
      (setq next pair))
    (let ((start (cdr (car marks))))
      (goto-char start)
      (if (not (eq item (tm:group-current-item group)))
	  (insert tm:group-non-pointer)
	(insert tm:group-pointer))
      (tm:group-print-item group item)
      (if (null next)
	  (delete-region (point) (point-max))
	(newline)
	(delete-region (point) (cdr next))))))

(defun tmg:redisplay-header ()
  "Redisplay the header."
  (let ((buffer-read-only ())
	(group tml:buffer-group))
    (goto-char (point-min))
    (tm:group-print-header group)
    (if (null tmg:item-marks)
	(delete-region (point) (point-max))
      (newline)
      (delete-region (point)
		     (cdr (tm:last-elt tmg:item-marks))))))
		     
(defun tmg:move-pointer-to-item (item)
  "Move the current item pointer (>) to ITEM in the current group buffer."
  (let ((item-mark (cdr (assq item tmg:item-marks)))
	(buffer-read-only ()))
    (if (not (equal item-mark tmg:current-item-mark))
	(progn
	  (if tmg:current-item-mark
	      (progn
		(goto-char tmg:current-item-mark)
		(delete-char tm:group-pointer-len)
		(insert tm:group-non-pointer)))
	  (setq tmg:current-item-mark item-mark)
	  (if item-mark
	      (progn
		(goto-char item-mark)
		(delete-char tm:group-pointer-len)
		(insert tm:group-pointer)))
	  (set-buffer-modified-p ())))))

(defun tm:group-refresh-buffer (group)
  "If GROUP has a buffer, update it to follow GROUP's changes."
  (let ((buffer (tm:group-has-buffer-p group)))
    (if buffer
	(let ((modifiedp (tm:group-modifiedp group)))
	  (if modifiedp
	      (progn
		(tm:set-group-modifiedp group ())
		(save-window-excursion
		  (set-buffer buffer)
		  (cond
		   ((eq modifiedp 'moved)
		    (tmg:move-pointer-to-item (tm:group-current-item group)))
		   ((eq modifiedp 'added)
		    (tmg:display-item-at-end (tm:group-last-item group)))
		   ((eq modifiedp 'deleted)
		    (tmg:display-group))
		   ((eq modifiedp 'header)
		    (tmg:redisplay-header))
		   ((eq (car modifiedp) 'modified)
		    (tmg:redisplay-item (cdr modifiedp)))))))))))

(defun tm:kill-group-buffer (group)
  "If GROUP has a buffer, then if this buffer name is group's buffer default
bufname, erase it; otherwise, kill it. Do not delete the group."
  (let ((buffer (tm:group-buffer group)))
    (if (and buffer (buffer-name buffer))
	(let ((window (tm:get-buffer-window buffer)))
	  (if window
	      (tm:delete-window window))
	  (kill-buffer buffer)))
    (tm:set-group-buffer group ())))


;; Group buffer mode functions
;; ---------------------------
;;

(defvar tm:*group-buffer-caller* ()
  "A (dynamic) variable which can be consulted in group buffer hooks.
When a buffer related command is called because of an action made
in a group buffer, its value is BUFFER.")

(defvar tm:group-buffer-help
  "Commands for all group buffers:

n\tselect the next item
p\tselect the previous item
space\tselect the pointed item
d\tdelete the pointed item
C-l\tredisplay the buffer
q\tquit the buffer without killing it
k\tkill the buffer

Commands specific to this buffer:

"
  "Help message while in a group buffer")

(defun tmg:quit-buffer ()
  "Quit the group buffer without killing it."
  (interactive)
  (tm:delete-window (selected-window)))

(defun tmg:kill-group ()
  "Kill the group buffer."
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (tm:group-delete tml:buffer-group)))

(defun tmg:next-item ()
  "Select the next item."
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (if (and (tm:group-next-selectable-item tml:buffer-group)
	     tmg:current-item-mark)
	(goto-char tmg:current-item-mark))))

(defun tmg:previous-item ()
  "Select the previous item."
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (if (and (tm:group-previous-selectable-item tml:buffer-group)
	     tmg:current-item-mark)
	(goto-char tmg:current-item-mark))))

(defun tmg:select-item ()
  "Select the point's item as current, and return it."
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (tmg:select-point-item)))

(defun tmg:select-point-item ()
  "Select and return the point's item as current, and return it."
  (let* ((item (tmg:point-item)))
    (if item
	(progn
	  (tm:set-group-current-item tml:buffer-group item)
	  (if tmg:current-item-mark
	      (goto-char tmg:current-item-mark))
	  item))))  

(defun tmg:point-item ()
  "Return the item corresponding to the point."
  (let ((alist tmg:item-marks)
	(here (point))
	(item ()))
    (while (and alist (null item))
      (let* ((pair (car alist))
	     (mark (cdr pair)))
	(setq alist (cdr alist))
	(if (>= here mark)
	    (setq item (car pair)))))
    item))

(defun tmg:delete-item ()
  "Delete the current item."
  (interactive)
  (let ((item (tmg:point-item)))
    (if item
	(let ((tm:*group-buffer-caller* 'buffer))
	  (tm:group-remove-item tml:buffer-group item)
	  (beginning-of-line)))))

(defun tmg:redisplay ()
  "Redisplay the buffer."
  (interactive)
  (tmg:display-group)
  (if tmg:current-item-mark
      (set-window-point (selected-window) tmg:current-item-mark))
  (recenter))

(defun tmg:help ()
  "Display help for a group buffer."
  (interactive)
  (tm:in-temporary-help-buffer ()
    (tm:group-buffer-print-help tml:buffer-group)))

(tm:defmethod tm:group-buffer-print-help ((group tm:group))
  (princ tm:group-buffer-help))


(provide 'talk-groups)
