From b461bc4dc755284b0333e764039003438a22c695 Mon Sep 17 00:00:00 2001 From: ueno Date: Sat, 27 Apr 2002 13:09:01 +0000 Subject: [PATCH] * 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 . (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. --- LSDB-ELS | 2 +- lsdb.el | 263 ++++++++++++++++++++++++++++++++++++++++++++++++++-------- xbm-thumb.el | 89 ++++++++++++++++++++ 3 files changed, 320 insertions(+), 34 deletions(-) create mode 100644 xbm-thumb.el 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 +;; 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 -- 1.7.10.4