[pal-cvs] CVS pal
tneste
tneste at common-lisp.net
Wed Nov 14 00:04:34 UTC 2007
Update of /project/pal/cvsroot/pal
In directory clnet:/tmp/cvs-serv13845
Modified Files:
package.lisp pal.lisp vector.lisp
Log Message:
Added :VMIRROR and :HMIRROR options to DRAW-IMAGE.
Added RECTANGLES-OVERLAP-P.
--- /project/pal/cvsroot/pal/package.lisp 2007/10/31 22:38:22 1.22
+++ /project/pal/cvsroot/pal/package.lisp 2007/11/14 00:04:34 1.23
@@ -459,5 +459,6 @@
#:v-dot #:v-magnitude #:v-normalize #:v-distance
#:v-truncate #:v-direction
#:closest-point-to-line #:point-in-line-p #:lines-intersection
- #:distance-from-line #:circle-line-intersection #:point-inside-rectangle-p
+ #:distance-from-line #:circle-line-intersection
+ #:point-inside-rectangle-p #:rectangles-overlap-p
#:circles-overlap-p #:point-inside-circle-p))
\ No newline at end of file
--- /project/pal/cvsroot/pal/pal.lisp 2007/10/31 22:38:22 1.40
+++ /project/pal/cvsroot/pal/pal.lisp 2007/11/14 00:04:34 1.41
@@ -515,14 +515,16 @@
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 scale valign halign vmirror hmirror)
+ (image image vec pos (or boolean number) angle (or boolean number) scale symbol halign symbol valign symbol vmirror symbol hmirror)
(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)
+ (tx1 (if hmirror (pal-ffi:image-tx2 image) 0f0))
+ (ty1 (if vmirror (pal-ffi:image-ty2 image) 0f0))
+ (tx2 (if hmirror 0f0 (pal-ffi:image-tx2 image)))
+ (ty2 (if vmirror 0f0 (pal-ffi:image-ty2 image))))
+ (if (or angle scale valign halign)
(with-transformation ()
(translate pos)
(when angle
@@ -540,26 +542,26 @@
(:middle (- (/ height 2f0)))
(otherwise 0f0))))
(with-gl pal-ffi:+gl-quads+
- (pal-ffi:gl-tex-coord2f 0f0 0f0)
+ (pal-ffi:gl-tex-coord2f tx1 ty1)
(pal-ffi:gl-vertex2f x y)
- (pal-ffi:gl-tex-coord2f tx2 0f0)
+ (pal-ffi:gl-tex-coord2f tx2 ty1)
(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-tex-coord2f tx1 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-tex-coord2f tx1 ty1)
(pal-ffi:gl-vertex2f x y)
- (pal-ffi:gl-tex-coord2f tx2 0f0)
+ (pal-ffi:gl-tex-coord2f tx2 ty1)
(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-tex-coord2f tx1 ty2)
(pal-ffi:gl-vertex2f x height))))))
@@ -897,8 +899,8 @@
font
(tag 'default-font)))))
-(defun draw-fps ()
- (draw-text (prin1-to-string (get-fps)) (v 0 0)))
+(defun draw-fps (&optional font)
+ (draw-text (prin1-to-string (get-fps)) (v 0 0) font))
(defun message (&rest messages)
(setf *messages* (append *messages* (list (format nil "~{~S ~}" messages))))
--- /project/pal/cvsroot/pal/vector.lisp 2007/10/30 20:43:10 1.10
+++ /project/pal/cvsroot/pal/vector.lisp 2007/11/14 00:04:34 1.11
@@ -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,24 +29,24 @@
(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
@@ -54,49 +54,49 @@
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))
@@ -264,12 +264,24 @@
(> y y1) (< y y2))
t nil)))
+
+(defun rectangles-overlap-p (a a-width a-height b b-width b-height)
+ (let ((ax (vx a))
+ (ay (vy a))
+ (bx (vx b))
+ (by (vy b)))
+ (not (or (> ax (+ bx b-width))
+ (< (+ ax a-width) bx)
+ (> ay (+ by b-height))
+ (< (+ ay a-height) by)))))
+
+
(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
More information about the Pal-cvs
mailing list