data-b.png

data-rgba.png

png-to-bytes.lisp

(ql:quickload :pngload)

(defpackage "DECODE-PNG"
  (:use "CL" "PNGLOAD")
  (:export "PNG-TO-BYTES"
           "SAVE-BYTES"))
(in-package "DECODE-PNG")

(defmacro with-functions ((&rest fnames) &body body)
  `(flet ,(mapcar (lambda (fname)
                    (if (listp fname)
                        (destructuring-bind (name &rest parameters) fname
                          `(,name ,parameters (funcall ,name ,@parameters)))
                        `(,fname (&rest arguments) (apply ,fname arguments))))
           fnames)
     (declare (inline ,@(mapcar (lambda (fname) (if (listp fname) (first fname) fname)) fnames)))
     ,@body))

(defun subrect (pref pixmap x y width height subsample bit-transform)
  (with-functions (pref bit-transform)
    (let* ((sh      (truncate height subsample))
           (sw      (truncate width  subsample))
           (subrect (make-array (list sh sw) :element-type 'bit)))
      (loop :for j :below sh
            :do (loop :for i :below sw
                      :do (setf (aref subrect j i)
                                (bit-transform
                                 (pref pixmap
                                       (+ y (* j subsample))
                                       (+ x (* i subsample)))))))
      subrect)))

(defun decode-bytes (bitmap)
  (loop
    :with s := (make-array (/ (reduce (function *) (array-dimensions bitmap)) 8)
                           :element-type '(unsigned-byte 8))
    :with r := -1
    :for j :below (array-dimension bitmap 0)
    :do (loop :for i :below (array-dimension bitmap 1) :by 8
              :do (loop :for k :below 8
                        :for b := (aref bitmap j i)
                          :then (logior (ash b 1) (aref bitmap j (+ i k)))
                        :finally (setf (aref s (incf r)) b)))
    :finally (return s)))

(defun 1-pref (pixmap x y) (aref pixmap x y))
(defun 3-pref (pixmap x y) (map-into (make-array (array-dimension pixmap 2) :element-type '(unsigned-byte 8))
                                     (let ((z -1))
                                       (lambda ()
                                         (aref pixmap x y (incf z))))))

(defun png-to-bytes (pathname)
  (let ((png (load-file pathname))
        (offset 2)
        (bit-size 4))
    (print (list :bit-depth (bit-depth png)
                 :color-type (color-type png)
                 :pixel-size (pixel-size png)
                 :transparency (transparency png)))
    (let* ((data (data png))
           (h (array-dimension data 0))
           (w (array-dimension data 1)))
      (multiple-value-bind (ref pixel-bit) (ecase (color-type png)
                                             (:greyscale
                                              (ecase (bit-depth png)
                                                (1 (values (function 1-pref)
                                                           (lambda (pixel) (- 1 pixel))))
                                                (8 (values (function 1-pref)
                                                           (lambda (pixel)
                                                             (if (< 127 pixel)
                                                                 0
                                                                 1))))))
                                             (:truecolour-alpha
                                              (ecase (bit-depth png)
                                                (8 (values (function 3-pref)
                                                           (lambda (pixel)
                                                             (if (< 127 (/ (+ (aref pixel 0)
                                                                              (aref pixel 1)
                                                                              (aref pixel 2))
                                                                           3))
                                                                 0
                                                                 1)))))))
        (decode-bytes (subrect ref data offset offset (- w (* 2 offset)) (- h (* 2 offset)) bit-size pixel-bit))))))

(defun save-bytes (bytes pathname)
  (with-open-file (out pathname :direction :output :if-does-not-exist :create :if-exists :supersede :element-type '(unsigned-byte 8))
    (write-sequence bytes out)))

#-(and)
(progn
  (setf *default-pathname-defaults* #P"~/src/public/gists/png-to-bytes/")
  (decode-png:save-bytes (decode-png:png-to-bytes #P"data-b.png")    #P"data-b.bin")
  (decode-png:save-bytes (decode-png:png-to-bytes #P"data-rgba.png") #P"data-rgba.bin"))