github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-05 14:11:33 +03:00
Code Issues Projects Releases Wiki Activity

Compute the move bound relative to the current index.

Browse Source
This commit is contained in:
Rob Rix 2017-10-23 23:18:01 -04:00
parent 74c1c18822
commit e0ca6c7ec4
1 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/RWS.hs
View File

@ -80,24 +80,24 @@ findNearestNeighbourTo :: (Foldable syntax, Functor syntax, GAlign syntax)
-> [UnmappedTerm syntax ann1] -> [UnmappedTerm syntax ann1]
-> [UnmappedTerm syntax ann2] -> [UnmappedTerm syntax ann2]
-> [MappedDiff syntax ann1 ann2] -> [MappedDiff syntax ann1 ann2]
findNearestNeighbourTo canCompare as bs = go (pred (termIndex (head as))) as bs findNearestNeighbourTo canCompare as bs = go as bs
where go _ as [] = This . (termIndex &&& term) <$> as where go as [] = This . (termIndex &&& term) <$> as
go _ [] bs = That . (termIndex &&& term) <$> bs go [] bs = That . (termIndex &&& term) <$> bs
go previous unmappedA@(UnmappedTerm minA _ _ : _) (termB@(UnmappedTerm j _ b) : restUnmappedB) = go unmappedA@(UnmappedTerm minA _ _ : _) (termB@(UnmappedTerm j _ b) : restUnmappedB) =
fromMaybe (That (j, b) : go previous unmappedA restUnmappedB) $ do fromMaybe (That (j, b) : go unmappedA restUnmappedB) $ do
-- Look up the nearest unmapped term in `unmappedA`. -- Look up the nearest unmapped term in `unmappedA`.
foundA@(UnmappedTerm i _ a) <- nearestUnmapped (\ a -> isNearAndComparableTo canCompare previous b a && termIndex a >= minA) kdTreeA termB foundA@(UnmappedTerm i _ a) <- nearestUnmapped (isNearAndComparableTo canCompare minA b) kdTreeA termB
-- Look up the nearest `foundA` in `unmappedB` -- Look up the nearest `foundA` in `unmappedB`
UnmappedTerm j' _ _ <- nearestUnmapped (\ b -> isNearAndComparableTo (flip canCompare) (pred j) a b && termIndex b >= j) kdTreeB foundA UnmappedTerm j' _ _ <- nearestUnmapped (isNearAndComparableTo (flip canCompare) j a) kdTreeB foundA
-- Return Nothing if their indices don't match -- Return Nothing if their indices don't match
guard (j == j') guard (j == j')
pure $! pure $!
let (deleted, _ : restUnmappedA) = span ((< i) . termIndex) unmappedA in let (deleted, _ : restUnmappedA) = span ((< i) . termIndex) unmappedA in
(This . (termIndex &&& term) <$> deleted) <> (These (i, a) (j, b) : go i restUnmappedA restUnmappedB) (This . (termIndex &&& term) <$> deleted) <> (These (i, a) (j, b) : go restUnmappedA restUnmappedB)
(kdTreeA, kdTreeB) = (toKdMap as, toKdMap bs) (kdTreeA, kdTreeB) = (toKdMap as, toKdMap bs)
isNearAndComparableTo :: ComparabilityRelation syntax ann1 ann2 -> Int -> Term syntax ann2 -> UnmappedTerm syntax ann1 -> Bool isNearAndComparableTo :: ComparabilityRelation syntax ann1 ann2 -> Int -> Term syntax ann2 -> UnmappedTerm syntax ann1 -> Bool
isNearAndComparableTo canCompare index term (UnmappedTerm k _ term') = inRange (succ index, index + defaultMoveBound) k && canCompareTerms canCompare term' term isNearAndComparableTo canCompare index term (UnmappedTerm k _ term') = inRange (index, index + defaultMoveBound) k && canCompareTerms canCompare term' term
-- | Finds the most-similar unmapped term to the passed-in term, if any. -- | Finds the most-similar unmapped term to the passed-in term, if any.
-- --
@ -118,7 +118,7 @@ defaultD = 15
defaultL = 2 defaultL = 2
defaultP = 2 defaultP = 2
defaultQ = 3 defaultQ = 3
defaultMoveBound = 1 defaultMoveBound = 0
mapContiguous :: (Foldable syntax, Functor syntax, GAlign syntax) mapContiguous :: (Foldable syntax, Functor syntax, GAlign syntax)