diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,9 @@ +1.4.4 (12 Nov 2019) +------------------- + +- Updated to build on GHC 8.8 +- New module `Diagrams.TwoD.Path.IntersectionExtras` + 1.4.3 (14 May 2018) ------------------- diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -9,3 +9,4 @@ Dominic Steinitz Ryan Yates Brent Yorgey +Mike Zuser diff --git a/diagrams-contrib.cabal b/diagrams-contrib.cabal --- a/diagrams-contrib.cabal +++ b/diagrams-contrib.cabal @@ -1,5 +1,5 @@ name: diagrams-contrib -version: 1.4.3 +version: 1.4.4 synopsis: Collection of user contributions to diagrams EDSL description: A collection of user contributions for diagrams, an embedded domain-specific language for generation @@ -15,7 +15,7 @@ cabal-version: 1.18 extra-source-files: README.markdown, CHANGES.markdown, diagrams/*.svg, CONTRIBUTORS extra-doc-files: diagrams/*.svg -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2 +tested-with: GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.3 || ==8.6.5 || ==8.8.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-contrib.git @@ -40,6 +40,7 @@ Diagrams.TwoD.Path.Boolean, Diagrams.TwoD.Path.Calligraphic, Diagrams.TwoD.Path.Follow, + Diagrams.TwoD.Path.IntersectionExtras Diagrams.TwoD.Path.IteratedSubset, Diagrams.TwoD.Path.LSystem, Diagrams.TwoD.Path.Turtle, @@ -50,10 +51,10 @@ Diagrams.TwoD.Path.Metafont.Internal Diagrams.TwoD.Path.Metafont.Combinators Diagrams.TwoD.Path.Metafont.Parser - build-depends: base >= 4.2 && < 4.12, + build-depends: base >= 4.8 && < 4.14, mtl >= 2.0 && < 2.3, mtl-compat >= 0.2.1 && < 0.3, - containers > 0.4 && < 0.6, + containers > 0.4 && < 0.7, split >= 0.2.1 && < 0.3, colour >= 2.3.1 && < 2.4, split >= 0.2.1 && < 0.3, @@ -61,7 +62,7 @@ diagrams-core >= 1.4 && < 1.5, diagrams-lib >= 1.4 && < 1.5, diagrams-solve >= 0.1 && < 0.2, - lens >= 4.0 && < 4.17, + lens >= 4.0 && < 4.19, linear >= 1.11.3 && < 1.21, force-layout >= 0.4 && < 0.5, data-default >= 0.5.2 && < 0.8, @@ -71,9 +72,9 @@ parsec >= 3.1 && < 3.2, text >= 0.11 && < 1.3, data-default-class < 0.2, - semigroups >= 0.3.4 && < 0.19, + semigroups >= 0.3.4 && < 0.20, cubicbezier >= 0.6 && < 0.7, - hashable >= 0.1.2 && < 1.3, + hashable >= 0.1.2 && < 1.4, mfsolve >= 0.3 && < 0.4 hs-source-dirs: src default-language: Haskell2010 @@ -88,8 +89,8 @@ Diagrams.TwoD.Path.Turtle.Internal build-depends: HUnit >= 1.2 && < 1.7, - QuickCheck >= 2.4 && < 2.12, - containers >= 0.3 && < 0.6, + QuickCheck >= 2.4 && < 2.14, + containers >= 0.3 && < 0.7, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4, diff --git a/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_cutByEx.svg b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_cutByEx.svg new file mode 100644 Binary files /dev/null and b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_cutByEx.svg differ diff --git a/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeBothEx.svg b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeBothEx.svg new file mode 100644 Binary files /dev/null and b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeBothEx.svg differ diff --git a/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeIntersectionsEx.svg b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeIntersectionsEx.svg new file mode 100644 Binary files /dev/null and b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeIntersectionsEx.svg differ diff --git a/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeSegmentsEx.svg b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeSegmentsEx.svg new file mode 100644 Binary files /dev/null and b/diagrams/src_Diagrams_TwoD_Path_IntersectionExtras_explodeSegmentsEx.svg differ diff --git a/src/Diagrams/TwoD/Path/IntersectionExtras.hs b/src/Diagrams/TwoD/Path/IntersectionExtras.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Path/IntersectionExtras.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Path.IntersectionExtras +-- Copyright : (c) 2018 Mike Zuser +-- License : BSD-style (see LICENSE) +-- Maintainer : Mike Zuser +-- +-- Extra functions for working with the intersections of `Path`s. This +-- module was motivated by `explodeIntersections`. The rest of the module is +-- either functions that where needed to build it or functions to help +-- consume it. +----------------------------------------------------------------------------- +module Diagrams.TwoD.Path.IntersectionExtras + ( -- * Intersection Parameters + intersectParams, intersectParams' + , intersectParamsP, intersectParamsP' + , intersectParamsT, intersectParamsT' + , intersectParamsTS, intersectParamsTS' + -- * Cutting Paths and Trails + , cutBy, cutBy' + , cutPBy, cutPBy' + , cutTBy, cutTBy' + -- * Rad Explosions + , explodeSegments + , explodeIntersections, explodeIntersections' + , explodeBoth, explodeBoth' + -- * Consuming Cut Paths + , OnSections(..) + ) where +import Data.List + +import Diagrams.Prelude +import Diagrams.TwoD.Segment + +-- defEps uses the value from Diagrams.TwoD.Path +defEps :: Fractional n => n +defEps = 1e-8 + +----------------------------------------------------------------------------- +-- Intersection Parameters -------------------------------------------------- +----------------------------------------------------------------------------- + +-- | Find the intersect parameters for each component trail of two pathlike +-- objects when the objects are intersected, returning a seperate list for +-- each trail. +intersectParams :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) => + t -> s -> ([[n]], [[n]]) +intersectParams = intersectParams' defEps + +-- | `intersectParams` using the given tolerance. +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) + +-- | Find the intersect parameters for each component trail of two +-- paths when the paths are intersected, returning a seperate list for +-- each trail. +intersectParamsP :: OrderedField n => Path V2 n -> Path V2 n -> ([[n]], [[n]]) +intersectParamsP = intersectParamsP' defEps + +-- | `intersectParamsP` using the given tolerance. +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) + +-- | Find the intersect parameters between two located trails. +intersectParamsT :: OrderedField n => + Located (Trail V2 n) -> Located (Trail V2 n) -> ([n], [n]) +intersectParamsT = intersectParamsT' defEps + +-- | `intersectParamsT` using the given tolerance. +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 + +-- | Find the intersect parameters for each component segment of two +-- located trails when the trails are intersected, returning a +-- list for each trail containing a list of intersections for +-- each segemnt of that trail. +intersectParamsTS :: OrderedField n => + Located (Trail V2 n) -> Located (Trail V2 n) -> ([[n]], [[n]]) +intersectParamsTS = intersectParamsTS' defEps + +-- | `intersectParamsTS` using the given tolerance. +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) + +----------------------------------------------------------------------------- +-- Cutting Paths and Trails ------------------------------------------------- +----------------------------------------------------------------------------- + +-- | Seperate a pathlike object into sections at every point it intersects +-- a second pathlike object, returning a list of sections for each component +-- trail. +-- +-- <> +-- +-- > cutByEx = onSections (squares `cutBy` line) colorLines +-- > <> stroke line +-- > where +-- > squares, line :: Path V2 Double +-- > squares = square 1 +-- > <> square 1 # rotate (1/8 @@ turn) +-- > line = hrule 2 +-- > colorLines = map (map lc) +-- > [ [ red, orange] +-- > , [blue, purple] ] +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` using the given tolerance for calculating intersections. +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) + +-- | Seperate a path into sections at every point it intersects a second path, +-- returning a list of sections for each component trail. +cutPBy :: (OrderedField n, Real n) => Path V2 n -> Path V2 n -> [[Located (Trail V2 n)]] +cutPBy = cutPBy' defEps + +-- | `cutPBy` using the given tolerance for calculating intersections. +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) + +-- | Seperate a located trail into sections at every point it intersects a path. +cutTBy :: (OrderedField n, Real n) => Located (Trail V2 n) -> Path V2 n -> [Located (Trail V2 n)] +cutTBy = cutTBy' defEps + +-- | `cutTBy` using the given tolerance for calculating intersections. +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) + +----------------------------------------------------------------------------- +-- Rad Explosions ----------------------------------------------------------- +----------------------------------------------------------------------------- + +-- | explodePath specialized to return located trails. This provides the compiler +-- the necessary type information to use it with `onSections` without providing +-- a type annotation. +-- +-- <> +-- +-- > explodeSegmentsEx = onSections (explodeSegments squares) colorLines +-- > where +-- > squares = square 1 +-- > <> square 1 # rotate (1/8 @@ turn) +-- > colorLines = map (map lc) +-- > [ [ red, yellow, gold, orange] +-- > , [blue, violet, purple, indigo] ] +explodeSegments :: (Metric v, OrderedField n) => Path v n -> [[Located (Trail v n)]] +explodeSegments = explodePath + +-- | Turn a path a list of component trails, then cut those segments at all +-- their intersections. +-- +-- <> +-- +-- > explodeIntersectionsEx = onSections (explodeIntersections squares) colorLines +-- > where +-- > squares = square 1 +-- > <> square 1 # rotate (1/8 @@ turn) +-- > colorLines = map (map lc) +-- > [ [ gray, red, orange, yellow, green, blue, indigo, violet] +-- > , [black, crimson, darkorange, gold, darkgreen, darkblue, midnightblue, darkviolet] ] +explodeIntersections :: (OrderedField n, Real n) => Path V2 n -> [[Located (Trail V2 n)]] +explodeIntersections = explodeIntersections' defEps + +-- | `explodeIntersections` using the given tolerance for calculating intersections. +explodeIntersections' :: (OrderedField n, Real n) => n -> Path V2 n -> [[Located (Trail V2 n)]] +explodeIntersections' eps path = cutBy' eps path path + +-- | Turn a path into a list of component segments for each component trail, +-- then cut those segments at all their intersections. +-- +-- <> +-- +-- > explodeBothEx = onSections (explodeBoth squares) colorLines +-- > where +-- > squares = square 1 +-- > <> square 1 # rotate (1/8 @@ turn) +-- > colorLines = map (map (map lc)) +-- > [ cycle [ [ gray, red, orange], [yellow, green, blue] ] +-- > , cycle [ [black, crimson, darkorange], [ gold, darkgreen, darkblue] ] ] +explodeBoth :: (OrderedField n, Real n) => Path V2 n -> [[[Located (Trail V2 n)]]] +explodeBoth = explodeBoth' defEps + +-- | `explodeBoth` using the given tolerance for calculating intersections. +explodeBoth' :: (OrderedField n, Real n) => n -> Path V2 n -> [[[Located (Trail V2 n)]]] +explodeBoth' eps path = map (map (flip (cutTBy' eps) path)) $ explodePath path + +----------------------------------------------------------------------------- +-- Consuming Cut Paths ----------------------------------------------------- +----------------------------------------------------------------------------- +class OnSections ps fs b n | ps b -> fs n, fs -> b n where + -- | Zipply apply an arbitrarily nested list of attributes to the same shape + -- of lists of pathlike objects, monoidally combining the results. + -- + -- See examples for `cutBy`, `explodeSegments`, `explodeIntersections`, and `explodeBoth`. + onSections :: ps -> fs -> QDiagram b V2 n Any + +-- Need to list out the instances rather than using overlaping instances +-- with ToPath in order to use the fundep (ps b -> fs). + +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