;;; Create XBM text buttons under XEmacs (requires 19.12 or beyond)
;;; Copyright (C) 1995 Kyle E. Jones
;;;
;;; 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 1, 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.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;;
;;; Synched up with: Not in FSF.
;;;
;;; Send bug reports to kyle@wonderworks.com

;;; The sole interface function is xbm-button-create.


(provide 'xbm-button)

(defvar xbm-button-version "1.00"
  "Version string for xbm-button.")

(defvar xbm-button-vertical-padding 3
  "Number of pixels between the text and the top/bottom of the button.")

(defvar xbm-button-horizontal-padding 3
  "Number of pixels between the text and the left/right edges of the button.")

(defvar xbm-button-font-pixel-lines
  '(
"000011000001111110000011110101111111000111111110111111110001111010011110011110111100001111011110111101111000001111000111101110000111000111110001111111000011111000011111110000111101011111111011110011101111000111011110111101110111101111011110111011111111000000000111000000000000000001110000000000011100000000011100000001100011011100000011100000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000011000001000111100011110000111000111110001110011111100111100011110001000000001100000111100000010100011110000110001000000010000001110000000100000010100000000000000000000000000000000001111000110111101100000000011010100000000000000000000000100111100100000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"000011000000110011000110001100110001100011000110011000110011000110001100001100011000000110001100010000110000000111000111000111000010001100011000110001100110001100001100011001100011011011011001100001000110000010001100011000100011000100001100010011000111000000000011000000000000000000110000000000110100000000001100000001100011001100000001100000000000000000000000000000000000000000000000000000000000000001100000000000000000000000000000000000000000000000000000000000100100111001100110110011000111000111100010011011111101100110110011010000000001100011000010000010100110111001101111000000010000011001000010101000100010000000000000000000000000000000001100001100001100110000000011010100000000000000000000000101100110110000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"000101100000110011001100000100110000110011000010011000010110000010001100001100011000000110001100100000110000000111000111000111100010011000001100110001101100000110001100011001100001010011001001100001000110000010001100011000100011101000001100010010001110000000000011000000000000000000110000000000110000000110001100000000000000001100000001100000000000000000000000000000000000000000000000000000000000000001100000000000000000000000000000000000000000000000000000000001100110011001100110110011001011000100000110011010001001100010110011011000000001100100111101001111110100100011001010000000111000011010000001110001100011000000000000000000000000000100001100001100001100110000000001010100000000000000000000000101100110010000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"000101100000110011001100000100110000110011001000011001010110000010001100001100011000000110001101000000110000000101101011000101110010011000001100110001101100000110001100011001111000010011001001100001000011000100000110101101000001111000000110100000011100001111000011011000001110000110110000111001111100111100001101100011100111001101110001100111011001100011101100000111000111011000001101100111011001111011111011101110011110111011101111011101110111011110111011111101100110011000000110000011001011000111100110000000011000110100110011011000000001100101001101000101000110100011001010011000101000001100111010101001000001000000000000000000000000000100001100001100001100110011011010000000000000110000110000001100000110011000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"001000110000111110001100000000110000110011111000011111000110000000001111111100011000000110001111100000110000000101101011000100111010011000001100110011001100000110001111100000111110000011000001100001000011000100000110101101000000111000000110100000011000001001100011101110111011011101110011101100110001100110001110110001100011001101100001100011101110110001110110011101110011101110111011100011111010001001100001100110001100010001100110001000110010001100010010011101100110011000001100001100010011000100110111110000011000111100011111000001100101101011011001000101000011110011010100110101101100011110010000100011000001100000000000000001111110000100001100001000001100010011011000000000000011100000011100001000001100001000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"001111110000110001101100000000110000110011001000011001000110001111001100001100011000000110001101110000110000000101101011000100011110011000001100111110001101100110001100110000001111000011000001100001000001101000000110101101000001011100000011000000111000000111100011000110110000011000110011111100110001100110001100110001100011001111000001100011001100110001100110011000110011000110110001100011000011110001100001100110000110100000110111010000011100000110100000111001100110011000011000000011010011000000110110011000110000101110000011000011111101101011011010011111100000111001100101100101000100100111100000000011000001101111110000000000000000111111101100010000001100001000000000000000001110000000000111011000010000001100100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"010000011000110001101100000100110000110011000010011000000110000110001100001100011001100110001100110000110000100100110011000100001110011000001100110000001110010110001100110001000011000011000001100001000001101000000011000110000001001110000011000001110001011001100011000110110000011000110011000000110000111100001100110001100011001101100001100011001100110001100110011000110011000110110001100011000001111001100001100110000110100000110111010000011100000110100001110001100110011000100010110011011111101100110110011000110001000110110011000010011000001001101100001010000110101000001001100100000001100011100000000011000001100000000000000001111110000100001100001000001100010000000000000000000011100000011100010000000000000100100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"010000011000110001100110001100110001100011000110011000000011000110001100001100011001100110001100111000110001100100110011000100000110001100011000110000000110011100001100011101100011000011000001110011000000110000000011000110000010000110000011000011100011011011100011001110111011011101110011101100110001000000001100110001100011001100110001100011001100110001100110011101110011101110111011100011000010001001100001101110000011000000011001100000100110000011000011100100100100011001111110110011000011001100110110011000110001100110110010000000000001100100000010001010000110101000001001101000000001110011111000000001000001000000000000000000000000000100001100001100001100110011011000000001100000110110110000010000011000000110100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"111000111101111111000011111001111111000111111110111100000001111010011110011110111100111000011110011101111111101110110111101110000010000111110001111000000011111000011110011001011110000111100000111110000000110000000011000110000111001111000111100011111111001101110010111000001110000110111000111001111001111110011110111011110011011110111011110111101110111011110111000111000011011000001101100111100011110000110000110111000011000000011001100001110111000011000011111100011000111101111110011110000111100111100011110000110000111100011100000000000001100011111100001010000011110000010000110000000000111100110000000001100011000000000000000000000000000100001100001100001100110011011000000001100000000110000000010000011000000010100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000111111000000000000000011000000000000000000000000000000000000000000000011000000000001100000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000100010000000000000000000000000000000001100001100001100110001000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000011000000000000000011000000000000000000000000000000000000000000000011000000000001100000000000000000000000000000000000000000000000000000000000011100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010100000000000111111100000000000000001111000110111101100010000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
"000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000111110000000000000000110000000000000000000000000000000000000000000000111100000000011110000000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
   )
  "List of strings representing pixel lines for the button font.")

