(defun arr2chars (arr)

(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 arr2chars (arr)
(let ((n 0))
(lambda ()
(prog1 (code-char (bits2no (coerce (subseq arr n (+ 8 n)) 'list)))
(incf n 8)))))

(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 (setf vector (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 (setf vec (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 arr2pbm (arr path dims)
(let* ((writer (write-bin path))
(header (format nil "P4~%~{~d~^ ~}~%" dims)))
(loop for x across header for g = (bitgen x) do
(loop repeat 8 do (funcall writer (funcall g))))
(loop for x across arr do (funcall writer x)
finally (funcall writer 'end))))

(defun chop (reader)
(loop repeat 8 do (funcall reader)))

(defun read-magic (reader)
(loop repeat (* 3 8) collect (funcall reader)))

(defun bits2no (list &key opposite-day)
(loop initially (when opposite-day (setf list (nreverse list)))
for l in list for x downfrom 7 for n = (ash l x) ; do (princ l)
sum n))

(defun read-header-line (reader &optional (maxlen 69))
(coerce
(loop for chlist = (loop repeat 8 collect (Funcall reader))
for no = (bits2no chlist) for ch = (code-char no)
for x from 0 ; do (format t "~@{~a ~}~%" chlist no ch x)
while (not (or (char= ch #\newline) (> x maxlen)))
collect ch)
'string))

(defun read-header (reader &optional print-comments)
(assert (string= "P4" (read-header-line reader)))
(loop for line = (read-header-line reader)
while (char= #\# (char line 0))
when print-comments do (print line)
finally (with-input-from-string (in line)
(return-from read-header (list (read in) (read in))))))

(defun pbm2ascii (pbm-path &key (foreground "%") (background "."))
(let* ((rdr (read-bin pbm-path))
(dims (prog1 (read-header 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 pbm2arr (pbm-path)
(let* ((rdr (read-bin pbm-path))
(dims (prog1 (read-header rdr) ))
(flat (* (second dims) (first dims)))
(arr (make-array flat :element-type '(integer 0 1) :initial-element '1)))
(loop for n below flat do (setf (aref arr n) (funcall rdr)))
(values arr dims)))

(defun help-me ()
(format t "
/bpm2ascii -i my.pbm -fgch 1 -bgch 2 -fgfg 4 -fgbg5 -bgfg 11 -bgfg 12

"))

(defun arr2ascii (arr cols &optional (stream *standard-output*))
(loop for a across arr for n from 1
for lineendp = (zerop (rem n cols))
do (progn (princ a stream) (when lineendp (terpri stream)))))

(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)))))

(Defun test-matrix (n)
(let ((arr-len (expt n 2)))
(make-array (expt n 2)
:element-type '(integer 0 1)
:initial-contents
(loop for row below n nconcing
(loop for col below n
collecting (if (< col (/ n 2)) 1 0))))))