Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv8836 Modified Files: ffi.lisp package.lisp pal.lisp todo.txt Log Message: Added image-from-array and image-from-fn --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/13 13:21:04 1.5 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/16 14:44:12 1.6 @@ -436,8 +436,8 @@ (width 0 :type u11)) (defstruct font - (image nil :type (or nil image)) - (glyphs nil :type (or nil (simple-vector 255))) + (image nil :type (or boolean image)) + (glyphs nil :type (or boolean (simple-vector 255))) (height 0 :type u11)) (defstruct music @@ -456,8 +456,6 @@ (defgeneric register-resource (resource)) (defgeneric free-resource (resource)) -(defgeneric free-all-resources ()) - (defmethod register-resource (resource) (assert (resource-p resource)) @@ -471,18 +469,26 @@ (setf *resources* (remove resource *resources*))) (defmethod free-resource ((resource music)) - (free-music (music-music resource))) + (when (music-music resource) + (setf (music-music resource) nil) + (free-music (music-music resource)))) (defmethod free-resource ((resource font)) - (free-resource (font-image resource))) + (when (font-image resource) + (free-resource (font-image resource)) + (setf (font-image resource) nil))) (defmethod free-resource ((resource image)) - (gl-delete-texture (image-texture resource))) + (when (> (image-texture resource) 0) + (setf (image-texture resource) 0) + (gl-delete-texture (image-texture resource)))) (defmethod free-resource ((resource sample)) - (free-chunk (sample-chunk resource))) + (when (sample-chunk resource) + (setf (sample-chunk resource) nil) + (free-chunk (sample-chunk resource)))) -(defmethod free-all-resources () +(defun free-all-resources () (dolist (r *resources*) (free-resource r)) (assert (null *resources*))) @@ -491,12 +497,14 @@ (cffi:defctype new-music :pointer) (defmethod cffi:translate-from-foreign (value (name (eql 'new-music))) + (assert (not (cffi:null-pointer-p value))) (let ((music (make-music :music value))) (register-resource music) music)) (cffi:defctype new-sample :pointer) (defmethod cffi:translate-from-foreign (value (name (eql 'new-sample))) + (assert (not (cffi:null-pointer-p value))) (let ((sample (make-sample :chunk value))) (register-resource sample) sample)) --- /project/pal/cvsroot/pal/package.lisp 2007/07/13 21:30:59 1.5 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/16 14:44:12 1.6 @@ -407,6 +407,9 @@ #:pop-clip #:update-screen + #:image-from-array + #:image-from-fn + #:load-image #:image-width #:image-height @@ -417,7 +420,7 @@ #:draw-arrow #:draw-image #:draw-image* - + #:load-font #:get-font-height #:draw-text --- /project/pal/cvsroot/pal/pal.lisp 2007/07/13 21:30:59 1.10 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/16 14:44:12 1.11 @@ -1,10 +1,12 @@ ;; Notes: ;; tags-resources-free? ;; circle/box/point overlap functions, fast v-dist -;; resources should check for void when freeing ;; do absolute paths for data-path work? ;; draw-image* aligns & scale, angle? ;; draw-polygon*, draw-circle +;; rgbas for textured polys. +;; opengl state macros + (declaim (optimize (speed 3) (safety 3))) @@ -50,8 +52,7 @@ (type (or boolean image) *current-image*)) -(defgeneric open-pal (&key width height fps title fullscreenp paths)) -(defmethod open-pal (&key (width 800) (height 600) (fps 60) (title "PAL") (fullscreenp nil) (paths nil)) +(defun open-pal (&key (width 800) (height 600) (fps 60) (title "PAL") (fullscreenp nil) (paths nil)) (when *pal-running* (close-pal)) (pal-ffi:init (logior pal-ffi:+init-video+ pal-ffi:+init-audio+)) @@ -121,8 +122,7 @@ (set-cursor nil)) (pal-ffi:free-all-resources)) -(defgeneric close-pal ()) -(defmethod close-pal () +(defun close-pal () (unwind-protect (progn (free-all-resources) (pal-ffi:close-audio) @@ -365,11 +365,22 @@ (cffi:mem-ref b :uint8) (cffi:mem-ref a :uint8))))) - - -(defun make-texture-from-surface (surface smooth-p) - (let* ((width (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w))) - (height (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h))) +(defun image-from-array (smooth-p array) + (image-from-fn (array-dimension array 0) + (array-dimension array 1) + smooth-p + (lambda (y x) + (let ((pixel (aref array x y))) + (values (first pixel) + (second pixel) + (third pixel) + (fourth pixel)))))) + + +(defun image-from-fn (width height smooth-p fn) + (let* ((mode pal-ffi:+gl-rgb+) + (width (min 1024 width)) + (height (min 1024 height)) (texture-width (expt 2 (or (find-if (lambda (x) (> (expt 2 x) (1- width))) @@ -381,8 +392,11 @@ (id (cffi:foreign-alloc :uint :count 1))) (with-foreign-vector (tdata (* texture-width texture-height) 4) (do-n (x width y height) - (multiple-value-bind (r g b a) (surface-get-pixel surface x y) - (let ((p (the fixnum (+ (* y (the u16 (* (the u11 texture-width) 4))) (the u16 (* 4 x)))))) + (multiple-value-bind (r g b a) (funcall fn x y) + (let ((a (or a 255)) + (p (the fixnum (+ (* y (the u16 (* (the u11 texture-width) 4))) (the u16 (* 4 x)))))) + (when (< a 255) + (setf mode pal-ffi:+gl-rgba+)) (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) (cffi:mem-ref tdata :uint8 (+ p 1)) (the u8 g) (cffi:mem-ref tdata :uint8 (+ p 2)) (the u8 b) @@ -393,26 +407,75 @@ (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ 0 - (if (= (cffi:foreign-slot-value (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:pixelformat) - 'pal-ffi:pixelformat 'pal-ffi:bytesperpixel) - 3) - pal-ffi:+gl-rgb+ - pal-ffi:+gl-rgba+) + mode texture-width texture-height 0 pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ tdata)) (let ((image (pal-ffi::make-image :texture (cffi:mem-ref id :uint) :tx2 (coerce (/ width texture-width) 'single-float) :ty2 (coerce (/ height texture-height) 'single-float) :texture-width texture-width :texture-height texture-height - :width (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) - :height (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)))) + :width width + :height height))) (setf *current-image* image) (cffi:foreign-free id) (pal-ffi:register-resource image)))) + +(defun image-from-surface (surface smooth-p) + (assert (not (cffi:null-pointer-p surface))) + (image-from-fn (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + smooth-p + (lambda (x y) + (surface-get-pixel surface x y)))) + +;; (defun image-from-surface (surface smooth-p) +;; (assert (not (cffi:null-pointer-p surface))) +;; (let* ((width (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w))) +;; (height (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h))) +;; (texture-width (expt 2 (or (find-if (lambda (x) +;; (> (expt 2 x) +;; (1- width))) +;; '(6 7 8 9 10)) 10))) +;; (texture-height (expt 2 (or (find-if (lambda (x) +;; (> (expt 2 x) +;; (1- height))) +;; '(6 7 8 9 10)) 10))) +;; (id (cffi:foreign-alloc :uint :count 1))) +;; (with-foreign-vector (tdata (* texture-width texture-height) 4) +;; (do-n (x width y height) +;; (multiple-value-bind (r g b a) (surface-get-pixel surface x y) +;; (let ((p (the fixnum (+ (* y (the u16 (* (the u11 texture-width) 4))) (the u16 (* 4 x)))))) +;; (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) +;; (cffi:mem-ref tdata :uint8 (+ p 1)) (the u8 g) +;; (cffi:mem-ref tdata :uint8 (+ p 2)) (the u8 b) +;; (cffi:mem-ref tdata :uint8 (+ p 3)) (the u8 a))))) +;; (pal-ffi:gl-gen-textures 1 id) +;; (pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (cffi:mem-ref id :uint)) +;; (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-mag-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) +;; (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) +;; (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ +;; 0 +;; (if (= (cffi:foreign-slot-value (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:pixelformat) +;; 'pal-ffi:pixelformat 'pal-ffi:bytesperpixel) +;; 3) +;; pal-ffi:+gl-rgb+ +;; pal-ffi:+gl-rgba+) +;; texture-width texture-height 0 pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ tdata)) +;; (let ((image (pal-ffi::make-image :texture (cffi:mem-ref id :uint) +;; :tx2 (coerce (/ width texture-width) 'single-float) +;; :ty2 (coerce (/ height texture-height) 'single-float) +;; :texture-width texture-width +;; :texture-height texture-height +;; :width (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) +;; :height (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)))) +;; (setf *current-image* image) +;; (cffi:foreign-free id) +;; (pal-ffi:register-resource image)))) + (defun load-image (file &optional (smooth-p nil)) (let* ((surface (pal-ffi:load-image (data-path file))) - (image (make-texture-from-surface surface smooth-p))) + (image (image-from-surface surface smooth-p))) (pal-ffi::free-surface surface) image)) @@ -541,7 +604,7 @@ (v+ pos (v width 0)) (v+ pos (v width height)) (v+ pos (v 0 height))) - 0 0 0 0 + r g b a :fill fill :absolutep absolutep)) ((eq nil fill) --- /project/pal/cvsroot/pal/todo.txt 2007/07/13 21:30:59 1.6 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/16 14:44:12 1.7 @@ -6,7 +6,9 @@ - More drawing primitives. -- image-from-array/image-to-array/screen-to-array etc. +- Improved texture handling + +- image-to-array/screen-to-array etc. - Fix the FPS limiter, the results could be a lot smoother.