module Main where

type VSeqs = (Integer,[(String,String)]) -- valued sequences


type VS_matrix = [[VSeqs]]


emptyVS :: VSeqs
emptyVS = (0,[("","")])

rightmostCol :: String -> [VSeqs]
rightmostCol "" = [emptyVS]
rightmostCol (c:cs) = (v-1,[('~':s1,c:s2)]) : above
                      where above@((v,(s1,s2):_):_) = rightmostCol cs


nextCol :: Char -> String -> [VSeqs] -> [VSeqs]
nextCol c "" ((v,(s1,s2):_):_) = (v-1,(c:s1,'~':s2):[]):[]
nextCol c str2 (vs:vsr) = makeEntry c str2 (head above) vs (head vsr) : above
                          where above = nextCol c (tail str2) vsr


makeEntry :: Char-> String -> VSeqs -> VSeqs -> VSeqs -> VSeqs
makeEntry c str2@(h:_) above@(va,sa) right@(vr,sr) aboveright@(vd,sd) = maxEntry fa fr fd
                                                                        where fa = (va-1, append '~' h  sa )
                                                                              fr = (vr-1, append  c '~' sr )
                                                                              fd = (vd+v, append  c  h  sd )
                                                                              v = if c==h then 1 else -1
                                                                              append l r tups = [ (l:ls,r:rs) | (ls,rs)<-tups ]

maxEntry :: VSeqs -> VSeqs -> VSeqs -> VSeqs
maxEntry a@(va,_) b@(vb,_) c@(vc,_) = if va>vb then if va>vc then a
                                                             else c
                                               else if vb>vc then b
                                                             else c
                          
                          
fillmatrix :: String -> String -> VS_matrix
fillmatrix str1 str2 = scanr xcc (rightmostCol str2) str1
                       where xcc :: Char -> [VSeqs] -> [VSeqs]
                             xcc x s = nextCol x str2 s


findBestSeqs :: String -> String -> VSeqs
findBestSeqs str1 str2 = head $ head $ fillmatrix str1 str2




main :: IO ()
main = do putStr                         "\"icecream\" \"scheme\"  : "
          putStrLn $ show $ findBestSeqs   "icecream"   "scheme"
          putStr                         "\"hate\"     \"hatter\"  : "
          putStrLn $ show $ findBestSeqs   "hate"       "hatter"
          putStr                         "\"scheme\"   \"saturn\"  : "
          putStrLn $ show $ findBestSeqs   "scheme"     "saturn"
          putStr                         "\"saturn\"   \"scheme\"  : "
          putStrLn $ show $ findBestSeqs   "saturn"     "scheme"
          putStr                         "\"saturn\"   \"hatter\"  : "
          putStrLn $ show $ findBestSeqs   "saturn"     "hatter"
          putStr                         "\"hatter\"   \"saturn\"  : "
          putStrLn $ show $ findBestSeqs   "hatter"     "saturn"
          putStr                         "\"mad\"      \"saturn\"  : "
          putStrLn $ show $ findBestSeqs   "mad"        "saturn"
          putStr                         "\"snowball\" \"icecream\": "
          putStrLn $ show $ findBestSeqs   "snowball"   "icecream"
          putStr                         "\"mad\"      \"computer\": "
          putStrLn $ show $ findBestSeqs   "mad"        "computer"
          putStr                         "\"mad\"      \"snowball\": "
          putStrLn $ show $ findBestSeqs   "mad"        "snowball"

          
{-




--Sample Sequences
icecream = "icecream"
scheme = "scheme"
saturn = "saturn"  -- "saaturn"
mad = ['m','a','d']
hatter = ['h','a','t','t','e','r']
hate = ['h','a','t','e']
snowball = ['s','n','o','w','b','a','l','l']
computer = ['c','o','m','p','u','t','e','r']
coffee = ['c','o','f','f','e','e']


--Function that's called in a console window which does the sequence 
--alignment and puts the two optimal sequences back together
printSeq :: String -> String -> (String,String)
printSeq s1 s2 = unzip (getSeq s1 s2)


--Main function of the program which does the actual sequence alignment
getSeq :: String -> String -> [(Char,Char)]
getSeq [] [] = []
getSeq [] s2 = case2 [] s2
getSeq s1 [] = case3 s1 []
getSeq s1 s2 = let a1 = case1 s1 s2;
                   a2 = case2 s1 s2;
                   a3 = case3 s1 s2;
               in maxSeq a1 a2 a3


case1 :: [Char] -> [Char] -> [(Char,Char)]
case1 s1 s2 = [(head s1,head s2)] ++ getSeq (tail s1) (tail s2)

case2 :: [Char] -> [Char] -> [(Char,Char)]
case2 s1 s2 = [('-',head s2)] ++ getSeq s1 (tail s2)

case3 :: [Char] -> [Char] -> [(Char,Char)]
case3 s1 s2 = [(head s1,'-')] ++ getSeq (tail s1) s2


--Grab the score of one tuple (a possible alignment)
score :: (Eq a) => (a,a) -> Integer
score (c1,c2) | c1==c2    = 1
              | otherwise = -1
            
--Sum up the score for a sequence
scoreSum :: (Eq a) => [(a,a)] -> Integer
scoreSum seq = sum $ map score seq


--Returns a solution
maxSeq :: (Eq a) => [(a,a)] -> [(a,a)] -> [(a,a)] -> [(a,a)]
maxSeq a1 a2 a3
        | s1 > s2 && s1 > s3 = a1
        | s3 > s1 && s3 > s2 = a3
        | otherwise          = a2
        where s1 = scoreSum a1
              s2 = scoreSum a2
              s3 = scoreSum a3

-}