Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv13046

Modified Files: ffi.lisp package.lisp pal-macros.lisp pal.lisp todo.txt vector.lisp Log Message: Minor fixes. Added HANDLE-EVENTS

--- /project/pal/cvsroot/pal/ffi.lisp 2007/07/30 10:38:12 1.16 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/08/15 14:36:21 1.17 @@ -1,5 +1,5 @@ (declaim (optimize (speed 3) - (safety 0))) + (safety 1)))

(in-package :pal-ffi)

@@ -456,42 +456,67 @@

(defgeneric register-resource (resource)) (defgeneric free-resource (resource)) +(defgeneric holdsp (holder resource)) + + + +(defmethod holdsp (holder resource) + nil) + +(defun heldp (resource) + (find-if (lambda (holder) (holdsp holder resource)) *resources*))

(defmethod register-resource (resource) (assert (resource-p resource)) (push resource *resources*) resource)

-(defmethod free-resource :before (resource) - (assert (typep resource 'resource)))

-(defmethod free-resource :after (resource) - (pal::reset-tags :resource resource) - (setf *resources* (remove resource *resources*))) + +(defmethod free-resource :around (resource) + (assert (typep resource 'resource)) + (when (and (not (heldp resource)) (find resource *resources*)) + (call-next-method) + (pal::reset-tags :resource resource) + (setf *resources* (remove resource *resources*)))) + +

(defmethod free-resource ((resource music)) - (when (music-music resource) - (free-music (music-music resource)) - (setf (music-music resource) nil))) + (assert (music-music resource)) + (free-music (music-music resource)) + (setf (music-music resource) nil)) + +

(defmethod free-resource ((resource font)) - (when (font-image resource) - (free-resource (font-image resource)) - (setf (font-image resource) nil))) + (assert (font-image resource)) + (let ((image (font-image resource))) + (setf (font-image resource) nil) + (free-resource image))) + +(defmethod holdsp ((font font) (image image)) + (eq (font-image font) image)) + +

(defmethod free-resource ((resource image)) - (when (> (image-texture resource) 0) - (gl-delete-texture (image-texture resource)) - (setf (image-texture resource) 0))) + (assert (> (image-texture resource) 0)) + (gl-delete-texture (image-texture resource)) + (setf (image-texture resource) 0)) + +

(defmethod free-resource ((resource sample)) - (when (sample-chunk resource) - (free-chunk (sample-chunk resource)) - (setf (sample-chunk resource) nil))) + (assert (sample-chunk resource)) + (free-chunk (sample-chunk resource)) + (setf (sample-chunk resource) nil)) + +

(defun free-all-resources () - (dolist (r *resources*) - (free-resource r)) + (loop while *resources* do + (free-resource (first *resources*))) (assert (null *resources*)))

--- /project/pal/cvsroot/pal/package.lisp 2007/07/29 21:53:52 1.14 +++ /project/pal/cvsroot/pal/package.lisp 2007/08/15 14:36:21 1.15 @@ -367,6 +367,7 @@ #:free-resource #:free-all-resources #:define-tags + #:add-tag #:tag #:sample #:music @@ -386,6 +387,7 @@ #:do-n #:curry

+ #:handle-events #:key-pressed-p #:keysym-char #:test-keys --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/30 10:38:12 1.12 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/08/15 14:36:21 1.13 @@ -1,5 +1,5 @@ (declaim (optimize (speed 3) - (safety 2))) + (safety 1)))

(in-package :pal)

@@ -9,10 +9,15 @@ (defmacro define-tags (&body tags) `(progn ,@(mapcar (lambda (r) - `(setf (gethash ',(first r) *tags*) - (cons (lambda () ,(second r)) nil))) + `(add-tag ',(first r) (lambda () ,(second r)))) (loop for (a b) on tags by #'cddr collect (list a b)))))

+ +(defun add-tag (tag fn) + (assert (and (symbolp tag) (functionp fn))) + (setf (gethash tag *tags*) + (cons fn nil))) + (defun reset-tags (&key resource) (maphash (if resource (lambda (k v) @@ -61,7 +66,7 @@ (declare ,@decls) ,@body))))

- +;; (declaim (ftype (function (double-float double-float) double-float) sss))

(defmacro with-resource ((resource init-form) &body body) `(let ((,resource ,init-form)) @@ -170,6 +175,7 @@

(declaim (inline funcall?)) (defun funcall? (fn &rest args) + (declare (type (or function symbol) fn) (dynamic-extent args)) (if (null fn) nil (apply fn args))) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/30 10:38:12 1.25 +++ /project/pal/cvsroot/pal/pal.lisp 2007/08/15 14:36:21 1.26 @@ -2,13 +2,13 @@ ;; smoothed polygons, guess circle segment count, add start/end args to draw-circle, use triangle-fan ;; calculate max-texture-size ;; fix the fps -;; clean up the do-event ;; check for redundant close-quads, make sure rotations etc. are optimised. ;; newline support for draw-text +;; optimise gl state handling

(declaim (optimize (speed 3) - (safety 2))) + (safety 1)))

(in-package :pal)

@@ -62,7 +62,6 @@ (pal-ffi:open-audio 22050 pal-ffi:+audio-s16+ 0 2048) (pal-ffi:gl-set-attribute pal-ffi:+gl-depth-size+ 0) (pal-ffi:gl-set-attribute pal-ffi:+gl-doublebuffer+ 1) - (pal-ffi:gl-pixel-store pal-ffi:+gl-pack-alignment+ 1) (let ((surface (pal-ffi::set-video-mode width height @@ -104,6 +103,7 @@ (pal-ffi:gl-ortho 0d0 (coerce *width* 'double-float) (coerce *height* 'double-float) 0d0 -1d0 1d0) (pal-ffi:gl-matrix-mode pal-ffi:+gl-modelview+) (pal-ffi:gl-load-identity) + (pal-ffi:gl-pixel-store pal-ffi:+gl-pack-alignment+ 1) (clear-screen 0 0 0) (reset-tags) (define-tags default-font (load-font "default-font")) @@ -195,7 +195,7 @@ (defun get-mouse-y () *mouse-y*)

-(defun dispatch-event (&key key-up-fn key-down-fn mouse-motion-fn quit-fn) +(defun handle-events (&key key-up-fn key-down-fn mouse-motion-fn quit-fn) (block event-loop (cffi:with-foreign-object (event :char 500) (do-event event key-up-fn key-down-fn mouse-motion-fn quit-fn)))) @@ -214,20 +214,15 @@

;; Screen

-(declaim (inline draw-messages)) (defun draw-messages () - (let ((y 0) - (fh (get-font-height))) + (let ((fh (get-font-height)) + (y 0)) (declare (type u11 y fh)) (dolist (m *messages*) (declare (type simple-string m)) (draw-text m (v 0 (incf y fh))))))

(defun update-screen () - (close-quads) - (let ((e (pal-ffi:gl-get-error))) - (unless (= e 0) - (error "GL error ~a" e))) (setf *new-fps* (max 1 (the fixnum (- (pal-ffi:get-tick) *ticks*)))) (setf *fps* (truncate (+ *fps* *new-fps*) 2)) (if (> *delay* 1) @@ -243,7 +238,11 @@ (with-default-settings (draw-image *cursor* (v- (get-mouse-pos) *cursor-offset*)) (draw-messages))) - (pal-ffi:gl-swap-buffers)) + (close-quads) + (pal-ffi:gl-swap-buffers) + (let ((e (pal-ffi:gl-get-error))) + (unless (= e 0) + (error "GL error ~a" e))))

(declaim (inline get-screen-width)) (defun get-screen-width () @@ -879,5 +878,5 @@

(defun message (object) (setf *messages* (append *messages* (list (prin1-to-string object)))) - (when (> (length *messages*) (- (truncate (get-screen-height) (get-font-height)) 2)) + (when (> (length *messages*) (- (truncate (get-screen-height) (get-font-height)) 1)) (pop *messages*))) \ No newline at end of file --- /project/pal/cvsroot/pal/todo.txt 2007/07/28 13:13:15 1.15 +++ /project/pal/cvsroot/pal/todo.txt 2007/08/15 14:36:21 1.16 @@ -9,8 +9,6 @@

- Box/box/line/circle etc. overlap functions, faster v-dist.

-- Improved texture handling. - - Fix the FPS limiter, the results could be a lot smoother.

- Correct aspect ratio when fullscreen on widescreen displays. --- /project/pal/cvsroot/pal/vector.lisp 2007/07/30 10:38:12 1.7 +++ /project/pal/cvsroot/pal/vector.lisp 2007/08/15 14:36:21 1.8 @@ -1,5 +1,5 @@ (declaim (optimize (speed 3) - (safety 2))) + (safety 1)))

(in-package :pal)