1 line
2.8 KiB
Common Lisp
1 line
2.8 KiB
Common Lisp
;;; -*- 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))))
|
|
|
|
|
|
|
|
|