July 2007 - pal-cvs@common-lisp.net - mailman3.common-lisp.net

[pal-cvs] CVS pal
by tneste 30 Jul '07

30 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv15809 Modified Files: ffi.lisp pal-macros.lisp pal.lisp vector.lisp Log Message: Rest of gl-quad optimisations --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/27 21:25:40 1.15 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/30 10:38:12 1.16 @@ -1,5 +1,5 @@ (declaim (optimize (speed 3) - (safety 3))) + (safety 0))) (in-package :pal-ffi) --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/29 19:11:44 1.11 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/30 10:38:12 1.12 @@ -1,5 +1,5 @@ (declaim (optimize (speed 3) - (safety 3))) + (safety 2))) (in-package :pal) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/29 21:55:24 1.24 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/30 10:38:12 1.25 @@ -4,9 +4,11 @@ ;; fix the fps ;; clean up the do-event ;; check for redundant close-quads, make sure rotations etc. are optimised. +;; newline support for draw-text + (declaim (optimize (speed 3) - (safety 3))) + (safety 2))) (in-package :pal) @@ -505,67 +507,52 @@ array))) -(defunct draw-image (image pos &key (angle 0f0) (scale 1f0) (valign :left) (halign :top)) - (image image vec pos single-float angle single-float scale symbol halign symbol valign) +(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) (set-image image) - (if (and (= angle 0f0) (= scale 1f0) (eq valign :left) (eq halign :top)) - (let* ((tx2 (pal-ffi:image-tx2 image)) - (ty2 (pal-ffi:image-ty2 image)) - (x (vx pos)) - (y (vy pos)) - (width (+ x (image-width image))) - (height (+ y (image-height image)))) - (with-gl pal-ffi:+gl-quads+ - (pal-ffi:gl-tex-coord2f 0f0 0f0) - (pal-ffi:gl-vertex2f x y) - (pal-ffi:gl-tex-coord2f tx2 0f0) - (pal-ffi:gl-vertex2f width y) - (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f width height) - (pal-ffi:gl-tex-coord2f 0f0 ty2) - (pal-ffi:gl-vertex2f x height))) - (let* ((tx2 (pal-ffi:image-tx2 image)) - (ty2 (pal-ffi:image-ty2 image)) - (width (* (image-width image) scale)) - (height (* (image-height image) scale)) - (b (v+ (v-rotate (v width 0) angle) pos)) - (c (v+ (v-rotate (v width height) angle) pos)) - (d (v+ (v-rotate (v 0 height) angle) pos))) - (with-gl pal-ffi:+gl-quads+ - (pal-ffi:gl-tex-coord2f 0f0 0f0) - (pal-ffi:gl-vertex2f (vx pos) (vy pos)) - (pal-ffi:gl-tex-coord2f tx2 0f0) - (pal-ffi:gl-vertex2f (vx b) (vy b)) - (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f (vx c) (vy c)) - (pal-ffi:gl-tex-coord2f 0f0 ty2) - (pal-ffi:gl-vertex2f (vx d) (vy d)))) - ;; (with-transformation () - ;; (translate pos) - ;; (when angle - ;; (rotate angle)) - ;; (when scale - ;; (scale scale scale)) ;; :-) - ;; (let ((x (case halign - ;; (:right (coerce (- width) 'single-float)) - ;; (:left 0f0) - ;; (:middle (- (/ width 2f0))) - ;; (otherwise 0f0))) - ;; (y (case valign - ;; (:bottom (coerce (- height) 'single-float)) - ;; (:top 0f0) - ;; (:middle (- (/ height 2f0))) - ;; (otherwise 0f0)))) - ;; (with-gl pal-ffi:+gl-quads+ - ;; (pal-ffi:gl-tex-coord2f 0f0 0f0) - ;; (pal-ffi:gl-vertex2f x y) - ;; (pal-ffi:gl-tex-coord2f tx2 0f0) - ;; (pal-ffi:gl-vertex2f (+ x width) y) - ;; (pal-ffi:gl-tex-coord2f tx2 ty2) - ;; (pal-ffi:gl-vertex2f (+ x width) (+ y height)) - ;; (pal-ffi:gl-tex-coord2f 0f0 ty2) - ;; (pal-ffi:gl-vertex2f x (+ y height))))) - )) + (let ((width (image-width image)) + (height (image-height image)) + (tx2 (pal-ffi:image-tx2 image)) + (ty2 (pal-ffi:image-ty2 image))) + (if (or angle scale valign halign) + (with-transformation () + (translate pos) + (when angle + (rotate angle)) + (when scale + (scale scale scale)) ;; :-) + (let ((x (case halign + (:right (coerce (- width) 'single-float)) + (:left 0f0) + (:middle (- (/ width 2f0))) + (otherwise 0f0))) + (y (case valign + (:bottom (coerce (- height) 'single-float)) + (:top 0f0) + (:middle (- (/ height 2f0))) + (otherwise 0f0)))) + (with-gl pal-ffi:+gl-quads+ + (pal-ffi:gl-tex-coord2f 0f0 0f0) + (pal-ffi:gl-vertex2f x y) + (pal-ffi:gl-tex-coord2f tx2 0f0) + (pal-ffi:gl-vertex2f (+ x width) y) + (pal-ffi:gl-tex-coord2f tx2 ty2) + (pal-ffi:gl-vertex2f (+ x width) (+ y height)) + (pal-ffi:gl-tex-coord2f 0f0 ty2) + (pal-ffi:gl-vertex2f x (+ y height))))) + (let* ((x (vx pos)) + (y (vy pos)) + (width (+ x width)) + (height (+ y height))) + (with-gl pal-ffi:+gl-quads+ + (pal-ffi:gl-tex-coord2f 0f0 0f0) + (pal-ffi:gl-vertex2f x y) + (pal-ffi:gl-tex-coord2f tx2 0f0) + (pal-ffi:gl-vertex2f width y) + (pal-ffi:gl-tex-coord2f tx2 ty2) + (pal-ffi:gl-vertex2f width height) + (pal-ffi:gl-tex-coord2f 0f0 ty2) + (pal-ffi:gl-vertex2f x height)))))) (defunct draw-image* (image from-pos to-pos width height) @@ -573,21 +560,23 @@ (set-image image) (let* ((vx (vx from-pos)) (vy (vy from-pos)) - (vx-to (vx to-pos)) - (vy-to (vy to-pos)) + (x1 (vx to-pos)) + (y1 (vy to-pos)) + (x2 (+ x1 width)) + (y2 (+ y1 height)) (tx1 (/ vx (pal-ffi:image-texture-width image))) (ty1 (/ vy (pal-ffi:image-texture-height image))) (tx2 (/ (+ vx width) (pal-ffi:image-texture-width image))) (ty2 (/ (+ vy height) (pal-ffi:image-texture-height image)))) (with-gl pal-ffi:+gl-quads+ (pal-ffi:gl-tex-coord2f tx1 ty1) - (pal-ffi:gl-vertex2f vx-to vy-to) + (pal-ffi:gl-vertex2f x1 y1) (pal-ffi:gl-tex-coord2f tx2 ty1) - (pal-ffi:gl-vertex2f (+ vx-to width) vy-to) + (pal-ffi:gl-vertex2f x2 y1) (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f (+ vx-to width) (+ vy-to height)) + (pal-ffi:gl-vertex2f x2 y2) (pal-ffi:gl-tex-coord2f tx1 ty2) - (pal-ffi:gl-vertex2f vx-to (+ vy-to height))))) + (pal-ffi:gl-vertex2f x1 y2)))) (declaim (inline draw-line)) (defunct draw-line (la lb r g b a &key (size 1.0f0) (smoothp)) --- /project/pal/cvsroot/pal/vector.lisp 2007/07/29 21:53:52 1.6 +++ /project/pal/cvsroot/pal/vector.lisp 2007/07/30 10:38:12 1.7 @@ -1,5 +1,5 @@ (declaim (optimize (speed 3) - (safety 3))) + (safety 2))) (in-package :pal)

1 0

[pal-cvs] CVS pal/examples
by tneste 30 Jul '07

