From: ueno <ueno>
Date: Sat, 27 Apr 2002 13:09:01 +0000 (+0000)
Subject: * LSDB-ELS (lsdb-modules-to-compile): Add xbm-thumb.
X-Git-Tag: lsdb-0_2~11
X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b461bc4dc755284b0333e764039003438a22c695;p=elisp%2Flsdb.git

* LSDB-ELS (lsdb-modules-to-compile): Add xbm-thumb.
* xbm-thumb.el: New file.

* lsdb.el: Require static and path-util.
(lsdb-x-face): New custom group.
(lsdb-display-small-x-face): New user option.
(lsdb-x-face-scale-factor): Abolish.
(lsdb-uncompface-program): New user option.
(lsdb-insert-x-face-function): Set default to lsdb-insert-x-face.
(lsdb-display-records-sort-predicate): New user option.
(lsdb-display-records): Sort records with lsdb-display-records-sort-predicate.
(lsdb-pointer-xpm): New constant.
(lsdb-xemacs-modeline-left-extent): New variable.
(lsdb-xemacs-modeline-right-extent): New variable.
(lsdb-modeline-buffer-identification): New function.
(lsdb-modeline-string): New variable.
(lsdb-mode): Set up mode-line-buffer-identification.
(lsdb-modeline-update): New function.
(lsdb-narrow-to-record): Applied the patch from
Hideyuki SHIRAI <shirai@rdmg.mgcs.mei.co.jp>.
(lsdb-mode-save): Don't ask whether to save the database when
the argument 'ask is passed.
(lsdb-insert-x-face-with-x-face-e21): Abolish.
(lsdb-insert-x-face-with-xemacs-glyph): Abolish.
(lsdb-call-process-on-string): New function.
(lsdb-mirror-bits): New function.
(lsdb-mirror-bytes): New constant.
(lsdb-convert-x-face-to-xbm): New function.
(lsdb-insert-x-face): New function.
---

