--- /usr/local/share/emacs/21.2/lisp/play/gamegrid.el Tue May 7 23:18:49 2002 +++ gamegrid.el Mon Sep 16 13:14:22 2002 @@ -42,6 +42,10 @@ (defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*" "Name of the font used in X mode.") +(defvar gamegrid-face nil + "Indicates the face to use as a default.") +(make-variable-buffer-local 'gamegrid-face) + (defvar gamegrid-display-options nil) (defvar gamegrid-buffer-width 0) @@ -115,6 +119,16 @@ " "XPM format image used for each square") +(defvar gamegrid-xbm "\ +/* gamegrid XBM */ +#define gamegrid_width 16 +#define gamegrid_height 16 +static unsigned char gamegrid_bits[] = { + 0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, + 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, + 0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };" + "XBM format image used for each square.") + ;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defsubst gamegrid-characterp (arg) @@ -145,7 +159,7 @@ (if gamegrid-font (condition-case nil (set-face-font face gamegrid-font) - ('error nil)))) + (error nil)))) (defun gamegrid-setup-face (face color) (set-face-foreground face color) @@ -153,20 +167,20 @@ (gamegrid-set-font face) (condition-case nil (set-face-background-pixmap face [nothing]);; XEmacs - ('error nil)) + (error nil)) (condition-case nil (set-face-background-pixmap face nil);; Emacs - ('error nil))) + (error nil))) (defun gamegrid-make-mono-tty-face () (let ((face (make-face 'gamegrid-mono-tty-face))) (condition-case nil (set-face-property face 'reverse t) - ('error nil)) + (error nil)) face)) (defun gamegrid-make-color-tty-face (color) - (let* ((color-str (symbol-value color)) + (let* ((color-str (if (stringp color) color (symbol-value color))) (name (intern (format "gamegrid-color-tty-face-%s" color-str))) (face (make-face name))) (gamegrid-setup-face face color-str) @@ -215,13 +229,16 @@ gamegrid-mono-tty-face)))) (defun gamegrid-colorize-glyph (color) - (make-glyph - (vector - 'xpm - :data gamegrid-xpm - :color-symbols (list (cons "col1" (gamegrid-color color 0.6)) - (cons "col2" (gamegrid-color color 0.8)) - (cons "col3" (gamegrid-color color 1.0)))))) + (find-image `((:type xpm :data ,gamegrid-xpm + :ascent center + :color-symbols + (("col1" . ,(gamegrid-color color 0.6)) + ("col2" . ,(gamegrid-color color 0.8)) + ("col3" . ,(gamegrid-color color 1.0)))) + (:type xbm :data ,gamegrid-xbm + :ascent center + :foreground ,(gamegrid-color color 1.0) + :background ,(gamegrid-color color 0.5))))) (defun gamegrid-match-spec (spec) (let ((locale (car spec)) @@ -245,38 +262,35 @@ (vector data)) ((eq data 'colorize) (gamegrid-colorize-glyph color)) + ((listp data) + (find-image data)) ;untested! ((vectorp data) - (make-glyph data))))) + (gamegrid-make-image-from-vector data))))) -(defun gamegrid-color-display-p () - (if (fboundp 'device-class) - (eq (device-class (selected-device)) 'color) - (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color))) +(defun gamegrid-make-image-from-vector (vect) + "Convert an XEmacs style \"glyph\" to an image-spec." + (let ((l (list 'image :type))) + (dotimes (n (length vect)) + (setf l (nconc l (list (aref vect n))))) + (nconc l (list :ascent 'center)))) (defun gamegrid-display-type () - (let ((window-system-p - (or (and (fboundp 'console-on-window-system-p) - (console-on-window-system-p)) - (and (fboundp 'display-color-p) - (display-color-p)) - window-system))) (cond ((and gamegrid-use-glyphs - window-system-p - (featurep 'xpm)) + (display-images-p)) 'glyph) ((and gamegrid-use-color - window-system-p - (gamegrid-color-display-p)) + (display-graphic-p) + (display-color-p)) 'color-x) - (window-system-p + ((display-graphic-p) 'mono-x) ((and gamegrid-use-color - (gamegrid-color-display-p)) + (display-color-p)) 'color-tty) - ((fboundp 'set-face-property) + ((display-multi-font-p) ;??? 'mono-tty) (t - 'emacs-tty)))) + 'emacs-tty))) (defun gamegrid-set-display-table () (if (fboundp 'specifierp) @@ -287,26 +301,21 @@ 'remove-locale) (setq buffer-display-table gamegrid-display-table))) -(defun gamegrid-hide-cursor () - (if (fboundp 'specifierp) - (set-specifier text-cursor-visible-p nil (current-buffer)))) - (defun gamegrid-setup-default-font () - (cond ((eq gamegrid-display-mode 'glyph) - (let* ((font-spec (face-property 'default 'font)) - (name (font-name font-spec)) - (max-height nil)) - (loop for c from 0 to 255 do - (let ((glyph (aref gamegrid-display-table c))) - (cond ((glyphp glyph) - (let ((height (glyph-height glyph))) - (if (or (null max-height) - (< max-height height)) - (setq max-height height))))))) - (if max-height - (while (and (> (font-height font-spec) max-height) - (setq name (x-find-smaller-font name))) - (add-spec-to-specifier font-spec name (current-buffer)))))))) + (setq gamegrid-face + (copy-face 'default + (intern (concat "gamegrid-face-" (buffer-name))))) + (when (eq gamegrid-display-mode 'glyph) + (let ((max-height nil)) + (loop for c from 0 to 255 do + (let ((glyph (aref gamegrid-display-table c))) + (when (and (listp glyph) (eq (car glyph) 'image)) + (let ((height (cdr (image-size glyph)))) + (if (or (null max-height) + (< max-height height)) + (setq max-height height)))))) + (when (and max-height (< max-height 1)) + (set-face-attribute gamegrid-face nil :height max-height))))) (defun gamegrid-initialize-display () (setq gamegrid-display-mode (gamegrid-display-type)) @@ -320,11 +329,13 @@ (aset gamegrid-display-table c glyph))) (gamegrid-setup-default-font) (gamegrid-set-display-table) - (gamegrid-hide-cursor)) + (setq cursor-type nil)) (defun gamegrid-set-face (c) - (unless (eq gamegrid-display-mode 'glyph) + (if (eq gamegrid-display-mode 'glyph) + (add-text-properties (1- (point)) (point) + (list 'display (list (aref gamegrid-display-table c)))) (put-text-property (1- (point)) (point) 'face @@ -351,14 +362,18 @@ (defun gamegrid-init-buffer (width height blank) (setq gamegrid-buffer-width width gamegrid-buffer-height height) - (let ((line (concat - (make-string width blank) - "\n")) + (let ((line (concat (make-string width blank) "\n")) (buffer-read-only nil)) (erase-buffer) (setq gamegrid-buffer-start (point)) (dotimes (i height) - (insert-string line)) + (insert line)) + ;; Adjust the height of the default face to the height of the + ;; images. Unlike XEmacs, Emacs doesn't allow to make the default + ;; face buffer-local; so we do this with an overlay. + (when (eq gamegrid-display-mode 'glyph) + (overlay-put (make-overlay (point-min) (point-max)) + 'face gamegrid-face)) (goto-char (point-min)))) (defun gamegrid-init (options)