[pal-cvs] CVS pal
tneste
tneste at common-lisp.net
Tue Jul 3 18:10:36 UTC 2007
Update of /project/pal/cvsroot/pal
In directory clnet:/tmp/cvs-serv18496
Modified Files:
ffi.lisp package.lisp pal-macros.lisp pal.lisp todo.txt
vector.lisp
Log Message:
Faster bitmap loading
--- /project/pal/cvsroot/pal/ffi.lisp 2007/07/01 22:49:25 1.2
+++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/03 18:10:33 1.3
@@ -846,4 +846,9 @@
#+win32 (defun get-application-folder ()
(cffi:with-foreign-object (path :char 4096)
(shgetfolderpatha (cffi:null-pointer) #x001c (cffi:null-pointer) 0 path)
- (concatenate 'string (cffi:foreign-string-to-lisp path) "/")))
\ No newline at end of file
+ (concatenate 'string (cffi:foreign-string-to-lisp path) "/")))
+
+(cffi:defcfun "calloc" :pointer (nelem :uint) (elsize :uint))
+(cffi:defcfun "free" :void (ptr :pointer))
+
+
--- /project/pal/cvsroot/pal/package.lisp 2007/06/28 20:14:05 1.1
+++ /project/pal/cvsroot/pal/package.lisp 2007/07/03 18:10:33 1.2
@@ -7,6 +7,8 @@
#:make-font
#:+gl-scissor-test+
#:+gl-points+
+ #:free
+ #:calloc
#:music-music
#:register-resource
#:sample-chunk
@@ -349,7 +351,7 @@
(:export #:open-pal
#:with-pal
#:close-pal
- #:get-info
+ #:get-gl-info
#:load-foreign-libraries
#:register-resource
#:free-resource
@@ -367,7 +369,6 @@
#:get-application-file
#:data-path
#:with-resource
- #:with-blend
#:with-clipping
#:randomly
@@ -385,9 +386,7 @@
#:get-mouse-x
#:get-mouse-y
- #:update-screen
#:clear-screen
- #:clear-depth-buffer
#:get-screen-width
#:get-screen-height
#:set-cursor
@@ -401,6 +400,7 @@
#:set-blend-mode
#:reset-blend-mode
#:set-blend-color
+ #:with-blend
#:load-image
#:image-width
@@ -409,7 +409,7 @@
#:draw-rectangle
#:draw-point
#:draw-line
- #:draw-arrow
+ #:draw-arrow
#:draw-image
#:draw-image-from
#:draw-quad
--- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/01 22:49:25 1.2
+++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/03 18:10:33 1.3
@@ -176,4 +176,11 @@
(apply 'open-pal (list , at args))
(unwind-protect
(progn , at body)
- (close-pal))))
\ No newline at end of file
+ (close-pal))))
+
+
+(defmacro with-foreign-vector ((chunk n size) &body body)
+ `(let ((,chunk (pal-ffi:calloc ,n ,size)))
+ (unwind-protect
+ , at body
+ (pal-ffi:free ,chunk))))
--- /project/pal/cvsroot/pal/pal.lisp 2007/07/01 22:49:25 1.2
+++ /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:10:33 1.3
@@ -147,7 +147,7 @@
result
(error "Data file not found: ~a" file))))
-(defun get-info ()
+(defun get-gl-info ()
(format nil "Vendor: ~a~%Renderer: ~a~%Version: ~a~%Extensions: ~a~%"
(pal-ffi:gl-get-string pal-ffi:+gl-vendor+)
(pal-ffi:gl-get-string pal-ffi:+gl-renderer+)
@@ -367,30 +367,27 @@
(> (expt 2 x)
(1- height)))
'(6 7 8 9 10)) 10)))
- (id (cffi:foreign-alloc :uint :count 1))
- (tdata (cffi:foreign-alloc :uint32 :count (* texture-width texture-height) :initial-element 0))
- ;; (tdata (cffi:foreign-alloc :uint64 :count (/ (* texture-width texture-height) 2) :initial-element 0))
- )
- (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)
- (cffi:foreign-free tdata)
+ (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)
--- /project/pal/cvsroot/pal/todo.txt 2007/07/01 22:49:25 1.2
+++ /project/pal/cvsroot/pal/todo.txt 2007/07/03 18:10:33 1.3
@@ -19,7 +19,5 @@
- Fix with-blend (r g b a), see that things work on Allegro CL.
-- Image loader need a faster way to allocate zeroed foreign vector.
-
- Make it run on OS X.
--- /project/pal/cvsroot/pal/vector.lisp 2007/06/28 20:14:05 1.1
+++ /project/pal/cvsroot/pal/vector.lisp 2007/07/03 18:10:33 1.2
@@ -3,7 +3,8 @@
(in-package :pal)
-(deftype component () 'single-float)
+#+CL-HAS-FULL-NUMERIC-TOWER-DAMMIT (deftype component () 'number)
+#-CL-HAS-FULL-NUMERIC-TOWER-DAMMIT (deftype component () 'single-float)
(defstruct (vec (:conc-name v))
(x 0 :type component) (y 0 :type component))
More information about the Pal-cvs
mailing list