diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 376d5d9f..10fb63f8 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,60 +221,46 @@ 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 -> - 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)) - ) - | 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) + -- 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 = 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 | 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 instance (Metric v, OrderedField n, Real n) => HasArcLength (SegTree v n) where diff --git a/test/Diagrams/Test/Trail.hs b/test/Diagrams/Test/Trail.hs index f7cec773..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 @@ -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,66 @@ 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 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 + ] + +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)