30 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv15809/examples Modified Files: hares.lisp Log Message: Rest of gl-quad optimisations --- /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/29 19:11:44 1.6 +++ /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/30 10:38:11 1.7 @@ -54,7 +54,7 @@ (defun example () - (with-pal (:width 800 :height 600 :fullscreenp t :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:width 800 :height 600 :fullscreenp nil :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) (setf *sprites* nil) (set-cursor nil) (dotimes (i 500)

1 0

[pal-cvs] CVS pal
by tneste 29 Jul '07

29 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv22662 Modified Files: pal.lisp Log Message: More gl-begin optimisations, ALIGN keywords currently broken. --- /project/pal/cvsroot/pal/pal.lisp 2007/07/29 19:11:44 1.23 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/29 21:55:24 1.24 @@ -1,9 +1,9 @@ ;; Notes: -;; smoothed polygons, guess circle segment count, add start/end args to draw-circle +;; 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. (declaim (optimize (speed 3) (safety 3))) @@ -105,7 +105,6 @@ (clear-screen 0 0 0) (reset-tags) (define-tags default-font (load-font "default-font")) - (add-path *pal-directory*) (add-path *default-pathname-defaults*) (if (listp paths) @@ -505,52 +504,68 @@ 3)))))) array))) -(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) + +(defunct draw-image (image pos &key (angle 0f0) (scale 1f0) (valign :left) (halign :top)) + (image image vec pos single-float angle single-float scale symbol halign symbol valign) (set-image image) - (let ((width (image-width image)) - (height (image-height image)) - (tx2 (pal-ffi:image-tx2 image)) - (ty2 (pal-ffi:image-ty2 image))) - (if (or angle scale valign halign) - (with-transformation () - (translate pos) - (when angle - (rotate angle)) - (when scale - (scale scale scale)) ;; :-) - (let ((x (case halign - (:right (coerce (- width) 'single-float)) - (:left 0f0) - (:middle (- (/ width 2f0))) - (otherwise 0f0))) - (y (case valign - (:bottom (coerce (- height) 'single-float)) - (:top 0f0) - (:middle (- (/ height 2f0))) - (otherwise 0f0)))) - (with-gl pal-ffi:+gl-quads+ - (pal-ffi:gl-tex-coord2f 0f0 0f0) - (pal-ffi:gl-vertex2f x y) - (pal-ffi:gl-tex-coord2f tx2 0f0) - (pal-ffi:gl-vertex2f (+ x width) y) - (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f (+ x width) (+ y height)) - (pal-ffi:gl-tex-coord2f 0f0 ty2) - (pal-ffi:gl-vertex2f x (+ y height))))) - (let* ((x (vx pos)) - (y (vy pos)) - (width (+ x width)) - (height (+ y height))) - (with-gl pal-ffi:+gl-quads+ - (pal-ffi:gl-tex-coord2f 0f0 0f0) - (pal-ffi:gl-vertex2f x y) - (pal-ffi:gl-tex-coord2f tx2 0f0) - (pal-ffi:gl-vertex2f width y) - (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f width height) - (pal-ffi:gl-tex-coord2f 0f0 ty2) - (pal-ffi:gl-vertex2f x height)))))) + (if (and (= angle 0f0) (= scale 1f0) (eq valign :left) (eq halign :top)) + (let* ((tx2 (pal-ffi:image-tx2 image)) + (ty2 (pal-ffi:image-ty2 image)) + (x (vx pos)) + (y (vy pos)) + (width (+ x (image-width image))) + (height (+ y (image-height image)))) + (with-gl pal-ffi:+gl-quads+ + (pal-ffi:gl-tex-coord2f 0f0 0f0) + (pal-ffi:gl-vertex2f x y) + (pal-ffi:gl-tex-coord2f tx2 0f0) + (pal-ffi:gl-vertex2f width y) + (pal-ffi:gl-tex-coord2f tx2 ty2) + (pal-ffi:gl-vertex2f width height) + (pal-ffi:gl-tex-coord2f 0f0 ty2) + (pal-ffi:gl-vertex2f x height))) + (let* ((tx2 (pal-ffi:image-tx2 image)) + (ty2 (pal-ffi:image-ty2 image)) + (width (* (image-width image) scale)) + (height (* (image-height image) scale)) + (b (v+ (v-rotate (v width 0) angle) pos)) + (c (v+ (v-rotate (v width height) angle) pos)) + (d (v+ (v-rotate (v 0 height) angle) pos))) + (with-gl pal-ffi:+gl-quads+ + (pal-ffi:gl-tex-coord2f 0f0 0f0) + (pal-ffi:gl-vertex2f (vx pos) (vy pos)) + (pal-ffi:gl-tex-coord2f tx2 0f0) + (pal-ffi:gl-vertex2f (vx b) (vy b)) + (pal-ffi:gl-tex-coord2f tx2 ty2) + (pal-ffi:gl-vertex2f (vx c) (vy c)) + (pal-ffi:gl-tex-coord2f 0f0 ty2) + (pal-ffi:gl-vertex2f (vx d) (vy d)))) + ;; (with-transformation () + ;; (translate pos) + ;; (when angle + ;; (rotate angle)) + ;; (when scale + ;; (scale scale scale)) ;; :-) + ;; (let ((x (case halign + ;; (:right (coerce (- width) 'single-float)) + ;; (:left 0f0) + ;; (:middle (- (/ width 2f0))) + ;; (otherwise 0f0))) + ;; (y (case valign + ;; (:bottom (coerce (- height) 'single-float)) + ;; (:top 0f0) + ;; (:middle (- (/ height 2f0))) + ;; (otherwise 0f0)))) + ;; (with-gl pal-ffi:+gl-quads+ + ;; (pal-ffi:gl-tex-coord2f 0f0 0f0) + ;; (pal-ffi:gl-vertex2f x y) + ;; (pal-ffi:gl-tex-coord2f tx2 0f0) + ;; (pal-ffi:gl-vertex2f (+ x width) y) + ;; (pal-ffi:gl-tex-coord2f tx2 ty2) + ;; (pal-ffi:gl-vertex2f (+ x width) (+ y height)) + ;; (pal-ffi:gl-tex-coord2f 0f0 ty2) + ;; (pal-ffi:gl-vertex2f x (+ y height))))) + )) (defunct draw-image* (image from-pos to-pos width height)

1 0

[pal-cvs] CVS pal/examples
by tneste 29 Jul '07

29 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv22662/examples Modified Files: teddy.lisp Log Message: More gl-begin optimisations, ALIGN keywords currently broken. --- /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/29 19:11:44 1.6 +++ /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/29 21:55:23 1.7 @@ -80,7 +80,7 @@ (defun example () - (with-pal (:fullscreenp nil :width 800 :height 600 :fullscreenp nil :fps 60 :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:fullscreenp nil :width 800 :height 600 :fps 60 :paths (merge-pathnames "examples/" pal::*pal-directory*)) ;; inits PAL, the args used are the default values. ;; PATHS is a pathname or list of pathnames that PAL uses to find the resource files loaded with LOAD-* functions. ;; By default PATHS contains the PAL source directory and value of *default-pathname-defaults*

1 0

[pal-cvs] CVS pal
by tneste 29 Jul '07

29 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv22308 Modified Files: package.lisp vector.lisp Log Message: Mnor cleanups and name changes: circles-overlap => circles-overlap-p, point-inside-rectangle => point-inside-rectangle-p, point-in-line => point-in-line-p. --- /project/pal/cvsroot/pal/package.lisp 2007/07/27 21:25:40 1.13 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/29 21:53:52 1.14 @@ -454,6 +454,6 @@ #:v+ #:v+! #:v- #:v-! #:v* #:v*! #:v/ #:v/! #:v-max #:v-min #:v-rotate #:v-dot #:v-magnitude #:v-normalize #:v-distance #:v-truncate #:v-direction - #:closest-point-to-line #:point-in-line #:lines-intersection - #:distance-from-line #:circle-line-intersection #:point-inside-rectangle - #:circles-overlap #:point-inside-circle)) \ No newline at end of file + #:closest-point-to-line #:point-in-line-p #:lines-intersection + #:distance-from-line #:circle-line-intersection #:point-inside-rectangle-p + #:circles-overlap-p #:point-inside-circle-p)) \ No newline at end of file --- /project/pal/cvsroot/pal/vector.lisp 2007/07/21 16:34:16 1.5 +++ /project/pal/cvsroot/pal/vector.lisp 2007/07/29 21:53:52 1.6 @@ -9,6 +9,7 @@ (defstruct (vec (:conc-name v)) (x 0 :type component) (y 0 :type component)) + (declaim (inline component)) (defunct component (x) (number x) @@ -28,19 +29,19 @@ (declaim (inline rad)) (defunct rad (degrees) - (number degrees) - (component (* (/ pi 180) degrees))) + (component degrees) + (* (/ pi 180) degrees)) (declaim (inline deg)) (defunct deg (radians) - (number radians) - (component (* (/ 180 pi) radians))) + (component radians) + (* (/ 180 pi) radians)) (declaim (inline angle-v)) (defunct angle-v (angle) - (number angle) + (component angle) (v (sin (rad angle)) (- (cos (rad angle))))) (declaim (inline vec-angle)) @@ -145,10 +146,10 @@ (defunct v-rotate (v a) (vec v component a) (let ((a (rad a))) - (vf (- (* (cos a) (vx v)) - (* (sin a) (vy v))) - (+ (* (sin a) (vx v)) - (* (cos a) (vy v)))))) + (v (- (* (cos a) (vx v)) + (* (sin a) (vy v))) + (+ (* (sin a) (vx v)) + (* (cos a) (vy v)))))) (declaim (inline v-dot)) (defunct v-dot (a b) @@ -166,10 +167,11 @@ (defunct v-normalize (v) (vec v) - (if (/= (v-magnitude v) 0.0) - (vf (/ (vx v) (v-magnitude v)) - (/ (vy v) (v-magnitude v))) - (vf 0.0 0.0))) + (let ((m (v-magnitude v))) + (if (/= m 0f0) + (vf (/ (vx v) m) + (/ (vy v) m)) + (vf 0f0 0f0)))) (defunct v-direction (from-vector to-vector) (vec from-vector vec to-vector) @@ -201,7 +203,7 @@ b) a))))) -(defunct point-in-line (a b p) +(defunct point-in-line-p (a b p) (vec a vec b vec p) (let ((d (v-direction a b))) (if (< (abs (+ (v-dot d (v-direction a p)) @@ -229,8 +231,8 @@ nil (let ((p (vf (/ (- (* b1 c2) (* b2 c1)) denom) (/ (- (* a2 c1) (* a1 c2)) denom)))) - (if (and (point-in-line la1 la2 p) - (point-in-line lb1 lb2 p)) + (if (and (point-in-line-p la1 la2 p) + (point-in-line-p lb1 lb2 p)) p nil)))))) @@ -250,24 +252,24 @@ (v-distance cp p) nil))) -(defunct point-inside-rectangle (topleft width height pos) - (vec topleft vec pos component width component height) +(defunct point-inside-rectangle-p (topleft width height point) + (vec topleft vec point component width component height) (let* ((x1 (vx topleft)) (y1 (vy topleft)) (x2 (+ x1 width)) (y2 (+ y1 height)) - (x (vx pos)) - (y (vy pos))) + (x (vx point)) + (y (vy point))) (if (and (> x x1) (< x x2) (> y y1) (< y y2)) t nil))) -(declaim (inline point-inside-circle)) -(defunct point-inside-circle (co r p) +(declaim (inline point-inside-circle-p)) +(defunct point-inside-circle-p (co r p) (vec co vec p component r) (<= (v-distance co p) r)) -(declaim (inline circles-overlap)) -(defunct circles-overlap (c1 r1 c2 r2) +(declaim (inline circles-overlap-p)) +(defunct circles-overlap-p (c1 r1 c2 r2) (vec c1 vec c2 component r1 component r2) (<= (v-distance c1 c2) (+ r2 r1))) \ No newline at end of file

1 0

[pal-cvs] CVS pal
by tneste 29 Jul '07

29 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv8365 Modified Files: pal-macros.lisp pal.lisp Log Message: Eliminated some of the unnecessary gl-begins. --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/24 12:55:06 1.10 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/29 19:11:44 1.11 @@ -79,6 +79,7 @@ (defmacro with-blend ((&key (mode t) color) &body body) `(progn + (close-quads) (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)) @@ -86,6 +87,7 @@ `(set-blend-color (first ,color) (second ,color) (third ,color) (fourth ,color))) (prog1 (progn ,@body) + (close-quads) (pal-ffi:gl-pop-attrib)))) (defmacro with-clipping ((x y width height) &body body) @@ -97,6 +99,7 @@ (defmacro with-transformation ((&key pos angle scale) &body body) `(progn + (close-quads) (pal-ffi:gl-push-matrix) ,(when pos `(translate ,pos)) @@ -108,16 +111,23 @@ (scale ,s ,s)))) (prog1 (progn ,@body) + (close-quads) (pal-ffi:gl-pop-matrix)))) (defmacro with-gl (mode &body body) - `(progn - (pal-ffi:gl-begin ,mode) - ,@body - (pal-ffi:gl-end))) + (if (eq mode 'pal-ffi:+gl-quads+) + `(progn + (open-quads) + ,@body) + `(progn + (close-quads) + (pal-ffi:gl-begin ,mode) + ,@body + (pal-ffi:gl-end)))) (defmacro with-line-settings (smoothp size r g b a &body body) `(progn + (close-quads) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (set-blend-color ,r ,g ,b ,a) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/27 22:48:40 1.22 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/29 19:11:44 1.23 @@ -3,7 +3,6 @@ ;; calculate max-texture-size ;; fix the fps ;; clean up the do-event -;; open quads and other optimisations (declaim (optimize (speed 3) @@ -33,6 +32,8 @@ (defvar *mouse-y* 0) (defvar *current-image* nil) (defvar *max-texture-size* 0) +(defvar *quads-open* nil) + (declaim (type list *messages*) (type list *clip-stack*) @@ -47,6 +48,7 @@ (type fixnum *fps*) (type u11 *max-fps*) (type u11 *delay*) + (type boolean *quads-open*) (type (or boolean image) *cursor*) (type (or boolean image) *current-image*)) @@ -79,6 +81,7 @@ *max-fps* (truncate 1000 fps) *ticks* (pal-ffi:get-tick) *clip-stack* nil + *quads-open* nil *fps* 1 *delay* 0 *new-fps* 0 @@ -220,10 +223,10 @@ (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) @@ -239,7 +242,6 @@ (with-default-settings (draw-image *cursor* (v- (get-mouse-pos) *cursor-offset*)) (draw-messages))) - (pal-ffi:gl-swap-buffers)) (declaim (inline get-screen-width)) @@ -257,6 +259,7 @@ (declaim (inline clear-screen)) (defunct clear-screen (r g b) (u8 r u8 g u8 b) + (close-quads) (pal-ffi:gl-clear-color (/ r 255f0) (/ g 255f0) (/ b 255f0) @@ -286,11 +289,13 @@ (defunct push-clip (x y width height) (u16 x u16 y u16 width u16 height) + (close-quads) (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*)) (defun pop-clip () + (close-quads) (pop *clip-stack*) (if *clip-stack* (let ((r (first *clip-stack*))) @@ -302,9 +307,23 @@ ;; State + +(declaim (inline open-quads)) +(defun open-quads () + (unless *quads-open* + (pal-ffi:gl-begin pal-ffi:+gl-quads+) + (setf *quads-open* t))) + +(declaim (inline close-quads)) +(defun close-quads () + (when *quads-open* + (pal-ffi:gl-end) + (setf *quads-open* nil))) + (declaim (inline set-blend-mode)) (defunct set-blend-mode (mode) (symbol mode) + (close-quads) (case mode ((nil) (pal-ffi:gl-disable pal-ffi:+gl-blend+)) (:blend (pal-ffi:gl-enable pal-ffi:+gl-blend+) @@ -315,20 +334,24 @@ (declaim (inline rotate)) (defunct rotate (angle) (single-float angle) + (close-quads) (pal-ffi:gl-rotatef angle 0f0 0f0 1f0)) (declaim (inline scale)) (defunct scale (x y) (single-float x single-float y) + (close-quads) (pal-ffi:gl-scalef x y 1f0)) (declaim (inline translate)) (defunct translate (vec) (vec vec) + (close-quads) (pal-ffi:gl-translatef (vx vec) (vy vec) 0f0)) (declaim (inline reset-blend-mode)) (defun reset-blend-mode () + (close-quads) (set-blend-mode :blend) (set-blend-color 255 255 255 255)) @@ -341,12 +364,12 @@ (defunct set-image (image) (image image) (unless (eq image *current-image*) + (close-quads) (setf *current-image* image) (pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (pal-ffi::image-texture image)))) - ;; Images (defun surface-get-pixel (image x y) @@ -385,6 +408,7 @@ (fourth pixel)))))) (defun image-from-fn (width height smoothp fn) + (close-quads) (let* ((mode pal-ffi:+gl-rgb+) (width (min 1024 width)) (height (min 1024 height)) @@ -452,6 +476,7 @@ (defunct screen-to-array (pos width height) (vec pos u16 width u16 height) + (close-quads) (let* ((x (truncate (vx pos))) (y (truncate (vy pos))) (rowsize (* width 4)) @@ -480,7 +505,6 @@ 3)))))) array))) - (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) (set-image image) @@ -514,17 +538,19 @@ (pal-ffi:gl-vertex2f (+ x width) (+ y height)) (pal-ffi:gl-tex-coord2f 0f0 ty2) (pal-ffi:gl-vertex2f x (+ y height))))) - (let ((x (vx pos)) - (y (vy pos))) + (let* ((x (vx pos)) + (y (vy pos)) + (width (+ x width)) + (height (+ y height))) (with-gl pal-ffi:+gl-quads+ (pal-ffi:gl-tex-coord2f 0f0 0f0) (pal-ffi:gl-vertex2f x y) (pal-ffi:gl-tex-coord2f tx2 0f0) - (pal-ffi:gl-vertex2f (+ x width) y) + (pal-ffi:gl-vertex2f width y) (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f (+ x width) (+ y height)) + (pal-ffi:gl-vertex2f width height) (pal-ffi:gl-tex-coord2f 0f0 ty2) - (pal-ffi:gl-vertex2f x (+ y height))))))) + (pal-ffi:gl-vertex2f x height)))))) (defunct draw-image* (image from-pos to-pos width height) @@ -577,6 +603,7 @@ (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) + (close-quads) (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 @@ -607,6 +634,7 @@ (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height)) (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height))))) (t + (close-quads) (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+) (pal-ffi:gl-color4ub r g b a) @@ -617,6 +645,7 @@ (list points u8 r u8 g u8 b u8 a (or image boolean) fill single-float size) (cond ((image-p fill) + (close-quads) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+)) (set-image fill) (pal-ffi:gl-color4ub r g b a) @@ -643,6 +672,7 @@ (dolist (p points) (pal-ffi:gl-vertex2f (vx p) (vy p)))))) (t + (close-quads) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) (pal-ffi:gl-color4ub r g b a) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) @@ -653,6 +683,7 @@ (defunct draw-polygon* (points &key image tex-coords colors) (list points list tex-coords list colors (or boolean image) image) + (close-quads) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) (cond ((and image tex-coords)

1 0

[pal-cvs] CVS pal/examples
by tneste 29 Jul '07

29 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv8365/examples Modified Files: hares.lisp images.lisp teddy.lisp Log Message: Eliminated some of the unnecessary gl-begins. --- /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/28 13:13:17 1.5 +++ /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/29 19:11:44 1.6 @@ -16,7 +16,6 @@ (defclass sprite () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (vel :accessor vel-of :initarg :vel :initform (v 0 0)) - (image :accessor image-of :initarg :image) (angle :accessor angle-of :initarg :angle :initform 0) (r :accessor r-of :initarg :r) (g :accessor g-of :initarg :g) @@ -29,12 +28,14 @@ (defmethod draw ((s sprite)) (set-blend-color (r-of s) (g-of s) (b-of s) 255) - (draw-image (image-of s) - (pos-of s) + (draw-image (tag 'hare) + (v- (pos-of s) (v* (v (image-width (tag 'hare)) + (image-height (tag 'hare))) + (* (scale-of s) .5))) :halign :middle :valign :middle - :angle (angle-of s) - :scale (scale-of s))) + :scale (scale-of s) + :angle (angle-of s))) (defmethod act ((s sprite)) (setf (angle-of s) (mod (+ (angle-of s) 1) 360)) @@ -53,13 +54,12 @@ (defun example () - (with-pal (:width 800 :height 600 :fullscreenp nil :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:width 800 :height 600 :fullscreenp t :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) (setf *sprites* nil) (set-cursor nil) (dotimes (i 500) (make-instance 'sprite - :image (tag 'hare) - :scaled (- (random .2) .1) + :scaled (- (random .1) .05) :scale (+ (random 1.5) .5) :r (random 255) :g (random 255) --- /project/pal/cvsroot/pal/examples/images.lisp 2007/07/27 22:48:40 1.6 +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/07/29 19:11:44 1.7 @@ -29,7 +29,8 @@ (with-pal (:paths (merge-pathnames "examples/" pal::*pal-directory*)) - (set-cursor (tag 'image-3)) ;; sets image-3 as a mouse cursor image + (set-cursor (tag 'image-3)) + ;; sets image-3 as a mouse cursor image (let ((a 0)) (event-loop () (draw-polygon* (list (v 0 0) --- /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/27 20:12:12 1.5 +++ /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/29 19:11:44 1.6 @@ -44,8 +44,8 @@ (defmethod act ((s sprite)) (v+! (pos-of s) (vel-of s)) - (v*! (vel-of s) .90) - (v*! (vel-of s) .90)) + (v*! (vel-of s) .98) + (v*! (vel-of s) .98)) (defmethod draw ((s sprite)) (draw-image (image-of s)

1 0

[pal-cvs] CVS pal/examples
by tneste 28 Jul '07

28 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv3114/examples Modified Files: hares.lisp Log Message: --- /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/21 16:34:16 1.4 +++ /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/28 13:13:17 1.5 @@ -71,11 +71,7 @@ (event-loop () - (draw-image* (tag 'bg) - (v 0 0) - (v 0 0) - (get-screen-width) - (get-screen-height)) + (draw-rectangle (v 0 0) 800 600 255 255 255 255 :fill (tag 'bg)) (with-blend (:mode *blend-mode*) (dolist (i *sprites*) (draw i)

1 0

[pal-cvs] CVS pal
by tneste 28 Jul '07

28 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv3114 Modified Files: changes.txt todo.txt Log Message: --- /project/pal/cvsroot/pal/changes.txt 2007/07/03 19:17:57 1.2 +++ /project/pal/cvsroot/pal/changes.txt 2007/07/28 13:13:15 1.3 @@ -1,3 +1,31 @@ +1.0, July 28 2007 + +- Numerous bugfixes and little improvements. + +- Much faster DRAW-TEXT. + +- Removed DRAW-QUAD in favour of DRAW-POLYGON* + +- Added ALIGN arguments to DRAW-IMAGE + +- DRAW-IMAGE-PART renamed to DRAW-IMAGE* + +- Added some examples. + +- Automatic coersion of numeric types. + +- RELT renamed to RANDOM-ELEMENT. + +- Added DRAW-ARROW, DRAW-CIRCLE, LOAD-IMAGE-TO-ARRAY, SCREEN-TO-ARRAY, IMAGE-FROM-FN. + +- Tag thunks must now return only objects of type RESOURCE. + +- Many small and not so small changes in the API. + +- Fixed problems loading the foreign .so's under Linux. + + + Release 3, July 3 2007 - Changed some of the parameters to sound functions. Volume is now defined as a --- /project/pal/cvsroot/pal/todo.txt 2007/07/27 20:12:14 1.14 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/28 13:13:15 1.15 @@ -2,9 +2,7 @@ - Add align, scale and angle options to DRAW-IMAGE*. -- Implement image mirroring. - -- Image tiles and animation. +- Implement image mirroring, tiles and animation. - Add more complex sound/music handling functions, channel set volume/dir, fade/etc. music.

1 0

[pal-cvs] CVS pal
by tneste 27 Jul '07

27 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv15516 Modified Files: pal.lisp Log Message: Cleaned up and fixed SCREEN-TO-ARRAY --- /project/pal/cvsroot/pal/pal.lisp 2007/07/27 21:25:40 1.21 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/27 22:48:40 1.22 @@ -452,24 +452,32 @@ (defunct screen-to-array (pos width 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)) - (- *height* (truncate (vy pos)) height) + (let* ((x (truncate (vx pos))) + (y (truncate (vy pos))) + (rowsize (* width 4)) + (array (make-array (list width height)))) + (cffi:with-foreign-object (image :unsigned-char (* (1+ width) (1+ height) 4)) + (pal-ffi:gl-read-pixels x + (- *height* y height) width height - pal-ffi:+gl-rgb+ pal-ffi:+gl-unsigned-byte+ + pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ image) (do-n (x width y height) - (setf (aref array x (- height y 1)) - (list (cffi:mem-aref image :unsigned-char (+ (* y width 3) - (* x 3))) - (cffi:mem-aref image :unsigned-char (+ (* y width 3) - (* x 3) - 1)) - (cffi:mem-aref image :unsigned-char (+ (* y width 3) - (* x 3) - 2)) - 255))) + (let ((yrow (* y rowsize))) + (declare (type fixnum yrow)) + (setf (aref array x (- height y 1)) + (list (cffi:mem-aref image :unsigned-char (+ yrow + (* x 4) + 0)) + (cffi:mem-aref image :unsigned-char (+ yrow + (* x 4) + 1)) + (cffi:mem-aref image :unsigned-char (+ yrow + (* x 4) + 2)) + (cffi:mem-aref image :unsigned-char (+ yrow + (* x 4) + 3)))))) array))) @@ -596,10 +604,7 @@ (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+))

1 0

[pal-cvs] CVS pal/examples
by tneste 27 Jul '07

27 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv15516/examples Modified Files: images.lisp Log Message: Cleaned up and fixed SCREEN-TO-ARRAY --- /project/pal/cvsroot/pal/examples/images.lisp 2007/07/21 16:34:16 1.5 +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/07/27 22:48:40 1.6 @@ -39,7 +39,8 @@ :colors (list (list 255 0 0 255) (list 255 0 0 255) (list 0 0 255 255) - (list 0 0 255 255))) ;; just draws a nice gradient background + (list 0 0 255 255))) + ;; just draws a nice gradient background ;; And draw a pattern of image-1s on the top of it. Not exactly seamless tiles but hey... (draw-rectangle (v 0 0) 800 600 255 255 255 255 :fill (tag 'image-1)) @@ -52,6 +53,7 @@ :halign :middle :angle (incf a .1))) + ;; Press left mousebutton to capture part of the screen as a new cursor (when (key-pressed-p :key-mouse-1) (set-cursor (image-from-array

1 0

[pal-cvs] CVS pal/examples
by tneste 27 Jul '07

27 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv23927/examples Modified Files: hello.lisp Log Message: Much faster DRAW-TEXT. Removed display-lists --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/21 16:34:16 1.8 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/27 21:25:40 1.9 @@ -36,4 +36,18 @@ (pal:with-transformation (:pos (pal:v 400 300) :angle (incf angle 1) :scale 3) (pal:draw-text "Hello from PAL" (pal:v 0 0))))))) -;; (hello-2) \ No newline at end of file +;; (hello-2) + + +(defun hello-3 () + (pal:with-pal (:fps 10000) + (pal:event-loop () + (pal:clear-screen 0 0 0) + (loop for x from 0 to 800 by (pal:get-text-size "Hello from PAL") + do + (loop for y from 20 to 600 by 10 + do + (pal:draw-text "Hello from PAL" (pal:v x y)))) + (pal:draw-fps)))) + +;; (hello-3) \ No newline at end of file

1 0

[pal-cvs] CVS pal
by tneste 27 Jul '07

27 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv23927 Modified Files: ffi.lisp package.lisp pal.lisp Log Message: Much faster DRAW-TEXT. Removed display-lists --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/27 20:12:13 1.14 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/27 21:25:40 1.15 @@ -438,8 +438,7 @@ (defstruct font (image nil :type (or boolean image)) (glyphs nil :type (or boolean (simple-vector 255))) - (height 0 :type u11) - (first-dl 0 :type u11)) + (height 0 :type u11)) (defstruct music music) @@ -478,7 +477,6 @@ (defmethod free-resource ((resource font)) (when (font-image resource) (free-resource (font-image resource)) - (gl-delete-lists (font-first-dl resource) 255) (setf (font-image resource) nil))) (defmethod free-resource ((resource image)) @@ -849,22 +847,6 @@ (cffi:defcfun ("glGetError" gl-get-error) :int) -(cffi:defcfun ("glGenLists" gl-gen-lists) :uint - (range :int)) - -(cffi:defcfun ("glNewList" gl-new-list) :void - (n :uint) - (mode :int)) - -(cffi:defcfun ("glEndList" gl-end-list) :void) - -(cffi:defcfun ("glCallList" gl-call-list) :void - (n :uint)) - -(cffi:defcfun ("glDeleteLists" gl-delete-lists) :void - (list :uint) - (range :int)) - (cffi:defcfun ("glGetIntegerv" %gl-get-integer) :void (value :int) (data :pointer)) --- /project/pal/cvsroot/pal/package.lisp 2007/07/24 12:55:06 1.12 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/27 21:25:40 1.13 @@ -15,12 +15,6 @@ #:+gl-smooth+ #:+gl-compile+ #:+gl-points+ - #:gl-gen-lists - #:gl-new-list - #:font-first-dl - #:gl-end-list - #:gl-call-list - #:gl-delete-lists #:free #:calloc #:music-music --- /project/pal/cvsroot/pal/pal.lisp 2007/07/27 20:12:14 1.20 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/27 21:25:40 1.21 @@ -1,10 +1,9 @@ ;; Notes: -;; smoothed polygons, guess circle segment count +;; smoothed polygons, guess circle segment count, add start/end args to draw-circle ;; calculate max-texture-size ;; fix the fps ;; clean up the do-event ;; open quads and other optimisations -;; test with latest sdl libs (declaim (optimize (speed 3) @@ -769,16 +768,8 @@ glyph))) (let ((font (pal-ffi:register-resource (pal-ffi:make-font :image (load-image (concatenate 'string font ".png")) :height (glyph-height (aref glyphs 32)) - :first-dl (pal-ffi:gl-gen-lists 255) :glyphs glyphs)))) (set-image (pal-ffi:font-image font)) - (loop - for g across (pal-ffi:font-glyphs font) - for dl from 0 to 255 - do - (pal-ffi:gl-new-list (+ (pal-ffi:font-first-dl font) dl) pal-ffi:+gl-compile+) - (draw-glyph (pal-ffi:font-image font) g) - (pal-ffi:gl-end-list)) font))) (defun glyph-from-line (line) @@ -791,36 +782,38 @@ :height (fourth coords) :xoff (sixth coords)))) -(defun draw-glyph (image g) +(defun draw-glyph (x height image g) + (declare (type single-float x height) (type image image) (type glyph g)) (let* ((vx (vx (glyph-pos g))) (vy (vy (glyph-pos g))) (width (coerce (glyph-width g) 'single-float)) - (height (coerce (glyph-height g) 'single-float)) (tx1 (/ vx (pal-ffi:image-texture-width image))) (ty1 (/ vy (pal-ffi:image-texture-height image))) (tx2 (/ (+ vx width) (pal-ffi:image-texture-width image))) (ty2 (/ (+ vy height) (pal-ffi:image-texture-height image)))) - (with-gl pal-ffi:+gl-quads+ - (pal-ffi:gl-tex-coord2f tx1 ty1) - (pal-ffi:gl-vertex2f 0f0 0f0) - (pal-ffi:gl-tex-coord2f tx2 ty1) - (pal-ffi:gl-vertex2f width 0f0) - (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f width height) - (pal-ffi:gl-tex-coord2f tx1 ty2) - (pal-ffi:gl-vertex2f 0f0 height))) - (translate (v (+ (glyph-width g) (glyph-xoff g)) 0))) + (pal-ffi:gl-tex-coord2f tx1 ty1) + (pal-ffi:gl-vertex2f x 0f0) + (pal-ffi:gl-tex-coord2f tx2 ty1) + (pal-ffi:gl-vertex2f (+ x width) 0f0) + (pal-ffi:gl-tex-coord2f tx2 ty2) + (pal-ffi:gl-vertex2f (+ x width) height) + (pal-ffi:gl-tex-coord2f tx1 ty2) + (pal-ffi:gl-vertex2f x height) + (+ (glyph-width g) (glyph-xoff g)))) (defunct draw-text (text pos &optional font) (vec pos simple-string text (or font boolean) font) (with-transformation (:pos pos) - (let* ((font (if font + (let* ((dx 0f0) + (font (if font font (tag 'default-font))) - (first-dl (pal-ffi:font-first-dl font))) + (height (coerce (pal-ffi:font-height font) 'single-float))) (set-image (pal-ffi:font-image font)) - (loop for char across text do - (pal-ffi:gl-call-list (+ first-dl (char-code char))))))) + (with-gl pal-ffi:+gl-quads+ + (loop for char across text do + (incf dx + (draw-glyph dx height (pal-ffi:font-image font) (aref (pal-ffi:font-glyphs font) (char-code char))))))))) (declaim (inline get-font-height)) (defunct get-font-height (&optional font)

1 0

[pal-cvs] CVS pal
by tneste 27 Jul '07

27 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv3945 Modified Files: ffi.lisp pal.lisp todo.txt Log Message: Bug fixes in ffi.lisp Added some sounds in examples/teddy.lisp --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/24 12:55:06 1.13 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/27 20:12:13 1.14 @@ -472,8 +472,8 @@ (defmethod free-resource ((resource music)) (when (music-music resource) - (setf (music-music resource) nil) - (free-music (music-music resource)))) + (free-music (music-music resource)) + (setf (music-music resource) nil))) (defmethod free-resource ((resource font)) (when (font-image resource) @@ -483,13 +483,13 @@ (defmethod free-resource ((resource image)) (when (> (image-texture resource) 0) - (setf (image-texture resource) 0) - (gl-delete-texture (image-texture resource)))) + (gl-delete-texture (image-texture resource)) + (setf (image-texture resource) 0))) (defmethod free-resource ((resource sample)) (when (sample-chunk resource) - (setf (sample-chunk resource) nil) - (free-chunk (sample-chunk resource)))) + (free-chunk (sample-chunk resource)) + (setf (sample-chunk resource) nil))) (defun free-all-resources () (dolist (r *resources*) @@ -497,22 +497,6 @@ (assert (null *resources*))) - -(cffi:defctype new-music :pointer) -(defmethod cffi:translate-from-foreign (value (name (eql 'new-music))) - (assert (not (cffi:null-pointer-p value))) - (let ((music (make-music :music value))) - (register-resource music) - music)) - -(cffi:defctype new-sample :pointer) -(defmethod cffi:translate-from-foreign (value (name (eql 'new-sample))) - (assert (not (cffi:null-pointer-p value))) - (let ((sample (make-sample :chunk value))) - (register-resource sample) - sample)) - - ;; Main SDL (cffi:defcfun ("SDL_Init" init) :int @@ -609,7 +593,7 @@ (cffi:defcfun ("Mix_FreeChunk" free-chunk) :void (chunk :pointer)) -(cffi:defcfun ("Mix_LoadWAV_RW" load-wav-rw) new-sample +(cffi:defcfun ("Mix_LoadWAV_RW" load-wav-rw) :pointer (io :pointer) (int :int)) (defun load-wav (file) @@ -621,7 +605,7 @@ (cffi:defcfun ("Mix_SetPosition" set-position) :int (channel :int) (angle :int16) (distance :uint8)) -(cffi:defcfun ("Mix_QuickLoad_RAW" quickload-raw) new-sample +(cffi:defcfun ("Mix_QuickLoad_RAW" quickload-raw) :pointer (uint8-ptr :pointer) (length :uint32)) (cffi:defcfun ("Mix_PlayChannelTimed" play-channel-timed) :int @@ -632,7 +616,7 @@ (cffi:defcfun ("Mix_HaltMusic" halt-music) :int) -(cffi:defcfun ("Mix_LoadMUS" load-music) new-music +(cffi:defcfun ("Mix_LoadMUS" load-music) :pointer (file :string)) (cffi:defcfun ("Mix_PlayMusic" play-music) :int --- /project/pal/cvsroot/pal/pal.lisp 2007/07/24 12:55:06 1.19 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/27 20:12:14 1.20 @@ -4,7 +4,7 @@ ;; fix the fps ;; clean up the do-event ;; open quads and other optimisations -;; test with latest cffi and sdl libs +;; test with latest sdl libs (declaim (optimize (speed 3) @@ -56,7 +56,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 2048) + (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) @@ -699,15 +699,20 @@ (defun load-sample (file &optional (volume 255)) "Volume 0-255" (let ((sample (pal-ffi:load-wav (data-path file)))) - (pal-ffi:volume-chunk (pal-ffi:sample-chunk sample) (1+ (truncate volume 2))) - sample)) + (assert (not (cffi:null-pointer-p sample))) + (let ((sample (pal-ffi:register-resource (pal-ffi::make-sample :chunk sample)))) + (pal-ffi:volume-chunk (pal-ffi:sample-chunk sample) (1+ (truncate volume 2))) + sample))) (declaim (inline play-sample)) (defun play-sample (sample &key (loops nil) (angle 0) (volume 255)) - "Angle is an integer between 0-360. Volume is an integer between 0-255." - (let ((channel (pal-ffi:play-channel -1 (pal-ffi:sample-chunk sample) (if (numberp loops) - loops - 0)))) + "Loops is: t = forever, nil = once, number = number of loops. Angle is an integer between 0-360. Volume is an integer between 0-255." + (let ((channel (pal-ffi:play-channel -1 (pal-ffi:sample-chunk sample) (cond + ((numberp loops) + loops) + ((eq t loops) + -1) + (t 0))))) (pal-ffi:set-position channel (truncate angle) (- 255 volume)) channel)) @@ -720,15 +725,17 @@ ;;; Music (defun load-music (file) - (pal-ffi:load-music (data-path file))) + (let ((music (pal-ffi:load-music (data-path file)))) + (assert (not (cffi:null-pointer-p music))) + (let ((music (pal-ffi::make-music :music music))) + (pal-ffi:register-resource music)))) (defun play-music (music &key (loops t) (volume 255)) "Volume 0-255. Loops is: t = forever, nil = once, number = number of loops" - (let ((loops (truncate loops))) - (pal-ffi:volume-music (1+ (truncate volume 2))) - (pal-ffi:play-music (pal-ffi:music-music music) (cond ((eq loops t) -1) - ((null loops) 0) - (t loops))))) + (pal-ffi:volume-music (1+ (truncate volume 2))) + (pal-ffi:play-music (pal-ffi:music-music music) (cond ((eq loops t) -1) + ((null loops) 0) + (t (truncate loops))))) (defun set-music-volume (volume) "Volume 0-255" --- /project/pal/cvsroot/pal/todo.txt 2007/07/21 16:34:16 1.13 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/27 20:12:14 1.14 @@ -6,6 +6,9 @@ - Image tiles and animation. +- Add more complex sound/music handling functions, channel set volume/dir, + fade/etc. music. + - Box/box/line/circle etc. overlap functions, faster v-dist. - Improved texture handling.

1 0

[pal-cvs] CVS pal
by tneste 24 Jul '07

24 Jul '07

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 ,@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)))))

1 0

[pal-cvs] CVS pal/examples
by tneste 24 Jul '07

24 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv16632/examples Modified Files: utils.lisp Log Message: Few name changes, RELT -> RANDOM-ELT --- /project/pal/cvsroot/pal/examples/utils.lisp 2007/07/16 14:44:12 1.1 +++ /project/pal/cvsroot/pal/examples/utils.lisp 2007/07/24 12:55:05 1.2 @@ -27,9 +27,9 @@ (mapcar (pal:curry '* 2 2) '(1 2 3 4 5)) -;; RELT returns a random element in a sequence +;; RANDOM-ELT returns a random element in a sequence -(pal:relt (mapcar (pal:curry '* 2 2) '(1 2 3 4 5))) +(pal:random-elt (mapcar (pal:curry '* 2 2) '(1 2 3 4 5))) ;; CLAMPs a value between min and max @@ -41,3 +41,8 @@ (pal:data-path "foo.png") + +;; LOAD-FOREIGN-LIBRARIES loads all the required dynamic libraries. Normally you don't need to use this +;; but if you are distributing apps with CLisp you need to call this in your init-fn before any other PAL functions. + +(pal:load-foreign-libraries) \ No newline at end of file

1 0

[pal-cvs] CVS pal
by tneste 21 Jul '07

21 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv30525 Modified Files: ffi.lisp pal-macros.lisp pal.asd pal.lisp todo.txt vector.lisp Log Message: Added automatic coercion of numerical arguments. --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/19 18:51:37 1.11 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/21 16:34:16 1.12 @@ -467,6 +467,7 @@ (assert (typep resource 'resource))) (defmethod free-resource :after (resource) + (pal::reset-tags-holding-this-resource resource) (setf *resources* (remove resource *resources*))) (defmethod free-resource ((resource music)) --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/19 16:37:25 1.8 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/21 16:34:16 1.9 @@ -6,7 +6,6 @@ (defvar *tags* (make-hash-table :test 'eq)) - (defmacro define-tags (&body tags) `(progn ,@(mapcar (lambda (r) @@ -20,6 +19,13 @@ (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))) + *tags*)) + (defun tag (name) (declare (type symbol name)) (let ((resource (gethash name *tags*))) @@ -31,6 +37,34 @@ (the resource (setf (cdr resource) r)))) (error "Named resource ~a not found" name)))) +(defun coerce-form-for (to-type value) + `(,value ,(case to-type + ((u8 u11 u16 integer fixnum) `(truncate ,value)) + (component `(coerce ,value 'component)) + (single-float `(coerce ,value 'single-float)) + (double-float `(coerce ,value 'double-float)) + (float `(coerce ,value 'float))))) + + +(defmacro defunct (name lambda-list declarations &body body) + (let* ((decls (loop for (a b) on declarations by #'cddr collecting + `(type ,a ,b))) + (coerced (remove-if (lambda (decl) + (null (second decl))) + (mapcar (lambda (decl) + (coerce-form-for (second decl) (third decl))) + decls)))) + (if coerced + `(defun ,name ,lambda-list + (let (,@coerced) + (declare ,@decls) + ,@body)) + `(defun ,name ,lambda-list + (declare ,@decls) + ,@body)))) + + + (defmacro with-resource ((resource init-form) &body body) `(let ((,resource ,init-form)) (prog1 (progn @@ -69,11 +103,11 @@ ,(when pos `(translate ,pos)) ,(when angle - `(pal-ffi:gl-rotatef ,angle 0f0 0f0 1f0)) + `(rotate ,angle)) ,(when scale (let ((s (gensym))) `(let ((,s ,scale)) - (pal-ffi:gl-scalef ,s ,s 1f0)))) + (scale ,s ,s)))) (prog1 (progn ,@body) (pal-ffi:gl-pop-matrix)))) --- /project/pal/cvsroot/pal/pal.asd 2007/07/13 21:30:59 1.2 +++ /project/pal/cvsroot/pal/pal.asd 2007/07/21 16:34:16 1.3 @@ -9,11 +9,11 @@ ((:file "ffi" :depends-on ("package")) (:file "vector" - :depends-on ("package")) + :depends-on ("pal-macros")) (:file "pal-macros" - :depends-on ("ffi" "vector")) + :depends-on ("ffi")) (:file "pal" - :depends-on ("pal-macros")) + :depends-on ("pal-macros" "vector")) (:file "package")) :depends-on ("cffi")) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/19 18:51:37 1.17 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/21 16:34:16 1.18 @@ -1,8 +1,5 @@ ;; Notes: -;; tags-resources-free -;; raise on top on windows ;; smoothed polygons, guess circle segment count -;; defunct ;; calculate max-texture-size ;; fix the fps @@ -113,6 +110,7 @@ (declaim (inline clamp)) (defun clamp (min v max) + (declare (number min max)) (max min (min max v))) (defun relt (sequence) @@ -171,10 +169,12 @@ ;; Events (declaim (inline key-pressed-p)) -(defun key-pressed-p (keysym) +(defunct key-pressed-p (keysym) + (symbol keysym) (gethash keysym *pressed-keys*)) -(defun keysym-char (keysym) +(defunct keysym-char (keysym) + (symbol keysym) (code-char (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym))) (declaim (inline get-mouse-pos)) @@ -197,13 +197,13 @@ (defun wait-keypress () (let ((key nil)) (event-loop - (:key-down-fn (lambda (k) - (setf key k) - (return-from event-loop key)))) + (: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-up-fn (lambda (k) + (when (eq key k) + (return-from event-loop key))))) key)) @@ -234,9 +234,9 @@ (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)) @@ -253,22 +253,23 @@ (truncate 1000 *fps*)) (declaim (inline clear-screen)) -(defun clear-screen (r g b) - (declare (type u8 r g b)) +(defunct clear-screen (r g b) + (u8 r u8 g u8 b) (pal-ffi:gl-clear-color (/ r 255f0) (/ g 255f0) (/ b 255f0) 1f0) (pal-ffi:gl-clear pal-ffi:+gl-color-buffer-bit+)) -(defun set-mouse-pos (x y) +(defunct set-mouse-pos (x y) + (u16 x u16 y) (pal-ffi:warp-mouse x y) (setf *mouse-x* x *mouse-y* y)) (defun set-cursor (image &optional offset) - (declare (type (or image boolean) image)) - (assert (or (image-p image) (typep image 'boolean))) + (assert (and (or (null offset) (vec-p offset)) + (or (image-p image) (typep image 'boolean)))) (when offset (setf *cursor-offset* offset)) (cond @@ -281,7 +282,8 @@ (pal-ffi:show-cursor nil))) image) -(defun push-clip (x y width height) +(defunct push-clip (x y width 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*)) @@ -299,7 +301,8 @@ ;; State (declaim (inline set-blend-mode)) -(defun set-blend-mode (mode) +(defunct set-blend-mode (mode) + (symbol mode) (case mode ((nil) (pal-ffi:gl-disable pal-ffi:+gl-blend+)) (:blend (pal-ffi:gl-enable pal-ffi:+gl-blend+) @@ -308,18 +311,18 @@ (pal-ffi:gl-blendfunc pal-ffi:+gl-src-alpha+ pal-ffi:+gl-one+)))) (declaim (inline rotate)) -(defun rotate (angle) - (declare (type single-float angle)) +(defunct rotate (angle) + (single-float angle) (pal-ffi:gl-rotatef angle 0f0 0f0 1f0)) (declaim (inline scale)) -(defun scale (x y) - (declare (type single-float x y)) +(defunct scale (x y) + (single-float x single-float y) (pal-ffi:gl-scalef x y 1f0)) (declaim (inline translate)) -(defun translate (vec) - (declare (type vec vec)) +(defunct translate (vec) + (vec vec) (pal-ffi:gl-translatef (vx vec) (vy vec) 0f0)) (declaim (inline reset-blend-mode)) @@ -328,13 +331,13 @@ (set-blend-color 255 255 255 255)) (declaim (inline set-blend-color)) -(defun set-blend-color (r g b a) - (declare (type u8 r g b a)) +(defunct set-blend-color (r g b a) + (u8 r u8 g u8 b u8 a) (pal-ffi:gl-color4ub r g b a)) (declaim (inline set-image)) -(defun set-image (image) - (declare (type image image)) +(defunct set-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)))) @@ -445,7 +448,8 @@ (pal-ffi::free-surface surface) image)) -(defun screen-to-array (pos width height) +(defunct screen-to-array (pos width 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)) @@ -466,8 +470,9 @@ 255))) array))) -(defun draw-image (image pos &key angle scale valign halign) - (declare (type image image) (type vec pos) (type (or boolean single-float) angle scale) (type symbol halign valign)) + +(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) (set-image image) (let ((width (image-width image)) (height (image-height image)) @@ -512,9 +517,8 @@ (pal-ffi:gl-vertex2f x (+ y height))))))) - -(defun draw-image* (image from-pos to-pos width height) - (declare (type image image) (type vec from-pos to-pos) (type u11 width height)) +(defunct draw-image* (image from-pos to-pos width 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)) @@ -535,47 +539,47 @@ (pal-ffi:gl-vertex2f vx-to (+ vy-to height))))) (declaim (inline draw-line)) -(defun draw-line (la lb r g b a &key (size 1.0f0) (smoothp)) - (declare (type vec la lb) (type u8 r g b a) (type single-float size)) +(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) (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)) -(defun draw-arrow (la lb r g b a &key (size 1.0f0) smoothp) - (declare (type vec la lb) (type u8 r g b a) (type single-float size)) +(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) (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)) -(defun draw-point (pos r g b a &key (size 1f0) smoothp) - (declare (type vec pos) (type u8 r g b a) (type single-float size)) +(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) (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 (pal-ffi:gl-enable pal-ffi:+gl-point-smooth+) (pal-ffi:gl-disable pal-ffi:+gl-point-smooth+)) (pal-ffi:gl-point-size size) - (set-blend-color r g b a) + (pal-ffi:gl-color4ub r g b a) (with-gl pal-ffi:+gl-point+ (pal-ffi:gl-vertex2f (vx pos) (vy pos))) (pal-ffi:gl-pop-attrib)) -(defun draw-rectangle (pos width height r g b a &key (fill t) (size 1f0) absolutep smoothp) - (declare (type vec pos) (type boolean absolutep) (type float size) (type u11 width height) (type u8 r g b a) (type (or image boolean) fill)) +(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) (cond ((image-p fill) (draw-polygon (list pos @@ -587,28 +591,28 @@ :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+) - (set-blend-color r g b a) + (pal-ffi:gl-color4ub r g b a) (pal-ffi:gl-rectf (vx pos) (vy pos) (+ (vx pos) width) (+ (vy pos) height)) (pal-ffi:gl-pop-attrib)))) -(defun draw-polygon (points r g b a &key (fill t) absolutep (size 1f0) smoothp) - (declare (type list points) (type u8 r g b a) (type (or image boolean) fill)) +(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) (cond ((image-p fill) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+)) (set-image fill) - (set-blend-color r g b a) + (pal-ffi:gl-color4ub r g b a) (with-gl pal-ffi:+gl-polygon+ (let ((dx (vx (first points))) (dy (vy (first points)))) @@ -628,20 +632,20 @@ (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+)) - (set-blend-color r g b a) + (pal-ffi:gl-color4ub r g b a) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (with-gl pal-ffi:+gl-polygon+ (dolist (p points) (pal-ffi:gl-vertex2f (vx p) (vy p)))) (pal-ffi:gl-pop-attrib)))) -(defun draw-polygon* (points &key image tex-coords colors) - (declare (type list points tex-coords colors) (type (or boolean image) image)) +(defunct draw-polygon* (points &key image tex-coords colors) + (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) @@ -678,7 +682,8 @@ (pal-ffi:gl-vertex2f (vx p) (vy p)))))) (pal-ffi:gl-pop-attrib)) -(defun draw-circle (pos radius r g b a &key (fill t) absolutep (size 1f0) smoothp (segments 30)) +(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) (declare (type vec pos) (type fixnum segments)) (draw-polygon (loop for a from 0 to (* 2 pi) by (/ (* 2 pi) segments) collecting (v+ pos @@ -700,7 +705,7 @@ (let ((channel (pal-ffi:play-channel -1 (pal-ffi:sample-chunk sample) (if (numberp loops) loops 0)))) - (pal-ffi:set-position channel angle (- 255 volume)) + (pal-ffi:set-position channel (truncate angle) (- 255 volume)) channel)) (defun set-sample-volume (sample volume) @@ -716,10 +721,11 @@ (defun play-music (music &key (loops t) (volume 255)) "Volume 0-255. Loops is: t = forever, nil = once, number = number of loops" - (pal-ffi:volume-music (1+ (truncate volume 2))) - (pal-ffi:play-music (pal-ffi:music-music music) (cond ((eq loops t) -1) - ((null loops) 0) - (t loops)))) + (let ((loops (truncate loops))) + (pal-ffi:volume-music (1+ (truncate volume 2))) + (pal-ffi:play-music (pal-ffi:music-music music) (cond ((eq loops t) -1) + ((null loops) 0) + (t loops))))) (defun set-music-volume (volume) "Volume 0-255" @@ -795,8 +801,8 @@ (pal-ffi:gl-vertex2f 0f0 height))) (translate (v (+ (glyph-width g) (glyph-xoff g)) 0))) -(defun draw-text (text pos &optional font) - (declare (type vec pos) (type simple-string text) (type (or font boolean) font)) +(defunct draw-text (text pos &optional font) + (vec pos simple-string text (or font boolean) font) (with-transformation (:pos pos) (let* ((font (if font font @@ -807,14 +813,14 @@ (pal-ffi:gl-call-list (+ first-dl (char-code char))))))) (declaim (inline get-font-height)) -(defun get-font-height (&optional font) - (declare (type (or font boolean) font)) +(defunct get-font-height (&optional font) + ((or font boolean) font) (pal-ffi:font-height (if font font (tag 'default-font)))) -(defun get-text-size (text &optional font) - (declare (type (or font boolean) font) (type simple-string text)) +(defunct get-text-size (text &optional font) + ((or font boolean) font simple-string text) (values (let ((glyphs (pal-ffi:font-glyphs (if font font (tag 'default-font))))) --- /project/pal/cvsroot/pal/todo.txt 2007/07/19 18:51:37 1.12 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/21 16:34:16 1.13 @@ -4,6 +4,8 @@ - Implement image mirroring. +- Image tiles and animation. + - Box/box/line/circle etc. overlap functions, faster v-dist. - Improved texture handling. @@ -14,11 +16,6 @@ - I would really like to see it run on OS X. -- Simple and transparent animation system for images. - -- Using fullscreen mode on Windows some times results in screen flickering - between desktop and PAL screen, usually fixed by alt-tabbing. Should be fixed. - - The problems with Linux and some gfx drivers should be somehow fixed. - Documentation and tutorials. --- /project/pal/cvsroot/pal/vector.lisp 2007/07/18 19:26:31 1.4 +++ /project/pal/cvsroot/pal/vector.lisp 2007/07/21 16:34:16 1.5 @@ -3,132 +3,147 @@ (in-package :pal) -#+CL-HAS-FULL-NUMERIC-TOWER-DAMMIT (deftype component () 'number) -#-CL-HAS-FULL-NUMERIC-TOWER-DAMMIT (deftype component () 'single-float) + +(deftype component () 'single-float) (defstruct (vec (:conc-name v)) (x 0 :type component) (y 0 :type component)) (declaim (inline component)) -(defun component (x) +(defunct component (x) + (number x) (coerce x 'component)) (declaim (inline v)) -(defun v (x y) - (make-vec :x (component x) :y (component y))) +(defunct v (x y) + (component x component y) + (make-vec :x x :y y)) (declaim (inline vf)) (defun vf (x y) + (declare (type component x) (type component y)) (make-vec :x x :y y)) + + (declaim (inline rad)) -(defun rad (degrees) - (declare (type component degrees)) +(defunct rad (degrees) + (number degrees) (component (* (/ pi 180) degrees))) -(defun deg (radians) - (declare (type component radians)) +(declaim (inline deg)) +(defunct deg (radians) + (number radians) (component (* (/ 180 pi) radians))) -(defun angle-v (angle) - (declare (type component angle)) +(declaim (inline angle-v)) +(defunct angle-v (angle) + (number angle) (v (sin (rad angle)) (- (cos (rad angle))))) (declaim (inline vec-angle)) -(defun v-angle (vec) - (declare (type vec vec)) +(defunct v-angle (vec) + (vec vec) (mod (deg (atan (vx vec) (if (zerop (vy vec)) least-negative-short-float (- (vy vec))))) 360)) -(defun v-random (length) +(defunct v-random (length) + (number length) (v* (angle-v (random 360.0)) length)) (declaim (inline v-round)) -(defun v-round (v) - (declare (type vec v)) +(defunct v-round (v) + (vec v) (v (round (vx v)) (round (vy v)))) (declaim (inline v-floor)) -(defun v-floor (v) - (declare (type vec v)) +(defunct v-floor (v) + (vec v) (v (floor (vx v)) (floor (vy v)))) (declaim (inline v=)) -(defun v= (a b) +(defunct v= (a b) + (vec a vec b) (and (= (vx a) (vx b)) (= (vy a) (vy b)))) (declaim (inline v+!)) -(defun v+! (a b) +(defunct v+! (a b) + (vec a vec b) (setf (vx a) (+ (vx a) (vx b))) (setf (vy a) (+ (vy a) (vy b))) nil) (declaim (inline v+)) -(defun v+ (a b) +(defunct v+ (a b) + (vec a vec b) (vf (+ (vx a) (vx b)) (+ (vy a) (vy b)))) (declaim (inline v-)) -(defun v- (a b) +(defunct v- (a b) + (vec a vec b) (vf (- (vx a) (vx b)) (- (vy a) (vy b)))) (declaim (inline v-!)) -(defun v-! (a b) +(defunct v-! (a b) + (vec a vec b) (setf (vx a) (- (vx a) (vx b))) (setf (vy a) (- (vy a) (vy b))) nil) (declaim (inline v*!)) -(defun v*! (v m) - (declare (type component m)) +(defunct v*! (v m) + (component m) (setf (vx v) (* (vx v) m)) (setf (vy v) (* (vy v) m)) nil) (declaim (inline v*)) -(defun v* (v m) - (declare (type component m)) +(defunct v* (v m) + (vec v component m) (vf (* (vx v) m) (* (vy v) m))) (declaim (inline v/)) -(defun v/ (v d) - (declare (type component d)) +(defunct v/ (v d) + (vec v component d) (vf (/ (vx v) d) (/ (vy v) d))) (declaim (inline v/!)) -(defun v/! (v d) - (declare (type component d)) +(defunct v/! (v d) + (vec v component d) (setf (vx v) (/ (vx v) d)) (setf (vy v) (/ (vy v) d)) nil) (declaim (inline v-max)) -(defun v-max (a b) +(defunct v-max (a b) + (vec a vec b) (if (< (v-magnitude a) (v-magnitude b)) b a)) (declaim (inline v-min)) -(defun v-min (a b) +(defunct v-min (a b) + (vec a vec b) (if (< (v-magnitude a) (v-magnitude b)) a b)) -(defun v-rotate (v a) - (declare (type component a) (type vec v)) +(defunct v-rotate (v a) + (vec v component a) (let ((a (rad a))) (vf (- (* (cos a) (vx v)) (* (sin a) (vy v))) @@ -136,43 +151,44 @@ (* (cos a) (vy v)))))) (declaim (inline v-dot)) -(defun v-dot (a b) +(defunct v-dot (a b) + (vec a vec b) (+ (* (vx a) (vx b)) (* (vy a) (vy b)))) (declaim (inline v-magnitude)) -(defun v-magnitude (v) - (declare (type vec v)) +(defunct v-magnitude (v) + (vec v) (the component (sqrt (the component (+ (expt (vx v) 2) (expt (vy v) 2)))))) -(declaim (inline v-normalize)) -(defun v-normalize (v) +(defunct v-normalize (v) + (vec v) (if (/= (v-magnitude v) 0.0) (vf (/ (vx v) (v-magnitude v)) (/ (vy v) (v-magnitude v))) (vf 0.0 0.0))) - -(defun v-direction (from-vector to-vector) +(defunct v-direction (from-vector to-vector) + (vec from-vector vec to-vector) (v-normalize (v- to-vector from-vector))) - -(declaim (inline v-distance)) -(defun v-distance (v1 v2) - (declare (type vec v1 v2)) +(defunct v-distance (v1 v2) + (vec v1 vec v2) (v-magnitude (v- v1 v2))) -(defun v-truncate (v l) + +(defunct v-truncate (v l) + (vec v component l) (v* (v-normalize v) l)) -(defun closest-point-to-line (a b p) - (declare (type vec a b p)) +(defunct closest-point-to-line (a b p) + (vec a vec b vec p) (let* ((dir (v- b a)) (diff (v- p a)) (len (v-dot dir dir))) @@ -185,16 +201,15 @@ b) a))))) -(declaim (inline point-in-line)) -(defun point-in-line (a b p) - (declare (type vec a b p)) +(defunct point-in-line (a b p) + (vec a vec b vec p) (let ((d (v-direction a b))) (if (< (abs (+ (v-dot d (v-direction a p)) (v-dot d (v-direction b p)))) .00001) t nil))) -(defun lines-intersection (la1 la2 lb1 lb2) - (declare (type vec la1 la2 lb1 lb2)) +(defunct lines-intersection (la1 la2 lb1 lb2) + (vec la1 vec la2 vec lb1 vec lb2) (let ((x1 (vx la1)) (y1 (vy la1)) (x2 (vx la2)) @@ -219,8 +234,8 @@ p nil)))))) -(defun circle-line-intersection (a b co r) - (declare (type vec a b co) (type component r)) +(defunct circle-line-intersection (a b co r) + (vec a vec b vec co component r) (let ((cp (closest-point-to-line a b co))) (if cp (if (<= (v-distance co cp) r) @@ -228,15 +243,15 @@ nil) nil))) -(defun distance-from-line (a b p) - (declare (type vec a b p)) +(defunct distance-from-line (a b p) + (vec a vec b vec p) (let ((cp (closest-point-to-line a b p))) (if cp (v-distance cp p) nil))) -(defun point-inside-rectangle (topleft width height pos) - (declare (type (or component fixnum) width height) (type vec pos topleft)) +(defunct point-inside-rectangle (topleft width height pos) + (vec topleft vec pos component width component height) (let* ((x1 (vx topleft)) (y1 (vy topleft)) (x2 (+ x1 width)) @@ -248,11 +263,11 @@ t nil))) (declaim (inline point-inside-circle)) -(defun point-inside-circle (co r p) - (declare (type vec co p) (type component r)) +(defunct point-inside-circle (co r p) + (vec co vec p component r) (<= (v-distance co p) r)) (declaim (inline circles-overlap)) -(defun circles-overlap (c1 r1 c2 r2) - (declare (vec c1 c2) (component r1 r2)) +(defunct circles-overlap (c1 r1 c2 r2) + (vec c1 vec c2 component r1 component r2) (<= (v-distance c1 c2) (+ r2 r1))) \ No newline at end of file

1 0

[pal-cvs] CVS pal/examples
by tneste 21 Jul '07

21 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv30525/examples Modified Files: hares.lisp hello.lisp images.lisp polygons.lisp swarm.lisp teddy.lisp Log Message: Added automatic coercion of numerical arguments. --- /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/18 19:27:22 1.3 +++ /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/21 16:34:16 1.4 @@ -17,11 +17,11 @@ ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (vel :accessor vel-of :initarg :vel :initform (v 0 0)) (image :accessor image-of :initarg :image) - (angle :accessor angle-of :initarg :angle :initform 0f0) + (angle :accessor angle-of :initarg :angle :initform 0) (r :accessor r-of :initarg :r) (g :accessor g-of :initarg :g) (b :accessor b-of :initarg :b) - (scale :accessor scale-of :initform 1.0f0 :initarg :scale) + (scale :accessor scale-of :initform 1 :initarg :scale) (scaled :accessor scaled-of :initarg :scaled))) (defmethod initialize-instance :after ((sprite sprite) &key &allow-other-keys) @@ -37,14 +37,14 @@ :scale (scale-of s))) (defmethod act ((s sprite)) - (setf (angle-of s) (mod (+ (angle-of s) 1f0) 360)) + (setf (angle-of s) (mod (+ (angle-of s) 1) 360)) (when (or (< (vx (pos-of s)) 0) (> (vx (pos-of s)) (get-screen-width))) (setf (vel-of s) (v (- (vx (vel-of s))) (vy (vel-of s))))) (when (or (< (vy (pos-of s)) 0) (> (vy (pos-of s)) (get-screen-height))) (setf (vel-of s) (v (vx (vel-of s)) (- (vy (vel-of s)))))) - (when (or (> (scale-of s) 2) (< (scale-of s) .5)) + (when (or (> (scale-of s) 2) (< (scale-of s) 1/2)) (setf (scaled-of s) (- (scaled-of s)))) (incf (scale-of s) (scaled-of s)) (v+! (pos-of s) (vel-of s))) @@ -53,22 +53,21 @@ (defun example () - (with-pal (:width 800 :height 600 :fullscreenp t :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:width 800 :height 600 :fullscreenp nil :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) (setf *sprites* nil) (set-cursor nil) - (dotimes (i 500) (make-instance 'sprite :image (tag 'hare) - :scaled (- (random .2f0) .1f0) - :scale (+ (random 1.5f0) .5f0) + :scaled (- (random .2) .1) + :scale (+ (random 1.5) .5) :r (random 255) :g (random 255) :b (random 255) :pos (v (random (get-screen-width)) (random (get-screen-height))) - :vel (v-random 3f0) - :angle (random 360f0))) + :vel (v-random 3.0) + :angle (random 360.0))) (event-loop () --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/18 21:29:55 1.7 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/21 16:34:16 1.8 @@ -33,7 +33,7 @@ (pal:draw-rectangle (pal:v 0 0) (pal:get-screen-width) (pal:get-screen-height) 0 0 0 10) - (pal:with-transformation (:pos (pal:v 400 300) :angle (incf angle 1f0) :scale 3f0) + (pal:with-transformation (:pos (pal:v 400 300) :angle (incf angle 1) :scale 3) (pal:draw-text "Hello from PAL" (pal:v 0 0))))))) ;; (hello-2) \ No newline at end of file --- /project/pal/cvsroot/pal/examples/images.lisp 2007/07/19 18:51:37 1.4 +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/07/21 16:34:16 1.5 @@ -30,7 +30,7 @@ (with-pal (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (set-cursor (tag 'image-3)) ;; sets image-3 as a mouse cursor image - (let ((a 0f0)) + (let ((a 0)) (event-loop () (draw-polygon* (list (v 0 0) (v 800 0) @@ -50,7 +50,7 @@ (v 0 0) :valign :middle :halign :middle - :angle (incf a .1f0))) + :angle (incf a .1))) ;; Press left mousebutton to capture part of the screen as a new cursor (when (key-pressed-p :key-mouse-1) --- /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/18 21:29:56 1.5 +++ /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/21 16:34:16 1.6 @@ -4,7 +4,7 @@ (with-pal (:paths (merge-pathnames "examples/" pal::*pal-directory*)) - (let ((angle 0f0) + (let ((angle 0) (grid (load-image "bg2.png")) (plane (load-image "lego-plane.png" t)) (slad (load-image "save_lisp.gif" t)) @@ -20,15 +20,15 @@ ;; DRAW-IMAGE draw the whole image at given position. Keyword arguments can be given to define the ;; scale, angle and horizontal and vertical alignment ("hotspot") - (draw-arrow (v 700 500) (get-mouse-pos) 255 255 0 255 :size 5f0 :smoothp t) + (draw-arrow (v 700 500) (get-mouse-pos) 255 255 0 255 :size 5 :smoothp t) (draw-image plane (v 700 500) :halign :middle ;; Possible options are :left, :right and :middle. :left is the default. :valign :bottom ;; -''- :top, :bottom, :middle. :top is the default. :angle (v-angle (v-direction (v 700 500) (get-mouse-pos))) ;; angle in degrees - :scale (* (v-distance (v 700 500) (get-mouse-pos)) .01f0)) + :scale (* (v-distance (v 700 500) (get-mouse-pos)) .01)) - (draw-point (v 700 500) 255 0 0 255 :size 10f0 :smoothp t) ;; Draw a red point at the hotspot of previous image. + (draw-point (v 700 500) 255 0 0 255 :size 10 :smoothp t) ;; Draw a red point at the hotspot of previous image. ;; DRAW-POLYGON draw a polygon which vertexes are given as a list of VECs. ;; FILL is either nil, t or image that is used as a pattern. @@ -51,7 +51,7 @@ ) 255 0 0 255 :fill nil - :size 5f0 + :size 5 :smoothp t :absolutep nil)) @@ -83,7 +83,7 @@ ;; DRAW-POLYGON* takes a list of vertex coordinates and as keyword arguments a list of texture coordinates(in pixels) for each vertex, ;; an image, and a list of lists of rgba values to use for each vertex. - (with-transformation (:pos (v 600 100) :angle (incf angle .5f0)) + (with-transformation (:pos (v 600 100) :angle (incf angle .5)) (draw-polygon* (list (v 00 10) (v 100 200) (v -100 200)) --- /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/16 20:46:24 1.4 +++ /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/21 16:34:16 1.5 @@ -1,4 +1,4 @@ - +;; NOTE: the following example is intentionally slow and somewhat obfuscated (defun swarm () (let ((vectors nil)) @@ -7,30 +7,30 @@ (pal:message key) (when (eq key :key-mouse-1) (setf vectors (append vectors (loop repeat 50 collecting (cons (pal:get-mouse-pos) - (pal:v-random 5f0)))))))) + (pal:v-random 5.0)))))))) (pal:draw-rectangle (pal:v 0 0) 1024 768 0 0 0 128) (pal:with-blend (:color '(255 128 128 255)) (pal:draw-text "Use left mousekey to add particles." (pal:v 0 0))) (let ((midpoint (pal:v/ (reduce 'pal:v+ vectors :initial-value (pal:v 0 0) :key 'car) - (max 1f0 + (max 1 (coerce (length vectors) 'single-float))))) - (pal:draw-point midpoint 255 0 0 255 :size 10f0 :smoothp t) + (pal:draw-point midpoint 255 0 0 255 :size 10 :smoothp t) (setf vectors (mapcar (lambda (v) (cons (pal:v+ (car v) (cdr v)) (pal:v* (pal:v+ (cdr v) (pal:v+ (pal:v/ (pal:v-direction midpoint (car v)) - (max 1f0 + (max 1 (sqrt (pal:v-distance midpoint (car v))))) (pal:v-direction (car v) (pal:get-mouse-pos)) )) - .90f0))) + .9))) vectors))) (pal:with-blend (:mode :additive) (dolist (v vectors) (pal:draw-arrow (car v) (pal:v+ (car v) (cdr v)) 10 7 0 255 - :size 10f0))))))) + :size 10))))))) ;; (swarm) \ No newline at end of file --- /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/13 21:30:58 1.3 +++ /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/21 16:34:16 1.4 @@ -24,7 +24,7 @@ (vel :accessor vel-of :initarg :vel :initform (v 0 0)) (alt :accessor alt-of :initarg :alt :initform 10) (image :accessor image-of :initarg :image) - (angle :accessor angle-of :initarg :angle :initform 0f0))) + (angle :accessor angle-of :initarg :angle :initform 0))) (defmethod initialize-instance :after ((sprite sprite) &key &allow-other-keys) (push sprite *sprites*)) @@ -50,7 +50,7 @@ (defmethod act ((s plane)) (v+! (vel-of s) - (v* (v-direction (pos-of s) (get-mouse-pos)) .3f0)) + (v* (v-direction (pos-of s) (get-mouse-pos)) .3)) (setf (angle-of s) (v-angle (vel-of s))) (call-next-method)) @@ -61,13 +61,13 @@ (:default-initargs :image (tag 'teddy))) (defmethod act ((s mutant-teddy)) - (setf (angle-of s) (mod (+ (angle-of s) 1f0) 360)) + (setf (angle-of s) (mod (+ (angle-of s) 1) 360)) (call-next-method)) (defun example () - (with-pal (:width 800 :height 600 :fullscreenp nil :fps 60 :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:fullscreenp nil :width 800 :height 600 :fullscreenp nil :fps 60 :paths (merge-pathnames "examples/" pal::*pal-directory*)) ;; inits PAL, the args used are the default values. ;; PATHS is a pathname or list of pathnames that PAL uses to find the resource files loaded with LOAD-* functions. ;; By default PATHS contains the PAL source directory and value of *default-pathname-defaults* @@ -84,8 +84,8 @@ (make-instance 'mutant-teddy :pos (v (random (get-screen-width)) (random (get-screen-height))) - :vel (v-random 3f0) - :angle (random 360f0))) + :vel (v-random 3.0) + :angle (random 360.0))) (event-loop () ;; simple event loop, no mouse-move, key-down etc. handlers defined, we'll handle input explicitly with TEST-KEYS.

1 0

[pal-cvs] CVS pal
by tneste 19 Jul '07

19 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv32635 Modified Files: ffi.lisp package.lisp pal.lisp todo.txt Log Message: Added SCREEN-TO-ARRAY --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/19 16:37:25 1.10 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/19 18:51:37 1.11 @@ -672,6 +672,7 @@ (defconstant +gl-line-loop+ #x2) (defconstant +gl-polygon+ #x9) (defconstant +gl-quads+ #x7) +(defconstant +gl-PACK-ALIGNMENT+ #xD05) (defconstant +gl-blend+ #xBE2) (defconstant +gl-src-alpha+ #x302) (defconstant +gl-dst-alpha+ #x304) @@ -888,6 +889,19 @@ (%gl-get-integer value data) (cffi:mem-ref data :int))) +(cffi:defcfun ("glReadPixels" gl-read-pixels) :void + (x :int) + (y :int) + (width :int) + (height :int) + (format :int) + (type :int) + (data :pointer)) + +(cffi:defcfun ("glPixelStorei" gl-pixel-store) :void + (pack :int) + (value :int)) + #+win32 (cffi:defcfun "SHGetFolderPathA" :int (owner :pointer) (folder :int) (handle :pointer) (flags :int) (path :pointer)) @@ -901,8 +915,4 @@ ;; SDL_SysWMinfo wmInfo; ;; SDL_GetWMInfo(&wmInfo); -;; HWND hWnd = wmInfo.window; - -;; image = (GLubyte *) malloc(width * height * sizeof(GLubyte) * 3) ; -;; glPixelStorei(GL_PACK_ALIGNMENT, 1) ; -;; glReadPixels(x, y, width, height, GL_RGB, GL_UNSIGNED_BYTE, image) ; \ No newline at end of file +;; HWND hWnd = wmInfo.window; \ No newline at end of file --- /project/pal/cvsroot/pal/package.lisp 2007/07/19 16:37:25 1.10 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/19 18:51:37 1.11 @@ -5,6 +5,9 @@ (:export #:+NO-EVENT+ #:+gl-line-smooth+ #:make-font + #:+gl-pack-alignment+ + #:gl-read-pixels + #:gl-pixel-store #:+gl-scissor-test+ #:free-surface #:gl-get-integer @@ -421,6 +424,7 @@ #:image-from-array #:image-from-fn #:load-image-to-array + #:screen-to-array #:load-image #:image-width --- /project/pal/cvsroot/pal/pal.lisp 2007/07/19 16:37:25 1.16 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/19 18:51:37 1.17 @@ -1,9 +1,10 @@ ;; Notes: -;; tags-resources-free? -;; save-screen +;; tags-resources-free ;; raise on top on windows ;; smoothed polygons, guess circle segment count ;; defunct +;; calculate max-texture-size +;; fix the fps (declaim (optimize (speed 3) @@ -58,7 +59,7 @@ (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) - + (pal-ffi:gl-pixel-store pal-ffi:+gl-pack-alignment+ 1) (let ((surface (pal-ffi::set-video-mode width height @@ -395,7 +396,8 @@ (do-n (x width y height) (multiple-value-bind (r g b a) (funcall fn x y) (let ((a (or a 255)) - (p (the fixnum (+ (* y (the u16 (* (the u11 texture-width) 4))) (the u16 (* 4 x)))))) + (p (the fixnum (+ (* y texture-width 4) + (the u16 (* 4 x)))))) (when (< a 255) (setf mode pal-ffi:+gl-rgba+)) (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) @@ -443,6 +445,27 @@ (pal-ffi::free-surface surface) image)) +(defun screen-to-array (pos width 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)) + (- *height* (truncate (vy pos)) height) + width height + pal-ffi:+gl-rgb+ pal-ffi:+gl-unsigned-byte+ + image) + (do-n (x width y height) + (setf (aref array x (- height y 1)) + (list (cffi:mem-aref image :unsigned-char (+ (* y width 3) + (* x 3))) + (cffi:mem-aref image :unsigned-char (+ (* y width 3) + (* x 3) + 1)) + (cffi:mem-aref image :unsigned-char (+ (* y width 3) + (* x 3) + 2)) + 255))) + array))) + (defun draw-image (image pos &key angle scale valign halign) (declare (type image image) (type vec pos) (type (or boolean single-float) angle scale) (type symbol halign valign)) (set-image image) --- /project/pal/cvsroot/pal/todo.txt 2007/07/19 16:37:25 1.11 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/19 18:51:37 1.12 @@ -4,17 +4,12 @@ - Implement image mirroring. -- Box/box/line/circle etc. overlap functions, faster v-dist +- Box/box/line/circle etc. overlap functions, faster v-dist. -- Improved texture handling - -- image-to-array/screen-to-array etc. +- Improved texture handling. - Fix the FPS limiter, the results could be a lot smoother. -- Check the sanity of vector.lisp and add some operations, esp. bounding-boxes - etc. - - Correct aspect ratio when fullscreen on widescreen displays. - I would really like to see it run on OS X.

1 0

[pal-cvs] CVS pal/examples
by tneste 19 Jul '07

19 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv32635/examples Modified Files: images.lisp Log Message: Added SCREEN-TO-ARRAY --- /project/pal/cvsroot/pal/examples/images.lisp 2007/07/19 16:37:25 1.3 +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/07/19 18:51:37 1.4 @@ -2,7 +2,6 @@ (:use :cl :pal)) (in-package :image-tests) -(defparameter *foo* nil) (define-tags ;; IMAGE-FROM-FN builds and image by calling the FN with x and y coordinates. @@ -51,4 +50,10 @@ (v 0 0) :valign :middle :halign :middle - :angle (incf a .5f0)))))) \ No newline at end of file + :angle (incf a .1f0))) + + ;; Press left mousebutton to capture part of the screen as a new cursor + (when (key-pressed-p :key-mouse-1) + (set-cursor (image-from-array + nil + (screen-to-array (get-mouse-pos) 128 128))))))) \ No newline at end of file

