From: ueno Date: Fri, 18 Feb 2000 04:14:32 +0000 (+0000) Subject: * EMU-ELS (emu-modules): Add 'image-stpl; require bitmap when X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c6af66d85e690895406c42040dcc0155ba4adae3;p=elisp%2Fapel.git * EMU-ELS (emu-modules): Add 'image-stpl; require bitmap when compiling; check `error' instead of `file-error'. * image-stpl.el: New file. --- diff --git a/EMU-ELS b/EMU-ELS index c78d23c..13b2b9c 100644 --- a/EMU-ELS +++ b/EMU-ELS @@ -185,9 +185,12 @@ ;; v21. (require 'image) '(pimage)) - (file-error - ;; Emacs w/ runtime bitmap-mule. - '(pimage image-bm tinyimage)))) + (error + (condition-case nil + (require 'bitmap) + (error nil)) + ;; Emacs w/ stipple pixmap or runtime bitmap-mule. + '(pimage image-bm image-stpl tinyimage)))) (t ;; v18. '(pimage tinyimage))) diff --git a/image-stpl.el b/image-stpl.el new file mode 100644 index 0000000..c0fbf25 --- /dev/null +++ b/image-stpl.el @@ -0,0 +1,165 @@ +;;; image-stpl.el -- pimage module using stipple pixmap. + +;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Keywords: emulation, image + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 this program; 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: + +(require 'poe) + +(defun image-stipple-read-xbm-buffer (buffer) + "Convert xbm buffer to stipple format." + (save-excursion + (set-buffer buffer) + (let ((case-fold-search t) width height xbytes right margin) + (goto-char (point-min)) + (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t) + (error "!! Illegal xbm file format." (current-buffer))) + (setq width (string-to-int (match-string 1)) + xbytes (/ (+ width 7) 8)) + (goto-char (point-min)) + (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t) + (error "!! Illegal xbm file format." (current-buffer))) + (setq height (string-to-int (match-string 1))) + + (goto-char (point-min)) + (re-search-forward "0x[0-9a-f][0-9a-f],") + (delete-region (point-min) (match-beginning 0)) + + (goto-char (point-min)) + (while (re-search-forward "[\n\r\t ,;}]" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (re-search-forward "0x" nil t) + (replace-match "\\x" nil t)) + (goto-char (point-min)) + (insert "(" (number-to-string width) " " (number-to-string height) " \"") + (goto-char (point-max)) + (insert "\")") + (goto-char (point-min)) + (read (current-buffer))))) + +(defun-maybe image-type-available-p (type) + "Value is non-nil if image type TYPE is available. +Image types are symbols like `xbm' or `jpeg'. +\[Emacs 21 emulating function]" + (eq type 'xbm)) + +(defun-maybe create-image (file-or-data &optional type data-p &rest props) + "Create an image. +FILE-OR-DATA is an image file name or image data. +Optional TYPE is a symbol describing the image type. If TYPE is omitted +or nil, try to determine the image type from its first few bytes +of image data. If that doesn't work, and FILE-OR-DATA is a file name, +use its file extension.as image type. +Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data. +Optional PROPS are additional image attributes to assign to the image. +Value is the image created, or nil if images of type TYPE are not supported. +\[Emacs 21 emulating function]" + (when (or (null type) (eq type 'xbm)) + (with-temp-buffer + (if data-p + (insert file-or-data) + (insert-file-contents file-or-data)) + (image-stipple-read-xbm-buffer (current-buffer))))) + +(defun-maybe insert-image (image string &optional area) + "Insert IMAGE into current buffer at point. +IMAGE is displayed by inserting STRING into the current buffer +with a `display' property whose value is the image. +AREA is where to display the image. AREA nil or omitted means +display it in the text area, a value of `left-margin' means +display it in the left marginal area, a value of `right-margin' +means display it in the right marginal area. +\[Emacs 21 emulating function]" + (save-excursion + (save-restriction + (narrow-to-region (point)(point)) + (insert (mapconcat + (function ignore) + (make-list (/ (cadr image) + (frame-char-height)) + (make-string (/ (car image) + (frame-char-width)) + ? )) "\n")) + (or (facep 'image-stipple-splash) + (make-face 'image-stipple-splash)) + (set-face-stipple 'image-stipple-splash image) + (set-text-properties (point-min)(point) '(face image-stipple-splash))))) + +(defun-maybe remove-images (start end &optional buffer) + "Remove images between START and END in BUFFER. +Remove only images that were put in BUFFER with calls to `put-image'. +BUFFER nil or omitted means use the current buffer. +\[Emacs 21 emulating function]" + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (setq start (next-single-property-change (point) 'face)) + (when (eq (get-text-property start 'face) 'image-stipple-splash) + (delete-region start (next-single-property-change + start 'face nil end)) + (goto-char start)))))) + +(defmacro-maybe defimage (symbol specs &optional doc) + "Define SYMBOL as an image. + +SPECS is a list of image specifications. DOC is an optional +documentation string. + +Each image specification in SPECS is a property list. The contents of +a specification are image type dependent. All specifications must at +least contain the properties `:type TYPE' and either `:file FILE' or +`:data DATA', where TYPE is a symbol specifying the image type, +e.g. `xbm', FILE is the file to load the image from, and DATA is a +string containing the actual image data. The first image +specification whose TYPE is supported, and FILE exists, is used to +define SYMBOL. + +Example: + + (defimage test-image ((:type xpm :file \"~/test1.xpm\") + (:type xbm :file \"~/test1.xbm\"))) +\[Emacs 21 emulating macro]" + (let ((spec + (catch 'found + (while specs + (if (eq (plist-get (car specs) ':type) 'xbm) + (throw 'found (car specs)))))) + file-or-data data-p) + (if (setq file-or-data (plist-get spec ':data)) + (setq data-p t) + (setq file-or-data (plist-get spec ':file))) + (` (defvar (, symbol) + (, (if spec (` (create-image (, file-or-data) 'xbm (, data-p))))) + (, doc))))) + +(provide 'image) + +(require 'product) +(product-provide (provide 'image-stpl) (require 'apel-ver)) + +;;; image-stpl.el ends here