(defvar xbm-button-font-line-indices
  '(("A" 0 10)
    ("B" 11 19)
    ("C" 20 28)
    ("D" 29 38)
    ("E" 39 47)
    ("F" 48 56)
    ("G" 57 66)
    ("H" 67 77)
    ("I" 78 82)
    ("J" 83 90)
    ("K" 91 100)
    ("L" 101 109)
    ("M" 110 121)
    ("N" 122 132)
    ("O" 133 142)
    ("P" 143 151)
    ("Q" 152 162)
    ("R" 163 172)
    ("S" 173 180)
    ("T" 181 189)
    ("U" 190 199)
    ("V" 200 210)
    ("W" 211 224)
    ("X" 225 234)
    ("Y" 235 243)
    ("Z" 244 252)
    ("a" 253 260)
    ("b" 261 269)
    ("c" 270 276)
    ("d" 277 285)
    ("e" 286 292)
    ("f" 293 298)
    ("g" 299 306)
    ("h" 307 315)
    ("i" 316 320)
    ("j" 321 324)
    ("k" 325 333)
    ("l" 334 338)
    ("m" 339 351)
    ("n" 352 360)
    ("o" 361 368)
    ("p" 369 377)
    ("q" 378 386)
    ("r" 387 393)
    ("s" 394 399)
    ("t" 400 405)
    ("u" 406 414)
    ("v" 415 423)
    ("w" 424 436)
    ("x" 437 444)
    ("y" 445 453)
    ("z" 454 460)
    ("0" 461 467)
    ("1" 468 472)
    ("2" 473 479)
    ("3" 480 486)
    ("4" 487 493)
    ("5" 494 500)
    ("6" 501 507)
    ("7" 508 514)
    ("8" 515 521)
    ("9" 522 528)
    ("`" 529 531)
    ("~" 532 538)
    ("!" 539 541)
    ("@" 542 552)
    ("#" 553 560)
    ("$" 561 567)
    ("%" 568 580)
    ("^" 581 586)
    ("&" 587 597)
    ("*" 598 603)
    ("(" 604 608)
    (")" 609 613)
    ("-" 614 620)
    ("_" 621 628)
    ("=" 629 635)
    ("+" 636 643)
    ("[" 644 648)
    ("{" 649 653)
    ("]" 654 658)
    ("}" 659 663)
    (";" 664 666)
    (":" 667 669)
    ("'" 670 672)
    ("\"" 673 676)
    ("," 677 679)
    ("<" 680 686)
    ("." 687 689)
    (">" 690 696)
    ("/" 697 700)
    ("?" 701 707)
    ("\\" 708 713)
    ("|" 714 715)
    (" " 716 719))
  "Indices into the xbm-button-font-pixel-lines strings for each character.