1 0

[pal-cvs] CVS pal
by tneste 19 Jul '07

19 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv8793 Modified Files: ffi.lisp package.lisp pal-macros.lisp pal.lisp todo.txt Added Files: readme.txt Log Message: Added LOAD-IMAGE-TO-ARRAY, few bug fixes. --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/18 21:29:56 1.9 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/19 16:37:25 1.10 @@ -901,4 +901,8 @@ ;; SDL_SysWMinfo wmInfo; ;; SDL_GetWMInfo(&wmInfo); -;; HWND hWnd = wmInfo.window; \ No newline at end of file +;; HWND hWnd = wmInfo.window; + +;; image = (GLubyte *) malloc(width * height * sizeof(GLubyte) * 3) ; +;; glPixelStorei(GL_PACK_ALIGNMENT, 1) ; +;; glReadPixels(x, y, width, height, GL_RGB, GL_UNSIGNED_BYTE, image) ; \ No newline at end of file --- /project/pal/cvsroot/pal/package.lisp 2007/07/18 21:29:56 1.9 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/19 16:37:25 1.10 @@ -6,6 +6,7 @@ #:+gl-line-smooth+ #:make-font #:+gl-scissor-test+ + #:free-surface #:gl-get-integer #:+gl-max-texture-size+ #:+gl-smooth+ @@ -419,6 +420,7 @@ #:image-from-array #:image-from-fn + #:load-image-to-array #:load-image #:image-width @@ -431,6 +433,7 @@ #:draw-arrow #:draw-image #:draw-image* + #:draw-circle #:load-font #:get-font-height --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/16 20:46:24 1.7 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/19 16:37:25 1.8 @@ -52,14 +52,16 @@ `(set-blend-mode ,mode)) ,(when color `(set-blend-color (first ,color) (second ,color) (third ,color) (fourth ,color))) - ,@body - (pal-ffi:gl-pop-attrib))) + (prog1 (progn + ,@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))) + (prog1 (progn + ,@body) + (pop-clip)))) (defmacro with-transformation ((&key pos angle scale) &body body) `(progn @@ -72,8 +74,9 @@ (let ((s (gensym))) `(let ((,s ,scale)) (pal-ffi:gl-scalef ,s ,s 1f0)))) - ,@body - (pal-ffi:gl-pop-matrix))) + (prog1 (progn + ,@body) + (pal-ffi:gl-pop-matrix)))) (defmacro with-gl (mode &body body) `(progn --- /project/pal/cvsroot/pal/pal.lisp 2007/07/18 21:29:56 1.15 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/19 16:37:25 1.16 @@ -1,8 +1,9 @@ ;; Notes: ;; tags-resources-free? -;; do absolute paths for data-path work? -;; box/box/line overlap functions, fast v-dist -;; load-image-to-array +;; save-screen +;; raise on top on windows +;; smoothed polygons, guess circle segment count +;; defunct (declaim (optimize (speed 3) @@ -57,54 +58,57 @@ (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 - width - height - 0 - (logior (if fullscreenp - pal-ffi::+fullscreen+ - 0) - pal-ffi:+opengl+))) - (error "PAL failed to obtain SDL surface")) - (pal-ffi:set-caption title (cffi:null-pointer)) - (pal-ffi:gl-disable pal-ffi:+gl-cull-face-test+) - (pal-ffi:gl-enable pal-ffi:+gl-texture-2d+) - (pal-ffi:gl-shade-model pal-ffi:+gl-flat+) - (pal-ffi:gl-disable pal-ffi:+gl-scissor-test+) - (set-blend-mode :blend) - (pal-ffi:gl-viewport 0 0 width height) - (pal-ffi:gl-matrix-mode pal-ffi:+gl-projection+) - (pal-ffi:gl-load-identity) - (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) - (clear-screen 0 0 0) - (reset-tags) - (define-tags default-font (load-font "default-font")) - (setf *data-paths* nil - *max-texture-size* (pal-ffi:gl-get-integer pal-ffi:+gl-max-texture-size+) - *messages* nil - *pressed-keys* (make-hash-table :test 'eq) - *ticks* (get-internal-real-time) - *title* title - *current-image* nil - *max-fps* (truncate 1000 fps) - *ticks* (pal-ffi:get-tick) - *clip-stack* nil - *fps* 1 - *delay* 0 - *new-fps* 0 - *cursor* t - *cursor-offset* (v 0 0) - *width* width - *height* height - *pal-running* t) - (add-path *pal-directory*) - (add-path *default-pathname-defaults*) - (if (listp paths) - (dolist (p paths) - (add-path p)) - (add-path paths))) + + (let ((surface (pal-ffi::set-video-mode + width + height + 0 + (logior (if fullscreenp + pal-ffi::+fullscreen+ + 0) + pal-ffi:+opengl+)))) + (when (cffi:null-pointer-p surface) + (error "PAL failed to obtain SDL surface")) + (setf *data-paths* nil + *max-texture-size* (pal-ffi:gl-get-integer pal-ffi:+gl-max-texture-size+) + *messages* nil + *pressed-keys* (make-hash-table :test 'eq) + *ticks* (get-internal-real-time) + *title* title + *current-image* nil + *max-fps* (truncate 1000 fps) + *ticks* (pal-ffi:get-tick) + *clip-stack* nil + *fps* 1 + *delay* 0 + *new-fps* 0 + *cursor* t + *cursor-offset* (v 0 0) + *pal-running* t + *width* (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + *height* (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)) + (pal-ffi:set-caption title (cffi:null-pointer)) + (pal-ffi:gl-disable pal-ffi:+gl-cull-face-test+) + (pal-ffi:gl-enable pal-ffi:+gl-texture-2d+) + (pal-ffi:gl-shade-model pal-ffi:+gl-flat+) + (pal-ffi:gl-disable pal-ffi:+gl-scissor-test+) + (set-blend-mode :blend) + (pal-ffi:gl-viewport 0 0 *width* *height*) + (pal-ffi:gl-matrix-mode pal-ffi:+gl-projection+) + (pal-ffi:gl-load-identity) + (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) + (clear-screen 0 0 0) + (reset-tags) + (define-tags default-font (load-font "default-font")) + + (add-path *pal-directory*) + (add-path *default-pathname-defaults*) + (if (listp paths) + (dolist (p paths) + (add-path p)) + (add-path paths)))) (declaim (inline clamp)) (defun clamp (min v max) @@ -367,7 +371,7 @@ (image-from-fn (array-dimension array 0) (array-dimension array 1) smoothp - (lambda (y x) + (lambda (x y) (let ((pixel (aref array x y))) (values (first pixel) (second pixel) @@ -417,11 +421,22 @@ (cffi:foreign-free id) (pal-ffi:register-resource image)))) +(defun load-image-to-array (file) + (let* ((surface (pal-ffi:load-image (data-path file)))) + (assert (not (cffi:null-pointer-p surface))) + (let* ((width (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w)) + (height (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)) + (array (make-array (list width height)))) + (do-n (x width y height) + (setf (aref array x y) (multiple-value-list (surface-get-pixel surface x y)))) + (pal-ffi:free-surface surface) + array))) + (defun load-image (file &optional (smoothp nil)) (let* ((surface (pal-ffi:load-image (data-path file))) (image (progn (assert (not (cffi:null-pointer-p surface))) (image-from-fn (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) - (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h) smoothp (lambda (x y) (surface-get-pixel surface x y)))))) --- /project/pal/cvsroot/pal/todo.txt 2007/07/18 21:29:56 1.10 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/19 16:37:25 1.11 @@ -2,6 +2,10 @@ - Add align, scale and angle options to DRAW-IMAGE*. +- Implement image mirroring. + +- Box/box/line/circle etc. overlap functions, faster v-dist + - Improved texture handling - image-to-array/screen-to-array etc. --- /project/pal/cvsroot/pal/readme.txt 2007/07/19 16:37:25 NONE +++ /project/pal/cvsroot/pal/readme.txt 2007/07/19 16:37:25 1.1 Linux gfx card problems It seems that some people (yours truly included, running Ubuntu 7.04 with ATI X550 and the OSS drivers) are having problems under Linux when trying to run PAL applications several times in the same Lisp session. I did some testing and it _looks_ like the problem is in some graphics cards drivers. Of course it is possible that there is a bug in PAL, but so far I haven't find it. Running the following function twice after PAL is loaded should trigger the bug, if present on your system: ----------- (defun test-open-close () (pal-ffi::init pal-ffi::+init-video+) (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 800 600 0 (logior pal-ffi::+gl-doublebuffer+ pal-ffi::+opengl+))) (error "PAL failed to obtain SDL surface")) (pal-ffi::quit)) ----------- This happens on my computer with both SBCL and CLisp, but not with an equivalent C program or any of the Windows CLs that I have tried. So far I have no idea what is causing this but if anyone has any clues or more info I'd appreciate sharing it. Since this kind of bug causes problems when developing in an incremental, "live" environment like CL here are some suboptimal workarounds: - The bug doesn't seem to appear with all drivers/gfx cards. Especially running X11 without HW acceleration should be safe. - Never call CLOSE-PAL. I haven't tested it much, but it should be possible to just call OPEN-PAL when starting your lisp session and never use CLOSE-PAL or WITH-PAL (which eventually calls CLOSE-PAL). Of course this means that some parameters like window size can't be changed after initialisation. - Never return from WITH-PAL. Run your main loop in a separate thread and install condition handlers that just restart your main loop without closing down PAL. That way you can incrementally change your functions/classes etc. while your app is running. I might actually add this as an option to WITH-PAL. All in all this bug mostly has effect only while developing, applications that don't need to open/close PAL several times should work fine. -- tomppa

