Update of /project/cells/cvsroot/cells-gtk3/ph-maths In directory clnet:/tmp/cvs-serv5005/ph-maths Added Files: ph-maths.asd ph-maths.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.asd 2008/04/13 10:59:24 NONE +++ /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.asd 2008/04/13 10:59:24 1.1 (asdf:defsystem :ph-maths :name "ph-maths" :components ((:file "ph-maths"))) --- /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.lisp 2008/04/13 10:59:24 NONE +++ /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.lisp 2008/04/13 10:59:24 1.1 ;;; ;;; Linear algebra 2d (defpackage :ph-maths-2d (:use :cl) (:nicknames :2d) (:export :v :x :y :v+ :v- :v* :min-abs :max-abs :v-polar :r :phi :polar-coords :polar-radius :polar-angle :cartesian-coords :abs-angle :deg->rad :rad->deg :v0 :vp :p :<> :intersect-line-circle :distance-point-line :point-in-box-p :to-decimal :to-rgb :to-rgb-vector :~=)) (in-package :ph-maths-2d) (declaim (optimize (speed 1) (debug 3) (space 0))) (defun denil (lst) (loop for val in lst if val collect val)) ;;; represent 2d vector as cons (declaim (inline v x y)) (defun v (x y) (cons x y)) (defun x (v) (car v)) (defun y (v) (cdr v)) ;;; basic linear algebra (declaim (inline v-reduce v+ v- v*)) (defun v-reduce (fn vectors) (declare (function fn)) (reduce #'(lambda (v1 v2) (v (funcall fn (x v1) (x v2)) (funcall fn (y v1) (y v2)))) (denil vectors))) (defun v+ (&rest vectors) (v-reduce #'+ vectors)) (defun v- (&rest vectors) (v-reduce #'- vectors)) (defun v* (lambda vector) (v (* (x vector) lambda) (* (y vector) lambda))) ;;; min/max (declaim (inline abs-reduce min-abs max-abs)) (defun abs-reduce (fn vals) (reduce fn (denil vals) :key #'abs)) (defun min-abs (&rest vals) (abs-reduce #'min vals)) (defun max-abs (&rest vals) (abs-reduce #'max vals)) ; polar coordinates (declaim (inline v-polar phi r polar-radius polar-angle polar-coords)) (defun v-polar (phi r) (cons phi r)) (defun phi (v) (car v)) (defun r (v) (cdr v)) (defun polar-radius (v) "return radius of cartesian vector v" (sqrt (+ (* (x v) (x v)) (* (y v) (y v))))) (defun polar-angle (v) "return angle of cartesian vector v" (if (zerop (x v)) (if (>= (y v) 0) #.(* pi -0.5) #.(* pi 0.5)) (atan (- (y v)) (x v)))) (defun polar-coords (v) "return a polar representation of cartesian vector v" (v-polar (polar-angle v) (polar-radius v))) ; cartesian coords (declaim (inline cartesian-coords)) (defun cartesian-coords (v-polar) "returns a cartesian representation of polar vector v-polar" (v (* (r v-polar) (cos (phi v-polar))) (* -1 (r v-polar) (sin (phi v-polar))))) ; degrees (declaim (inline deg->rad rad->deg abs-angle)) (defun deg->rad (degs) (/ (* degs pi) 180.0)) (defun rad->deg (rads) (* (/ rads pi) 180.0)) (defun abs-angle (phi) "returns a positive angle 0 <= phi <= 2pi" (cond ((or (= phi #.(* 2 pi)) (= phi #.(* -2 pi))) phi) (t (mod phi #.(* 2 pi))))) ; albegra -- 2d (declaim (inline v0 vp <> p)) (defun v0 (v) "returns a vector with the same direction as v and unit length" (let ((r (polar-radius v))) (if (plusp r) (v* (/ 1 r) v) (v 0 0)))) (defun vp (v) "returns a unit vector perpendicular to v" (let ((u (v0 v))) (v (- (y u)) (x u)))) (defun <> (v1 v2) "returns the scalar product <v1, v2>" (+ (* (x v1) (x v2)) (* (y v1) (y v2)))) (defun p (v1 v2) "returns the projection of v1 onto v2. Second return value is the length of the projection." (let* ((v2_0 (v0 v2)) (len (<> v2_0 v1))) (values (v* len v2_0) len))) (declaim (inline distance-point-line intersect-line-circle point-in-box-p)) (defun distance-point-line (point p1 p2) "returns the shortest distance from point to the line p1,p2." (abs (second (multiple-value-list (p (v- p1 point) (vp (v- p2 p1))))))) (defun intersect-line-circle (p1 p2 r) "returns the intersection of a line through p1 and p2 and a circle around p2 with radius r" (v+ p2 (v* r (v0 (v- p1 p2))))) (defun point-in-box-p (p p1 p2 &key (tol 0)) "returns true if p is inside the box given by p1,p2" (and (< (- (min (x p1) (x p2)) tol) (x p) (+ (max (x p1) (x p2)) tol)) (< (- (min (y p1) (y p2)) tol) (y p) (+ (max (y p1) (y p2)) tol)))) ;; base conversion (defun to-decimal (val &key (base 16)) "converts val (a value in base base as a string) to an integer" (loop for p from 0 to (1- (length val)) for x downfrom (1- (length val)) summing (* (let ((c (char-code (char val p)))) (cond ((< 47 c 58) (- c 48)) ((< 64 c 91) (- c 55)) ((< 96 c 123) (- c 87)) (t (warn "Illegal character in hex argument to to-decimal") 0))) (expt base x)))) (defun to-rgb (html-color) "parses an html color code like #A204B2 to '(.8 .01 .7 4)" (loop for val from 0 to 2 for pos = (1+ (* val 2)) collecting (/ (to-decimal (subseq html-color pos (+ pos 2))) 256))) (defun to-rgb-vector (html-color) "parses an html color code like #A204B2 to #(.8 .01 .7 4)" (coerce (loop for val from 0 to 2 for pos = (1+ (* val 2)) collecting (/ (to-decimal (subseq html-color pos (+ pos 2))) 256)) 'vector)) ; fuzzy comparison (defun ~= (&rest params) (if (cdr params) (let ((max (apply #'max params)) (min (apply #'min params))) (> .05 (abs (/ (- max min) (max (abs max) (abs min) 1d-8))))) t))