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-array (length red
) :element-type
'(unsigned-byte 32) :fill-pointer
0)))
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
))
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)))
72 (defun decode-8bit (stream row-length nrows
)
73 (let ((index-array (make-array (* row-length nrows
) :fill-pointer
0)))
75 (for index from
0 below nrows
)
76 (decode-row stream index-array row-length
))))
78 (defun merge-array-and-palette (array palette
)
79 (let ((result (make-array (length array
)) :element-type
'(unsigned-byte 32) :fill-pointer
0))
81 (for palette-index in array
)
82 (vector-push (logior (ash (aref palette
(* 3 palette-index
)) 24)
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
)
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
)))))