From 542a7580d5d2b897da430315bc1e8541b98b281e Mon Sep 17 00:00:00 2001 From: Mike Zuser Date: Mon, 11 Mar 2019 16:22:50 -0400 Subject: [PATCH 1/5] bug fix: #329 section on trail producing incorr... section on trail producing incorrect result when upper param is >= 1 (domainUpper) #329 The first parameter was not being rescaled properly in the case that the second parameter was >= 1. The old code tried to rescale as though an extra segment was added, while what the code actually does is replace the last segment with a longer one. This leads two two cases, either the first param is on a previous segment and doesn't need to change or it's on the last segment and has to be rescaled to the new length. --- src/Diagrams/Trail.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 376d5d9f..4df3e649 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -238,11 +238,14 @@ splitAtParam' tree@(SegTree t) p case FT.viewr t of EmptyR -> emptySplit t' FT.:> seg -> - case seg `splitAtParam` (1 - (1 - p)*tSegs) of - (seg1, seg2) -> - ( (SegTree $ t' |> seg1, \u -> u * tSegs / (tSegs + 1)) - , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p)) - ) + let f u | n < (tSegs - 1) = u + | otherwise = (n + u' / (1 + (p - 1)*tSegs)) / tSegs + where (n, u') = propFrac $ u * tSegs + in case seg `splitAtParam` (1 + (p - 1)*tSegs) of + (seg1, seg2) -> + ( (SegTree $ t' |> seg1 , f) + , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p)) + ) | otherwise = case FT.viewl after of EmptyL -> emptySplit From dcedd10f86075c411e8bc6d4993b2d46e322e87f Mon Sep 17 00:00:00 2001 From: Mike Zuser Date: Wed, 13 Mar 2019 16:52:13 -0400 Subject: [PATCH 2/5] refactor splitAtParam'. fix section x a b w/ a > b The three cases on p of splitAtParam' on close inspection only differed by what is now splitParam, so could be merged. In addition the new version avoids creating segments of length 0 when p is 0 or 1. I also decided to remove the dead code for creating the rescale function for the right segment. section previously did not handle the case where a > b. I have included it in this commit because it depends on the splitAtParam' which has changed signature. --- src/Diagrams/Trail.hs | 78 +++++++++++++++---------------------------- 1 file changed, 26 insertions(+), 52 deletions(-) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 4df3e649..8fabedf7 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -112,7 +112,7 @@ module Diagrams.Trail import Control.Arrow ((***)) import Control.Lens hiding (at, transform, (<|), (|>)) import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), - (<|), (|>)) + viewl, (<|), (|>)) import qualified Data.FingerTree as FT import Data.Fixed import qualified Data.Foldable as F @@ -221,63 +221,37 @@ instance Num n => DomainBounds (SegTree v n) instance (Metric v, OrderedField n, Real n) => EndValues (SegTree v n) -type SplitResult v n = ((SegTree v n, n -> n), (SegTree v n, n -> n)) - -splitAtParam' :: (Metric v, OrderedField n, Real n) => SegTree v n -> n -> SplitResult v n -splitAtParam' tree@(SegTree t) p - | p < 0 = - case FT.viewl t of - EmptyL -> emptySplit - seg FT.:< t' -> - case seg `splitAtParam` (p * tSegs) of - (seg1, seg2) -> - ( (SegTree $ FT.singleton seg1, (*p)) - , (SegTree $ seg2 <| t', \u -> 1 - (1 - u) * tSegs / (tSegs + 1)) - ) - | p >= 1 = - case FT.viewr t of - EmptyR -> emptySplit - t' FT.:> seg -> - let f u | n < (tSegs - 1) = u - | otherwise = (n + u' / (1 + (p - 1)*tSegs)) / tSegs - where (n, u') = propFrac $ u * tSegs - in case seg `splitAtParam` (1 + (p - 1)*tSegs) of - (seg1, seg2) -> - ( (SegTree $ t' |> seg1 , f) - , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p)) - ) - | otherwise = - case FT.viewl after of - EmptyL -> emptySplit - seg FT.:< after' -> - let (n, p') = propFrac $ p * tSegs - f p n u | u * tSegs < n = u * tSegs / (n + 1) - | otherwise = (n + (u * tSegs - n) / (p * tSegs - n)) / (n+1) - in case seg `splitAtParam` p' of - (seg1, seg2) -> - ( ( SegTree $ before |> seg1 , f p n ) - , ( SegTree $ seg2 <| after' - , \v -> 1 - f (1 - p) (tSegs - n - 1) (1 - v) - ) - ) - where - (before, after) = FT.split ((p * tSegs <) . numSegs) t - tSegs = numSegs t - emptySplit = let t' = (tree, id) in (t',t') - - propFrac x = let m = signum x * mod1 x in (x - m, m) +splitAtParam' :: (Metric v, OrderedField n, Real n) + => SegTree v n -> n -> ((SegTree v n, SegTree v n), n -> n) +splitAtParam' (SegTree t) p + | tSegs == 0 = ((mempty , mempty ), id) + | otherwise = ((SegTree treeL, SegTree treeR), rescale) + where + tSegs = numSegs t + splitParam q | q < 0 = (0 , q * tSegs) + | q >= 1 = (tSegs - 1, 1 + (q - 1) * tSegs) + | otherwise = propFrac $ q * tSegs + where propFrac x = let m = mod1 x in (x - m, m) + (pSegs, pParam) = splitParam p + (before, viewl -> seg FT.:< after) = FT.split ((pSegs <) . numSegs) t + (segL, segR) = seg `splitAtParam` pParam + (treeL, treeR) | pParam == 0 = (before , seg <| after) + | pParam == 1 = (before |> seg , after) + | otherwise = (before |> segL, segR <| after) + rescale u | pSegs == uSegs = (uSegs + uParam / pParam) / (pSegs + 1) + | otherwise = u * tSegs / (pSegs + 1) + where (uSegs, uParam) = splitParam u instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where - splitAtParam tree p = let ((a,_),(b,_)) = splitAtParam' tree p in (a,b) + splitAtParam tree p = fst $ splitAtParam' tree p reverseDomain (SegTree t) = SegTree $ FT.reverse t' where t' = FT.fmap' reverseSegment t - section x t1 t2 = let ((a,fa),_) = splitAtParam' x t2 - in snd $ splitAtParam a (fa t1) - - -- XXX seems like it should be possible to collapse some of the - -- above cases into one? + section x p1 p2 | p1 <= p2 = let ((a, _), rescale) = splitAtParam' x p2 + in snd $ splitAtParam a (rescale p1) + | otherwise = let (SegTree t) = section x p2 p1 + in SegTree . FT.reverse $ FT.fmap' reverseSegment t instance (Metric v, OrderedField n, Real n) => HasArcLength (SegTree v n) where From 729bd7b29f66788325be59587d778b507f90ece4 Mon Sep 17 00:00:00 2001 From: Mike Zuser Date: Wed, 20 Mar 2019 09:30:41 -0400 Subject: [PATCH 3/5] Add tests for section on Trail' Line - Test that the endpoints of the section match the original parameters. - Test that the first and last segments of the section match sectioning the first and last segements. --- test/Diagrams/Test/Trail.hs | 47 +++++++++++++++++++++++++++++++++++++ test/Instances.hs | 4 ++++ 2 files changed, 51 insertions(+) diff --git a/test/Diagrams/Test/Trail.hs b/test/Diagrams/Test/Trail.hs index f7cec773..6250d287 100644 --- a/test/Diagrams/Test/Trail.hs +++ b/test/Diagrams/Test/Trail.hs @@ -8,6 +8,9 @@ import Instances import Test.Tasty import Test.Tasty.QuickCheck +import Data.Fixed +import Data.List + tests :: TestTree tests = testGroup "Trail" [ let wrap :: Trail' Line V2 Double -> Located (Trail V2 Double) @@ -45,4 +48,48 @@ tests = testGroup "Trail" \t -> (reverseLocLoop . reverseLocLoop $ t) =~ (t :: Located (Trail' Loop V2 Double)) + , testProperty "section on Trail' Line endpoints match paramaters" $ + \t (Param a) (Param b) -> + let t' = section (t :: Located (Trail' Line V2 Double)) a b + in t `atParam` a =~ t' `atParam` 0 && + t `atParam` b =~ t' `atParam` 1 + + , testProperty "section on Trail' Line matches section on FixedSegment" $ + \t (Param a) (Param b) -> sectionTrailSectionFixedSegment t a b + ] + +data Param = Param Double deriving Show + +instance Arbitrary Param where + arbitrary = Param <$> choose (-0.5, 1.5) + +sectionTrailSectionFixedSegment :: Located (Trail' Line V2 Double) -> Double -> Double -> Bool +sectionTrailSectionFixedSegment t p1 p2 + | null segs = t == t' + | otherwise = aSecT =~ aSecFS && bSecT =~ bSecFS + where + a = min p1 p2 + b = max p1 p2 + t' = section t a b + + segs = fixTrail $ mapLoc wrapLine t + segs' = fixTrail $ mapLoc wrapLine t' + + aSecT = head segs' + bSecT = last segs' + + (aSegIx, a') = splitParam a + (bSegIx, b') = splitParam b + + aSecFS = section (segs !! floor aSegIx) a' x + where x = if aSegIx == bSegIx then b' else 1 + bSecFS = section (segs !! floor bSegIx) x b' + where x = if aSegIx == bSegIx then a' else 0 + + splitParam p | p < 0 = (0 , p * n) + | p >= 1 = (n - 1, 1 + (p - 1) * n) + | otherwise = propFrac $ p * n + where + propFrac x = let m = x `mod'` 1 in (x - m, m) + n = genericLength segs diff --git a/test/Instances.hs b/test/Instances.hs index a434b933..564e3f28 100644 --- a/test/Instances.hs +++ b/test/Instances.hs @@ -57,6 +57,10 @@ instance Approx n => Approx (Segment Closed V2 n) where -- The above is conservative: -- Cubic never equals Linear even if they describe the same points +instance Approx n => Approx (FixedSegment V2 n) where + FLinear a0 b0 =~ FLinear a1 b1 = a0 =~ a1 && b0 =~ b1 + FCubic a0 b0 c0 d0 =~ FCubic a1 b1 c1 d1 = a0 =~ a1 && b0 =~ b1 && c0 =~ c1 && d0 =~ d1 + instance Approx n => Approx (Trail' Line V2 n) where l0 =~ l1 = and $ zipWith (=~) (lineSegments l0) (lineSegments l1) From d40c12e0677c42034f4a6c720c99bf41ae22a738 Mon Sep 17 00:00:00 2001 From: Mike Zuser Date: Wed, 20 Mar 2019 09:45:15 -0400 Subject: [PATCH 4/5] clean up code in Sectionable instance of SegTree The fix for section t a b when a > b in dcedd10 reimplemented reverseDomain. Call reverseDomain instead. --- src/Diagrams/Trail.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 8fabedf7..ef655584 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -250,8 +250,7 @@ instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where section x p1 p2 | p1 <= p2 = let ((a, _), rescale) = splitAtParam' x p2 in snd $ splitAtParam a (rescale p1) - | otherwise = let (SegTree t) = section x p2 p1 - in SegTree . FT.reverse $ FT.fmap' reverseSegment t + | otherwise = reverseDomain $ section x p2 p1 instance (Metric v, OrderedField n, Real n) => HasArcLength (SegTree v n) where From 418b3b7859e8e65cb55ff66c7043b27e2960a331 Mon Sep 17 00:00:00 2001 From: Mike Zuser Date: Fri, 22 Mar 2019 20:09:30 -0400 Subject: [PATCH 5/5] Fix several errors in Sectionable of SegTree MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - section failed for p1 < 0 ∧ p2 = 0 because treeL was empty - fix div by zero when p2 is at the end of a segment - document the safety of the divisions in sectionAtParam' - fix error in rescale when p2 is at the end of a segment - add test cases for when ps are domain ends on relevent domains --- src/Diagrams/Trail.hs | 18 ++++++++++++++---- test/Diagrams/Test/Trail.hs | 26 ++++++++++++++++++++++---- 2 files changed, 36 insertions(+), 8 deletions(-) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index ef655584..10fb63f8 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -238,9 +238,18 @@ splitAtParam' (SegTree t) p (treeL, treeR) | pParam == 0 = (before , seg <| after) | pParam == 1 = (before |> seg , after) | otherwise = (before |> segL, segR <| after) - rescale u | pSegs == uSegs = (uSegs + uParam / pParam) / (pSegs + 1) - | otherwise = u * tSegs / (pSegs + 1) - where (uSegs, uParam) = splitParam u + -- section uses rescale to find the new value of p1 after the split at p2 + rescale u | pSegs' == uSegs = (uSegs + uParam / pParam' {-^1-}) / (pSegs' + 1) {-^2-} + | otherwise = u * tSegs / (pSegs' + 1) {-^3-} + where + -- param 0 on a segment is param 1 on the previous segment + (pSegs', pParam') | pParam == 0 = (pSegs-1, 1) + | otherwise = (pSegs , pParam) + (uSegs , uParam ) = splitParam u + -- ^1 (pParam ≠ 0 → pParam' = pParam) ∧ (pParam = 0 → pParam' = 1) → pParam' ≠ 0 + -- ^2 uSegs ≥ 0 ∧ pSegs' = uSegs → pSegs' ≥ 0 → pSegs' + 1 > 0 + -- ^3 pSegs' + 1 = 0 → pSegs' = -1 → pSegs = 0 ∧ pParam = 0 → p = 0 + -- → rescale is not called instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where splitAtParam tree p = fst $ splitAtParam' tree p @@ -248,7 +257,8 @@ instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where reverseDomain (SegTree t) = SegTree $ FT.reverse t' where t' = FT.fmap' reverseSegment t - section x p1 p2 | p1 <= p2 = let ((a, _), rescale) = splitAtParam' x p2 + section x p1 p2 | p2 == 0 = reverseDomain . fst $ splitAtParam x p1 + | p1 <= p2 = let ((a, _), rescale) = splitAtParam' x p2 in snd $ splitAtParam a (rescale p1) | otherwise = reverseDomain $ section x p2 p1 diff --git a/test/Diagrams/Test/Trail.hs b/test/Diagrams/Test/Trail.hs index 6250d287..3f4c1bff 100644 --- a/test/Diagrams/Test/Trail.hs +++ b/test/Diagrams/Test/Trail.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} - +{-# LANGUAGE TypeFamilies #-} module Diagrams.Test.Trail where @@ -50,9 +50,27 @@ tests = testGroup "Trail" , testProperty "section on Trail' Line endpoints match paramaters" $ \t (Param a) (Param b) -> - let t' = section (t :: Located (Trail' Line V2 Double)) a b - in t `atParam` a =~ t' `atParam` 0 && - t `atParam` b =~ t' `atParam` 1 + let s = section (t :: Located (Trail' Line V2 Double)) a b + in t `atParam` a =~ s `atParam` 0 && + t `atParam` b =~ s `atParam` 1 + + , testProperty "section on Trail' Line where a paramater is 0 or 1" $ + \t (Param a) -> + let l = section (t :: Located (Trail' Line V2 Double)) 0 a + r = section (t :: Located (Trail' Line V2 Double)) a 1 + in t `atParam` 0 =~ l `atParam` 0 && + t `atParam` a =~ l `atParam` 1 && + t `atParam` a =~ r `atParam` 0 && + t `atParam` 1 =~ r `atParam` 1 + + , testProperty "section on Trail' Line where a segment paramater is 0 or 1" $ + \t (Param a) i -> + let st = unLoc t # \(Line st) -> st :: SegTree V2 Double + b | numSegs st > 0 = (fromIntegral (i `mod` (numSegs st + 1) :: Word)) / numSegs st + | otherwise = 0 + s = section (t :: Located (Trail' Line V2 Double)) a b + in t `atParam` a =~ s `atParam` 0 && + t `atParam` b =~ s `atParam` 1 , testProperty "section on Trail' Line matches section on FixedSegment" $ \t (Param a) (Param b) -> sectionTrailSectionFixedSegment t a b