;;; -*- Mode: Lisp; Package: DESIGN; Syntax: Ansi-common-lisp -*-

;;; clips the line-segment (x0,y0)--(x1,y1)
;;; to the rectangular area x- <= x <= x+, y- <= y <= y+
;;; returns coords of new end-points, or nil if completely clipped away
;;; courtesy of JGA

(defun clipper (x0 y0 x1 y1 x- x+ y- y+)
  (macrolet ((clipper-bound (value lower upper)
               `(cond ((< ,value ,lower) :below)
                      ((> ,value ,upper) :above)))
             (clipper-linterp (u0 v0 u1 v1 u)
               `(/ (+ (* (- ,u1 ,u) ,v0) (* (- ,u ,u0) ,v1)) (- ,u1 ,u0)))
             (all-gone ()
               `(return-from clipper (values nil nil nil nil))))
    (let ((bx0 (clipper-bound x0 x- x+))
          (by0 (clipper-bound y0 y- y+)) 
          (bx1 (clipper-bound x1 x- x+))
          (by1 (clipper-bound y1 y- y+)))
      (when (or (and bx0 (eql bx0 bx1))
                (and by0 (eql by0 by1)))
        (all-gone))
      (let ((cy0 by0) (cy1 by1))
        (when bx0
          (cond ((eql bx0 :below)
                 (setq y0 (clipper-linterp x0 y0 x1 y1 x-) x0 x-))
                (T ; (eql bx0 :above)
                 (setq y0 (clipper-linterp x0 y0 x1 y1 x+) x0 x+)))
          (setq cy0 (clipper-bound y0 y- y+))
          (when (and cy0 (eql cy0 cy1)) (all-gone)))
        (when bx1
          (cond ((eql bx1 :below)
                 (setq y1 (clipper-linterp x0 y0 x1 y1 x-) x1 x-))
                (T ; (eql bx0 :above)
                 (setq y1 (clipper-linterp x0 y0 x1 y1 x+) x1 x+)))
          (setq cy1 (clipper-bound y1 y- y+))
          (when (and cy1 (eql cy0 cy1)) (all-gone)))
        (when cy0
          (cond ((eql cy0 :below)
                 (setq x0 (clipper-linterp y0 x0 y1 x1 y-) y0 y-))
                (T ; (eql cy0 :above)
                 (setq x0 (clipper-linterp y0 x0 y1 x1 y+) y0 y+))))
        (when cy1
          (cond ((eql cy1 :below)
                 (setq x1 (clipper-linterp y0 x0 y1 x1 y-) y1 y-))
                (T ; (eql cy1 :above)
                 (setq x1 (clipper-linterp y0 x0 y1 x1 y+) y1 y+))))
        (values y0 x0 y1 x1)))))



;;; The segments are (x1,y1)->(x2,y2) and (x3,y3)->(x4,y4) ,
;;; the values returned are (x,y) of intersection point and 
;;; p and q which are the fractional lengths along the segments
;;; where the intersection is; as usual NIL is returned when no
;;; intersection. 

(defun edge-intersection (x1y1 x2y2 x3y3 x4y4)
  ;; args are points
  (edge-intersection* (point-x x1y1) (point-y x1y1)
			     (point-x x2y2) (point-y x2y2)
			     (point-x x3y3) (point-y x3y3)
			     (point-x x4y4) (point-y x4y4)))

(defun edge-intersection* (x1 y1 x2 y2 x3 y3 x4 y4)
  (declare (values x y p q))
  (let* ((dx-12 (- x2 x1)) (dy-12 (- y2 y1))
         (dx-34 (- x4 x3)) (dy-34 (- y4 y3))
         (dd (- (* dx-34 dy-12) (* dx-12 dy-34))))
    (when (not (zerop dd))
      (let* ((dx-13 (- x3 x1))
             (dy-13 (- y3 y1))
             (p (/ (- (* dx-34 dy-13) (* dx-13 dy-34)) dd))
             (q (/ (- (* dx-12 dy-13) (* dx-13 dy-12)) dd)))
        (when (and (>= p 0.0) (<= p 1.0) (>= q 0.0) (<= q 1.0))
          (values (+ x1 (* p dx-12))
                  (+ y1 (* p dy-12))
                  p
                  q))))))