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 ,@args)) (unwind-protect (progn ,@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 + ,@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))