diff --git a/alpino-tools.cabal b/alpino-tools.cabal --- a/alpino-tools.cabal +++ b/alpino-tools.cabal @@ -1,5 +1,5 @@ Name: alpino-tools -Version: 0.0.5 +Version: 0.1.0 License: OtherLicense License-file: LICENSE Copyright: Copyright 2010 Daniël de Kok @@ -13,12 +13,15 @@ Build-Type: Simple Library - Exposed-Modules: Data.Alpino.Model, Data.Alpino.Model.Enumerator + Exposed-Modules: Data.Alpino.DepStruct, Data.Alpino.DepStruct.Pickle, + Data.Alpino.DepStruct.Triples, Data.Alpino.Model, + Data.Alpino.Model.Enumerator Build-Depends: base >= 4 && < 5, bytestring >= 0.9.1.7, utf8-string >= 0.3.6, bytestring-lexing >= 0.2.1, enumerator >= 0.4.8 && < 0.5, transformers >= 0.2.2.0, containers >= 0.3.0.0, random >= 1.0.0.3, - random-shuffle >= 0.0.2 + random-shuffle >= 0.0.2, hexpat-pickle >= 0.4, + rosezipper >= 0.2, mtl >= 2.0.1.0 HS-Source-Dirs: src Ghc-Options: -O2 -Wall diff --git a/src/Data/Alpino/DepStruct.hs b/src/Data/Alpino/DepStruct.hs new file mode 100644 --- /dev/null +++ b/src/Data/Alpino/DepStruct.hs @@ -0,0 +1,72 @@ +-- | +-- Module : Data.Alpino.DepStruct +-- Copyright : (c) 2011 Daniël de Kok +-- License : Apache 2 +-- +-- Maintainer : Daniël de Kok +-- Stability : experimental +-- +-- Definitions for Alpino dependency structures. + +module Data.Alpino.DepStruct ( + + -- * Dependency structures + AlpinoDS(..), + Cat(..), + DSLabel(..), + Rel(..) + +) where + +import Data.Tree + +-- | Alpino dependency structures define syntactic relations between +-- words. For convenience, the dependency structure is represented +-- as a rose tree. Additionally, the dependency structure contains +-- the sentence corresponding to the dependency structure. +data AlpinoDS = AlpinoDS { + -- | Root of the dependency tree. + dsRoot :: Tree DSLabel, + -- | Sentence corresponding to the dependency tree. + dsSentence :: String +} deriving(Show, Eq) + +-- | Label containing syntactic or lexical information of a node. +data DSLabel = + CatLabel { + -- | Category + labelRel :: Rel, + -- | Dependency relation + labelCat :: Cat, + -- | Coindexation + labelIdx :: Maybe Integer, + -- | Start position + labelBegin :: Maybe Integer, + -- | End position + labelEnd :: Maybe Integer + } + | LexLabel { + -- | Dependency relation + labelRel :: Rel, + -- | Part of speech tag + labelPos :: String, + -- | Root/stem + labelRoot :: String, + -- | Coindexation + labelIdx :: Maybe Integer, + -- | Start position + labelBegin :: Maybe Integer, + -- | End position + labelEnd :: Maybe Integer + } deriving (Show, Eq) + +data Rel = Hdf | Hd | Cmp | Sup | Su | Obj1 | PObj1 | Obj2| Se | PC | VC + | SVP | PredC | Ld | Me | PredM | ObComp | Mod | Body | Det | App | Whd + | Rhd | Cnj | Crd | Nucl | Sat | Tag | DP | Top | MWP | DLink | DashDash + deriving (Eq, Ord, Show) + +data Cat = SMain | NP | PPart | PPres | PP | SSub | Inf | Cp | DU | Ap + | AdvP | TI | Rel | WhRel | WhSub | Conj | WhQ | Oti | Ahi | DetP | SV1 + | SVan | MWU | TopCat + deriving (Eq, Ord, Show) + diff --git a/src/Data/Alpino/DepStruct/Pickle.hs b/src/Data/Alpino/DepStruct/Pickle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Alpino/DepStruct/Pickle.hs @@ -0,0 +1,211 @@ +-- | +-- Module : Data.Alpino.DepStruct.Pickle +-- Copyright : (c) 2011 Daniël de Kok +-- License : Apache 2 +-- +-- Maintainer : Daniël de Kok +-- Stability : experimental +-- +-- Pickling and unpickling of Alpino dependency structures from XML. + +module Data.Alpino.DepStruct.Pickle (xpAlpinoDS) where + +import Control.Monad.State (State, evalState, get, put) +import Data.Tree (rootLabel, subForest) +import qualified Data.Tree as DT +import Text.Printf (printf) +import Text.XML.Expat.Pickle + +import Data.Alpino.DepStruct + +data LabelOrRef = + Label { + lorLabel :: DSLabel + } + | Ref { + lorRel :: Rel, + lorIdx :: Integer +} deriving (Show) + +-- | Pickler for Alpino dependency structures. +xpAlpinoDS :: PU [UNode String] AlpinoDS +xpAlpinoDS = + xpElemNodes "alpino_ds" $ + xpWrap ( + \(lOrRefTree, sent) -> + AlpinoDS (evalState (resolveTree lOrRefTree) []) sent, + \n -> ( + evalState (refTree $ dsRoot n) [], + dsSentence n + ) + ) $ + xpPair + xpNode + xpSentence + +xpNode :: PU [UNode String] (DT.Tree LabelOrRef) +xpNode = + xpAlt picklerIndex [xpLexNode, xpCatNode, xpRefNode] + where + picklerIndex (DT.Node lr _) = case lr of + (Label label) -> case label of + LexLabel _ _ _ _ _ _ -> 0 + CatLabel _ _ _ _ _ -> 1 + Ref _ _ -> 2 + +xpCatNode :: PU [UNode String] (DT.Tree LabelOrRef) +xpCatNode = + xpWrap ( + \((rel, cat, idx, begin, end), forest) -> + DT.Node (Label $ CatLabel rel cat idx begin end) forest, + \t -> ( + (labelRel $ lorLabel $ rootLabel t, + labelCat $ lorLabel $ rootLabel t, + labelIdx $ lorLabel $ rootLabel t, + labelBegin $ lorLabel $ rootLabel t, + labelEnd $ lorLabel $ rootLabel t), + subForest t) + ) $ + xpElem "node" + (xp5Tuple + (xpAttr "rel" xpRel) + (xpAttr "cat" xpCat) + (xpAttrImplied "index" xpickle) + (xpAttrImplied "begin" xpickle) + (xpAttrImplied "end" xpickle)) + (xpList xpNode) + +xpLexNode :: PU [UNode String] (DT.Tree LabelOrRef) +xpLexNode = + xpWrap ( + \(rel, pos, root, idx, begin, end) -> + DT.Node (Label $ LexLabel rel pos root idx begin end) [], + \t -> + (labelRel $ lorLabel $ rootLabel t, + labelPos $ lorLabel $ rootLabel t, + labelRoot $ lorLabel $ rootLabel t, + labelIdx $ lorLabel $ rootLabel t, + labelBegin $ lorLabel $ rootLabel t, + labelEnd $ lorLabel $ rootLabel t)) $ + xpElemAttrs "node" + (xp6Tuple + (xpAttr "rel" xpRel) + (xpAttr "pos" xpText) + (xpAttr "root" xpText) + (xpAttrImplied "index" xpickle) + (xpAttrImplied "begin" xpickle) + (xpAttrImplied "end" xpickle)) + +xpRefNode :: PU [UNode String] (DT.Tree LabelOrRef) +xpRefNode = + xpWrap ( + \(rel, idx) -> + DT.Node (Ref rel idx) [], + \t -> + (lorRel $ rootLabel t, + lorIdx $ rootLabel t)) $ + xpElemAttrs "node" + (xpPair + (xpAttr "rel" xpRel) + (xpAttr "index" xpickle)) + +cats :: [(Cat, String)] +cats = [(SMain, "smain"), (NP, "np"), (PPart, "ppart"), (PPres, "ppres"), + (PP, "pp"), (SSub, "ssub"), (Inf, "inf"), (Cp, "cp"), (DU, "du"), + (Ap, "ap"), (AdvP, "advp"), (TI, "ti"), (Rel, "rel"), (WhRel, "whrel"), + (WhSub, "whsub"), (Conj, "conj"), (WhQ, "whq"), (Oti, "oti"), + (Ahi, "ahi"), (DetP, "detp"), (SV1, "sv1"), (SVan, "svan"), + (MWU, "mwu"), (TopCat, "top")] + +xpCat :: PU String Cat +xpCat = + xpWrapMaybe_ + "Could not parse 'cat' attribute." + (\cat -> lookup cat $ map (\(a, b) -> (b, a)) cats, + -- Fixme: We should use pattern matching completeness check. + \cat -> case lookup cat cats of + Just c -> c + Nothing -> error "Bug: Category list is incomplete!" + ) + xpText + +rels :: [(Rel, String)] +rels = [(Hdf, "hdf"), (Hd, "hd"), (Cmp, "cmp"), (Sup, "sup"), + (Su, "su"), (Obj1, "obj1"), (PObj1, "pobj1"), (Obj2, "obj2"), + (Se, "se"), (PC, "pc"), (VC, "vc"), (SVP, "svp"), (PredC, "predc"), + (Ld, "ld"), (Me, "me"), (PredM, "predm"), (ObComp, "obcomp"), + (Mod, "mod"), (Body, "body"), (Det, "det"), (App, "app"), + (Whd, "whd"), (Rhd, "rhd"), (Cnj, "cnj"), (Crd, "crd"), + (Nucl, "nucl"), (Sat, "sat"), (Tag, "tag"), (DP, "dp"), + (Top, "top"), (MWP, "mwp"), (DLink, "dlink"), (DashDash, "--")] + +xpRel :: PU String Rel +xpRel = + xpWrapMaybe_ + "Could not parse 'rel' attribute." + (\rel -> lookup rel $ map (\(a, b) -> (b, a)) rels, + -- Fixme: We should use pattern matching completeness check. + \rel -> case lookup rel rels of + Just r -> r + Nothing -> error "Bug: Relation list is incomplete!" + ) + xpText + +xpSentence :: PU [UNode String] String +xpSentence = + xpElemNodes "sentence" (xpContent xpText0) + +-- +-- There is a discrepancy between our representation of dependency trees +-- in Haskell, and those in XML. In the XML representation, coreferent nodes +-- are only represented once in full. Subsequent occurances just have the +-- 'index' attribute. +-- +-- This representation is annoying in real-life use, because a function +-- that processes a dependency structure has to resolve these 'reference +-- nodes'. For these reason, we add the full structure to all instances of +-- a coreferent node. Two functions are used: +-- +-- resolveTree - expands reference nodes to full nodes (used during +-- pickling) +-- refTree - replaces duplicate coreferent nodes by a reference (used +-- during unpickling) +-- + +type ResolveState = [(Integer, DT.Tree DSLabel)] + +-- Resolve nodes that only have a coreference index and a relation. +resolveTree :: DT.Tree LabelOrRef -> State ResolveState (DT.Tree DSLabel) +resolveTree (DT.Node (Label l) sf) = do + lsf <- mapM resolveTree sf + let node = DT.Node l lsf + case labelIdx l of + Just idx -> do + coIndexed <- get + put $ (idx, node):coIndexed + Nothing -> return () + return node + +resolveTree (DT.Node (Ref rel idx) _) = do + coIndexed <- get + let (DT.Node l ds) = case lookup idx coIndexed of + Just n -> n + Nothing -> error $ printf "Invalid coreference: %i" idx + let newLabel = l { labelRel = rel } + return $ DT.Node newLabel ds + +type RefState = [Integer] + +refTree :: DT.Tree DSLabel -> State RefState (DT.Tree LabelOrRef) +refTree (DT.Node l sf) = do + coIndexed <- get + case labelIdx l of + Just idx -> if elem idx coIndexed then + return $ DT.Node (Ref (labelRel l) idx) [] + else do + lrSf <- mapM refTree sf + put $ idx : coIndexed + return $ DT.Node (Label l) lrSf + Nothing -> do + lrSf <- mapM refTree sf + return $ DT.Node (Label l) lrSf diff --git a/src/Data/Alpino/DepStruct/Triples.hs b/src/Data/Alpino/DepStruct/Triples.hs new file mode 100644 --- /dev/null +++ b/src/Data/Alpino/DepStruct/Triples.hs @@ -0,0 +1,152 @@ +-- | +-- Module : Data.Alpino.DepStruct.Triples +-- Copyright : (c) 2011 Daniël de Kok +-- License : Apache 2 +-- +-- Maintainer : Daniël de Kok +-- Stability : experimental +-- +-- Definition and extraction of Alpino dependency triples. + +module Data.Alpino.DepStruct.Triples ( + + -- * Dependency triples + DepTriple(..), + DepTripleComponent(..), + depTriples, + + -- * Utility functions + tzFold + +) where + +import Control.Monad (ap) +import Data.Maybe (catMaybes, fromJust) +import Data.Set (Set, fromList) +import Data.Tree.Zipper + +import Data.Alpino.DepStruct + +-- Dependency triples + +-- | The 'DepTriple' type represents a dependency that occurs in +-- a dependency structure. The triple consists of the head, a dependent, and +-- the relation between the head and the dependeny. For convenience, the +-- triple is composed of two 'DepTripleComponent' instances: the first +-- representing the head and its role in the relation, the second +-- representing the dependant and its role in the relation. +data DepTriple = DepTriple { + tripleHead :: DepTripleComponent, + tripleDep :: DepTripleComponent +} deriving (Eq, Ord, Show) + +-- | The 'DepTripleComponent' type represents a head or a dependant in a +-- dependency relation. +data DepTripleComponent = DepTripleComponent { + triplePos :: String, + tripleRoot :: String, + tripleRel :: Rel +} deriving (Eq, Ord, Show) + +-- | Extract 'DepTriples' from the tree starting at the node represented by +-- the 'TreePos' zipper. +depTriples :: TreePos Full DSLabel -> Set DepTriple +depTriples = + fromList . map (uncurry hdDepToTriple) . hdsDeps . heads + where + hdsDeps = concat . map hdDeps -- Find dependencies of given heads. + hdDeps = (zip . repeat) `ap` dependants -- Find dependencies of a head. + +heads :: TreePos Full DSLabel -> [TreePos Full DSLabel] +heads = + tzFilter isHead + +isHead :: TreePos Full DSLabel -> Bool +isHead t = case label t of + (LexLabel rel _ _ _ _ _) -> rel `elem` headRels + _ -> False + +headRels :: [Rel] +headRels = [Hd, Cmp, Crd, DLink, Rhd, Whd] + +-- Find dependants of a node. Dependants are: +-- +-- * Siblings that are lexical nodes +-- * Heads of non-lexical nodes +-- +dependants :: TreePos Full DSLabel -> [TreePos Full DSLabel] +dependants = catMaybes . map lexOrHdDtr . siblings + +-- Get zippers for the siblings of a node. +siblings :: TreePos Full DSLabel -> + [TreePos Full DSLabel] +siblings t = + case parent t of + (Just p) -> filter ((/=) t) $ childList p + Nothing -> [] -- No parent? No siblings. + +-- Get zippers fo the children of a node. +childList :: TreePos Full DSLabel -> [TreePos Full DSLabel] +childList = curLevel . firstChild + where + curLevel (Nothing) = [] + curLevel (Just t') = t':curLevel (next t') + +-- If the node is a lexical node, return it as-is. If not, return its +-- head daughter. +lexOrHdDtr :: TreePos Full DSLabel -> Maybe (TreePos Full DSLabel) +lexOrHdDtr t = + case label t of + (LexLabel _ _ _ _ _ _) -> Just t + (CatLabel _ _ _ _ _) -> case filter isHead $ childList t of + [c] -> Just c + _ -> Nothing + +-- Retrieve the relation of a node if it serves as a dependent. +relAsDependent :: TreePos Full DSLabel -> Maybe Rel +relAsDependent t = + case label t of + (LexLabel rel _ _ _ _ _) -> if rel `elem` headRels then + case parent t of + Just p -> case label p of + (LexLabel rel' _ _ _ _ _) -> Just rel' + (CatLabel rel' _ _ _ _) -> Just rel' + Nothing -> Nothing + else + Just rel + (CatLabel _ _ _ _ _) -> Nothing + +hdDepToTriple :: TreePos Full DSLabel -> TreePos Full DSLabel -> + DepTriple +hdDepToTriple hd dep = DepTriple hdTripleComp depTripleComp + where + hdTripleComp = DepTripleComponent (labelPos hdLabel) (labelRoot hdLabel) (labelRel hdLabel) + hdLabel = label hd + depTripleComp = DepTripleComponent (labelPos depLabel) (labelRoot depLabel) (fromJust $ relAsDependent dep) + depLabel = label dep + +-- Utility functions + +-- | Fold over a tree depth-first, starting at the node wrapped in the +-- 'TreePos' zipper. +tzFold :: (a -> TreePos Full b -> a) -> a -> TreePos Full b -> a +tzFold f acc t = + foldSiblings $ foldChildren $ f acc t + where + foldChildren acc' = + case firstChild t of + Just c -> tzFold f acc' c + Nothing -> acc' + foldSiblings acc' = + case next t of + Just s -> tzFold f acc' s + Nothing -> acc' + +tzFilter :: (TreePos Full b -> Bool) -> TreePos Full b -> [TreePos Full b] +tzFilter f = + tzFold adder [] + where + adder acc t + | f t = t:acc + | otherwise = acc +