;;;;circul.el
;; Circulation over Buffers 

;;;;;;;;;;;;;;;;;;;;;;
;; example of set-key:
;(global-set-key [(control kp-enter)]  'circul-bury-buffer)
;(global-set-key [(control kp-add)]  'circul-unbury-buffer)

;; keypad numbers from 1 to 6 assigned to do the following:
; C-n assign n to the current buffer
; n unbury buffer n

;(global-set-key [(control kp-end)] ;C-1
;  '(lambda () (interactive) (circul-assign-current-buffer 1)))
;(global-set-key [(kp-end)] ;1
;  '(lambda () (interactive) (circul-unbury-buffer-n 1)))

;(global-set-key [(control kp-down)] 
;  '(lambda () (interactive) (circul-assign-current-buffer 2)))
;(global-set-key [(kp-down)]
;  '(lambda () (interactive) (circul-unbury-buffer-n 2)))

;(global-set-key [(control kp-next)] 
;  '(lambda () (interactive) (circul-assign-current-buffer 3)))
;(global-set-key [(kp-next)]
;  '(lambda () (interactive) (circul-unbury-buffer-n 3)))

;(global-set-key [(control kp-left)] 
;  '(lambda () (interactive) (circul-assign-current-buffer 4)))
;(global-set-key [(kp-left)]
;  '(lambda () (interactive) (circul-unbury-buffer-n 4)))

;(global-set-key [(control kp-begin)] 
;  '(lambda () (interactive) (circul-assign-current-buffer 5)))
;(global-set-key [(kp-begin)]
;  '(lambda () (interactive) (circul-unbury-buffer-n 5)))

;(global-set-key [(control kp-right)] 
;  '(lambda () (interactive) (circul-assign-current-buffer 6)))
;(global-set-key [(kp-right)] 
;  '(lambda () (interactive) (circul-unbury-buffer-n 6)))
;;;;;;;;;;;;;;;;;;;;;;;;

(defcustom circul-uninteresting-buffer-regexp
  "\\`\\*\\|\\` \\|.+\\.log\\'"
  "Regexp of unintersting buffer names")
(defcustom circul-uninteresting-buffer-exception-regexp 
  ""
  "Regexp of exceptions for circul-uninteresting-buffer-regexp")
(defcustom circul-buffer-list nil 
  "list of assigned buffers")

(eval-and-compile
  (cond
   ((fboundp 'update-tab-in-gutter)    
    (defsubst circul-update-gutter ()
      "see `update-tab-in-gutter'"
      (update-tab-in-gutter (window-frame))))
   (t (defsubst circul-update-gutter () 
	"does nothing (xemacs compatibility)" 
	())
      )))


;;
(defun add-to-alist (al elt)
  "add elt to the alist al"
  (let ((e (assoc (car elt) al)))
    (if e (rplacd e (cdr elt))
      (set al (cons elt al)))))

(defun remove-of-alist (al elt)
  "remove elt of the alist al"
  (let ((e (assoc (car elt) al)))
    (if e (rplacd e (cdr elt))
      (set al (cons elt al)))))



(defun is-uninteresting-buffer (buf)
  "(is-interesting-buffer buf) rend t si la chaine buf est un nom de buffer interessant, nil sinon."
  (let* ((first-char (substring buf 0 1)))
    (and
     (string-match circul-uninteresting-buffer-regexp buf)
     (not 
      (string-match circul-uninteresting-buffer-exception-regexp buf)))
    )
  )


;tire de mouse.el (mouse-unbury-buffer) et modifie par moi
(defun unbury-buffer ()
  "from mouse.el : Unbury and select the most recently buried buffer."
  (interactive)
  (let* ((bufs (buffer-list))
	 (entry (1- (length bufs)))
	 val)
    (while (not (setq val (nth entry bufs)
		      val (and (/= (aref (buffer-name val) 0)
				   ? )
			       val)))
      (setq entry (1- entry)))
    (switch-to-buffer val))
  )




(defun find-first-interesting (list-buf)
  "rend le nom du premier buffer interessant de la liste list-buf, nil s'il n'y en a pas"
  (let* ((l list-buf))
    (while (and 
	    (not (eq l nil))
	    (is-uninteresting-buffer (buffer-name (car l))))
      (setq l (cdr l)))
    (if (eq l nil) nil (buffer-name (car l)))
    )
  )


(defun find-last-interesting (list-buf)
  "rend le nom du dernier buffer interessant de la liste list-buf, nil s'il n'y en a pas"
  (let* ((l list-buf)
	 (cpt nil))
    (while (not (eq l nil))
      (if (is-uninteresting-buffer (buffer-name (car l)))
	  ()
	(setq cpt (buffer-name (car l))))
      (setq l (cdr l))
      )
    cpt
    )
  )


(defun circul-bury-buffer ()
  "enterre le buffer courant et passe 
     - au premier buffer interessant dans la liste s'il existe
     - au premier buffer de la liste sinon"
  (interactive)
  (bury-buffer)
  (let* ((intbuf (find-first-interesting (buffer-list))))
    (if (eq intbuf nil) () (switch-to-buffer intbuf))
    )
  )

(defun circul-unbury-buffer ()
  "Déterre le dernier buffer interessant s'il existe, sinon deterre le dernier"
  (interactive)
  (let* ((intbuf (find-last-interesting (buffer-list))))
    (if (eq intbuf nil) (unbury-buffer) (switch-to-buffer intbuf))
    )
  )


;;;; list d'association, ca existe surement qqpart
;;;; marche apparemment aussi bien pour des liste de liste
;;;; que des alist

(defun find-assoc (cle l)
  "trouve l'element corresponant à cle dans la table d'assoc l (liste de liste à deux args)"
  (let* ((tab l))
    (while (and (not (eq tab nil))
		(not (= (car (car tab)) cle)))
      (setq tab (cdr tab))
      )
    (if (eq tab nil) nil
      (cadr (car tab)))
    )
  )

(defun find-elt-in-assoc (elt l)
  "(find-elt-in-assoc elt l) suppresses all occurence of (_ elt) in l"
  (let* ((tab l)
	 (num nil))
    (while (not (eq tab nil))
      (if (string-equal (cadr (car tab)) elt)
	  (setq num (car (car tab)))
	)
      (setq tab (cdr tab))
      )
    num
    )
  )




(defun supp-cle-in-assoc (cle l)
  "(supp-cle-in-assoc cle l) suppresses all occurence of (cle _) in l"
  (let* ((tab l)
	 (newtab nil))
    (while (not (eq tab nil))
      (if (not (eq (car (car tab)) cle))
	  (setq newtab (cons (car tab) newtab))
	)
      (setq tab (cdr tab))
      )
    newtab
    )
  )

(defun supp-elt-in-assoc (elt l)
  "(supp-elt-in-assoc elt l) suppresses all occurence of (_ elt) in l"
  (let* ((tab l)
	 (newtab nil))
    (while (not (eq tab nil))
      (if (not (string-equal (cadr (car tab)) elt))
	  (setq newtab (cons (car tab) newtab))
	)
      (setq tab (cdr tab))
      )
    newtab
    )
  )

(defun add-assoc (el l)
  "add el= (x y) in the list l, deletes first all occurences of (x _)"
  (let* ((laux (supp-cle-in-assoc (car el) l)))
    (cons el laux))
  )



;;; assigner des numeros a des buffers.

(defun circul-assign-current-buffer (n)
  "assign number n to the current buffer in circul-buffer-list"
  (interactive)
  (setq circul-buffer-list 
	(add-assoc 
	 (cons n  
	       (cons (buffer-name (car (buffer-list))) nil)) 
	 circul-buffer-list)
	)
  )

(defun circul-unbury-buffer-n (n)
  "Unbury buffer char n found in circul-buffer-list"
  (interactive)
  (let* ((buf (find-assoc n circul-buffer-list)))
    (if (eq buf nil) 
	(error "No buffer assign to this")
      (switch-to-buffer buf)))
  )

(add-hook 'kill-buffer-hook 
	  (lambda () 
	    (setq circul-buffer-list 
		  (supp-elt-in-assoc (buffer-name (current-buffer))
				     circul-buffer-list))
	    )
	  )


(defun circul-set-current-buf (n)
  "assign char n to the current buffer in circul-buffer-list,
and suppress the register called n if it exists"
  (interactive)
  (setq register-alist
	(supp-cle-in-assoc n register-alist))
  (circul-assign-current-buffer n)
  (circul-update-gutter)
  )

(defun circul-set-current-reg (n)
  "assign char n to the current buffer in circul-buffer-list,
and suppress the register called n if it exists"
  (interactive)
  (setq circul-buffer-list 
	(supp-cle-in-assoc n circul-buffer-list))
  (point-to-register n)
  )

(defun circul-jump-to-register-or-buffer (n)
  "jump to the register or the buffer named n"
  (interactive)
  (if (find-assoc n circul-buffer-list)
      (circul-unbury-buffer-n n)
    (jump-to-register n))
  )


(defun circul-select-tab-buffers (bsel currbuf)
  (not (is-uninteresting-buffer (buffer-name bsel)))
)

(defun circul-format-buffers-tab (bf)
  (let* 
      ((bname (buffer-name bf))
       (num (find-elt-in-assoc bname circul-buffer-list))
       res)
    (if (not num) (setq res bname) 
      (setq res (concat bname "("  (char-to-string num) ")" )))
    res
    )
)



(setq buffers-tab-filter-functions '(circul-select-tab-buffers))
(setq buffers-tab-max-buffer-line-length 15)
(setq buffers-tab-max-size 15)
(setq buffers-tab-format-buffer-line-function 'circul-format-buffers-tab)

(provide 'circul)