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 - ,@body) - (free-resource ,resource)))) + (prog1 (progn + ,@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) + ,@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)) - ,@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)) + ,@body + (pal-ffi:gl-pop-attrib)))

(defmacro with-clipping ((x y width height) &body body) `(progn - (push-clip ,x ,y ,width ,height) - ,@body - (pop-clip))) + (push-clip ,x ,y ,width ,height) + ,@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)))) - ,@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)))) + ,@body + (pal-ffi:gl-pop-matrix)))

(defmacro with-gl (mode &body body) `(progn - (pal-ffi:gl-begin ,mode) - ,@body - (pal-ffi:gl-end))) + (pal-ffi:gl-begin ,mode) + ,@body + (pal-ffi:gl-end)))

(defmacro randomly (p &body body) `(when (= (random ,p) 0) - ,@body)) + ,@body))

(defmacro do-n ((&rest args) &body body) (labels ((expand (args) (cond ((null args) `(progn ,@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 ,@args ,rest)))) + (declare (dynamic-extent ,rest)) + (apply ,fn ,@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 ,@args))) + (funcall ,fn ,@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) - ,@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) + ,@redraw + (update-screen))))))

(defmacro with-pal (args &body body) `(progn - (apply 'open-pal (list ,@args)) - (unwind-protect - (progn ,@body) - (close-pal)))) \ No newline at end of file + (apply 'open-pal (list ,@args)) + (unwind-protect + (progn ,@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.