At Tue, 9 Jan 2007 00:40:21 +0000 (UTC),
Luke Crook wrote:
[snip]
> The point code that exists in lispbuilder-sdl makes use of vectors. So #(10
> 10), (vector 10 10), or (point 10 10) all do the same thing.
Not to look insistent, but I have talked to #lisp people, and the conclusion
was that a cons cell has most likely a smaller footprint than an array,
and that a structure type might be even better.
> Do you have code for the compound operations?
This is what i use -- feel free to do anything with it.
(This means i hereby place it in the public domain)
I realise that the requirements/design choices might be different,
but i guess at least sharing this code is better than not...
(deftype v2 () '(cons fixnum fixnum))
(declaim (ftype (function (fixnum fixnum) v2) v2))
(defun v2 (c1 c2)
(declare (type fixnum c1 c2))
(cons c1 c2))
(declaim (ftype (function () v2) v2zero))
(defun v2zero ()
(cons 0 0))
(declaim (ftype (function (v2) boolean) v2zerop))
(defun v2zerop (p)
(declare (type v2 p))
(= 0 (car p) (cdr p)))
(declaim (ftype (function (v2) boolean) v2plusp-or))
(defun v2plusp-or (p)
(declare (type v2 p))
(or (plusp (car p))
(plusp (cdr p))))
(declaim (ftype (function (v2) boolean) v2plusp-and))
(defun v2plusp-and (p)
(declare (type v2 p))
(and (plusp (car p))
(plusp (cdr p))))
(declaim (ftype (function (v2) boolean) v2minusp-or))
(defun v2minusp-or (p)
(declare (type v2 p))
(or (minusp (car p))
(minusp (cdr p))))
(declaim (ftype (function (v2) boolean) v2minusp-and))
(defun v2minusp-and (p)
(declare (type v2 p))
(and (minusp (car p))
(minusp (cdr p))))
(declaim (ftype (function (v2 v2) boolean) v2eq))
(defun v2eq (p0 p1)
(declare (type v2 p0 p1))
(and
(= (car p0) (car p1))
(= (cdr p0) (cdr p1))))
(declaim (ftype (function (v2 v2) v2) v2+))
(defun v2+ (p1 p2)
(declare (type v2 p1 p2))
(v2 (+ (car p1) (car p2))
(+ (cdr p1) (cdr p2))))
(declaim (ftype (function (v2 v2) v2) v2-))
(defun v2- (p1 p2)
(declare (type v2 p1 p2))
(v2 (- (car p1) (car p2))
(- (cdr p1) (cdr p2))))
(declaim (ftype (function (v2 v2) v2) v2d))
(defun v2d (p1 p2)
(declare (type v2 p1 p2))
(v2 (abs (- (car p1) (car p2)))
(abs (- (cdr p1) (cdr p2)))))
(defun v2setf (to from)
(declare (type v2 to from))
(setf (car to) (car from)
(cdr to) (cdr from))
to)
(declaim (ftype (function (v2 v2) v2) v2setf))
(declaim (ftype (function (v2 v2) fixnum) v2dist))
(defun v2dist (p1 p2)
(declare (type v2 p1 p2))
(let ((d (v2d p1 p2)))
(ceiling (sqrt (+ (* (car d) (car d)) (* (cdr d) (cdr d)))))))
(declaim (ftype (function (v2 v2) double-float) v2distf))
(defun v2distf (p1 p2)
(declare (type v2 p1 p2))
(let ((d (v2d p1 p2)))
(coerce (sqrt (+ (* (car d) (car d)) (* (cdr d) (cdr d)))) 'double-float)))
(declaim (ftype (function (v2 v2) v2) v2min))
(defun v2min (p1 p2)
(declare (type v2 p1 p2))
(v2 (min (car p1) (car p2))
(min (cdr p1) (cdr p2))))
(declaim (ftype (function (v2 v2) v2) v2max))
(defun v2max (p1 p2)
(declare (type v2 p1 p2))
(v2 (max (car p1) (car p2))
(max (cdr p1) (cdr p2))))
(declaim (ftype (function (fixnum fixnum v2) v2) v2+i))
(defun v2+i (c1 c2 p)
(declare (type fixnum c1 c2)
(type v2 p))
(v2 (+ (car p) c1)
(+ (cdr p) c2)))
(declaim (ftype (function (fixnum fixnum v2) v2) v2-i))
(defun v2-i (c1 c2 p)
(declare (type fixnum c1 c2)
(type v2 p))
(v2 (- (car p) c1)
(- (cdr p) c2)))
(declaim (ftype (function (fixnum v2) v2) v2*i))
(defun v2*i (n p)
(declare (type v2 p) (type fixnum n))
(v2 (* (car p) n)
(* (cdr p) n)))
(declaim (ftype (function (fixnum v2) v2) v2/i))
(defun v2/i (n p)
(declare (type v2 p) (type fixnum n))
(v2 (floor (/ (car p) n))
(floor (/ (cdr p) n))))
(declaim (ftype (function (v2 v2) v2) v2incf))
(defun v2incf (tgt delta)
(declare (type v2 delta tgt))
(incf (car tgt) (car delta))
(incf (cdr tgt) (cdr delta))
tgt)
(declaim (ftype (function (v2) v2) v2-1))
(defun v2-1 (p)
(declare (type v2 p))
(v2 (1- (car p))
(1- (cdr p))))
(declaim (ftype (function (v2) v2) v2cp))
(defun v2cp (p)
(declare (type v2 p))
(v2 (car p)
(cdr p)))
(declaim (ftype (function (v2) list) v2list))
(defun v2list (p)
(declare (type v2 p))
(list (car p)
(cdr p)))
(declaim (ftype (function (v2) list) v2neigh4))
(defun v2neigh4 (p)
(declare (type v2 p))
(list
(v2 (1+ (car p)) (cdr p))
(v2 (1- (car p)) (cdr p))
(v2 (car p) (1+ (cdr p)))
(v2 (car p) (1- (cdr p)))))
;; (eval-when '(toplevel load compile) ...
(declaim (ftype (function (fixnum) (values fixnum fixnum)) v2nth-neigh4))
(defun v2nth-neigh4 (i)
(declare (type fixnum i))
(labels ((c (x)
(declare (type fixnum x))
(- 1 (ash (logand x 2) -1)
(ash (logand (logand x 1)
(lognot (ash (logand x 2) -1))) 1))))
(values (c i) (c (logxor 2 i)))))
(declaim (ftype (function (array) v2) array-v2dim))
(defun array-v2dim (arr)
(v2 (array-dimension arr 0)
(array-dimension arr 1)))
(defmacro aref-v2 (arr v2)
(once-only (v2)
`(aref ,arr (car ,v2) (cdr ,v2))))
(defsetf aref-v2 (arr v2) (val)
(once-only (v2)
`(setf (aref ,arr (car ,v2) (cdr ,v2)) ,val)))
;; conses more than it could, given an intelligent iterating fn
(defmacro do-v2neigh ((npt pt &key neighfn numneighs) &body body)
(with-unique-names (i)
(once-only (pt)
`(dotimes (,i ,numneighs)
(let ((,npt (multiple-value-call #'v2+i (funcall ,neighfn ,i) ,pt)))
,@body)))))
(defstruct box
(o (v2 0 0) :type v2)
(d (v2 0 0) :type v2))
(defun box-x (box) (car (box-o box)))
(defun box-y (box) (cdr (box-o box)))
(defun box-w (box) (car (box-d box)))
(defun box-h (box) (cdr (box-d box)))
(declaim (ftype (function (&key (:lu v2) (:rd v2)) box) make-box-pts))
(defun make-box-pts (&key lu rd)
(declare (type v2 lu rd))
(make-box :o lu :d (v2- rd lu)))
(declaim (ftype (function (v2 v2 v2) boolean) point-contained-literal))
(defun point-contained-literal (p o d)
"check whether p is contained in o/d"
(declare (type v2 p o d))
(labels ((val-fits (val upfrom below)
(and (>= val upfrom) (< val below))))
(and (val-fits (car p) (car o) (+ (car o) (car d)))
(val-fits (cdr p) (cdr o) (+ (cdr o) (cdr d))))))
(declaim (ftype (function (v2 box) boolean) point-contained))
(defun point-contained (p box)
(declare (type v2 p) (type box box))
(point-contained-literal p (box-o box) (box-d box)))
(declaim (ftype (function (box box) boolean) box-contained))
(defun box-contained (what in)
(declare (type box what) (type box in))
(and (point-contained (box-o what) in)
(point-contained (v2+ (box-o what) (box-d what)) in)))
(declaim (ftype (function (box box) boolean) box-intersects))
(defun box-intersects (b1 b2)
"as in set-intersection"
(declare (type box b1) (type box b2))
(or (point-contained (box-o b1) b2)
(point-contained (box-o b2) b1)
(point-contained (v2-1 (v2+ (box-o b1) (box-d b1))) b2)
(point-contained (v2 (box-x b1) (+ (box-y b1) (box-h b1) -1)) b2)
(point-contained (v2 (+ (box-x b1) (box-w b1) -1) (box-y b1)) b2)))
(declaim (ftype (function (fixnum box) box) box-scaled))
(defun box-scaled (n box)
(declare (type fixnum n) (type box box))
(make-box :o (v2*i n (box-o box)) :d (v2*i n (box-d box))))
(declaim (ftype (function (fixnum box) box) box-downscaled))
(defun box-downscaled (n box)
(declare (type fixnum n) (type box box))
(make-box :o (v2/i n (box-o box)) :d (v2/i n (box-d box))))
(declaim (ftype (function (fixnum box) box) box-shrink))
(defun box-shrink (n box)
(declare (type fixnum n) (type box box))
(make-box :o (v2+i n n (box-o box)) :d (v2+i (* -2 n) (* -2 n) (box-d box))))
(declaim (ftype (function (fixnum box) box) box-extend))
(defun box-extend (n box)
(declare (type fixnum n) (type box box))
(make-box :o (v2-i n n (box-o box)) :d (v2+i (* 2 n) (* 2 n) (box-d box))))
(declaim (ftype (function (v2 box) box) box-extend-v2))
(defun box-extend-v2 (p box)
(declare (type v2 p) (type box box))
(make-box :o (v2- (box-o box) p) :d (v2+ (v2*i 2 p) (box-d box))))
(declaim (ftype (function (v2 box) box) box-moved))
(defun box-moved (p box)
(declare (type v2 p) (type box box))
(make-box :o (v2+ p (box-o box)) :d (box-d box)))
(declaim (ftype (function (box) v2) box-o+d))
(defun box-o+d (box)
(declare (type box box))
(v2+ (box-o box) (box-d box)))
(declaim (ftype (function (box) box) box-to-4p))
(defun box-to-4p (box)
(declare (type box box))
(make-box :o (box-o box) :d (v2-1 (box-o+d box))))
(declaim (ftype (function (v2 box) v2) box-clamp-point))
(defun box-clamp-point (p box)
(declare (type v2 p) (type box box))
(labels ((clamp-val (val min span)
(cond ((< val min) min)
((>= val (+ min span)) (1- (+ min span)))
(t val))))
(v2 (clamp-val (car p) (box-x box) (box-w box))
(clamp-val (cdr p) (box-y box) (box-h box)))))
(declaim (ftype (function (&rest (boxes list)) (or null box)) box-intersect))
(defun box-intersect (&rest boxes)
(cond ((null boxes) nil)
((null (cdr boxes)) (car boxes))
(t
(let ((lu (box-o (car boxes)))
(rd (box-o+d (car boxes))))
(dolist (box (cdr boxes))
(setf lu (v2max lu (box-o box))
rd (v2min rd (box-o+d box))))
(when (not (v2minusp-or (v2- rd lu)))
(make-box-pts :lu lu :rd rd))))))
(declaim (ftype (function (v2 box) v2) box-point-diversion))
(defun box-point-diversion (p box)
(declare (type v2 p) (type box box))
(labels ((div-val (val min span)
(cond ((< val min) (- val min))
((>= val (+ min span)) (- val min span -1))
(t 0))))
(v2 (div-val (car p) (box-x box) (box-w box))
(div-val (cdr p) (box-y box) (box-h box)))))
;; could benefit from an in-place looping construct
(defmacro do-v2v2 ((pt from to &key (inc (list 'quote (v2 1 1)) incp)) &body
body)
(once-only (from to inc)
`(let ((,pt (v2zero)))
(loop :for y :from (cdr ,from) :below (cdr ,to) ,@(when incp `(:by (cdr
,inc)))
:do (loop :for x :from (car ,from) :below (car ,to) ,@(when incp
`(:by (car ,inc)))
:do
(setf (car ,pt) x (cdr ,pt) y)
,@body)))))
(defmacro do-box ((pt box &rest rest) &body body)
(once-only (box)
`(do-v2v2 (,pt (box-o ,box) (box-o+d ,box) ,@rest)
,@body)))
(defun array-box-set! (val box arr)
(declare (type double-float val) (type box box))
(do-box (pt box)
(setf (aref-v2 arr pt) val))
arr)
(defmacro do-box-intersection ((pt (&rest boxes) &rest rest) &body body)
`(do-box (,pt (box-intersect ,@boxes) ,@rest)
,@body))
>
> - Luke
regards, Samium Gromoff
_______________________________________________
application-builder mailing list
[email protected]
http://www.lispniks.com/mailman/listinfo/application-builder