1 0

[pal-cvs] CVS pal/examples
by tneste 19 Jul '07

19 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv8793/examples Modified Files: images.lisp Log Message: Added LOAD-IMAGE-TO-ARRAY, few bug fixes. --- /project/pal/cvsroot/pal/examples/images.lisp 2007/07/18 19:27:22 1.2 +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/07/19 16:37:25 1.3 @@ -2,11 +2,12 @@ (:use :cl :pal)) (in-package :image-tests) +(defparameter *foo* nil) (define-tags ;; IMAGE-FROM-FN builds and image by calling the FN with x and y coordinates. ;; FN should return at least three VALUES for r, g and b and an optional fourth value for alpha. - image-1 (image-from-fn 256 256 nil + image-1 (image-from-fn 255 255 nil (lambda (x y) (values (truncate (+ 127 (* 128 (sin (/ x 10))))) (truncate (+ 127 (* 128 (cos (/ y 10))))) @@ -16,12 +17,20 @@ ;; Try setting the SMOOTHP parameter to T and see what happens. image-2 (image-from-array nil #2A(((255 255 255 128) (0 0 0) (255 255 255)) ((255 255 255) (255 255 0) (255 255 255)) - ((255 255 255) (0 0 0) (255 255 255 128))))) + ((255 255 255) (0 0 0) (255 255 255 128)))) + ;; LOAD-IMAGE-TO-ARRAY does exactly what it says. Let's load the plane image and randomize the alpha values a bit. + image-3 (image-from-array nil + (let ((image (load-image-to-array "lego-plane.png"))) + (do-n (x (array-dimension image 0) y (array-dimension image 1)) + (when (> (fourth (aref image x y)) 200) + (setf (fourth (aref image x y)) (+ (random 128) 127)))) + image))) -(with-pal () - (set-cursor (tag 'image-2)) ;; sets image-2 as a mouse cursor image + +(with-pal (:paths (merge-pathnames "examples/" pal::*pal-directory*)) + (set-cursor (tag 'image-3)) ;; sets image-3 as a mouse cursor image (let ((a 0f0)) (event-loop () (draw-polygon* (list (v 0 0) @@ -33,7 +42,7 @@ (list 0 0 255 255) (list 0 0 255 255))) ;; just draws a nice gradient background - ;; And draw a pattern of image-1s on the top of it. Not exactly seamlessly tiled but hey... + ;; And draw a pattern of image-1s on the top of it. Not exactly seamless tiles but hey... (draw-rectangle (v 0 0) 800 600 255 255 255 255 :fill (tag 'image-1)) ;; let's scale up a bit to see what the image-2 looks like.

1 0

[pal-cvs] CVS pal/examples
by tneste 18 Jul '07

18 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv26613/examples Modified Files: hello.lisp polygons.lisp Log Message: Added DRAW-CIRCLE --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/16 20:46:23 1.6 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/18 21:29:55 1.7 @@ -4,6 +4,7 @@ (defun hello-1 () (pal:with-pal (:title "Hello!" :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (print (pal:get-gl-info)) (let ((font (pal:load-font "georgia"))) (loop for y from 0 to 300 by 2 do (pal:draw-line (pal:v 0 (* y 2)) (pal:v 800 (* y 2)) --- /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/18 19:27:22 1.4 +++ /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/18 21:29:56 1.5 @@ -64,10 +64,19 @@ ;; For example, image of size 65x30 will be expanded to the size 128x32, so it is a ;; good idea to try and fit the image sizes inside the nearest power of two to save memory. - (with-blend (:color '(255 255 255 128)) - (draw-rectangle (v+ (get-mouse-pos) (v 30 30)) - 100 100 - 255 255 255 64 + ;; (draw-rectangle (v+ (get-mouse-pos) (v 30 30)) + ;; 100 100 + ;; 255 255 255 64 + ;; :absolutep t + ;; :fill slad) + + ;; Replaced with DRAW-CIRCLE, looks a lot nicer that way + ;; It works mostly the same as DRAW-RECTANGLE + + (loop for r from 100 downto 50 by 2 do + (draw-circle (v+ (get-mouse-pos) (v 30 30)) + r + 255 255 255 10 :absolutep t :fill slad))

1 0

[pal-cvs] CVS pal
by tneste 18 Jul '07

18 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv26613 Modified Files: ffi.lisp package.lisp pal.lisp todo.txt Log Message: Added DRAW-CIRCLE --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/18 20:41:34 1.8 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/18 21:29:56 1.9 @@ -681,7 +681,7 @@ (defconstant +gl-points+ 0) (defconstant +gl-ONE-MINUS-DST-ALPHA+ #x305) (defconstant +gl-ONE-MINUS-DST-COLOR+ #x307) -(defconstant +MAX-TEXTURE-SIZE+ #xD33) +(defconstant +gl-MAX-TEXTURE-SIZE+ #xD33) (defconstant +gl-ONE-MINUS-SRC-ALPHA+ #x303) (defconstant +gl-ONE-MINUS-SRC-COLOR+ #x301) (defconstant +gl-texture-mag-filter+ #x2800) @@ -879,6 +879,14 @@ (list :uint) (range :int)) +(cffi:defcfun ("glGetIntegerv" %gl-get-integer) :void + (value :int) + (data :pointer)) + +(defun gl-get-integer (value) + (cffi:with-foreign-object (data :int) + (%gl-get-integer value data) + (cffi:mem-ref data :int))) #+win32 (cffi:defcfun "SHGetFolderPathA" :int (owner :pointer) (folder :int) (handle :pointer) (flags :int) (path :pointer)) --- /project/pal/cvsroot/pal/package.lisp 2007/07/18 20:41:34 1.8 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/18 21:29:56 1.9 @@ -6,6 +6,8 @@ #:+gl-line-smooth+ #:make-font #:+gl-scissor-test+ + #:gl-get-integer + #:+gl-max-texture-size+ #:+gl-smooth+ #:+gl-compile+ #:+gl-points+ --- /project/pal/cvsroot/pal/pal.lisp 2007/07/18 20:41:34 1.14 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/18 21:29:56 1.15 @@ -1,8 +1,8 @@ ;; Notes: ;; tags-resources-free? -;; box/box/line overlap functions, fast v-dist ;; do absolute paths for data-path work? -;; draw-circle +;; box/box/line overlap functions, fast v-dist +;; load-image-to-array (declaim (optimize (speed 3) @@ -31,6 +31,7 @@ (defvar *mouse-x* 0) (defvar *mouse-y* 0) (defvar *current-image* nil) +(defvar *max-texture-size* 0) (declaim (type list *messages*) (type list *clip-stack*) @@ -81,6 +82,7 @@ (reset-tags) (define-tags default-font (load-font "default-font")) (setf *data-paths* nil + *max-texture-size* (pal-ffi:gl-get-integer pal-ffi:+gl-max-texture-size+) *messages* nil *pressed-keys* (make-hash-table :test 'eq) *ticks* (get-internal-real-time) @@ -153,11 +155,11 @@ (error "Data file not found: ~a" file)))) (defun get-gl-info () - (format nil "Vendor: ~a~%Renderer: ~a~%Version: ~a~%Extensions: ~a~%" - (pal-ffi:gl-get-string pal-ffi:+gl-vendor+) - (pal-ffi:gl-get-string pal-ffi:+gl-renderer+) - (pal-ffi:gl-get-string pal-ffi:+gl-version+) - (pal-ffi:gl-get-string pal-ffi:+gl-extensions+))) + (list :vendor (pal-ffi:gl-get-string pal-ffi:+gl-vendor+) + :rendered (pal-ffi:gl-get-string pal-ffi:+gl-renderer+) + :version (pal-ffi:gl-get-string pal-ffi:+gl-version+) + :extensions (pal-ffi:gl-get-string pal-ffi:+gl-extensions+) + :max-texture-size *max-texture-size*)) @@ -372,7 +374,6 @@ (third pixel) (fourth pixel)))))) - (defun image-from-fn (width height smoothp fn) (let* ((mode pal-ffi:+gl-rgb+) (width (min 1024 width)) @@ -639,7 +640,13 @@ (pal-ffi:gl-vertex2f (vx p) (vy p)))))) (pal-ffi:gl-pop-attrib)) - +(defun draw-circle (pos radius r g b a &key (fill t) absolutep (size 1f0) smoothp (segments 30)) + (declare (type vec pos) (type fixnum segments)) + (draw-polygon (loop for a from 0 to (* 2 pi) by (/ (* 2 pi) segments) collecting + (v+ pos + (v (* (sin a) radius) + (* (cos a) radius)))) + r g b a :fill fill :absolutep absolutep :size size :smoothp smoothp)) ;;; Samples @@ -753,12 +760,13 @@ (defun draw-text (text pos &optional font) (declare (type vec pos) (type simple-string text) (type (or font boolean) font)) (with-transformation (:pos pos) - (let ((font (if font - font - (tag 'default-font)))) + (let* ((font (if font + font + (tag 'default-font))) + (first-dl (pal-ffi:font-first-dl font))) (set-image (pal-ffi:font-image font)) (loop for char across text do - (pal-ffi:gl-call-list (+ (pal-ffi:font-first-dl font) (char-code char))))))) + (pal-ffi:gl-call-list (+ first-dl (char-code char))))))) (declaim (inline get-font-height)) (defun get-font-height (&optional font) --- /project/pal/cvsroot/pal/todo.txt 2007/07/18 20:41:36 1.9 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/18 21:29:56 1.10 @@ -1,7 +1,5 @@ TODO: -- More drawing primitives. - - Add align, scale and angle options to DRAW-IMAGE*. - Improved texture handling

1 0

[pal-cvs] CVS pal
by tneste 18 Jul '07

18 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv18802 Modified Files: ffi.lisp package.lisp pal.lisp todo.txt Log Message: DRAW-TEXT now uses display lists --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/18 19:27:22 1.7 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/18 20:41:34 1.8 @@ -438,7 +438,8 @@ (defstruct font (image nil :type (or boolean image)) (glyphs nil :type (or boolean (simple-vector 255))) - (height 0 :type u11)) + (height 0 :type u11) + (first-dl 0 :type u11)) (defstruct music music) @@ -476,6 +477,7 @@ (defmethod free-resource ((resource font)) (when (font-image resource) (free-resource (font-image resource)) + (gl-delete-lists (font-first-dl resource) 255) (setf (font-image resource) nil))) (defmethod free-resource ((resource image)) @@ -679,12 +681,14 @@ (defconstant +gl-points+ 0) (defconstant +gl-ONE-MINUS-DST-ALPHA+ #x305) (defconstant +gl-ONE-MINUS-DST-COLOR+ #x307) +(defconstant +MAX-TEXTURE-SIZE+ #xD33) (defconstant +gl-ONE-MINUS-SRC-ALPHA+ #x303) (defconstant +gl-ONE-MINUS-SRC-COLOR+ #x301) (defconstant +gl-texture-mag-filter+ #x2800) (defconstant +gl-texture-min-filter+ #x2801) (defconstant +gl-linear+ #x2601) (defconstant +gl-rgba+ #x1908) +(defconstant +gl-compile+ #x1300) (defconstant +gl-rgb+ #x1907) (defconstant +gl-scissor-test+ #xC11) (defconstant +gl-unsigned-byte+ #x1401) @@ -859,6 +863,21 @@ (cffi:defcfun ("glGetError" gl-get-error) :int) +(cffi:defcfun ("glGenLists" gl-gen-lists) :uint + (range :int)) + +(cffi:defcfun ("glNewList" gl-new-list) :void + (n :uint) + (mode :int)) + +(cffi:defcfun ("glEndList" gl-end-list) :void) + +(cffi:defcfun ("glCallList" gl-call-list) :void + (n :uint)) + +(cffi:defcfun ("glDeleteLists" gl-delete-lists) :void + (list :uint) + (range :int)) --- /project/pal/cvsroot/pal/package.lisp 2007/07/18 19:27:22 1.7 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/18 20:41:34 1.8 @@ -7,7 +7,14 @@ #:make-font #:+gl-scissor-test+ #:+gl-smooth+ + #:+gl-compile+ #:+gl-points+ + #:gl-gen-lists + #:gl-new-list + #:font-first-dl + #:gl-end-list + #:gl-call-list + #:gl-delete-lists #:free #:calloc #:music-music --- /project/pal/cvsroot/pal/pal.lisp 2007/07/18 19:25:57 1.13 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/18 20:41:34 1.14 @@ -693,12 +693,11 @@ (pos (v 0 0) :type vec) (width 0 :type u11) (height 0 :type u11) - (xoff 0 :type fixnum) - (dl 0 :type u11)) + (xoff 0 :type fixnum)) (defun load-font (font) - (let ((glyphs (make-array 255 :initial-element (make-glyph :width 1 :height 1 :xoff 0 :dl 0) :element-type 'glyph)) + (let ((glyphs (make-array 255 :initial-element (make-glyph :width 1 :height 1 :xoff 0) :element-type 'glyph)) (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 @@ -707,38 +706,59 @@ (let ((glyph (glyph-from-line line))) (setf (aref glyphs (char-code (glyph-char glyph))) glyph))) - (pal-ffi:register-resource (pal-ffi:make-font :image (load-image (concatenate 'string font ".png")) - :height (glyph-height (aref glyphs 32)) - :glyphs glyphs)))) + (let ((font (pal-ffi:register-resource (pal-ffi:make-font :image (load-image (concatenate 'string font ".png")) + :height (glyph-height (aref glyphs 32)) + :first-dl (pal-ffi:gl-gen-lists 255) + :glyphs glyphs)))) + (set-image (pal-ffi:font-image font)) + (loop + for g across (pal-ffi:font-glyphs font) + for dl from 0 to 255 + do + (pal-ffi:gl-new-list (+ (pal-ffi:font-first-dl font) dl) pal-ffi:+gl-compile+) + (draw-glyph (pal-ffi:font-image font) g) + (pal-ffi:gl-end-list)) + font))) (defun glyph-from-line (line) (let ((char (elt line 0)) (coords (read-from-string (concatenate 'string "(" (subseq line 2) ")")))) (make-glyph :char char - :dl 0 :pos (v (first coords) (second coords)) :width (third coords) :height (fourth coords) :xoff (sixth coords)))) +(defun draw-glyph (image g) + (let* ((vx (vx (glyph-pos g))) + (vy (vy (glyph-pos g))) + (width (coerce (glyph-width g) 'single-float)) + (height (coerce (glyph-height g) 'single-float)) + (tx1 (/ vx (pal-ffi:image-texture-width image))) + (ty1 (/ vy (pal-ffi:image-texture-height image))) + (tx2 (/ (+ vx width) (pal-ffi:image-texture-width image))) + (ty2 (/ (+ vy height) (pal-ffi:image-texture-height image)))) + (with-gl pal-ffi:+gl-quads+ + (pal-ffi:gl-tex-coord2f tx1 ty1) + (pal-ffi:gl-vertex2f 0f0 0f0) + (pal-ffi:gl-tex-coord2f tx2 ty1) + (pal-ffi:gl-vertex2f width 0f0) + (pal-ffi:gl-tex-coord2f tx2 ty2) + (pal-ffi:gl-vertex2f width height) + (pal-ffi:gl-tex-coord2f tx1 ty2) + (pal-ffi:gl-vertex2f 0f0 height))) + (translate (v (+ (glyph-width g) (glyph-xoff g)) 0))) + (defun draw-text (text pos &optional font) (declare (type vec pos) (type simple-string text) (type (or font boolean) font)) (with-transformation (:pos pos) - (let* ((font (if font - font - (tag 'default-font))) - (origo (v 0 0)) - (image (pal-ffi:font-image font))) - (declare (type image image) (type vec origo)) + (let ((font (if font + font + (tag 'default-font)))) + (set-image (pal-ffi:font-image font)) (loop for char across text do - (let ((g (aref (pal-ffi:font-glyphs font) (char-code char)))) - (draw-image* image - (glyph-pos g) - origo - (glyph-width g) - (glyph-height g)) - (pal-ffi:gl-translatef (coerce (+ (glyph-width g) (glyph-xoff g)) 'single-float) 0f0 0f0)))))) + (pal-ffi:gl-call-list (+ (pal-ffi:font-first-dl font) (char-code char))))))) (declaim (inline get-font-height)) (defun get-font-height (&optional font) --- /project/pal/cvsroot/pal/todo.txt 2007/07/18 19:27:22 1.8 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/18 20:41:36 1.9 @@ -1,9 +1,5 @@ TODO: -- Add display list support. - -- Font rendering is too slow, maybe use display lists for that? - - More drawing primitives. - Add align, scale and angle options to DRAW-IMAGE*.

1 0

[pal-cvs] CVS pal
by tneste 18 Jul '07

18 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv1000 Modified Files: ffi.lisp package.lisp todo.txt Log Message: Added DRAW-POLYGON* --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/16 14:44:12 1.6 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/18 19:27:22 1.7 @@ -699,6 +699,7 @@ (defconstant +gl-DEPTH-BUFFER-BIT+ #x100) (defconstant +gl-ENABLE-BIT+ #x2000) (defconstant +gl-LINE-BIT+ #x4) +(defconstant +gl-smooth+ #x1D01) (defconstant +gl-LINE-SMOOTH+ #xB20) (defconstant +gl-NEAREST+ #x2600) (defconstant +gl-point-smooth+ #xB10) --- /project/pal/cvsroot/pal/package.lisp 2007/07/16 14:44:12 1.6 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/18 19:27:22 1.7 @@ -6,6 +6,7 @@ #:+gl-line-smooth+ #:make-font #:+gl-scissor-test+ + #:+gl-smooth+ #:+gl-points+ #:free #:calloc @@ -414,6 +415,7 @@ #:image-width #:image-height #:draw-polygon + #:draw-polygon* #:draw-rectangle #:draw-point #:draw-line @@ -443,4 +445,5 @@ #:v-dot #:v-magnitude #:v-normalize #:v-distance #:v-truncate #:v-direction #:closest-point-to-line #:point-in-line #:lines-intersection - #:distance-from-line #:circle-line-intersection #:point-inside-rectangle)) \ No newline at end of file + #:distance-from-line #:circle-line-intersection #:point-inside-rectangle + #:circles-overlap #:point-inside-circle)) \ No newline at end of file --- /project/pal/cvsroot/pal/todo.txt 2007/07/16 14:44:12 1.7 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/18 19:27:22 1.8 @@ -6,6 +6,8 @@ - More drawing primitives. +- Add align, scale and angle options to DRAW-IMAGE*. + - Improved texture handling - image-to-array/screen-to-array etc.

1 0

[pal-cvs] CVS pal/examples
by tneste 18 Jul '07

18 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv1000/examples Modified Files: hares.lisp images.lisp polygons.lisp Log Message: Added DRAW-POLYGON* --- /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/13 21:30:58 1.2 +++ /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/18 19:27:22 1.3 @@ -1,6 +1,5 @@ ;;; Graphics and idea shamelessly ripped from Haaf's Game Engines (http://hge.relishgames.com/) 'Thousands of Hares' demo. - (defpackage :pal-example (:use :cl :pal)) (in-package :pal-example) @@ -54,7 +53,7 @@ (defun example () - (with-pal (:width 800 :height 600 :fullscreenp nil :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:width 800 :height 600 :fullscreenp t :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) (setf *sprites* nil) (set-cursor nil) @@ -72,6 +71,7 @@ :angle (random 360f0))) (event-loop () + (draw-image* (tag 'bg) (v 0 0) (v 0 0) @@ -80,8 +80,7 @@ (with-blend (:mode *blend-mode*) (dolist (i *sprites*) (draw i) - (act i) - )) + (act i))) (test-keys (:key-1 (setf *blend-mode* nil)) --- /project/pal/cvsroot/pal/examples/images.lisp 2007/07/16 14:44:12 1.1 +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/07/18 19:27:22 1.2 @@ -3,18 +3,43 @@ (in-package :image-tests) -(define-tags image-1 (image-from-fn 255 255 t - (lambda (x y) - (values x 0 x y))) - image-2 (image-from-array nil #2A(((255 255 255 128) (0 0 0) (255 255 255)) - ((255 255 255) (255 255 0) (255 255 255)) - ((255 255 255) (0 0 0) (255 255 255 128))))) +(define-tags + ;; IMAGE-FROM-FN builds and image by calling the FN with x and y coordinates. + ;; FN should return at least three VALUES for r, g and b and an optional fourth value for alpha. + image-1 (image-from-fn 256 256 nil + (lambda (x y) + (values (truncate (+ 127 (* 128 (sin (/ x 10))))) + (truncate (+ 127 (* 128 (cos (/ y 10))))) + (truncate (+ 127 (* 128 (cos (/ (+ x y) 10))))) + (truncate (+ 127 (* 128 (cos (/ (- x y) 10)))))))) + ;; IMAGE-FROM-ARRAY builds and image from an 2d array of (list r g b &optional a) + ;; Try setting the SMOOTHP parameter to T and see what happens. + image-2 (image-from-array nil #2A(((255 255 255 128) (0 0 0) (255 255 255)) + ((255 255 255) (255 255 0) (255 255 255)) + ((255 255 255) (0 0 0) (255 255 255 128))))) (with-pal () - (set-cursor (tag 'image-1)) - (event-loop () - (clear-screen 50 100 255) - (with-transformation (:scale 100f0) - (draw-image (tag 'image-2) (v 0 0))))) \ No newline at end of file + (set-cursor (tag 'image-2)) ;; sets image-2 as a mouse cursor image + (let ((a 0f0)) + (event-loop () + (draw-polygon* (list (v 0 0) + (v 800 0) + (v 800 600) + (v 0 600)) + :colors (list (list 255 0 0 255) + (list 255 0 0 255) + (list 0 0 255 255) + (list 0 0 255 255))) ;; just draws a nice gradient background + + ;; And draw a pattern of image-1s on the top of it. Not exactly seamlessly tiled but hey... + (draw-rectangle (v 0 0) 800 600 255 255 255 255 :fill (tag 'image-1)) + + ;; let's scale up a bit to see what the image-2 looks like. + (with-transformation (:pos (v 400 300) :scale a) + (draw-image (tag 'image-2) + (v 0 0) + :valign :middle + :halign :middle + :angle (incf a .5f0)))))) \ No newline at end of file --- /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/16 20:46:24 1.3 +++ /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/18 19:27:22 1.4 @@ -4,9 +4,10 @@ (with-pal (:paths (merge-pathnames "examples/" pal::*pal-directory*)) - (let ((grid (load-image "bg2.png")) + (let ((angle 0f0) + (grid (load-image "bg2.png")) (plane (load-image "lego-plane.png" t)) - (slad (load-image "save_lisp.gif")) + (slad (load-image "save_lisp.gif" t)) (teddy (load-image "yellow-teddy.png"))) (set-cursor nil) (event-loop () @@ -70,6 +71,20 @@ :absolutep t :fill slad)) + ;; DRAW-POLYGON* takes a list of vertex coordinates and as keyword arguments a list of texture coordinates(in pixels) for each vertex, + ;; an image, and a list of lists of rgba values to use for each vertex. + + (with-transformation (:pos (v 600 100) :angle (incf angle .5f0)) + (draw-polygon* (list (v 00 10) + (v 100 200) + (v -100 200)) + :image slad + :tex-coords (list (v 280 240) + (v 380 310) + (v 170 310)) + :colors (list (list 255 255 255 255) + (list 255 0 0 255) + (list 0 0 255 0)))) ;; DRAW-IMAGE* draws a part of image, defined by a starting point, width and height. ;; If width or height are larger than the source image the image is tiled

1 0

[pal-cvs] CVS pal
by tneste 18 Jul '07

18 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv929 Modified Files: vector.lisp Log Message: Few trivial functions added. --- /project/pal/cvsroot/pal/vector.lisp 2007/07/09 18:17:44 1.3 +++ /project/pal/cvsroot/pal/vector.lisp 2007/07/18 19:26:31 1.4 @@ -245,4 +245,14 @@ (y (vy pos))) (if (and (> x x1) (< x x2) (> y y1) (< y y2)) - t nil))) \ No newline at end of file + t nil))) + +(declaim (inline point-inside-circle)) +(defun point-inside-circle (co r p) + (declare (type vec co p) (type component r)) + (<= (v-distance co p) r)) + +(declaim (inline circles-overlap)) +(defun circles-overlap (c1 r1 c2 r2) + (declare (vec c1 c2) (component r1 r2)) + (<= (v-distance c1 c2) (+ r2 r1))) \ No newline at end of file

1 0

[pal-cvs] CVS pal
by tneste 18 Jul '07

18 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv871 Modified Files: pal.lisp Log Message: Added DRAW-POLYGON* --- /project/pal/cvsroot/pal/pal.lisp 2007/07/16 20:46:24 1.12 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/18 19:25:57 1.13 @@ -1,11 +1,8 @@ ;; Notes: ;; tags-resources-free? -;; circle/box/point overlap functions, fast v-dist +;; box/box/line overlap functions, fast v-dist ;; do absolute paths for data-path work? -;; draw-image* aligns & scale, angle? -;; draw-polygon*, draw-circle -;; rgbas for textured polys. -;; opengl state macros +;; draw-circle (declaim (optimize (speed 3) @@ -447,12 +444,12 @@ (let ((x (case halign (:right (coerce (- width) 'single-float)) (:left 0f0) - (:middle (coerce (- (/ width 2)) 'single-float)) + (:middle (- (/ width 2f0))) (otherwise 0f0))) (y (case valign (:bottom (coerce (- height) 'single-float)) (:top 0f0) - (:middle (coerce (- (/ height 2)) 'single-float)) + (:middle (- (/ height 2f0))) (otherwise 0f0)))) (with-gl pal-ffi:+gl-quads+ (pal-ffi:gl-tex-coord2f 0f0 0f0) @@ -604,6 +601,43 @@ (pal-ffi:gl-vertex2f (vx p) (vy p)))) (pal-ffi:gl-pop-attrib)))) +(defun draw-polygon* (points &key image tex-coords colors) + (declare (type list points tex-coords colors) (type (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) + (set-image image) + (cond + (colors + (pal-ffi:gl-shade-model pal-ffi:+gl-smooth+) + (with-gl pal-ffi:+gl-polygon+ + (loop + for p in points + for tc in tex-coords + for c in colors + do + (pal-ffi:gl-tex-coord2f (/ (vx tc) (pal-ffi:image-texture-width image)) (/ (vy tc) (pal-ffi:image-texture-height image))) + (pal-ffi:gl-color4ub (first c) (second c) (third c) (fourth c)) + (pal-ffi:gl-vertex2f (vx p) (vy p))))) + (t + (with-gl pal-ffi:+gl-polygon+ + (loop + for p in points + for tc in tex-coords + do + (pal-ffi:gl-tex-coord2f (/ (vx tc) (pal-ffi:image-texture-width image)) (/ (vy tc) (pal-ffi:image-texture-height image))) + (pal-ffi:gl-vertex2f (vx p) (vy p))))))) + (t + (pal-ffi:gl-shade-model pal-ffi:+gl-smooth+) + (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) + (with-gl pal-ffi:+gl-polygon+ + (loop + for p in points + for c in colors + do + (pal-ffi:gl-color4ub (first c) (second c) (third c) (fourth c)) + (pal-ffi:gl-vertex2f (vx p) (vy p)))))) + (pal-ffi:gl-pop-attrib))

1 0

[pal-cvs] CVS pal/examples
by tneste 16 Jul '07

16 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv16636/examples Modified Files: hello.lisp polygons.lisp swarm.lisp Log Message: Added smoothp option to draw-polygon/line/point/rectangle. RGBA values now have effect on textured images drawn with aforementioned functions. Removed some unnecessary gl-state pushing.(+gl-color-buffer-bit+) --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/13 21:30:58 1.5 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/16 20:46:23 1.6 @@ -7,7 +7,7 @@ (let ((font (pal:load-font "georgia"))) (loop for y from 0 to 300 by 2 do (pal:draw-line (pal:v 0 (* y 2)) (pal:v 800 (* y 2)) - 50 50 255 (truncate y 2))) + 50 50 255 (truncate y 2) :smoothp t)) (let ((midpoint (pal:v-round (pal:v (/ (- (pal:get-screen-width) (pal:get-text-size "Hello from PAL" font)) @@ -25,7 +25,7 @@ (defun hello-2 () - (pal:with-pal () + (pal:with-pal (:fps 10000) (let ((angle 0f0)) (pal:set-blend-color 0 255 0 255) (pal:event-loop () --- /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/13 21:30:58 1.2 +++ /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/16 20:46:24 1.3 @@ -8,6 +8,7 @@ (plane (load-image "lego-plane.png" t)) (slad (load-image "save_lisp.gif")) (teddy (load-image "yellow-teddy.png"))) + (set-cursor nil) (event-loop () (draw-rectangle (v 0 0) @@ -18,6 +19,7 @@ ;; DRAW-IMAGE draw the whole image at given position. Keyword arguments can be given to define the ;; scale, angle and horizontal and vertical alignment ("hotspot") + (draw-arrow (v 700 500) (get-mouse-pos) 255 255 0 255 :size 5f0 :smoothp t) (draw-image plane (v 700 500) :halign :middle ;; Possible options are :left, :right and :middle. :left is the default. @@ -25,10 +27,10 @@ :angle (v-angle (v-direction (v 700 500) (get-mouse-pos))) ;; angle in degrees :scale (* (v-distance (v 700 500) (get-mouse-pos)) .01f0)) - (draw-point (v 700 500) 255 0 0 255 :size 10f0) ;; Draw a red point at the hotspot of previous image. + (draw-point (v 700 500) 255 0 0 255 :size 10f0 :smoothp t) ;; Draw a red point at the hotspot of previous image. ;; DRAW-POLYGON draw a polygon which vertexes are given as a list of VECs. - ;; FILL is either nil, t or image that is used as a pattern. If fill is an image the rgba values have no effect. + ;; FILL is either nil, t or image that is used as a pattern. ;; When ABSOLUTEP is T image patterns position is decided by screen coordinates. ;; Max value of SIZE depends on the OpenGL implementation, you probably shouldn't use values greater than 10f0 @@ -38,7 +40,7 @@ (v 50 100) (v -50 100) ) - 255 0 0 255 + 0 0 255 255 :fill grid :absolutep t) (draw-polygon (list (v -100 0) @@ -47,11 +49,12 @@ (v -50 100) ) 255 0 0 255 - :fill nil :size 4f0 + :fill nil + :size 5f0 + :smoothp t :absolutep nil)) - ;; DRAW-RECTANGLEs arguments are similar to DRAW-POLYGON ;; Notice how the size of the actual SLAD image used is expanded up to the nearest power of two and the extra space is filled with blank, ;; usually this happens transparently to the user (eg. image-width returns the original width of image) but in some cases @@ -61,9 +64,9 @@ ;; good idea to try and fit the image sizes inside the nearest power of two to save memory. (with-blend (:color '(255 255 255 128)) - (draw-rectangle (get-mouse-pos) + (draw-rectangle (v+ (get-mouse-pos) (v 30 30)) 100 100 - 0 0 0 0 + 255 255 255 64 :absolutep t :fill slad)) --- /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/13 21:30:58 1.3 +++ /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/16 20:46:24 1.4 @@ -15,7 +15,7 @@ (let ((midpoint (pal:v/ (reduce 'pal:v+ vectors :initial-value (pal:v 0 0) :key 'car) (max 1f0 (coerce (length vectors) 'single-float))))) - (pal:draw-point midpoint 255 0 0 255 :size 10f0) + (pal:draw-point midpoint 255 0 0 255 :size 10f0 :smoothp t) (setf vectors (mapcar (lambda (v) (cons (pal:v+ (car v) (cdr v)) (pal:v* (pal:v+ (cdr v)

1 0

[pal-cvs] CVS pal
by tneste 16 Jul '07

16 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv16636 Modified Files: pal-macros.lisp pal.lisp Log Message: Added smoothp option to draw-polygon/line/point/rectangle. RGBA values now have effect on textured images drawn with aforementioned functions. Removed some unnecessary gl-state pushing.(+gl-color-buffer-bit+) --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/13 13:21:04 1.6 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/16 20:46:24 1.7 @@ -18,8 +18,7 @@ (maphash (lambda (k v) (declare (ignore k)) (setf (cdr v) nil)) - *tags*) - (define-tags default-font (load-font "default-font"))) + *tags*)) (defun tag (name) (declare (type symbol name)) @@ -82,6 +81,18 @@ ,@body (pal-ffi:gl-end))) +(defmacro with-line-settings (smoothp size r g b a &body body) + `(progn + (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) + (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) + (set-blend-color ,r ,g ,b ,a) + (pal-ffi:gl-line-width ,size) + (if ,smoothp + (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) + (pal-ffi:gl-disable pal-ffi:+gl-line-smooth+)) + ,@body + (pal-ffi:gl-pop-attrib))) + (defmacro randomly (p &body body) `(when (= (random ,p) 0) ,@body)) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/16 14:44:12 1.11 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/16 20:46:24 1.12 @@ -80,9 +80,9 @@ (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-alpha-func pal-ffi:+gl-greater+ 0.0f0) (clear-screen 0 0 0) (reset-tags) + (define-tags default-font (load-font "default-font")) (setf *data-paths* nil *messages* nil *pressed-keys* (make-hash-table :test 'eq) @@ -215,7 +215,6 @@ (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))) (unless (= e 0) @@ -365,10 +364,10 @@ (cffi:mem-ref b :uint8) (cffi:mem-ref a :uint8))))) -(defun image-from-array (smooth-p array) +(defun image-from-array (smoothp array) (image-from-fn (array-dimension array 0) (array-dimension array 1) - smooth-p + smoothp (lambda (y x) (let ((pixel (aref array x y))) (values (first pixel) @@ -377,7 +376,7 @@ (fourth pixel)))))) -(defun image-from-fn (width height smooth-p fn) +(defun image-from-fn (width height smoothp fn) (let* ((mode pal-ffi:+gl-rgb+) (width (min 1024 width)) (height (min 1024 height)) @@ -403,8 +402,8 @@ (cffi:mem-ref tdata :uint8 (+ p 3)) (the u8 a))))) (pal-ffi:gl-gen-textures 1 id) (pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (cffi:mem-ref id :uint)) - (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-mag-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) - (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) + (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-mag-filter+ (if smoothp pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) + (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smoothp pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ 0 mode @@ -420,62 +419,14 @@ (cffi:foreign-free id) (pal-ffi:register-resource image)))) - -(defun image-from-surface (surface smooth-p) - (assert (not (cffi:null-pointer-p surface))) - (image-from-fn (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) - (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) - smooth-p - (lambda (x y) - (surface-get-pixel surface x y)))) - -;; (defun image-from-surface (surface smooth-p) -;; (assert (not (cffi:null-pointer-p surface))) -;; (let* ((width (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w))) -;; (height (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h))) -;; (texture-width (expt 2 (or (find-if (lambda (x) -;; (> (expt 2 x) -;; (1- width))) -;; '(6 7 8 9 10)) 10))) -;; (texture-height (expt 2 (or (find-if (lambda (x) -;; (> (expt 2 x) -;; (1- height))) -;; '(6 7 8 9 10)) 10))) -;; (id (cffi:foreign-alloc :uint :count 1))) -;; (with-foreign-vector (tdata (* texture-width texture-height) 4) -;; (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)))))) -;; (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) -;; (cffi:mem-ref tdata :uint8 (+ p 1)) (the u8 g) -;; (cffi:mem-ref tdata :uint8 (+ p 2)) (the u8 b) -;; (cffi:mem-ref tdata :uint8 (+ p 3)) (the u8 a))))) -;; (pal-ffi:gl-gen-textures 1 id) -;; (pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (cffi:mem-ref id :uint)) -;; (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-mag-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) -;; (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) -;; (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ -;; 0 -;; (if (= (cffi:foreign-slot-value (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:pixelformat) -;; 'pal-ffi:pixelformat 'pal-ffi:bytesperpixel) -;; 3) -;; pal-ffi:+gl-rgb+ -;; pal-ffi:+gl-rgba+) -;; texture-width texture-height 0 pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ tdata)) -;; (let ((image (pal-ffi::make-image :texture (cffi:mem-ref id :uint) -;; :tx2 (coerce (/ width texture-width) 'single-float) -;; :ty2 (coerce (/ height texture-height) 'single-float) -;; :texture-width texture-width -;; :texture-height texture-height -;; :width (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) -;; :height (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)))) -;; (setf *current-image* image) -;; (cffi:foreign-free id) -;; (pal-ffi:register-resource image)))) - -(defun load-image (file &optional (smooth-p nil)) +(defun load-image (file &optional (smoothp nil)) (let* ((surface (pal-ffi:load-image (data-path file))) - (image (image-from-surface surface smooth-p))) + (image (progn (assert (not (cffi:null-pointer-p surface))) + (image-from-fn (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + smoothp + (lambda (x y) + (surface-get-pixel surface x y)))))) (pal-ffi::free-surface surface) image)) @@ -548,56 +499,47 @@ (pal-ffi:gl-vertex2f vx-to (+ vy-to height))))) (declaim (inline draw-line)) -(defun draw-line (la lb r g b a &key (size 1.0f0)) +(defun draw-line (la lb r g b a &key (size 1.0f0) (smoothp)) (declare (type vec la lb) (type u8 r g b a) (type single-float size)) - (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) - (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) - (set-blend-color r g b a) - (pal-ffi:gl-line-width size) - (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) - (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-pop-attrib)) + (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))))) (declaim (inline draw-arrow)) -(defun draw-arrow (la lb r g b a &key (size 1.0f0)) +(defun draw-arrow (la lb r g b a &key (size 1.0f0) smoothp) (declare (type vec la lb) (type u8 r g b a) (type single-float size)) - (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) - (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) - (set-blend-color r g b a) - (pal-ffi:gl-line-width size) - (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) - (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)))))) - (pal-ffi:gl-pop-attrib)) + (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)))))))) (declaim (inline draw-point)) -(defun draw-point (pos r g b a &key (size 1f0)) +(defun draw-point (pos r g b a &key (size 1f0) smoothp) (declare (type vec pos) (type u8 r g b a) (type single-float size)) - (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) + (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+) - (pal-ffi:gl-enable pal-ffi:+gl-point-smooth+) + (if smoothp + (pal-ffi:gl-enable pal-ffi:+gl-point-smooth+) + (pal-ffi:gl-disable pal-ffi:+gl-point-smooth+)) (pal-ffi:gl-point-size size) (set-blend-color r g b a) (with-gl pal-ffi:+gl-point+ (pal-ffi:gl-vertex2f (vx pos) (vy pos))) (pal-ffi:gl-pop-attrib)) -(defun draw-rectangle (pos width height r g b a &key (fill t) (size 1f0) absolutep) +(defun draw-rectangle (pos width height r g b a &key (fill t) (size 1f0) absolutep smoothp) (declare (type vec pos) (type boolean absolutep) (type float size) (type u11 width height) (type u8 r g b a) (type (or image boolean) fill)) - (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) (cond ((image-p fill) (draw-polygon (list pos @@ -608,29 +550,29 @@ :fill fill :absolutep absolutep)) ((eq nil fill) - (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) - (set-blend-color r g b a) - (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) - (pal-ffi:gl-line-width size) - (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-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))))) (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+) (set-blend-color r g b a) - (pal-ffi:gl-rectf (vx pos) (vy pos) (+ (vx pos) width) (+ (vy pos) height)))) - (pal-ffi:gl-pop-attrib)) + (pal-ffi:gl-rectf (vx pos) (vy pos) (+ (vx pos) width) (+ (vy pos) height)) + (pal-ffi:gl-pop-attrib)))) -(defun draw-polygon (points r g b a &key (fill t) absolutep (size 1f0)) +(defun draw-polygon (points r g b a &key (fill t) absolutep (size 1f0) smoothp) (declare (type list points) (type u8 r g b a) (type (or image boolean) fill)) (cond ((image-p fill) + (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+)) (set-image fill) + (set-blend-color r g b a) (with-gl pal-ffi:+gl-polygon+ (let ((dx (vx (first points))) (dy (vy (first points)))) @@ -646,22 +588,17 @@ (- y dy)) (pal-ffi:image-texture-height fill)))) (pal-ffi:gl-tex-coord2f tx ty) - (pal-ffi:gl-vertex2f x y)))))) - ((eq nil fill) - (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) - (pal-ffi:gl-line-width size) - (set-blend-color r g b a) - (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) - (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) - (with-gl pal-ffi:+gl-line-loop+ - (dolist (p points) - (pal-ffi:gl-vertex2f (vx p) (vy p)))) + (pal-ffi:gl-vertex2f x y))))) (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)))))) (t - (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) + (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) (set-blend-color r g b a) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) - (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) (with-gl pal-ffi:+gl-polygon+ (dolist (p points) (pal-ffi:gl-vertex2f (vx p) (vy p))))

1 0

[pal-cvs] CVS pal
by tneste 16 Jul '07

16 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv8836 Modified Files: ffi.lisp package.lisp pal.lisp todo.txt Log Message: Added image-from-array and image-from-fn --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/13 13:21:04 1.5 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/16 14:44:12 1.6 @@ -436,8 +436,8 @@ (width 0 :type u11)) (defstruct font - (image nil :type (or nil image)) - (glyphs nil :type (or nil (simple-vector 255))) + (image nil :type (or boolean image)) + (glyphs nil :type (or boolean (simple-vector 255))) (height 0 :type u11)) (defstruct music @@ -456,8 +456,6 @@ (defgeneric register-resource (resource)) (defgeneric free-resource (resource)) -(defgeneric free-all-resources ()) - (defmethod register-resource (resource) (assert (resource-p resource)) @@ -471,18 +469,26 @@ (setf *resources* (remove resource *resources*))) (defmethod free-resource ((resource music)) - (free-music (music-music resource))) + (when (music-music resource) + (setf (music-music resource) nil) + (free-music (music-music resource)))) (defmethod free-resource ((resource font)) - (free-resource (font-image resource))) + (when (font-image resource) + (free-resource (font-image resource)) + (setf (font-image resource) nil))) (defmethod free-resource ((resource image)) - (gl-delete-texture (image-texture resource))) + (when (> (image-texture resource) 0) + (setf (image-texture resource) 0) + (gl-delete-texture (image-texture resource)))) (defmethod free-resource ((resource sample)) - (free-chunk (sample-chunk resource))) + (when (sample-chunk resource) + (setf (sample-chunk resource) nil) + (free-chunk (sample-chunk resource)))) -(defmethod free-all-resources () +(defun free-all-resources () (dolist (r *resources*) (free-resource r)) (assert (null *resources*))) @@ -491,12 +497,14 @@ (cffi:defctype new-music :pointer) (defmethod cffi:translate-from-foreign (value (name (eql 'new-music))) + (assert (not (cffi:null-pointer-p value))) (let ((music (make-music :music value))) (register-resource music) music)) (cffi:defctype new-sample :pointer) (defmethod cffi:translate-from-foreign (value (name (eql 'new-sample))) + (assert (not (cffi:null-pointer-p value))) (let ((sample (make-sample :chunk value))) (register-resource sample) sample)) --- /project/pal/cvsroot/pal/package.lisp 2007/07/13 21:30:59 1.5 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/16 14:44:12 1.6 @@ -407,6 +407,9 @@ #:pop-clip #:update-screen + #:image-from-array + #:image-from-fn + #:load-image #:image-width #:image-height @@ -417,7 +420,7 @@ #:draw-arrow #:draw-image #:draw-image* - + #:load-font #:get-font-height #:draw-text --- /project/pal/cvsroot/pal/pal.lisp 2007/07/13 21:30:59 1.10 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/16 14:44:12 1.11 @@ -1,10 +1,12 @@ ;; Notes: ;; tags-resources-free? ;; circle/box/point overlap functions, fast v-dist -;; resources should check for void when freeing ;; do absolute paths for data-path work? ;; draw-image* aligns & scale, angle? ;; draw-polygon*, draw-circle +;; rgbas for textured polys. +;; opengl state macros + (declaim (optimize (speed 3) (safety 3))) @@ -50,8 +52,7 @@ (type (or boolean image) *current-image*)) -(defgeneric open-pal (&key width height fps title fullscreenp paths)) -(defmethod open-pal (&key (width 800) (height 600) (fps 60) (title "PAL") (fullscreenp nil) (paths nil)) +(defun open-pal (&key (width 800) (height 600) (fps 60) (title "PAL") (fullscreenp nil) (paths nil)) (when *pal-running* (close-pal)) (pal-ffi:init (logior pal-ffi:+init-video+ pal-ffi:+init-audio+)) @@ -121,8 +122,7 @@ (set-cursor nil)) (pal-ffi:free-all-resources)) -(defgeneric close-pal ()) -(defmethod close-pal () +(defun close-pal () (unwind-protect (progn (free-all-resources) (pal-ffi:close-audio) @@ -365,11 +365,22 @@ (cffi:mem-ref b :uint8) (cffi:mem-ref a :uint8))))) - - -(defun make-texture-from-surface (surface smooth-p) - (let* ((width (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w))) - (height (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h))) +(defun image-from-array (smooth-p array) + (image-from-fn (array-dimension array 0) + (array-dimension array 1) + smooth-p + (lambda (y x) + (let ((pixel (aref array x y))) + (values (first pixel) + (second pixel) + (third pixel) + (fourth pixel)))))) + + +(defun image-from-fn (width height smooth-p fn) + (let* ((mode pal-ffi:+gl-rgb+) + (width (min 1024 width)) + (height (min 1024 height)) (texture-width (expt 2 (or (find-if (lambda (x) (> (expt 2 x) (1- width))) @@ -381,8 +392,11 @@ (id (cffi:foreign-alloc :uint :count 1))) (with-foreign-vector (tdata (* texture-width texture-height) 4) (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)))))) + (multiple-value-bind (r g b a) (funcall fn x y) + (let ((a (or a 255)) + (p (the fixnum (+ (* y (the u16 (* (the u11 texture-width) 4))) (the u16 (* 4 x)))))) + (when (< a 255) + (setf mode pal-ffi:+gl-rgba+)) (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) (cffi:mem-ref tdata :uint8 (+ p 1)) (the u8 g) (cffi:mem-ref tdata :uint8 (+ p 2)) (the u8 b) @@ -393,26 +407,75 @@ (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ 0 - (if (= (cffi:foreign-slot-value (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:pixelformat) - 'pal-ffi:pixelformat 'pal-ffi:bytesperpixel) - 3) - pal-ffi:+gl-rgb+ - pal-ffi:+gl-rgba+) + mode texture-width texture-height 0 pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ tdata)) (let ((image (pal-ffi::make-image :texture (cffi:mem-ref id :uint) :tx2 (coerce (/ width texture-width) 'single-float) :ty2 (coerce (/ height texture-height) 'single-float) :texture-width texture-width :texture-height texture-height - :width (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) - :height (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)))) + :width width + :height height))) (setf *current-image* image) (cffi:foreign-free id) (pal-ffi:register-resource image)))) + +(defun image-from-surface (surface smooth-p) + (assert (not (cffi:null-pointer-p surface))) + (image-from-fn (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) + smooth-p + (lambda (x y) + (surface-get-pixel surface x y)))) + +;; (defun image-from-surface (surface smooth-p) +;; (assert (not (cffi:null-pointer-p surface))) +;; (let* ((width (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w))) +;; (height (min 1024 (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h))) +;; (texture-width (expt 2 (or (find-if (lambda (x) +;; (> (expt 2 x) +;; (1- width))) +;; '(6 7 8 9 10)) 10))) +;; (texture-height (expt 2 (or (find-if (lambda (x) +;; (> (expt 2 x) +;; (1- height))) +;; '(6 7 8 9 10)) 10))) +;; (id (cffi:foreign-alloc :uint :count 1))) +;; (with-foreign-vector (tdata (* texture-width texture-height) 4) +;; (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)))))) +;; (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) +;; (cffi:mem-ref tdata :uint8 (+ p 1)) (the u8 g) +;; (cffi:mem-ref tdata :uint8 (+ p 2)) (the u8 b) +;; (cffi:mem-ref tdata :uint8 (+ p 3)) (the u8 a))))) +;; (pal-ffi:gl-gen-textures 1 id) +;; (pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (cffi:mem-ref id :uint)) +;; (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-mag-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) +;; (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) +;; (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ +;; 0 +;; (if (= (cffi:foreign-slot-value (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:pixelformat) +;; 'pal-ffi:pixelformat 'pal-ffi:bytesperpixel) +;; 3) +;; pal-ffi:+gl-rgb+ +;; pal-ffi:+gl-rgba+) +;; texture-width texture-height 0 pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ tdata)) +;; (let ((image (pal-ffi::make-image :texture (cffi:mem-ref id :uint) +;; :tx2 (coerce (/ width texture-width) 'single-float) +;; :ty2 (coerce (/ height texture-height) 'single-float) +;; :texture-width texture-width +;; :texture-height texture-height +;; :width (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) +;; :height (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)))) +;; (setf *current-image* image) +;; (cffi:foreign-free id) +;; (pal-ffi:register-resource image)))) + (defun load-image (file &optional (smooth-p nil)) (let* ((surface (pal-ffi:load-image (data-path file))) - (image (make-texture-from-surface surface smooth-p))) + (image (image-from-surface surface smooth-p))) (pal-ffi::free-surface surface) image)) @@ -541,7 +604,7 @@ (v+ pos (v width 0)) (v+ pos (v width height)) (v+ pos (v 0 height))) - 0 0 0 0 + r g b a :fill fill :absolutep absolutep)) ((eq nil fill) --- /project/pal/cvsroot/pal/todo.txt 2007/07/13 21:30:59 1.6 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/16 14:44:12 1.7 @@ -6,7 +6,9 @@ - More drawing primitives. -- image-from-array/image-to-array/screen-to-array etc. +- Improved texture handling + +- image-to-array/screen-to-array etc. - Fix the FPS limiter, the results could be a lot smoother.

1 0

[pal-cvs] CVS pal/examples
by tneste 16 Jul '07

16 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv8836/examples Added Files: images.lisp utils.lisp Log Message: Added image-from-array and image-from-fn --- /project/pal/cvsroot/pal/examples/images.lisp 2007/07/16 14:44:12 NONE +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/07/16 14:44:12 1.1 (defpackage :image-tests (:use :cl :pal)) (in-package :image-tests) (define-tags image-1 (image-from-fn 255 255 t (lambda (x y) (values x 0 x y))) image-2 (image-from-array nil #2A(((255 255 255 128) (0 0 0) (255 255 255)) ((255 255 255) (255 255 0) (255 255 255)) ((255 255 255) (0 0 0) (255 255 255 128))))) (with-pal () (set-cursor (tag 'image-1)) (event-loop () (clear-screen 50 100 255) (with-transformation (:scale 100f0) (draw-image (tag 'image-2) (v 0 0)))))--- /project/pal/cvsroot/pal/examples/utils.lisp 2007/07/16 14:44:12 NONE +++ /project/pal/cvsroot/pal/examples/utils.lisp 2007/07/16 14:44:12 1.1 ;; Some examples of the misc macros and utility functions in PAL ;; Get path to applications user specific data directory. Application name is taken from the :title argument ;; to OPEN/WITH-PAL so be careful to set it to something sensible. ;; If the directory doesn't exists it is created, the exact location of the files is OS dependant. (pal:get-application-folder) (pal:get-application-file "saved_game.data") ;; DO-N is like DO-TIMES but it iterates over the cartesian product of its arguments. Handy when working with tilemaps etc. (pal:do-n (i 3 j 3 k 3) (format t "~a ~a ~a~%" i j k)) ;; RANDOMLY evaluates its body, umm, randomly. (pal:randomly 10 (print "I'm a lucky s-expression!")) ;; has a 1/10 chance to get evaluated ;; CURRY, your average currying macro (mapcar (pal:curry '* 2 2) '(1 2 3 4 5)) ;; RELT returns a random element in a sequence (pal:relt (mapcar (pal:curry '* 2 2) '(1 2 3 4 5))) ;; CLAMPs a value between min and max (pal:clamp 10 (random 30) 20) ;; DATA-PATH searches for a file from the PATHS given to PAL and returns the first match (pal:data-path "foo.png")

1 0

[pal-cvs] CVS pal
by tneste 13 Jul '07

13 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv13905 Modified Files: package.lisp pal.asd pal.lisp todo.txt Log Message: Rest of the api changes applied. --- /project/pal/cvsroot/pal/package.lisp 2007/07/13 13:21:04 1.4 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/13 21:30:59 1.5 @@ -416,9 +416,8 @@ #:draw-line #:draw-arrow #:draw-image - #:draw-image-from - #:draw-quad - + #:draw-image* + #:load-font #:get-font-height #:draw-text --- /project/pal/cvsroot/pal/pal.asd 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/pal.asd 2007/07/13 21:30:59 1.2 @@ -2,7 +2,10 @@ (in-package #:asdf) (defsystem pal - :components + :description "Pixel Art Library" + :author "Tomi Neste" + :license "MIT" + :components ((:file "ffi" :depends-on ("package")) (:file "vector" --- /project/pal/cvsroot/pal/pal.lisp 2007/07/13 13:21:04 1.9 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/13 21:30:59 1.10 @@ -1,10 +1,10 @@ -;; Urgent: +;; Notes: ;; tags-resources-free? ;; circle/box/point overlap functions, fast v-dist ;; resources should check for void when freeing -;; sdl window not always on top on windows? ;; do absolute paths for data-path work? -;; draw-image aligns, draw-quad! abs. +;; draw-image* aligns & scale, angle? +;; draw-polygon*, draw-circle (declaim (optimize (speed 3) (safety 3))) @@ -416,21 +416,30 @@ (pal-ffi::free-surface surface) image)) -(defun draw-image (image pos &key angle scale (valign :left) (halign :top)) +(defun draw-image (image pos &key angle scale valign halign) (declare (type image image) (type vec pos) (type (or boolean single-float) angle scale) (type symbol halign valign)) (set-image image) (let ((width (image-width image)) (height (image-height image)) (tx2 (pal-ffi:image-tx2 image)) (ty2 (pal-ffi:image-ty2 image))) - (if angle + (if (or angle scale valign halign) (with-transformation () (translate pos) - (rotate angle) + (when angle + (rotate angle)) (when scale - (scale scale scale)) - (let ((x (- (/ (image-width image) 2f0))) - (y (- (/ (image-height image) 2f0)))) + (scale scale scale)) ;; :-) + (let ((x (case halign + (:right (coerce (- width) 'single-float)) + (:left 0f0) + (:middle (coerce (- (/ width 2)) 'single-float)) + (otherwise 0f0))) + (y (case valign + (:bottom (coerce (- height) 'single-float)) + (:top 0f0) + (:middle (coerce (- (/ height 2)) 'single-float)) + (otherwise 0f0)))) (with-gl pal-ffi:+gl-quads+ (pal-ffi:gl-tex-coord2f 0f0 0f0) (pal-ffi:gl-vertex2f x y) @@ -440,32 +449,21 @@ (pal-ffi:gl-vertex2f (+ x width) (+ y height)) (pal-ffi:gl-tex-coord2f 0f0 ty2) (pal-ffi:gl-vertex2f x (+ y height))))) - (with-gl pal-ffi:+gl-quads+ - (pal-ffi:gl-tex-coord2f 0f0 0f0) - (pal-ffi:gl-vertex2f (vx pos) (vy pos)) - (pal-ffi:gl-tex-coord2f tx2 0f0) - (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos)) - (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height)) - (pal-ffi:gl-tex-coord2f 0f0 ty2) - (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height)))))) + (let ((x (vx pos)) + (y (vy pos))) + (with-gl pal-ffi:+gl-quads+ + (pal-ffi:gl-tex-coord2f 0f0 0f0) + (pal-ffi:gl-vertex2f x y) + (pal-ffi:gl-tex-coord2f tx2 0f0) + (pal-ffi:gl-vertex2f (+ x width) y) + (pal-ffi:gl-tex-coord2f tx2 ty2) + (pal-ffi:gl-vertex2f (+ x width) (+ y height)) + (pal-ffi:gl-tex-coord2f 0f0 ty2) + (pal-ffi:gl-vertex2f x (+ y height))))))) -(defun draw-quad (image a b c d &key absolutep) - (declare (type image image) (type vec a b c d)) - (set-image image) - (let ((tx2 (pal-ffi:image-tx2 image)) - (ty2 (pal-ffi:image-ty2 image))) - (with-gl pal-ffi:+gl-quads+ - (pal-ffi:gl-tex-coord2f 0f0 0f0) - (pal-ffi:gl-vertex2f (vx a) (vy a)) - (pal-ffi:gl-tex-coord2f tx2 0f0) - (pal-ffi:gl-vertex2f (vx b) (vy b)) - (pal-ffi:gl-tex-coord2f tx2 ty2) - (pal-ffi:gl-vertex2f (vx c) (vy c)) - (pal-ffi:gl-tex-coord2f 0f0 ty2) - (pal-ffi:gl-vertex2f (vx d) (vy d))))) -(defun draw-image-from (image from-pos to-pos width height) + +(defun draw-image* (image from-pos to-pos width height) (declare (type image image) (type vec from-pos to-pos) (type u11 width height)) (set-image image) (let* ((vx (vx from-pos)) @@ -534,15 +532,21 @@ (pal-ffi:gl-vertex2f (vx pos) (vy pos))) (pal-ffi:gl-pop-attrib)) -(defun draw-rectangle (pos width height r g b a &key (filledp t) (size 1f0)) - (declare (type vec pos) (type float size) (type u11 width height) (type u8 r g b a) (type boolean filledp)) +(defun draw-rectangle (pos width height r g b a &key (fill t) (size 1f0) absolutep) + (declare (type vec pos) (type boolean absolutep) (type float size) (type u11 width height) (type u8 r g b a) (type (or image boolean) fill)) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) - (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) - (set-blend-color r g b a) (cond - (filledp - (pal-ffi:gl-rectf (vx pos) (vy pos) (+ (vx pos) width) (+ (vy pos) height))) - (t + ((image-p fill) + (draw-polygon (list pos + (v+ pos (v width 0)) + (v+ pos (v width height)) + (v+ pos (v 0 height))) + 0 0 0 0 + :fill fill + :absolutep absolutep)) + ((eq nil fill) + (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) + (set-blend-color r g b a) (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) (pal-ffi:gl-line-width size) (with-gl pal-ffi:+gl-line-loop+ @@ -552,10 +556,14 @@ (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))))) + (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height)))) + (t + (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) + (set-blend-color r g b a) + (pal-ffi:gl-rectf (vx pos) (vy pos) (+ (vx pos) width) (+ (vy pos) height)))) (pal-ffi:gl-pop-attrib)) -(defun draw-polygon (points r g b a &key fill absolutep (size 1f0)) +(defun draw-polygon (points r g b a &key (fill t) absolutep (size 1f0)) (declare (type list points) (type u8 r g b a) (type (or image boolean) fill)) (cond ((image-p fill) @@ -648,8 +656,7 @@ (defstruct glyph (char #\space :type character) - (x 0 :type u11) - (y 0 :type u11) + (pos (v 0 0) :type vec) (width 0 :type u11) (height 0 :type u11) (xoff 0 :type fixnum) @@ -657,7 +664,7 @@ (defun load-font (font) - (let ((glyphs (make-array 255 :initial-element (make-glyph :x 0 :y 0 :width 1 :height 1 :xoff 0 :dl 0) :element-type 'glyph)) + (let ((glyphs (make-array 255 :initial-element (make-glyph :width 1 :height 1 :xoff 0 :dl 0) :element-type 'glyph)) (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 @@ -675,32 +682,29 @@ (coords (read-from-string (concatenate 'string "(" (subseq line 2) ")")))) (make-glyph :char char :dl 0 - :x (first coords) - :y (second coords) + :pos (v (first coords) + (second coords)) :width (third coords) :height (fourth coords) :xoff (sixth coords)))) -(defun draw-glyph (char font) - (declare (type font font) (type character char)) - (let ((image (pal-ffi:font-image font)) - (g (aref (pal-ffi:font-glyphs font) (char-code char)))) - (draw-image-from image - (v (glyph-x g) - (glyph-y g)) - (v 0 0) - (glyph-width g) - (glyph-height g)) - (pal-ffi:gl-translatef (coerce (+ (glyph-width g) (glyph-xoff g)) 'single-float) 0f0 0f0))) - (defun draw-text (text pos &optional font) (declare (type vec pos) (type simple-string text) (type (or font boolean) font)) (with-transformation (:pos pos) - (let ((font (if font - font - (tag 'default-font)))) - (loop for c across text do - (draw-glyph c font))))) + (let* ((font (if font + font + (tag 'default-font))) + (origo (v 0 0)) + (image (pal-ffi:font-image font))) + (declare (type image image) (type vec origo)) + (loop for char across text do + (let ((g (aref (pal-ffi:font-glyphs font) (char-code char)))) + (draw-image* image + (glyph-pos g) + origo + (glyph-width g) + (glyph-height g)) + (pal-ffi:gl-translatef (coerce (+ (glyph-width g) (glyph-xoff g)) 'single-float) 0f0 0f0)))))) (declaim (inline get-font-height)) (defun get-font-height (&optional font) --- /project/pal/cvsroot/pal/todo.txt 2007/07/13 13:21:04 1.5 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/13 21:30:59 1.6 @@ -2,25 +2,40 @@ - Add display list support. -- Make font rendering use display lists. +- Font rendering is too slow, maybe use display lists for that? - More drawing primitives. - image-from-array/image-to-array/screen-to-array etc. -- Fix the FPS limiter. +- Fix the FPS limiter, the results could be a lot smoother. - Check the sanity of vector.lisp and add some operations, esp. bounding-boxes etc. - Correct aspect ratio when fullscreen on widescreen displays. -- CL native font resource builder. +- I would really like to see it run on OS X. -- Fix with-blend (r g b a). +- Simple and transparent animation system for images. -- Make it run on OS X. +- Using fullscreen mode on Windows some times results in screen flickering + between desktop and PAL screen, usually fixed by alt-tabbing. Should be fixed. -- TrueType font support. +- The problems with Linux and some gfx drivers should be somehow fixed. -- Simple animation system for images. +- Documentation and tutorials. + + + +As separate projects on top of PAL: + +- Native CL font resource builder + +- TTF support + +- GUI + +- Some sort of sprite library? + +- Network code?

1 0

[pal-cvs] CVS pal/examples
by tneste 13 Jul '07

13 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv13905/examples Modified Files: hares.lisp hello.lisp polygons.lisp swarm.lisp teddy.lisp Log Message: Rest of the api changes applied. --- /project/pal/cvsroot/pal/examples/hares.lisp 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/examples/hares.lisp 2007/07/13 21:30:58 1.2 @@ -32,8 +32,10 @@ (set-blend-color (r-of s) (g-of s) (b-of s) 255) (draw-image (image-of s) (pos-of s) - (angle-of s) - (scale-of s))) + :halign :middle + :valign :middle + :angle (angle-of s) + :scale (scale-of s))) (defmethod act ((s sprite)) (setf (angle-of s) (mod (+ (angle-of s) 1f0) 360)) @@ -52,7 +54,7 @@ (defun example () - (with-pal (:width 800 :height 600 :fullscreenp nil :fps 6000) + (with-pal (:width 800 :height 600 :fullscreenp nil :fps 6000 :paths (merge-pathnames "examples/" pal::*pal-directory*)) (setf *sprites* nil) (set-cursor nil) @@ -70,11 +72,11 @@ :angle (random 360f0))) (event-loop () - (draw-image-from (tag 'bg) - (v 0 0) - (v 0 0) - (get-screen-width) - (get-screen-height)) + (draw-image* (tag 'bg) + (v 0 0) + (v 0 0) + (get-screen-width) + (get-screen-height)) (with-blend (:mode *blend-mode*) (dolist (i *sprites*) (draw i) --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/03 18:42:33 1.4 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/13 21:30:58 1.5 @@ -3,17 +3,22 @@ (defun hello-1 () - (pal:with-pal (:paths "/path/to/examples/") + (pal:with-pal (:title "Hello!" :paths (merge-pathnames "examples/" pal::*pal-directory*)) (let ((font (pal:load-font "georgia"))) - (pal:draw-text "Hello from PAL" - (pal:v-round - (pal:v (/ (- (pal:get-screen-width) - (pal:get-text-size "Hello from PAL" font)) - 2) - (/ (- (pal:get-screen-height) - (pal:get-font-height font)) - 2))) - font)) + (loop for y from 0 to 300 by 2 do + (pal:draw-line (pal:v 0 (* y 2)) (pal:v 800 (* y 2)) + 50 50 255 (truncate y 2))) + (let ((midpoint (pal:v-round + (pal:v (/ (- (pal:get-screen-width) + (pal:get-text-size "Hello from PAL" font)) + 2) + (/ (- (pal:get-screen-height) + (pal:get-font-height font)) + 2))))) + (pal:set-blend-color 0 0 0 255) + (pal:draw-text "Hello from PAL" (pal:v+ midpoint (pal:v 5 5)) font) + (pal:reset-blend-mode) + (pal:draw-text "Hello from PAL" midpoint font))) (pal:wait-keypress))) ;; (hello-1) --- /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/13 13:21:04 1.1 +++ /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/13 21:30:58 1.2 @@ -3,22 +3,34 @@ (in-package :poly-tests) -(with-pal () +(with-pal (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let ((grid (load-image "bg2.png")) + (plane (load-image "lego-plane.png" t)) (slad (load-image "save_lisp.gif")) (teddy (load-image "yellow-teddy.png"))) (event-loop () - ;; DRAW-RECTANGLE just draws a filled or wireframe rectangle on screen - (draw-rectangle (v 0 0) 800 600 - 0 0 0 32 :filledp t) + 0 0 0 32) ;; Draw a black, transparent rectangle over the scene. + ;; (clear-screen 0 0 0) ;; Use this instead if the afterimages give you a headache. + + ;; DRAW-IMAGE draw the whole image at given position. Keyword arguments can be given to define the + ;; scale, angle and horizontal and vertical alignment ("hotspot") + + (draw-image plane + (v 700 500) + :halign :middle ;; Possible options are :left, :right and :middle. :left is the default. + :valign :bottom ;; -''- :top, :bottom, :middle. :top is the default. + :angle (v-angle (v-direction (v 700 500) (get-mouse-pos))) ;; angle in degrees + :scale (* (v-distance (v 700 500) (get-mouse-pos)) .01f0)) + + (draw-point (v 700 500) 255 0 0 255 :size 10f0) ;; Draw a red point at the hotspot of previous image. ;; DRAW-POLYGON draw a polygon which vertexes are given as a list of VECs. - ;; FILL is either nil, true or image that is used as a pattern. If fill is an image the rgba values are not used. + ;; FILL is either nil, t or image that is used as a pattern. If fill is an image the rgba values have no effect. ;; When ABSOLUTEP is T image patterns position is decided by screen coordinates. - + ;; Max value of SIZE depends on the OpenGL implementation, you probably shouldn't use values greater than 10f0 (with-transformation (:pos (v 100 100)) (draw-polygon (list (v -100 0) @@ -35,34 +47,39 @@ (v -50 100) ) 255 0 0 255 - :fill nil :size 5f0 + :fill nil :size 4f0 :absolutep nil)) - ;; Note: next one doesn't work like you might expect since the image size is rounded up - ;; to the nearest power of two and the extra is filled with blank. - - (with-blend (:color '(255 255 255 20)) - (draw-polygon (list (v+ (get-mouse-pos) (v -100 -100)) - (v+ (get-mouse-pos) (v 100 -100)) - (v+ (get-mouse-pos) (v 100 100)) - (v+ (get-mouse-pos) (v -100 100))) - 0 0 0 0 - :absolutep t - :fill slad)) - ;; DRAW-IMAGE-FROM draws a part of image, defined by a starting point, width and height. - ;; If width or height are larger than the source image the image is tiled + ;; DRAW-RECTANGLEs arguments are similar to DRAW-POLYGON + ;; Notice how the size of the actual SLAD image used is expanded up to the nearest power of two and the extra space is filled with blank, + ;; usually this happens transparently to the user (eg. image-width returns the original width of image) but in some cases + ;; it can cause some artifacts. In this case if the original image had width and height of power of two it would be seamlessly + ;; tiled across the screen. + ;; For example, image of size 65x30 will be expanded to the size 128x32, so it is a + ;; good idea to try and fit the image sizes inside the nearest power of two to save memory. + + (with-blend (:color '(255 255 255 128)) + (draw-rectangle (get-mouse-pos) + 100 100 + 0 0 0 0 + :absolutep t + :fill slad)) - (draw-image-from teddy (v 0 (get-mouse-y)) - (v (get-mouse-x) 0) - (truncate (image-width teddy) 2) - (get-screen-height)) - (draw-image-from teddy (v (truncate (image-width teddy) 2) (get-mouse-y) ) - (v (- (get-screen-width) (get-mouse-x)) 0) - (truncate (image-width teddy) 2) - (get-screen-height)) - ;; (draw-quad ...) to be done + ;; DRAW-IMAGE* draws a part of image, defined by a starting point, width and height. + ;; If width or height are larger than the source image the image is tiled + ;; Like with DRAW-POLYGON non-power-of-two image sizes can give unexpected results. - ))) \ No newline at end of file + (let ((x (abs (- 400 (get-mouse-x))))) + (draw-image* teddy + (v 0 (get-mouse-y)) + (v x 0) + (truncate (image-width teddy) 2) + (get-screen-height)) + (draw-image* teddy + (v (truncate (image-width teddy) 2) (get-mouse-y) ) + (v (- (get-screen-width) x) 0) + (truncate (image-width teddy) 2) + (get-screen-height)))))) \ No newline at end of file --- /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/03 18:42:33 1.2 +++ /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/13 21:30:58 1.3 @@ -9,13 +9,13 @@ (setf vectors (append vectors (loop repeat 50 collecting (cons (pal:get-mouse-pos) (pal:v-random 5f0)))))))) (pal:draw-rectangle (pal:v 0 0) 1024 768 0 0 0 128) - (pal:with-blend (:r 255 :g 128 :b 128 :a 255) + (pal:with-blend (:color '(255 128 128 255)) (pal:draw-text "Use left mousekey to add particles." (pal:v 0 0))) (let ((midpoint (pal:v/ (reduce 'pal:v+ vectors :initial-value (pal:v 0 0) :key 'car) (max 1f0 (coerce (length vectors) 'single-float))))) - (pal:draw-point midpoint 255 0 0 255 10f0) + (pal:draw-point midpoint 255 0 0 255 :size 10f0) (setf vectors (mapcar (lambda (v) (cons (pal:v+ (car v) (cdr v)) (pal:v* (pal:v+ (cdr v) @@ -31,6 +31,6 @@ (pal:draw-arrow (car v) (pal:v+ (car v) (cdr v)) 10 7 0 255 - 10f0))))))) + :size 10f0))))))) ;; (swarm) \ No newline at end of file --- /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/01 22:49:25 1.2 +++ /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/13 21:30:58 1.3 @@ -22,6 +22,7 @@ (defclass sprite () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (vel :accessor vel-of :initarg :vel :initform (v 0 0)) + (alt :accessor alt-of :initarg :alt :initform 10) (image :accessor image-of :initarg :image) (angle :accessor angle-of :initarg :angle :initform 0f0))) @@ -36,7 +37,9 @@ (defmethod draw ((s sprite)) (draw-image (image-of s) (pos-of s) - (angle-of s))) + :valign :middle + :halign :middle + :angle (angle-of s))) @@ -64,15 +67,19 @@ (defun example () - (with-pal (:width 800 :height 600 :fullscreenp nil :fps 60) + (with-pal (:width 800 :height 600 :fullscreenp nil :fps 60 :paths (merge-pathnames "examples/" pal::*pal-directory*)) ;; inits PAL, the args used are the default values. - ;; NOTE: fix the PATHS to point to the location of the resource files - ;; PATHS is a pathname or list of pathnames that defines paths that the LOAD-* functions use for finding resources. + ;; PATHS is a pathname or list of pathnames that PAL uses to find the resource files loaded with LOAD-* functions. + ;; By default PATHS contains the PAL source directory and value of *default-pathname-defaults* ;; only call PAL functions (with the expection of DEFINE-TAGS forms) inside WITH-PAL or between OPEN-PAL and CLOSE-PAL (setf *sprites* nil) + + ;; Hide the mouse cursor and use cursor.png instead. 18,18 is the offset ("hotspot") for the cursor image + ;; Other possible options to cursor are: t - show the default cursor, nil - hide all cursors (set-cursor (tag 'cursor) (v 18 18)) - (make-instance 'plane) + + (make-instance 'plane :alt 20) (dotimes (i 20) (make-instance 'mutant-teddy :pos (v (random (get-screen-width)) @@ -82,35 +89,47 @@ (event-loop () ;; simple event loop, no mouse-move, key-down etc. handlers defined, we'll handle input explicitly with TEST-KEYS. - ;; the default key-down handler quits the event-loop when ESC is pressed. - ;; to define e.g. a key-handler use a form like (event-loop (:key-down-handler (lambda (key) ...)) ...) + ;; The default key-down handler quits the event-loop when ESC is pressed, if you define your own key-down-handler + ;; don't forget to make sure there is a way to quit pal (especially when in fullscreen). + ;; to define e.g. a key-handler use a form like (event-loop (:key-down-fn (lambda (key) ...)) ...) ;; you can quit the event loop with (return-from event-loop) ;; first, draw a scrolling tiled background - (draw-image-from (tag 'tile) - (v 0 0) - (v 0 (- *y-scroll* 64)) - (get-screen-width) - (+ (get-screen-height) 64)) + (draw-image* (tag 'tile) + (v 0 0) + (v 0 (- *y-scroll* 64)) + (get-screen-width) + (+ (get-screen-height) 64)) (setf *y-scroll* (mod (+ *y-scroll* 1) 64)) - ;; then the sprites + ;; then the sprites, first the shadows + ;; sorting the sprites and their shadows according to their altitude is left as an exercise to the reader + + (with-blend (:color '(0 0 0 128)) + (dolist (i *sprites*) + (with-transformation (:pos (v (alt-of i) (alt-of i))) + (draw i)))) + (with-blend (:mode *blend-mode*) (dolist (i *sprites*) (draw i) + + ;; Let's do this for CLisp or we might a get nasty floating-point-undereflow error in the vector operations. #+CLISP (ext:without-floating-point-underflow (act i)) #-CLISP (act i))) + ;; TEST-KEYS is used to check if some key is currently pressed, _all_ the matching forms are evaluated. (test-keys (:key-1 (setf *blend-mode* nil) (message *blend-mode*)) (:key-2 (setf *blend-mode* :blend) (message *blend-mode*)) - (:key-3 (setf *blend-mode* :additive) - (message *blend-mode*))) + ;; We can also test for several keys at once: + ((:key-3 :key-space :key-mouse-1) (setf *blend-mode* :additive) + (message *blend-mode*))) - (draw-fps) + (draw-fps) ;; Draw the frames/second counter to the top left corner. (draw-text "Press key to select blend-mode:" (v 200 (* 0 (get-font-height)))) (draw-text "1=nil 2=:blend 3=:additive" (v 200 (* 1 (get-font-height)))))))

1 0

[pal-cvs] CVS pal
by tneste 13 Jul '07

13 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv16987 Modified Files: ffi.lisp package.lisp pal-macros.lisp pal.lisp todo.txt Log Message: Changes in the API, especially in the various DRAW-* functions. Most examples still not updated, polygon examples added. --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/09 18:17:44 1.4 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/13 13:21:04 1.5 @@ -464,6 +464,9 @@ (push resource *resources*) resource) +(defmethod free-resource :before (resource) + (assert (typep resource 'resource))) + (defmethod free-resource :after (resource) (setf *resources* (remove resource *resources*))) @@ -860,4 +863,6 @@ (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 --- /project/pal/cvsroot/pal/package.lisp 2007/07/09 18:17:44 1.3 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/13 13:21:04 1.4 @@ -371,7 +371,6 @@ #:get-application-file #:data-path #:with-resource - #:with-clipping #:randomly #:relt @@ -403,6 +402,10 @@ #:reset-blend-mode #:set-blend-color #:with-blend + #:with-clipping + #:push-clip + #:pop-clip + #:update-screen #:load-image #:image-width --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/09 18:17:44 1.5 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/13 13:21:04 1.6 @@ -41,17 +41,18 @@ (defmacro with-default-settings (&body body) `(with-transformation () - (with-blend (:mode :blend :r 255 :g 255 :b 255 :a 255) + (with-blend (:mode :blend :color '(255 255 255 255)) (pal-ffi:gl-load-identity) ,@body))) -(defmacro with-blend ((&key (mode t) r g b a) &body body) + +(defmacro with-blend ((&key (mode t) color) &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)) + ,(when color + `(set-blend-color (first ,color) (second ,color) (third ,color) (fourth ,color))) ,@body (pal-ffi:gl-pop-attrib))) @@ -112,8 +113,10 @@ args))) (defmacro funcall? (fn &rest args) - `(when ,fn - (funcall ,fn ,@args))) + (if (null fn) + nil + `(funcall ,fn ,@args))) + (defmacro do-event (event key-up-fn key-down-fn mouse-motion-fn quit-fn) `(loop while (pal-ffi:poll-event ,event) @@ -169,7 +172,7 @@ (defmacro event-loop ((&key key-up-fn key-down-fn mouse-motion-fn quit-fn) &body redraw) (let ((event (gensym))) `(block event-loop - (cffi:with-foreign-object (,event :char 1000) + (cffi:with-foreign-object (,event :char 500) (loop (do-event ,event ,key-up-fn ,key-down-fn ,mouse-motion-fn ,quit-fn) ,@redraw --- /project/pal/cvsroot/pal/pal.lisp 2007/07/09 18:17:44 1.8 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/13 13:21:04 1.9 @@ -1,9 +1,10 @@ -;; are the texture options sane for draw-poly etc. +;; Urgent: ;; tags-resources-free? -;; animations -;; circle/box/point overlap functions +;; circle/box/point overlap functions, fast v-dist ;; resources should check for void when freeing -;; sdl window not on top? +;; sdl window not always on top on windows? +;; do absolute paths for data-path work? +;; draw-image aligns, draw-quad! abs. (declaim (optimize (speed 3) (safety 3))) @@ -186,7 +187,7 @@ (defun dispatch-event (&key key-up-fn key-down-fn mouse-motion-fn quit-fn) (block event-loop - (cffi:with-foreign-object (event :char 100) + (cffi:with-foreign-object (event :char 500) (do-event event key-up-fn key-down-fn mouse-motion-fn quit-fn)))) (defun wait-keypress () @@ -251,9 +252,9 @@ (declaim (inline clear-screen)) (defun clear-screen (r g b) (declare (type u8 r g b)) - (pal-ffi:gl-clear-color (coerce (/ r 255f0) 'single-float) - (coerce (/ g 255f0) 'single-float) - (coerce (/ b 255f0) 'single-float) + (pal-ffi:gl-clear-color (/ r 255f0) + (/ g 255f0) + (/ b 255f0) 1f0) (pal-ffi:gl-clear pal-ffi:+gl-color-buffer-bit+)) @@ -415,8 +416,8 @@ (pal-ffi::free-surface surface) image)) -(defun draw-image (image pos &optional angle scale) - (declare (type image image) (type vec pos) (type (or boolean single-float) angle scale)) +(defun draw-image (image pos &key angle scale (valign :left) (halign :top)) + (declare (type image image) (type vec pos) (type (or boolean single-float) angle scale) (type symbol halign valign)) (set-image image) (let ((width (image-width image)) (height (image-height image)) @@ -449,7 +450,7 @@ (pal-ffi:gl-tex-coord2f 0f0 ty2) (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height)))))) -(defun draw-quad (image a b c d) +(defun draw-quad (image a b c d &key absolutep) (declare (type image image) (type vec a b c d)) (set-image image) (let ((tx2 (pal-ffi:image-tx2 image)) @@ -486,12 +487,12 @@ (pal-ffi:gl-vertex2f vx-to (+ vy-to height))))) (declaim (inline draw-line)) -(defun draw-line (la lb r g b a &optional (width 1.0f0)) - (declare (type vec la lb) (type u8 r g b a) (type single-float width)) +(defun draw-line (la lb r g b a &key (size 1.0f0)) + (declare (type vec la lb) (type u8 r g b a) (type single-float size)) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (set-blend-color r g b a) - (pal-ffi:gl-line-width width) + (pal-ffi:gl-line-width size) (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) (with-gl pal-ffi:+gl-lines+ (pal-ffi:gl-vertex2f (vx la) (vy la)) @@ -500,14 +501,14 @@ (declaim (inline draw-arrow)) -(defun draw-arrow (la lb r g b a &optional (width 1.0f0)) - (declare (type vec la lb) (type u8 r g b a) (type single-float width)) +(defun draw-arrow (la lb r g b a &key (size 1.0f0)) + (declare (type vec la lb) (type u8 r g b a) (type single-float size)) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (set-blend-color r g b a) - (pal-ffi:gl-line-width width) + (pal-ffi:gl-line-width size) (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) - (let ((d (v* (v-direction la lb) (+ width 8f0)))) + (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)) @@ -522,7 +523,7 @@ (declaim (inline draw-point)) -(defun draw-point (pos r g b a &optional (size 1f0)) +(defun draw-point (pos r g b a &key (size 1f0)) (declare (type vec pos) (type u8 r g b a) (type single-float size)) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) @@ -533,8 +534,8 @@ (pal-ffi:gl-vertex2f (vx pos) (vy pos))) (pal-ffi:gl-pop-attrib)) -(defun draw-rectangle (pos width height r g b a &optional (filledp t)) - (declare (type vec pos) (type u11 width height) (type u8 r g b a) (type boolean filledp)) +(defun draw-rectangle (pos width height r g b a &key (filledp t) (size 1f0)) + (declare (type vec pos) (type float size) (type u11 width height) (type u8 r g b a) (type boolean filledp)) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (set-blend-color r g b a) @@ -543,6 +544,7 @@ (pal-ffi:gl-rectf (vx pos) (vy pos) (+ (vx pos) width) (+ (vy pos) height))) (t (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) + (pal-ffi:gl-line-width size) (with-gl pal-ffi:+gl-line-loop+ (pal-ffi:gl-vertex2f (vx pos) (vy pos)) (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos)) @@ -553,23 +555,30 @@ (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height))))) (pal-ffi:gl-pop-attrib)) -(defun draw-polygon (points r g b a &optional (fill t) image) - (declare (type list points) (type u8 r g b a) (type symbol fill) (type (or image boolean) image)) +(defun draw-polygon (points r g b a &key fill absolutep (size 1f0)) + (declare (type list points) (type u8 r g b a) (type (or image boolean) fill)) (cond - ((and (eq fill t) image) - (set-image image) + ((image-p fill) + (set-image fill) (with-gl pal-ffi:+gl-polygon+ (let ((dx (vx (first points))) (dy (vy (first points)))) (dolist (p points) (let* ((x (vx p)) (y (vy p)) - (tx (/ (- x dx) (pal-ffi:image-texture-width image))) - (ty (/ (- y dy) (pal-ffi:image-texture-height image)))) + (tx (/ (if absolutep + x + (- x dx)) + (pal-ffi:image-texture-width fill))) + (ty (/ (if absolutep + y + (- y dy)) + (pal-ffi:image-texture-height fill)))) (pal-ffi:gl-tex-coord2f tx ty) (pal-ffi:gl-vertex2f x y)))))) ((eq nil fill) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) + (pal-ffi:gl-line-width size) (set-blend-color r g b a) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) @@ -577,18 +586,15 @@ (dolist (p points) (pal-ffi:gl-vertex2f (vx p) (vy p)))) (pal-ffi:gl-pop-attrib)) - ((eq t fill) + (t (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) (set-blend-color r g b a) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (pal-ffi:gl-enable pal-ffi:+gl-line-smooth+) - (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) (with-gl pal-ffi:+gl-polygon+ (dolist (p points) (pal-ffi:gl-vertex2f (vx p) (vy p)))) - (pal-ffi:gl-pop-attrib)) - (t - (set-image image)))) + (pal-ffi:gl-pop-attrib)))) @@ -621,7 +627,7 @@ (defun load-music (file) (pal-ffi:load-music (data-path file))) -(defun play-music (music &optional (loops t) (volume 255)) +(defun play-music (music &key (loops t) (volume 255)) "Volume 0-255. Loops is: t = forever, nil = once, number = number of loops" (pal-ffi:volume-music (1+ (truncate volume 2))) (pal-ffi:play-music (pal-ffi:music-music music) (cond ((eq loops t) -1) --- /project/pal/cvsroot/pal/todo.txt 2007/07/03 18:42:35 1.4 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/13 13:21:04 1.5 @@ -17,8 +17,10 @@ - CL native font resource builder. -- Fix with-blend (r g b a), see that things work on Allegro CL. +- Fix with-blend (r g b a). - Make it run on OS X. - TrueType font support. + +- Simple animation system for images.

1 0

[pal-cvs] CVS pal/examples
by tneste 13 Jul '07

13 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv16987/examples Added Files: polygons.lisp save_lisp.gif Log Message: Changes in the API, especially in the various DRAW-* functions. Most examples still not updated, polygon examples added. --- /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/13 13:21:04 NONE +++ /project/pal/cvsroot/pal/examples/polygons.lisp 2007/07/13 13:21:04 1.1 (defpackage poly-tests (:use :cl :pal)) (in-package :poly-tests) (with-pal () (let ((grid (load-image "bg2.png")) (slad (load-image "save_lisp.gif")) (teddy (load-image "yellow-teddy.png"))) (event-loop () ;; DRAW-RECTANGLE just draws a filled or wireframe rectangle on screen (draw-rectangle (v 0 0) 800 600 0 0 0 32 :filledp t) ;; DRAW-POLYGON draw a polygon which vertexes are given as a list of VECs. ;; FILL is either nil, true or image that is used as a pattern. If fill is an image the rgba values are not used. ;; When ABSOLUTEP is T image patterns position is decided by screen coordinates. (with-transformation (:pos (v 100 100)) (draw-polygon (list (v -100 0) (v 100 0) (v 50 100) (v -50 100) ) 255 0 0 255 :fill grid :absolutep t) (draw-polygon (list (v -100 0) (v 100 0) (v 50 100) (v -50 100) ) 255 0 0 255 :fill nil :size 5f0 :absolutep nil)) ;; Note: next one doesn't work like you might expect since the image size is rounded up ;; to the nearest power of two and the extra is filled with blank. (with-blend (:color '(255 255 255 20)) (draw-polygon (list (v+ (get-mouse-pos) (v -100 -100)) (v+ (get-mouse-pos) (v 100 -100)) (v+ (get-mouse-pos) (v 100 100)) (v+ (get-mouse-pos) (v -100 100))) 0 0 0 0 :absolutep t :fill slad)) ;; DRAW-IMAGE-FROM draws a part of image, defined by a starting point, width and height. ;; If width or height are larger than the source image the image is tiled (draw-image-from teddy (v 0 (get-mouse-y)) (v (get-mouse-x) 0) (truncate (image-width teddy) 2) (get-screen-height)) (draw-image-from teddy (v (truncate (image-width teddy) 2) (get-mouse-y) ) (v (- (get-screen-width) (get-mouse-x)) 0) (truncate (image-width teddy) 2) (get-screen-height)) ;; (draw-quad ...) to be done )))--- /project/pal/cvsroot/pal/examples/save_lisp.gif 2007/07/13 13:21:04 NONE +++ /project/pal/cvsroot/pal/examples/save_lisp.gif 2007/07/13 13:21:04 1.1 GIF89a#"ÄðððÀÀÀ@@@000 ```ÐÐÐ ààà°°°PPPpppÿÿÿ!ù,#"ÿ $dihª®lëŸp,Ïtmßx®ï|ïÿÀ pH,È€rÉl:ÐštJZ¯Ø¬vËíz¿à°xL.ÏèŽzÍn»ßðž|N¯ÛïøŒ~Ïïûÿ ¡¢£€¥Š§š©ª«¬®¯°±²³Žµ¶·ž¹º»ŒœŸ¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ H° Á*\È°¡Ã#JH±¢Å3jÜÈ±£Ç CI²€É(Sÿª\É²¥Ë0cÊI³ŠÍ8sêÜÉFO xz° À£H` 4ãH£F5 )Å€jJU nû@Õ¯Ã]ûàZ Ä²%K ÀÛFË.õéÀÀ\€Þ÷Á»%ü= @ÀàŒ¢@àwñÇ äý[@2f=àùóÁ¢8À±é6§æúZ`Ê³XP[Õé @`3¹Rwî}*@hÝ¥ï0Èª4sU£6Æ#wÔËI Xày¿n)»Ö³sP iŒkUÎèYž·s(¶U`&0 ßÿZ Ø×š= j1žÞX äö>DapÁrdmÈFû]Ásk6ÀÄE JPÇ€ÀdbR.Â8U(0EôxÔT8[}i°k$8¢L2X%bGíXZ]Vl©Ø%¶u~Pâ§TO-æ_ejWçJôy5H|7tGVdCU×ómÅšwZJhj¡ª]:Ck1%`@f¡åVaPF!6dzTgµ®¥Šýøš[!:ÆúV\¶¬TÂÆÐé$Øúš®u¡ÿl`ìVJÕ ÒFu@²+t+i Ïµ'Ø2È![7nË[ûÂ²B»fu_Tà+Õ ò./,œ/°u²F Hµ:Âª[Ñ0`æ EpÅe€>LàVÀ#Ð»VŒ#€|ša3]©àð~2Tª& ±TÛqPNµ€¹c oÏA°9W³÷EzeÄJÅsÁ-íDÔ[Õ§sI³e6ÖExÜ C×Ã\ÔÛN(°Îl*÷Q'Ã]DØUlšCº.Ð²YÜæáÓgøüþuiê Ðžÿ0PÇ$ÀzhÏõm óæG N¢®@ìU_MB1£[d~û}sM;%§-èÂÏ56 ïTÔÍ Æ¶üÿ®Ekî'Æ,Tì8qïà€`ŸØß/ÀèÇ9¡Ö_»0?RéÆ£¿,©siÃ^ý|Ÿ#oÿCÊêVÐºš$@ÊËÿRd¡ñmCSjö3²0Zk1Nµ =î èôŽÀ}%,Õ²u¡jåu1dÂîžiÅj-0ÝXŠG$`FH¥2;ðîhA|Bã&xæIY-äBŠšÿ FålábP7Ú.c.hÓî77è#0#×Ø·±ÅZA F êWJœXH>Þ (xãöXHÚ°`ÚÃ©æÂÅ¡EÑ2°RÞFLQ*^õEî djðAêencÁÐVX+1kA"°ËŠt}Ë'¹7«rbPßVÐžõò Ì eTÀÑ²åùE1ÔklälÒ(²aâ ÚšËl±-âÔ9? `BR "lçWžoÞk.U4 ß³¶û+·R8(1*î»òcHÿ²,Ÿû(ÛTÎÇIá¢Há4SjUø'KPIfÕ`¡xbÁ>°ÌÔô(.ÈNFðÆoJ²I8Ñù`ÊË Àøc;åÇd`¥{S*Y k.ÁkîëÞÚvf52uI°ê.øR*%X¹¡FÍ§VU!,3K@ZcBŠÑt3žŒY v:ÖúK.ò,Bå+¹®©±,ìÎh0×ÀphÂ4cãX)B6 dÐªçµ ^3ÚµD¹$Y)KP[:JPÈñXæ§ŠêA©Çf²à£VrSÙ'dn\ÿ8ôP·~ÅÔe.pœB`cYæOçRÝ³medCË»î~Œ¹ê Ö]ªïQMxš>xF¶S }y`_Ì|Ž,ëœ^vÙ·±ÓÍÖy`V*"F,@Šú="Å«_ÙgF[,l%db«VöjÃ:Øèà§?úys2Ù#ÖzÁ¬:ëÝ]8à×&4m`@_öãXõÔ`Ì¡ ÆH¹- Kéw@·lùHtiÀ )Ø8M!ÖRžæÍ6l.BÀOÌ÷æ.ÒtHpÿâÜ«Øz >Ý[$âlN,í]~ÚÅ;jÞfE33Ï ÓFË|°X3Š©Mšg`¹aÕ³1Àlj*[ò+øÈd`aØQiò£ð, ÊSöÞ¬B'g0ŒúP\QfÝ(ÐØãÎnPYL!0Tkt>v \Õð{1d¥ßÀªÜ°Ì@Ù`š-ŠÍÍá·vÓÇÞ+ÈõQÔËÊEÖf·"ÛÛi B€ 4nn%11M@yÄoË³ä[ xPN&¿k1® AÛ>àÓ4VAÄÿÙËm:8*7ã^A¹?ôåÁŽ¬IË*åÝ~Ð}<õ]3É@H]ú® ¶é©¶ÜgTíT=B öTËîêÁš¿ÌäÌz£ïÜ×·CaÞ`öÝïHé¿ÛÊ4=á^LÔG°uCo+N(NÆ2§ù&5_AçàóÞÄ ðWõP&Sá§Àô«Qî;ÎÞ>6*OÞÔ##>Žj T³@^1@úâW!ý¿ŽJù£q§ÒúdjóÀL Ø=¡v øJ.RYÕ}p,õ.<K[Qû€Z,×ùí#üËDúG)wÿ¿ žw+=@÷eëté¡SvÔqp bÕiÄj$¶}d[í'Öbñ"Á{° @xÇl¶7±R·5Iö±`.`fUf§m7QS'À#c"ðt"X·BÞ¶)Ð¢18 [Ákâ0Ý²:/k¿0·=ž<öSxD1H0MCèn(Ð-y#gRf¬H81Ðàv71t¢Ñ¿ÇweYñåæsÁ%Í~á¹Ñ:Åjé±øµ×zÁ§®<'e^§HÏ d4@p<v:cÞ Sÿs¡Z'0u[Á¶À^U^x&öÞ}}S4(Ï°SGR1ÒdøÅáðð'Û€mI¡ud2RÍ°dÔQjó#ÚhE&b'ÇHs{Zåx<ò°¡ÇÁç!oæýæ6'ã5¥NÛTfä*Ì$[13|ö«EØS}<šFüSjE$PQ§C(À [°U1é~éåÏTH9dá0DÈw$çqç£/,Wá@NØ=(6ä`4CVhŽæhSŠDeþ§ > Øšã8Òæÿã7sDŸc¡ ÚS&ilEoY&whé$6!6Y (¥¿3:óÈUæónÇ6`I|y {ÆhŽxh ÉjÚajrVSÆÃp}I Æ°S E·EQ°2ãÚÖÇgÕöD²5 @©À$?'ZuâÚQ8æ ì%^|ž&iùM¹7@sÉ(V7<Ã1Á¹ uÃ(0]o«×r"aj4yS)uÉŽyDÆENÑi2ùp9ÃTv '|ókÏX.º"Ykfq\TU>QAÛká÷ÿy^Ê3æiõš2¢à·K÷{Z"é|#Ð)08ä!(¶Aø.S©ó ž¢sA0uH4& %0)¡³BÐI"9 âfÈRá"ØÈÜ0W7€ï)"ùA°Ö,)JQúYð98d«XhÚbl±$^ø€' %PZ.6!@êGñ@pÛ)?Õ¢vŽ¥· jd.©øyb+`[º !j7-`Œå:pF,ÈÄiû/®2sº ë¥·$ÐµãI¿S1ûPRÕÙº bÕ¢B]Ã'c:oQØÿõ¥@÷©¡Ù?3ö^èXšmÿB(M®y³F· ÿYozÑñQ=õ,UA|8Zpsrc (%yxºfØEå¥|SêÃ¥9à4§ ¥dð£Ëóálëbx€PcµŸ >M«I!¥/ç(®íàc¬¿6X ïxŠÙè¢Àr%ê!J¡Ô@J¡rÑîY©![H@.ùV ²vsÅT38³§Fªè B²% .ÆÁ°*LBC¯¢Z@peëž°åÅ¹uW M'»~mJ¡1Ö©²±ÇºÿãÑZ¬Ç¯DROÍ*G€-tåI«YR £WîúÖqÞ9Ç£íð¥rÙw¶jøÊ¢u£s!Ô_ñ:¶ÒhŠÒð,Û!Z£³4xøH9 A,µ}IØ óÅyE$òp.Â€žéÐ9o`\ôSÑ%8ûw{»°Ø¹ÀE£PÓ ú°ÁÔ·ÂsB)t!JgQ~ÚVfêJ;.¹°Â[i¥ºÄ,vÍ»RnfÛ[ouûœß±téKÓéy$ 3Èáœ5¿ä` JÑÿBrî;]ö;3$A5«Á;µ7£%?nô»00Ó[\ºA#ÁñP¿Ðv *EFó¹Üp³?4(+Ûª"Â# UÁõC ,¢©²SËA·SaH&uJHüûÏÑÊ{3yR¡ yd8 V¬ Âž÷fá1jYEÆËZKÀ'1ÃÄ'ãÆ³Cp{"ÆœµÉ³ ?·çf¥ŠvšócGZÇ;pÜ@5×-°Yðã&ÈèP71cÌ2!J|&sQ13H<l;eÃÛ;ÀVµÿÏ@Ã-Rç_ª|ÿ£'CÈ4àD `ü¥k~Ê»Bj\¯XÆ%ÏŽ¥vFÃ,«`üÊ®L<#Ì64¥¶üG4U®tÕ ^§aoC(Þ¡°ÛI®ÀËÐ0Ÿ¶ª~,aÞÌ)#mž¬ÍÙÓ9)þr ÔT1dªk¢ÎäH¶×°ì5&xírÉñ@Ž* V÷Õ<^Iû{GB.Ý²Ìœµ-ðS"0¬,¬Zm@|OÐÜµ;X÷r£ú<ªKû¥€ÁbAuÀ,HÝ#mbŸù`²GÝÃŒÿ£z¹ñµÿëÔå.òT-ÑFšm0ãÌár5qÖÑa€Æ\MÕGXÑTc-lStCÑÒ[[MZ×1]e×ø Šû"aT»a¹\EW<#g `bØ3àÝZÈØQA)UVðw0UmšYfÁ1p6ù®UóÉÚ¥PDEÊÙ6Xf -óqÆF@,J±LDa8NµÜÏÀÝ#zeF±!áÖ=SA¹(EeSÊw¥¡÷¶<^²Á9ÄÜ º!,r£xJÐŠ+"IÞqÁÿ.4*Ò®Ék}$Àg¥ÑË*0CúWZkÛR-¶Œ`É`ðÛ)ÝUÑ.1íÛGÒ2®a$IüC\U®,bÙ1œÛH!¬dP$Søa`gÑ!Â2"u`3¯3Àý ¶Ùâe1Ü)}á+ æ#ëb$ub0¿w"Õå¿beýGbáéCq|äº;X±T,5Ñ9ý90$%Å+ua%ä28s¬ÔÑ*ÄKV Í<hÔå%dQÓH Khº Ã·$EYm{/Ð)@d4NâßãÕ2âêT1ÿ7ägDh%H®ß/">_¢Ç+Wey+ããêóØ(f,·?êì·>Ha:§ê4AÑxÇ^é:;XEÏî^ÓØ"í0`D=®¿Qúb.{¢Dß>Õ" ¢ä^îL°ÞI¬> }@;AÄžqí±ì:`:ïú#§Óvg03×1Le[ð'æá_¬Û>ãðà~Å"ª~ýðm8b8l¡Žñ1kI_3_žr(ô^%(D©òHP-ÓÚ+Y9O3_0lAÏâ 9Oéö)ÿšóó@8€ÓË©±»*8Gï13YlEQáO¯ð9À1,¢UZ¯ÄëÙL]ïñŽÂÐoeä2$Pö;oØ~ô)¿öž%=#\Rs1÷OGbý{Oò Œä·òm1?kŽ$]1¯;V6+õM[§ø®¿"*ùÀõ5ÐYùA@5Ú-Œ®Vù;Æú|ZA0ŒãúdöÑ7:GoïŽ¿&€vy÷(ÙößñÿøSá_HAüoü0°ã)íNÑËÏ(B" Rçå×Vo@ñXÄ8,D ¶äýHÏESTÿ(4 yä#ûÂo`g;ÔOóœÿÂ!±h<"Ê%šX ¹Â!±kb±Ü:øÇ[3®EÕCo9Â@žŸ¯%šž1ýÙàd-2Æ(0} š5VZ^b2&å€eÊuºÐ,måÈÕ8Ô$ Ž žæ€ŽpíBP2À.)8š8Ø2W[_+!Hêb_ s×ì8Ôøö0p!ìr§søÍÕ/ÁB4 z[+ÈÅŸ.C4®FJ ¶p¢ Ðö Ýrvø@Æé$ÿSQÃÍ°% ð¬Æú\yIáD9u ºDàDš E`@ž¢¥êäœD)ÙQ2ŸU*MÔüµB4yPQ®E ]+w.¢NMH¥K$@~ãØ±³°=}PsðzuÂ~ÅØÂnÅ?8]Ž\¢i¯ëN8Ô$ã»GE£NÊóîÓ© àË9#'ñ@@ÏÇb.%By³â1Mçdâ-xDAžr¹ÒœÞ[õåìÞ±dMæç÷ 8°çÎ¡Âõ/Vç`Á¹u Ì¶ã`ón·:Qõ@^÷dAßoáÿXyCl'BhÉâuâ^¹ÐÝpŽæ>Ò5U5]ÅhÒÑ`[aQZÚ<ÀG¡7òØD:!_Ø~ý ÇÃMn(pd|<p0V?-Py¢ðÂ9H#ÃÄáZÉEkÂimrÑÀK¥89YkqåžáÛÃm@9. r/4Ù/ùnÆ`âýš§vµ©§£ÂÀ%)yÑ],n'4ðÈÇÃ¢bÁØøVŸj}É6ô C"°Ñilaq§æÐÿ'©×úEmTÞQ§£4û··š¥5¬DBåsv@ü°ÀI&§º !°@f°@²Þzê×2¶9Ø[@@ŠÉOS4økg0ô×Éžò À6öà ¡ @íÃ7Ìð¬]€õðÅÈÌMÁœeŸ1Pò)L3.Æ6ÀÁÂáI¶ bfäNÂâøDÑÎU4Å97Þ©Ùý±ð00S ð¹ÍœAÐÛÍP¥Ö@·Px¹ÀÑ@ Ütñ\ÃÁló8ö©Ö®õ¿. `ÿ·Sm5 ]n ²69éº\nÓ©:æþxªíBqžûwsÞÃ;pùX/€h ÆŽßv£<ÜàûíåÊ³õ@Ñ »Î€éìn.'Ú¡¶'+ÁÀé§Àµ| ,`»¢{6]Ž·¹ýõÓSOÓ{:üR°+l&E:êÓ*à@` 4Þ^83Zð °ŸVNœ@òßÿR³3}cóÉpŽm&úûuH'Ð¢$_ÆW'ï}¯P£ Â×ü¬rD,¡wÈ2 «+ÜPvøhšø\B2À ü±ÿ"#f'a"&vªs¡&ü¬Èìr!jÜH§'éBN£VùYÒlä©£È%Zöy€8ÄEJ*Ôâ#&õ<ñ±1` Ey-?zËÒ$&©Ê1íãá]B)KÕhË+o9ªáÑéŸ ëîrÉazælÈŒVáèÄÉe^:#4«3Œo!¶ŽæC°©£Iq3·Ëk)Î( Ü æ9Û¹&Ícî4Hù<Î3kRÕè©O 3[â?€¡í&ÈJÁ*.4¢HÃ:u)Ñk$uŒ(Gÿá ¢Ñ€ í(IKjÒ¢4¥*])K[êÒÂ4Š2)MkjÓâº±<sêÓz1*Qº SÒšJ]*PräHŠB5ªE¥jÕ«¡AIÅ*W»º8 4þô*YË:dk«f]+[Tœ¶Â5®¶J\ë*×BÔ®ze*Ozº×¿þÔ],aê>Â6±FEk'ªX&ñ±I š)x#Y&FêÕ e¹1ÖÍzªdøÉ+hÑYqà¬Ž9c[>ñLÕB -l# 3X¶8mQð©ÛQ-`ý-xëaT1ü!mk\ÖŒ6¹7b%¬|+ÿ]?Èö'¢ëuÆîÆÙ=~fYð^K}è}xÕÁøuœ¯|98rõ'µõíÑ'÷«¢°o^{I@G4×¿ÕÈÝoêKK\.[¬xÞ×1)X(ðäz,®±ú&C¬mÂ¿ª*öÁîÿbÆ<U¬ÄÒg§s×öfp/á6LøKëiäõ¯)N&»D÷n4ç~ír@&Öì$n)VürÒÊe©S¥[Ž÷¬ãEîuwd4EãíBK]áøÙåzsàd"øðQþÝê\[FÍÁSYQ\Xhÿx9ÆLµeôÚ>TŽì9Ç nÆé²XAZWŸŠE;Á*5dùžûÕà²ßOqaÐº¥ÝZ œŽŽ.€ ¥Ä®Anú¢-*«vØCÐ1CrÞZµÅT+_ÔYÙÔoõýÒyPÌekÔDpK/×{çÑ4iÞ¯BÀ`Vù«\Èöfá9Ã1;%ÒãI"Ýzv5!Ey6_7ÐåÁ']¶bÆÑdUDm ób÷'ý¶ {öDª}u/QðLÊÑë-û·Úç¿Æg¿ÔÞ€ÆKælØÿ_rÕ7>AßV0Lª3€¿i1ÞŠ°Ë£ÑpoO7Ãî€É©??Ú{ÐC'¶xQÊFo¯1®]çBªùa`]Ð@ãÄ4Ÿ×Àsa8s6®ßºîb>'Ì³Ç?lbÐmÔM°®ï=p9Äœêá)D«[&ã\YÌÝ+ÖIŸÈï]ì£¶®§£LÁGRžîí¶ ÔZÛ¢ÜÏ ÷R<ëúnqü·ð€`&kb¥¯3Ô·»aìã±k&líC`gÉHAã_úºÆu<ôúÇs¿v0èáRA¯`ðœÿàÀR^ô+ý×+Xpí àBÌT kœÕÜl>ü¥ÚüY^xUÐ iå@ôV ^â`ÂS!L{QÏòA¡ÉÀum |ÕC\ É-Ä¥Uç5°GZÐ÷AìšýÈf6 ŽÅD@¡QåFüÁ @ºÚí¡µµ@zE Â@ÜpàÞíAjE~\Î:Á@îÊ@Ÿ^W9ØÂÏHÇ [eêÅ"6B3¿ùîCº J),N %¡&ÿ'r'á(ÓKœ¡ (žlÐÐ.Q#ºC©)²"á(" 6Á µT áRHþÀø``uÂc£,ÝÑ/]íâªP9aÇú]£¥dãÅÆL'²(ÆRÔbÓ]1È+îÛ:fz£ $ßÌ¬Ô=HãqéÏð<?ú?&5Ê£ìÞ@ 5QáB.YxÁaúáÝæIä-d(¢8@* mu8€Vd)D#Ib)_INEò¡Q¿<SÉŒÜ#Gz, qÄ9ø$lå3¥ÿ$fäÿøY÷¢Efc:ºJ,¬ÊMåTe\€S¬€5ñäkÑcG`AäuYï`VfXH HòŒÑ@Aö^6åë4]Vx$`:àYº]MÔBXúÙ!^K-æ÷dS0ú#d>Ç_E!Õ-y8å8bb&¥9æè`t=ßTá3ÎäíäŠ eà]O&ig$]nf!RÄk`)%ÎIŠL6lVr&§ávÂä(ÀUú,&KúÝ_@T×Yãç÷ÕægBmMgÏØf+§NÔPnAA§x¥%`ÿgå{²g|@ö]Þä¬§Nt§ ÁEZ-&0]0ç:^s=©ñÀ zÇ°Ê31e"@TT%gDâ7ôŠøyá÷šèDèk$]ÕlpâÝ9y§äa:%Â(,B|£AÔäBøàKÊÅd_ÛØ=ÓtbæŠ$A$©œqM_ÉÙc^M$ NúÈ%&P€xÔ,ÌAvµ]&©)€Î[A6ö§,ÞlÖå%Ì©xð6ÙB:5~*x mFµvÖ¢Já%<'°µLÓ-Q×eÿè5V¥&\-$yä®ÍxN`ÍšÂqéüAk2CÂhçTÊÑÌX`Âáê-g]0ësÑ)šàò )^éC9ê2JØ%éË|QôæÄ¥Ò€_HÏ£ã^eÕü ¥è%4.êžÂvATR6h@ Íþk+CP#*i/MÍ@ÁË,«-Þ'_k8A6Õ(B¡²Jx*"Âœ^ÂAljVÐu14lOœú1ŸªëÄ @rR×YO\Ö ZÑìnÉKM¬Bºî£=IQí@Î6»ZÿEÔdºÉÊV êbTÚÞ©ãxÉ)]BW«&ÏÈ_ôXK@ôDxUÉ0ÐdÜfÂ'QÐ]-&Nª*mØt«ÒWÂ±Ófäa¯ÄZÅ26YÅÁÑó§ø«€9¶¶€¹ªEè5pê ŒVFÁ£ÊHCX€Ÿ(Â©O/â)D©]Âðîç.A×]nÄ¢Ô5Ñvê!5ÁÂ6Å¥-€:*äòî5äaÇ² -NÝ"Zìù æD%é÷&·a(ïô.C&düÌÂŽGHªÑtïéXYîYuæñäö<Ìÿ/úïÓÌÁ*}vMXË¢ŠãÿÞÐ)ÔèìÒ/lú@<Øñ^/ô0 $Æœ`+¥;âAÎöEeÃééàéJÓÂydp5àªxsdÑÏð óÞ?|ïk®lXgøG|¬(@ÁÆð ^&šžÂðé°'0°ÞØÀO LËyAäàf.$ñ2.p&0E¥yøFhŽ/ã<a790ŒOw¶æáÞÍZE)pî{Ãtö5ÆOÀ~!ÂðÝèùþÃ A ÁéÕ<È £±¯ B~°Q$ÎKà¯BàCô°©õº@"ÿAÛBA`«%ËEvA/8ÔÇžËØpk:EýbñùÉ~¥+÷÷òºÖÝ)mÒ§ÖhÁ|0_O·.MÔÇŽñÊP0r4^±€€S³hš/ªZÑß¥¶Vqé²]P9ß-Ñ³QÈ"ÿ&eîr8¿A]¶²=ék#/b-_t6óÿ4ÙDð¯AÏs#Ë÷äÜš©2°/3*Áé!±EëF#A!a»²µm5rÌóD£ôÐï² C$ÉíFÃÐLT/O@?r"a«æô,ÃÚÿ°Eè30Vk3Óq<ÛŽºr£X=5TsÃ !óô§òLŽ6Â7û#/õ»ÆaÝHÁ;õAüŠhÒPöJ rÓ³ø<C4`^]ëQPïk;×ß|àÒbRŽHv66a¡ÿÐÇOp2€P¬tã'ôquþpDsueëñe_Ï®â;¡0y€tž$Iüuñ¹u+ÖÚªvŒŽ·æJvŽÇvjÐGoCSæHCÆ!ÇÀtb5jÛîpjF+·äò@g{ô/Â÷)ei×È¡E'ŒnvRäµ%D1z(=ªõZDÖŸVŽz³M?ÿEùÐËš^Ø ù ßé·5±¡áæõ)Ï²s>ÍhdºØÅ|'8&ñwkàÚ uúgeÕ¶5¬ecÌÃgxÃ'm¶I§Ðõ2Ð w§x5Yf}ÁzbÉFÈ'ÝÞx5M±ssÇ!Ö¬fŽgHx{Tõµä7@=¹ß4CžEÏìÿÃPÞxù-É2hæhÃh:ÀGG¥®y'Ù¬bÊDý¬¶2Ã_óö×FOñÐ7Î.Pódú,$äâí`?!ëæ£?ÕÊ±ÕZÊr§ŠðÿÌ€kx76'©R@`z)xz'ý¹S8:«ó©ºy³Q,:EÛº*ñ£GOz³QÃâ¯¿ÒKTN R_ÈO#»m°÷. @ÑÔzŽÇÉ¬SËRû³¶ûÒŽ§¹/ñºPû2]:³5,Ž§;%9ÛAÓ&d{Œ3ÏµŸK$äÞó»jÅäÛŒOâÐªüT;7yÂ®Ã×æRð±Ä¿'?µÅ¿'?F¹Æ×:â®Ç;f!À»È#b.ŽÉ+XÜšü{ŠIË¿''€<ÌÏÚFÓüYZëÍ;f4ŒÎûüÏ}ÐýÐ}ÑýÑ#}Ò+ýÒ3}Ó;ýÓCv}ÔKýÔS}Õ[ýÕc}ÖkýÖs}×{ý×}ØýØ}ÙýÙ£}Ú«ýÚ³}Û»ýÛÃ}ÜËýÜÓ}ÝÛýÝã}ÞëýÞó}ßûýß~àþà~áþá#~â+þâ3~ã;þãC~äKþäS~å[þåc~ækþæs~I;

1 0

[pal-cvs] CVS pal
by tneste 09 Jul '07

09 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv5293 Modified Files: ffi.lisp package.lisp pal-macros.lisp pal.lisp vector.lisp Log Message: Fixed problems loading the .so's under Linux. TAG thunks must now only return objects of type PAL:RESOURCE. --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/03 18:10:33 1.3 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/09 18:17:44 1.4 @@ -5,23 +5,23 @@ (cffi:define-foreign-library sdl - (:windows "SDL") - (:linux "libSDL-1.2.so.0")) + (:windows "SDL") + (:unix (:or "libSDL-1.2.so.0" "libSDL-1.2.so"))) (cffi:define-foreign-library sdl-mixer - (:windows "SDL_mixer") - (:linux "libSDL_mixer-1.2.so.0")) + (:windows "SDL_mixer") + (:unix (:or "libSDL_mixer-1.2.so.0" "libSDL_mixer-1.2.so"))) (cffi:define-foreign-library sdl-image - (:windows "SDL_image") - (:linux "libSDL_image-1.2.so.0")) + (:windows "SDL_image") + (:unix (:or "libSDL_image-1.2.so.0" "libSDL_image-1.2.so"))) (cffi:define-foreign-library opengl - (:windows "opengl32.dll") - (:linux "libGL.so")) + (:windows "opengl32.dll") + (:unix (:or "libGL.so"))) #+win32 (cffi:define-foreign-library shell32 - (:windows "shell32.dll")) + (:windows "shell32.dll")) (defun load-foreign-libraries () (cffi:use-foreign-library sdl) @@ -72,19 +72,19 @@ (cffi:defcstruct rectangle - (x :short) + (x :short) (y :short) (w :uint16) (h :uint16)) (cffi:defcstruct color - (r :uint8) + (r :uint8) (g :uint8) (b :uint8) (unused :uint8)) (cffi:defcstruct surface - (flags :uint) + (flags :uint) (pixelformat :pointer) (w :int) (h :int) @@ -100,7 +100,7 @@ (refcount :int)) (cffi:defcstruct pixelformat - (palette :pointer) + (palette :pointer) (BitsPerPixel :uint8) (BytesPerPixel :uint8) (Rloss :uint8) @@ -119,40 +119,40 @@ (alpha :uint8)) (cffi:defcstruct keysym - (scancode :uint8) + (scancode :uint8) (sym :int) (mod :int) (unicode :uint16)) (cffi:defcstruct keyboard-event - (type :uint8) + (type :uint8) (state :uint8) (keysym keysym)) (cffi:defcstruct mouse-button-event - (type :uint8) + (type :uint8) (which :uint8) (button :uint8) (state :uint8) (x :uint16) (y :uint16)) (cffi:defcstruct mouse-motion-event - (type :uint8) + (type :uint8) (which :uint8) (state :uint8) (x :uint16) (y :uint16) (xrel :int16) (yrel :int16)) (cffi:defcstruct quit-event - (type :uint8)) + (type :uint8)) (cffi:defcstruct active-event - (type :uint8) + (type :uint8) (gain :uint8) (state :uint8)) (cffi:defcstruct resize-event - (type :uint8) + (type :uint8) (w :int) (h :int)) @@ -169,7 +169,7 @@ (defconstant +expose-event+ 17) (cffi:defcenum sdl-key - (:key-unknown 0) + (:key-unknown 0) (:key-first 0) (:key-backspace 8) (:key-tab 9) @@ -405,7 +405,7 @@ :key-last) (cffi:defcenum sdl-mod - (:mod-none #x0000) + (:mod-none #x0000) (:mod-lshift #x0001) (:mod-rshift #x0002) (:mod-lctrl #x0040) @@ -446,11 +446,21 @@ (defstruct sample chunk) + +(deftype resource () '(or music sample image font)) + +(defun resource-p (object) + (typep object 'resource)) + + + (defgeneric register-resource (resource)) (defgeneric free-resource (resource)) (defgeneric free-all-resources ()) + (defmethod register-resource (resource) + (assert (resource-p resource)) (push resource *resources*) resource) @@ -472,8 +482,7 @@ (defmethod free-all-resources () (dolist (r *resources*) (free-resource r)) - (when *resources* - (error "Allocated resources left: ~a" *resources*))) + (assert (null *resources*))) --- /project/pal/cvsroot/pal/package.lisp 2007/07/03 18:10:33 1.2 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/09 18:17:44 1.3 @@ -15,6 +15,8 @@ #:load-foreign-libraries #:sample #:music + #:resource + #:resource-p #:sample-p #:music-p #:gl-get-error @@ -345,7 +347,7 @@ (:use :common-lisp) (:import-from :pal-ffi #:free-resource #:register-resource #:load-foreign-libraries - #:image-p #:image #:font #:font-p #:sample #:music #:sample-p #:music-p + #:image-p #:image #:font #:font-p #:sample #:music #:sample-p #:music-p #:resource #:resource-p #:image-width #:image-height #:u8 #:u11 #:u16) (:export #:open-pal @@ -431,7 +433,7 @@ #:halt-music #:v #:vec #:copy-vec #:angle-v #:v-angle #:vx #:vy - #:v= #:v-round #:v-random + #:v= #:v-round #:v-floor #:v-random #:v+ #:v+! #:v- #:v-! #:v* #:v*! #:v/ #:v/! #:v-max #:v-min #:v-rotate #:v-dot #:v-magnitude #:v-normalize #:v-distance #:v-truncate #:v-direction --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/03 18:42:35 1.4 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/09 18:17:44 1.5 @@ -22,11 +22,14 @@ (define-tags default-font (load-font "default-font"))) (defun tag (name) + (declare (type symbol name)) (let ((resource (gethash name *tags*))) (if resource (if (cdr resource) - (cdr resource) - (setf (cdr resource) (funcall (car resource)))) + (the resource (cdr resource)) + (let ((r (funcall (car resource)))) + (assert (resource-p r)) + (the resource (setf (cdr resource) r)))) (error "Named resource ~a not found" name)))) (defmacro with-resource ((resource init-form) &body body) @@ -151,7 +154,7 @@ ((= 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)))) + (keysym (read-from-string (format nil ":key-mouse-~a" button)))) (setf (gethash keysym *pressed-keys*) t) (funcall? ,key-down-fn keysym))) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/04 18:41:12 1.7 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/09 18:17:44 1.8 @@ -1,3 +1,10 @@ +;; are the texture options sane for draw-poly etc. +;; tags-resources-free? +;; animations +;; circle/box/point overlap functions +;; resources should check for void when freeing +;; sdl window not on top? + (declaim (optimize (speed 3) (safety 3))) @@ -136,7 +143,7 @@ (if #-:clisp (probe-file path) #+:clisp (ext:probe-directory path) (pushnew path *data-paths*) - (warn "Illegal data path: ~a" path))) + (format *debug-io* "Illegal data path: ~a" path))) (defun data-path (file) (let ((result nil)) --- /project/pal/cvsroot/pal/vector.lisp 2007/07/03 18:10:33 1.2 +++ /project/pal/cvsroot/pal/vector.lisp 2007/07/09 18:17:44 1.3 @@ -53,6 +53,12 @@ (declare (type vec v)) (v (round (vx v)) (round (vy v)))) +(declaim (inline v-floor)) +(defun v-floor (v) + (declare (type vec v)) + (v (floor (vx v)) (floor (vy v)))) + + (declaim (inline v=)) (defun v= (a b) (and (= (vx a) (vx b))

1 0

[pal-cvs] CVS pal
by tneste 04 Jul '07

04 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv24185 Modified Files: pal.lisp Log Message: Fixed a CLisp specific(? )bug in CLEAR-SCREEN --- /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:50:48 1.6 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/04 18:41:12 1.7 @@ -244,7 +244,10 @@ (declaim (inline clear-screen)) (defun clear-screen (r g b) (declare (type u8 r g b)) - (pal-ffi:gl-clear-color (/ r 255f0) (/ g 255f0) (/ b 255f0) 255f0) + (pal-ffi:gl-clear-color (coerce (/ r 255f0) 'single-float) + (coerce (/ g 255f0) 'single-float) + (coerce (/ b 255f0) 'single-float) + 1f0) (pal-ffi:gl-clear pal-ffi:+gl-color-buffer-bit+)) (defun set-mouse-pos (x y)

1 0

[pal-cvs] CVS pal
by tneste 03 Jul '07

03 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv2922 Modified Files: changes.txt Log Message: --- /project/pal/cvsroot/pal/changes.txt 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/changes.txt 2007/07/03 19:17:57 1.2 @@ -1,4 +1,14 @@ -Release 3 +Release 3, July 3 2007 + +- Changed some of the parameters to sound functions. Volume is now defined as a + value between 0 - 255 instead of 0 - 128. + +- Removed the MOUSE-BUTTON-DOWN/UP-FNs from event handling functions. Use + KEY-*-FNs instead. + +- Loading bitmaps should be a lot faster now. + +- Fixed the Lispworks bugs. - Renamed GL-PAL system to PAL.

1 0

[pal-cvs] CVS pal
by tneste 03 Jul '07

03 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv29106 Modified Files: pal.lisp Log Message: Fixed a major two byte memory leak --- /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:42:35 1.5 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:50:48 1.6 @@ -396,6 +396,7 @@ :width (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:w) :height (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:h)))) (setf *current-image* image) + (cffi:foreign-free id) (pal-ffi:register-resource image)))) (defun load-image (file &optional (smooth-p nil))

1 0

[pal-cvs] CVS pal
by tneste 03 Jul '07

03 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv27783 Modified Files: pal-macros.lisp pal.lisp todo.txt Log Message: Removed MOUSE-BUTTON-DOWN/UP-FN from event handling functions. Use KEY-*-FN instead --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/03 18:10:33 1.3 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/03 18:42:35 1.4 @@ -112,7 +112,7 @@ `(when ,fn (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) +(defmacro do-event (event key-up-fn key-down-fn mouse-motion-fn quit-fn) `(loop while (pal-ffi:poll-event ,event) do (let ((type (cffi:mem-ref ,event :uint8))) @@ -143,16 +143,18 @@ (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)) + (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) - (funcall? ,mouse-button-up-fn button))) + (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) )) - (setf (gethash (read-from-string (format nil ":key-mouse-~a" button)) + (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) - (funcall? ,mouse-button-down-fn button))) + (funcall? ,key-down-fn keysym))) ((= type pal-ffi:+quit-event+) (if ,quit-fn @@ -161,12 +163,12 @@ ))))) -(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) +(defmacro event-loop ((&key key-up-fn key-down-fn mouse-motion-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) + (do-event ,event ,key-up-fn ,key-down-fn ,mouse-motion-fn ,quit-fn) ,@redraw (update-screen)))))) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:27:22 1.4 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:42:35 1.5 @@ -177,10 +177,10 @@ (defun get-mouse-y () *mouse-y*) -(defun dispatch-event (&key key-up-fn key-down-fn mouse-motion-fn mouse-button-up-fn mouse-button-down-fn quit-fn) +(defun dispatch-event (&key key-up-fn key-down-fn mouse-motion-fn quit-fn) (block event-loop (cffi:with-foreign-object (event :char 100) - (do-event event key-up-fn key-down-fn mouse-motion-fn mouse-button-up-fn mouse-button-down-fn quit-fn)))) + (do-event event key-up-fn key-down-fn mouse-motion-fn quit-fn)))) (defun wait-keypress () (let ((key nil)) @@ -557,9 +557,6 @@ (ty (/ (- y dy) (pal-ffi:image-texture-height image)))) (pal-ffi:gl-tex-coord2f tx ty) (pal-ffi:gl-vertex2f x y)))))) - ((and (listp fill) image) - (set-image image) - ) ((eq nil fill) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-line-bit+ pal-ffi:+gl-enable-bit+)) (set-blend-color r g b a) @@ -578,7 +575,9 @@ (with-gl pal-ffi:+gl-polygon+ (dolist (p points) (pal-ffi:gl-vertex2f (vx p) (vy p)))) - (pal-ffi:gl-pop-attrib)))) + (pal-ffi:gl-pop-attrib)) + (t + (set-image image)))) --- /project/pal/cvsroot/pal/todo.txt 2007/07/03 18:10:33 1.3 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/03 18:42:35 1.4 @@ -21,3 +21,4 @@ - Make it run on OS X. +- TrueType font support.

