{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Diagrams.TwoD.Path.IntersectionExtras
(
intersectParams, intersectParams'
, intersectParamsP, intersectParamsP'
, intersectParamsT, intersectParamsT'
, intersectParamsTS, intersectParamsTS'
, cutBy, cutBy'
, cutPBy, cutPBy'
, cutTBy, cutTBy'
, explodeSegments
, explodeIntersections, explodeIntersections'
, explodeBoth, explodeBoth'
, OnSections(..)
) where
import Data.List
import Diagrams.Prelude
import Diagrams.TwoD.Segment
defEps :: Fractional n => n
defEps = 1e-8
intersectParams :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) =>
t -> s -> ([[n]], [[n]])
intersectParams = intersectParams' defEps
intersectParams' :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) =>
n -> t -> s -> ([[n]], [[n]])
intersectParams' eps as bs = intersectParamsP' eps (toPath as) (toPath bs)
intersectParamsP :: OrderedField n => Path V2 n -> Path V2 n -> ([[n]], [[n]])
intersectParamsP = intersectParamsP' defEps
intersectParamsP' :: OrderedField n => n -> Path V2 n -> Path V2 n -> ([[n]], [[n]])
intersectParamsP' eps as bs = (ps, qs)
where
is = map (flip map (pathTrails bs) . intersectParamsT' eps) (pathTrails as)
ps = map (concat . map fst) is
qs = map (concat . map snd) (transpose is)
intersectParamsT :: OrderedField n =>
Located (Trail V2 n) -> Located (Trail V2 n) -> ([n], [n])
intersectParamsT = intersectParamsT' defEps
intersectParamsT' :: OrderedField n =>
n -> Located (Trail V2 n) -> Located (Trail V2 n) -> ([n], [n])
intersectParamsT' eps as bs = (reparam ps, reparam qs)
where
(ps, qs) = intersectParamsTS' eps as bs
reparam segs = concat $ zipWith f [(0::Int)..] segs
where f segNo = map $ \p -> (fromIntegral segNo + p) / genericLength segs
intersectParamsTS :: OrderedField n =>
Located (Trail V2 n) -> Located (Trail V2 n) -> ([[n]], [[n]])
intersectParamsTS = intersectParamsTS' defEps
intersectParamsTS' :: OrderedField n =>
n -> Located (Trail V2 n) -> Located (Trail V2 n) -> ([[n]], [[n]])
intersectParamsTS' eps as bs = (ps, qs)
where
(as', bs') = (as, bs) & both %~ (zip [0..] . fixTrail)
is = map (flip map bs' . isect) as'
isect (i, a) (j, b)
| a == b = []
| otherwise = filter (not . ends)
. map (\(p, q, _) -> (p, q))
$ segmentSegment eps a b
where
ends (p, q) = adjacent && min p q `near` 0 && max p q `near` 1
adjacent = as == bs && (abs (i - j) == 1 || min i j == 0 && max i j == length as' - 1)
near x n = abs (x - n) < eps
ps = map (map fst . concat) is
qs = map (map snd . concat) (transpose is)
cutBy :: (OrderedField n, Real n, InSpace V2 n t, SameSpace t s, ToPath t, ToPath s) =>
t -> s -> [[Located (Trail V2 n)]]
cutBy = cutBy' defEps
cutBy' :: (OrderedField n, Real n, InSpace V2 n t, SameSpace t s, ToPath t, ToPath s) =>
n -> t -> s -> [[Located (Trail V2 n)]]
cutBy' eps a b = cutPBy' eps (toPath a) (toPath b)
cutPBy :: (OrderedField n, Real n) => Path V2 n -> Path V2 n -> [[Located (Trail V2 n)]]
cutPBy = cutPBy' defEps
cutPBy' :: (OrderedField n, Real n) => n -> Path V2 n -> Path V2 n -> [[Located (Trail V2 n)]]
cutPBy' eps p1 p2 = map (flip (cutTBy' eps) p2) (pathTrails p1)
cutTBy :: (OrderedField n, Real n) => Located (Trail V2 n) -> Path V2 n -> [Located (Trail V2 n)]
cutTBy = cutTBy' defEps
cutTBy' :: (OrderedField n, Real n) => n -> Located (Trail V2 n) -> Path V2 n -> [Located (Trail V2 n)]
cutTBy' eps t p
| null isects = [t]
| null nearEnds && norm (start .-. end) < eps = gluedEnds
| otherwise = subsections
where
subsections = zipWith (section t) (0:isects) (isects++[1])
isects = sortAndAvoidEmpty notNearEnds
sortAndAvoidEmpty = map head . groupBy (\a b -> abs (a - b) < eps) . sort
(notNearEnds, nearEnds) = partition (\p -> (eps < p) && (p < 1-eps)) rawIsects
rawIsects = concatMap (fst . intersectParamsT' eps t) (pathTrails p)
start = head subsections `atParam` 0
end = last subsections `atParam` 1
gluedEnds = unfixTrail (fixTrail (last subsections) ++ fixTrail (head subsections))
: init (tail subsections)
explodeSegments :: (Metric v, OrderedField n) => Path v n -> [[Located (Trail v n)]]
explodeSegments = explodePath
explodeIntersections :: (OrderedField n, Real n) => Path V2 n -> [[Located (Trail V2 n)]]
explodeIntersections = explodeIntersections' defEps
explodeIntersections' :: (OrderedField n, Real n) => n -> Path V2 n -> [[Located (Trail V2 n)]]
explodeIntersections' eps path = cutBy' eps path path
explodeBoth :: (OrderedField n, Real n) => Path V2 n -> [[[Located (Trail V2 n)]]]
explodeBoth = explodeBoth' defEps
explodeBoth' :: (OrderedField n, Real n) => n -> Path V2 n -> [[[Located (Trail V2 n)]]]
explodeBoth' eps path = map (map (flip (cutTBy' eps) path)) $ explodePath path
class OnSections ps fs b n | ps b -> fs n, fs -> b n where
onSections :: ps -> fs -> QDiagram b V2 n Any
instance (TypeableFloat n, OnSections ps fs b n) =>
OnSections [ps] [fs] b n where
onSections ps fs = mconcat $ zipWith onSections ps fs
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (Path V2 n) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (Located (Trail V2 n)) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (Located (Trail' l V2 n)) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (Located [Segment Closed V2 n]) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (Located (Segment Closed V2 n)) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (Trail V2 n) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (Trail' l V2 n) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (FixedSegment V2 n) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs $ stroke ps
instance (TypeableFloat n, Renderable (Path V2 n) b) =>
OnSections (QDiagram b V2 n Any) (QDiagram b V2 n Any -> QDiagram b V2 n Any) b n where
onSections ps fs = fs ps