;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*-
;;;
;;; Copyright (c) 1988, 1989 by Xerox Corporation.  All rights reserved.
;;;

(in-package 'xcl-user)

(defun xerox-to-xbm(path bitmap &optional name)
  (let* ((base (il:|fetch| il:bitmapbase il:|of| bitmap))
	 (height (il:|fetch| il:bitmapheight il:|of| bitmap))
	 (width (il:|fetch| il:bitmapwidth il:|of| bitmap))
	 (depth 1)
	 (w (il:|fetch| il:bitmaprasterwidth il:|of| bitmap))
	 (il-line-size (ceiling (* width depth) 8))
	 (line-width (* 4 (ceiling (* width depth) 32)))
	 (line-waste (- line-width il-line-size))
	 (data (make-array (* height line-width) 
			   :element-type '(unsigned-byte 8)
			   :initial-element 0))
	 (i -1)
	 (byte-width (ceiling (* width depth) 8))
	 (line 0)
	 (byte-number 0)
	 (count 0))

    (unless name (setq name (pathname-name path)))
    (when (and (probe-file path)
	       (y-or-n-p "Delete the old version of bitmap?"))
      (delete-file path))

    (dotimes (j height)
      (dotimes (k (floor il-line-size 2))
	(setf (aref data (incf i)) (il:\\getbasebyte base 0))
	(setf (aref data (incf i)) (il:\\getbasebyte base 1))
	(setq base (il:\\addbase base 1))) 
      (dotimes (k (second (multiple-value-list (floor il-line-size 2))))
	(setf (aref data (incf i)) (il:\\getbasebyte base 0))
	(setq base (il:\\addbase base 1)))
      (incf i line-waste))
    
    ;; The following code is a modified version of code chunk from the CLX file
    ;; image.lisp.  The significant difference is that I had to reverse the bit
    ;; order of each byte of data by reflecting the nibbles, then reversing
    ;; them. 
    
    ;; Writes an image to a C include file in standard X11 format
    ;; NAME argument used for variable prefixes.  Defaults to "image"
    (setq name (string-downcase (string name)))
    (with-open-file (fstream path :direction :output)
      (format fstream "#define ~a_width ~d~%" name width)
      (format fstream "#define ~a_height ~d~%" name height)
      (unless (= depth 1)
	(format fstream "#define ~a_depth ~d~%" name depth))
      (format fstream "static char ~a_bits[] = {" name)
      (dotimes (i height)
	(dotimes (j byte-width)
	  (when (zerop (mod count 12)) (format fstream "~%  "))
	  (write-string " 0x" fstream)
	  ;; Faster than (format fstream "0x~2,'0x," byte)
	  (let ((byte (aref data (+ line byte-number)))
		;; Reflect nibbles.
		(translate "084c2a6e195d3b7f")) ;"0123456789abcdef"
	    ;; Reverse nibbles.
	    (write-char (aref translate (ldb (byte 4 0) byte)) fstream)
	    (write-char (aref translate (ldb (byte 4 4) byte)) fstream)
	    (incf byte-number)
	    (incf count)
	    (unless (and (= (1+ i) height)
			 (= (1+ j) byte-width))
	      (write-char #\, fstream))))
	(setq byte-number 0
	      line (+ line line-width)))
      (format fstream "};~%" fstream))))