[pal-cvs] CVS pal
tneste
tneste at common-lisp.net
Tue Jul 24 12:55:07 UTC 2007
Update of /project/pal/cvsroot/pal
In directory clnet:/tmp/cvs-serv16632
Modified Files:
ffi.lisp package.lisp pal-macros.lisp pal.lisp
Log Message:
Few name changes, RELT -> RANDOM-ELT
--- /project/pal/cvsroot/pal/ffi.lisp 2007/07/21 16:34:16 1.12
+++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/24 12:55:06 1.13
@@ -467,7 +467,7 @@
(assert (typep resource 'resource)))
(defmethod free-resource :after (resource)
- (pal::reset-tags-holding-this-resource resource)
+ (pal::reset-tags :resource resource)
(setf *resources* (remove resource *resources*)))
(defmethod free-resource ((resource music))
@@ -912,8 +912,4 @@
(concatenate 'string (cffi:foreign-string-to-lisp path) "/")))
(cffi:defcfun "calloc" :pointer (nelem :uint) (elsize :uint))
-(cffi:defcfun "free" :void (ptr :pointer))
-
-;; SDL_SysWMinfo wmInfo;
-;; SDL_GetWMInfo(&wmInfo);
-;; HWND hWnd = wmInfo.window;
\ No newline at end of file
+(cffi:defcfun "free" :void (ptr :pointer))
\ No newline at end of file
--- /project/pal/cvsroot/pal/package.lisp 2007/07/19 18:51:37 1.11
+++ /project/pal/cvsroot/pal/package.lisp 2007/07/24 12:55:06 1.12
@@ -387,7 +387,7 @@
#:with-resource
#:randomly
- #:relt
+ #:random-elt
#:clamp
#:do-n
#:curry
--- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/21 16:34:16 1.9
+++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/24 12:55:06 1.10
@@ -13,17 +13,15 @@
(cons (lambda () ,(second r)) nil)))
(loop for (a b) on tags by #'cddr collect (list a b)))))
-(defun reset-tags ()
- (maphash (lambda (k v)
- (declare (ignore k))
- (setf (cdr v) nil))
- *tags*))
-
-(defun reset-tags-holding-this-resource (resource)
- (maphash (lambda (k v)
- (declare (ignore k))
- (when (eq resource (cdr v))
- (setf (cdr v) nil)))
+(defun reset-tags (&key resource)
+ (maphash (if resource
+ (lambda (k v)
+ (declare (ignore k))
+ (when (eq resource (cdr v))
+ (setf (cdr v) nil)))
+ (lambda (k v)
+ (declare (ignore k))
+ (setf (cdr v) nil)))
*tags*))
(defun tag (name)
@@ -37,7 +35,7 @@
(the resource (setf (cdr resource) r))))
(error "Named resource ~a not found" name))))
-(defun coerce-form-for (to-type value)
+(defun make-coerce-form (to-type value)
`(,value ,(case to-type
((u8 u11 u16 integer fixnum) `(truncate ,value))
(component `(coerce ,value 'component))
@@ -52,7 +50,7 @@
(coerced (remove-if (lambda (decl)
(null (second decl)))
(mapcar (lambda (decl)
- (coerce-form-for (second decl) (third decl)))
+ (make-coerce-form (second decl) (third decl)))
decls))))
(if coerced
`(defun ,name ,lambda-list
@@ -160,11 +158,11 @@
,@(rest arg)))
args)))
-(defmacro funcall? (fn &rest args)
+(declaim (inline funcall?))
+(defun funcall? (fn &rest args)
(if (null fn)
nil
- `(funcall ,fn , at args)))
-
+ (apply fn args)))
(defmacro do-event (event key-up-fn key-down-fn mouse-motion-fn quit-fn)
`(loop while (pal-ffi:poll-event ,event)
@@ -173,22 +171,20 @@
(cond
((= type pal-ffi:+key-up-event+)
- (let ((keysym (cffi:foreign-slot-value ,event 'pal-ffi:keyboard-event 'pal-ffi:keysym)))
- (setf (gethash (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi:sym))
- *pressed-keys*)
+ (let* ((keysym (cffi:foreign-slot-value ,event 'pal-ffi:keyboard-event 'pal-ffi:keysym))
+ (sym (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi:sym))))
+ (setf (gethash sym *pressed-keys*)
nil)
- (funcall? ,key-up-fn
- (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi:sym)))))
+ (funcall? ,key-up-fn sym)))
((= type pal-ffi:+key-down-event+)
- (let ((keysym (cffi:foreign-slot-value ,event 'pal-ffi:keyboard-event 'pal-ffi:keysym)))
- (setf (gethash (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi:sym))
- *pressed-keys*)
+ (let* ((keysym (cffi:foreign-slot-value ,event 'pal-ffi:keyboard-event 'pal-ffi:keysym))
+ (sym (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi:sym))))
+ (setf (gethash sym *pressed-keys*)
t)
(if ,key-down-fn
- (funcall ,key-down-fn
- (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi:sym)))
- (when (eq (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi:sym)) :key-escape)
+ (funcall ,key-down-fn sym)
+ (when (eq sym :key-escape)
(return-from event-loop)))))
((= type pal-ffi:+mouse-motion-event+)
@@ -199,15 +195,15 @@
((= type pal-ffi:+mouse-button-up-event+)
(let* ((button (cffi:foreign-slot-value ,event 'pal-ffi:mouse-button-event 'pal-ffi:button))
(keysym (read-from-string (format nil ":key-mouse-~a" button))))
- (setf (gethash keysym
- *pressed-keys*) nil)
+ (setf (gethash keysym *pressed-keys*)
+ nil)
(funcall? ,key-up-fn keysym)))
((= type pal-ffi:+mouse-button-down-event+)
(let* ((button (cffi:foreign-slot-value ,event 'pal-ffi:mouse-button-event 'pal-ffi:button))
(keysym (read-from-string (format nil ":key-mouse-~a" button))))
- (setf (gethash keysym
- *pressed-keys*) t)
+ (setf (gethash keysym *pressed-keys*)
+ t)
(funcall? ,key-down-fn keysym)))
((= type pal-ffi:+quit-event+)
--- /project/pal/cvsroot/pal/pal.lisp 2007/07/21 16:34:16 1.18
+++ /project/pal/cvsroot/pal/pal.lisp 2007/07/24 12:55:06 1.19
@@ -2,6 +2,9 @@
;; smoothed polygons, guess circle segment count
;; calculate max-texture-size
;; fix the fps
+;; clean up the do-event
+;; open quads and other optimisations
+;; test with latest cffi and sdl libs
(declaim (optimize (speed 3)
@@ -113,7 +116,7 @@
(declare (number min max))
(max min (min max v)))
-(defun relt (sequence)
+(defun random-elt (sequence)
(elt sequence (random (length sequence))))
(defun free-all-resources ()
@@ -170,11 +173,11 @@
(declaim (inline key-pressed-p))
(defunct key-pressed-p (keysym)
- (symbol keysym)
+ (symbol keysym)
(gethash keysym *pressed-keys*))
(defunct keysym-char (keysym)
- (symbol keysym)
+ (symbol keysym)
(code-char (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym)))
(declaim (inline get-mouse-pos))
@@ -196,14 +199,12 @@
(defun wait-keypress ()
(let ((key nil))
- (event-loop
- (:key-down-fn (lambda (k)
- (setf key k)
- (return-from event-loop key))))
- (event-loop
- (:key-up-fn (lambda (k)
- (when (eq key k)
- (return-from event-loop key)))))
+ (event-loop (:key-down-fn (lambda (k)
+ (setf key k)
+ (return-from event-loop key))))
+ (event-loop (:key-up-fn (lambda (k)
+ (when (eq key k)
+ (return-from event-loop key)))))
key))
@@ -223,21 +224,23 @@
(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 *ticks* (pal-ffi:get-tick))
(setf *fps* (truncate (+ *fps* *new-fps*) 2))
(if (> *delay* 1)
(decf *delay*))
(when (< *fps* *max-fps*)
(incf *delay* 2))
+ (setf *ticks* (pal-ffi:get-tick))
(pal-ffi:delay *delay*)
(if (or (eq t *cursor*) (eq nil *cursor*))
(when *messages*
(with-default-settings
- (draw-messages)))
+ (draw-messages)))
(with-default-settings
- (draw-image *cursor* (v- (get-mouse-pos) *cursor-offset*))
+ (draw-image *cursor* (v- (get-mouse-pos) *cursor-offset*))
(draw-messages)))
+
(pal-ffi:gl-swap-buffers))
(declaim (inline get-screen-width))
@@ -254,7 +257,7 @@
(declaim (inline clear-screen))
(defunct clear-screen (r g b)
- (u8 r u8 g u8 b)
+ (u8 r u8 g u8 b)
(pal-ffi:gl-clear-color (/ r 255f0)
(/ g 255f0)
(/ b 255f0)
@@ -262,7 +265,7 @@
(pal-ffi:gl-clear pal-ffi:+gl-color-buffer-bit+))
(defunct set-mouse-pos (x y)
- (u16 x u16 y)
+ (u16 x u16 y)
(pal-ffi:warp-mouse x y)
(setf *mouse-x* x
*mouse-y* y))
@@ -283,7 +286,7 @@
image)
(defunct push-clip (x y width height)
- (u16 x u16 y u16 width u16 height)
+ (u16 x u16 y u16 width u16 height)
(pal-ffi:gl-scissor x y width height)
(pal-ffi:gl-enable pal-ffi:+gl-scissor-test+)
(push (vector x y width height) *clip-stack*))
@@ -302,7 +305,7 @@
(declaim (inline set-blend-mode))
(defunct set-blend-mode (mode)
- (symbol mode)
+ (symbol mode)
(case mode
((nil) (pal-ffi:gl-disable pal-ffi:+gl-blend+))
(:blend (pal-ffi:gl-enable pal-ffi:+gl-blend+)
@@ -312,17 +315,17 @@
(declaim (inline rotate))
(defunct rotate (angle)
- (single-float angle)
+ (single-float angle)
(pal-ffi:gl-rotatef angle 0f0 0f0 1f0))
(declaim (inline scale))
(defunct scale (x y)
- (single-float x single-float y)
+ (single-float x single-float y)
(pal-ffi:gl-scalef x y 1f0))
(declaim (inline translate))
(defunct translate (vec)
- (vec vec)
+ (vec vec)
(pal-ffi:gl-translatef (vx vec) (vy vec) 0f0))
(declaim (inline reset-blend-mode))
@@ -332,12 +335,12 @@
(declaim (inline set-blend-color))
(defunct set-blend-color (r g b a)
- (u8 r u8 g u8 b u8 a)
+ (u8 r u8 g u8 b u8 a)
(pal-ffi:gl-color4ub r g b a))
(declaim (inline set-image))
(defunct set-image (image)
- (image image)
+ (image image)
(unless (eq image *current-image*)
(setf *current-image* image)
(pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (pal-ffi::image-texture image))))
@@ -449,7 +452,7 @@
image))
(defunct screen-to-array (pos width height)
- (vec pos u16 width u16 height)
+ (vec pos u16 width u16 height)
(let ((array (make-array (list width height))))
(cffi:with-foreign-object (image :unsigned-char (* width height 3))
(pal-ffi:gl-read-pixels (truncate (vx pos))
@@ -472,7 +475,7 @@
(defunct draw-image (image pos &key angle scale valign halign)
- (image image vec pos (or boolean number) angle (or boolean number) scale symbol halign symbol valign)
+ (image image vec pos (or boolean number) angle (or boolean number) scale symbol halign symbol valign)
(set-image image)
(let ((width (image-width image))
(height (image-height image))
@@ -518,7 +521,7 @@
(defunct draw-image* (image from-pos to-pos width height)
- (image image vec from-pos vec to-pos u11 width u11 height)
+ (image image vec from-pos vec to-pos u11 width u11 height)
(set-image image)
(let* ((vx (vx from-pos))
(vy (vy from-pos))
@@ -540,33 +543,33 @@
(declaim (inline draw-line))
(defunct draw-line (la lb r g b a &key (size 1.0f0) (smoothp))
- (vec la vec lb single-float size u8 r u8 g u8 b u8 a boolean smoothp)
+ (vec la vec lb single-float size u8 r u8 g u8 b u8 a boolean smoothp)
(with-line-settings smoothp size r g b a
- (with-gl pal-ffi:+gl-lines+
- (pal-ffi:gl-vertex2f (vx la) (vy la))
- (pal-ffi:gl-vertex2f (vx lb) (vy lb)))))
+ (with-gl pal-ffi:+gl-lines+
+ (pal-ffi:gl-vertex2f (vx la) (vy la))
+ (pal-ffi:gl-vertex2f (vx lb) (vy lb)))))
(declaim (inline draw-arrow))
(defunct draw-arrow (la lb r g b a &key (size 1.0f0) smoothp)
- (vec la vec lb u8 r u8 g u8 b u8 a single-float size boolean smoothp)
+ (vec la vec lb u8 r u8 g u8 b u8 a single-float size boolean smoothp)
(with-line-settings smoothp size r g b a
- (let ((d (v* (v-direction la lb) (+ size 8f0))))
- (with-gl pal-ffi:+gl-lines+
- (pal-ffi:gl-vertex2f (vx la) (vy la))
- (pal-ffi:gl-vertex2f (vx lb) (vy lb))
- (pal-ffi:gl-vertex2f (vx lb) (vy lb))
- (pal-ffi:gl-vertex2f (vx (v+ lb (v-rotate d 140f0)))
- (vy (v+ lb (v-rotate d 140f0))))
- (pal-ffi:gl-vertex2f (vx lb) (vy lb))
- (pal-ffi:gl-vertex2f (vx (v+ lb (v-rotate d -140f0)))
- (vy (v+ lb (v-rotate d -140f0))))))))
+ (let ((d (v* (v-direction la lb) (+ size 8f0))))
+ (with-gl pal-ffi:+gl-lines+
+ (pal-ffi:gl-vertex2f (vx la) (vy la))
+ (pal-ffi:gl-vertex2f (vx lb) (vy lb))
+ (pal-ffi:gl-vertex2f (vx lb) (vy lb))
+ (pal-ffi:gl-vertex2f (vx (v+ lb (v-rotate d 140f0)))
+ (vy (v+ lb (v-rotate d 140f0))))
+ (pal-ffi:gl-vertex2f (vx lb) (vy lb))
+ (pal-ffi:gl-vertex2f (vx (v+ lb (v-rotate d -140f0)))
+ (vy (v+ lb (v-rotate d -140f0))))))))
(declaim (inline draw-point))
(defunct draw-point (pos r g b a &key (size 1f0) smoothp)
- (vec pos u8 r u8 g u8 b u8 a single-float size boolean smoothp)
+ (vec pos u8 r u8 g u8 b u8 a single-float size boolean smoothp)
(pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+))
(pal-ffi:gl-disable pal-ffi:+gl-texture-2d+)
(if smoothp
@@ -579,7 +582,7 @@
(pal-ffi:gl-pop-attrib))
(defunct draw-rectangle (pos width height r g b a &key (fill t) (size 1f0) absolutep smoothp)
- (vec pos u16 width u16 height u8 r u8 g u8 b u8 a (or symbol image) fill single-float size boolean absolutep boolean smoothp)
+ (vec pos u16 width u16 height u8 r u8 g u8 b u8 a (or symbol image) fill single-float size boolean absolutep boolean smoothp)
(cond
((image-p fill)
(draw-polygon (list pos
@@ -591,14 +594,14 @@
:absolutep absolutep))
((eq nil fill)
(with-line-settings smoothp size r g b a
- (with-gl pal-ffi:+gl-line-loop+
- (pal-ffi:gl-vertex2f (vx pos) (vy pos))
- (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos))
- (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos))
- (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height))
- (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height))
- (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height))
- (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height)))))
+ (with-gl pal-ffi:+gl-line-loop+
+ (pal-ffi:gl-vertex2f (vx pos) (vy pos))
+ (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos))
+ (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos))
+ (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height))
+ (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height))
+ (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height))
+ (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height)))))
(t
(pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+))
(pal-ffi:gl-disable pal-ffi:+gl-texture-2d+)
@@ -607,7 +610,7 @@
(pal-ffi:gl-pop-attrib))))
(defunct draw-polygon (points r g b a &key (fill t) absolutep (size 1f0) smoothp)
- (list points u8 r u8 g u8 b u8 a (or image boolean) fill single-float size)
+ (list points u8 r u8 g u8 b u8 a (or image boolean) fill single-float size)
(cond
((image-p fill)
(pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+))
@@ -632,9 +635,9 @@
(pal-ffi:gl-pop-attrib))
((eq nil fill)
(with-line-settings smoothp size r g b a
- (with-gl pal-ffi:+gl-line-loop+
- (dolist (p points)
- (pal-ffi:gl-vertex2f (vx p) (vy p))))))
+ (with-gl pal-ffi:+gl-line-loop+
+ (dolist (p points)
+ (pal-ffi:gl-vertex2f (vx p) (vy p))))))
(t
(pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+))
(pal-ffi:gl-color4ub r g b a)
@@ -645,7 +648,7 @@
(pal-ffi:gl-pop-attrib))))
(defunct draw-polygon* (points &key image tex-coords colors)
- (list points list tex-coords list colors (or boolean image) image)
+ (list points list tex-coords list colors (or boolean image) image)
(pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+))
(cond
((and image tex-coords)
@@ -683,7 +686,7 @@
(pal-ffi:gl-pop-attrib))
(defunct draw-circle (pos radius r g b a &key (fill t) absolutep (size 1f0) smoothp (segments 30))
- (vec pos single-float radius u8 r u8 g u8 b u8 a (or image symbol) fill boolean absolutep single-float size boolean smoothp fixnum segments)
+ (vec pos single-float radius u8 r u8 g u8 b u8 a (or image symbol) fill boolean absolutep single-float size boolean smoothp fixnum segments)
(declare (type vec pos) (type fixnum segments))
(draw-polygon (loop for a from 0 to (* 2 pi) by (/ (* 2 pi) segments) collecting
(v+ pos
@@ -802,7 +805,7 @@
(translate (v (+ (glyph-width g) (glyph-xoff g)) 0)))
(defunct draw-text (text pos &optional font)
- (vec pos simple-string text (or font boolean) font)
+ (vec pos simple-string text (or font boolean) font)
(with-transformation (:pos pos)
(let* ((font (if font
font
@@ -814,13 +817,13 @@
(declaim (inline get-font-height))
(defunct get-font-height (&optional font)
- ((or font boolean) font)
+ ((or font boolean) font)
(pal-ffi:font-height (if font
font
(tag 'default-font))))
(defunct get-text-size (text &optional font)
- ((or font boolean) font simple-string text)
+ ((or font boolean) font simple-string text)
(values (let ((glyphs (pal-ffi:font-glyphs (if font
font
(tag 'default-font)))))
More information about the Pal-cvs
mailing list