module Graphics.SVGFonts.TriangulationUtils where import Maybe ( isJust, fromJust ) type P2 a = (a,a,Int) type Angle a = (P2 a, P2 a, P2 a) data (Num a) => Line a = Segment { point1, point2 :: P2 a } | Ray { point1, point2 :: P2 a } | Line { point1, point2 :: P2 a } angles :: [a] -> [(a,a,a)] angles xs = zip3 (rotateR xs) xs (rotateL xs) isRightTurnOrOn m x p = (area2 m x p) <= 0 isLeftTurn m x p = (area2 m x p) > 0 area2 (x2,y2,_) (x0,y0,_) (x1,y1,_) = (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0) containsBNV (Triangle (s,t,v)) p = (a==b && b==c) where a = isLeftTurn s t p b = isLeftTurn t v p c = isLeftTurn v s p data Orientation = Collinear | Clockwise | CounterClockwise deriving (Eq, Show) orientation :: (Num a, Ord a) => P2 a -> P2 a -> P2 a -> Orientation orientation p q r | s>0 = CounterClockwise -- to the left | s==0 = Collinear | s<0 = Clockwise -- to the right where s = area2 p q r angle2 :: (Floating a, Ord a) => P2 a -> P2 a -> a angle2 x y | denum == 0 = 0 | cosPhi >= 1.0 = 0 | cosPhi <= -1.0 = pi | cross2 x y >= 0 = acos cosPhi | otherwise = - acos cosPhi where denum = (x <.> x) * (y <.> y) cosPhi = (x <.> y) / sqrt denum (x0,y0,i) <.> (x1,y1,b) = x0*y0 + x1*y1 cross2 :: Num a => P2 a -> P2 a -> a (x0,y0,a) `cross2` (x1,y1,b) = x0*y1 - x1*y0 rotateL xs = tail xs ++ [head xs] rotateR xs = [last xs] ++ init xs add (ax,ay,i) (bx,by,_) = (ax+bx,ay+by,i) sub (ax,ay,i) (bx,by,_) = (ax-bx,ay-by,i) sel3_1 (x,y,z) = x sel3_2 (x,y,z) = y sel3_3 (x,y,z) = z uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) uncurry3 f p = f (sel3_1 p) (sel3_2 p) (sel3_3 p) sublist, sublist2, takeDrop :: Eq a => a -> a -> [a] -> [a] sublist i j xs = takeDrop i j xs ++ [j] sublist2 i j xs = case takeDrop i j xs of { [] -> []; ys -> tail ys } takeDrop i j xs = takeWhile (/=j) (dropWhile (/=i) (xs++xs)) rotate :: (Floating a, Ord a) => P2 a -> P2 a -> a -> P2 a rotate p o phi = o `add` (rotateOrg (p `sub` o) phi) rotateOrg :: (Floating a, Ord a) => P2 a -> a -> P2 a rotateOrg (x,y,i) phi = (x*cos phi - y*sin phi, x*sin phi + y*cos phi,i) angleWrt, angle3 :: (Floating a, Ord a) => P2 a -> P2 a -> P2 a -> a angleWrt p q r = angle2 (q `sub` p) (r `sub` p) angle3 p q r = (-1) * angle2 (p `sub` q) (r `sub` q) choose1, choose2 :: Rel a -> (a -> a -> a) choose1 rel x y = if x `rel` y then x else y choose2 rel x y = if x `rel` y then y else x minimumBy, maximumBy :: Rel a -> [a] -> a minimumBy rel = foldl1 (\ x y -> if x `rel` y then x else y) -- minimumBy = foldl1 . choose1 maximumBy = foldl1 . choose2 extremaBy :: Rel a -> [a] -> [a] extremaBy cmp [] = [] extremaBy cmp [x] = [x] extremaBy cmp xs@(_:_:_) = [minimumBy cmp xs, maximumBy cmp xs] type Rel a = a -> a -> Bool data With a b = a :& b sat :: With a b -> b sat (a :& b) = b liftToWith :: (a -> b -> c) -> With a d -> With b e -> c liftToWith r (a :& _) (b :& _) = a `r` b instance Eq a => Eq (With a b) where (==) = liftToWith (==) instance Ord a => Ord (With a b) where compare = liftToWith compare minimumWith, maximumWith :: Ord b => (a -> b) -> [a] -> a minimumWith f xs = sat (minimum [f x :& x | x<-xs]) maximumWith f xs = sat (maximum [f x :& x | x<-xs]) minima, maxima :: Ord a => [a] -> [a] minima = minimaBy compare maxima = maximaBy compare minimaBy, maximaBy :: (a -> a -> Ordering) -> [a] -> [a] minimaBy cmp (x:xs) = foldl f [x] xs where f ms@(h:_) b = case cmp b h of LT -> [b] EQ -> b:ms GT -> ms maximaBy cmp (x:xs) = foldl f [x] xs where f ms@(h:_) b = case cmp b h of GT -> [b] EQ -> b:ms LT -> ms minimaWith, maximaWith :: Ord b => (a -> b) -> [a] -> [a] minimaWith f xs = map sat (minima [f x :& x | x<-xs]) maximaWith f xs = map sat (maxima [f x :& x | x<-xs]) minimaWithBy, maximaWithBy :: (a -> a -> Ordering) -> (b -> a) -> [b] -> [b] minimaWithBy cmp f xs = map sat (minimaBy (liftToWith cmp) [f x :& x | x<-xs]) maximaWithBy cmp f xs = map sat (maximaBy (liftToWith cmp) [f x :& x | x<-xs]) sqrDistance (x0,y0,_) (x1,y1,_) = r <.> r where r = (x0-x1,y0-y1,0) edges :: [a] -> [(a,a)] edges xs = zip xs (rotateL xs) intersect, strictIntersect :: (Ord a, Fractional a) => Line a -> Line a -> Maybe (P2 a) doIntersect,doStrictIntersect :: (Ord a, Fractional a) => Line a -> Line a -> Bool intersect s1 s2 | isJust res && ok s1 r && ok s2 s = Just i | otherwise = Nothing where res = intersection s1 s2 (i,r,s) = fromJust res ok (Segment _ _) r = 0<=r && r<=1 ok (Ray _ _) r = r>=0 ok (Line _ _) r = True {- intersect = interAux paramOk where paramOk (Segment _ _) r = 0<=r && r<=1 paramOk (Ray _ _) r = r>=0 paramOk (Line _ _) r = True -} doIntersect s t = isJust (intersect s t) strictIntersect = interAux paramOk where paramOk (Segment _ _) r = 00 paramOk (Line _ _) r = True doStrictIntersect s t = isJust (strictIntersect s t) interAux :: Fractional a => (Line a -> a -> Bool) -> Line a -> Line a -> Maybe (P2 a) interAux ok s1 s2 = if isJust res && ok s1 r && ok s2 s then Just i else Nothing where res = intersection s1 s2 (i,r,s) = fromJust res k <*> p = mapP (k*) p mapP f (x,y,i) = (f x, f y, i) intersection :: Fractional a => Line a -> Line a -> Maybe (P2 a,a,a) intersection s1 s2 | denom == 0 = Nothing | otherwise = Just (i, r, s) where (xa,ya,_) = point1 s1 (xb,yb,_) = point2 s1 (xc,yc,_) = point1 s2 (xd,yd,_) = point2 s2 denom = (xb-xa)*(yd-yc)-(yb-ya)*(xd-xc) r = ((ya-yc)*(xd-xc)-(xa-xc)*(yd-yc)) / denom s = ((ya-yc)*(xb-xa)-(xa-xc)*(yb-ya)) / denom -- i = Point2 (xa + r*(xb-xa), ya + r*(yb-ya)) i = (xa+r*xb-xa, ya+r*yb-ya,0) splitWhile :: (a -> Bool) -> [a] -> ([a], [a]) splitWhile p xs = split xs [] where split [] ls = (reverse ls, []) split ys@(x:xs) ls = if p x then split xs (x:ls) else (reverse ls, ys) newtype (Num a) => Triangle a = Triangle (P2 a, P2 a, P2 a) -- vertices :: (Num a) => Triangle (P2 a, P2 a, P2 a) -> [P2 a] vertices (Triangle (p,q,r)) = [p,q,r] -- segments :: (Num a) => Triangle (P2 a, P2 a, P2 a) -> [Line a] segments (Triangle (p,q,r)) = [Segment p q, Segment q r, Segment r p] -- area :: Fractional a => Triangle (P2 a, P2 a, P2 a) -> a area (Triangle (p,q,r)) = 0.5 * area2 p q r -- contains :: (Num a, Ord a) => Triangle (P2 a, P2 a, P2 a) -> P2 a -> Bool contains tri@(Triangle (s,t,v)) p = containsBNV tri p || p==s || p==t || p==v -- inInteriourOf :: (Num a, Ord a) => P2 a -> Triangle (P2 a, P2 a, P2 a) -> Bool inInteriourOf p tri = checkBy test tri p where test Collinear b c = False test a Collinear c = False test a b Collinear = False test a b c = a==b && b==c type Rel3 a = a -> a -> a -> Bool -- checkBy :: (Num a, Ord a) => Rel3 Orientation -> Triangle (P2 a, P2 a, P2 a) -> P2 a -> Bool checkBy chk (Triangle (s,t,v)) p = chk a b c where a = orientation s t p b = orientation t v p c = orientation v s p