pal-cvs

pal-cvs@common-lisp.net

127 discussions

[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/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 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
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/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
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
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/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-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

← Newer
1
...
7
8
9
10
11
12
13
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

pal-cvs