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