Format is
  (STR START END)
STR contains the character.
START is where the character's pixels start in each string of
   xbm-button-font-pixel-lines (0 is the index of the first pixel).
END is the index of the position after the last pixel of the character.")

(defun xbm-bit-lines-to-xbm-bits (&optional beg end)
  "Convert lines of bits to a string of chars containing the bits,
plus width and height information.  A list of the form
   (WIDTH HEIGHT STRING)
is returned.  WIDTH is set to be the length of the first line,
ignoring the newline.  HEIGHT is the number of lines in the region.

BEG and END specify the region containing the bit lines.  Each
line should contain only the characters '0' or '1' and be
terminated by a newline."
  (or beg (setq beg (point-min)))
  (or end (setq end (point-max)))
  (let (octet octet-count bit-count b char width height)
    (save-excursion
      (save-excursion
	(set-buffer (setq b (get-buffer-create
			     " xbm-button-bit-lines-to-xbm")))
	(erase-buffer))
      (goto-char beg)
      (setq bit-count 0
	    height 0
	    width (- (save-excursion (end-of-line) (point)) (point))
	    octet 0)
      (while (< (point) end)
	(setq char (char-after (point)))
	(cond ((= char ?0)
	       (setq bit-count (1+ bit-count)))
	      ((= char ?1)
	       ;; least significant bit of octet is leftmost pixel.
	       (setq octet (+ octet (expt 2 bit-count))
		     bit-count (1+ bit-count)))
	      ((= char ?\n)
	       (setq height (1+ height))))
	;; output octet whenever we have retrived 8 bits or when
	;; a newline is encountered.
	(cond ((or (= bit-count 8) (= char ?\n))
	       (save-excursion
		 (set-buffer b)
		 (insert-char octet))
	       (setq bit-count 0
		     octet 0)))
	(forward-char 1))
      (set-buffer b)
      ;; otput last octet if any bits collected.
      (cond ((not (= bit-count 0))
	     (insert-char octet)))

      (list width height (buffer-substring nil nil b)) )))

