From bcf82afeb9cb95e5803501a0fb1eb7c03bae5085 Mon Sep 17 00:00:00 2001 From: John Connors Date: Sun, 24 Aug 2008 17:28:39 +0100 Subject: [PATCH] PCX Loading works --- file-md2.lisp | 22 +++++++++++++++---- file-pcx.lisp | 62 +++++++++++++++++++++++++++++----------------------- lodematron-test.lisp | 2 +- lodematron.asd | 4 ++-- 4 files changed, 56 insertions(+), 34 deletions(-) diff --git a/file-md2.lisp b/file-md2.lisp index 71cc4e4..43b9066 100644 --- a/file-md2.lisp +++ b/file-md2.lisp @@ -315,7 +315,8 @@ (defclass md2 () ((sts :accessor sts-of :initarg :sts) (frames :accessor frames-of :initarg :frames) - (tris :accessor tris-of :initarg :tris))) + (tris :accessor tris-of :initarg :tris) + (skins :accessor skins-of :initform (make-hash-table :test 'equal)))) (defun parse-md2-file (stream) @@ -331,7 +332,21 @@ :tris (parse-md2-triangles (tris-offset-of header) (ntris-of header) stream)))) result))) - +;; skins -- +(defun is-pcx (x) + "Test whether file extension is pcx" + (let ((name (namestring x))) (string-equal "pcx" (subseq name (- (length name) 3))))) + +(defun directory-scan (directory-name) + "Scan a directory and get a list of skin names" + (let ((directory-name-length (length (namestring (merge-pathnames directory-name)))) + (directory-list (cl-fad:list-directory (merge-pathnames directory-name)))) + (mapcar #'(lambda (x) + (let ((name (namestring x))) + (subseq (namestring name) directory-name-length (- (length name) 4)))) + (remove-if-not #'is-pcx directory-list)))) + +;; animation -- (defmethod pose ((model md2) (mesh simple-mesh) frame-name skin-name) "Set the pose of mesh based on an md2 frame" (let ((frame (gethash frame-name (frames-of model)))) @@ -340,8 +355,7 @@ (vertices (cdr frame))) ;; problem when we texture -- 1:1 mapping betewen index and vertex is lost.. ;; maybe md2 mesh with it's own texture - or reallocate and renumber vertices? - ;; just a new mesh type with extra attributes - + ;; just a new mesh type with extra attributes (setf (vertices-of mesh) (make-vertex3d-array (length vertices))) (pose-vertices (vertices-of mesh) (scale-of header) (translation-of header) vertices) (setf (faces-of mesh) (make-triangle-array (length (tris-of model)))) diff --git a/file-pcx.lisp b/file-pcx.lisp index 2cd4981..3828dbb 100644 --- a/file-pcx.lisp +++ b/file-pcx.lisp @@ -8,7 +8,7 @@ (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 + (xmax :u16) ; resw 1 (ymax :u16) ; resw 1 (vertdpi :u16) ; resw 1 ; (3) (palette :u8 :array-size 48) ; resb 48 ; (4) @@ -37,7 +37,7 @@ (length-byte length)) (progn (vector-push length array) - length)))) + 1)))) (defun decode-row (stream array row-length) (let ((row-index 0)) @@ -55,49 +55,57 @@ (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))) + (let ((result (make-colour-array (length red) :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)) + (colour-vector-push (colour* (/ r 255.0) (/ g 255.0) (/ b 255.0) 1.0) result)) result)) (defun extract-palette (stream) - (let ((palette-pos (- 768 (file-length stream)))) - (file-position stream (1- palette-pos)) - (assert (= (read-byte stream) 192)) + (let ((palette-pos (- (file-length stream) 768))) + (file-position stream palette-pos) +;; (format t "Reading palette from ~X~%" (file-position stream)) +;; (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)))) + (decode-row stream index-array row-length)) + index-array)) (defun merge-array-and-palette (array palette) - (let ((result (make-array (length array)) :element-type '(unsigned-byte 32) :fill-pointer 0)) + (let ((result (make-colour-array (length array) :fill-pointer 0))) (iterate - (for palette-index in array) - (vector-push (logior (ash (aref palette (* 3 palette-index)) 24) + (for palette-index in-vector array) + (colour-vector-push (colour* (/ (aref palette (* 3 palette-index)) 255.0) + (/ (aref palette (1+ (* 3 palette-index))) 255.0) + (/ (aref palette (+ 2 (* 3 palette-index))) 255.0) + 1.0) + result)) + result)) -(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) +(defun parse-pcx-file (filename) + (with-open-file (stream (merge-pathnames filename) :direction :input :element-type '(unsigned-byte 8)) + (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))) + (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)) + (case (bits-per-pixel-of header) + (1 (warn "Unsupported PCX Format")) + (4 (warn "Unsupported PCX Format")) + (8 (merge-array-and-palette (decode-8bit stream (- xmax xmin) (- ymax ymin)) (extract-palette stream))) + (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))))) + (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 c076b11..a68c8dc 100644 --- a/lodematron-test.lisp +++ b/lodematron-test.lisp @@ -40,7 +40,7 @@ (close *md2-file*) -(defparameter *pcx-file* (open (merge-pathnames #P"dalekx/brit.pcx") +(defparameter *pcx-file* (open (merge-pathnames #P"dalekx/brit.PCX") :direction :input :element-type '(unsigned-byte 8))) diff --git a/lodematron.asd b/lodematron.asd index f530a4f..3e82049 100644 --- a/lodematron.asd +++ b/lodematron.asd @@ -12,9 +12,9 @@ (:file "lodematron-write" ) (:file "lodematron-rw" ) (:file "file-3ds") + (:file "pcx") (:file "file-md2") (:file "file-ifs") - (:file "file-lwo") - (:file "pcx")) + (:file "file-lwo"))) -- 2.11.4.GIT