{-# LANGUAGE RecordWildCards #-}
module Data.CRF.Chain2.Tiers.DAG.Feature
(
Feat (..)
, presentFeats
, EdgeIx (..)
, hiddenFeats
, obFeatsOn
, trFeatsOn
, FeatSel
, selectPresent
, selectHidden
, lbNum
, lbIxs
, edgeIxs
, prevEdgeIxs
, nextEdgeIxs
, initialEdgeIxs
, finalEdgeIxs
) where
import Control.Applicative ((<$>))
import qualified Data.Number.LogFloat as L
import qualified Data.Vector as V
import Data.Maybe (maybeToList)
import Data.DAG (DAG, EdgeID)
import qualified Data.DAG as DAG
import Data.CRF.Chain2.Tiers.Core (X, Y, Ob, Cb, CbIx, Feat)
import qualified Data.CRF.Chain2.Tiers.Core as C
obFeats :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]
obFeats edgeID dag =
[ (ft, px)
| let edgeLabel = DAG.edgeLabel edgeID dag
, (x, px) <- C.unY (snd edgeLabel)
, o <- C.unX (fst edgeLabel)
, ft <- C.obFeats o x ]
trFeats1 :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]
trFeats1 i dag =
[ (ft, px)
| null (prevEdges i)
, (x, px) <- edgeLabel i
, ft <- C.trFeats1 x ]
where
edgeLabel = C.unY . snd . flip DAG.edgeLabel dag
prevEdges = flip DAG.prevEdges dag
trFeats2 :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]
trFeats2 i dag =
[ (ft, px * py)
| (x, px) <- edgeLabel i
, j <- prevEdges i
, null (prevEdges j)
, (y, py) <- edgeLabel j
, ft <- C.trFeats2 x y ]
where
edgeLabel = C.unY . snd . flip DAG.edgeLabel dag
prevEdges = flip DAG.prevEdges dag
trFeats3 :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]
trFeats3 i dag =
[ (ft, px * py * pz)
| (x, px) <- edgeLabel i
, j <- prevEdges i
, (y, py) <- edgeLabel j
, k <- prevEdges j
, (z, pz) <- edgeLabel k
, ft <- C.trFeats3 x y z ]
where
edgeLabel = C.unY . snd . flip DAG.edgeLabel dag
prevEdges = flip DAG.prevEdges dag
presentFeatsOn :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]
presentFeatsOn edgeID dag
= obFeats edgeID dag
++ trFeats1 edgeID dag
++ trFeats2 edgeID dag
++ trFeats3 edgeID dag
presentFeats :: DAG a (X, Y) -> [(Feat, L.LogFloat)]
presentFeats dag = concat
[ presentFeatsOn edgeID dag
| edgeID <- DAG.dagEdges dag ]
obList :: DAG a X -> EdgeID -> [Ob]
obList dag i = C.unX $ DAG.edgeLabel i dag
{-# INLINE obList #-}
lbVec :: DAG a X -> EdgeID -> V.Vector Cb
lbVec dag i = C._unR $ DAG.edgeLabel i dag
{-# INLINE lbVec #-}
lbNum :: DAG a X -> EdgeID -> Int
lbNum dag = V.length . lbVec dag
{-# INLINE lbNum #-}
lbOn :: DAG a X -> EdgeID -> CbIx -> Maybe Cb
lbOn dag = (V.!?) . lbVec dag
{-# INLINE lbOn #-}
lbIxs :: DAG a X -> EdgeID -> [CbIx]
lbIxs dag i = [0 .. lbNum dag i - 1]
{-# INLINE lbIxs #-}
edgeIxs :: DAG a X -> EdgeID -> [EdgeIx]
edgeIxs dag i =
[ EdgeIx {edgeID=i, lbIx=u}
| u <- lbIxs dag i ]
prevEdgeIxs :: DAG a X -> Maybe EdgeID -> [Maybe EdgeIx]
prevEdgeIxs _ Nothing = [Nothing]
prevEdgeIxs dag (Just i)
| null js = [Nothing]
| otherwise = Just <$>
[ EdgeIx {edgeID=j, lbIx=u}
| j <- js, u <- lbIxs dag j ]
where js = DAG.prevEdges i dag
nextEdgeIxs :: DAG a X -> Maybe EdgeID -> [Maybe EdgeIx]
nextEdgeIxs _ Nothing = [Nothing]
nextEdgeIxs dag (Just i)
| null js = [Nothing]
| otherwise = Just <$>
[ EdgeIx {edgeID=j, lbIx=u}
| j <- js, u <- lbIxs dag j ]
where js = DAG.nextEdges i dag
initialEdgeIxs :: DAG a X -> [EdgeIx]
initialEdgeIxs dag = concat
[ edgeIxs dag i
| i <- DAG.dagEdges dag
, DAG.isInitialEdge i dag ]
finalEdgeIxs :: DAG a X -> [EdgeIx]
finalEdgeIxs dag = concat
[ edgeIxs dag i
| i <- DAG.dagEdges dag
, DAG.isFinalEdge i dag ]
data EdgeIx = EdgeIx
{ edgeID :: {-# UNPACK #-} !EdgeID
, lbIx :: {-# UNPACK #-} !CbIx
}
deriving (Show, Eq, Ord)
obFeatsOn :: DAG a X -> EdgeIx -> [Feat]
obFeatsOn dag EdgeIx{..} = concat
[ C.obFeats o e
| e <- maybeToList $ lbOn dag edgeID lbIx
, o <- obList dag edgeID ]
{-# INLINE obFeatsOn #-}
trFeatsOn
:: DAG a X
-> Maybe EdgeIx
-> Maybe EdgeIx
-> Maybe EdgeIx
-> [Feat]
trFeatsOn dag u' v' w' = doit
(lbOn' =<< u')
(lbOn' =<< v')
(lbOn' =<< w')
where
lbOn' EdgeIx{..} = lbOn dag edgeID lbIx
doit (Just u) (Just v) (Just w) = C.trFeats3 u v w
doit (Just u) (Just v) _ = C.trFeats2 u v
doit (Just u) _ _ = C.trFeats1 u
doit _ _ _ = []
{-# INLINE trFeatsOn #-}
hiddenFeats :: DAG a X -> [Feat]
hiddenFeats dag =
obFs ++ trFs
where
obFs = concat
[ obFeatsOn dag u
| i <- DAG.dagEdges dag
, u <- edgeIxs dag i ]
trFs = concat
[ trFeatsOn dag u v w
| i <- DAG.dagEdges dag
, u <- Just <$> edgeIxs dag i
, v <- prevEdgeIxs dag (edgeID <$> u)
, w <- prevEdgeIxs dag (edgeID <$> v) ]
type FeatSel a = DAG a (X, Y) -> [Feat]
selectPresent :: FeatSel a
selectPresent = map fst . presentFeats
selectHidden :: FeatSel a
selectHidden = hiddenFeats . fmap fst