+++ /dev/null
-;;; 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