{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Data.CRF.Chain2.Tiers.Core
(
Ob (..)
, mkOb, unOb
, Lb (..)
, mkLb, unLb
, FeatIx (..)
, mkFeatIx, unFeatIx
, CbIx
, Cb (..)
, mkCb
, unCb
, X (_unX, _unR)
, mkX
, unX
, unR
, lbAt
, Y (_unY)
, mkY
, unY
, Feat (..)
, obFeats
, trFeats1
, trFeats2
, trFeats3
) where
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (second)
import Data.Binary (Binary, put, get, putWord8, getWord8)
import Data.Ix (Ix)
import Data.Int (Int16, Int32)
import Data.List (zip4)
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed.Deriving
import qualified Data.Number.LogFloat as L
import Data.CRF.Chain2.Tiers.Array (Bounds)
newtype Ob = Ob { _unOb :: Int32 }
deriving (Show, Eq, Ord, Binary)
derivingUnbox "Ob" [t| Ob -> Int32 |] [| _unOb |] [| Ob |]
mkOb :: Int -> Ob
mkOb = Ob . fromIntegral
{-# INLINE mkOb #-}
unOb :: Ob -> Int
unOb = fromIntegral . _unOb
{-# INLINE unOb #-}
newtype Lb = Lb { _unLb :: Int16 }
deriving (Show, Eq, Ord, Binary , Num, Ix, Bounds)
derivingUnbox "Lb" [t| Lb -> Int16 |] [| _unLb |] [| Lb |]
mkLb :: Int -> Lb
mkLb = Lb . fromIntegral
{-# INLINE mkLb #-}
unLb :: Lb -> Int
unLb = fromIntegral . _unLb
{-# INLINE unLb #-}
type CbIx = Int
newtype FeatIx = FeatIx { _unFeatIx :: Int32 }
deriving (Show, Eq, Ord, Binary)
derivingUnbox "FeatIx" [t| FeatIx -> Int32 |] [| _unFeatIx |] [| FeatIx |]
mkFeatIx :: Int -> FeatIx
mkFeatIx = FeatIx . fromIntegral
{-# INLINE mkFeatIx #-}
unFeatIx :: FeatIx -> Int
unFeatIx = fromIntegral . _unFeatIx
{-# INLINE unFeatIx #-}
newtype Cb = Cb { _unCb :: U.Vector Lb }
deriving (Show, Eq, Ord, Binary)
mkCb :: [Lb] -> Cb
mkCb = Cb . U.fromList
unCb :: Cb -> [Lb]
unCb = U.toList . _unCb
data X = X {
_unX :: U.Vector Ob
, _unR :: V.Vector Cb }
deriving (Show, Eq, Ord)
instance Binary X where
put X{..} = put _unX >> put _unR
get = X <$> get <*> get
mkX :: [Ob] -> [Cb] -> X
mkX x r = X (U.fromList x) (V.fromList r)
{-# INLINE mkX #-}
unX :: X -> [Ob]
unX = U.toList . _unX
{-# INLINE unX #-}
unR :: X -> [Cb]
unR = V.toList . _unR
{-# INLINE unR #-}
lbAt :: X -> CbIx -> Cb
lbAt x = (_unR x V.!)
{-# INLINE lbAt #-}
newtype Y = Y { _unY :: V.Vector (Cb, Double) }
deriving (Show, Eq, Ord, Binary)
mkY :: [(Cb, Double)] -> Y
mkY = Y . V.fromList . map (second log)
{-# INLINE mkY #-}
unY :: Y -> [(Cb, L.LogFloat)]
unY = map (second L.logToLogFloat) . V.toList . _unY
{-# INLINE unY #-}
data Feat
= TFeat3
{ x1 :: {-# UNPACK #-} !Lb
, x2 :: {-# UNPACK #-} !Lb
, x3 :: {-# UNPACK #-} !Lb
, ln :: {-# UNPACK #-} !Int }
| TFeat2
{ x1 :: {-# UNPACK #-} !Lb
, x2 :: {-# UNPACK #-} !Lb
, ln :: {-# UNPACK #-} !Int }
| TFeat1
{ x1 :: {-# UNPACK #-} !Lb
, ln :: {-# UNPACK #-} !Int }
| OFeat
{ ob :: {-# UNPACK #-} !Ob
, x1 :: {-# UNPACK #-} !Lb
, ln :: {-# UNPACK #-} !Int }
deriving (Show, Eq, Ord)
instance Binary Feat where
put (OFeat o x k) = putWord8 0 >> put o >> put x >> put k
put (TFeat3 x y z k) = putWord8 1 >> put x >> put y >> put z >> put k
put (TFeat2 x y k) = putWord8 2 >> put x >> put y >> put k
put (TFeat1 x k) = putWord8 3 >> put x >> put k
get = getWord8 >>= \i -> case i of
0 -> OFeat <$> get <*> get <*> get
1 -> TFeat3 <$> get <*> get <*> get <*> get
2 -> TFeat2 <$> get <*> get <*> get
3 -> TFeat1 <$> get <*> get
_ -> error "get feature: unknown code"
obFeats :: Ob -> Cb -> [Feat]
obFeats ob' xs =
[ OFeat ob' x k
| (x, k) <- zip (unCb xs) [0..] ]
trFeats1 :: Cb -> [Feat]
trFeats1 xs =
[ TFeat1 x k
| (x, k) <- zip (unCb xs) [0..] ]
trFeats2 :: Cb -> Cb -> [Feat]
trFeats2 xs1 xs2 =
[ TFeat2 x1' x2' k
| (x1', x2', k) <- zip3 (unCb xs1) (unCb xs2) [0..] ]
trFeats3 :: Cb -> Cb -> Cb -> [Feat]
trFeats3 xs1 xs2 xs3 =
[ TFeat3 x1' x2' x3' k
| (x1', x2', x3', k) <- zip4 (unCb xs1) (unCb xs2) (unCb xs3) [0..] ]