file-pcx.lisp

   1
   2 (in-package :lodematron)
   3
   4 (define-binary-class pcx-header
   5     ((manufacturer  :u8) ;  resb    1       ; should always be 0ah
   6      (version       :u8) ; resb    1       ; (1)
   7      (encoding      :u8) ;  resb    1       ; should always be 01h
   8      (bits-per-pixel   :u8) ; resb    1       ; (2)
   9      (xmin           :u16) ; resw    1       ; image width = xmax-xmin
  10      (ymin           :u16) ; resw    1       ; image height = ymax-ymin
  11      (xmax           :i16) ; resw    1
  12      (ymax           :u16) ; resw    1
  13      (vertdpi        :u16) ; resw    1       ; (3)
  14      (palette        :u8 :array-size 48) ; resb    48      ; (4)
  15      (reserved       :u8) ; resb    1
  16      (colour-planes    :u8) ; resb    1       ; (5)
  17      (bytes-per-line   :u16) ; resw    1       ; (6)
  18      (palette-type    :u16) ;resw    1
  19      (hscrsize       :u16) ; resw    1       ; only supported by
  20      (vscrsize       :u16) ;   1       ; pc paintbrush iv or higher
  21      (filler         :u8 :array-size 56))))
  22
  23 (defun length-byte-p (byte)
  24     (= (logand byte #XA0) #XA0))
  25
  26 (defun length-byte (byte)
  27     (logand byte (lognot #XA0)))
  28
  29
  30 (defun decode-run (stream array)
  31   (let ((length (read-byte stream)))
  32     (if (length-byte-p length)
  33         (let ((colour (read-byte stream)))
  34           (iterate
  35            (for index from 0 below (length-byte length))
  36            (vector-push colour array))
  37           (length-byte length))
  38         (progn
  39           (vector-push length array)
  40           length))))
  41
  42 (defun decode-row (stream array row-length)
  43   (let ((row-index 0))
  44     (iterate
  45      (while (< row-index row-length))
  46      (incf row-index (decode-run stream array)))))
  47
  48 (defun decode-rgb (stream row-length nrows &key red green blue)
  49   (iterate
  50    (for index from 0 below nrows)
  51    (decode-row stream red row-length)
  52    (decode-row stream green row-length)
  53    (decode-row stream blue row-length)))
  54
  55
  56 (defun merge-arrays (&key red green blue)
  57   (assert (= (length red) (length green) (length blue)))
  58   (let ((result (make-array (length red) :element-type '(unsigned-byte 32) :fill-pointer 0)))
  59     (iterate
  60      (for r in-vector red)
  61      (for g in-vector green)
  62      (for b in-vector blue)
  63      (vector-push (logior (ash r 24) (ash g 16) (ash b 8)) result))
  64   result))
  65
  66 (defun extract-palette (stream)
  67    (let ((palette-pos (- 768 (file-length stream))))
  68      (file-position stream (1- palette-pos))
  69      (assert (= (read-byte stream) 192))
  70      (read-value :u8 stream :array-size 768)))
  71
  72 (defun decode-8bit (stream row-length nrows)
  73   (let ((index-array (make-array (* row-length nrows) :fill-pointer 0)))
  74     (iterate
  75      (for index from 0 below nrows)
  76      (decode-row stream index-array row-length))))
  77
  78 (defun merge-array-and-palette (array palette)
  79   (let ((result (make-array (length array)) :element-type '(unsigned-byte 32) :fill-pointer 0))
  80     (iterate
  81       (for palette-index in array)
  82       (vector-push (logior (ash (aref palette (* 3 palette-index)) 24)
  83
  84
  85 (defun parse-pcx-file (stream)
  86   (let* ((header (read-value :pcx-header stream))
  87          (xmax (xmax-of header))
  88          (ymax (ymax-of header))
  89          (xmin (xmin-of header))
  90          (ymin (ymin-of header))
  91          (red-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type '(unsigned-byte 32) :fill-pointer 0))
  92          (blue-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type '(unsigned-byte 32) :fill-pointer 0))
  93          (green-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type '(unsigned-byte 32) :fill-pointer 0)))
  94     (case (bits-per-pixel-of header)
  95       ;; be sersi
  96       (1 (warn "Unsupported PCX Format"))
  97       (4 (warn "Unsupported PCX Format"))
  98       (8 (warn "Unsupported PCX Format"))
  99       (24 (decode-rgb stream (/ (bytes-per-line-of header)  (colour-planes-of header)) (- ymax ymin)
 100                       :red red-array :green green-array :blue blue-array)
 101           (merge-arrays :red red-array :green green-array :blue blue-array)))))
 102
 103