content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE TypeFamilies     #-}
  
  module Diagrams.Test.Trail where
  
  import           Diagrams.Prelude
  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)
          wrap = (`at` origin) . wrapLine
      in
      testProperty "unfixTrail . fixTrail == id for lines" $
      \l -> (unfixTrail . fixTrail $ wrap l) =~ (wrap l)
  
    , testProperty "glueLine . cutLoop == id" $
      \loop -> (glueLine . cutLoop $ loop) =~ (loop :: Trail' Loop V2 Double)
  
    , testProperty "trailOffset == sumV . trailOffsets" $
      \t -> trailOffset t =~ (sumV . trailOffsets $ (t :: Trail V2 Double))
  
    , testProperty "reverseTrail . reverseTrail == id" $
      \t -> (reverseTrail . reverseTrail $ t) =~ (t :: Trail V2 Double)
  
    , testProperty "reverseLocTrail . reverseLocTrail == id" $
      \t -> (reverseLocTrail . reverseLocTrail $ t) =~
            (t :: Located (Trail V2 Double))
  
    , testProperty "reverseLine . reverseLine == id" $
      \t -> (reverseLine . reverseLine $ t) =~
            (t :: Trail' Line V2 Double)
  
    , testProperty "reverseLocLine . reverseLocLine == id" $
      \t -> (reverseLocLine . reverseLocLine $ t) =~
            (t :: Located (Trail' Line V2 Double))
  
    , testProperty "reverseLoop . reverseLoop == id" $
      \t -> (reverseLoop . reverseLoop $ t) =~
            (t :: Trail' Loop V2 Double)
  
    , testProperty "reverseLocLoop . reverseLocLoop == id" $
      \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 :: Word) > 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 k1 k2
    | null segs = t == t'
    | otherwise = aSecT =~ aSecFS && bSecT =~ bSecFS
    where
      a = min k1 k2
      b = max k1 k2
      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
  