{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Encoding of Watson-Crick and Wobble Pairs in the Vienna RNA package style.

module Biobase.RNA.ViennaPair where

import Data.Ix
import qualified Data.Vector.Generic as VG
import Data.Primitive.Types
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector.Unboxed as VU
import Data.Tuple.HT (swap)

import Biobase.RNA
import Biobase.RNA.NucBounds



-- | Use machine Ints internally

newtype ViennaPair = ViennaPair Int
  deriving (Eq,Ord,Ix)

(vpNP:vpCG:vpGC:vpGU:vpUG:vpAU:vpUA:vpNS:_) = map ViennaPair [0..]

class MkViennaPair a where
  mkViennaPair :: a -> ViennaPair
  fromViennaPair :: ViennaPair -> a

instance MkViennaPair (Nucleotide,Nucleotide) where
  mkViennaPair (b1,b2)
    | b1==nucC&&b2==nucG = vpCG
    | b1==nucG&&b2==nucC = vpGC
    | b1==nucG&&b2==nucU = vpGU
    | b1==nucU&&b2==nucG = vpUG
    | b1==nucA&&b2==nucU = vpAU
    | b1==nucU&&b2==nucA = vpUA
    | otherwise = vpNS
  fromViennaPair p
    | p==vpCG = (nucC,nucG)
    | p==vpGC = (nucG,nucC)
    | p==vpGU = (nucG,nucU)
    | p==vpUG = (nucU,nucG)
    | p==vpAU = (nucA,nucU)
    | p==vpUA = (nucU,nucA)
    | otherwise = error "non-standard pairs can't be backcasted"

deriving instance VGM.MVector VU.MVector ViennaPair
deriving instance VG.Vector VU.Vector ViennaPair
deriving instance VU.Unbox ViennaPair
deriving instance Prim ViennaPair

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
  {-# INLINE toEnum #-}
  {-# INLINE fromEnum #-}

instance Bounded ViennaPair where
  minBound = vpNP
  maxBound = vpNS

instance NucBounds ViennaPair where
  minNormal = vpCG
  maxNormal = vpUA
  minExtended = vpNP
  maxExtended = vpNS

instance Show ViennaPair where
  show x
    | Just s <- x `lookup` pairToString = s

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 = (map swap pairToString)



-- | reverse a vienna pair

revPair :: ViennaPair -> ViennaPair
revPair p
  | p==vpCG = vpGC
  | p==vpGC = vpCG
  | p==vpGU = vpUG
  | p==vpUG = vpGU
  | p==vpAU = vpUA
  | p==vpUA = vpAU
  | p==vpNP = vpNP
  | p==vpNS = vpNS



-- * Convenience structures

cguaP = [vpCG..vpUA]
cgnsP = [vpCG..vpNS]
pairToString = [(vpCG,"CG"),(vpGC,"GC"),(vpUA,"UA"),(vpAU,"AU"),(vpGU,"GU"),(vpUG,"UG"),(vpNS,"NS"),(vpNP,"NP")]