BentleyOttmann WIP

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
bentleyOttmann ss = work eventQueue T.empty (bp, ep, xp)
 where 
  --Our initial event queue consists of the endpoints of our input list of segments.
  eventQueue = S.fromList (concat $ map toPoints ss)
  --We initialize a lookup structure that maps event points to segments that interact there.
  --Beginning and endpoints are filled, and intersection points are empty.
  bp = M.fromListWith (++) $ zip (map lep ss) (map return ss)
  ep = M.fromListWith (++) $ zip (map rep ss) (map return ss)
  xp = M.empty
  --A convenient lookup function to use with our lookup structure.
  lookup = M.findWithDefault []
  --work takes an event queue, a sweep line structure, and a lookup structure, and produces a list of intersection points
  --paired with the intersecting segments.
  work eq sl lk@(bp, ep, xp)
   --We check the event queue to see if it is non-empty. If there is an event to process, we do so.
   | Just (e@(Point x _), eq') <- S.minView eq =
    let line = Line (Point x 0) (Point x 1) --The current sweepline.
        bs = lookup e bp --What segments begin at this event point?
        es = lookup e ep --What segments end at this event point?
        xs = lookup e xp --What segments intersect at this event point?
        is = bs ++ es ++ xs
        --sl' and then sl'': We first remove segments ending and intersecting at this point from the sweepline.
        --We then add beginning segments and intersecting segments. This reverses the order of the x-ing segments
        --in the sweepline.
        sl' = foldl (flip ($)) sl (map (T.deleteBy (cmp line)) (xs ++ es))
        sl'' = foldl (flip ($)) sl' (map (T.insertBy (cmp line)) (bs ++ xs))
        --We now check for new intersections. `cmp line' is the ordering of segments w.r.t. to the sweepline.
        nxs = case bs ++ xs of
            --If we only removed segments from the sweepline, then we look for the immediate
            --neighbors of the removed segments in the old version of the structure. 
            []  -> let nmin = fromJust $ T.findBy (cmp line) (minimumBy (cmp line) es) sl
                       nmax = fromJust $ T.findBy (cmp line) (maximumBy (cmp line) es) sl
                   in if T.isEmpty sl'' then [] else catMaybes [xtestl (T.prev nmin), xtestr (T.next nmax)]
            --If we added segments, we look for their neighbors in the new version of the sweepline structure,
            -- and check those for intersections.
            bxs -> let nmin = fromJust $ T.findBy (cmp line) (minimumBy (cmp line) bxs) sl''
                       nmax = fromJust $ T.findBy (cmp line) (maximumBy (cmp line) bxs) sl''
                   in catMaybes [xtestl nmin, xtestr nmax]
        --nxs' is what we get when we remove intersections that have already been found and recorded in our lookup structure.
        nxs' = filter (not . flip M.member xp . fst) nxs
        --eq'' is the new event queue, with the new intersection points added as new event points.
        eq'' = eq' `S.union` (S.fromList (map fst nxs'))
        --finally, lk' is the new lookup structure augmented with the new intersection points as keys.
        lk' = (bp, ep, xp `M.union` M.fromList nxs')
    --Now, we check the number of segments associated to the current endpoint. If there's more than one, it's an intersection.
    --We add it to the list if it exists and continue to process the rest of the events with the updated sweepline and lookup structures.
    in if length is > 1 then (e, is) : (work eq'' sl'' lk') else work eq'' sl'' lk'
   --At some point, the eventqueue will be empty. That means we are done and there are no new intersection points to report.
   | otherwise = []
4:28: Error: Use concatMap
Found:
concat $ map toPoints ss
Why not:
concatMap toPoints ss
7:30: Error: Use &&&
Found:
zip (map lep ss) (map return ss)
Why not:
map (lep Control.Arrow.&&& return) ss
8:30: Error: Use &&&
Found:
zip (map rep ss) (map return ss)
Why not:
map (rep Control.Arrow.&&& return) ss
42:16: Warning: Redundant bracket
Found:
eq' `S.union` (S.fromList (map fst nxs'))
Why not:
eq' `S.union` S.fromList (map fst nxs')
47:30: Warning: Redundant bracket
Found:
(e, is) : (work eq'' sl'' lk')
Why not:
(e, is) : work eq'' sl'' lk'

BentleyOttmann WIP (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
bentleyOttmann ss = work eventQueue T.empty (bp, ep, xp)
 where 
  eventQueue = S.fromList (concat $ map toPoints ss)
  bp = M.fromListWith (++) $ zip (map lep ss) (map return ss)
  ep = M.fromListWith (++) $ zip (map rep ss) (map return ss)
  xp = M.empty
  lookup = M.findWithDefault []
  work eq sl lk@(bp, ep, xp)
   | Just (e@(Point x _), eq') <- S.minView eq =
    let line = Line (Point x 0) (Point x 1)
        bs = lookup e bp
        es = lookup e ep
        xs = lookup e xp
        is = bs ++ es ++ xs
        sl' = foldl (flip ($)) sl (map (T.deleteBy (cmp line)) (xs ++ es))
        sl'' = foldl (flip ($)) sl' (map (T.insertBy (cmp line)) (bs ++ xs))
        nxs = case bs ++ xs of
            []  -> let nmin = getCandidate minimumBy es sl
                       nmax = getCandidate maximumBy es sl
                   in if T.isEmpty sl'' then [] else catMaybes [xtestl (T.prev nmin), xtestr (T.next nmax)]
            bxs -> let nmin = getCandidate minimumBy bxs sl''
                       nmax = getCandidate minimumBy bxs sl''
                   in catMaybes [xtestl nmin, xtestr nmax]
           where getCandidate f es sl = fromJust $ T.findBy (cmp line) (f (cmp line) es) sl
        nxs' = filter (not . flip M.member xp . fst) nxs
        eq'' = eq' `S.union` (S.fromList (map fst nxs'))
        lk' = (bp, ep, xp `M.union` M.fromList nxs')
    in if length is > 1 then (e, is) : (work eq'' sl'' lk') else work eq'' sl'' lk'
   | otherwise = []
3:28: Error: Use concatMap
Found:
concat $ map toPoints ss
Why not:
concatMap toPoints ss
4:30: Error: Use &&&
Found:
zip (map lep ss) (map return ss)
Why not:
map (lep Control.Arrow.&&& return) ss
5:30: Error: Use &&&
Found:
zip (map rep ss) (map return ss)
Why not:
map (rep Control.Arrow.&&& return) ss
26:16: Warning: Redundant bracket
Found:
eq' `S.union` (S.fromList (map fst nxs'))
Why not:
eq' `S.union` S.fromList (map fst nxs')
28:30: Warning: Redundant bracket
Found:
(e, is) : (work eq'' sl'' lk')
Why not:
(e, is) : work eq'' sl'' lk'

BentleyOttmann WIP (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
bentleyOttmann ss = work eventQueue T.empty (bp, ep, xp)
 where 
  eventQueue = S.fromList (concatMap toPoints ss)
  bp = beginPoints ss
  ep = endPoints ss
  xp = M.empty
  lookup = M.findWithDefault []
  work eq sl lk@(bp, ep, xp)
   | Just (e@(Point x _), eq') <- S.minView eq =
    let line = Line (Point x 0) (Point x 1)
        bs = lookup e bp
        es = lookup e ep
        xs = lookup e xp
        is = bs ++ es ++ xs
        sl' = foldl (flip ($)) sl (map (T.deleteBy (cmp line)) (xs ++ es))
        sl'' = foldl (flip ($)) sl' (map (T.insertBy (cmp line)) (bs ++ xs))
        nxs = case bs ++ xs of
            []  -> let nmin = getCandidate minimumBy es sl
                       nmax = getCandidate maximumBy es sl
                   in if T.isEmpty sl'' then [] else catMaybes [xtestl (T.prev nmin), xtestr (T.next nmax)]
            bxs -> let nmin = getCandidate minimumBy bxs sl''
                       nmax = getCandidate minimumBy bxs sl''
                   in catMaybes [xtestl nmin, xtestr nmax]
           where getCandidate f es sl = fromJust $ T.findBy (cmp line) (f (cmp line) es) sl
        nxs' = filter (not . flip M.member xp . fst) nxs
        eq'' = eq' `S.union` S.fromList (map fst nxs')
        lk' = (bp, ep, xp `M.union` M.fromList nxs')
    in if length is > 1 then (e, is) : work eq'' sl'' lk' else work eq'' sl'' lk'
   | otherwise = []

BentleyOttmann WIP (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
--There was a bug.
bentleyOttmann ss = work eventQueue T.empty (bp, ep, xp)
 where 
  eventQueue = S.fromList (concatMap toPoints ss)
  bp = beginPoints ss
  ep = endPoints ss
  xp = M.empty
  lookup = M.findWithDefault []
  work eq sl lk@(bp, ep, xp)
   | Just (e@(Point x _), eq') <- S.minView eq =
    let line = Line (Point x 0) (Point x 1)
        bs = lookup e bp
        es = lookup e ep
        xs = lookup e xp
        is = bs ++ es ++ xs
        sl' = foldl (flip ($)) sl (map (T.deleteBy (cmp line)) (xs ++ es))
        sl'' = foldl (flip ($)) sl' (map (T.insertBy (cmp line)) (bs ++ xs))
        nxs = case bs ++ xs of
            []  -> let (nmin, nmax) = getCandidates es sl
                   in if T.isEmpty sl'' then [] else catMaybes [xtestl (T.prev nmin), xtestr (T.next nmax)]
            bxs -> let (nmin, nmax) = getCandidates bxs sl''
                   in catMaybes [xtestl nmin, xtestr nmax]
           where getCandidates ss sl = (aux minimumBy ss sl, aux maximumBy ss sl)
                 aux f ss sl = fromJust $ T.findBy (cmp line) (f (cmp line) ss) sl
        nxs' = filter (not . flip M.member xp . fst) nxs
        eq'' = eq' `S.union` S.fromList (map fst nxs')
        lk' = (bp, ep, M.unionWith ((nub .) . (++)) xp (M.fromList nxs))
    in if length is > 1 then (e, is) : work eq'' sl'' lk' else work eq'' sl'' lk'
   | otherwise = []