module SuthHodgClip (clipTo) where

import Data.List

type   Pt a = (a, a)
type   Ln a = (Pt a, Pt a)
type Poly a = [Pt a]


polyFrom ps = last ps: ps


linesFrom pps@(_:ps) = zip pps ps



(.|) :: (Num a, Ord a) => Pt a -> Ln a -> Bool
(x,y) .| ((px,py),(qx,qy)) = (qx-px)*(y-py) >= (qy-py)*(x-px)


(><) :: Fractional a => Ln a -> Ln a -> Pt a
((x1,y1),(x2,y2)) >< ((x3,y3),(x4,y4)) =
    let (r,s) = (x1*y2-y1*x2, x3*y4-y3*x4)
        (t,u,v,w) = (x1-x2, y3-y4, y1-y2, x3-x4)
        d = t*u-v*w 
    in ((r*w-t*s)/d, (r*u-v*s)/d)





(-|) :: (Fractional a, Ord a) => Ln a -> Ln a -> [Pt a]
ln@(p0, p1) -| clipLn =
    case (p0 .| clipLn, p1 .| clipLn) of
      (False, False) -> []
      (False, True)  -> [isect, p1]
      (True,  False) -> [isect]
      (True,  True)  -> [p1]
    where isect = ln >< clipLn


(<|) :: (Fractional a, Ord a) => Poly a -> Ln a -> Poly a
poly <| clipLn = polyFrom $ concatMap (-| clipLn) (linesFrom poly)



clipTo :: (Fractional a, Ord a) => [Pt a] -> [Pt a] -> [Pt a]
targPts `clipTo` clipPts = 
    let targPoly = polyFrom targPts
        clipLines = linesFrom (polyFrom clipPts)
    in foldl' (<|) targPoly clipLines