1 0

[pal-cvs] CVS pal/examples
by tneste 03 Jul '07

03 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv27783/examples Modified Files: hello.lisp swarm.lisp Log Message: Removed MOUSE-BUTTON-DOWN/UP-FN from event handling functions. Use KEY-*-FN instead --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/03 18:10:33 1.3 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/03 18:42:33 1.4 @@ -6,14 +6,14 @@ (pal:with-pal (:paths "/path/to/examples/") (let ((font (pal:load-font "georgia"))) (pal:draw-text "Hello from PAL" - (pal:v-round - (pal:v (/ (- (pal:get-screen-width) - (pal:get-text-size "Hello from PAL" font)) - 2) - (/ (- (pal:get-screen-height) - (pal:get-font-height font)) - 2))) - font)) + (pal:v-round + (pal:v (/ (- (pal:get-screen-width) + (pal:get-text-size "Hello from PAL" font)) + 2) + (/ (- (pal:get-screen-height) + (pal:get-font-height font)) + 2))) + font)) (pal:wait-keypress))) ;; (hello-1) @@ -22,11 +22,12 @@ (defun hello-2 () (pal:with-pal () (let ((angle 0f0)) + (pal:set-blend-color 0 255 0 255) (pal:event-loop () - (pal:draw-rectangle (pal:v 0 0) - (pal:get-screen-width) (pal:get-screen-height) - 50 50 200 10) - (pal:with-transformation (:pos (pal:v 400 300) :angle (incf angle 1f0) :scale 3f0) - (pal:draw-text "Hello from PAL" (pal:v 0 0))))))) + (pal:draw-rectangle (pal:v 0 0) + (pal:get-screen-width) (pal:get-screen-height) + 0 0 0 10) + (pal:with-transformation (:pos (pal:v 400 300) :angle (incf angle 1f0) :scale 3f0) + (pal:draw-text "Hello from PAL" (pal:v 0 0))))))) ;; (hello-2) \ No newline at end of file --- /project/pal/cvsroot/pal/examples/swarm.lisp 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/03 18:42:33 1.2 @@ -3,10 +3,11 @@ (defun swarm () (let ((vectors nil)) (pal:with-pal (:width 1024 :height 768) - (pal:event-loop (:mouse-button-down-fn (lambda (mb) - (when (= mb 1) - (setf vectors (append vectors (loop repeat 50 collecting (cons (pal:get-mouse-pos) - (pal:v-random 5f0)))))))) + (pal:event-loop (:key-down-fn (lambda (key) + (pal:message key) + (when (eq key :key-mouse-1) + (setf vectors (append vectors (loop repeat 50 collecting (cons (pal:get-mouse-pos) + (pal:v-random 5f0)))))))) (pal:draw-rectangle (pal:v 0 0) 1024 768 0 0 0 128) (pal:with-blend (:r 255 :g 128 :b 128 :a 255) (pal:draw-text "Use left mousekey to add particles." (pal:v 0 0)))

1 0

[pal-cvs] CVS pal
by tneste 03 Jul '07

03 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv23257 Modified Files: pal.lisp Log Message: Changed the arguments of sound functions. Volume is now 0 - 255. --- /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:10:33 1.3 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:27:22 1.4 @@ -585,23 +585,24 @@ ;;; Samples -(defun load-sample (file &optional (volume 128)) - "Volume 0-128" +(defun load-sample (file &optional (volume 255)) + "Volume 0-255" (let ((sample (pal-ffi:load-wav (data-path file)))) - (pal-ffi:volume-chunk (pal-ffi:sample-chunk sample) volume) + (pal-ffi:volume-chunk (pal-ffi:sample-chunk sample) (1+ (truncate volume 2))) sample)) (declaim (inline play-sample)) -(defun play-sample (sample &optional (loops 0) (angle 0) (distance 0)) - "Angle is an integer between 0-360. Distance is an integer between 0-255." - (let ((channel (pal-ffi:play-channel -1 (pal-ffi:sample-chunk sample) loops))) - (pal-ffi:set-position channel angle distance) +(defun play-sample (sample &key (loops nil) (angle 0) (volume 255)) + "Angle is an integer between 0-360. Volume is an integer between 0-255." + (let ((channel (pal-ffi:play-channel -1 (pal-ffi:sample-chunk sample) (if (numberp loops) + loops + 0)))) + (pal-ffi:set-position channel angle (- 255 volume)) channel)) (defun set-sample-volume (sample volume) - "Volume 0-128." - (pal-ffi:volume-chunk (pal-ffi:sample-chunk sample) volume)) - + "Volume 0-255" + (pal-ffi:volume-chunk (pal-ffi:sample-chunk sample) (1+ (truncate volume 2)))) @@ -610,14 +611,16 @@ (defun load-music (file) (pal-ffi:load-music (data-path file))) -(defun play-music (music &optional (loops -1) (volume 128)) - "Volume 0-128, -1 for loops is repeat" - (pal-ffi:volume-music volume) - (pal-ffi:play-music (pal-ffi:music-music music) loops)) +(defun play-music (music &optional (loops t) (volume 255)) + "Volume 0-255. Loops is: t = forever, nil = once, number = number of loops" + (pal-ffi:volume-music (1+ (truncate volume 2))) + (pal-ffi:play-music (pal-ffi:music-music music) (cond ((eq loops t) -1) + ((null loops) 0) + (t loops)))) (defun set-music-volume (volume) - "Volume 0-128" - (pal-ffi:volume-music volume)) + "Volume 0-255" + (pal-ffi:volume-music (1+ (truncate volume 2)))) (defun halt-music () (pal-ffi:halt-music))

1 0

[pal-cvs] CVS pal
by tneste 03 Jul '07

03 Jul '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv18496 Modified Files: ffi.lisp package.lisp pal-macros.lisp pal.lisp todo.txt vector.lisp Log Message: Faster bitmap loading --- /project/pal/cvsroot/pal/ffi.lisp 2007/07/01 22:49:25 1.2 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/07/03 18:10:33 1.3 @@ -846,4 +846,9 @@ #+win32 (defun get-application-folder () (cffi:with-foreign-object (path :char 4096) (shgetfolderpatha (cffi:null-pointer) #x001c (cffi:null-pointer) 0 path) - (concatenate 'string (cffi:foreign-string-to-lisp path) "/"))) \ No newline at end of file + (concatenate 'string (cffi:foreign-string-to-lisp path) "/"))) + +(cffi:defcfun "calloc" :pointer (nelem :uint) (elsize :uint)) +(cffi:defcfun "free" :void (ptr :pointer)) + + --- /project/pal/cvsroot/pal/package.lisp 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/package.lisp 2007/07/03 18:10:33 1.2 @@ -7,6 +7,8 @@ #:make-font #:+gl-scissor-test+ #:+gl-points+ + #:free + #:calloc #:music-music #:register-resource #:sample-chunk @@ -349,7 +351,7 @@ (:export #:open-pal #:with-pal #:close-pal - #:get-info + #:get-gl-info #:load-foreign-libraries #:register-resource #:free-resource @@ -367,7 +369,6 @@ #:get-application-file #:data-path #:with-resource - #:with-blend #:with-clipping #:randomly @@ -385,9 +386,7 @@ #:get-mouse-x #:get-mouse-y - #:update-screen #:clear-screen - #:clear-depth-buffer #:get-screen-width #:get-screen-height #:set-cursor @@ -401,6 +400,7 @@ #:set-blend-mode #:reset-blend-mode #:set-blend-color + #:with-blend #:load-image #:image-width @@ -409,7 +409,7 @@ #:draw-rectangle #:draw-point #:draw-line - #:draw-arrow + #:draw-arrow #:draw-image #:draw-image-from #:draw-quad --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/01 22:49:25 1.2 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/07/03 18:10:33 1.3 @@ -176,4 +176,11 @@ (apply 'open-pal (list ,@args)) (unwind-protect (progn ,@body) - (close-pal)))) \ No newline at end of file + (close-pal)))) + + +(defmacro with-foreign-vector ((chunk n size) &body body) + `(let ((,chunk (pal-ffi:calloc ,n ,size))) + (unwind-protect + ,@body + (pal-ffi:free ,chunk)))) --- /project/pal/cvsroot/pal/pal.lisp 2007/07/01 22:49:25 1.2 +++ /project/pal/cvsroot/pal/pal.lisp 2007/07/03 18:10:33 1.3 @@ -147,7 +147,7 @@ result (error "Data file not found: ~a" file)))) -(defun get-info () +(defun get-gl-info () (format nil "Vendor: ~a~%Renderer: ~a~%Version: ~a~%Extensions: ~a~%" (pal-ffi:gl-get-string pal-ffi:+gl-vendor+) (pal-ffi:gl-get-string pal-ffi:+gl-renderer+) @@ -367,30 +367,27 @@ (> (expt 2 x) (1- height))) '(6 7 8 9 10)) 10))) - (id (cffi:foreign-alloc :uint :count 1)) - (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)))))) - (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) - (cffi:mem-ref tdata :uint8 (+ p 1)) (the u8 g) - (cffi:mem-ref tdata :uint8 (+ p 2)) (the u8 b) - (cffi:mem-ref tdata :uint8 (+ p 3)) (the u8 a))))) - (pal-ffi:gl-gen-textures 1 id) - (pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (cffi:mem-ref id :uint)) - (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-mag-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) - (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) - (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ - 0 - (if (= (cffi:foreign-slot-value (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:pixelformat) - 'pal-ffi:pixelformat 'pal-ffi:bytesperpixel) - 3) - pal-ffi:+gl-rgb+ - pal-ffi:+gl-rgba+) - texture-width texture-height 0 pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ tdata) - (cffi:foreign-free tdata) + (id (cffi:foreign-alloc :uint :count 1))) + (with-foreign-vector (tdata (* texture-width texture-height) 4) + (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)))))) + (setf (cffi:mem-ref tdata :uint8 p) (the u8 r) + (cffi:mem-ref tdata :uint8 (+ p 1)) (the u8 g) + (cffi:mem-ref tdata :uint8 (+ p 2)) (the u8 b) + (cffi:mem-ref tdata :uint8 (+ p 3)) (the u8 a))))) + (pal-ffi:gl-gen-textures 1 id) + (pal-ffi:gl-bind-texture pal-ffi:+gl-texture-2d+ (cffi:mem-ref id :uint)) + (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-mag-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) + (pal-ffi:gl-tex-parameteri pal-ffi:+gl-texture-2d+ pal-ffi:+gl-texture-min-filter+ (if smooth-p pal-ffi:+gl-linear+ pal-ffi:+gl-nearest+)) + (pal-ffi:gl-teximage2d pal-ffi:+gl-texture-2d+ + 0 + (if (= (cffi:foreign-slot-value (cffi:foreign-slot-value surface 'pal-ffi:surface 'pal-ffi:pixelformat) + 'pal-ffi:pixelformat 'pal-ffi:bytesperpixel) + 3) + pal-ffi:+gl-rgb+ + pal-ffi:+gl-rgba+) + texture-width texture-height 0 pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+ tdata)) (let ((image (pal-ffi::make-image :texture (cffi:mem-ref id :uint) :tx2 (coerce (/ width texture-width) 'single-float) :ty2 (coerce (/ height texture-height) 'single-float) --- /project/pal/cvsroot/pal/todo.txt 2007/07/01 22:49:25 1.2 +++ /project/pal/cvsroot/pal/todo.txt 2007/07/03 18:10:33 1.3 @@ -19,7 +19,5 @@ - 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. --- /project/pal/cvsroot/pal/vector.lisp 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/vector.lisp 2007/07/03 18:10:33 1.2 @@ -3,7 +3,8 @@ (in-package :pal) -(deftype component () 'single-float) +#+CL-HAS-FULL-NUMERIC-TOWER-DAMMIT (deftype component () 'number) +#-CL-HAS-FULL-NUMERIC-TOWER-DAMMIT (deftype component () 'single-float) (defstruct (vec (:conc-name v)) (x 0 :type component) (y 0 :type component))

1 0

[pal-cvs] CVS pal/examples
by tneste 03 Jul '07

03 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv18496/examples Modified Files: hello.lisp Log Message: Faster bitmap loading --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/01 22:49:25 1.2 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/03 18:10:33 1.3 @@ -3,17 +3,17 @@ (defun hello-1 () - (pal:with-pal (:paths "/path/to/examples/) + (pal:with-pal (:paths "/path/to/examples/") (let ((font (pal:load-font "georgia"))) (pal:draw-text "Hello from PAL" - (pal:v-round - (pal:v (/ (- (pal:get-screen-width) - (pal:get-text-size "Hello from PAL" font)) - 2) - (/ (- (pal:get-screen-height) - (pal:get-font-height font)) - 2))) - font)) + (pal:v-round + (pal:v (/ (- (pal:get-screen-width) + (pal:get-text-size "Hello from PAL" font)) + 2) + (/ (- (pal:get-screen-height) + (pal:get-font-height font)) + 2))) + font)) (pal:wait-keypress))) ;; (hello-1) @@ -23,10 +23,10 @@ (pal:with-pal () (let ((angle 0f0)) (pal:event-loop () - (pal:draw-rectangle (pal:v 0 0) - (pal:get-screen-width) (pal:get-screen-height) - 50 50 200 10) - (pal:with-transformation (:pos (pal:v 400 300) :angle (incf angle 1f0) :scale 3f0) - (pal:draw-text "Hello from PAL" (pal:v 0 0))))))) + (pal:draw-rectangle (pal:v 0 0) + (pal:get-screen-width) (pal:get-screen-height) + 50 50 200 10) + (pal:with-transformation (:pos (pal:v 400 300) :angle (incf angle 1f0) :scale 3f0) + (pal:draw-text "Hello from PAL" (pal:v 0 0))))))) ;; (hello-2) \ No newline at end of file

1 0

[pal-cvs] CVS pal
by tneste 01 Jul '07

01 Jul '07

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.

1 0

[pal-cvs] CVS pal/examples
by tneste 01 Jul '07

01 Jul '07

Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv13199/examples Modified Files: hello.lisp teddy.lisp Log Message: Fixed the Lispworks problems, some minor cleanups --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/01 22:49:25 1.2 @@ -3,7 +3,7 @@ (defun hello-1 () - (pal:with-pal (:paths "path/to/examples/folder/") + (pal:with-pal (:paths "/path/to/examples/) (let ((font (pal:load-font "georgia"))) (pal:draw-text "Hello from PAL" (pal:v-round --- /project/pal/cvsroot/pal/examples/teddy.lisp 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/examples/teddy.lisp 2007/07/01 22:49:25 1.2 @@ -64,7 +64,7 @@ (defun example () - (with-pal (:width 800 :height 600 :fullscreenp nil :fps 60 :paths "./") + (with-pal (:width 800 :height 600 :fullscreenp nil :fps 60) ;; inits PAL, the args used are the default values. ;; NOTE: fix the PATHS to point to the location of the resource files ;; PATHS is a pathname or list of pathnames that defines paths that the LOAD-* functions use for finding resources. @@ -72,7 +72,6 @@ (setf *sprites* nil) (set-cursor (tag 'cursor) (v 18 18)) - (make-instance 'plane) (dotimes (i 20) (make-instance 'mutant-teddy @@ -100,7 +99,7 @@ (dolist (i *sprites*) (draw i) #+CLISP (ext:without-floating-point-underflow - (act i)) + (act i)) #-CLISP (act i))) (test-keys

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

pal-cvs July 2007