-- | The Nussinov RNA secondary structure prediction problem.

module Main where

import           Control.Applicative ()
import           Control.Monad
import           Control.Monad.ST
import           Data.Char (toUpper,toLower)
import           Data.List
import           Data.Vector.Fusion.Util
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import           Data.Vector.Unboxed (Vector)
import           Text.Printf
import           Data.Sequence ((|>),Seq,empty)
import           Data.Foldable (toList)

import           ADP.Fusion.PointL
import           Data.PrimitiveArray as PA hiding (map,toList)
import           FormalLanguage.CFG

import           FormalLanguage.GrammarProduct



[grammarProduct|
Grammar: Step
N: X
T: c
S: X
X -> stp <<< X c
X -> del <<< X
//
Grammar: Stand
N: X
S: X
X -> del <<< X
//
Grammar: Done
N: X
S: X
X -> don <<< e
//
Product: Glbl
Step >< Step  -  Stand * 2  +  Done * 2
//
Emit: Glbl
|]

makeAlgebraProduct ''SigGlbl



score :: Monad m => SigGlbl m Int Int Char Char
score = SigGlbl
  { donDon = \   (Z:.():.()) -> 0
  , stpStp = \ x (Z:.a :.b ) -> if a==b then x+1 else -999999
  , delStp = \ x (Z:.():.b ) -> x - 2
  , stpDel = \ x (Z:.a :.()) -> x - 2
  , h       = SM.foldl' max (-999999)
  }
{-# INLINE score #-}

-- |
--
-- TODO use fmlist to make this more efficient.

pretty :: Monad m => SigGlbl m (String,String) [(String,String)] Char Char
pretty = SigGlbl
  { donDon = \       (Z:.():.()) -> ("","")
  , stpStp = \ (x,y) (Z:.a :.b ) -> (x ++ [a],y ++ [b])
  , delStp = \ (x,y) (Z:.():.b ) -> (x ++ "-",y ++ [b])
  , stpDel = \ (x,y) (Z:.a :.()) -> (x ++ [a],y ++ "-")
  , h      = SM.toList
  }

runNeedlemanWunsch :: Int -> String -> String -> (Int,[(String,String)],String)
runNeedlemanWunsch k i1' i2' = (d, take k . unId $ axiom b, show perf) where
  i1 = VU.fromList i1'
  i2 = VU.fromList i2'
  Mutated (Z:.t) perf eachPerf = runNeedlemanWunschForward i1 i2
  d = unId $ axiom t
  !(Z:.b) = gGlbl (score <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i1) (chr i2)
{-# NoInline runNeedlemanWunsch #-}

-- | Decoupling the forward phase for CORE observation.

runNeedlemanWunschForward
  :: Vector Char
  -> Vector Char
  -> Mutated (Z:.TwITbl 0 0 Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int)
{-# NoInline runNeedlemanWunschForward #-}
runNeedlemanWunschForward i1 i2 = runST $ do
  arr <- newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)
  ts <- fillTables $ gGlbl score
          (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)
          (chr i1) (chr i2)
  return ts
  where !n1 = VU.length i1
        !n2 = VU.length i2
  {-
    -}

main = do
  ls <- lines <$> getContents
  let eats [] = return ()
      eats [x] = return ()
      eats (a:b:xs) = do
        putStrLn a
        putStrLn b
        let (k,ys,p) = runNeedlemanWunsch 1 a b
        forM_ ys $ \(y1,y2) -> printf "%s %5d\n%s\n" y1 k y2
        putStrLn p
        eats xs
  eats ls