From 95c53e1b0fd17cbab9b7b77d8e63373873701511 Mon Sep 17 00:00:00 2001 From: John Connors Date: Sun, 24 Aug 2008 07:59:17 +0100 Subject: [PATCH] Adding PCX file reader --- file-pcx.lisp | 103 +++++++++++++++++++++++++++++++++++++++++++++++++++ lodematron-test.lisp | 8 ++++ lodematron.asd | 3 +- pcx.lisp | 91 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 204 insertions(+), 1 deletion(-) create mode 100644 file-pcx.lisp create mode 100644 pcx.lisp diff --git a/file-pcx.lisp b/file-pcx.lisp new file mode 100644 index 0000000..2cd4981 --- /dev/null +++ b/file-pcx.lisp @@ -0,0 +1,103 @@ + +(in-package :lodematron) + +(define-binary-class pcx-header + ((manufacturer :u8) ; resb 1 ; should always be 0ah + (version :u8) ; resb 1 ; (1) + (encoding :u8) ; resb 1 ; should always be 01h + (bits-per-pixel :u8) ; resb 1 ; (2) + (xmin :u16) ; resw 1 ; image width = xmax-xmin + (ymin :u16) ; resw 1 ; image height = ymax-ymin + (xmax :i16) ; resw 1 + (ymax :u16) ; resw 1 + (vertdpi :u16) ; resw 1 ; (3) + (palette :u8 :array-size 48) ; resb 48 ; (4) + (reserved :u8) ; resb 1 + (colour-planes :u8) ; resb 1 ; (5) + (bytes-per-line :u16) ; resw 1 ; (6) + (palette-type :u16) ;resw 1 + (hscrsize :u16) ; resw 1 ; only supported by + (vscrsize :u16) ; 1 ; pc paintbrush iv or higher + (filler :u8 :array-size 56)))) + +(defun length-byte-p (byte) + (= (logand byte #XA0) #XA0)) + +(defun length-byte (byte) + (logand byte (lognot #XA0))) + + +(defun decode-run (stream array) + (let ((length (read-byte stream))) + (if (length-byte-p length) + (let ((colour (read-byte stream))) + (iterate + (for index from 0 below (length-byte length)) + (vector-push colour array)) + (length-byte length)) + (progn + (vector-push length array) + length)))) + +(defun decode-row (stream array row-length) + (let ((row-index 0)) + (iterate + (while (< row-index row-length)) + (incf row-index (decode-run stream array))))) + +(defun decode-rgb (stream row-length nrows &key red green blue) + (iterate + (for index from 0 below nrows) + (decode-row stream red row-length) + (decode-row stream green row-length) + (decode-row stream blue row-length))) + + +(defun merge-arrays (&key red green blue) + (assert (= (length red) (length green) (length blue))) + (let ((result (make-array (length red) :element-type '(unsigned-byte 32) :fill-pointer 0))) + (iterate + (for r in-vector red) + (for g in-vector green) + (for b in-vector blue) + (vector-push (logior (ash r 24) (ash g 16) (ash b 8)) result)) + result)) + +(defun extract-palette (stream) + (let ((palette-pos (- 768 (file-length stream)))) + (file-position stream (1- palette-pos)) + (assert (= (read-byte stream) 192)) + (read-value :u8 stream :array-size 768))) + +(defun decode-8bit (stream row-length nrows) + (let ((index-array (make-array (* row-length nrows) :fill-pointer 0))) + (iterate + (for index from 0 below nrows) + (decode-row stream index-array row-length)))) + +(defun merge-array-and-palette (array palette) + (let ((result (make-array (length array)) :element-type '(unsigned-byte 32) :fill-pointer 0)) + (iterate + (for palette-index in array) + (vector-push (logior (ash (aref palette (* 3 palette-index)) 24) + + +(defun parse-pcx-file (stream) + (let* ((header (read-value :pcx-header stream)) + (xmax (xmax-of header)) + (ymax (ymax-of header)) + (xmin (xmin-of header)) + (ymin (ymin-of header)) + (red-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type '(unsigned-byte 32) :fill-pointer 0)) + (blue-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type '(unsigned-byte 32) :fill-pointer 0)) + (green-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type '(unsigned-byte 32) :fill-pointer 0))) + (case (bits-per-pixel-of header) + ;; be sersi + (1 (warn "Unsupported PCX Format")) + (4 (warn "Unsupported PCX Format")) + (8 (warn "Unsupported PCX Format")) + (24 (decode-rgb stream (/ (bytes-per-line-of header) (colour-planes-of header)) (- ymax ymin) + :red red-array :green green-array :blue blue-array) + (merge-arrays :red red-array :green green-array :blue blue-array))))) + + \ No newline at end of file diff --git a/lodematron-test.lisp b/lodematron-test.lisp index e141c64..c076b11 100644 --- a/lodematron-test.lisp +++ b/lodematron-test.lisp @@ -39,3 +39,11 @@ (close *md2-file*) + +(defparameter *pcx-file* (open (merge-pathnames #P"dalekx/brit.pcx") + :direction :input + :element-type '(unsigned-byte 8))) + +(parse-pcx-file *pcx-file*) + +(close *pcx-file*) \ No newline at end of file diff --git a/lodematron.asd b/lodematron.asd index 9529fc2..f530a4f 100644 --- a/lodematron.asd +++ b/lodematron.asd @@ -14,6 +14,7 @@ (:file "file-3ds") (:file "file-md2") (:file "file-ifs") - (:file "file-lwo"))) + (:file "file-lwo") + (:file "pcx")) diff --git a/pcx.lisp b/pcx.lisp new file mode 100644 index 0000000..5e05c2b --- /dev/null +++ b/pcx.lisp @@ -0,0 +1,91 @@ +(define-binary-class pcx-header + (manufacturer :u8) ; resb 1 ; should always be 0ah + (version :u8) ; resb 1 ; (1) + (encoding :u8) ; resb 1 ; should always be 01h + (bits-per-pixel :u8) ; resb 1 ; (2) + (xmin :u16) ; resw 1 ; image width = xmax-xmin + (ymin :u16) ; resw 1 ; image height = ymax-ymin + (xmax :i16) ; resw 1 + (ymax :u16) ; resw 1 + (vertdpi :u16) ; resw 1 ; (3) + (palette :u8 :array-size 48) ; resb 48 ; (4) + (reserved :u8) ; resb 1 + (color-planes :u8) ; resb 1 ; (5) + (bytes-per-line :u16) ; resw 1 ; (6) + (palette-type :u16) ;resw 1 + (hscrsize :u16) ; resw 1 ; only supported by + (vscrsize :u16) ; 1 ; pc paintbrush iv or higher + (filler :u8 :array-size 56)) + +(defun length-byte-p (byte) + (= (logand byte #XA0) #XA0)) + +(defun length-byte (byte) + (logand byte (lognot #XA0))) + + +(defun decode-run (stream array) + (let ((length (read-byte stream))) + (if (length-byte-p byte) + (let ((colour (read-byte stream))) + (iterate + (for index from 0 below (length-byte length)) + (vector-push colour array)) + (length-byte length)) + (progn + (vector-push colour array) + 1)))) + +(defun decode-row (stream array row-length) + (let ((row-index 0)) + (iterate + (while (< row-index row-length) + (incf row-index (decode-run stream array)))))) + +(defun decode-rgb (stream row-length nrows &key red green blue) + (iterate + (for index from 0 below nrows) + (decode-row stream red row-length) + (decode-row stream green row-length) + (decode-row stream blue row-length))) + + +(defun merge-arrays (stream &key red green blue) + (assert (= (length red-array) (length green-array) (length blue-array))) + (let ((result (make-array (length red-array) :element-type (unsigned-byte 32)))) + (iterate + (for colour in-vector result) + (for red in-vector red) + (for green in-vector green) + (for blue in-vector blue) + (setf colour (logor (ash red 24) (ash g 16) (ash b 8))))) + result) + +(defun extract-palette (stream) + (file-position stream + (let ((palette (file-length streapm + )) + +(defun decode-8bit(stream row-length nrows) + (let ((index-array (make-array (* row-length nrows))) :fill-pointer 0) + (iterate + (for index from 0 belw nrows) + (decode-row stream index-array row-length))) + + + +(defun parse-pcx-file (stream) + (let* ((header (read-value :pcx-header stream)) + (red-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type (unsigned-byte 32) :fill-pointer 0)) + (blue-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type (unsigned-byte 32) :fill-pointer 0)) + (green-array (make-array (list (* (- xmax xmin) (- ymax ymin))) :element-type (unsigned-byte 32) :fill-pointer 0))) + (case (bits-per-pixel header) + ;; be sersi + (1 (warn "Unsupported PCX Format")) + (4 (warn "Unsupported PCX Format")) + (8 (warn "Unsupported PCX Format")) + (24 (decode-rgb stream (/ (bytes-per-line-of header) (colour-planes-of header)) (- ymax ymin) + :red red-array :green green-array :blue blue-array) + (merge-arrays :red red-array :green green-array :blue blue-array)) + + \ No newline at end of file -- 2.11.4.GIT