module Biobase.Secondary.Vienna where
import Data.Aeson
import Data.Binary
import Data.Ix
import Data.Primitive.Types
import Data.Serialize (Serialize(..))
import Data.Tuple (swap)
import Data.Vector.Fusion.Stream.Monadic (map,flatten,Step(..))
import Data.Vector.Fusion.Stream.Size (Size (Unknown))
import Data.Vector.Unboxed.Deriving
import GHC.Base (remInt,quotInt)
import GHC.Generics (Generic)
import Prelude hiding (map)
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector.Unboxed as VU
import qualified Prelude as P
import Data.PrimitiveArray hiding (Complement(..),map)
import Biobase.Primary.Letter
import Biobase.Primary.Nuc
import Biobase.Primary.Nuc.RNA
newtype ViennaPair = ViennaPair { unViennaPair :: Int }
deriving (Eq,Ord,Generic,Ix)
instance Binary (ViennaPair)
instance Serialize (ViennaPair)
instance FromJSON (ViennaPair)
instance ToJSON (ViennaPair)
instance Index ViennaPair where
linearIndex _ _ (ViennaPair p) = p
smallestLinearIndex _ = error "still needed?"
largestLinearIndex (ViennaPair p) = p
size _ (ViennaPair h) = h+1
inBounds (ViennaPair l) (ViennaPair h) (ViennaPair p) = l <= p && p <= h
instance IndexStream z => IndexStream (z:.ViennaPair) where
streamUp (ls:.ViennaPair l) (hs:.ViennaPair h) = flatten mk step Unknown $ streamUp ls hs
where mk z = return (z,l)
step (z,k)
| k > h = return $ Done
| otherwise = return $ Yield (z:.ViennaPair k) (z,k+1)
streamDown (ls:.ViennaPair l) (hs:.ViennaPair h) = flatten mk step Unknown $ streamDown ls hs
where mk z = return (z,h)
step (z,k)
| k < l = return $ Done
| otherwise = return $ Yield (z:.ViennaPair k) (z,k1)
instance IndexStream ViennaPair where
streamUp l h = map (\(Z:.k) -> k) $ streamUp (Z:.l) (Z:.h)
streamDown l h = map (\(Z:.k) -> k) $ streamDown (Z:.l) (Z:.h)
pattern NP = ViennaPair 0 :: ViennaPair
pattern CG = ViennaPair 1 :: ViennaPair
pattern GC = ViennaPair 2 :: ViennaPair
pattern GU = ViennaPair 3 :: ViennaPair
pattern UG = ViennaPair 4 :: ViennaPair
pattern AU = ViennaPair 5 :: ViennaPair
pattern UA = ViennaPair 6 :: ViennaPair
pattern NS = ViennaPair 7 :: ViennaPair
pattern Undef = ViennaPair 8 :: ViennaPair
class MkViennaPair a where
mkViennaPair :: a -> ViennaPair
fromViennaPair :: ViennaPair -> a
instance MkViennaPair (Letter RNA, Letter RNA) where
mkViennaPair = \case
(C,G) -> CG
(G,C) -> GC
(G,U) -> GU
(U,G) -> UG
(A,U) -> AU
(U,A) -> UA
_ -> NS
fromViennaPair = \case
CG -> (C,G)
GC -> (G,C)
GU -> (G,U)
UG -> (U,G)
AU -> (A,U)
UA -> (U,A)
_ -> error "non-standard pairs can't be backcasted"
isViennaPair :: Letter RNA -> Letter RNA -> Bool
isViennaPair l r = l==C && r==G
|| l==G && r==C
|| l==A && r==U
|| l==U && r==A
|| l==G && r==U
|| l==U && r==G
viennaPairTable :: Unboxed (Z:.Letter RNA:.Letter RNA) ViennaPair
viennaPairTable = fromAssocs (Z:.N:.N) (Z:.U:.U) NS
[ (Z:.C:.G , CG)
, (Z:.G:.C , GC)
, (Z:.G:.U , GU)
, (Z:.U:.G , UG)
, (Z:.A:.U , AU)
, (Z:.U:.A , UA)
]
instance Enum ViennaPair where
toEnum x
| x>=0 && x<=7 = ViennaPair x
| otherwise = error $ "can't make to enum" ++ show x
fromEnum (ViennaPair x) = x
instance Bounded ViennaPair where
minBound = NP
maxBound = NS
instance Show ViennaPair where
show x
| Just s <- x `lookup` pairToString = s
| otherwise = "??"
instance Read ViennaPair where
readsPrec p [] = []
readsPrec p [x] = []
readsPrec p (x:y:xs)
| x ==' ' = readsPrec p (y:xs)
| Just n <- (x:y:[]) `lookup` s2p = [(n,xs)]
| otherwise = []
where s2p = (P.map swap pairToString)
revPair :: ViennaPair -> ViennaPair
revPair = \case
CG -> GC
GC -> CG
GU -> UG
UG -> GU
AU -> UA
UA -> AU
NP -> NP
NS -> NS
cguaP = [CG .. UA]
cgnsP = [CG .. NS]
pairToString = [(CG,"CG"),(GC,"GC"),(UA,"UA"),(AU,"AU"),(GU,"GU"),(UG,"UG"),(NS,"NS"),(NP,"NP")]
derivingUnbox "ViennaPair"
[t| ViennaPair -> Int |] [| unViennaPair |] [| ViennaPair |]