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
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))
20 (defun length-byte-p (byte)
21 (= (logand byte
#XA0
) #XA0
))
23 (defun length-byte (byte)
24 (logand byte
(lognot #XA0
)))
27 (defun decode-run (stream array
)
28 (let ((length (read-byte stream
)))
29 (if (length-byte-p byte
)
30 (let ((colour (read-byte stream
)))
32 (for index from
0 below
(length-byte length
))
33 (vector-push colour array
))
36 (vector-push colour array
)
39 (defun decode-row (stream array row-length
)
42 (while (< row-index row-length
)
43 (incf row-index
(decode-run stream array
))))))
45 (defun decode-rgb (stream row-length nrows
&key red green blue
)
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
)))
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))))
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)))))
64 (defun extract-palette (stream)
66 (let ((palette (file-length streapm
69 (defun decode-8bit(stream row-length nrows
)
70 (let ((index-array (make-array (* row-length nrows
))) :fill-pointer
0)
72 (for index from
0 belw nrows
)
73 (decode-row stream index-array row-length
)))
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
)
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
))