Update of /project/pal/cvsroot/pal
In directory clnet:/tmp/cvs-serv32428
Modified Files:
package.lisp pal-macros.lisp pal.asd pal.lisp todo.txt
vector.lisp
Added Files:
color.lisp
Log Message:
Added color.lisp. WITH-BLEND now takes a COLOR structure as its :COLOR argument instead of a list.
--- /project/pal/cvsroot/pal/package.lisp 2007/10/24 18:07:03 1.20
+++ /project/pal/cvsroot/pal/package.lisp 2007/10/30 20:43:10 1.21
@@ -370,7 +370,7 @@
#:free-resource
#:free-all-resources
#:define-tags
- #:add-tag
+ #:add-tag
#:tag
#:sample
#:music
@@ -388,8 +388,8 @@
#:random-elt
#:clamp
#:do-n
-
- #:handle-events
+
+ #:handle-events
#:key-pressed-p
#:keysym-char
#:test-keys
@@ -451,6 +451,8 @@
#:play-music
#:halt-music
+ #:color #:color-r #:color-g #:color-b #:color-a #:random-color
+
#:v #:vec #:copy-vec #:angle-v #:v-angle #:vx #:vy
#:v= #:v-round #:v-floor #:v-random
#:v+ #:v+! #:v- #:v-! #:v* #:v*! #:v/ #:v/! #:v-max #:v-min #:v-rotate
--- /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/24 17:51:47 1.15
+++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/30 20:43:10 1.16
@@ -90,20 +90,20 @@
(defmacro with-default-settings (&body body)
"Evaluate BODY with default transformations and blend settings."
`(with-transformation ()
- (with-blend (:mode :blend :color '(255 255 255 255))
+ (with-blend (:mode :blend :color (color 255 255 255 255))
(pal-ffi:gl-load-identity)
,@body)))
(defmacro with-blend ((&key (mode t) color) &body body)
- "Evaluate BODY with blend options set to MODE and COLOR. Color is a list of (r g b a) values."
+ "Evaluate BODY with blend options set to MODE and COLOR."
`(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))
,(when color
- `(set-blend-color (first ,color) (second ,color) (third ,color) (fourth ,color)))
+ `(set-blend-color (color-r ,color) (color-g ,color) (color-b ,color) (color-a ,color)))
(prog1 (progn
,@body)
(close-quads)
--- /project/pal/cvsroot/pal/pal.asd 2007/07/21 16:34:16 1.3
+++ /project/pal/cvsroot/pal/pal.asd 2007/10/30 20:43:10 1.4
@@ -8,12 +8,14 @@
:components
((:file "ffi"
:depends-on ("package"))
+ (:file "color"
+ :depends-on ("package"))
(:file "vector"
:depends-on ("pal-macros"))
(:file "pal-macros"
- :depends-on ("ffi"))
+ :depends-on ("ffi" "color"))
(:file "pal"
- :depends-on ("pal-macros" "vector"))
+ :depends-on ("pal-macros" "color" "vector"))
(:file "package"))
:depends-on ("cffi"))
--- /project/pal/cvsroot/pal/pal.lisp 2007/10/29 20:04:19 1.37
+++ /project/pal/cvsroot/pal/pal.lisp 2007/10/30 20:43:10 1.38
@@ -1,8 +1,3 @@
-;; Notes:
-;; add start/end args to draw-circle
-;; check for redundant close-quads, optimise rotations/offsets etc. in draw-image
-;; optimise gl state handling, fix clipping, structured color values
-
(declaim (optimize (speed 3)
(safety 1)))
@@ -185,10 +180,12 @@
(defunct keysym-char (keysym)
(symbol keysym)
- (let ((kv (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym)))
- (if (and (> kv 0) (< kv 256))
- (code-char kv)
- nil)))
+ (if (or (eq keysym :key-mouse-1) (eq keysym :key-mouse-2) (eq keysym :key-mouse-3))
+ nil
+ (let ((kv (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym)))
+ (if (and (> kv 0) (< kv 256))
+ (code-char kv)
+ nil))))
(declaim (inline get-mouse-pos))
(defun get-mouse-pos ()
@@ -882,9 +879,7 @@
(declaim (inline get-font-height))
(defunct get-font-height (&optional font)
((or font boolean) font)
- (pal-ffi:font-height (if font
- font
- (tag 'default-font))))
+ (pal-ffi:font-height (or font (tag 'default-font))))
(defunct get-text-size (text &optional font)
((or font boolean) font simple-string text)
@@ -904,5 +899,4 @@
(defun message (&rest messages)
(setf *messages* (append *messages* (list (format nil "~{~S ~}" messages))))
(when (> (length *messages*) (- (truncate (get-screen-height) (get-font-height)) 1))
- (pop *messages*)))
-
+ (pop *messages*)))
\ No newline at end of file
--- /project/pal/cvsroot/pal/todo.txt 2007/10/29 20:04:20 1.19
+++ /project/pal/cvsroot/pal/todo.txt 2007/10/30 20:43:10 1.20
@@ -1,7 +1,26 @@
TODO:
+
+For v1.1
+
+- Fix offsets in draw-image.
+
+- Polygon smooth hint?
+
- Add align, scale and angle options to DRAW-IMAGE*.
+- Better clipping.
+
+- Structured color values.
+
+
+
+After v1.1
+
+- Better drawing primitives, real lines, start/end args to draw-circle etc.
+
+- As always, optimise GL state handling.
+
- Implement image mirroring, tiles and animation.
- Box/box/line/circle etc. overlap functions, faster v-dist.
@@ -16,9 +35,11 @@
As separate projects on top of PAL:
-- Native CL font resource builder
+- GUI, work in progress.
+
+- Native CL font resource builder.
-- TTF support
+- TTF support.
- Some sort of sprite library?
--- /project/pal/cvsroot/pal/vector.lisp 2007/10/11 19:26:23 1.9
+++ /project/pal/cvsroot/pal/vector.lisp 2007/10/30 20:43:10 1.10
@@ -12,12 +12,12 @@
(declaim (inline component))
(defunct component (x)
- (number x)
+ (number x)
(coerce x 'component))
(declaim (inline v))
(defunct v (x y)
- (component x component y)
+ (component x component y)
(make-vec :x x :y y))
(declaim (inline vf))
@@ -29,74 +29,74 @@
(declaim (inline rad))
(defunct rad (degrees)
- (component degrees)
+ (component degrees)
(* (/ pi 180) degrees))
(declaim (inline deg))
(defunct deg (radians)
- (component radians)
+ (component radians)
(* (/ 180 pi) radians))
(declaim (inline angle-v))
(defunct angle-v (angle)
- (component angle)
+ (component angle)
(v (sin (rad angle)) (- (cos (rad angle)))))
(declaim (inline v-angle))
(defunct v-angle (vec)
- (vec vec)
+ (vec vec)
(mod (deg (atan (vx vec)
(if (zerop (vy vec))
least-negative-short-float
- (- (vy vec)))))
+ (- (vy vec))) ))
360))
(defunct v-random (length)
- (number length)
+ (number length)
(v* (angle-v (random 360.0)) length))
(declaim (inline v-round))
(defunct v-round (v)
- (vec v)
+ (vec v)
(v (round (vx v)) (round (vy v))))
(declaim (inline v-floor))
(defunct v-floor (v)
- (vec v)
+ (vec v)
(v (floor (vx v)) (floor (vy v))))
(declaim (inline v=))
(defunct v= (a b)
- (vec a vec b)
+ (vec a vec b)
(and (= (vx a) (vx b))
(= (vy a) (vy b))))
(declaim (inline v+!))
(defunct v+! (a b)
- (vec a vec b)
+ (vec a vec b)
(setf (vx a) (+ (vx a) (vx b)))
(setf (vy a) (+ (vy a) (vy b)))
nil)
(declaim (inline v+))
(defunct v+ (a b)
- (vec a vec b)
+ (vec a vec b)
(vf (+ (vx a) (vx b))
(+ (vy a) (vy b))))
(declaim (inline v-))
(defunct v- (a b)
- (vec a vec b)
+ (vec a vec b)
(vf (- (vx a) (vx b))
(- (vy a) (vy b))))
(declaim (inline v-!))
(defunct v-! (a b)
- (vec a vec b)
+ (vec a vec b)
(setf (vx a) (- (vx a) (vx b)))
(setf (vy a) (- (vy a) (vy b)))
nil)
@@ -104,47 +104,47 @@
(declaim (inline v*!))
(defunct v*! (v m)
- (component m)
+ (component m)
(setf (vx v) (* (vx v) m))
(setf (vy v) (* (vy v) m))
nil)
(declaim (inline v*))
(defunct v* (v m)
- (vec v component m)
+ (vec v component m)
(vf (* (vx v) m)
(* (vy v) m)))
(declaim (inline v/))
(defunct v/ (v d)
- (vec v component d)
+ (vec v component d)
(vf (/ (vx v) d)
(/ (vy v) d)))
(declaim (inline v/!))
(defunct v/! (v d)
- (vec v component d)
+ (vec v component d)
(setf (vx v) (/ (vx v) d))
(setf (vy v) (/ (vy v) d))
nil)
(declaim (inline v-max))
(defunct v-max (a b)
- (vec a vec b)
+ (vec a vec b)
(if (< (v-magnitude a) (v-magnitude b))
b a))
(declaim (inline v-min))
(defunct v-min (a b)
- (vec a vec b)
+ (vec a vec b)
(if (< (v-magnitude a) (v-magnitude b))
a b))
(defunct v-rotate (v a)
- (vec v component a)
+ (vec v component a)
(let ((a (rad a)))
(v (- (* (cos a) (vx v))
(* (sin a) (vy v)))
@@ -153,20 +153,20 @@
(declaim (inline v-dot))
(defunct v-dot (a b)
- (vec a vec b)
+ (vec a vec b)
(+ (* (vx a) (vx b))
(* (vy a) (vy b))))
(declaim (inline v-magnitude))
(defunct v-magnitude (v)
- (vec v)
+ (vec v)
(the component (sqrt (the component
(+ (expt (vx v) 2)
(expt (vy v) 2))))))
(defunct v-normalize (v)
- (vec v)
+ (vec v)
(let ((m (v-magnitude v)))
(if (/= m 0f0)
(vf (/ (vx v) m)
@@ -174,23 +174,23 @@
(vf 0f0 0f0))))
(defunct v-direction (from-vector to-vector)
- (vec from-vector vec to-vector)
+ (vec from-vector vec to-vector)
(v-normalize (v- to-vector from-vector)))
(defunct v-distance (v1 v2)
- (vec v1 vec v2)
+ (vec v1 vec v2)
(v-magnitude (v- v1 v2)))
(defunct v-truncate (v l)
- (vec v component l)
+ (vec v component l)
(v* (v-normalize v) l))
(defunct closest-point-to-line (a b p)
- (vec a vec b vec p)
+ (vec a vec b vec p)
(let* ((dir (v- b a))
(diff (v- p a))
(len (v-dot dir dir)))
@@ -204,14 +204,14 @@
a)))))
(defunct point-in-line-p (a b p)
- (vec a vec b vec 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)))
(defunct lines-intersection (la1 la2 lb1 lb2)
- (vec la1 vec la2 vec lb1 vec lb2)
+ (vec la1 vec la2 vec lb1 vec lb2)
(let ((x1 (vx la1))
(y1 (vy la1))
(x2 (vx la2))
@@ -237,7 +237,7 @@
nil))))))
(defunct circle-line-intersection (a b co r)
- (vec a vec b vec co component 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)
@@ -246,14 +246,14 @@
nil)))
(defunct distance-from-line (a b p)
- (vec a vec b vec p)
+ (vec a vec b vec p)
(let ((cp (closest-point-to-line a b p)))
(if cp
(v-distance cp p)
nil)))
(defunct point-inside-rectangle-p (topleft width height point)
- (vec topleft vec point component width component height)
+ (vec topleft vec point component width component height)
(let* ((x1 (vx topleft))
(y1 (vy topleft))
(x2 (+ x1 width))
@@ -266,10 +266,10 @@
(declaim (inline point-inside-circle-p))
(defunct point-inside-circle-p (co r p)
- (vec co vec p component r)
+ (vec co vec p component r)
(<= (v-distance co p) r))
(declaim (inline circles-overlap-p))
(defunct circles-overlap-p (c1 r1 c2 r2)
- (vec c1 vec c2 component r1 component r2)
+ (vec c1 vec c2 component r1 component r2)
(<= (v-distance c1 c2) (+ r2 r1)))
\ No newline at end of file
--- /project/pal/cvsroot/pal/color.lisp 2007/10/30 20:43:11 NONE
+++ /project/pal/cvsroot/pal/color.lisp 2007/10/30 20:43:11 1.1
(in-package :pal)
(defstruct color
(r 0 :type pal::u8)
(g 0 :type pal::u8)
(b 0 :type pal::u8)
(a 0 :type pal::u8))
(declaim (inline color))
(defun color (r g b a)
(make-color :r r :g g :b b :a a))
(defun random-color ()
(color (random 255) (random 255) (random 255) (random 255)))