;;;###autoload
(defun xbm-button-create (text border-thickness)
  "Returns a list of XBM image instantiators for a button displaying TEXT.
The list is of the form
   (UP DOWN DISABLED)
where UP, DOWN, and DISABLED are the up, down and disabled image
instantiators for the button.

BORDER-THICKNESS specifies how many pixels should be used for the
borders on the edges of the buttons.  It should be a positive integer,
or 0 to mean no border."
  (save-excursion
    (set-buffer (get-buffer-create " xbm-button-create"))
    (erase-buffer)
    ;; create the correct number of lines for the pixels for the
    ;; characters.
    (insert-char ?\n (length xbm-button-font-pixel-lines))
    (let ((i 0)
	  (str (make-string 1 0))
	  (lim (length text))
	  (bg-char ?0)
	  font-pixel-lines q)
      ;; loop through text, adding the character pixels
      (while (< i lim)
	(aset str 0 (aref text i))
	(if (null (setq q (assoc str xbm-button-font-line-indices)))
	    nil ; no pixel data for this character
	  (goto-char (point-min))
	  (setq font-pixel-lines xbm-button-font-pixel-lines)
	  (while font-pixel-lines
	    (end-of-line)
	    (if (not (bolp))
		;; Insert space before some of the characters.
		;; This isn't really correct for this font
		;; but doing it right is too hard.
		;; This isn't TeX after all.
		(if (memq (aref str 0) '(?, ?. ?\" ?! ?| ?\' ?\`))
		    (insert-char bg-char 1))
	      ;; offset the start a bit from the left edge of the button
	      (insert-char bg-char xbm-button-horizontal-padding))
	    ;; insert the character pixels.
	    (insert (substring (car font-pixel-lines) (nth 1 q) (nth 2 q)))
	    (forward-line)
	    (setq font-pixel-lines (cdr font-pixel-lines))))
	(setq i (1+ i)))
      ;; now offset the text from the right edge of the button.
      (goto-char (point-min))
      (while (not (eobp))
	(end-of-line)
	(insert-char bg-char xbm-button-horizontal-padding)
	(forward-line)))
    (let ((fg-char ?1)
	  (bg-char ?0)
	  i len up down disabled)
      ;; find the length of a pixel line.
      (goto-char (point-min))
      (end-of-line)
      (setq len (- (point) (point-min)))
      ;; offset text from the top of the button
      (goto-char (point-min))
      (setq i xbm-button-vertical-padding)
      (while (> i 0)
	(insert-char bg-char len)
	(insert ?\n)
	(setq i (1- i)))
      ;; offset text from the bottom of the button
      (goto-char (point-max))
      (setq i xbm-button-vertical-padding)
      (while (> i 0)
	(insert-char bg-char len)
	(insert ?\n)
	(setq i (1- i)))
      ;; add borders to the pixel lines
      (goto-char (point-min))
      (while (not (eobp))
	(insert-char fg-char border-thickness)
	(end-of-line)
	(insert-char fg-char border-thickness)
	(forward-line))
      ;; add top and bottom border lines
      (setq i border-thickness)
      (goto-char (point-min))
      (while (> i 0)
	(insert-char fg-char (+ len (* 2 border-thickness)))
	(insert ?\n)
	(setq i (1- i)))
      (setq i border-thickness)
      (goto-char (point-max))
      (while (> i 0)
	(insert-char fg-char (+ len (* 2 border-thickness)))
	(insert ?\n)
	(setq i (1- i)))
      ;; convert the pixel lines to octets of xbm bit data
      (setq up (xbm-bit-lines-to-xbm-bits)
	    down up)
      ;; stipple the foreground pixels for the disabled button.
      (let ((str (make-string 1 0))
	    (bit 0)
	    lim line-start)
	(aset str 0 fg-char)
	(goto-char (point-min))
	(while (not (eobp))
	  (setq lim (save-excursion (end-of-line) (point))
		line-start (point))
	  (while (search-forward str lim t)
	    (if (= (% (- (point) line-start) 2) bit)
		(subst-char-in-region (1- (point)) (point) fg-char bg-char t)))
	  (if (zerop bit)
	      (setq bit 1)
	    (setq bit 0))
	  (forward-line)))
      (setq disabled (xbm-bit-lines-to-xbm-bits))

      (list (vector 'xbm ':data up)
	    (vector 'xbm ':data down)
	    (vector 'xbm ':data disabled)) )))