{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Data.CRF.Chain1.Constrained.Core
(
Ob (..)
, Lb (..)
, X (..)
, mkX
, unX
, unR
, Y (..)
, mkY
, unY
, AVec (..)
, fromList
, fromSet
, Feature (..)
, isSFeat
, isTFeat
, isOFeat
) where
import Control.Applicative ((<*>), (<$>))
import Data.Vector.Binary ()
import Data.Binary (Binary, Get, get, put, putWord8, getWord8)
import Data.Ix (Ix)
import qualified Data.Set as S
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed.Deriving
newtype Ob = Ob { unOb :: Int }
deriving ( Show, Read, Eq, Ord, Binary )
derivingUnbox "Ob" [t| Ob -> Int |] [| unOb |] [| Ob |]
newtype Lb = Lb { unLb :: Int }
deriving ( Show, Read, Eq, Ord, Binary, Num, Ix )
derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |]
newtype AVec a = AVec { unAVec :: U.Vector a }
deriving (Show, Read, Eq, Ord, Binary)
fromList :: (Ord a, U.Unbox a) => [a] -> AVec a
fromList = fromSet . S.fromList
{-# INLINE fromList #-}
fromSet :: (Ord a, U.Unbox a) => S.Set a -> AVec a
fromSet = AVec . U.fromList . S.toAscList
{-# INLINE fromSet #-}
data X
= X { _unX :: AVec Ob }
| R { _unX :: AVec Ob
, _unR :: AVec Lb }
deriving (Show, Read, Eq, Ord)
instance Binary X where
put X{..} = putWord8 0 >> put _unX
put R{..} = putWord8 1 >> put _unX >> put _unR
get = getWord8 >>= \i -> case i of
0 -> X <$> get
_ -> R <$> get <*> get
mkX :: [Ob] -> [Lb] -> X
mkX x [] = X (fromList x)
mkX x r = R (fromList x) (fromList r)
{-# INLINE mkX #-}
unX :: X -> [Ob]
unX = U.toList . unAVec . _unX
{-# INLINE unX #-}
unR :: AVec Lb -> X -> [Lb]
unR r0 X{..} = U.toList . unAVec $ r0
unR _ R{..} = U.toList . unAVec $ _unR
{-# INLINE unR #-}
newtype Y = Y { _unY :: AVec (Lb, Double) }
deriving (Show, Read, Eq, Ord, Binary)
mkY :: [(Lb, Double)] -> Y
mkY = Y . fromList
{-# INLINE mkY #-}
unY :: Y -> [(Lb, Double)]
unY = U.toList . unAVec . _unY
{-# INLINE unY #-}
data Feature
= SFeature
{-# UNPACK #-} !Lb
| TFeature
{-# UNPACK #-} !Lb
{-# UNPACK #-} !Lb
| OFeature
{-# UNPACK #-} !Ob
{-# UNPACK #-} !Lb
deriving (Show, Eq, Ord)
instance Binary Feature where
put (SFeature x) = put (0 :: Int) >> put x
put (TFeature x y) = put (1 :: Int) >> put (x, y)
put (OFeature o x) = put (2 :: Int) >> put (o, x)
get = do
k <- get :: Get Int
case k of
0 -> SFeature <$> get
1 -> TFeature <$> get <*> get
2 -> OFeature <$> get <*> get
_ -> error "Binary Feature: unknown identifier"
isSFeat :: Feature -> Bool
isSFeat (SFeature _) = True
isSFeat _ = False
{-# INLINE isSFeat #-}
isOFeat :: Feature -> Bool
isOFeat (OFeature _ _) = True
isOFeat _ = False
{-# INLINE isOFeat #-}
isTFeat :: Feature -> Bool
isTFeat (TFeature _ _) = True
isTFeat _ = False
{-# INLINE isTFeat #-}