module Data.Alpino.DepStruct.Triples (
DepTriple(..),
DepTripleComponent(..),
depTriples,
tzFold
) where
import Control.Monad (ap)
import Data.Maybe (catMaybes, fromJust)
import Data.Set (Set, fromList)
import Data.Tree.Zipper
import Data.Alpino.DepStruct
data DepTriple = DepTriple {
tripleHead :: DepTripleComponent,
tripleDep :: DepTripleComponent
} deriving (Eq, Ord, Show)
data DepTripleComponent = DepTripleComponent {
triplePos :: String,
tripleRoot :: String,
tripleRel :: Rel
} deriving (Eq, Ord, Show)
depTriples :: TreePos Full DSLabel -> Set DepTriple
depTriples =
fromList . map (uncurry hdDepToTriple) . hdsDeps . heads
where
hdsDeps = concat . map hdDeps
hdDeps = (zip . repeat) `ap` dependants
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]
dependants :: TreePos Full DSLabel -> [TreePos Full DSLabel]
dependants = catMaybes . map lexOrHdDtr . siblings
siblings :: TreePos Full DSLabel ->
[TreePos Full DSLabel]
siblings t =
case parent t of
(Just p) -> filter ((/=) t) $ childList p
Nothing -> []
childList :: TreePos Full DSLabel -> [TreePos Full DSLabel]
childList = curLevel . firstChild
where
curLevel (Nothing) = []
curLevel (Just t') = t':curLevel (next t')
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
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
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