{-# LANGUAGE RecordWildCards #-}
-- | Pairwise & multi-sequence alignment with an affine gap penalty model. Forked from "Data.Align". This algorithm uses a gap opening penalty and a gap extension penalty to score alignments.
module Data.Align.Affine
  (
  -- * Global alignment
  align
  , AlignConfig
  , alignConfig
  , Step
  , Trace, traceScore, trace
  , debugAlign, debugStrAlign
  -- * Multi-sequence alignment
  , 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

-- | Either an unmatched item or a match.
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)

-- | The result of the alignment.
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
  }

-- | This algorithm uses an affine gap penalty model. See section 12.6 "Convex gap weights" in Gusfield 1997: <https://doi.org/10.1017/CBO9780511574931>.
alignConfig :: (a -> a -> s)   -- ^ Scoring function.
            -> s               -- ^ Gap opening score.
            -> s               -- ^ Gap extension score.
            -> 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

-- | Aligns two sequences using the Needleman-Wunsch algorithm. See Needleman & Wunsch 1970: <https://doi.org/10.1016/0022-2836(70)90057-4>.
align :: (G.Vector v a, Num s, Ord s)
  => AlignConfig a s
  -> v a  -- ^ Left sequence.
  -> v a  -- ^ Right sequence.
  -> 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)

-- | Utility for displaying a Char-based alignment.
--
-- == Example
-- 
-- > >>> :{
-- > let tr = align (alignConfig (\a b -> if a == b then 0.5 else (-0.5)) 
-- >                            (-3) (-0.25)) 
-- >               (Data.Vector.fromList "circumambulate") 
-- >               (Data.Vector.fromList "perambulatory")
-- > in do
-- >   print $ traceScore tr
-- >   putStrLn . debugAlign . trace $ tr
-- > :}
-- 
-- == Output
--
-- > -4.75
-- > circumambulate--
-- > per---ambulatory
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

-- | Utility for displaying a String-based alignment.
-- 
-- == Example
--
-- >>> :{
-- let tr = align (alignConfig (\a b -> if a == b then 0.5 else (-0.5)) 
--                             (-3) (-0.25)) 
--                (Data.Vector.fromList ["kra","ya","ṇā","ddha","ra","ṇā","tyā","cñā","yāḥ"]) 
--                (Data.Vector.fromList ["bha","ra","ṇā","da","pa","ha","ra","ṇā","tyā","cña","yā"])
-- in do
--    print $ traceScore tr
--    putStrLn . debugStrAlign . trace $ tr
-- :}
--
-- == Output
--
-- > -4.0
-- > |kra|ya|ṇā|ddha|--|--|ra|ṇā|tyā|cñā|yāḥ|
-- > |bha|ra|ṇā|da  |pa|ha|ra|ṇā|tyā|cñā|yā |
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)

-- | A step in a multi-sequence alignment.
data MultiStep a = MultiStep
  { MultiStep a -> Maybe a
center :: Maybe a    -- ^ 'Nothing' means gap insertion.
  , MultiStep a -> [Maybe a]
others :: [Maybe a]  -- ^ Parallel to 'otherIndices'.
  }

-- | The result of a multi-sequence alignment.
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]
  }

-- | The center step followed by other steps.
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

-- | The center index followed by other indices.
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

-- | Align multiple sequences using the Center Star method. 
--
-- See, for example, section 14.6.2, "A bounded-error approximation method for SP alignment" in Gusfield 1997.
-- 
-- Assumes the list of sequences to have length > 1, and the indices to be unique.
centerStar :: (G.Vector v a, Num s, Ord s, Ord i)
  => AlignConfig a s
  -> [(i, v a)]  -- TODO use internal indices rather to make uniqueness sure
  -> 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  -- drop cache
    ((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))  -- cache scores
    ([[((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)

-- | Renders a char-based multi-alignment result to a string.
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 '-'