;;; buffer-thumbnail.el
;;;
;;; Rel:standalone-buffer-thumbnail-el-3
;;;
;;; Copyright (C) 2005, 2006 Thien-Thi Nguyen
;;; This file is part of ttn's personal elisp library, released under GNU
;;; GPL with ABSOLUTELY NO WARRANTY.  See the file COPYING for details.
;;;
;;; Description: Maintain an XPM interpretation of buffer contents.

(require 'xpm-fulmination)
(require 'cl)

(defvar buffer-thumbnail nil
  "XPM data for a buffer, set by `buffer-thumbnail-update'.")

(defvar buffer-thumbnail-modified-tick nil
  "A number set at the time `buffer-thumbnail' is updated.
This is the value of calling `buffer-modified-tick'.")

(defvar buffer-thumbnail-method-name 'text-roughly-square
  "*Symbol naming the method used to generate a buffer thumbnail.")

(defvar buffer-thumbnail-methods (make-hash-table :size 11)
  "Hash table of methods for `buffer-thumbnail-update'.")

(defmacro define-buffer-thumbnail-method (spec &rest body)
  `(puthash ',(car spec)
            '(,(cdr spec)                               ;;; 0: properties
              ,(when (stringp (car body))               ;;; 1: docstring
                 (car body))
              (lambda (beg end) ,@body))                ;;; 2: compute
            buffer-thumbnail-methods))

;;;###autoload
(defun buffer-thumbnail-list-methods ()
  "List methods available for `buffer-thumbnail-method-name' in a buffer."
  (interactive)
  (switch-to-buffer (get-buffer-create "*Buffer Thumbnail Methods*"))
  (erase-buffer)
  (let ((default (default-value 'buffer-thumbnail-method-name))
        (dist (make-hash-table :size 11))
        props docstring)
    (mapc (lambda (buf)
            (with-current-buffer buf
              (incf (gethash buffer-thumbnail-method-name dist 0))))
          (buffer-list))
    (maphash (lambda (name method)
               (insert (format "%s (%s%d buffers)\n"
                               (propertize (format "%s" name) 'face
                                           'font-lock-function-name-face)
                               (if (eq default name) "default, " "")
                               (gethash name dist 0)))
               (setq props (nth 0 method)
                     docstring (nth 1 method))
               (while props
                 (insert (format "  %-20s %s\n" (car props) (cadr props)))
                 (setq props (cddr props)))
               (when docstring
                 (insert (propertize docstring
                                     'face 'font-lock-doc-face)
                         "\n"))
               (insert "\n"))
             buffer-thumbnail-methods)))

;;;###autoload
(defun buffer-thumbnail-update (&optional beg end)
  "Make variable `buffer-thumbnail' buffer-local and update it."
  (interactive)
  (unless (and beg end)
    (setq beg (if mark-active (min (point) (mark)) (point-min))
          end (if mark-active (max (point) (mark)) (point-max))))
  (let* ((method (gethash buffer-thumbnail-method-name
                          buffer-thumbnail-methods))
         (properties (nth 0 method))
         (docstring (nth 1 method))     ; presently unused
         (compute (nth 2 method))
         computed-result ff)            ; poor man's promise
    (set (make-local-variable 'buffer-thumbnail)
         (flet ((result () (setq computed-result
                                 (or computed-result
                                     (funcall compute beg end)))))
           (cond ((and buffer-thumbnail
                       buffer-thumbnail-modified-tick
                       (<= (buffer-modified-tick)
                           buffer-thumbnail-modified-tick))
                  buffer-thumbnail)
                 ((and (listp (result)) (eq 'image (car (result))))
                  (result))
                 ((setq ff (memq :forcing-function properties))
                  (funcall (cadr ff) (result)))
                 (t
                  (error "No image and no %s for buffer thumbnail method `%s'"
                         :forcing-function
                         buffer-thumbnail-method-name)))))
    (set (make-local-variable 'buffer-thumbnail-modified-tick)
         (buffer-modified-tick))))

;;;###autoload
(defun buffer-thumbnail-browse (&optional beg end)
  (interactive)
  (unless (and beg end)
    (setq beg (if mark-active (min (point) (mark)) (point-min))
          end (if mark-active (max (point) (mark)) (point-max))))
  (let ((start (current-time))
        xpm diff)
    (buffer-thumbnail-update beg end)
    (setq xpm buffer-thumbnail)
    (switch-to-buffer
     (generate-new-buffer
      (concat "*buffer thumbnail* " (buffer-name))))
    (set (make-local-variable 'buffer-thumbnail) xpm)
    (setq major-mode 'buffer-thumbnail-browse
          mode-name "Buffer Thumbnail Browse")
    (use-local-map (let ((m (make-sparse-keymap)))
                     (define-key
                       m "w" (lambda (filename)
                               (interactive "FWrite XPM to file: ")
                               (let ((data (plist-get (cdr buffer-thumbnail)
                                                      :data)))
                                 (with-temp-buffer
                                   (insert data)
                                   (write-file filename)))))
                     m))
    (erase-buffer)
    (insert-image xpm)
    (forward-char -1)
    (unless (member (setq diff (time-since start)) '((0 0) (0 1)))
      (message (format-time-string "%s seconds" diff)))))


;;; built-in thumbnail methods

(defun buffer-thumbnail-collect-face-colors (beg end)
  (flet ((vs (s) (apply 'concat "#" (mapcar (lambda (n)
                                              (format "%04X" n))
                                            (color-values s))))
         (fg (try) (let (ans c)
                     (catch t
                       (dolist (face (if (consp try) try (list try)))
                         (setq c (face-attribute face :foreground nil t))
                         (unless (eq 'unspecified c)
                           (setq ans c)
                           (throw t t))))
                     ;; if last was unspecified, use the default
                     (if (and (not ans) (eq 'unspecified c))
                         (fg 'default)
                       ans))))
    (let ((avail "1234567890!@$%^&*ABCDEFGHIJKLMNOPQRSTUVWXYZ")
          (acc (list (list t ?# (vs (fg 'default)))
                     (list nil 32 (vs (face-background 'default)))))
          (seen '(default))
          (p beg)
          try face face-fg)
      (while (< (setq p (next-char-property-change p end)) end)
        (when (and (setq try (get-text-property p 'face))
                   (setq face (if (consp try) (car try) try))
                   (not (memq face seen))
                   (setq face-fg (fg try))) ; ugh
          (push (list face (aref avail 0) (vs face-fg)) acc)
          (push face seen)
          (setq avail (substring avail 1))))
      (nreverse acc))))

(define-buffer-thumbnail-method
  (text-roughly-square :xpm-size :data-dependent
                       :forcing-function xpmfulm-as-xpm)
  "Text in the region is mapped from charcter to pixel, preserving
colors of the `face' text property when possible.  The resulting block
is divided into columns to roughly approximate a square.  For short
regions, this may actually give an XPM wider than it is tall."
  (let* ((width (save-excursion
                  (let ((w (progn (goto-char beg)
                                  (end-of-line)
                                  (- (point) beg)))
                        p)
                    (while (< (point) end)
                      (beginning-of-line 2)
                      (setq p (point)
                            w (progn (end-of-line)
                                     (max w (- (point) p)))))
                    w)))
         (height (1+ (count-lines beg end)))
         (up (ceiling (/ (sqrt (+ width (* height width))) width)))
         (fw (* up width))
         (fh (ceiling (/ (* 1.0 height) up)))
         (curbuf (current-buffer))
         (face-color-map (buffer-thumbnail-collect-face-colors beg end))
         (colors (mapcar (lambda (x)
                           (cons (nth 1 x) (nth 2 x)))
                         face-color-map))
         (fulmbuf (xpmfulm-buffer "bufferthumb" fw fh colors))
         (row 0) (col 0)
         p q s m n face)
    (buffer-disable-undo fulmbuf)
    (save-excursion
      (goto-char beg)
      (while (< (point) end)
        (setq p (point)
              q (progn (end-of-line) (point))
              s (buffer-substring-no-properties p q)
              m p
              n 0)
        (while (< m q)
          (aset s n (nth 1 (assq (cond ((= 32 (aref s n)) nil) ; space
                                       ((setq face (get-text-property m 'face))
                                        (if (consp face) (car face) face))
                                       (t t))
                                 face-color-map)))
          (setq m (1+ m)
                n (1+ n)))
        (with-current-buffer fulmbuf
          ;; abstraction violation!
          (goto-char (+ 1 (* row (1+ fw)) col))
          (insert s)
          (delete-char (- q p)))
        (forward-line 1)
        (incf row)
        (when (= 0 (mod row fh))
          (setq row 0 col (+ width col)))))
    fulmbuf))

(define-buffer-thumbnail-method
  (text-roughly-square-magenta :xpm-size :data-dependent
                               :forcing-function xpmfulm-as-xpm)
  "The region's text is folded into two colors: black for spaces,
and magenta for everything else (newlines ignored).  The resulting
block is divided into columns to roughly approximate a square.  For
short regions, this may actually give an XPM wider than it is tall."
  (let* ((width (save-excursion
                  (let ((w (progn (goto-char beg)
                                  (end-of-line)
                                  (- (point) beg)))
                        p)
                    (while (< (point) end)
                      (beginning-of-line 2)
                      (setq p (point)
                            w (progn (end-of-line)
                                     (max w (- (point) p)))))
                    w)))
         (height (1+ (count-lines beg end)))
         (up (ceiling (/ (sqrt (+ width (* height width))) width)))
         (fw (* up width))
         (fh (ceiling (/ (* 1.0 height) up)))
         (curbuf (current-buffer))
         (fulmbuf (xpmfulm-buffer "bufferthumb" fw fh
                                  '((32 . "#000000000000")
                                    (?# . "#FFFF0000FFFF"))))
         (row 0) (col 0)
         p q)
    (buffer-disable-undo fulmbuf)
    ;; In the following, the "abstraction violation!" warnings are actually a
    ;; call to improve the abstraction.  At least, that's what the enfeebled
    ;; drunk programmer mumbled to me.  "But why don't you fix that in the
    ;; source straight away?", I asked sincerely.  He laughed and said, "Your
    ;; two minds are ready to filter the polarization, fool!  When you get
    ;; your ninety degrees properly settled, then we'll talk!"  I hesitated,
    ;; wary of vomit and invective, but there was no other sound in the dark.
    (save-excursion
      (goto-char beg)
      (while (< (point) end)
        (setq p (point)
              q (progn (end-of-line) (point)))
        (with-current-buffer fulmbuf
          ;; abstraction violation!
          (goto-char (+ 1 (* row (1+ fw)) col))
          (insert-buffer-substring-no-properties curbuf p q)
          (delete-char (- q p)))
        (forward-line 1)
        (incf row)
        (when (= 0 (mod row fh))
          (setq row 0 col (+ width col)))))
    (with-current-buffer fulmbuf
      ;; more abstraction violation!
      (let ((v (apply 'vector (mapcar (lambda (n)
                                        (make-string n ?#))
                                      (number-sequence 0 width))))
            (cookie-loc (- (point-max) 3)))
        (goto-char (point-min))
        (while (re-search-forward "[^ \n]+" (- (point-max) 3) t)
          (replace-match (aref v (- (match-end 0) (match-beginning 0))) t t))))
    fulmbuf))

;;; Local Variables:
;;; eval: (font-lock-add-keywords nil '("define-buffer-thumbnail-method"))
;;; End:

;;; ttn-sez: worth-compiling
;;; buffer-thumbnail.el ends here