diff --git a/LSDB-ELS b/LSDB-ELS
index 9182139..e0b9385 100644
--- a/LSDB-ELS
+++ b/LSDB-ELS
@@ -5,7 +5,7 @@
 ;;; Code:
 
 (setq lsdb-modules-to-compile
-      '(lsdb))
+      '(xbm-thumb lsdb))
 
 (setq lsdb-modules-not-to-compile nil)
 
diff --git a/lsdb.el b/lsdb.el
index 9961524..92b3c3e 100644
--- a/lsdb.el
+++ b/lsdb.el
@@ -44,6 +44,7 @@
 (require 'poem)
 (require 'pces)
 (require 'mime)
+(require 'static)
 
 ;;;_* USER CUSTOMIZATION VARIABLES:
 (defgroup lsdb nil
@@ -120,15 +121,28 @@ where the last element is optional."
   :group 'lsdb
   :type 'integer)
 
+(defgroup lsdb-x-face nil
+  "The Lovely Sister Database, X-Face related settings."
+  :group 'lsdb)
+
+(defcustom lsdb-display-small-x-face nil
+  "If non-nil, downscale the size of X-Face image."
+  :group 'lsdb-x-face
+  :type 'float)
+
+(defcustom lsdb-uncompface-program (exec-installed-p "uncompface")
+  "Name of the uncompface program."
+  :group 'lsdb-x-face
+  :type 'file)
+
 (defcustom lsdb-insert-x-face-function
-  (if (and (>= emacs-major-version 21)
-	   (locate-library "x-face-e21"))
-      #'lsdb-insert-x-face-with-x-face-e21
-    (if (and (featurep 'xemacs)
-	     (memq 'xface (image-instantiator-format-list)))
-	#'lsdb-insert-x-face-with-xemacs-glyph))
-  "Function to display X-Face."
-  :group 'lsdb
+  (and lsdb-uncompface-program
+       (or (>= emacs-major-version 21)
+	   (and (featurep 'xemacs)
+		(memq 'xbm (image-instantiator-format-list))))
+       #'lsdb-insert-x-face)
+  "A function to display X-Face."
+  :group 'lsdb-x-face
   :type 'function)
 
 (defcustom lsdb-display-record-hook
@@ -138,6 +152,11 @@ where the last element is optional."
   :group 'lsdb
   :type 'hook)
 
+(defcustom lsdb-display-records-sort-predicate nil
+  "A predicate to sort records."
+  :group 'lsdb
+  :type 'function)
+  
 (defgroup lsdb-edit-form nil
   "A mode for editing forms."
   :group 'lsdb)
@@ -468,6 +487,11 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
 (defun lsdb-display-records (records)
   (with-output-to-temp-buffer lsdb-buffer-name
     (set-buffer standard-output)
+    (setq records
+	  (sort (copy-sequence records)
+		(or lsdb-display-records-sort-predicate
+		    (lambda (record1 record2)
+		      (string-lessp (car record1) (car record2))))))
     (while records
       (save-restriction
 	(narrow-to-region (point) (point))
@@ -552,6 +576,85 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
       (insert (pop lsdb-last-candidates-pointer)))))
 
 ;;;_. Major Mode (`lsdb-mode') Implementation
+;;;_ : Modeline Buffer Identification
+(defconst lsdb-pointer-xpm
+  "/* XPM */
+static char * lsdb_pointer_xpm[] = {
+\"14 14 5 1\",
+\" 	c None\",
+\"+	c #FF9696\",
+\"@	c #FF0000\",
+\"#	c #FF7575\",
+\"$	c #FF5959\",
+\"              \",
+\"  +++   @@@   \",
+\" +++## @@@@@  \",
+\" ++### @@@@@  \",
+\" +#####@@@@@  \",
+\" +###$$@@@@@  \",
+\" +###$$@@@@@  \",
+\"  ##$$$@@@@   \",
+\"   #$$$@@@    \",
+\"    $$@@@     \",
+\"     $@@      \",
+\"      @       \",
+\"              \",
+\"              \"};")
+
+(static-if (featurep 'xemacs)
+    (progn
+      (defvar lsdb-xemacs-modeline-left-extent
+	(copy-extent modeline-buffer-id-left-extent))
+
+      (defvar lsdb-xemacs-modeline-right-extent
+	(copy-extent modeline-buffer-id-right-extent))
+
+      (defun lsdb-modeline-buffer-identification (line)
+	"Decorate 1st element of `mode-line-buffer-identification' LINE.
+Modify whole identification by side effect."
+	(let ((id (car line)) chopped)
+	  (if (and (stringp id) (string-match "^LSDB:" id))
+	      (progn
+		(setq chopped (substring id 0 (match-end 0))
+		      id (substring id (match-end 0)))
+		(nconc
+		 (list
+		  (let ((glyph
+			 (make-glyph
+			  (nconc
+			   (if (featurep 'xpm)
+			       (list (vector 'xpm :data lsdb-pointer-xpm)))
+			   (list (vector 'string :data chopped))))))
+		    (if glyph
+			(progn
+			  (set-glyph-face glyph 'modeline-buffer-id)
+			  (cons lsdb-xemacs-modeline-left-extent glyph))
+		      (cons lsdb-xemacs-modeline-left-extent
+			    chopped)))
+		  (cons lsdb-xemacs-modeline-right-extent id))
+		 (cdr line)))
+	    line))))
+  (condition-case nil
+      (progn
+	(require 'image)
+	(defun lsdb-modeline-buffer-identification (line)
+	  "Decorate 1st element of `mode-line-buffer-identification' LINE.
+Modify whole identification by side effect."
+	  (let ((id (copy-sequence (car line)))
+		(image
+		 (if (image-type-available-p 'xpm)
+		     (create-image lsdb-pointer-xpm 'xpm t :ascent 'center))))
+	    (when (and image
+		       (stringp id) (string-match "^LSDB:" id))
+	      (add-text-properties 0 (length id)
+				   (list 'display image
+					 'rear-nonsticky (list 'display))
+				   id)
+	      (setcar line id))
+	    line)))
+    (error
+     (defalias 'lsdb-modeline-buffer-identification 'identity))))
+
 (defvar lsdb-mode-map
   (let ((keymap (make-sparse-keymap)))
     (define-key keymap "a" 'lsdb-mode-add-entry)
@@ -569,6 +672,8 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
     keymap)
   "LSDB's keymap.")
 
+(defvar lsdb-modeline-string "")
+
 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
   "Major mode for browsing LSDB records."
   (setq buffer-read-only t)
@@ -577,13 +682,36 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
       ;; `find-file-hooks'.
       (font-lock-set-defaults)
     (set (make-local-variable 'font-lock-defaults)
-	 '(lsdb-font-lock-keywords t))))
+	 '(lsdb-font-lock-keywords t)))
+  (make-local-variable 'post-command-hook)
+  (setq post-command-hook 'lsdb-modeline-update)
+  (make-local-variable 'lsdb-modeline-string)
+  (setq mode-line-buffer-identification
+	(lsdb-modeline-buffer-identification
+	 '("LSDB: " lsdb-modeline-string)))
+  (lsdb-modeline-update)
+  (force-mode-line-update))
+
+(defun lsdb-modeline-update ()
+  (let ((record
+	 (get-text-property (if (eobp) (point-min) (point)) 'lsdb-record))
+	net)
+    (if record
+	(progn
+	  (setq net (car (cdr (assq 'net (cdr record)))))
+	  (if (equal net (car record))
+	      (setq lsdb-modeline-string net)
+	    (setq lsdb-modeline-string (concat (car record) " <" net ">"))))
+      (setq lsdb-modeline-string ""))))
 
 (defun lsdb-narrow-to-record ()
-  (narrow-to-region
-   (previous-single-property-change (point) 'lsdb-record nil (point-min))
-   (next-single-property-change (point) 'lsdb-record nil (point-max)))
-  (goto-char (point-min)))
+  (let ((end (next-single-property-change (point) 'lsdb-record nil
+					  (point-max))))
+    (narrow-to-region
+     (previous-single-property-change (point) 'lsdb-record nil
+				      (point-min))
+     end)
+    (goto-char (point-min))))
 
 (defun lsdb-current-record ()
   (let ((record (get-text-property (point) 'lsdb-record)))
@@ -699,12 +827,13 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
 		 (point))
 	       (list 'lsdb-record record)))))))))
 
-(defun lsdb-mode-save ()
+(defun lsdb-mode-save (&optional ask)
   "Save LSDB hash table into `lsdb-file'."
   (interactive)
   (if (not lsdb-hash-table-is-dirty)
       (message "(No changes need to be saved)")
     (when (or (interactive-p)
+	      (not ask)
 	      (y-or-n-p "Save the LSDB now?"))
       (lsdb-save-file lsdb-file lsdb-hash-table)
       (setq lsdb-hash-table-is-dirty nil)
@@ -1004,30 +1133,98 @@ the user wants it."
       (while x-face
 	(funcall lsdb-insert-x-face-function (pop x-face))))))
 
-;; stolen (and renamed) from gnus-summary-x-face.el written by Akihiro Arisawa.
-(defvar lsdb-x-face-scale-factor 0.5
-  "A number of scale factor used to scale down X-face image.
-See also `x-face-scale-factor'.")
-
-(defun lsdb-insert-x-face-with-x-face-e21 (x-face)
-  (require 'x-face-e21)
-  (insert-image (x-face-create-image
-		 x-face :scale-factor lsdb-x-face-scale-factor)))
-
-(defun lsdb-insert-x-face-with-xemacs-glyph (x-face)
-  (let ((glyph
-	 (make-glyph
-	  (vector 'xface :data (concat "X-Face: " x-face)))))
-    (if glyph
-	(set-extent-end-glyph
-	 (make-extent (point) (point))
-	 glyph))))
+(defun lsdb-call-process-on-string
+  (program string &optional buffer &rest args)
+  (if (eq buffer t)
+      (setq buffer (current-buffer)))
+  (let ((process (apply #'start-process program buffer program args))
+	status exit-status)
+    (unwind-protect
+	(progn
+	  (set-process-sentinel process #'ignore) ;don't insert exit status
+	  (process-send-string process string)
+	  (process-send-eof process)
+	  (while (eq 'run (process-status process))
+	    (accept-process-output process 5))
+	  (setq status (process-status process)
+		exit-status (process-exit-status process))
+	  (if (memq status '(stop signal))
+	      (error "%s exited abnormally: '%s'" program exit-status))
+	  (if (= 127 exit-status)
+	      (error "%s could not be found" program))
+	  (delete-process process))
+      (if (and process (eq 'run (process-status process)))
+	  (interrupt-process process)))))
+
+(eval-and-compile
+  (defun lsdb-mirror-bits (bits nbits)
+    (if (= nbits 1)
+	bits
+      (logior (lsh (lsdb-mirror-bits (logand bits (1- (lsh 1 (/ nbits 2))))
+				     (/ nbits 2))
+		   (/ nbits 2))
+	      (lsdb-mirror-bits (lsh bits (- (/ nbits 2)))
+				(/ nbits 2))))))
+(defconst lsdb-mirror-bytes
+  (eval-when-compile
+    (let ((table (make-vector 256 0))
+	  (i 0))
+      (while (< i 256)
+	(aset table i (logxor (lsdb-mirror-bits i 8) 255))
+	(setq i (1+ i)))
+      table)))
+      
+(defun lsdb-convert-x-face-to-xbm (x-face &optional bit-reverse)
+  (with-temp-buffer
+    (lsdb-call-process-on-string
+     lsdb-uncompface-program (concat x-face "\n") t)
+    (set-buffer-multibyte nil)
+    (let* ((result (make-string 288 ?\0))
+	   (index 0))
+      (goto-char (point-min))
+      (while (re-search-forward
+	      "0x\\([0-9A-F][0-9A-F]\\)\\([0-9A-F][0-9A-F]\\),\n?" nil
+	      t)
+	(aset result
+	      (prog1 index
+		(setq index (1+ index)))
+	      (car (read-from-string
+		    (concat "?\\x" (match-string 1)))))
+	(aset result
+	      (prog1 index
+		(setq index (1+ index)))
+	      (car (read-from-string
+		    (concat "?\\x" (match-string 2))))))
+      (when bit-reverse
+	(setq index 0)
+	(while (< index 288)
+	  (aset result index
+		(aref lsdb-mirror-bytes (aref result index)))
+	  (setq index (1+ index))))
+      (list 48 48 result))))
+
+(autoload 'xbm-make-thumbnail "xbm-thumb")
+
+(defun lsdb-insert-x-face (x-face)
+  (let ((data
+	 (if lsdb-display-small-x-face
+	     (xbm-make-thumbnail (lsdb-convert-x-face-to-xbm x-face t))
+	   (lsdb-convert-x-face-to-xbm x-face t))))
+    (static-if (featurep 'xemacs)
+	(let ((glyph (make-glyph (vector 'xbm :data data))))
+	  (if glyph
+	      (set-extent-end-glyph
+	       (make-extent (point) (point))
+	       glyph)))
+      (insert-image
+       (create-image
+	(nth 2 data) 'xbm t :width (car data) :height (nth 1 data))))))
 
 (require 'product)
 (provide 'lsdb)
 
 (product-provide 'lsdb
-  (product-define "LSDB" nil '(0 1)))
+  (product-define "LSDB" nil '(0 2)))
 
 ;;;_* Local emacs vars.
 ;;; The following `outline-layout' local variable setting:
diff --git a/xbm-thumb.el b/xbm-thumb.el
new file mode 100644
index 0000000..5005ea5
--- /dev/null
+++ b/xbm-thumb.el
@@ -0,0 +1,89 @@
+;;; xbm-thumb.el --- create XBM thumbnail under Emacs.
+;; Copyright (C) 2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 2000-02-26
+;; Keywords: xbm, image
+
+;; This file is not part of any package.
+
+;; 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 2, 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+
+;;; Commentary:
+;; 
+
+;;; Code:
+
+(defvar xbm-thumb-dot-threshold 1)
+
+(defun xbm-thumb-fold-left (function accu sequence)
+  (if (null sequence) accu
+    (xbm-thumb-fold-left
+     function (funcall function accu (car sequence))
+     (cdr sequence))))
+
+(defun xbm-thumb-aggregate-block (b1 b2)
+  (let ((idx 128) (result 0))
+    (while (> idx 1)
+      (setq result
+	    (logior (lsh result 1)
+		    (if (< xbm-thumb-dot-threshold
+			   (xbm-thumb-fold-left
+			    #'+ 0 (list
+				   (logand b1 idx)
+				   (logand b1 (lsh idx -1))
+				   (logand b2 idx)
+				   (logand b2 (lsh idx -1)))))
+			1 0))
+	    idx (lsh idx -2)))
+    result))
+
+(defun xbm-thumb-aggregate-row (row)
+  (let ((len (/ (length row) 2))
+	(result "")
+	(i 0))
+    (while (< i len)
+      (setq result
+	    (format "%s\\x%02x" result
+		    (logior
+		     (lsh (xbm-thumb-aggregate-block
+			   (aref row (1+ i)) (aref row (+ i 1 len))) 4)
+		     (xbm-thumb-aggregate-block
+		      (aref row i) (aref row (+ i len)))))
+	    i (+ i 2)))
+    result))
+
+;;;###autoload
+(defun xbm-make-thumbnail (data)
+  "Create XBM thumbnail."
+  (let* ((string (nth 2 data))
+	 (len (length string))
+	 (width (/ (car data) 8))
+	 (result "")
+	 (i 0))
+    (while (< i len)
+      (setq result
+	    (concat result
+		    (xbm-thumb-aggregate-row
+		     (substring string i (setq i (+ i (* 2 width))))))))
+    (list
+     (/ (car data) 2) (/ (nth 1 data) 2)
+     (car (read-from-string (concat "\"" result "\""))))))
+
+(provide 'xbm-thumb)
+
+;;; xbm-thumb.el ends here