[pal-cvs] CVS pal
tneste
tneste at common-lisp.net
Sun Jul 1 22:49:26 UTC 2007
Update of /project/pal/cvsroot/pal
In directory clnet:/tmp/cvs-serv13199
Modified Files:
ffi.lisp pal-macros.lisp pal.lisp todo.txt
Log Message:
Fixed the Lispworks problems, some minor cleanups
--- /project/pal/cvsroot/pal/ffi.lisp 2007/06/28 20:14:05 1.1
+++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/01 22:49:25 1.2
@@ -661,7 +661,6 @@
(defconstant +gl-ONE-MINUS-DST-COLOR+ #x307)
(defconstant +gl-ONE-MINUS-SRC-ALPHA+ #x303)
(defconstant +gl-ONE-MINUS-SRC-COLOR+ #x301)
-(defconstant +gl-depth-buffer-bit+ #x100)
(defconstant +gl-texture-mag-filter+ #x2800)
(defconstant +gl-texture-min-filter+ #x2801)
(defconstant +gl-linear+ #x2601)
@@ -673,8 +672,6 @@
(defconstant +gl-renderer+ #x1F01)
(defconstant +gl-version+ #x1F02)
(defconstant +gl-extensions+ #x1F03)
-(defconstant +gl-depth-buffer-bit+ #x100)
-(defconstant +gl-DEPTH-TEST+ #xB71)
(defconstant +gl-ALPHA-TEST+ #xBC0)
(defconstant +gl-ALPHA-TEST-FUNC+ #xBC1)
(defconstant +gl-GREATER+ #x204)
--- /project/pal/cvsroot/pal/pal-macros.lisp 2007/06/28 20:14:05 1.1
+++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/01 22:49:25 1.2
@@ -9,10 +9,10 @@
(defmacro define-tags (&body tags)
`(progn
- ,@(mapcar (lambda (r)
- `(setf (gethash ',(first r) *tags*)
- (cons (lambda () ,(second r)) nil)))
- (loop for (a b) on tags by #'cddr collect (list a b)))))
+ ,@(mapcar (lambda (r)
+ `(setf (gethash ',(first r) *tags*)
+ (cons (lambda () ,(second r)) nil)))
+ (loop for (a b) on tags by #'cddr collect (list a b)))))
(defun reset-tags ()
(maphash (lambda (k v)
@@ -31,142 +31,149 @@
(defmacro with-resource ((resource init-form) &body body)
`(let ((,resource ,init-form))
- (prog1 (progn
- , at body)
- (free-resource ,resource))))
+ (prog1 (progn
+ , at body)
+ (free-resource ,resource))))
+
+
+(defmacro with-default-settings (&body body)
+ `(with-transformation ()
+ (with-blend (:mode :blend :r 255 :g 255 :b 255 :a 255)
+ (pal-ffi:gl-load-identity)
+ , at body)))
(defmacro with-blend ((&key (mode t) r g b a) &body body)
`(progn
- (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+))
- ,(unless (eq mode t)
- `(set-blend-mode ,mode))
- ,(when (and r g b a)
- `(set-blend-color ,r ,g ,b ,a))
- , at body
- (pal-ffi:gl-pop-attrib)))
+ (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+))
+ ,(unless (eq mode t)
+ `(set-blend-mode ,mode))
+ ,(when (and r g b a)
+ `(set-blend-color ,r ,g ,b ,a))
+ , at body
+ (pal-ffi:gl-pop-attrib)))
(defmacro with-clipping ((x y width height) &body body)
`(progn
- (push-clip ,x ,y ,width ,height)
- , at body
- (pop-clip)))
+ (push-clip ,x ,y ,width ,height)
+ , at body
+ (pop-clip)))
(defmacro with-transformation ((&key pos angle scale) &body body)
`(progn
- (pal-ffi:gl-push-matrix)
- ,(when pos
- `(translate ,pos))
- ,(when angle
- `(pal-ffi:gl-rotatef ,angle 0f0 0f0 1f0))
- ,(when scale
- (let ((s (gensym)))
- `(let ((,s ,scale))
- (pal-ffi:gl-scalef ,s ,s 1f0))))
- , at body
- (pal-ffi:gl-pop-matrix)))
+ (pal-ffi:gl-push-matrix)
+ ,(when pos
+ `(translate ,pos))
+ ,(when angle
+ `(pal-ffi:gl-rotatef ,angle 0f0 0f0 1f0))
+ ,(when scale
+ (let ((s (gensym)))
+ `(let ((,s ,scale))
+ (pal-ffi:gl-scalef ,s ,s 1f0))))
+ , at body
+ (pal-ffi:gl-pop-matrix)))
(defmacro with-gl (mode &body body)
`(progn
- (pal-ffi:gl-begin ,mode)
- , at body
- (pal-ffi:gl-end)))
+ (pal-ffi:gl-begin ,mode)
+ , at body
+ (pal-ffi:gl-end)))
(defmacro randomly (p &body body)
`(when (= (random ,p) 0)
- , at body))
+ , at body))
(defmacro do-n ((&rest args) &body body)
(labels ((expand (args)
(cond
((null args) `(progn , at body))
(t `(dotimes ,(list (first args) (second args))
- (declare (type fixnum ,(first args)))
- ,(expand (cddr args)))))))
+ (declare (type fixnum ,(first args)))
+ ,(expand (cddr args)))))))
(expand args)))
(defmacro curry (fn &rest args)
(let ((rest (gensym)))
`(lambda (&rest ,rest)
- (declare (dynamic-extent ,rest))
- (apply ,fn , at args ,rest))))
+ (declare (dynamic-extent ,rest))
+ (apply ,fn , at args ,rest))))
(defmacro test-keys (&body args)
`(progn
- ,@(mapcar (lambda (arg)
- `(when ,(if (listp (first arg))
- `(or ,@(mapcar (lambda (a)
- (list 'key-pressed-p a))
- (first arg)))
- `(key-pressed-p ,(first arg)))
- ,@(rest arg)))
- args)))
+ ,@(mapcar (lambda (arg)
+ `(when ,(if (listp (first arg))
+ `(or ,@(mapcar (lambda (a)
+ (list 'key-pressed-p a))
+ (first arg)))
+ `(key-pressed-p ,(first arg)))
+ ,@(rest arg)))
+ args)))
(defmacro funcall? (fn &rest args)
`(when ,fn
- (funcall ,fn , at args)))
+ (funcall ,fn , at args)))
(defmacro do-event (event key-up-fn key-down-fn mouse-motion-fn mouse-button-up-fn mouse-button-down-fn quit-fn)
`(loop while (pal-ffi:poll-event ,event)
- do
- (let ((type (cffi:mem-ref ,event :uint8)))
- (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*)
- nil)
- (funcall? ,key-up-fn
- (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi: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*)
- 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)
- (return-from event-loop)))))
-
- ((= type pal-ffi:+mouse-motion-event+)
- (setf *mouse-x* (cffi:foreign-slot-value ,event 'pal-ffi:mouse-motion-event 'pal-ffi:x)
- *mouse-y* (cffi:foreign-slot-value ,event 'pal-ffi:mouse-motion-event 'pal-ffi:y))
- (funcall? ,mouse-motion-fn *mouse-x* *mouse-y*))
-
- ((= type pal-ffi:+mouse-button-up-event+)
- (let ((button (cffi:foreign-slot-value ,event 'pal-ffi:mouse-button-event 'pal-ffi:button)))
- (setf (gethash (read-from-string (format nil ":key-mouse-~a" button))
- *pressed-keys*) nil)
- (funcall? ,mouse-button-up-fn button)))
-
- ((= type pal-ffi:+mouse-button-down-event+)
- (let ((button (cffi:foreign-slot-value ,event 'pal-ffi:mouse-button-event 'pal-ffi:button) ))
- (setf (gethash (read-from-string (format nil ":key-mouse-~a" button))
- *pressed-keys*) t)
- (funcall? ,mouse-button-down-fn button)))
-
- ((= type pal-ffi:+quit-event+)
- (if ,quit-fn
- (funcall ,quit-fn)
- (return-from event-loop))
- )))))
+ do
+ (let ((type (cffi:mem-ref ,event :uint8)))
+ (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*)
+ nil)
+ (funcall? ,key-up-fn
+ (cffi:foreign-enum-keyword 'pal-ffi:sdl-key (cffi:foreign-slot-value keysym 'pal-ffi:keysym 'pal-ffi: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*)
+ 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)
+ (return-from event-loop)))))
+
+ ((= type pal-ffi:+mouse-motion-event+)
+ (setf *mouse-x* (cffi:foreign-slot-value ,event 'pal-ffi:mouse-motion-event 'pal-ffi:x)
+ *mouse-y* (cffi:foreign-slot-value ,event 'pal-ffi:mouse-motion-event 'pal-ffi:y))
+ (funcall? ,mouse-motion-fn *mouse-x* *mouse-y*))
+
+ ((= type pal-ffi:+mouse-button-up-event+)
+ (let ((button (cffi:foreign-slot-value ,event 'pal-ffi:mouse-button-event 'pal-ffi:button)))
+ (setf (gethash (read-from-string (format nil ":key-mouse-~a" button))
+ *pressed-keys*) nil)
+ (funcall? ,mouse-button-up-fn button)))
+
+ ((= type pal-ffi:+mouse-button-down-event+)
+ (let ((button (cffi:foreign-slot-value ,event 'pal-ffi:mouse-button-event 'pal-ffi:button) ))
+ (setf (gethash (read-from-string (format nil ":key-mouse-~a" button))
+ *pressed-keys*) t)
+ (funcall? ,mouse-button-down-fn button)))
+
+ ((= type pal-ffi:+quit-event+)
+ (if ,quit-fn
+ (funcall ,quit-fn)
+ (return-from event-loop))
+ )))))
(defmacro event-loop ((&key key-up-fn key-down-fn mouse-motion-fn mouse-button-up-fn mouse-button-down-fn quit-fn) &body redraw)
(let ((event (gensym)))
`(block event-loop
- (cffi:with-foreign-object (,event :char 1000)
- (loop
- (do-event ,event ,key-up-fn ,key-down-fn ,mouse-motion-fn ,mouse-button-up-fn ,mouse-button-down-fn ,quit-fn)
- , at redraw
- (update-screen))))))
+ (cffi:with-foreign-object (,event :char 1000)
+ (loop
+ (do-event ,event ,key-up-fn ,key-down-fn ,mouse-motion-fn ,mouse-button-up-fn ,mouse-button-down-fn ,quit-fn)
+ , at redraw
+ (update-screen))))))
(defmacro with-pal (args &body body)
`(progn
- (apply 'open-pal (list , at args))
- (unwind-protect
- (progn , at body)
- (close-pal))))
\ No newline at end of file
+ (apply 'open-pal (list , at args))
+ (unwind-protect
+ (progn , at body)
+ (close-pal))))
\ No newline at end of file
--- /project/pal/cvsroot/pal/pal.lisp 2007/06/28 20:14:05 1.1
+++ /project/pal/cvsroot/pal/pal.lisp 2007/07/01 22:49:25 1.2
@@ -3,7 +3,9 @@
(in-package :pal)
-(defparameter *pal-directory* (make-pathname :directory (pathname-directory *load-pathname*)))
+(defparameter *pal-directory* (make-pathname :directory (pathname-directory *load-pathname*)
+ :host (pathname-host *load-pathname*)
+ :device (pathname-device *load-pathname*)))
(defvar *messages* nil)
(defvar *pal-running* nil)
(defvar *title* "")
@@ -45,7 +47,7 @@
(when *pal-running*
(close-pal))
(pal-ffi:init (logior pal-ffi:+init-video+ pal-ffi:+init-audio+))
- (pal-ffi:open-audio 22050 pal-ffi:+audio-s16+ 2 1024) ;; 4096
+ (pal-ffi:open-audio 22050 pal-ffi:+audio-s16+ 2 2048)
(pal-ffi:gl-set-attribute pal-ffi:+gl-depth-size+ 0)
(pal-ffi:gl-set-attribute pal-ffi:+gl-doublebuffer+ 1)
(when (cffi:null-pointer-p (pal-ffi::set-video-mode
@@ -89,8 +91,8 @@
*width* width
*height* height
*pal-running* t)
- (add-path *default-pathname-defaults*)
(add-path *pal-directory*)
+ (add-path *default-pathname-defaults*)
(if (listp paths)
(dolist (p paths)
(add-path p))
@@ -196,6 +198,15 @@
;; Screen
+(declaim (inline draw-messages))
+(defun draw-messages ()
+ (let ((y 0)
+ (fh (get-font-height)))
+ (declare (type u11 y fh))
+ (dolist (m *messages*)
+ (declare (type simple-string m))
+ (draw-text m (v 0 (incf y fh))))))
+
(declaim (inline update-screen))
(defun update-screen ()
(let ((e (pal-ffi:gl-get-error)))
@@ -210,17 +221,12 @@
(incf *delay* 2))
(pal-ffi:delay *delay*)
(if (or (eq t *cursor*) (eq nil *cursor*))
- nil
- (with-transformation ()
- (with-blend (:mode :blend :r 255 :g 255 :b 255 :a 255)
- (pal-ffi:gl-load-identity)
- (draw-image *cursor* (v- (get-mouse-pos) *cursor-offset*))
- (let ((y 0)
- (fh (get-font-height)))
- (declare (type u11 y fh))
- (dolist (m *messages*)
- (declare (type simple-string m))
- (draw-text m (v 0 (incf y fh))))))))
+ (when *messages*
+ (with-default-settings
+ (draw-messages)))
+ (with-default-settings
+ (draw-image *cursor* (v- (get-mouse-pos) *cursor-offset*))
+ (draw-messages)))
(pal-ffi:gl-swap-buffers))
(declaim (inline get-screen-width))
@@ -362,7 +368,9 @@
(1- height)))
'(6 7 8 9 10)) 10)))
(id (cffi:foreign-alloc :uint :count 1))
- (tdata (cffi:foreign-alloc :uint64 :count (/ (* texture-width texture-height) 2) :initial-element 0)))
+ (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))))))
@@ -637,7 +645,7 @@
(lines (with-open-file (file (data-path (concatenate 'string font ".fnt")))
(loop repeat 4 do (read-line file))
(loop for i from 0 to 94 collecting
- (substitute #\space #\, (subseq (read-line file) 6) :start 1)))))
+ (substitute #\space #\, (subseq (read-line file) 6) :start 1)))))
(dolist (line lines)
(let ((glyph (glyph-from-line line)))
(setf (aref glyphs (char-code (glyph-char glyph)))
@@ -676,7 +684,7 @@
font
(tag 'default-font))))
(loop for c across text do
- (draw-glyph c font)))))
+ (draw-glyph c font)))))
(declaim (inline get-font-height))
(defun get-font-height (&optional font)
@@ -691,8 +699,8 @@
font
(tag 'default-font)))))
(loop for c across text summing
- (+ (glyph-width (aref glyphs (char-code c)))
- (glyph-xoff (aref glyphs (char-code c))))))
+ (+ (glyph-width (aref glyphs (char-code c)))
+ (glyph-xoff (aref glyphs (char-code c))))))
(pal-ffi:font-height (if font
font
(tag 'default-font)))))
--- /project/pal/cvsroot/pal/todo.txt 2007/06/28 20:14:05 1.1
+++ /project/pal/cvsroot/pal/todo.txt 2007/07/01 22:49:25 1.2
@@ -17,6 +17,9 @@
- CL native font resource builder.
-- Fix with-blend (r g b a), message texts in update only when cursor is set,
- Lispworks bugs, see that things work on Allegro CL.
+- 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.
More information about the Pal-cvs
mailing list