pcx.lisp

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