module NLP.GenI.FeatureStructure where
import Data.Binary
import Data.Function (on)
import Data.Generics (Data)
import Data.List (sortBy)
import qualified Data.Map as Map
import Data.Typeable (Typeable)
import Data.Text ( Text )
import qualified Data.Text as T
import NLP.GenI.GeniShow
import NLP.GenI.GeniVal
import NLP.GenI.General ( geniBug )
import NLP.GenI.Pretty
import Control.DeepSeq
type Flist a = [AvPair a]
data AvPair a = AvPair { avAtt :: Text
, avVal :: a }
deriving (Ord, Eq, Data, Typeable)
type FeatStruct a = Map.Map Text a
emptyFeatStruct :: FeatStruct a
emptyFeatStruct = Map.empty
mkFeatStruct :: Flist GeniVal -> FeatStruct GeniVal
mkFeatStruct fs = Map.fromListWith oops . map fromPair $ fs
where
fromPair (AvPair a v) = (a,v)
oops _ _ = geniBug $
"I've allowed a feature structure with multiple versions of a key"
++ " to sneak through: " ++ prettyStr fs
fromFeatStruct :: FeatStruct a -> Flist a
fromFeatStruct = sortFlist . map (uncurry AvPair) . Map.toList
instance Pretty (FeatStruct GeniVal) where
pretty = pretty . fromFeatStruct
instance GeniShow (FeatStruct GeniVal) where
geniShowText = geniShowText . fromFeatStruct
sortFlist :: Flist a -> Flist a
sortFlist = sortBy (compare `on` avAtt)
instance DescendGeniVal v => DescendGeniVal (AvPair v) where
descendGeniVal s (AvPair a v) = AvPair a (descendGeniVal s v)
instance DescendGeniVal a => DescendGeniVal (String, a) where
descendGeniVal s (n,v) = (n,descendGeniVal s v)
instance DescendGeniVal v => DescendGeniVal ([String], Flist v) where
descendGeniVal s (a,v) = (a, descendGeniVal s v)
instance Collectable a => Collectable (AvPair a) where
collect (AvPair _ b) = collect b
instance Pretty (Flist GeniVal) where
pretty = geniShowText
instance Pretty (AvPair GeniVal) where
pretty = geniShowText
instance GeniShow (Flist GeniVal) where
geniShowText = squares . T.unwords . map geniShowText
instance GeniShow (AvPair GeniVal) where
geniShowText (AvPair a v) = a `T.append` ":" `T.append` geniShowText v
unifyFeat :: Monad m => Flist GeniVal -> Flist GeniVal -> m (Flist GeniVal, Subst)
unifyFeat f1 f2 =
let (att, val1, val2) = unzip3 $ alignFeat f1 f2
in att `seq`
do (res, subst) <- unify val1 val2
return (zipWith AvPair att res, subst)
alignFeat :: Flist GeniVal -> Flist GeniVal -> [(Text,GeniVal,GeniVal)]
alignFeat f1 f2 = alignFeatH f1 f2 []
alignFeatH :: Flist GeniVal -> Flist GeniVal -> [(Text,GeniVal,GeniVal)] -> [(Text,GeniVal,GeniVal)]
alignFeatH [] [] acc = reverse acc
alignFeatH [] (AvPair f v :x) acc = alignFeatH [] x ((f,mkGAnon,v) : acc)
alignFeatH x [] acc = alignFeatH [] x acc
alignFeatH fs1@(AvPair f1 v1:l1) fs2@(AvPair f2 v2:l2) acc =
case compare f1 f2 of
EQ -> alignFeatH l1 l2 ((f1, v1, v2) : acc)
LT -> alignFeatH l1 fs2 ((f1, v1, mkGAnon) : acc)
GT -> alignFeatH fs1 l2 ((f2, mkGAnon, v2) : acc)
crushAvPair :: AvPair [GeniVal] -> Maybe (AvPair GeniVal)
crushAvPair (AvPair a v) = AvPair a `fmap` crushOne v
crushFlist :: Flist [GeniVal] -> Maybe (Flist GeniVal)
crushFlist = mapM crushAvPair
instance (Binary a) => Binary (AvPair a) where
put (AvPair x1 x2)
= do put x1
put x2
get
= do x1 <- get
x2 <- get
return (AvPair x1 x2)
instance (NFData a) => NFData (AvPair a) where
rnf (AvPair x1 x2) = rnf x1 `seq` rnf x2 `seq` ()