-- | Working with edges of a matching graph.
module MCSP.Data.MatchingGraph (
    -- * Data Type
    Edge,
    pattern Edge,
    start,
    blockLen,

    -- * Finding Edges
    edgeSet,
    compatibleEdges,

    -- * Building Solutions
    Solution,
    solution,
    solutions,

    -- * Restoring Partitions
    mergeness,
    blockCount,
    toPartitions,
) where

import Data.Bool (Bool, not, (&&))
import Data.Eq (Eq (..))
import Data.Foldable (length, null)
import Data.Function (($), (.))
import Data.Int (Int)
import Data.IntMap.Strict qualified as IntMap (IntMap, insert, size, toDescList)
import Data.Interval (Interval, (<=..<))
import Data.IntervalSet (IntervalSet, insert, intersection)
import Data.IntervalSet qualified as IntervalSet (null, singleton)
import Data.List (concatMap, map, replicate, takeWhile, (++))
import Data.List.NonEmpty (NonEmpty (..), unfoldr)
import Data.Maybe (Maybe (..))
import Data.Monoid (mappend, mempty)
import Data.Ord (Ord (..))
import Data.Vector.Generic qualified as Vector (foldl', fromList, fromListN, length, map, snoc)
import Data.Vector.Unboxed (Vector, (!))
import GHC.Num (fromInteger, (+), (-))
import GHC.Real (toInteger)
import Text.Show (Show)

import MCSP.Data.Pair (Pair, both, cartesian, left, liftP, right, ($:), (&&&))
import MCSP.Data.String (String, slice, unsafeSlice)
import MCSP.Data.String.Extra (Partition, chars)

-- --------------------- --
-- Edge Set Construction --
-- --------------------- --

-- | Represents a position of a block or a character.
type Index = Int

-- | Represents the length of a block.
type Length = Int

-- | A single edge in the matching graph for a pair of strings.
--
-- An edge @((s, p), k)@ represents a common subtring @S[s .. s + k - 1] = P[p .. p + k - 1]@ of
-- length @k@ that can be used as a block for partitions.
type Edge = (Pair Index, Length)

-- Note: `Edge` is implemented as a tuple so we don't need to derive anything, but we should use
-- the pattern below.

{-# COMPLETE Edge #-}

-- | A single edge in the matching graph for a pair of strings.
--
-- An edge @`Edge` {`start` = (left, right), `blockLen`}@ represents a common subtring
-- @S[left .. left + blockLen - 1] = P[right .. right + blockLen - 1]@ of length `blockLen` that
-- can be used as a block for partitions.
pattern Edge :: Pair Index -> Length -> Edge
pattern $mEdge :: forall {r}.
Edge -> ((Length, Length) -> Length -> r) -> ((# #) -> r) -> r
$bEdge :: (Length, Length) -> Length -> Edge
Edge {Edge -> (Length, Length)
start, Edge -> Length
blockLen} = (start, blockLen)
{-# INLINE CONLIKE Edge #-}

-- | /O(n)/ List edges starting from a position pair @(s,p)@.
--
-- >>> edgesFrom ("abab", "abba") (0,0)
-- [((0,0),2)]
edgesFrom :: Eq a => Pair (String a) -> Pair Index -> [Edge]
edgesFrom :: forall a. Eq a => Pair (String a) -> (Length, Length) -> [Edge]
edgesFrom Pair (String a)
strs (Length, Length)
start = (Edge -> Bool) -> [Edge] -> [Edge]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Pair (String a) -> Edge -> Bool
forall {a}. Eq a => (String a, String a) -> Edge -> Bool
isCommonBlock Pair (String a)
strs) ([Edge] -> [Edge]) -> [Edge] -> [Edge]
forall a b. (a -> b) -> a -> b
$ (Length -> Edge) -> [Length] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map ((Length, Length)
start,) [Length
Item [Length]
2 ..]
  where
    isCommonBlock :: (String a, String a) -> Edge -> Bool
isCommonBlock (String a
l, String a
r) Edge {start :: Edge -> (Length, Length)
start = (Length
s, Length
p), blockLen :: Edge -> Length
blockLen = Length
k} =
        Length
s Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
k Length -> Length -> Bool
forall a. Ord a => a -> a -> Bool
<= String a -> Length
forall a. String a -> Length
forall (t :: * -> *) a. Foldable t => t a -> Length
length String a
l Bool -> Bool -> Bool
&& Length
p Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
k Length -> Length -> Bool
forall a. Ord a => a -> a -> Bool
<= String a -> Length
forall a. String a -> Length
forall (t :: * -> *) a. Foldable t => t a -> Length
length String a
r Bool -> Bool -> Bool
&& Length -> Length -> String a -> String a
forall a. Length -> Length -> String a -> String a
unsafeSlice Length
s Length
k String a
l String a -> String a -> Bool
forall a. Eq a => a -> a -> Bool
== Length -> Length -> String a -> String a
forall a. Length -> Length -> String a -> String a
unsafeSlice Length
p Length
k String a
r
{-# INLINEABLE edgesFrom #-}

-- | /O(n^3)/ List all edges of the matching graph for a pair of strings.
--
-- >>> edgeSet ("abab", "abba")
-- [((0,0),2),((1,2),2),((2,0),2)]
edgeSet :: Eq a => Pair (String a) -> Vector Edge
edgeSet :: forall a. Eq a => Pair (String a) -> Vector Edge
edgeSet (String a
l, String a
r) = [Edge] -> Vector Edge
forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList ([Edge] -> Vector Edge) -> [Edge] -> Vector Edge
forall a b. (a -> b) -> a -> b
$ ((Length, Length) -> [Edge]) -> [(Length, Length)] -> [Edge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String a, String a) -> (Length, Length) -> [Edge]
forall a. Eq a => Pair (String a) -> (Length, Length) -> [Edge]
edgesFrom (String a
l, String a
r)) [(Length, Length)]
start
  where
    start :: [(Length, Length)]
start = [Length] -> [Length] -> [(Length, Length)]
forall a b. [a] -> [b] -> [(a, b)]
cartesian [Length
Item [Length]
0 .. String a -> Length
forall a. String a -> Length
forall (t :: * -> *) a. Foldable t => t a -> Length
length String a
l Length -> Length -> Length
forall a. Num a => a -> a -> a
- Length
1] [Length
Item [Length]
0 .. String a -> Length
forall a. String a -> Length
forall (t :: * -> *) a. Foldable t => t a -> Length
length String a
r Length -> Length -> Length
forall a. Num a => a -> a -> a
- Length
1]

-- ----------------------- --
-- Edges used in Partition --

-- | Transform a partition into a vector that indicates, for a given
-- index of the original string, what is the size of the block that
-- starts in that position, or is zero if no block starts there.
--
-- >>> blockMap ["a", "test", "of", "this", "function"]
-- [1,4,0,0,0,2,0,4,0,0,0,8,0,0,0,0,0,0,0]
blockMap :: Partition a -> Vector Int
blockMap :: forall a. Partition a -> Vector Length
blockMap Partition a
x
    | (Partition a
_, [Length]
result, Length
_) <- (Partition a, [Length], Length) -> (Partition a, [Length], Length)
forall a.
(Partition a, [Length], Length) -> (Partition a, [Length], Length)
go (Partition a
x, [], Length
0) = [Length] -> Vector Length
forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [Length]
result
  where
    go :: (Partition a, [Int], Int) -> (Partition a, [Int], Int)
    go :: forall a.
(Partition a, [Length], Length) -> (Partition a, [Length], Length)
go ([], [Length]
list, Length
i) = ([], [Length]
list, Length
i)
    go (String a
p : Partition a
ps, [Length]
list, Length
i) =
        let size :: Length
size = String a -> Length
forall a. String a -> Length
forall (t :: * -> *) a. Foldable t => t a -> Length
length String a
p
         in (Partition a, [Length], Length) -> (Partition a, [Length], Length)
forall a.
(Partition a, [Length], Length) -> (Partition a, [Length], Length)
go (Partition a
ps, [Length]
list [Length] -> [Length] -> [Length]
forall a. [a] -> [a] -> [a]
++ [Length
Item [Length]
size] [Length] -> [Length] -> [Length]
forall a. [a] -> [a] -> [a]
++ Length -> Length -> [Length]
forall a. Length -> a -> [a]
replicate (Length
size Length -> Length -> Length
forall a. Num a => a -> a -> a
- Length
1) Length
0, Length
i Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
size)

-- | Map each edge to a boolean to indicate wheter that edge
-- is compatible with a given pair of partitions, i.e. could
-- have been used to generate that pair.
--
-- >>> compatibleEdges (["a", "ba", "b"], ["a", "b", "ba"]) [((0,0),2),((1,2),2),((2,0),2)]
-- [False,True,False]
compatibleEdges :: Pair (Partition a) -> Vector Edge -> Vector Bool
compatibleEdges :: forall a. Pair (Partition a) -> Vector Edge -> Vector Bool
compatibleEdges ((Partition a -> Vector Length)
-> Pair (Partition a) -> (Vector Length, Vector Length)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Partition a -> Vector Length
forall a. Partition a -> Vector Length
blockMap -> (Vector Length, Vector Length)
maps) = (Edge -> Bool) -> Vector Edge -> Vector Bool
forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
Vector.map Edge -> Bool
isEdgeIn
  where
    isEdgeIn :: Edge -> Bool
isEdgeIn ((Length, Length)
indices, Length
k) = (Vector Length -> Length -> Length)
-> (Vector Length, Vector Length)
-> (Length, Length)
-> (Length, Length)
forall a b c. (a -> b -> c) -> Pair a -> Pair b -> Pair c
liftP Vector Length -> Length -> Length
forall a. Unbox a => Vector a -> Length -> a
(!) (Vector Length, Vector Length)
maps (Length, Length)
indices (Length, Length) -> (Length, Length) -> Bool
forall a. Eq a => a -> a -> Bool
== (Length
k, Length
k)

-- ------------------ --
-- Building Solutions --
-- ------------------ --

-- | Indices for a subtring to be used as a block.
type Block = Interval Index

-- | Creates an interval representing a substring @S[i .. i + n - 1]@.
--
-- >>> blockInterval 1 4
-- Finite 1 <=..< Finite 5
blockInterval :: Index -> Length -> Block
blockInterval :: Length -> Length -> Block
blockInterval Length
lo Length
len = Length -> Extended Length
extend Length
lo Extended Length -> Extended Length -> Block
forall r. Ord r => Extended r -> Extended r -> Interval r
<=..< Length -> Extended Length
extend (Length
lo Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
len)
  where
    extend :: Length -> Extended Length
extend = Integer -> Extended Length
forall a. Num a => Integer -> a
fromInteger (Integer -> Extended Length)
-> (Length -> Integer) -> Length -> Extended Length
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Length -> Integer
forall a. Integral a => a -> Integer
toInteger

-- | Extract the interval for the associated blocks in each string from an edge.
--
-- >>> toBlocks Edge {start=(0, 2), blockLen=5}
-- (Finite 0 <=..< Finite 5,Finite 2 <=..< Finite 7)
toBlocks :: Edge -> Pair Block
toBlocks :: Edge -> Pair Block
toBlocks Edge {start :: Edge -> (Length, Length)
start = (Length
s, Length
p), blockLen :: Edge -> Length
blockLen = Length
k} = (Length -> Length -> Block
blockInterval Length
s Length
k, Length -> Length -> Block
blockInterval Length
p Length
k)

-- | The set of all matched regions of string.
--
-- Used to avoid overlapping blocks in the final partition.
type MatchedSet = IntervalSet Index

-- | Checks if a block was already matched in the current solution.
--
-- >>> let edge = Edge {start=(0,2), blockLen=5}
-- >>> blockInterval 0 5 `overlaps` mempty
-- False
--
-- >>> blockInterval 0 5 `overlaps` IntervalSet.singleton (blockInterval 5 10)
-- False
--
-- >>> blockInterval 0 5 `overlaps` IntervalSet.singleton (blockInterval 4 5)
-- True
overlaps :: Block -> MatchedSet -> Bool
Block
interval overlaps :: Block -> MatchedSet -> Bool
`overlaps` MatchedSet
set = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ MatchedSet -> Bool
forall r. IntervalSet r -> Bool
IntervalSet.null (Block -> MatchedSet
forall r. Ord r => Interval r -> IntervalSet r
IntervalSet.singleton Block
interval MatchedSet -> MatchedSet -> MatchedSet
forall r. Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
`intersection` MatchedSet
set)

-- | Turn an edge into a non-overlapping interval pair.
--
-- Returns `Nothing` if any of the interval would overlap.
--
-- >>> let edge = Edge {start=(0,2), blockLen=5}
-- >>> nonOverlappingBlock edge mempty
-- Just (Finite 0 <=..< Finite 5,Finite 2 <=..< Finite 7)
--
-- >>> nonOverlappingBlock edge (IntervalSet.singleton `both` (toBlocks edge))
-- Nothing
nonOverlappingBlock :: Edge -> Pair MatchedSet -> Maybe (Pair Block)
nonOverlappingBlock :: Edge -> Pair MatchedSet -> Maybe (Pair Block)
nonOverlappingBlock Edge
edge Pair MatchedSet
matched =
    if Bool -> Bool
not (Pair Block -> Block
forall a. Pair a -> a
left Pair Block
block Block -> MatchedSet -> Bool
`overlaps` Pair MatchedSet -> MatchedSet
forall a. Pair a -> a
left Pair MatchedSet
matched) Bool -> Bool -> Bool
&& Bool -> Bool
not (Pair Block -> Block
forall a. Pair a -> a
right Pair Block
block Block -> MatchedSet -> Bool
`overlaps` Pair MatchedSet -> MatchedSet
forall a. Pair a -> a
right Pair MatchedSet
matched)
        then Pair Block -> Maybe (Pair Block)
forall a. a -> Maybe a
Just Pair Block
block
        else Maybe (Pair Block)
forall a. Maybe a
Nothing
  where
    block :: Pair Block
block = Edge -> Pair Block
toBlocks Edge
edge

-- | A partial solution to the strings partitioning.
--
-- Each @(k,v)@ pair in the map represents a block @S[k ... k + v]@ that should be used in the final
-- solution.
type IndexedPartition = IntMap.IntMap Length

-- | Insert an edge to the final solution, without checking for overlapping blocks.
insertInPartition :: Edge -> Pair IndexedPartition -> Pair IndexedPartition
insertInPartition :: Edge -> Pair IndexedPartition -> Pair IndexedPartition
insertInPartition Edge
edge = (Length -> IndexedPartition -> IndexedPartition)
-> (Length, Length)
-> Pair IndexedPartition
-> Pair IndexedPartition
forall a b c. (a -> b -> c) -> Pair a -> Pair b -> Pair c
liftP (Length -> Length -> IndexedPartition -> IndexedPartition
forall a. Length -> a -> IntMap a -> IntMap a
`IntMap.insert` Edge -> Length
blockLen Edge
edge) (Edge -> (Length, Length)
start Edge
edge)

-- | A collection of data used for constructing solutions from an edge set.
data MatchingInfo = Info
    { -- | Collection of blocks from non-overlapping edges, used as a solution.
      MatchingInfo -> Pair IndexedPartition
partition :: Pair IndexedPartition,
      -- | Set of ranges matched in each string.
      MatchingInfo -> Pair MatchedSet
matchedSet :: Pair MatchedSet,
      -- | List of edges not used in the solution.
      MatchingInfo -> Vector Edge
unused :: Vector Edge
    }
    deriving stock (Length -> MatchingInfo -> ShowS
[MatchingInfo] -> ShowS
MatchingInfo -> String
(Length -> MatchingInfo -> ShowS)
-> (MatchingInfo -> String)
-> ([MatchingInfo] -> ShowS)
-> Show MatchingInfo
forall a.
(Length -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Length -> MatchingInfo -> ShowS
showsPrec :: Length -> MatchingInfo -> ShowS
$cshow :: MatchingInfo -> String
show :: MatchingInfo -> String
$cshowList :: [MatchingInfo] -> ShowS
showList :: [MatchingInfo] -> ShowS
Show)

-- | Representation of a trivial solution.
--
-- >>> empty
-- Info {partition = (fromList [],fromList []), matchedSet = (fromList [],fromList []), unused = []}
empty :: MatchingInfo
empty :: MatchingInfo
empty = Info {partition :: Pair IndexedPartition
partition = Pair IndexedPartition
forall a. Monoid a => a
mempty, matchedSet :: Pair MatchedSet
matchedSet = Pair MatchedSet
forall a. Monoid a => a
mempty, unused :: Vector Edge
unused = []}

-- | Constructs a partial solution from a list of edges, collecting the `unused` edges.
--
-- >>> resolve [Edge {start=(0,2), blockLen=5}]
-- Info {partition = (fromList [(0,5)],fromList [(2,5)]), matchedSet = (fromList [Finite 0 <=..< Finite 5],fromList [Finite 2 <=..< Finite 7]), unused = []}
resolve :: Vector Edge -> MatchingInfo
resolve :: Vector Edge -> MatchingInfo
resolve = (MatchingInfo -> Edge -> MatchingInfo)
-> MatchingInfo -> Vector Edge -> MatchingInfo
forall (v :: * -> *) b a.
Vector v b =>
(a -> b -> a) -> a -> v b -> a
Vector.foldl' MatchingInfo -> Edge -> MatchingInfo
addEdge MatchingInfo
empty
  where
    addEdge :: MatchingInfo -> Edge -> MatchingInfo
addEdge Info {Pair IndexedPartition
Pair MatchedSet
Vector Edge
partition :: MatchingInfo -> Pair IndexedPartition
matchedSet :: MatchingInfo -> Pair MatchedSet
unused :: MatchingInfo -> Vector Edge
partition :: Pair IndexedPartition
matchedSet :: Pair MatchedSet
unused :: Vector Edge
..} Edge
edge = case Edge -> Pair MatchedSet -> Maybe (Pair Block)
nonOverlappingBlock Edge
edge Pair MatchedSet
matchedSet of
        -- non overlapping edge, add to solution
        Just Pair Block
blocks ->
            Info
                { partition :: Pair IndexedPartition
partition = Edge -> Pair IndexedPartition -> Pair IndexedPartition
insertInPartition Edge
edge Pair IndexedPartition
partition,
                  matchedSet :: Pair MatchedSet
matchedSet = (Block -> MatchedSet -> MatchedSet)
-> Pair Block -> Pair MatchedSet -> Pair MatchedSet
forall a b c. (a -> b -> c) -> Pair a -> Pair b -> Pair c
liftP Block -> MatchedSet -> MatchedSet
forall r. Ord r => Interval r -> IntervalSet r -> IntervalSet r
insert Pair Block
blocks Pair MatchedSet
matchedSet,
                  Vector Edge
unused :: Vector Edge
unused :: Vector Edge
unused
                }
        -- edge overlaps, add to unused
        Maybe (Pair Block)
Nothing ->
            Info
                { Pair IndexedPartition
partition :: Pair IndexedPartition
partition :: Pair IndexedPartition
partition,
                  Pair MatchedSet
matchedSet :: Pair MatchedSet
matchedSet :: Pair MatchedSet
matchedSet,
                  unused :: Vector Edge
unused = Vector Edge -> Edge -> Vector Edge
forall (v :: * -> *) a. Vector v a => v a -> a -> v a
Vector.snoc Vector Edge
unused Edge
edge
                }

-- | Construct another solution with the `unused` edges of the previous solution.
--
-- Return `Nothing` for any trivial solution.
--
-- >>> nextSolution (resolve [Edge {start=(0,2), blockLen=5}])
-- Just (Info {partition = (fromList [],fromList []), matchedSet = (fromList [],fromList []), unused = []})
--
-- >>> nextSolution empty
-- Nothing
nextSolution :: MatchingInfo -> Maybe MatchingInfo
nextSolution :: MatchingInfo -> Maybe MatchingInfo
nextSolution Info {Pair IndexedPartition
Pair MatchedSet
Vector Edge
partition :: MatchingInfo -> Pair IndexedPartition
matchedSet :: MatchingInfo -> Pair MatchedSet
unused :: MatchingInfo -> Vector Edge
partition :: Pair IndexedPartition
matchedSet :: Pair MatchedSet
unused :: Vector Edge
..} =
    if IndexedPartition -> Bool
forall a. IntMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Pair IndexedPartition -> IndexedPartition
forall a. Pair a -> a
left Pair IndexedPartition
partition) Bool -> Bool -> Bool
&& IndexedPartition -> Bool
forall a. IntMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Pair IndexedPartition -> IndexedPartition
forall a. Pair a -> a
right Pair IndexedPartition
partition)
        then Maybe MatchingInfo
forall a. Maybe a
Nothing
        else MatchingInfo -> Maybe MatchingInfo
forall a. a -> Maybe a
Just (Vector Edge -> MatchingInfo
resolve Vector Edge
unused)

-- | A complete solution to the strings partitioning.
--
-- Each @(k,v)@ pair in the solution represents a block @S[k ... k + v]@.
type Solution = Pair (Vector (Index, Length))

-- | Extract the solution from the `MatchingInfo`.
toSolution :: MatchingInfo -> Solution
toSolution :: MatchingInfo -> Solution
toSolution Info {Pair IndexedPartition
Pair MatchedSet
Vector Edge
partition :: MatchingInfo -> Pair IndexedPartition
matchedSet :: MatchingInfo -> Pair MatchedSet
unused :: MatchingInfo -> Vector Edge
partition :: Pair IndexedPartition
matchedSet :: Pair MatchedSet
unused :: Vector Edge
..} = IndexedPartition -> Vector (Length, Length)
forall {v :: * -> *} {a}.
Vector v (Length, a) =>
IntMap a -> v (Length, a)
toSolutionVector (IndexedPartition -> Vector (Length, Length))
-> Pair IndexedPartition -> Solution
forall a b. (a -> b) -> (a, a) -> (b, b)
`both` Pair IndexedPartition
partition
  where
    toSolutionVector :: IntMap a -> v (Length, a)
toSolutionVector IntMap a
part = Length -> [(Length, a)] -> v (Length, a)
forall (v :: * -> *) a. Vector v a => Length -> [a] -> v a
Vector.fromListN (IntMap a -> Length
forall a. IntMap a -> Length
IntMap.size IntMap a
part) (IntMap a -> [(Length, a)]
forall a. IntMap a -> [(Length, a)]
IntMap.toDescList IntMap a
part)

-- | The solution represented by the edge list.
--
-- Apply each edge in the same order they are listed, ignoring edges that overlaps with the partial
-- solution.
--
-- >>> solution $ edgeSet ("abab", "abba")
-- ([(0,2)],[(0,2)])
--
-- >>> solution $ edgeSet ("abab", "abab")
-- ([(2,2),(0,2)],[(2,2),(0,2)])
solution :: Vector Edge -> Solution
solution :: Vector Edge -> Solution
solution = MatchingInfo -> Solution
toSolution (MatchingInfo -> Solution)
-> (Vector Edge -> MatchingInfo) -> Vector Edge -> Solution
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Edge -> MatchingInfo
resolve

-- | List of all solutions represented with an ordering of the edge set.
--
-- This is done by reapeatedly constructing `solution`s with the unused edges from the previous
-- `solution`.
--
-- >>> solutions $ edgeSet ("abab", "abba")
-- ([(0,2)],[(0,2)]) :| [([(1,2)],[(2,2)]),([(2,2)],[(0,2)]),([],[])]
--
-- >>> solutions $ edgeSet ("abab", "abab")
-- ([(2,2),(0,2)],[(2,2),(0,2)]) :| [([(0,3)],[(0,3)]),([(0,4)],[(0,4)]),([(2,2),(0,2)],[(2,2),(0,2)]),([(1,2)],[(1,2)]),([(1,3)],[(1,3)]),([],[])]
solutions :: Vector Edge -> NonEmpty Solution
solutions :: Vector Edge -> NonEmpty Solution
solutions Vector Edge
edges = (MatchingInfo -> (Solution, Maybe MatchingInfo))
-> MatchingInfo -> NonEmpty Solution
forall a b. (a -> (b, Maybe a)) -> a -> NonEmpty b
unfoldr (MatchingInfo -> Solution
toSolution (MatchingInfo -> Solution)
-> (MatchingInfo -> Maybe MatchingInfo)
-> MatchingInfo
-> (Solution, Maybe MatchingInfo)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& MatchingInfo -> Maybe MatchingInfo
nextSolution) (Vector Edge -> MatchingInfo
resolve Vector Edge
edges)

-- -------------------- --
-- Restoring Partitions --
-- -------------------- --

-- | Calculates how much the solution merges the characters of the string.
--
-- The mergeness is given by the string length minus the number of blocks.
--
-- >>> mergeness mempty
-- 0
--
-- >>> mergeness (solution $ edgeSet ("abab", "abba"))
-- 1
mergeness :: Solution -> Length
mergeness :: Solution -> Length
mergeness Solution
sol = Length -> Length -> Length
forall a. Ord a => a -> a -> a
min (Length -> Length -> Length) -> (Length, Length) -> Length
forall a b c. (a -> b -> c) -> (a, b) -> c
$: Vector (Length, Length) -> Length
forall {v :: * -> *} {a}.
Vector v (a, Length) =>
v (a, Length) -> Length
blocks (Vector (Length, Length) -> Length) -> Solution -> (Length, Length)
forall a b. (a -> b) -> (a, a) -> (b, b)
`both` Solution
sol
  where
    blocks :: v (a, Length) -> Length
blocks v (a, Length)
part = (Length -> (a, Length) -> Length)
-> Length -> v (a, Length) -> Length
forall (v :: * -> *) b a.
Vector v b =>
(a -> b -> a) -> a -> v b -> a
Vector.foldl' Length -> (a, Length) -> Length
forall {a} {a}. Num a => a -> (a, a) -> a
sum Length
0 v (a, Length)
part Length -> Length -> Length
forall a. Num a => a -> a -> a
- v (a, Length) -> Length
forall (v :: * -> *) a. Vector v a => v a -> Length
Vector.length v (a, Length)
part
    sum :: a -> (a, a) -> a
sum a
total (a
_, a
len) = a
total a -> a -> a
forall a. Num a => a -> a -> a
+ a
len

-- | Calculates the number of blocks the solution will create.
--
-- >>> blockCount "abab" mempty
-- 4
--
-- >>> blockCount "abab" (solution $ edgeSet ("abab", "abba"))
-- 3
blockCount :: String a -> Solution -> Length
blockCount :: forall a. String a -> Solution -> Length
blockCount String a
str Solution
sol = String a -> Length
forall a. String a -> Length
forall (t :: * -> *) a. Foldable t => t a -> Length
length String a
str Length -> Length -> Length
forall a. Num a => a -> a -> a
- Solution -> Length
mergeness Solution
sol

-- | Extract the partition from a block slice map.
--
-- >>> toPartition "abcd" [(1, 2)]
-- [a,bc,d]
--
-- >>> toPartition "abcd" [(2, 2)]
-- [a,b,cd]
--
-- >>> toPartition "abcd" [(0, 2)]
-- [ab,c,d]
--
-- >>> toPartition "abcd" [(0, 4)]
-- [abcd]
--
-- >>> toPartition "abcd" []
-- [a,b,c,d]
toPartition :: String a -> Vector (Index, Length) -> Partition a
toPartition :: forall a. String a -> Vector (Length, Length) -> Partition a
toPartition String a
s = Length -> (Length, Partition a) -> Partition a
concatChars Length
0 ((Length, Partition a) -> Partition a)
-> (Vector (Length, Length) -> (Length, Partition a))
-> Vector (Length, Length)
-> Partition a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Length, Partition a)
 -> (Length, Length) -> (Length, Partition a))
-> (Length, Partition a)
-> Vector (Length, Length)
-> (Length, Partition a)
forall (v :: * -> *) b a.
Vector v b =>
(a -> b -> a) -> a -> v b -> a
Vector.foldl' (Length, Partition a) -> (Length, Length) -> (Length, Partition a)
insertBlock (String a -> Length
forall a. String a -> Length
forall (t :: * -> *) a. Foldable t => t a -> Length
length String a
s, [])
  where
    insertBlock :: (Length, Partition a) -> (Length, Length) -> (Length, Partition a)
insertBlock (Length
f, Partition a
p) (Length
i, Length
n) = (Length
i, Length -> Length -> String a -> String a
forall a. Length -> Length -> String a -> String a
slice Length
i Length
n String a
s String a -> Partition a -> Partition a
forall a. a -> [a] -> [a]
: Length -> (Length, Partition a) -> Partition a
concatChars (Length
i Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
n) (Length
f, Partition a
p))
    concatChars :: Length -> (Length, Partition a) -> Partition a
concatChars Length
i (Length
f, Partition a
p) = String a -> Partition a
forall a. String a -> Partition a
chars (Length -> Length -> String a -> String a
forall a. Length -> Length -> String a -> String a
slice Length
i (Length
f Length -> Length -> Length
forall a. Num a => a -> a -> a
- Length
i) String a
s) Partition a -> Partition a -> Partition a
forall a. Monoid a => a -> a -> a
`mappend` Partition a
p

-- | Construct the partitions for a solution.
--
-- >>> toPartitions ("abab", "abba") mempty
-- ([a,b,a,b],[a,b,b,a])
--
-- >>> toPartitions ("abab", "abba") (solution $ edgeSet ("abab", "abba"))
-- ([ab,a,b],[ab,b,a])
--
-- >>> toPartitions ("abba", "abab") (solution $ edgeSet ("abba", "abab"))
-- ([ab,b,a],[ab,a,b])
toPartitions :: Pair (String a) -> Solution -> Pair (Partition a)
toPartitions :: forall a. Pair (String a) -> Solution -> Pair (Partition a)
toPartitions = (String a -> Vector (Length, Length) -> Partition a)
-> Pair (String a) -> Solution -> Pair (Partition a)
forall a b c. (a -> b -> c) -> Pair a -> Pair b -> Pair c
liftP String a -> Vector (Length, Length) -> Partition a
forall a. String a -> Vector (Length, Length) -> Partition a
toPartition