cgit.sxemacs.org Git - packages/blob - xemacs-packages/liece/lisp/bitmap-stipple.el

   1 ;;; bitmap-stipple.el --- display bitmap file using stipple.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-05-30
   6 ;; Keywords: bitmap, stipple
   7
   8 ;; This file is not part of any package.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30
  31 (defun bitmap-stipple-xbm-file-to-stipple (file)
  32   "Convert xbm FILE into icon format and return the list of spec and buffers."
  33   (with-temp-buffer
  34     (erase-buffer)
  35     (let ((case-fold-search t) width height xbytes right margin)
  36       (insert-file-contents file)
  37       (goto-char (point-min))
  38       (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t)
  39           (error "!! Illegal xbm file format" (current-buffer)))
  40       (setq width (string-to-int (match-string 1))
  41             xbytes (/ (+ width 7) 8))
  42       (goto-char (point-min))
  43       (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t)
  44           (error "!! Illegal xbm file format" (current-buffer)))
  45       (setq height (string-to-int (match-string 1)))
  46
  47       (goto-char (point-min))
  48       (re-search-forward "0x[0-9a-f][0-9a-f],")
  49       (delete-region (point-min) (match-beginning 0))
  50
  51       (goto-char (point-min))
  52       (while (re-search-forward "[\n\r\t ,;}]" nil t)
  53         (replace-match ""))
  54       (goto-char (point-min))
  55       (while (re-search-forward "0x" nil t)
  56         (replace-match "\\x" nil t))
  57       (goto-char (point-min))
  58       (insert "(" (number-to-string width) " " (number-to-string height) " \"")
  59       (goto-char (point-max))
  60       (insert "\")")
  61       (goto-char (point-min))
  62       (read (current-buffer)))))
  63
  64 (defun bitmap-stipple-insert-pixmap (pixmap &optional center)
  65   "Insert PIXMAP in the current buffer.
  66 Optional argument CENTER specified, pixmap will be centered."
  67   (let (width height beg i)
  68     (or (facep 'bitmap-stipple-splash)
  69         (make-face 'bitmap-stipple-splash))
  70     (setq width (/ (car pixmap) (frame-char-width))
  71           height (/ (cadr pixmap) (frame-char-height)))
  72     (set-face-foreground 'bitmap-stipple-splash "red")
  73     (set-face-stipple 'bitmap-stipple-splash pixmap)
  74     (if center (insert-char ?\n height))
  75     (setq i height)
  76     (while (> i 0)
  77       (setq beg (point))
  78       (insert-char ?  width)
  79       (set-text-properties beg (point) '(face bitmap-stipple-splash))
  80       (insert "\n")
  81       (decf i))))
  82
  83 ;;;###autoload
  84 (defun bitmap-stipple-insert-xbm-file (file)
  85   "Insert xbm FILE at point."
  86   (interactive "fxbm file: ")
  87   (save-excursion
  88     (bitmap-stipple-insert-pixmap
  89      (bitmap-stipple-xbm-file-to-stipple file))))
  90
  91 (provide 'bitmap-stipple)
  92
  93 ;;; bitmap-stipple.el ends here