FormalGrammars-0.2.0.0: src/Nussinov.hs

-- | 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 as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import           Text.Printf
import           Unsafe.Coerce (unsafeCoerce)

import           ADP.Fusion
import           Data.PrimitiveArray as PA hiding (map)

import           FormalLanguage



-- | Define signature and grammar

[formalLanguage|
Verbose

Grammar: Nussinov
N: X
T: c
S: X
X -> unp <<< X c
X -> jux <<< X c X c
X -> nil <<< e
//

Outside: Vonissun
Source:  Nussinov
//

Emit: Nussinov
Emit: Vonissun
|]



makeAlgebraProduct ''SigNussinov
makeAlgebraProduct ''SigVonissun

bpmax :: Monad m => SigNussinov m Int Int Char
bpmax = SigNussinov
  { nUnp = \ x c     -> x
  , nJux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999
  , nNil = \ ()      -> 0
  , nH   = SM.foldl' max 0
  }
{-# INLINE bpmax #-}

bpmaxV :: Monad m => SigVonissun m Int Int Char
bpmaxV = undefined

pairs !c !d
  =  c=='A' && d=='U'
  || c=='C' && d=='G'
  || c=='G' && d=='C'
  || c=='G' && d=='U'
  || c=='U' && d=='A'
  || c=='U' && d=='G'
{-# INLINE pairs #-}

pretty :: Monad m => SigNussinov m String [String] Char
pretty = SigNussinov
  { nUnp = \ x c     -> x ++ "."
  , nJux = \ x c y d -> x ++ "(" ++ y ++ ")"
  , nNil = \ ()      -> ""
  , nH   = SM.toList
  }
{-# INLINE pretty #-}

prettyV :: Monad m => SigVonissun m String [String] Char
prettyV = undefined

runNussinov :: Int -> String -> (Int,[String]) -- ,Int,[String])
runNussinov k inp = (d, take k . unId $ axiom b) where
  i = VU.fromList . Prelude.map toUpper $ inp
  n = VU.length i
  !(Z:.t) = mutateTablesDefault
          $ gNussinov bpmax
              (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))
              (chr i)
              :: Z:.ITbl Id Unboxed Subword Int
  d = unId $ axiom t
  !(Z:.b) = gNussinov (bpmax <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i)
{-# NoInline runNussinov #-}

runVonissun :: Int -> String -> (Int,[String])
runVonissun k inp = (d, []) where -- take k . unId $ axiom b) where
  i = VU.fromList . Prelude.map toUpper $ inp
  n = VU.length i
  !(Z:.t) = mutateTablesDefault
          $ gVonissun bpmaxV
              (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-999999) []))
              (undefined :: ITbl Id Unboxed Subword Int)
              (chr i)
              :: Z:.ITbl Id Unboxed (Outside Subword) Int
  d = unId $ axiom t
--  !(Z:.b) = gVonissun (bpmaxV <|| prettyV) (toBacktrack t (undefined :: Id a -> Id a)) (undefined :: Backtrack (ITbl Id Unboxed Subword Int) Id Id String) (chr i)
{-# NoInline runVonissun #-}



main = do
  ls <- lines <$> getContents
  forM_ ls $ \l -> do
    putStrLn l
    let (k,[x]) = runNussinov 1 l
    printf "%s %5d\n" x k