Tables.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- | Turner Nearest Neighbor Energy Tables}

-- TODO (Read) instance? (Vector has no Read instance...)

module Biobase.DataSource.Turner.Tables where

import qualified Data.Map as M

import Data.PrimitiveArray
import Data.PrimitiveArray.Ix



-- | A data structure describing all fields as used by the Turner 2004
-- parameter set. Some fields are commented out until they are being used.

data Turner2004 a b c = Turner2004
  { stack :: PrimArray (a,a) c
  , dangle3 :: PrimArray (a,b) c
  , dangle5 :: PrimArray (a,b) c
  , hairpinL :: PrimArray Int c
  , hairpinMM :: PrimArray (a,b,b) c
  , hairpinLookup :: M.Map [b] c
--  , hairpinGGG :: c
--  , hairpinCslope :: c
--  , hairpinCintercept :: c
--  , hairpinC3 :: c
  , bulgeL :: PrimArray Int c
--  , bulgeSingleC :: c
  , iloop1x1 :: PrimArray (a,a,b,b) c
  , iloop1x2 :: PrimArray (a,a,b,b,b) c
  , iloop2x2 :: PrimArray (a,a,b,b,b,b) c
  , iloopMM :: PrimArray (a,b,b) c
  , iloop2x3MM :: PrimArray (a,b,b) c
  , iloop1xnMM :: PrimArray (a,b,b) c
  , iloopL :: PrimArray Int c
  , multiMM :: PrimArray (a,b,b) c
  , ninio :: c
  , maxNinio :: c
  , multiOffset :: c
  , multiNuc :: c
  , multiHelix :: c
--  , multiAsym :: c
--  , multiStrain :: c
  , extMM :: PrimArray (a,b,b) c
--  , coaxStack :: PrimArray (a,a) c
--  , coaxStackOpen :: PrimArray (a,b,b) c
--  , coaxStackCont :: PrimArray (a,b,b) c
  , largeLoop :: Double
  , termAU :: c
  , intermolecularInit :: c
  }



-- | Map functions over the payload.

dmap f Turner2004{..} = Turner2004
  { stack = amap f stack
  , dangle3 = amap f dangle3
  , dangle5 = amap f dangle5
  , hairpinL = amap f hairpinL
  , hairpinMM = amap f hairpinMM
  , hairpinLookup = fmap f hairpinLookup
--  , hairpinGGG = f hairpinGGG
--  , hairpinCslope = f hairpinCslope
--  , hairpinCintercept = f hairpinCintercept
--  , hairpinC3 = f hairpinC3
  , bulgeL = amap f bulgeL
--  , bulgeSingleC = f bulgeSingleC
  , iloop1x1 = amap f iloop1x1
  , iloop1x2 = amap f iloop1x2
  , iloop2x2 = amap f iloop2x2
  , iloopMM = amap f iloopMM
  , iloop2x3MM = amap f iloop2x3MM
  , iloop1xnMM = amap f iloop1xnMM
  , iloopL = amap f iloopL
  , multiMM = amap f multiMM
  , ninio = f ninio
  , maxNinio = f maxNinio
  , multiOffset = f multiOffset
  , multiNuc = f multiNuc
  , multiHelix = f multiHelix
--  , multiAsym = f multiAsym
--  , multiStrain = f multiStrain
  , extMM = amap f extMM
--  , coaxStack = amap f coaxStack
--  , coaxStackOpen = amap f coaxStackOpen
--  , coaxStackCont = amap f coaxStackCont
  , largeLoop = largeLoop
  , termAU = f termAU
  , intermolecularInit = f intermolecularInit
  }



-- | Zip two payloads.
--
-- TODO right now, we have undefined behaviour when some arrrays are of different length

dZipWith f t1 t2 = Turner2004
  { stack = zipWithPA f (stack t1) (stack t2)
  , dangle3 = zipWithPA f (dangle3 t1) (dangle3 t2)
  , dangle5 = zipWithPA f (dangle5 t1) (dangle5 t2)
  , hairpinL = zipWithPA f (hairpinL t1) (hairpinL t2)
  , hairpinMM = zipWithPA f (hairpinMM t1) (hairpinMM t2)
  , hairpinLookup = undefined -- zipWithPA f (hairpinLookup t1) (hairpinLookup t2)
  , bulgeL = zipWithPA f (bulgeL t1) (bulgeL t2)
  , iloop1x1 = zipWithPA f (iloop1x1 t1) (iloop1x1 t2)
  , iloop1x2 = zipWithPA f (iloop1x2 t1) (iloop1x2 t2)
  , iloop2x2 = zipWithPA f (iloop2x2 t1) (iloop2x2 t2)
  , iloopMM = zipWithPA f (iloopMM t1) (iloopMM t2)
  , iloop2x3MM = zipWithPA f (iloop2x3MM t1) (iloop2x3MM t2)
  , iloop1xnMM = zipWithPA f (iloop1xnMM t1) (iloop1xnMM t2)
  , iloopL = zipWithPA f (iloopL t1) (iloopL t2)
  , multiMM = zipWithPA f (multiMM t1) (multiMM t2)
  , ninio = f (ninio t1) (ninio t2)
  , maxNinio = f (maxNinio t1) (maxNinio t2)
  , multiOffset = f (multiOffset t1) (multiOffset t2)
  , multiNuc = f (multiNuc t1) (multiNuc t2)
  , multiHelix = f (multiHelix t1) (multiHelix t2)
  , extMM = zipWithPA f (extMM t1) (extMM t2)
  , largeLoop = largeLoop t1 -- no zipping here! TODO make this a constant somewhere!
  , termAU = f (termAU t1) (termAU t2)
  , intermolecularInit = f (intermolecularInit t1) (intermolecularInit t2)
  }

zipWithPA f a1 a2 = let (l,u) = bounds a1 in fromList l u $ zipWith f (toList a1) (toList a2)