(in-package "bit-d-generate")
(defvar *cmd-input-file*)
(defvar *cmd-foreground-char* #\0)
(defvar *cmd-background-char* #\1)
(defvar *cmd-fgfg-color* "")
(defvar *cmd-fgbg-color* "")
(defvar *cmd-bgfg-color* "")
(defvar *cmd-bgbg-color* "")
(defvar *cmd-unset-color* "")
(defun ansi-escape (stream arg colonp atsignp)
(declare (ignore atsignp))
(format stream "~a[~:[38~;48~];5;~dm" #\escape colonp arg))
(defconstant +bdg-rules+
'(("-i" 1 (setq *cmd-input-file* 1))
("-fgch" 1 (setq *cmd-foreground-char* (char 1 0)))
("-bgch" 1 (setq *cmd-background-char* (char 1 0)))
("-fgfg" 1 (setq *cmd-fgfg-color* (format nil "~/bdg::ansi-escape/"
(parse-integer 1))))
("-fgbg" 1 (setq *cmd-fgbg-color* (format nil "~:/bdg::ansi-escape/"
(parse-integer 1))))
("-bgfg" 1 (setq *cmd-bgfg-color* (format nil "~/bdg::ansi-escape/"
(parse-integer 1))))
("-bgbg" 1 (setq *cmd-bgbg-color* (format nil "~:/bdg::ansi-escape/"
(parse-integer 1))))))
#|
Jammed the pbm file format. Reading is slow.
Header lines (including space/newline) is all ascii
P4
16 2
11001100100011101100110010001110
The 1s and 0s are bits.
Junk at the end to make it a multiple of 8.
It's like this:
#!/bin/sh
rm -f my.pbm out.png
ecl <<EOG
(require "bit-d-generate")
(bdg::smoke)
(bdg::test-p4-pbm)
EOG
# imagemagick & feh
convert my.pbm -scale 300x out.png && feh out.png
# or netpbm - seems unreliable though
pbmtoascii my.pbm
|#
(eval-when (:compile-toplevel)
(defmacro manually-open
((var path &rest open-args) (&rest other-lets) &body body)
`(let* ((,var (apply 'open ,path ',open-args)) ,@other-lets)
(lambda (,@(when (member :output open-args) '(x)))
,@body))))
(defun write-bin (path) (manually-open
(file path :direction :output :element-type (unsigned-byte 8)
:if-does-not-exist :create :if-exists :append)
((vector (make-array 8 :fill-pointer 0 :element-type '(integer 0 1))))
(case x (end (unwind-protect (when file (close file))
(when file (close file :abort t)))) (t (vector-push x vector)))
(when (equal 8 (fill-pointer vector))
(write-byte (loop for v across vector for s from 0 below 8
summing (ash v s)
finally (setf (fill-pointer vector) '0)) file))))
(defun read-bin (path)
(manually-open (file path :direction :input :element-type (unsigned-byte 8))
((vector (make-array 8 :fill-pointer 0
:element-type '(integer 0 1)))
(in))
(handler-case (when (zerop (fill-pointer vector))
(loop initially (setf in (read-byte file))
for n below 8 for a = (logand 1 (ash in (- n 7)))
do (vector-push a vector)
finally (nreverse vector)))
(end-of-file (e) (close file :abort t)))
(vector-pop vector)))
(defun make-bitter (&optional (vector nil)) "should use a byte-spec instead"
(let ((vector (or vector
(make-array 8 :element-type '(integer 0 1) :fill-pointer 0))))
(lambda (byte)
(loop for n below 8 for a = (logand 1 (ash byte (- n 7)))
do (vector-push a vector)
finally (return (lambda () (unless (zerop (fill-pointer vector))
(vector-pop vector))))))))
(defun bitgen (byt &key opposite-day
&aux (byt (if (characterp byt) (char-code byt) byt))) "
(let ((g (bitgen 3 :opposite-day t)))
(loop repeat 8 do (princ (funcall g))))
00000011
:opposite-day t bitreverses the output."
(let* ((vec (make-array 8 :element-type '(integer 0 1) :fill-pointer 0))
(btr (make-bitter vec))
(Plmb (funcall btr byt)))
(when opposite-day (nreverse vec))
(values plmb)))
(defun smoke (&aux (path #p"test.bin"))
(let ((writ (write-bin path))
(bytes '(#b11110000 #b10101010)))
(unwind-protect
(loop initially (format t "Input ~{~2r~}~%Output " bytes)
for byte in bytes
for g = (bitgen byte)
do (loop repeat 8 for b = (funcall g)
do (funcall writ b)))
(when writ (funcall writ 'end))))
(let ((read (read-bin path)))
(loop repeat 16 do (princ (funcall read)))))
(defun test-p4-pbm () "
Check that it works for a hardcoded 1x16 vector 8x2 geom.
"
(let* ((path #p"my.pbm") (writer (write-bin path))
(pattern '( #b11100001 #b10100001))
(header #(#\P #\4 #\newline #\8 #\space #\2 #\newline)))
(unwind-protect
(loop for x across header for g = (bitgen x) do
(loop repeat 8 do (funcall writer (funcall g)))
finally
(loop for p in pattern for g = (bitgen p) do
(loop for b = (funcall g) while b do (funcall writer b))))
(funcall writer 'end))))
(defun chop (reader)
(loop repeat 8 do (funcall reader)))
(defun read-dims (reader)
(let ((string "") (newline~2r (format nil "#b~2,8,'0r" (char-code #\newline)))
(sharp~2r (format nil "#b~2,8,'0r" (char-code #\#))))
(loop for z from 0 for byte-bits = (loop repeat 8 collecting (funcall reader))
for byte-str = (format nil "#b~{~a~}" byte-bits)
while (not (string= newline~2r byte-str))
do (if (string= sharp~2r byte-str)
(loop for comment-bits = (loop repeat 8 collecting (funcall reader))
for comment-binstr = (format nil "#b~{~a~}" comment-bits)
while (not (string= newline~2r comment-binstr)))
(setf string (concatenate 'string string
(format nil "~a"
(code-char (with-input-from-string (*standard-input* byte-str)
(read)))))))
finally (return (with-input-from-string (*standard-input* string)
(list (read) (read)))))))
(defun pbm2ascii (pbm-path &key (foreground "1") (background "2"))
(let* ((rdr (read-bin pbm-path))
(magic-number (loop repeat (* 2 8) collect (funcall rdr) finally (chop rdr)))
(dims (prog1 (read-dims rdr) ))
(flat (* (second dims) (first dims)))
(arr (make-array flat :element-type '(integer 0 1) :initial-element '1)))
(loop for n below flat sum (if (not (ignore-errors (setf (aref arr n) (funcall rdr)))) 1 0))
(loop for a across arr for n from 1
for eol = (and (not nil) (zerop (mod n (first dims))))
do (mapc 'princ (case a (0 (list *cmd-fgfg-color* *cmd-fgbg-color*))
(1 (list *cmd-bgfg-color* *cmd-bgbg-color*))))
do (princ (case a (1 background) (0 foreground)))
do (princ *cmd-unset-color*)
do (when eol (terpri)))))
(defun help-me ()
(format t "
./bpm2ascii -i my.pbm -fgch 1 -bgch 2
"))
(defun cmd-line ()
(let ((ext:*lisp-init-file-list* nil))
(handler-case
(progn (ext:process-command-args :rules +bdg-rules+)
(unless (notany (complement (lambda (x) (string= "" x)))
(list *cmd-fgfg-color* *cmd-fgbg-color*
*cmd-bgfg-color* *cmd-bgbg-color*))
(setf *cmd-unset-color* (format nil "~a[0m" #\escape)))
(pbm2ascii *cmd-input-file* :foreground *cmd-foreground-char* :background *cmd-background-char*))
(error (e) (help-me) (ext:quit 1)))))