;; -*- mode: emacs-lisp -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This program is free software; you can redistribute it and/or         ;;
;; modify it 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.                                       ;;
;;                                                                       ;;
;; This program is distributed in the hope that it will be useful, but   ;;
;; WITHOUT ANY WARRANTY; without even the implied warranty of            ;;
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU      ;;
;; General Public License for more details.                              ;;
;;                                                                       ;;
;; You should have received a copy of the GNU General Public License     ;;
;; along with this program. If not, see <http://www.gnu.org/licenses/>.  ;;
;;                                                                       ;;
;; Written by and Copyright (C) Francois Fleuret                         ;;
;; Contact <francois@fleuret.org> for comments & bug reports             ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The selector/select function provides a simple interface for
;; selecting an object with on-the-fly pattern matching in a standard
;; buffer (i.e. not in the minibuffer). You can either use it in your
;; own functions or directly use selector/quick-pick-recent or
;; selector/quick-move-in-buffer.
;;
;; For instance, you can add in your .emacs.el
;;
;; (require 'recentf)
;; (recentf-mode 1)
;;
;; (when (load "selector" t t)
;;   (define-key global-map [(control x) (control r)] 'selector/quick-pick-recent)
;;   (define-key global-map [(control c) (control s)] 'selector/quick-move-in-buffer)
;;   (define-key global-map [(control x) (control b)] 'selector/switch-buffer)
;; )

(defgroup selector ()
  "Major mode for selection of entries with dynamic pattern matching"
  :version "1.2.3")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User-configurable variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcustom selector/memorize-entry-only-on-motions t
  "If non-nil, only the cursor motions memorize the current selection.
Restriction of the selection does not. This means that if you
change the pattern and then edit it to cancel the change, the
cursor will come back to its original location, unless you have
explicitely moved it with the arrow keys at some point."
  :type 'bool
  :group 'selector)

(defcustom selector/info-in-mode-line nil
  "If nil, the pattern is shown in the menu header.
Otherwise use the mode-line."
  :type 'bool
  :group 'selector)

(defcustom selector/always-create-buffer nil
  "If nil, re-use existing similar buffer when possible."
  :type 'bool
  :group 'selector)

(defcustom selector/add-to-file-name-history t
  "If non-nil, file selected with selector/quick-pick-recent will be added to the mini-buffer filename history."
  :type 'bool
  :group 'selector)

(defcustom selector/mode-hook nil
  "Hook called at the end of the selector mode initialization."
  :type 'hook
  :group 'selector)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defface selector/selection
  ;; '((t (:bold t)))
  '((t (:background "chartreuse")))
  "The face for the current selection.")

(defface selector/dim
  '((t (:foreground "gray70")))
  "The face for dimmed entries.")

(defface selector/date
  '((t (:foreground "dark violet")))
  "The face for the dates in selector/quick-pick-recent.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar selector/pattern
  ""
  "The pattern to match to appear in the selector buffer.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/string-match-all (regexps string)
  "Return if STRING matches all regular expressions in REGEXPS."
  (if regexps
      (and (string-match (car regexps) string)
           (selector/string-match-all (cdr regexps) string))
    t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/move-highlight-overlay ()
  "Move the highlight overlay to highlight the current line."
  (if (get-text-property (point) 'entry)
      (move-overlay selector/highlight-overlay
                    (or (previous-single-property-change (1+ (point)) 'entry)
                        (point-min))
                    (or (next-single-property-change (point) 'entry)
                        (point-max)))
    ;; (move-overlay selector/highlight-overlay 0 0)
    (delete-overlay selector/highlight-overlay)
    )

  (unless (and selector/memorize-entry-only-on-motions
               (memq this-command
                     '(selector/delete-backward-char
                       selector/self-insert-command)))
    (setq selector/current-entry (get-text-property (point) 'entry)))
  )

(defun selector/refresh ()
  "Erase and reconstruct the content of the current buffer
according to `selector/entries' and `selector/pattern'."

  (let ((inhibit-read-only t)
        (pos (point))
        (line-beginning (line-beginning-position))
        (regexps (mapcar 'regexp-quote (split-string selector/pattern ";")))
        (newpos (point))
        (nb-shown-entries 0))

    (erase-buffer)

    (mapc (lambda (s)
            (when (selector/string-match-all regexps (car s))
              (setq nb-shown-entries (1+ nb-shown-entries))
              (if (eq (cdr s) selector/current-entry)
                  (setq newpos (+ (- pos line-beginning) (point))))
              (insert
               (propertize (concat (car s) "\n")
                           'entry (cdr s)
                           ;; 'face 'compilation-error
                           ))))
          selector/entries)

    (setq newpos (min newpos (point-max)))
    (setq selector/nb-shown-entries (number-to-string nb-shown-entries))

    (goto-char (or (and (get-text-property newpos 'entry) newpos)
                   (previous-single-property-change newpos 'entry)
                   (point-max)))

    (beginning-of-line)
    (force-mode-line-update)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/self-insert-command ()
  "Insert the last pressed key at the end of `selector/pattern'."
  (interactive)
  (setq selector/pattern (concat selector/pattern
                                 (this-command-keys)))
  (selector/refresh)
  )

(defun selector/delete-backward-char ()
  "Remove the last character of `selector/pattern'."
  (interactive)
  (when (> (length selector/pattern) 0)
    (setq selector/pattern (substring selector/pattern 0 -1)))
  (selector/refresh)
  )

(defun selector/kill-line ()
  "Move the content of `selector/pattern' to the kill ring."
  (interactive)
  (kill-new selector/pattern t)
  (setq selector/pattern "")
  (selector/refresh))

(defun selector/yank (&optional arg)
  "Append the content of the kill ring to `selector/pattern'."
  (interactive "P")
  (setq selector/pattern (concat selector/pattern
                                 (current-kill (cond
                                                ((listp arg) 0)
                                                ((eq arg '-) -2)
                                                (t (1- arg))))))
  (selector/refresh))

(defun selector/return ()
  "Call the function specified by `selector/callback' with the
entry at point as parameter."
  (interactive)
  (let ((result (get-text-property (point) 'entry))
        (callback selector/callback))
    (kill-this-buffer)
    (if result (funcall callback result)
      (error "No selection"))))

(defun selector/goto-next-entry ()
  "Move point to the next entry."
  (interactive)
  (let ((n (or (next-single-property-change (point) 'entry)
               (point-min))))
    (if n (goto-char n))))

(defun selector/goto-previous-entry ()
  "Move point to the previous entry."
  (interactive)
  (let ((n (or (previous-single-property-change (point) 'entry)
               (previous-single-property-change (point-max) 'entry))))
    (if n (goto-char n))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/mode ()
  "Mode for selection of strings. See `selector/select' for a
detailed explanation."

  (unless (boundp 'selector/map)
    (setq selector/map (make-sparse-keymap))

    (mapc (lambda (p)
            (substitute-key-definition (car p)
                                       (cdr p)
                                       selector/map global-map)
            )

          ;; What are the functions to substitute by what
          '((self-insert-command . selector/self-insert-command)
            (delete-backward-char . selector/delete-backward-char)
            (kill-line . selector/kill-line)
            (yank . selector/yank)
            (newline . selector/return)
            ;; (keyboard-quit . kill-this-buffer)
            ))

    (define-key selector/map "\C-g"
      'kill-this-buffer)

    (define-key selector/map (kbd "TAB")
      'selector/goto-next-entry)

    (define-key selector/map [(shift iso-lefttab)]
      'selector/goto-previous-entry)

    )

  (setq major-mode 'selector/mode
        mode-name "Selector"
        buffer-read-only t
        )

  (set
   (if selector/info-in-mode-line 'mode-line-format 'header-line-format)
   '(" " selector/nb-shown-entries "/"
     selector/nb-total-entries " pattern: " selector/pattern)
   )

  (buffer-disable-undo)
  (use-local-map selector/map)
  (run-hooks 'selector/mode-hook)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/select (entries callback &optional name)
  "Open a new buffer showing dynamically a subset of entries
matching a pattern that can be changed by pressing the usual
\"insertable\" symbols or backspace. Pressing the enter key
validates the selection.

Note that the pattern is not a regexp but a series of substrings
separated by `;'s that have all to be present.

The key mapping is hacked so that the keys associated to
`self-insert-command', `delete-backward-char', `kill-line',
`yank' and `newline' are associated to functions which do somehow
what they are supposed to do. The latter validating the
selection.

ENTRIES is a list of cons cells, each composed of a string to
display and an object to pass as the unique parameter to CALLBACK
when the user actually does a selection. The optional NAME
parameter specifies the name to give to the buffer.

Setting `selector/memorize-entry-only-on-motions' to non-nil
means that the entry to keep the cursor on when changing the
selection is set only on cursor motions. To show the pattern in
the modeline set `selector/info-in-mode-line'. The header line is
used by default. To always open a new buffer and not re-use an
existing buffer with the same name, set
`selector/always-create-buffer' to non-nil.

There seems to be header-line refreshing problems with emacs21."

  (switch-to-buffer
   (get-buffer-create
    (funcall
     (if selector/always-create-buffer 'generate-new-buffer-name 'identity)
     (or name "*selector*"))))

  (set (make-local-variable 'selector/entries) entries)
  (set (make-local-variable 'selector/callback) callback)
  (set (make-local-variable 'selector/pattern) "")
  (set (make-local-variable 'selector/highlight-overlay) (make-overlay 0 0))
  (set (make-local-variable 'selector/current-entry) nil)
  (set (make-local-variable 'selector/nb-total-entries)
       (number-to-string (length entries)))
  (set (make-local-variable 'selector/nb-shown-entries) "?")

  (overlay-put selector/highlight-overlay 'face 'selector/selection)

  (add-hook 'post-command-hook 'selector/move-highlight-overlay nil t)
  (selector/mode)
  (selector/refresh)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To open recent files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/filename-to-string (filename)
  "Generate the line associated to a filename for `selector/quick-pick-recent'"
  (concat
   " "
   (if (file-remote-p s)
       "          "
     (propertize
      (format-time-string   "%b %a %e" (elt (file-attributes s) 5))
      'face 'selector/date))

   ;; " -- "

   " "

   (if (string-match abbreviated-home-dir s)
       (concat (propertize
                (substring s 0 (match-end 0)) 'face 'selector/dim)
               (substring s (match-end 0)))
     s)

   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; (if (and (boundp 'selector/previous-filename) selector/previous-filename)
   ;;     (let ((l (abs (compare-strings
   ;;                    selector/previous-filename nil nil
   ;;                    filename nil nil))))
   ;;       ;; (if (> l 0) (setq l 
   ;;       (setq selector/previous-filename filename)
   ;;       (concat (propertize
   ;;                (substring s 0 l) 'face 'selector/dim)
   ;;               (substring s l))
   ;;       )
   ;;   filename
   ;;   )
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   )
  )

(defun selector/find-file (filename)
  (if selector/add-to-file-name-history
      (add-to-history 'file-name-history
                      (replace-regexp-in-string
                       abbreviated-home-dir "~/" filename)
                      )
    )

  (find-file filename))

(defun selector/pick-file (filename)
  "Callback function for `selector/quick-pick-recent'. When
called with a universal argument, allows the user to edit the
filename."
  (interactive)
  (if current-prefix-arg
      (selector/find-file (read-file-name
                           "Find file: "
                           (file-name-directory filename)
                           nil
                           nil
                           (file-name-nondirectory filename)))
    (selector/find-file filename)))

(defun selector/quick-pick-recent ()
  "Open a file picked in `recentf-list' with the dynamic
pattern-matching search implemented in `selector/select'. With a
prefix argument, allows to edit the filename after selection."
  (interactive)

  (unless (and (boundp recentf-mode) recentf-mode)
    (error "recentf mode must be turned on"))

  ;; (setq selector/previous-filename "")

  (selector/select

   (mapcar
    (lambda (s)
      (cons (selector/filename-to-string s) s))
    recentf-list)

   'selector/pick-file
   "*selector find-file*"
   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To search in the current buffer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/quick-move-in-buffer ()
  "Move the cursor in the current buffer to a line selected
dynamically with `selector/select'."
  (interactive)
  (selector/select
   (reverse
    (let ((l nil))
      (save-excursion
        (goto-char (point-min))
        (while (< (point) (point-max))
          (setq l (cons (cons (buffer-substring (point-at-bol) (point-at-eol))
                              (point-at-bol)) l))
          (forward-line 1))
        l))
    )
   'goto-char
   "*selector buffer move*"
   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To switch between buffers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/switch-buffer () (interactive)
  "Select the current buffer dynamically with `selector/select'."
  (interactive)
  (selector/select
   (let ((l nil))
     (mapc
      (lambda (buffer)
        (with-current-buffer buffer
          (let ((name (buffer-name))
                (size (buffer-size))
                (file (buffer-file-name))
                (modified (buffer-modified-p)))
            (when (not (string-match "^ +" name))
              (push
               (cons
                (replace-regexp-in-string
                 " +$"
                 ""
                 (format
                  "% 8d %s %-30s%s"
                  size
                  (if modified "*" "-")
                  name
                  (if file (concat
                            (replace-regexp-in-string abbreviated-home-dir
                                                      "~/" file)
                            ) "")
                  ))
                buffer)
               l)
              ))))
      (reverse (buffer-list)))
     l)
   'switch-to-buffer
   "*selector switch-buffer*"
   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To search among sentences (i.e. between periods, not between \n)
;; This is work in progress, it currently looks kind of ugly but is
;; already useful to navigate in a long article
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/search-sentence ()
  "Move the cursor to a sentence chosen dynamically with
`selector/select'."
  (interactive)
  (selector/select
   (let ((sentences nil))
     (save-excursion
       (goto-char (point-min))
       (while (re-search-forward "[^.]+\\." nil t)
         (let ((s (replace-regexp-in-string "^[ \n]+" ""
                                            (match-string-no-properties 0)))
               (p (match-beginning 0)))
           (setq s (replace-regexp-in-string "[ \n]+$" "" s))
           (when (> (length s) 1)
             (push (cons
                    (with-temp-buffer
                      (insert s "\n")
                      (fill-region (point-min) (point-max))
                      (buffer-string))
                    p) sentences)))))
     (reverse sentences))
   'goto-char))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defface selector/dir
  '((t (:foreground "red")))
  "The face for directories.")

(defface selector/symlink
  '((t (:foreground "blue")))
  "The face for symlinks.")

(defun selector/rec-find-file (&optional filename) (interactive)
  (setq filename (or filename
                     (and (buffer-file-name) (file-name-directory (buffer-file-name)))
                     default-directory))

  (if (file-regular-p filename) (find-file filename)
    (selector/select
     (mapcar
      (lambda (file)
        (let ((f (car file)))
          (cons
           (if (file-regular-p f)
               f
             (if (file-symlink-p f)
                 (propertize f 'face 'selector/symlink)
               (propertize f 'face 'selector/dir)))
           (concat filename "/" f))))
      (directory-files-and-attributes filename))
     'selector/rec-find-file
     (concat "selector " filename)
     )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;