never executed always true always false

    1 module Reanimate.Math.EarClip
    2   ( earCut
    3   , earCut'
    4   , earClip
    5   , earClip'
    6   , isEarCorner
    7   ) where
    8 
    9 import           Data.List
   10 import qualified Data.Set                   as Set
   11 import           Data.Tuple
   12 
   13 import           Reanimate.Math.Common
   14 import           Reanimate.Math.Triangulate
   15 
   16 import qualified Data.Vector                as V
   17 import qualified Geometry.Earcut            as C
   18 import           Linear.V2
   19 
   20 -- import Debug.Trace
   21 
   22 earCut :: (Real a) => Ring a -> Triangulation
   23 earCut = last . earCut'
   24 
   25 earCut' :: (Real a) => Ring a -> [Triangulation]
   26 earCut' p =
   27   map (edgesToTriangulation (ringSize p)) $ inits $ nub
   28   [ if fst pair < snd pair then pair else swap pair
   29   | (a,b,c) <- V.toList (C.earcut lst)
   30   , pair <- [(a,b), (a,c), (b,c)]
   31   , fst pair /= (snd pair+1) `mod` ringSize p
   32   , fst pair /= (snd pair-1) `mod` ringSize p
   33   ]
   34   where
   35     lst = [ (x,y) | V2 x y <- V.toList $ V.map (fmap realToFrac) $ ringUnpack p ]
   36 
   37 -- Triangulation by ear clipping. O(n^2)
   38 earClip :: (Fractional a, Ord a, Epsilon a) => Ring a -> Triangulation
   39 earClip = last . earClip'
   40 
   41 earClip' :: (Fractional a, Ord a, Epsilon a) => Ring a -> [Triangulation]
   42 earClip' p = map (edgesToTriangulation $ ringSize p) $ inits $
   43   let ears = Set.fromList [ i
   44              | i <- elts
   45              , isEarCorner p elts (mod (i-1) n) i (mod (i+1) n) ]
   46   in worker ears (mkQueue elts)
   47   where
   48     n = ringSize p
   49     elts = [0 .. n-1]
   50     -- worker :: Set.Set Int -> PolyQueue Int -> [(P,P)]
   51     worker _ears queue | isSimpleQ queue = []
   52     worker ears queue
   53       | x `Set.member` ears =
   54         let dq = dropQ queue
   55             v0 = prevQ 1 queue
   56             v1 = prevQ 0 queue
   57             v3 = peekQ dq
   58             v4 = peekQ (nextQ dq)
   59             e1 = if isEarCorner p (toList dq) v0 v1 v3
   60                   then Set.insert v1 ears
   61                   else Set.delete v1 ears
   62             e2 = if isEarCorner p (toList dq) v1 v3 v4
   63                   then Set.insert v3 e1
   64                   else Set.delete v3 e1
   65         in (v1,v3) : worker e2 dq
   66       | otherwise = worker ears (nextQ queue)
   67       where
   68         x = peekQ queue
   69 
   70 data PolyQueue a = PolyQueue a [a] [a] [a]
   71 
   72 -- sizeQ :: PolyQueue a -> Int
   73 -- sizeQ (PolyQueue _ a b _) = 1 + length a + length b
   74 
   75 mkQueue :: [a] -> PolyQueue a
   76 mkQueue (x:xs) = PolyQueue x xs [] (reverse (x:xs))
   77 mkQueue []     = error "mkQueue: empty"
   78 
   79 toList :: PolyQueue a -> [a]
   80 toList (PolyQueue e a b _) = e : a ++ b
   81 
   82 isSimpleQ :: PolyQueue a -> Bool
   83 isSimpleQ (PolyQueue _ xs ys _) =
   84   case xs ++ ys of
   85     [_,_] -> True
   86     _     -> False
   87 
   88 peekQ :: PolyQueue a -> a
   89 peekQ (PolyQueue e _ _ _) = e
   90 
   91 nextQ :: PolyQueue a -> PolyQueue a
   92 nextQ (PolyQueue x [] ys p)     =
   93   let (y:xs) = reverse (x:ys)
   94   in PolyQueue y xs [] (x:p)
   95 nextQ (PolyQueue x (y:xs) ys p) = PolyQueue y xs (x:ys) (x:p)
   96 
   97 dropQ :: PolyQueue a -> PolyQueue a
   98 dropQ (PolyQueue _ [] ys p)    =
   99   let (x:xs) = reverse ys
  100   in PolyQueue x xs [] p
  101 dropQ (PolyQueue _ (x:xs) ys p) = PolyQueue x xs ys p
  102 
  103 prevQ :: Int -> PolyQueue a -> a
  104 prevQ nth (PolyQueue _ _ _ p) = p!!nth
  105 
  106 -- O(n)
  107 -- Returns true if ac can be cut from polygon. That is, true if 'b' is an ear.
  108 -- isEarCorner polygon a b c = True iff ac can be cut
  109 isEarCorner :: (Fractional a, Ord a, Epsilon a) => Ring a -> [Int] -> Int -> Int -> Int -> Bool
  110 isEarCorner p polygon a b c =
  111     isLeftTurn aP bP cP &&
  112     -- If it is a right turn then the line ac will be outside the polygon
  113     and [ not (isInside aP bP cP (ringAccess p k))
  114     | k <- polygon, k /= a && k /= b && k /= c
  115     ]
  116   where
  117     aP = ringAccess p a
  118     bP = ringAccess p b
  119     cP = ringAccess p c