(defun get-bit (s)
  (let ((c (read-char s)))
    (if (or (char= c #\Newline)
            (char= c #\Return))
        (get-bit s)
        (- (char-code c) (char-code #\0)))))

(defun visual-crypto (pic1 pic2 secret outfile1 outfile2)
  "PIC1, PIC2, SECRET, OUTFILE1 and OUTFILE2 are paths to PBM files."
  (with-open-file (sp1 pic1)
    (with-open-file (sp2 pic2)
      (with-open-file (ss secret)
        (with-open-file (out1 outfile1 :direction :output :if-exists :supersede)
          (with-open-file (out2 outfile2 :direction :output :if-exists :supersede)
            (assert (eq (read sp1) 'P1))
            (assert (eq (read sp2) 'P1))
            (assert (eq (read ss) 'P1))
            (format out1 "P1~%")
            (format out2 "P1~%")
            (let* ((width (read sp1))
                   (height (read sp1)))
              (assert (= (read sp2) width))
              (assert (= (read sp2) height))
              (assert (= (read ss) width))
              (assert (= (read ss) height))
              (format out1 "~d ~d~%" (* 2 width) (* 2 height))
              (format out2 "~d ~d~%" (* 2 width) (* 2 height))
              (iter (for j from 0 below height)
                    (for top1 = ())
                    (for bottom1 = ())
                    (for top2 = ())
                    (for bottom2 = ())
                    (iter (for i from 0 below width)
                          (for pix1 = (get-bit sp1))
                          (for pix2 = (get-bit sp2))
                          (for pixs = (get-bit ss))
                          (for r = (if (zerop (random 2)) '(1 0) '(0 1)))
                          (push 1 top1) (push pix2 top2)
                          (push pix1 top1) (push 1 top2)
                          (push (first r) bottom1) (push (second r) bottom1)
                          (cond ((= pixs 0)
                                 (push (first r) bottom2) (push (second r) bottom2))
                                (t
                                 (push (second r) bottom2) (push (first r) bottom2)))) 
                    (format out1 "~{~d~}~%~{~d~}~%" (nreverse top1) (nreverse bottom1))
                    (format out2 "~{~d~}~%~{~d~}~%" (nreverse top2) (nreverse bottom2))))))))))


;;; steganography

(define-constant +base64+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

(defun add-char-to-rgb (rgb c)
  (let ((n (position c +base64+)))
    (list (logior (logand (first rgb) #b11111100) (logand (ash n -4) #b11))
          (logior (logand (second rgb) #b11111100) (logand (ash n -2) #b11))
          (logior (logand (third rgb) #b11111100) (logand n #b11)))))

(defun char-from-rgb (rgb)
  (elt +base64+
       (+ (ash (logand (first rgb) #b11) 4)
          (ash (logand (second rgb) #b11) 2)
          (logand (third rgb) #b11))))

(defun hide-base64-message-in-ppm (ppm-file b64-msg outfile)
  (with-open-file (in ppm-file)
    (with-open-file (out outfile :direction :output :if-exists :supersede)
      (assert (eq (read in) 'P3))
      (format out "P3~%")
      (let* ((width (read in))
             (height (read in)))
        (assert (= (read in) 255))
        (format out "~d ~d~%255~%" width height)
        (iter (for i from 0 below (* width height))
              (for r = (read in))
              (for g = (read in))
              (for b = (read in))
              (for secret first b64-msg then (rest secret))
              (for rgb =
                   (if secret
                       (add-char-to-rgb (list r g b) (first secret))
                       (list r g b)))
              (format out "~{~d~^ ~}~%" rgb))))))

(defun decode-base64-message-from-ppm (ppm-file outfile)
  (with-open-file (in ppm-file)
    (with-open-file (out outfile :direction :output :if-exists :supersede)
      (assert (eq (read in) 'P3))
      (let* ((width (read in))
             (height (read in)))
        (assert (= (read in) 255))
        (iter (for i from 1 below (* width height))
              (for r = (read in))
              (for g = (read in))
              (for b = (read in))
              (format out "~a" (char-from-rgb (list r g b)))
              (when (zerop (mod i 76))
                (terpri out)))))))