From 65bbe7bb8d42cc4ea4f729813d17063bdddc9250 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Tue, 24 Dec 1991 13:17:55 +0000
Subject: [PATCH] Initial revision

---
 tk-silica/image.lisp | 99 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)
 create mode 100644 tk-silica/image.lisp

diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp
new file mode 100644
index 00000000..0835c2d4
--- /dev/null
+++ b/tk-silica/image.lisp
@@ -0,0 +1,99 @@
+(in-package :xm-silica)
+
+
+(defun correct-case (x) x)
+(defun kintern (x) (intern x :keyword))
+(defun make-pattern-from-file (file designs)
+  (multiple-value-bind
+      (array width height depth)
+      (read-bitmap-file file)
+    (make-pattern array designs)))
+
+(defun read-bitmap-file (pathname)
+  ;; Creates an image from a C include file in standard X11 format
+  (declare (type (or pathname string stream) pathname))
+  (declare (values image))
+  (with-open-file (fstream pathname :direction :input)
+    (let ((line "")
+	  (properties nil)
+	  (name nil)
+	  (name-end nil))
+      (declare (type string line)
+	       (type stringable name)
+	       (type list properties))
+      ;; Get properties
+      
+      (loop
+	(setq line (read-line fstream))
+	(when  (> (length line) 0)
+	  (unless (char= (aref line 0) #\#)
+	    (return))
+	  (flet ((read-keyword (line start end)
+		   (kintern
+		    (substitute
+		     #\- #\_
+		     (#-excl string-upcase
+			     #+excl correct-case
+			     (subseq line start end))
+		     :test #'char=))))
+	    (when (null name)
+	      (setq name-end (position #\_ line :test #'char= :from-end t)
+		    name (read-keyword line 8 name-end))
+	      (unless (eq name :image)
+		(setf (getf properties :name) name)))
+	    (let* ((ind-start (1+ name-end))
+		   (ind-end (position #\Space line :test #'char=
+				      :start ind-start))
+		   (ind (read-keyword line ind-start ind-end))
+		   (val-start (1+ ind-end))
+		   (val (parse-integer line :start val-start)))
+	      (setf (getf properties ind) val)))))
+      
+      (multiple-value-bind (width height depth left-pad)
+	  (flet ((extract-property (ind &rest default)
+		   (prog1 (apply #'getf properties ind default)
+		     (remf properties ind))))
+	    (values (extract-property :width)
+		    (extract-property :height)
+		    (extract-property :depth 1)
+		    (extract-property :left-pad 0)))
+	(unless (and width height) (error "Not a BITMAP file"))
+	(let* ((bits-per-pixel
+		(cond ((> depth 24) 32)
+		      ((> depth 16) 24)
+		      ((> depth 8)  16)
+		      ((> depth 4)   8)
+		      ((> depth 2)   4)
+		      ((> depth 1)   2)
+		      (t 1)))
+	       (data (make-array (list height width)))
+	       (w 0)
+	       (h 0))
+	  (labels ((read-a-byte ()
+		     (peek-char #\x fstream)
+		     (read-char fstream)
+		     (+ (* 16 (digit-char-p (read-char fstream) 16))
+			(digit-char-p (read-char fstream) 16)))
+		   (store-byte (x)
+		     (setf (aref data h w) x)
+		     (incf w)
+		     (when (= w width)
+		       (setq w 0)
+		       (incf h))
+		     (when (= h height)
+		       (return-from read-bitmap-file
+			 (values data
+				 width 
+				 height
+				 depth)))))
+	    (loop
+	      (let ((x 0))
+		(dotimes (i (ceiling bits-per-pixel 8))
+		  (setf x (ash x 8))
+		  (incf x (read-a-byte)))
+		(if (>= bits-per-pixel 8)
+		    (store-byte x)
+		  (dotimes (j (/ 8 bits-per-pixel))
+		    (store-byte
+		     (ldb (byte bits-per-pixel (* j bits-per-pixel))
+			  x))))))))))))
-- 
GitLab