2 (in-package :lodematron
)
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
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))))
23 (defun length-byte-p (byte)
24 (= (logand byte
#XA0
) #XA0
))
26 (defun length-byte (byte)
27 (logand byte
(lognot #XA0
)))
30 (defun decode-run (stream array
)
31 (let ((length (read-byte stream
)))
32 (if (length-byte-p length
)
33 (let ((colour (read-byte stream
)))
35 (for index from
0 below
(length-byte length
))
36 (vector-push colour array
))
39 (vector-push length array
)
42 (defun decode-row (stream array row-length
)
45 (while (< row-index row-length
))
46 (incf row-index
(decode-run stream array
)))))
48 (defun decode-rgb (stream row-length nrows
&key red green blue
)
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
)))
56 (defun merge-arrays (&key red green blue
)
57 (assert (= (length red
) (length green
) (length blue
)))
58 (let ((result (make-colour-array (length red
) :fill-pointer
0)))
61 (for g in-vector green
)
62 (for b in-vector blue
)
63 (colour-vector-push (colour* (/ r
255.0) (/ g
255.0) (/ b
255.0) 1.0) result
))
66 (defun extract-palette (stream)
67 (let ((palette-pos (- (file-length stream
) 768)))
68 (file-position stream palette-pos
)
69 ;; (format t "Reading palette from ~X~%" (file-position stream))
70 ;; (assert (= (read-byte stream) 192))
71 (read-value :u8 stream
:array-size
768)))
73 (defun decode-8bit (stream row-length nrows
)
74 (let ((index-array (make-array (* row-length nrows
) :fill-pointer
0)))
76 (for index from
0 below nrows
)
77 (decode-row stream index-array row-length
))
80 (defun merge-array-and-palette (array palette
)
81 (let ((result (make-colour-array (length array
) :fill-pointer
0)))
83 (for palette-index in-vector array
)
84 (colour-vector-push (colour* (/ (aref palette
(* 3 palette-index
)) 255.0)
85 (/ (aref palette
(1+ (* 3 palette-index
))) 255.0)
86 (/ (aref palette
(+ 2 (* 3 palette-index
))) 255.0)
92 (defun parse-pcx-file (filename)
93 (with-open-file (stream (merge-pathnames filename
) :direction
:input
:element-type
'(unsigned-byte 8))
94 (let* ((header (read-value :pcx-header stream
))
95 (xmax (xmax-of header
))
96 (ymax (ymax-of header
))
97 (xmin (xmin-of header
))
98 (ymin (ymin-of header
))
99 (red-array (make-array (list (* (- xmax xmin
) (- ymax ymin
))) :element-type
'(unsigned-byte 32) :fill-pointer
0))
100 (blue-array (make-array (list (* (- xmax xmin
) (- ymax ymin
))) :element-type
'(unsigned-byte 32) :fill-pointer
0))
101 (green-array (make-array (list (* (- xmax xmin
) (- ymax ymin
))) :element-type
'(unsigned-byte 32) :fill-pointer
0)))
102 (format t
"Encoding ~A Colour planes ~A Bytes Per Line ~A width ~A height ~A ~%" (encoding-of header
) (colour-planes-of header
) (bytes-per-line-of header
) (- (xmax-of header
) (xmin-of header
)) (- ymax ymin
))
103 (case (bits-per-pixel-of header
)
104 (1 (warn "Unsupported PCX Format"))
105 (4 (warn "Unsupported PCX Format"))
106 (8 (merge-array-and-palette (decode-8bit stream
(- xmax xmin
) (- ymax ymin
)) (extract-palette stream
)))
107 (24 (decode-rgb stream
(/ (bytes-per-line-of header
) (colour-planes-of header
)) (- ymax ymin
)
108 :red red-array
:green green-array
:blue blue-array
)
109 (merge-arrays :red red-array
:green green-array
:blue blue-array
))))))