{-# LANGUAGE RecordWildCards #-}
module Data.Align.Affine
(
align
, AlignConfig
, alignConfig
, Step
, Trace, traceScore, trace
, debugAlign, debugStrAlign
, centerStar
, MultiStep, center, others, stepOfAll
, MultiTrace, centerIndex, otherIndices, allIndices, multiTrace
, debugMultiAlign
) where
import Control.Monad.Trans.State.Strict (evalState, gets, modify)
import Data.Function (on)
import Data.Maybe (fromMaybe)
import qualified Data.List as L
import qualified Data.Map.Strict as M
import Data.Ord (comparing)
import qualified Data.Vector.Generic as G
type Step a = Either (Either a a) (a, a)
stepLeft :: a -> Either (Either a b1) b2
stepLeft :: a -> Either (Either a b1) b2
stepLeft = Either a b1 -> Either (Either a b1) b2
forall a b. a -> Either a b
Left (Either a b1 -> Either (Either a b1) b2)
-> (a -> Either a b1) -> a -> Either (Either a b1) b2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b1
forall a b. a -> Either a b
Left
stepRight :: b1 -> Either (Either a b1) b2
stepRight :: b1 -> Either (Either a b1) b2
stepRight = Either a b1 -> Either (Either a b1) b2
forall a b. a -> Either a b
Left (Either a b1 -> Either (Either a b1) b2)
-> (b1 -> Either a b1) -> b1 -> Either (Either a b1) b2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b1 -> Either a b1
forall a b. b -> Either a b
Right
stepBoth :: a1 -> b -> Either a2 (a1, b)
stepBoth :: a1 -> b -> Either a2 (a1, b)
stepBoth a :: a1
a b :: b
b = (a1, b) -> Either a2 (a1, b)
forall a b. b -> Either a b
Right (a1
a,b
b)
data Trace a s = Trace
{ Trace a s -> s
traceScore :: s
, Trace a s -> [Step a]
trace :: [Step a]
}
instance (Show a, Show s) => Show (Trace a s) where
show :: Trace a s -> String
show (Trace s :: s
s t :: [Step a]
t) = "Trace(score = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ s -> String
forall a. Show a => a -> String
show s
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", steps = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Step a] -> String
forall a. Show a => a -> String
show [Step a]
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
tappend :: Num s => Trace a s -> (s, Step a) -> Trace a s
Trace a :: s
a b :: [Step a]
b tappend :: Trace a s -> (s, Step a) -> Trace a s
`tappend` (y :: s
y,z :: Step a
z) = s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace (s
as -> s -> s
forall a. Num a => a -> a -> a
+s
y) (Step a
zStep a -> [Step a] -> [Step a]
forall a. a -> [a] -> [a]
:[Step a]
b)
data AffineTrace a s = AffineTrace {
AffineTrace a s -> Trace a s
at_max :: Trace a s
, AffineTrace a s -> Trace a s
at_left_gap :: Trace a s
, AffineTrace a s -> Trace a s
at_right_gap :: Trace a s
}
data AlignConfig a s = AlignConfig
{ AlignConfig a s -> a -> a -> s
acPairScore :: a -> a -> s
, AlignConfig a s -> s
acGapOpen :: s
, AlignConfig a s -> s
acGapExtension :: s
}
alignConfig :: (a -> a -> s)
-> s
-> s
-> AlignConfig a s
alignConfig :: (a -> a -> s) -> s -> s -> AlignConfig a s
alignConfig = (a -> a -> s) -> s -> s -> AlignConfig a s
forall a s. (a -> a -> s) -> s -> s -> AlignConfig a s
AlignConfig
align :: (G.Vector v a, Num s, Ord s)
=> AlignConfig a s
-> v a
-> v a
-> Trace a s
align :: AlignConfig a s -> v a -> v a -> Trace a s
align AlignConfig{..} as :: v a
as bs :: v a
bs =
let p :: (Int, Int)
p = (v a -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
lastIndex v a
as, v a -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
lastIndex v a
bs)
in Trace a s -> Trace a s
forall a s. Trace a s -> Trace a s
revTrace (Trace a s -> Trace a s)
-> (AffineTrace a s -> Trace a s) -> AffineTrace a s -> Trace a s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AffineTrace a s -> Trace a s
forall a s. AffineTrace a s -> Trace a s
at_max (AffineTrace a s -> Trace a s) -> AffineTrace a s -> Trace a s
forall a b. (a -> b) -> a -> b
$ State (Map (Int, Int) (AffineTrace a s)) (AffineTrace a s)
-> Map (Int, Int) (AffineTrace a s) -> AffineTrace a s
forall s a. State s a -> s -> a
evalState ((Int, Int)
-> State (Map (Int, Int) (AffineTrace a s)) (AffineTrace a s)
forall (m :: * -> *).
Monad m =>
(Int, Int)
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
go (Int, Int)
p) Map (Int, Int) (AffineTrace a s)
forall k a. Map k a
M.empty
where
revTrace :: Trace a s -> Trace a s
revTrace (Trace s :: s
s t :: [Step a]
t) = s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace s
s ([Step a] -> [Step a]
forall a. [a] -> [a]
reverse [Step a]
t)
lastIndex :: v a -> Int
lastIndex v :: v a
v = v a -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.length v a
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
go :: (Int, Int)
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
go p :: (Int, Int)
p = do
Maybe (AffineTrace a s)
res <- (Map (Int, Int) (AffineTrace a s) -> Maybe (AffineTrace a s))
-> StateT
(Map (Int, Int) (AffineTrace a s)) m (Maybe (AffineTrace a s))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((Map (Int, Int) (AffineTrace a s) -> Maybe (AffineTrace a s))
-> StateT
(Map (Int, Int) (AffineTrace a s)) m (Maybe (AffineTrace a s)))
-> (Map (Int, Int) (AffineTrace a s) -> Maybe (AffineTrace a s))
-> StateT
(Map (Int, Int) (AffineTrace a s)) m (Maybe (AffineTrace a s))
forall a b. (a -> b) -> a -> b
$ (Int, Int)
-> Map (Int, Int) (AffineTrace a s) -> Maybe (AffineTrace a s)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Int, Int)
p
case Maybe (AffineTrace a s)
res of
Just r :: AffineTrace a s
r -> AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
forall (m :: * -> *) a. Monad m => a -> m a
return AffineTrace a s
r
Nothing -> do
AffineTrace a s
newRes <- (Int, Int)
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
pgo (Int, Int)
p
(Map (Int, Int) (AffineTrace a s)
-> Map (Int, Int) (AffineTrace a s))
-> StateT (Map (Int, Int) (AffineTrace a s)) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Int, Int)
-> AffineTrace a s
-> Map (Int, Int) (AffineTrace a s)
-> Map (Int, Int) (AffineTrace a s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int, Int)
p AffineTrace a s
newRes)
AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
forall (m :: * -> *) a. Monad m => a -> m a
return AffineTrace a s
newRes
pgo :: (Int, Int)
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
pgo (i :: Int
i,j :: Int
j)
| Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (-1) Bool -> Bool -> Bool
|| Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (-1) = AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
forall (m :: * -> *) a. Monad m => a -> m a
return (AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s))
-> AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
forall a b. (a -> b) -> a -> b
$
if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then Trace a s -> Trace a s -> Trace a s -> AffineTrace a s
forall a s. Trace a s -> Trace a s -> Trace a s -> AffineTrace a s
AffineTrace (s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace 0 []) (s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace 0 []) (s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace 0 [])
else if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (-1)
then Int -> (a -> Step a) -> v a -> AffineTrace a s
forall (v :: * -> *) t a.
Vector v t =>
Int -> (t -> Step a) -> v t -> AffineTrace a s
skipInit Int
j a -> Step a
forall b1 a b2. b1 -> Either (Either a b1) b2
stepRight v a
bs
else Int -> (a -> Step a) -> v a -> AffineTrace a s
forall (v :: * -> *) t a.
Vector v t =>
Int -> (t -> Step a) -> v t -> AffineTrace a s
skipInit Int
i a -> Step a
forall a b1 b2. a -> Either (Either a b1) b2
stepLeft v a
as
| Bool
otherwise = do
let a :: a
a = v a
as v a -> Int -> a
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
G.! Int
i
b :: a
b = v a
bs v a -> Int -> a
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
G.! Int
j
AffineTrace a s
diag <- (Int, Int)
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
let diag_max :: Trace a s
diag_max = (AffineTrace a s -> Trace a s
forall a s. AffineTrace a s -> Trace a s
at_max AffineTrace a s
diag) Trace a s -> (s, Step a) -> Trace a s
forall s a. Num s => Trace a s -> (s, Step a) -> Trace a s
`tappend` (a -> a -> s
acPairScore a
a a
b, a -> a -> Step a
forall a1 b a2. a1 -> b -> Either a2 (a1, b)
stepBoth a
a a
b)
AffineTrace a s
a_gaps <- (Int, Int)
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1, Int
j)
let a_gap1 :: Trace a s
a_gap1 = (AffineTrace a s -> Trace a s
forall a s. AffineTrace a s -> Trace a s
at_max AffineTrace a s
a_gaps) Trace a s -> (s, Step a) -> Trace a s
forall s a. Num s => Trace a s -> (s, Step a) -> Trace a s
`tappend` (s
acGapOpen s -> s -> s
forall a. Num a => a -> a -> a
+ s
acGapExtension, a -> Step a
forall a b1 b2. a -> Either (Either a b1) b2
stepLeft a
a)
let a_gap2 :: Trace a s
a_gap2 = (AffineTrace a s -> Trace a s
forall a s. AffineTrace a s -> Trace a s
at_left_gap) AffineTrace a s
a_gaps Trace a s -> (s, Step a) -> Trace a s
forall s a. Num s => Trace a s -> (s, Step a) -> Trace a s
`tappend` (s
acGapExtension, a -> Step a
forall a b1 b2. a -> Either (Either a b1) b2
stepLeft a
a)
let a_gap_max :: Trace a s
a_gap_max = (Trace a s -> Trace a s -> Ordering) -> [Trace a s] -> Trace a s
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
L.maximumBy ((Trace a s -> s) -> Trace a s -> Trace a s -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Trace a s -> s
forall a s. Trace a s -> s
traceScore) [Trace a s
a_gap1, Trace a s
a_gap2]
AffineTrace a s
b_gaps <- (Int, Int)
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
go ( Int
i,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
let b_gap1 :: Trace a s
b_gap1 = (AffineTrace a s -> Trace a s
forall a s. AffineTrace a s -> Trace a s
at_max AffineTrace a s
b_gaps) Trace a s -> (s, Step a) -> Trace a s
forall s a. Num s => Trace a s -> (s, Step a) -> Trace a s
`tappend` (s
acGapOpen s -> s -> s
forall a. Num a => a -> a -> a
+ s
acGapExtension, a -> Step a
forall b1 a b2. b1 -> Either (Either a b1) b2
stepRight a
b)
let b_gap2 :: Trace a s
b_gap2 = (AffineTrace a s -> Trace a s
forall a s. AffineTrace a s -> Trace a s
at_right_gap AffineTrace a s
b_gaps) Trace a s -> (s, Step a) -> Trace a s
forall s a. Num s => Trace a s -> (s, Step a) -> Trace a s
`tappend` (s
acGapExtension, a -> Step a
forall b1 a b2. b1 -> Either (Either a b1) b2
stepRight a
b)
let b_gap_max :: Trace a s
b_gap_max = (Trace a s -> Trace a s -> Ordering) -> [Trace a s] -> Trace a s
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
L.maximumBy ((Trace a s -> s) -> Trace a s -> Trace a s -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Trace a s -> s
forall a s. Trace a s -> s
traceScore) [Trace a s
b_gap1, Trace a s
b_gap2]
let maxi :: Trace a s
maxi = (Trace a s -> Trace a s -> Ordering) -> [Trace a s] -> Trace a s
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
L.maximumBy ((Trace a s -> s) -> Trace a s -> Trace a s -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Trace a s -> s
forall a s. Trace a s -> s
traceScore) [Trace a s
diag_max, Trace a s
a_gap_max, Trace a s
b_gap_max]
AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
forall (m :: * -> *) a. Monad m => a -> m a
return (AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s))
-> AffineTrace a s
-> StateT (Map (Int, Int) (AffineTrace a s)) m (AffineTrace a s)
forall a b. (a -> b) -> a -> b
$ Trace a s -> Trace a s -> Trace a s -> AffineTrace a s
forall a s. Trace a s -> Trace a s -> Trace a s -> AffineTrace a s
AffineTrace Trace a s
maxi Trace a s
a_gap_max Trace a s
b_gap_max
skipInit :: Int -> (t -> Step a) -> v t -> AffineTrace a s
skipInit idx :: Int
idx stepFun :: t -> Step a
stepFun xs :: v t
xs =
let score :: s
score = s
acGapOpen s -> s -> s
forall a. Num a => a -> a -> a
+ s
acGapExtension s -> s -> s
forall a. Num a => a -> a -> a
* Int -> s
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
tr :: [Step a]
tr = [Step a] -> [Step a]
forall a. [a] -> [a]
reverse [t -> Step a
stepFun (v t
xs v t -> Int -> t
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
G.! Int
xi) | Int
xi <- [0..Int
idx]]
in Trace a s -> Trace a s -> Trace a s -> AffineTrace a s
forall a s. Trace a s -> Trace a s -> Trace a s -> AffineTrace a s
AffineTrace (s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace s
score [Step a]
tr) (s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace s
score [Step a]
tr) (s -> [Step a] -> Trace a s
forall a s. s -> [Step a] -> Trace a s
Trace s
score [Step a]
tr)
debugAlign :: [Step Char] -> String
debugAlign :: [Step Char] -> String
debugAlign = String -> String -> [Step Char] -> String
go [] []
where
go :: String -> String -> [Step Char] -> String
go as :: String
as bs :: String
bs [] = ShowS
forall a. [a] -> [a]
reverse String
as String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
reverse String
bs
go as :: String
as bs :: String
bs (t :: Step Char
t:ts :: [Step Char]
ts) = case Step Char
t of
Left (Left c :: Char
c) -> String -> String -> [Step Char] -> String
go (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
as) ('-'Char -> ShowS
forall a. a -> [a] -> [a]
:String
bs) [Step Char]
ts
Left (Right c :: Char
c) -> String -> String -> [Step Char] -> String
go ('-'Char -> ShowS
forall a. a -> [a] -> [a]
:String
as) (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
bs) [Step Char]
ts
Right (c :: Char
c, d :: Char
d) -> String -> String -> [Step Char] -> String
go (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
as) (Char
dChar -> ShowS
forall a. a -> [a] -> [a]
:String
bs) [Step Char]
ts
debugStrAlign :: [Step String] -> String
debugStrAlign :: [Step String] -> String
debugStrAlign = ShowS -> ShowS -> [Step String] -> String
forall a.
(String -> [a]) -> (String -> [a]) -> [Step String] -> [a]
go ShowS
forall a. a -> a
id ShowS
forall a. a -> a
id
where
go :: (String -> [a]) -> (String -> [a]) -> [Step String] -> [a]
go as :: String -> [a]
as bs :: String -> [a]
bs [] = String -> [a]
as "|\n" [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ String -> [a]
bs "|"
go as :: String -> [a]
as bs :: String -> [a]
bs (t :: Step String
t:ts :: [Step String]
ts) = case Step String
t of
Left (Left c :: String
c) -> (String -> [a]) -> (String -> [a]) -> [Step String] -> [a]
go (String -> [a]
as (String -> [a]) -> ShowS -> String -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("|"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++))
(String -> [a]
bs (String -> [a]) -> ShowS -> String -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("|"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ShowS
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c) (Char -> String
forall a. a -> [a]
repeat '-') String -> ShowS
forall a. [a] -> [a] -> [a]
++)) [Step String]
ts
Left (Right c :: String
c) -> (String -> [a]) -> (String -> [a]) -> [Step String] -> [a]
go (String -> [a]
as (String -> [a]) -> ShowS -> String -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("|"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ShowS
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c) (Char -> String
forall a. a -> [a]
repeat '-') String -> ShowS
forall a. [a] -> [a] -> [a]
++))
(String -> [a]
bs (String -> [a]) -> ShowS -> String -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("|"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++)) [Step String]
ts
Right (c :: String
c,d :: String
d) -> (String -> [a]) -> (String -> [a]) -> [Step String] -> [a]
go (String -> [a]
as (String -> [a]) -> ShowS -> String -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("|"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
filldc String -> ShowS
forall a. [a] -> [a] -> [a]
++))
(String -> [a]
bs (String -> [a]) -> ShowS -> String -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("|"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
d String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
fillcd String -> ShowS
forall a. [a] -> [a] -> [a]
++)) [Step String]
ts
where
fill :: Int -> String
fill n :: Int
n = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. a -> [a]
repeat ' '
filldc :: String
filldc = Int -> String
fill (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c)
fillcd :: String
fillcd = Int -> String
fill (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
d)
data MultiStep a = MultiStep
{ MultiStep a -> Maybe a
center :: Maybe a
, MultiStep a -> [Maybe a]
others :: [Maybe a]
}
data MultiTrace i a s = MultiTrace
{ MultiTrace i a s -> i
centerIndex :: i
, MultiTrace i a s -> [i]
otherIndices :: [i]
, MultiTrace i a s -> [MultiStep a]
multiTrace :: [MultiStep a]
}
stepOfAll :: MultiStep a -> [Maybe a]
stepOfAll :: MultiStep a -> [Maybe a]
stepOfAll MultiStep{..} = Maybe a
centerMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
others
allIndices :: MultiTrace i a s -> [i]
allIndices :: MultiTrace i a s -> [i]
allIndices MultiTrace{..} = i
centerIndexi -> [i] -> [i]
forall a. a -> [a] -> [a]
:[i]
otherIndices
centerStar :: (G.Vector v a, Num s, Ord s, Ord i)
=> AlignConfig a s
-> [(i, v a)]
-> MultiTrace i a s
centerStar :: AlignConfig a s -> [(i, v a)] -> MultiTrace i a s
centerStar conf :: AlignConfig a s
conf vs :: [(i, v a)]
vs =
let (firstPair :: ((i, i), Trace a s)
firstPair:rest :: [((i, i), Trace a s)]
rest) = [((i, i), Trace a s)]
centerPairs
initialTrace :: MultiTrace i a s
initialTrace = MultiTrace :: forall i a s. i -> [i] -> [MultiStep a] -> MultiTrace i a s
MultiTrace
{ centerIndex :: i
centerIndex = (i, i) -> i
forall a b. (a, b) -> a
fst ((i, i) -> i)
-> (((i, i), Trace a s) -> (i, i)) -> ((i, i), Trace a s) -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((i, i), Trace a s) -> (i, i)
forall a b. (a, b) -> a
fst (((i, i), Trace a s) -> i) -> ((i, i), Trace a s) -> i
forall a b. (a -> b) -> a -> b
$ ((i, i), Trace a s)
firstPair
, otherIndices :: [i]
otherIndices = [(i, i) -> i
forall a b. (a, b) -> b
snd ((i, i) -> i)
-> (((i, i), Trace a s) -> (i, i)) -> ((i, i), Trace a s) -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((i, i), Trace a s) -> (i, i)
forall a b. (a, b) -> a
fst (((i, i), Trace a s) -> i) -> ((i, i), Trace a s) -> i
forall a b. (a -> b) -> a -> b
$ ((i, i), Trace a s)
firstPair]
, multiTrace :: [MultiStep a]
multiTrace = [Either (Either a a) (a, a)] -> [MultiStep a]
forall a. [Either (Either a a) (a, a)] -> [MultiStep a]
initialSteps ([Either (Either a a) (a, a)] -> [MultiStep a])
-> (((i, i), Trace a s) -> [Either (Either a a) (a, a)])
-> ((i, i), Trace a s)
-> [MultiStep a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace a s -> [Either (Either a a) (a, a)]
forall a s. Trace a s -> [Step a]
trace (Trace a s -> [Either (Either a a) (a, a)])
-> (((i, i), Trace a s) -> Trace a s)
-> ((i, i), Trace a s)
-> [Either (Either a a) (a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((i, i), Trace a s) -> Trace a s
forall a b. (a, b) -> b
snd (((i, i), Trace a s) -> [MultiStep a])
-> ((i, i), Trace a s) -> [MultiStep a]
forall a b. (a -> b) -> a -> b
$ ((i, i), Trace a s)
firstPair
}
in (MultiTrace i a s -> ((i, i), Trace a s) -> MultiTrace i a s)
-> MultiTrace i a s -> [((i, i), Trace a s)] -> MultiTrace i a s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MultiTrace i a s -> ((i, i), Trace a s) -> MultiTrace i a s
forall a a s a s s.
MultiTrace a a s -> ((a, a), Trace a s) -> MultiTrace a a s
mergePair MultiTrace i a s
forall s. MultiTrace i a s
initialTrace [((i, i), Trace a s)]
rest
where
initialSteps :: [Either (Either a a) (a, a)] -> [MultiStep a]
initialSteps = [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
forall a.
[MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go []
where
go :: [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go acc :: [MultiStep a]
acc [] = [MultiStep a] -> [MultiStep a]
forall a. [a] -> [a]
reverse [MultiStep a]
acc
go acc :: [MultiStep a]
acc (s :: Either (Either a a) (a, a)
s:xs :: [Either (Either a a) (a, a)]
xs) = [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Either (Either a a) (a, a) -> [Maybe a] -> MultiStep a
forall a. Either (Either a a) (a, a) -> [Maybe a] -> MultiStep a
conv Either (Either a a) (a, a)
s []MultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) [Either (Either a a) (a, a)]
xs
conv :: Either (Either a a) (a, a) -> [Maybe a] -> MultiStep a
conv s :: Either (Either a a) (a, a)
s rest :: [Maybe a]
rest = case Either (Either a a) (a, a)
s of
Right (c :: a
c, d :: a
d) -> Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep (a -> Maybe a
forall a. a -> Maybe a
Just a
c) (a -> Maybe a
forall a. a -> Maybe a
Just a
dMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
rest)
Left (Left c :: a
c) -> Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep (a -> Maybe a
forall a. a -> Maybe a
Just a
c) (Maybe a
forall a. Maybe a
NothingMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
rest)
Left (Right d :: a
d) -> Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just a
dMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
rest)
mergePair :: MultiTrace a a s -> ((a, a), Trace a s) -> MultiTrace a a s
mergePair MultiTrace{..} ((_,j :: a
j), tr :: Trace a s
tr) = MultiTrace :: forall i a s. i -> [i] -> [MultiStep a] -> MultiTrace i a s
MultiTrace
{ centerIndex :: a
centerIndex = a
centerIndex
, otherIndices :: [a]
otherIndices = a
ja -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
otherIndices
, multiTrace :: [MultiStep a]
multiTrace = [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
forall a.
[MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
mergeSteps [MultiStep a]
multiTrace (Trace a s -> [Either (Either a a) (a, a)]
forall a s. Trace a s -> [Step a]
trace Trace a s
tr)
}
where
mergeSteps :: [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
mergeSteps mss' :: [MultiStep a]
mss' = [MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
forall a.
[MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go [] [MultiStep a]
mss'
where
noOthers :: [Maybe a]
noOthers = (Maybe a -> Maybe a) -> [Maybe a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> Maybe a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) ([Maybe a] -> [Maybe a])
-> ([MultiStep a] -> [Maybe a]) -> [MultiStep a] -> [Maybe a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiStep a -> [Maybe a]
forall a. MultiStep a -> [Maybe a]
others (MultiStep a -> [Maybe a])
-> ([MultiStep a] -> MultiStep a) -> [MultiStep a] -> [Maybe a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MultiStep a] -> MultiStep a
forall a. [a] -> a
head ([MultiStep a] -> [Maybe a]) -> [MultiStep a] -> [Maybe a]
forall a b. (a -> b) -> a -> b
$ [MultiStep a]
mss'
go :: [MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go acc :: [MultiStep a]
acc [] [] = [MultiStep a] -> [MultiStep a]
forall a. [a] -> [a]
reverse [MultiStep a]
acc
go acc :: [MultiStep a]
acc (MultiStep{..}:mss :: [MultiStep a]
mss) [] =
[MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep Maybe a
center (Maybe a
forall a. Maybe a
NothingMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
others)MultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) [MultiStep a]
mss []
go acc :: [MultiStep a]
acc [] (s :: Either (Either a a) (a, a)
s:ss :: [Either (Either a a) (a, a)]
ss) = [MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Either (Either a a) (a, a) -> [Maybe a] -> MultiStep a
forall a. Either (Either a a) (a, a) -> [Maybe a] -> MultiStep a
conv Either (Either a a) (a, a)
s [Maybe a]
forall a. [Maybe a]
noOthersMultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) [] [Either (Either a a) (a, a)]
ss
go acc :: [MultiStep a]
acc (m :: MultiStep a
m@MultiStep{..}:mss :: [MultiStep a]
mss) (s :: Either (Either a a) (a, a)
s:ss :: [Either (Either a a) (a, a)]
ss) = case (Maybe a
center, Either (Either a a) (a, a)
s) of
(Nothing, Left (Right d :: a
d)) ->
[MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep Maybe a
center (a -> Maybe a
forall a. a -> Maybe a
Just a
dMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
others)MultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) [MultiStep a]
mss [Either (Either a a) (a, a)]
ss
(Nothing, _) ->
[MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep Maybe a
center (Maybe a
forall a. Maybe a
NothingMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
others)MultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) [MultiStep a]
mss (Either (Either a a) (a, a)
sEither (Either a a) (a, a)
-> [Either (Either a a) (a, a)] -> [Either (Either a a) (a, a)]
forall a. a -> [a] -> [a]
:[Either (Either a a) (a, a)]
ss)
(Just _, Right (_, d :: a
d)) ->
[MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep Maybe a
center (a -> Maybe a
forall a. a -> Maybe a
Just a
dMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
others)MultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) [MultiStep a]
mss [Either (Either a a) (a, a)]
ss
(Just _, Left (Left _)) ->
[MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep Maybe a
center (Maybe a
forall a. Maybe a
NothingMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
others)MultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) [MultiStep a]
mss [Either (Either a a) (a, a)]
ss
(Just _, Left (Right d :: a
d)) ->
[MultiStep a]
-> [MultiStep a] -> [Either (Either a a) (a, a)] -> [MultiStep a]
go (Maybe a -> [Maybe a] -> MultiStep a
forall a. Maybe a -> [Maybe a] -> MultiStep a
MultiStep Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just a
dMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
forall a. [Maybe a]
noOthers)MultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
acc) (MultiStep a
mMultiStep a -> [MultiStep a] -> [MultiStep a]
forall a. a -> [a] -> [a]
:[MultiStep a]
mss) [Either (Either a a) (a, a)]
ss
centerPairs :: [((i, i), Trace a s)]
centerPairs
= (s, [((i, i), Trace a s)]) -> [((i, i), Trace a s)]
forall a b. (a, b) -> b
snd
((s, [((i, i), Trace a s)]) -> [((i, i), Trace a s)])
-> ([((i, i), Trace a s)] -> (s, [((i, i), Trace a s)]))
-> [((i, i), Trace a s)]
-> [((i, i), Trace a s)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((s, [((i, i), Trace a s)])
-> (s, [((i, i), Trace a s)]) -> Ordering)
-> [(s, [((i, i), Trace a s)])] -> (s, [((i, i), Trace a s)])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
L.maximumBy (((s, [((i, i), Trace a s)]) -> s)
-> (s, [((i, i), Trace a s)])
-> (s, [((i, i), Trace a s)])
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (s, [((i, i), Trace a s)]) -> s
forall a b. (a, b) -> a
fst)
([(s, [((i, i), Trace a s)])] -> (s, [((i, i), Trace a s)]))
-> ([((i, i), Trace a s)] -> [(s, [((i, i), Trace a s)])])
-> [((i, i), Trace a s)]
-> (s, [((i, i), Trace a s)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([((i, i), Trace a s)] -> (s, [((i, i), Trace a s)]))
-> [[((i, i), Trace a s)]] -> [(s, [((i, i), Trace a s)])]
forall a b. (a -> b) -> [a] -> [b]
map (\g :: [((i, i), Trace a s)]
g -> ([((i, i), Trace a s)] -> s
forall a a. [(a, Trace a s)] -> s
starSum [((i, i), Trace a s)]
g, [((i, i), Trace a s)]
g))
([[((i, i), Trace a s)]] -> [(s, [((i, i), Trace a s)])])
-> ([((i, i), Trace a s)] -> [[((i, i), Trace a s)]])
-> [((i, i), Trace a s)]
-> [(s, [((i, i), Trace a s)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((i, i), Trace a s) -> ((i, i), Trace a s) -> Bool)
-> [((i, i), Trace a s)] -> [[((i, i), Trace a s)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (i -> i -> Bool
forall a. Eq a => a -> a -> Bool
(==) (i -> i -> Bool)
-> (((i, i), Trace a s) -> i)
-> ((i, i), Trace a s)
-> ((i, i), Trace a s)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((i, i) -> i
forall a b. (a, b) -> a
fst ((i, i) -> i)
-> (((i, i), Trace a s) -> (i, i)) -> ((i, i), Trace a s) -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((i, i), Trace a s) -> (i, i)
forall a b. (a, b) -> a
fst))
([((i, i), Trace a s)] -> [[((i, i), Trace a s)]])
-> ([((i, i), Trace a s)] -> [((i, i), Trace a s)])
-> [((i, i), Trace a s)]
-> [[((i, i), Trace a s)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((i, i), Trace a s) -> ((i, i), Trace a s) -> Ordering)
-> [((i, i), Trace a s)] -> [((i, i), Trace a s)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy ((((i, i), Trace a s) -> (i, i))
-> ((i, i), Trace a s) -> ((i, i), Trace a s) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((i, i), Trace a s) -> (i, i)
forall a b. (a, b) -> a
fst)
([((i, i), Trace a s)] -> [((i, i), Trace a s)])
-> [((i, i), Trace a s)] -> [((i, i), Trace a s)]
forall a b. (a -> b) -> a -> b
$ [((i, i), Trace a s)]
pairAligns
where
pairAligns :: [((i, i), Trace a s)]
pairAligns = do
((i :: i
i,v :: v a
v):rest :: [(i, v a)]
rest) <- [(i, v a)] -> [[(i, v a)]]
forall a. [a] -> [[a]]
L.tails [(i, v a)]
vs
(j :: i
j,w :: v a
w) <- [(i, v a)]
rest
let tr :: Trace a s
tr = AlignConfig a s -> v a -> v a -> Trace a s
forall (v :: * -> *) a s.
(Vector v a, Num s, Ord s) =>
AlignConfig a s -> v a -> v a -> Trace a s
align AlignConfig a s
conf v a
v v a
w
[((i
i,i
j), Trace a s
tr), ((i
j,i
i), Trace a s -> Trace a s
forall a s. Trace a s -> Trace a s
flipLR Trace a s
tr)]
where
flipLR :: Trace a s -> Trace a s
flipLR tr :: Trace a s
tr = Trace a s
tr { trace :: [Step a]
trace = (Step a -> Step a) -> [Step a] -> [Step a]
forall a b. (a -> b) -> [a] -> [b]
map Step a -> Step a
forall b a b a.
Either (Either b a) (b, a) -> Either (Either a b) (a, b)
go ([Step a] -> [Step a])
-> (Trace a s -> [Step a]) -> Trace a s -> [Step a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace a s -> [Step a]
forall a s. Trace a s -> [Step a]
trace (Trace a s -> [Step a]) -> Trace a s -> [Step a]
forall a b. (a -> b) -> a -> b
$ Trace a s
tr }
where
go :: Either (Either b a) (b, a) -> Either (Either a b) (a, b)
go (Left (Left a :: b
a)) = Either a b -> Either (Either a b) (a, b)
forall a b. a -> Either a b
Left (b -> Either a b
forall a b. b -> Either a b
Right b
a)
go (Left (Right a :: a
a)) = Either a b -> Either (Either a b) (a, b)
forall a b. a -> Either a b
Left (a -> Either a b
forall a b. a -> Either a b
Left a
a)
go (Right (c :: b
c,d :: a
d)) = (a, b) -> Either (Either a b) (a, b)
forall a b. b -> Either a b
Right (a
d,b
c)
starSum :: [(a, Trace a s)] -> s
starSum = [s] -> s
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([s] -> s) -> ([(a, Trace a s)] -> [s]) -> [(a, Trace a s)] -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Trace a s) -> s) -> [(a, Trace a s)] -> [s]
forall a b. (a -> b) -> [a] -> [b]
map (Trace a s -> s
forall a s. Trace a s -> s
traceScore (Trace a s -> s)
-> ((a, Trace a s) -> Trace a s) -> (a, Trace a s) -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Trace a s) -> Trace a s
forall a b. (a, b) -> b
snd)
debugMultiAlign :: [MultiStep Char] -> String
debugMultiAlign :: [MultiStep Char] -> String
debugMultiAlign =
[String] -> String
unlines ([String] -> String)
-> ([MultiStep Char] -> [String]) -> [MultiStep Char] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe Char] -> String) -> [[Maybe Char]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe Char -> Char) -> [Maybe Char] -> String
forall a b. (a -> b) -> [a] -> [b]
map Maybe Char -> Char
charOrDash) ([[Maybe Char]] -> [String])
-> ([MultiStep Char] -> [[Maybe Char]])
-> [MultiStep Char]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe Char]] -> [[Maybe Char]]
forall a. [[a]] -> [[a]]
L.transpose ([[Maybe Char]] -> [[Maybe Char]])
-> ([MultiStep Char] -> [[Maybe Char]])
-> [MultiStep Char]
-> [[Maybe Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiStep Char -> [Maybe Char])
-> [MultiStep Char] -> [[Maybe Char]]
forall a b. (a -> b) -> [a] -> [b]
map MultiStep Char -> [Maybe Char]
forall a. MultiStep a -> [Maybe a]
stepOfAll
where
charOrDash :: Maybe Char -> Char
charOrDash = Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe '-'