More md2 improvements
[lodematron.git] / pcx.lisp
blob5e05c2b79d47fb49fe84c54d23d2d7bb68e393cd
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))
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)))
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))))
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))))))
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)))
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)
64 (defun extract-palette (stream)
65 (file-position 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)
71 (iterate
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)
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))