[pal-cvs] CVS pal
tneste
tneste at common-lisp.net
Wed Aug 15 14:36:21 UTC 2007
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 , at decls)
, at 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)
More information about the Pal-cvs
mailing list