From 15c1c43e4b7fe5b3c967caa191521d028970b3fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 13 Jun 2017 21:33:57 -0400 Subject: [PATCH] :fire: Endpoint. --- src/SES/Myers.hs | 45 +++++++++++---------------------------------- 1 file changed, 11 insertions(+), 34 deletions(-) diff --git a/src/SES/Myers.hs b/src/SES/Myers.hs index b4751a4ec..46b6b90f6 100644 --- a/src/SES/Myers.hs +++ b/src/SES/Myers.hs @@ -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