github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 00:42:33 +03:00
Code Issues Projects Releases Wiki Activity

🔥 Endpoint.

Browse Source
This commit is contained in:
Rob Rix 2017-06-13 21:33:57 -04:00
parent 9ab7a3ca28
commit 15c1c43e4b
1 changed files with 11 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
src/SES/Myers.hs
View File

@ -6,7 +6,6 @@ module SES.Myers
, EditGraph(..)
, Distance(..)
, Diagonal(..)
, Endpoint(..)
, ses
, MyersState
) where
@ -18,7 +17,6 @@ import Data.Functor.Classes
import Data.These
import GHC.Show hiding (show)
import Prologue hiding (for, error)
import Text.Show (showListWith)
-- | An edit script, i.e. a sequence of changes/copies of elements.
type EditScript a b = [These a b]
@ -43,10 +41,6 @@ newtype Distance = Distance { unDistance :: Int }
newtype Diagonal = Diagonal { unDiagonal :: Int }
deriving (Eq, Ix, Ord, Show)
-- | The endpoint of a path through the edit graph, represented as the x/y indices and the script of edits made to get to that point.
data Endpoint a b = Endpoint { x :: !Int, script :: !(EditScript a b) }
deriving (Eq, Show)
-- API
@ -72,12 +66,12 @@ runSES eq (EditGraph as bs)
where -- | Search an edit graph for the shortest edit script along a specific diagonal, moving onto a given diagonal from one of its in-bounds adjacent diagonals (if any), and sliding down any diagonal edges eagerly.
searchAlongK (Diagonal k) = do
v <- get
let getK = uncurry Endpoint . (v !) . Diagonal
let getK k = let (x, script) = v ! Diagonal k in (x, x - k, script)
prev = getK (pred k)
next = getK (succ k)
Endpoint x' script = slideFrom $! if d == 0 || k < negate m || k > n then
(x', _, script) = slideFrom $! if d == 0 || k < negate m || k > n then
-- The top-left corner, or otherwise out-of-bounds.
Endpoint 0 []
(0, 0, [])
else if k == negate d || k == negate m then
-- The lower/left extent of the search region or edit graph, whichever is smaller.
moveDownFrom next
@ -96,19 +90,20 @@ runSES eq (EditGraph as bs)
else
Nothing
where -- | Move downward from a given vertex, inserting the element for the corresponding row.
moveDownFrom (Endpoint x script) = Endpoint x (if (x - pred k) < m then That (bs ! (x - pred k)) : script else script)
moveDownFrom (x, y, script) = (x, succ y, if y < m then That (bs ! y) : script else script)
-- | Move rightward from a given vertex, deleting the element for the corresponding column.
moveRightFrom (Endpoint x script) = Endpoint (succ x) (if x < n then This (as ! x) : script else script)
moveRightFrom (x, y, script) = (succ x, y, if x < n then This (as ! x) : script else script)
-- | Slide down any diagonal edges from a given vertex.
slideFrom (Endpoint x script)
slideFrom (x, y, script)
| x >= 0, x < n
, (x - k) >= 0, (x - k) < m
, y >= 0, y < m
, a <- as ! x
, b <- bs ! (x - k)
, a `eq` b = slideFrom (Endpoint (succ x) (These a b : script))
| otherwise = Endpoint x script
, b <- bs ! y
, a `eq` b = slideFrom (succ x, y, These a b : script)
| otherwise = ( x, succ y, script)
x (x, _, _) = x
-- Implementation details
@ -131,26 +126,8 @@ for all run = foldr (\ a b -> (<|>) <$> run a <*> b) (return Nothing) all
liftShowsVector :: Show i => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array.Array i a -> ShowS
liftShowsVector sp sl d = liftShowsPrec sp sl d . toList
-- | Lifted showing of These.
liftShowsThese :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> Int -> These a b -> ShowS
liftShowsThese sa sb d t = case t of
This a -> showsUnaryWith sa "This" d a
That b -> showsUnaryWith sb "That" d b
These a b -> showsBinaryWith sa sb "These" d a b
-- | Lifted showing of edit scripts.
liftShowsEditScript :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> Int -> EditScript a b -> ShowS
liftShowsEditScript sa sb _ = showListWith (liftShowsThese sa sb 0)
-- | Lifted showing of edit graph endpoints.
liftShowsEndpoint :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> Int -> Endpoint a b -> ShowS
liftShowsEndpoint sp1 sp2 d (Endpoint x script) = showsBinaryWith showsPrec (liftShowsEditScript sp1 sp2) "Endpoint" d x script
-- Instances
instance Show2 EditGraph where
liftShowsPrec2 sp1 sl1 sp2 sl2 d (EditGraph as bs) = showsBinaryWith (liftShowsVector sp1 sl1) (liftShowsVector sp2 sl2) "EditGraph" d as bs
instance Show2 Endpoint where
liftShowsPrec2 sp1 _ sp2 _ = liftShowsEndpoint sp1 sp2