;;; outline-ext.el
;;;
;;; Copyright (C) 1999, 2004, 2007, 2008 Thien-Thi Nguyen
;;;
;;; This file is part of ttn's personal elisp library, released under
;;; the terms of the GNU General Public License as published by the
;;; Free Software Foundation; either version 3, or (at your option) any
;;; later version.  There is NO WARRANTY.  See file COPYING for details.

;;; Description: Extend outline mode.

(require 'cl)

(defvar outline-regexp-analysis)

;;;---------------------------------------------------------------------------
;;; Data tables

(defvar outline-sequence-alist
  '(;;key ini increment-function
    (int0 "0" (lambda (cur) (int-to-string (1+ (string-to-int cur)))))
    (int1 "1" (lambda (cur) (int-to-string (1+ (string-to-int cur)))))
    (lc   "a" (lambda (cur) (string (1+ (string-to-char cur)))))
    (uc   "A" (lambda (cur) (string (1+ (string-to-char cur)))))
    (lcr  "i" outline-roman-1+)
    (ucr  "I" (lambda (cur) (upcase (outline-roman-1+ (downcase cur)))))))

(defvar outline-style-alist
  '(("dotted integer"
     :sep "."
     (int1 :noindent))
    ("big little"
     (uc) (int1) (lc) (int1))
    ))

;;;---------------------------------------------------------------------------
;;; Support funcs

(defun outline-analyze-regexp (re)
  "Return info on regular expression RE."
  (let (result)
    (find-if (lambda (type)
               (when (string-match (car type) re)
                 (let* ((beg (match-beginning 0))
                        (end (match-end 0))
                        (rpt (substring re
                                        (+ beg (nth 1 type))
                                        (+ end (nth 2 type))))
                        (len (length re)))
                   (push (cons 'repeat rpt) result)
                   (unless (= 0 beg)
                     (push (cons 'prefix (substring re 0 beg)) result))
                   (when (< end len)
                     (push (cons 'suffix (substring re (- end len))) result))
                   (push (cons 'or-more
                               (if (= ?+ (aref re (+ end (nth 3 type)))) 1 0))
                         result))))
             '(("\\\\([^)]+\\\\)[*+]"   2 -3 -1)
               ("\\[[^][()]\\][*+]"     1 -2 -1)
               ("[^][()][*+]"           0 -1 -1)
               ;; Add new cases here.
               ))
    (reverse result)))

(defun outline-abstract-level ()
  (when (looking-at outline-regexp)
    (let ((repeat (cdr (assq 'repeat outline-regexp-analysis))))
      (if (not repeat)
          0
        (let* ((suffix (cdr (assq 'suffix outline-regexp-analysis)))
               (suffix-begin (if suffix
                                 (save-match-data
                                   (save-excursion
                                     (search-forward suffix)
                                     (match-beginning 0)))
                               (match-end 0)))
               (prefix (cdr (assq 'prefix outline-regexp-analysis)))
               (prefix-end (+ (point) (length prefix))))
          (+ 1 (- (cdr (assq 'or-more outline-regexp-analysis)))
             (/ (- suffix-begin prefix-end) (length repeat))))))))

(defun outline-ivec-to-string (ivec step sep)
  (mapconcat
   (lambda (idx)
     (let* ((seq (cdr (assq (caar step) outline-sequence-alist)))
            (ini (car seq))
            (inc (cadr seq)))
       (prog1
           (do ((i 0 (1+ i))
                (s ini (funcall inc s)))
               ((= idx i) s))
         (setq step (cdr step)))))
   (append ivec nil)
   sep))

(defun outline-overlay-match (newtext)
  (save-match-data
    (let* ((beg (car (match-data)))
           (end (cadr (match-data)))
           (ov  (make-overlay beg end)))
      (mapcar (lambda (ent)
                (let ((prop (car ent))
                      (val  (cdr ent)))
                  (overlay-put ov prop val)))
              '((evaporate . t)
                (intangible . t)
      ;; Work stopped here.
      )))))

;;;---------------------------------------------------------------------------
;;; Entry points

(defun outline-cast (style &optional prefix modp)
  "Cast an outline buffer into a new style."
  (interactive (list (completing-read "Style: " outline-style-alist nil t)
                     (read-string "Prefix: ")))
  (setq outline-regexp-analysis (outline-analyze-regexp outline-regexp))
  (save-excursion
    (goto-char (point-min))
    (let ((step (copy-sequence (cdr (assoc style outline-style-alist))))
          kw sep last-ivec suffix)
      (while (and (setq kw (car step))
                  (symbolp kw)
                  (string= ":" (substring (symbol-name kw) 0 1)))
        (setq step (cdr step))
        (case kw
          (:sep
           (setq sep (car step)
                 step (cdr step)))
          (t
           (error "Unrecognized keyword: %s" kw))))
      (setcdr (last step) step)
      (setq last-ivec (list -1))
      (setq prefix (concat (or (cdr (assq 'prefix outline-regexp-analysis))
                               "")
                           prefix))
      (setq suffix (or (cdr (assq 'suffix outline-regexp-analysis))
                       ""))
      (setq sep (or sep ""))
      (while (re-search-forward (concat "^" outline-regexp) (point-max) t)
        (beginning-of-line)
        (let ((last-level (length last-ivec))
              (cur-level (outline-abstract-level)))
          (funcall
           (if modp 'outline-overlay-match 'replace-match)
           (concat
            prefix
            (outline-ivec-to-string
             (reverse
              (setq last-ivec
                    (cond
                     ((= cur-level last-level)
                      (cons
                       (1+
                        (car last-ivec))
                       (cdr last-ivec)))
                     ((< cur-level last-level)
                      (setq last-ivec
                            (last last-ivec cur-level))
                      (cons
                       (1+
                        (car last-ivec))
                       (cdr last-ivec)))
                     ((> cur-level last-level)
                      (cons 0 last-ivec))
                     (t
                      (error "WTF! cur-level=%d last-level=%d"
                             cur-level last-level)))))
             step sep)
            suffix))))
      (setcdr step nil))))              ; be nice to emacs

; testing

;*[1]
;**[1.1]
;**[1.2]
;*[2]
;**[2.1]
;**[2.2]
;***[2.2.1]
;***[2.2.2]
;***[2.2.3]
;**[2.3]

;;;---------------------------------------------------------------------------
;;; Load-time actions

(make-variable-buffer-local 'outline-regexp-analysis)
(put 'outline-regexp-analysis 'permanent-local t)

;;;---------------------------------------------------------------------------
;;; That's it!

(provide 'outline-ext)

;;; outline-ext.el ends here