diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) 2015-2016, Jakub Waszczuk +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/partage.cabal b/partage.cabal new file mode 100644 --- /dev/null +++ b/partage.cabal @@ -0,0 +1,80 @@ +name: partage +version: 0.1.0.0 +synopsis: Parsing factorized +description: + Parsing factorized tree adjoining grammars. +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.10 +copyright: Copyright (c) 2015-2016 Jakub Waszczuk +author: Jakub Waszczuk +maintainer: waszczuk.kuba@gmail.com +stability: experimental +category: Natural Language Processing +homepage: https://github.com/kawu/partage +build-type: Simple + +library + default-language: + Haskell2010 + hs-source-dirs: src + build-depends: + base >= 4 && < 5 + , containers >= 0.5 && < 0.6 + , mtl >= 2.1 && < 2.3 + , transformers >= 0.3 && < 0.5 + , pipes >= 4.1 && < 4.2 + , PSQueue >= 1.1 && < 1.2 + , data-partition >= 0.3 && < 0.4 + , mmorph >= 1.0 && < 1.1 + , dawg-ord >= 0.5 && < 0.6 + , data-lens-light >= 0.1 && < 0.2 + , random >= 1.1 && < 1.2 + , vector >= 0.10 && < 0.12 + + exposed-modules: + NLP.Partage.Tree + , NLP.Partage.Tree.Other + , NLP.Partage.FactGram + , NLP.Partage.Gen + , NLP.Partage.Auto + , NLP.Partage.Auto.List + , NLP.Partage.Auto.Trie + , NLP.Partage.Auto.DAWG + , NLP.Partage.Auto.Set + , NLP.Partage.Earley + + other-modules: + NLP.Partage.SOrd + , NLP.Partage.FactGram.Internal + , NLP.Partage.Earley.AutoAP + , NLP.Partage.SubtreeSharing + + ghc-options: -Wall + -- cpp-options: -DDebug + + +source-repository head + type: git + location: https://github.com/kawu/partage.git + + +test-suite test + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: + test.hs + other-modules: + TestSet + , Parser + build-depends: + partage + , base >= 4 && < 5 + , containers >= 0.5 && < 0.6 + , tasty >= 0.10 + , tasty-hunit >= 0.9 + , HUnit >= 1.2 diff --git a/src/NLP/Partage/Auto.hs b/src/NLP/Partage/Auto.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Auto.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + + +-- | Abstract implementation of an automaton (or a set of automata, +-- in general). `Auto` provides a minimal interface needed to +-- use automata in parsing and thus allows to use one of the +-- concrete implementations provided by the library: +-- +-- * "NLP.Partage.Auto.DAWG": directed acyclic word graph +-- * "NLP.Partage.Auto.Trie": prefix tree +-- * "NLP.Partage.Auto.List": set of lists +-- * "NLP.Partage.Auto.Set": set of automata, one automaton per +-- `Head` non-terminal + + +module NLP.Partage.Auto +( +-- * Automata + Auto (..) +, Edge (..) +, GramAuto + +-- * Utilities +, allIDs +, allEdges +) where + + +import qualified Control.Monad.State.Strict as E + +import qualified Data.Set as S + +import Data.DAWG.Ord (ID) +import NLP.Partage.FactGram (Lab(..)) + + +-- | A datatype used to distinguish head non-terminals from body +-- non-terminals in automata-based grammar representation. +data Edge a + = Head a + | Body a + deriving (Show, Eq, Ord) + + +-- | Minimal automaton implementation. +-- Multiple roots are allowed in order to account for +-- list implementation of an automaton. +data Auto a = Auto + { roots :: S.Set ID + -- ^ Set of automata roots + , follow :: ID -> a -> Maybe ID + -- ^ Follow a transition with the given symbol from the given node + , edges :: ID -> [(a, ID)] + -- ^ List of outgoing edges (transitions) + } + + +-- | Automaton type specialized to represent grammar rules. +type GramAuto n t = Auto (Edge (Lab n t)) + + +-- | Extract the set of underlying IDs. +allIDs :: Ord a => Auto a -> S.Set ID +allIDs d = S.fromList $ concat + [[i, j] | (i, _, j) <- allEdges d] + + +-- | Return the list of automaton transitions. +allEdges :: Ord a => Auto a -> [(ID, a, ID)] +allEdges = S.toList . walk + + +-- | Traverse the automaton and collect all the edges. +walk :: Ord a => Auto a -> S.Set (ID, a, ID) +walk Auto{..} = + flip E.execState S.empty $ + flip E.evalStateT S.empty $ + mapM_ doit (S.toList roots) + where + -- The embedded state serves to store the resulting set of + -- transitions; the surface state serves to keep track of + -- already visited nodes. + doit i = do + b <- E.gets $ S.member i + E.when (not b) $ do + E.modify $ S.insert i + E.forM_ (edges i) $ \(x, j) -> do + E.lift . E.modify $ S.insert (i, x, j) + doit j diff --git a/src/NLP/Partage/Auto/DAWG.hs b/src/NLP/Partage/Auto/DAWG.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Auto/DAWG.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + + +-- | A version where the grammar is actually compressed to a form of +-- a single /directed acyclic word graph/, i.e. a +-- /minimal finite state automaton/. + + +module NLP.Partage.Auto.DAWG +( +-- -- * DAWG +-- DAWG +-- , buildAuto +-- +-- -- * Interface +-- , shell + fromGram +) where + + +-- import qualified Control.Monad.State.Strict as E +-- import Control.Monad.Trans.Class (lift) + +import qualified Data.Set as S + +-- import Data.DAWG.Ord (ID) +import qualified Data.DAWG.Ord as D + +import NLP.Partage.FactGram + ( FactGram, Lab(..), Rule(..) ) + + +import qualified NLP.Partage.Auto as A + + +-------------------------------------------------- +-- Interface +-------------------------------------------------- + + +-- -- | DAWG as automat with one parameter. +-- newtype Auto a = Auto { unAuto :: D.DAWG a () } + + +-- | Abstract over the concrete representation of the grammar +-- automaton. +shell :: (Ord n, Ord t) => DAWG n t -> A.GramAuto n t +shell d = A.Auto + { roots = S.singleton (D.root d) + , follow = \i x -> D.follow i x d + , edges = flip D.edges d } + + +-- | Build the DAWG-based representation of the given grammar. +fromGram :: (Ord n, Ord t) => FactGram n t -> A.GramAuto n t +fromGram = shell . buildAuto + + +-------------------------------------------------- +-- Implementation +-------------------------------------------------- + + +-- | The automaton-based representation of a factorized TAG +-- grammar. Left transitions contain non-terminals belonging to +-- body non-terminals while Right transitions contain rule heads +-- non-terminals. +type DAWG n t = D.DAWG (A.Edge (Lab n t)) () + + +-- | Build automaton from the given grammar. +buildAuto :: (Ord n, Ord t) => FactGram n t -> DAWG n t +buildAuto gram = D.fromLang + [ map A.Body bodyR ++ [A.Head headR] + | Rule{..} <- S.toList gram ] + + +-- -- | Return the list of automaton transitions. +-- edges :: (Ord n, Ord t) => DAWG n t -> [(ID, Edge (Lab n t), ID)] +-- edges = S.toList . walk +-- +-- +-- -- | Traverse the automaton and collect all the edges. +-- -- +-- -- TODO: it is provided in the general case in the `Mini` module. +-- -- Remove the version below. +-- walk +-- :: (Ord n, Ord t) +-- => DAWG n t +-- -> S.Set (ID, Edge (Lab n t), ID) +-- walk dawg = +-- flip E.execState S.empty $ +-- flip E.evalStateT S.empty $ +-- doit (D.root dawg) +-- where +-- -- The embedded state serves to store the resulting set of +-- -- transitions; the surface state serves to keep track of +-- -- already visited nodes. +-- doit i = do +-- b <- E.gets $ S.member i +-- E.when (not b) $ do +-- E.modify $ S.insert i +-- E.forM_ (D.edges i dawg) $ \(x, j) -> do +-- E.lift . E.modify $ S.insert (i, x, j) +-- doit j diff --git a/src/NLP/Partage/Auto/List.hs b/src/NLP/Partage/Auto/List.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Auto/List.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + + +-- | List-based grammar representation: each rule is represented as a +-- separate, trivial automaton. + + +module NLP.Partage.Auto.List +( +-- -- * ListSet +-- ListSet +-- , buildList +-- +-- -- * Interface +-- , shell + fromGram +) where + + +import qualified Control.Arrow as Arr +import qualified Control.Monad.State.Strict as E + +import Data.Maybe (maybeToList) +import qualified Data.Set as S +import qualified Data.Map.Strict as M + +import Data.DAWG.Ord (ID) + +import qualified NLP.Partage.Auto as A +import NLP.Partage.FactGram (FactGram, Lab(..), Rule(..)) + + +-- | A single list. +type List a = Maybe (a, ID) + + +-- | List-based grammar representation: each rule is represented as a +-- separate, trivial automaton. +data ListSet a = ListSet + { rootSet :: S.Set ID + , listMap :: M.Map ID (List a) + } + + +-- | Convert list to a `ListSet`. +convert :: Ord a => [[a]] -> ListSet a +convert xs0 = ListSet + { rootSet = S.fromList rootList + , listMap = listMap0 } + where + (rootList, (_, listMap0)) = E.runState + (mapM mkList xs0) + (0 :: Int, M.empty) + mkList [] = do + i <- newID + yield i Nothing + return i + mkList (x:xs) = do + i <- newID + j <- mkList xs + yield i $ Just (x, j) + return i + newID = E.state $ \(n, m) -> (n, (n + 1, m)) + yield i node = E.modify $ Arr.second (M.insert i node) + + +-- | Follow symbol from the given node. +follow :: Ord a => ListSet a -> ID -> a -> Maybe ID +follow ListSet{..} i x = do + (y, j) <- E.join $ M.lookup i listMap + E.guard (x == y) + return j + + +-- | All edges outgoing from the given node ID. +edges :: ListSet a -> ID -> [(a, ID)] +edges ListSet{..} i + = maybeToList . E.join + $ M.lookup i listMap + + +-------------------------------------------------- +-- List from grammar +-------------------------------------------------- + + +-- | Build trie from the given grammar. +buildList :: (Ord n, Ord t) => FactGram n t -> [[A.Edge (Lab n t)]] +buildList gram = + [ map A.Body bodyR ++ [A.Head headR] + | Rule{..} <- S.toList gram ] + + +-------------------------------------------------- +-- Interface +-------------------------------------------------- + + +-- | Abstract over the concrete implementation. +shell :: (Ord n, Ord t) => [[A.Edge (Lab n t)]] -> A.GramAuto n t +shell d0 = A.Auto + { roots = rootSet d + , follow = follow d + , edges = edges d } + where d = convert d0 + + +-- | Build the list-based representation of the given grammar. +fromGram :: (Ord n, Ord t) => FactGram n t -> A.GramAuto n t +fromGram = shell . buildList diff --git a/src/NLP/Partage/Auto/Set.hs b/src/NLP/Partage/Auto/Set.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Auto/Set.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE RecordWildCards #-} + + +-- | A version in which a separate automaton is built (according to +-- the underlying building function) for each distinct rule head +-- symbol, i.e. the set of rules is first partitioned w.r.t. the +-- heads of the individual rules, and then for each partition a +-- separate automaton is built. + + +module NLP.Partage.Auto.Set +( +-- -- AutoSet +-- AutoSet +-- , buildAutoSet +-- +-- -- * Interface +-- , shell + fromGram +) where + + +import Control.Applicative ((<$>)) +import Control.Monad (forM) +import qualified Control.Monad.State.Strict as E +-- -- import Control.Monad.Trans.Class (lift) + +import Data.List (foldl') +import Data.Maybe (maybeToList) +import qualified Data.Set as S +import qualified Data.Map.Strict as M + +import Data.DAWG.Ord (ID) + +import NLP.Partage.FactGram + ( FactGram, Lab(..), Rule(..) ) + + +import qualified NLP.Partage.Auto as A + + +-------------------------------------------------- +-- Interface +-------------------------------------------------- + + +-- | Abstract over the concrete implementation of automaton. +shell :: (Ord a) => AutoSet a -> A.Auto a +shell AutoSet{..} = A.Auto + { roots = S.fromList + . map unExID + . S.toList $ rootSet + -- we could note in the specification of the + -- `Mini.Auto` that it doesn't have to be very + -- efficient because it is run only once per + -- parsing session + , follow = \e x -> do + (autoID, i) <- M.lookup (ExID e) fromExID + auto <- M.lookup autoID autoMap + j <- A.follow auto i x + unExID <$> M.lookup (autoID, j) toExID + , edges = \e -> do + let mtl = maybeToList + (autoID, i) <- mtl $ M.lookup (ExID e) fromExID + auto <- mtl $ M.lookup autoID autoMap + (x, j) <- A.edges auto i + e' <- mtl $ M.lookup (autoID, j) toExID + return (x, unExID e') + } + + +-- | Build the set of automata from the given grammar. +fromGram + :: (Ord n, Ord t) + => (FactGram n t -> A.GramAuto n t) + -- ^ The underlying automaton construction method + -> FactGram n t + -- ^ The grammar to compress + -> A.GramAuto n t +fromGram mkOne = shell . buildAutoSet mkOne + + +-------------------------------------------------- +-- Implementation +-------------------------------------------------- + + +-- | An external identifier (in contrast to internal identifiers +-- which are local to individual component automata). +newtype ExID = ExID { unExID :: ID } + deriving (Show, Eq, Ord) + + +-- | An automaton identifier. +newtype AutoID = AutoID { _unAutoID :: ID } + deriving (Show, Eq, Ord) + + +-- | An ensemble of automata. +data AutoSet a = AutoSet + { autoMap :: M.Map AutoID (A.Auto a) + -- ^ individual automata and their identifiers + , rootSet :: S.Set ExID + -- ^ A set of roots of the ensemble + , fromExID :: M.Map ExID (AutoID, ID) + -- ^ Map external IDs to internal ones + , toExID :: M.Map (AutoID, ID) ExID + -- ^ Reverse of `fromEx` + } + + +-- | An empty `AutoSet`. +emptyAS :: AutoSet a +emptyAS = AutoSet M.empty S.empty M.empty M.empty + + +-- | Assuming that two `AutoSet`s are disjoint (i.e. they have +-- disjoint sets of `AutoID`s and disjoin sets of `ExID`s), we can +-- union them easily. +unionAS :: AutoSet a -> AutoSet a -> AutoSet a +unionAS p q = AutoSet + { autoMap = M.union (autoMap p) (autoMap q) + , rootSet = S.union (rootSet p) (rootSet q) + , fromExID = M.union (fromExID p) (fromExID q) + , toExID = M.union (toExID p) (toExID q) } + + +-- | Union a list of `AutoSet`s. +unionsAS :: [AutoSet a] -> AutoSet a +unionsAS = foldl' unionAS emptyAS + + +-- | Build automata from the given grammar. +buildAutoSet + :: (Ord n, Ord t) + => (FactGram n t -> A.GramAuto n t) + -- ^ The underlying automaton construction method + -> FactGram n t + -- ^ The grammar to compress + -> AutoSet (A.Edge (Lab n t)) +buildAutoSet mkOne gram = runM $ + unionsAS <$> sequence + [ mkAutoSet + (AutoID autoID) + (mkOne ruleSet) + | (autoID, ruleSet) + <- zip [0..] (M.elems gramByHead) ] + where + -- grammar divided by rule heads + gramByHead = M.fromListWith S.union + [ (headR r, S.singleton r) + | r <- S.toList gram ] + -- build a single automatom + mkAutoSet autoID auto = do + rootMap <- mkNodeMap (A.roots auto) + descMap <- mkNodeMap (A.allIDs auto S.\\ A.roots auto) + let nodeMap = rootMap `M.union` descMap + return AutoSet + { autoMap = M.singleton autoID auto + , rootSet = M.keysSet rootMap + , fromExID = nodeMap + , toExID = rev1to1 nodeMap } + where + mkNodeMap inNodeSet = fmap M.fromList $ + forM (S.toList inNodeSet) $ \i -> do + e <- newExID + return (e, (autoID, i)) + -- low-level monad-related functions + runM = flip E.evalState (0 :: Int) + newExID = E.state $ \k -> (ExID k, k + 1) + -- reverse bijection + rev1to1 = M.fromList . map swap . M.toList + swap (x, y) = (y, x) diff --git a/src/NLP/Partage/Auto/Trie.hs b/src/NLP/Partage/Auto/Trie.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Auto/Trie.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + + +-- | Prefix tree grammar representation: the set of rules is stored +-- in a form of a prefix tree. + + +module NLP.Partage.Auto.Trie +( +-- -- * Trie +-- Trie +-- , empty +-- , insert +-- , fromLang +-- +-- -- * From grammar +-- , buildTrie +-- +-- -- * Interface +-- , shell + fromGram +) where + + +import qualified Control.Arrow as Arr +import Control.Applicative ((<$>), (<*>), pure) +import qualified Control.Monad.State.Strict as E + +import Data.Maybe (fromMaybe) +import Data.List (foldl') +import qualified Data.Set as S +import qualified Data.Map.Strict as M + +import Data.DAWG.Ord (ID) + +import qualified NLP.Partage.Auto as A +import NLP.Partage.FactGram (FactGram, Lab(..), Rule(..)) + + +-------------------------------------------------- +-- Trie +-------------------------------------------------- + + +-- | Simple trie implementation. +newtype Trie a = Trie { _unTrie :: M.Map a (Trie a) } + + +-- | Empty trie. +empty :: Trie a +empty = Trie M.empty + + +-- | Insert new element into the trie. +insert :: Ord a => [a] -> Trie a -> Trie a +insert (x:xs) (Trie t) = + let s = fromMaybe empty (M.lookup x t) + in Trie $ M.insert x (insert xs s) t +insert [] t = t + + +-- | Build trie from language. +fromLang :: Ord a => [[a]] -> Trie a +fromLang = foldl' (flip insert) empty + + +-------------------------------------------------- +-- Trie from grammar +-------------------------------------------------- + + +-- | Build trie from the given grammar. +buildTrie :: (Ord n, Ord t) => FactGram n t -> Trie (A.Edge (Lab n t)) +buildTrie gram = fromLang + [ map A.Body bodyR ++ [A.Head headR] + | Rule{..} <- S.toList gram ] + + +-------------------------------------------------- +-- Interface +-------------------------------------------------- + + +-- | Abstract over the concrete implementation. +shell :: (Ord n, Ord t) => Trie (A.Edge (Lab n t)) -> A.GramAuto n t +shell d0 = A.Auto + { roots = S.singleton (rootID d) + , follow = follow d + , edges = edges d } + where d = convert d0 + + +-- | Build the trie-based representation of the given grammar. +fromGram :: (Ord n, Ord t) => FactGram n t -> A.GramAuto n t +fromGram = shell . buildTrie + + +-- | Node type. +type Node a = M.Map a ID + + +-- | Alternative trie represetation with explicit node identifiers. +data ITrie a = ITrie + { rootID :: ID + -- ^ Root of the trie + , nodeMap :: M.Map ID (Node a) + } + + +-- | Follow symbol from the given node. +follow :: Ord a => ITrie a -> ID -> a -> Maybe ID +follow ITrie{..} i x = do + node <- M.lookup i nodeMap + M.lookup x node + + +-- | All edges outgoing from the given node ID. +edges :: ITrie a -> ID -> [(a, ID)] +edges ITrie{..} i = case M.lookup i nodeMap of + Nothing -> [] + Just m -> M.toList m + + +-- | Convert `Trie` to `ITrie`. +convert :: Ord a => Trie a -> ITrie a +convert t0 = ITrie + { rootID = root + , nodeMap = nodeMap' } + where + (root, (_, nodeMap')) = E.runState (doit t0) (0 :: Int, M.empty) + doit (Trie t) = do + i <- newID + node <- M.fromList <$> sequence + [ (,) <$> pure x <*> doit s + | (x, s) <- M.toList t ] + yield i node + return i + newID = E.state $ \(n, m) -> (n, (n + 1, m)) + yield i node = E.modify $ Arr.second (M.insert i node) diff --git a/src/NLP/Partage/Earley.hs b/src/NLP/Partage/Earley.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Earley.hs @@ -0,0 +1,41 @@ +-- | Earley-style TAG parsing based on automata, with a distinction +-- between active and passive items. + + +module NLP.Partage.Earley +( +-- * Earley-style parsing +-- $earley + recognize +, recognizeFrom +, parse +, earley +-- ** With automata precompiled +, recognizeAuto +, recognizeFromAuto +, parseAuto +, earleyAuto + +-- * Parsing trace (hypergraph) +, Hype +-- ** Extracting parsed trees +, parsedTrees +-- ** Stats +, hyperNodesNum +, hyperEdgesNum +-- ** Printing +, printHype + +-- * Sentence position +, Pos +) where + + +import NLP.Partage.Earley.AutoAP + +{- $earley + All the parsing functions described below employ the + "NLP.Partage.Auto.DAWG" grammar representation. + You can also pre-compile your own automaton and use it with + e.g. `parseAuto`. +-} diff --git a/src/NLP/Partage/Earley/AutoAP.hs b/src/NLP/Partage/Earley/AutoAP.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Earley/AutoAP.hs @@ -0,0 +1,1275 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + + +-- | Earley-style TAG parsing based on automata, with a distinction +-- between active and passive items. + + +module NLP.Partage.Earley.AutoAP +( +-- * Earley-style parsing + recognize +, recognizeFrom +, parse +, earley +-- ** With automata precompiled +, recognizeAuto +, recognizeFromAuto +, parseAuto +, earleyAuto + +-- * Parsing trace (hypergraph) +, Hype +-- ** Extracting parsed trees +, parsedTrees +-- ** Stats +, hyperNodesNum +, hyperEdgesNum +-- ** Printing +, printHype + +-- * Sentence position +, Pos +) where + + +import Prelude hiding (span, (.)) +import Control.Applicative ((<$>)) +import Control.Monad (guard, void, (>=>), when, forM_) +import Control.Monad.Trans.Class (lift) +-- import Control.Monad.Trans.Maybe (MaybeT (..)) +import qualified Control.Monad.RWS.Strict as RWS +import Control.Category ((>>>), (.)) + +import Data.Function (on) +import Data.Maybe ( isJust, isNothing, mapMaybe + , maybeToList ) +import qualified Data.Map.Strict as M +import Data.Ord ( comparing ) +import Data.List ( sortBy ) +import qualified Data.Set as S +import qualified Data.PSQueue as Q +import Data.PSQueue (Binding(..)) +import Data.Lens.Light +import qualified Data.Vector as V + +import qualified Pipes as P +-- import qualified Pipes.Prelude as P + +import Data.DAWG.Ord (ID) +-- import qualified Data.DAWG.Ord.Dynamic as D + +import NLP.Partage.SOrd +import NLP.Partage.FactGram (FactGram) +import NLP.Partage.FactGram.Internal + ( Lab(..), Rule(..), viewLab ) +import qualified NLP.Partage.Auto as A +import qualified NLP.Partage.Auto.DAWG as D +import qualified NLP.Partage.Tree as T + + +-------------------------------------------------- +-- BASE TYPES +-------------------------------------------------- + + +-- | A position in the input sentence. +type Pos = Int + + +data Span = Span { + -- | The starting position. + _beg :: Pos + -- | The ending position (or rather the position of the dot). + , _end :: Pos + -- | Coordinates of the gap (if applies) + , _gap :: Maybe (Pos, Pos) + } deriving (Show, Eq, Ord) +$( makeLenses [''Span] ) + + +-- | Active chart item : state reference + span. +data Active = Active { + _state :: ID + , _spanA :: Span + } deriving (Show, Eq, Ord) +$( makeLenses [''Active] ) + + +-- | Passive chart item : label + span. +data Passive n t = Passive { + _label :: Lab n t + , _spanP :: Span + } deriving (Show, Eq, Ord) +$( makeLenses [''Passive] ) + + +-- | Does it represent regular rules? +regular :: Span -> Bool +regular = isNothing . getL gap + + +-- | Does it represent auxiliary rules? +auxiliary :: Span -> Bool +auxiliary = isJust . getL gap + + +-- | Print an active item. +printSpan :: Span -> IO () +printSpan span = do + putStr . show $ getL beg span + putStr ", " + case getL gap span of + Nothing -> return () + Just (p, q) -> do + putStr $ show p + putStr ", " + putStr $ show q + putStr ", " + putStr . show $ getL end span + + +-- | Print an active item. +printActive :: Active -> IO () +printActive p = do + putStr "(" + putStr . show $ getL state p + putStr ", " + printSpan $ getL spanA p + putStrLn ")" + + +-- | Print a passive item. +printPassive :: (Show n, Show t) => Passive n t -> IO () +printPassive p = do + putStr "(" + putStr . viewLab $ getL label p + putStr ", " + printSpan $ getL spanP p + putStrLn ")" + + +-------------------------------------------------- +-- Traversal +-------------------------------------------------- + + +-- | Traversal represents an action of inducing a new item on the +-- basis of one or two other chart items. It can be seen as an +-- application of one of the inference rules specifying the parsing +-- algorithm. +-- +-- TODO: Sometimes there is no need to store all the arguments of the +-- inference rules, it seems. From one of the arguments the other +-- one could be derived. +data Trav n t + = Scan + { _scanFrom :: Active + -- ^ The input active state + , _scanTerm :: t + -- ^ The scanned terminal + } + | Subst + { _passArg :: Passive n t + -- ^ The passive argument of the action + , _actArg :: Active + -- ^ The active argument of the action + } + -- ^ Pseudo substitution + | Foot + { _actArg :: Active + -- ^ The passive argument of the action + -- , theFoot :: n + , _theFoot :: Passive n t + -- ^ The foot non-terminal + } + -- ^ Foot adjoin + | Adjoin + { _passAdj :: Passive n t + -- ^ The adjoined item + , _passMod :: Passive n t + -- ^ The modified item + } + -- ^ Adjoin terminate with two passive arguments + deriving (Show, Eq, Ord) + + +-- | Print a traversal. +printTrav :: (Show n, Show t) => Item n t -> Trav n t -> IO () +printTrav q' (Scan p x) = do + putStr "# " >> printActive p + putStr "+ " >> print x + putStr "= " >> printItem q' +printTrav q' (Subst p q) = do + putStr "# " >> printActive q + putStr "+ " >> printPassive p + putStr "= " >> printItem q' +printTrav q' (Foot q p) = do + putStr "# " >> printActive q + putStr "+ " >> printPassive p + putStr "= " >> printItem q' +printTrav q' (Adjoin p s) = do + putStr "# " >> printPassive p + putStr "+ " >> printPassive s + putStr "= " >> printItem q' + + +-------------------------------------------------- +-- Priority +-------------------------------------------------- + + +-- | Priority type. +-- +-- NOTE: Priority has to be composed from two elements because +-- otherwise `tryAdjoinTerm` could work incorrectly. That is, +-- the modified item could be popped from the queue after the +-- modifier (auxiliary) item and, as a result, adjunction would +-- not be considered. +type Prio = (Int, Int) + + +-- | Priority of an active item. Crucial for the algorithm -- +-- states have to be removed from the queue in a specific order. +prioA :: Active -> Prio +prioA p = + let i = getL (beg . spanA) p + j = getL (end . spanA) p + in (j, j - i) + + +-- | Priority of a passive item. Crucial for the algorithm -- +-- states have to be removed from the queue in a specific order. +prioP :: Passive n t -> Prio +prioP p = + let i = getL (beg . spanP) p + j = getL (end . spanP) p + in (j, j - i) + + +-- | Extended priority which preservs information about the traversal +-- leading to the underlying chart item. +data ExtPrio n t = ExtPrio + { prioVal :: Prio + -- ^ The actual priority + , prioTrav :: S.Set (Trav n t) + -- ^ Traversal leading to the underlying chart item + } deriving (Show) + +instance (Eq n, Eq t) => Eq (ExtPrio n t) where + (==) = (==) `on` prioVal +instance (Ord n, Ord t) => Ord (ExtPrio n t) where + compare = compare `on` prioVal + + +-- | Construct a new `ExtPrio`. +extPrio :: Prio -> ExtPrio n t +extPrio p = ExtPrio p S.empty + + +-- | Join two priorities: +-- * The actual priority preserved is the lower of the two, +-- * The traversals are unioned. +-- +-- NOTE: at the moment, priority is strictly specified by the +-- underlying chart item itself so we know that both priorities must +-- be equal. Later when we start using probabilities this statement +-- will no longer hold. +joinPrio :: (Ord n, Ord t) => ExtPrio n t -> ExtPrio n t -> ExtPrio n t +joinPrio x y = ExtPrio + (min (prioVal x) (prioVal y)) + (S.union (prioTrav x) (prioTrav y)) + + +-------------------------------------------------- +-- Item Type +-------------------------------------------------- + + +-- | Passive or active item. +data Item n t + = ItemP (Passive n t) + | ItemA Active + deriving (Show, Eq, Ord) + + +-- | Print an active item. +printItem :: (Show n, Show t) => Item n t -> IO () +printItem (ItemP p) = printPassive p +printItem (ItemA p) = printActive p + + +-- | Priority of an active item. Crucial for the algorithm -- +-- states have to be removed from the queue in a specific order. +prio :: Item n t -> Prio +prio (ItemP p) = prioP p +prio (ItemA p) = prioA p + + +-------------------------------------------------- +-- Earley monad +-------------------------------------------------- + + +-- | The reader of the earley monad: vector of sets of terminals. +type EarRd t = V.Vector (S.Set t) + + +-- | A hypergraph dynamically constructed during parsing. +data Hype n t = Hype + { automat :: A.GramAuto n t + -- ^ The underlying automaton (abstract implementation) + + , withBody :: M.Map (Lab n t) (S.Set ID) + -- ^ A data structure which, for each label, determines the + -- set of automaton states from which this label goes out + -- as a body transition. + + -- , doneActive :: M.Map (ID, Pos) (S.Set (Active n t)) + , doneActive :: M.Map Pos (M.Map ID + (M.Map Active (S.Set (Trav n t)))) + -- ^ Processed active items partitioned w.r.t ending + -- positions and state IDs. + + -- , donePassive :: S.Set (Passive n t) + , donePassive :: M.Map (Pos, n, Pos) + (M.Map (Passive n t) (S.Set (Trav n t))) + -- ^ Processed passive items. + + , waiting :: Q.PSQ (Item n t) (ExtPrio n t) + -- ^ The set of states waiting on the queue to be processed. + -- Invariant: the intersection of `done' and `waiting' states + -- is empty. + -- + -- NOTE2: Don't understand the note below... + -- NOTE: The only operation which requires active states to + -- be put to the queue in the current algorithm is the scan + -- operation. So perhaps we could somehow bypass this + -- problem and perform scan elsewhere. Nevertheless, it is + -- not certain that the same will apply to the probabilistic + -- parser. + } + + +-- | Make an initial `Hype` from a set of states. +mkHype + :: (Ord n, Ord t) + => A.GramAuto n t + -> S.Set Active + -> Hype n t +mkHype dag s = Hype + { automat = dag + , withBody = mkWithBody dag + , doneActive = M.empty + , donePassive = M.empty + , waiting = Q.fromList + [ ItemA p :-> extPrio (prioA p) + | p <- S.toList s ] } + + +-- | Create the `withBody` component based on the automaton. +mkWithBody + :: (Ord n, Ord t) + => A.GramAuto n t + -> M.Map (Lab n t) (S.Set ID) +mkWithBody dag = M.fromListWith S.union + [ (x, S.singleton i) + | (i, A.Body x, _j) <- A.allEdges dag ] + + +-- | Earley parser monad. Contains the input sentence (reader) +-- and the state of the computation `Hype'. +type Earley n t = RWS.RWST (EarRd t) () (Hype n t) IO + + +-- | Read word from the given position of the input. +readInput :: Pos -> P.ListT (Earley n t) t +readInput i = do + -- ask for the input + sent <- RWS.ask + -- just a safe way to retrieve the i-th element + -- each $ take 1 $ drop i xs + xs <- some $ sent V.!? i + each $ S.toList xs + + +-------------------------------------------------- +-- Hypergraph stats +-------------------------------------------------- + + +-- | Number of nodes in the parsing hypergraph. +hyperNodesNum :: Hype n t -> Int +hyperNodesNum e + = length (listPassive e) + + length (listActive e) + + +-- | Number of edges in the parsing hypergraph. +hyperEdgesNum :: forall n t. Hype n t -> Int +hyperEdgesNum earSt + = sumOver listPassive + + sumOver listActive + where + sumOver :: (Hype n t -> [(a, S.Set (Trav n t))]) -> Int + sumOver listIt = sum + [ S.size travSet + | (_, travSet) <- listIt earSt ] + + +-- | Extract hypergraph (hyper)edges. +hyperEdges :: Hype n t -> [(Item n t, Trav n t)] +hyperEdges earSt = + passiveEdges ++ activeEdges + where + passiveEdges = + [ (ItemP p, trav) + | (p, travSet) <- listPassive earSt + , trav <- S.toList travSet ] + activeEdges = + [ (ItemA p, trav) + | (p, travSet) <- listActive earSt + , trav <- S.toList travSet ] + + +-- | Print the hypergraph edges. +printHype :: (Show n, Show t) => Hype n t -> IO () +printHype earSt = + forM_ edges $ \(p, trav) -> + printTrav p trav + where + edges = sortIt (hyperEdges earSt) + sortIt = sortBy (comparing $ prio.fst) + + + +-------------------- +-- Active items +-------------------- + + +-- | List all active done items together with the corresponding +-- traversals. +listActive :: Hype n t -> [(Active, S.Set (Trav n t))] +listActive = (M.elems >=> M.elems >=> M.toList) . doneActive + + +-- | Return the corresponding set of traversals for an active item. +activeTrav + :: (Ord n, Ord t) + => Active -> Hype n t + -> Maybe (S.Set (Trav n t)) +activeTrav p + = ( M.lookup (p ^. spanA ^. end) + >=> M.lookup (p ^. state) + >=> M.lookup p ) + . doneActive + + +-- | Check if the active item is not already processed. +_isProcessedA :: (Ord n, Ord t) => Active -> Hype n t -> Bool +_isProcessedA p = + check . activeTrav p + where + check (Just _) = True + check _ = False + + +-- | Check if the active item is not already processed. +isProcessedA :: (Ord n, Ord t) => Active -> Earley n t Bool +isProcessedA p = _isProcessedA p <$> RWS.get + + +-- | Mark the active item as processed (`done'). +saveActive + :: (Ord t, Ord n) + => Active + -> S.Set (Trav n t) + -> Earley n t () +saveActive p ts = + RWS.state $ \s -> ((), s {doneActive = newDone s}) + where + newDone st = + M.insertWith + ( M.unionWith + ( M.unionWith S.union ) ) + ( p ^. spanA ^. end ) + ( M.singleton (p ^. state) + ( M.singleton p ts ) ) + ( doneActive st ) + + +-------------------- +-- Passive items +-------------------- + + +-- | List all passive done items together with the corresponding +-- traversals. +listPassive :: Hype n t -> [(Passive n t, S.Set (Trav n t))] +listPassive = (M.elems >=> M.toList) . donePassive + + +-- | Return the corresponding set of traversals for a passive item. +passiveTrav + :: (Ord n, Ord t) + => Passive n t -> Hype n t + -> Maybe (S.Set (Trav n t)) +passiveTrav p + = ( M.lookup + ( p ^. spanP ^. beg + , nonTerm $ p ^. label + , p ^. spanP ^. end ) >=> M.lookup p ) + . donePassive + + +-- | Check if the state is not already processed. +_isProcessedP :: (Ord n, Ord t) => Passive n t -> Hype n t -> Bool +_isProcessedP x = + check . passiveTrav x + where + check (Just _) = True + check _ = False + + +-- | Check if the passive item is not already processed. +isProcessedP :: (Ord n, Ord t) => Passive n t -> Earley n t Bool +isProcessedP p = _isProcessedP p <$> RWS.get + + +-- | Mark the passive item as processed (`done'). +savePassive + :: (Ord t, Ord n) + => Passive n t + -> S.Set (Trav n t) + -> Earley n t () +savePassive p ts = + RWS.state $ \s -> ((), s {donePassive = newDone s}) + where + newDone st = + M.insertWith + ( M.unionWith S.union ) + ( p ^. spanP ^. beg + , nonTerm $ p ^. label + , p ^. spanP ^. end ) + ( M.singleton p ts ) + ( donePassive st ) + + +-------------------- +-- Waiting Queue +-------------------- + + +-- | Add the active item to the waiting queue. Check first if it +-- is not already in the set of processed (`done') states. +pushActive :: (Ord t, Ord n) => Active -> Trav n t -> Earley n t () +pushActive p t = isProcessedA p >>= \b -> if b + then saveActive p $ S.singleton t + else modify' $ \s -> s {waiting = newWait (waiting s)} + where + newWait = Q.insertWith joinPrio (ItemA p) newPrio + newPrio = ExtPrio (prioA p) (S.singleton t) +-- pushActive p = RWS.state $ \s -> +-- let waiting' = if isProcessedA p s +-- then waiting s +-- else Q.insert (ItemA p) (prioA p) (waiting s) +-- in ((), s {waiting = waiting'}) + + +-- | Add the passive item to the waiting queue. Check first if it +-- is not already in the set of processed (`done') states. +pushPassive :: (Ord t, Ord n) => Passive n t -> Trav n t -> Earley n t () +pushPassive p t = isProcessedP p >>= \b -> if b + then savePassive p $ S.singleton t + else modify' $ \s -> s {waiting = newWait (waiting s)} + where + newWait = Q.insertWith joinPrio (ItemP p) newPrio + newPrio = ExtPrio (prioP p) (S.singleton t) +-- -- | Add the passive item to the waiting queue. Check first if it +-- -- is not already in the set of processed (`done') states. +-- pushPassive :: (Ord t, Ord n) => Passive n t -> Earley n t () +-- pushPassive p = RWS.state $ \s -> +-- let waiting' = if isProcessedP p s +-- then waiting s +-- else Q.insert (ItemP p) (prioP p) (waiting s) +-- in ((), s {waiting = waiting'}) + + +-- | Add to the waiting queue all items induced from the given item. +pushInduced :: (Ord t, Ord n) => Active -> Trav n t -> Earley n t () +pushInduced p t = do + hasElems (getL state p) >>= \b -> when b + (pushActive p t) + P.runListT $ do + x <- heads (getL state p) + lift . flip pushPassive t $ + Passive x (getL spanA p) + + +-- | Remove a state from the queue. +popItem + :: (Ord t, Ord n) + => Earley n t + (Maybe (Binding (Item n t) (ExtPrio n t))) +popItem = RWS.state $ \st -> case Q.minView (waiting st) of + Nothing -> (Nothing, st) + Just (b, s) -> (Just b, st {waiting = s}) + + +--------------------------------- +-- Extraction of Processed Items +--------------------------------- + + +-- | Return all active processed items which: +-- * expect a given label, +-- * end on the given position. +expectEnd + :: (Ord n, Ord t) => Lab n t -> Pos + -> P.ListT (Earley n t) Active +expectEnd sym i = do + Hype{..} <- lift RWS.get + -- determine items which end on the given position + doneEnd <- some $ M.lookup i doneActive + -- determine automaton states from which the given label + -- leaves as a body transition + stateSet <- some $ M.lookup sym withBody + -- pick one of the states + stateID <- each $ S.toList stateSet + -- + -- ALTERNATIVE: state <- each . S.toList $ + -- stateSet `S.intersection` M.keySet doneEnd + -- + -- determine items which refer to the chosen states + doneEndLab <- some $ M.lookup stateID doneEnd + -- return them all! + each $ M.keys doneEndLab + + +-- | Check if a passive item exists with: +-- * the given root non-terminal value (but not top-level +-- auxiliary) +-- * the given span +rootSpan + :: Ord n => n -> (Pos, Pos) + -> P.ListT (Earley n t) (Passive n t) +rootSpan x (i, j) = do + Hype{..} <- lift RWS.get + -- listValues (i, x, j) donePassive + each $ case M.lookup (i, x, j) donePassive of + Nothing -> [] + Just m -> M.keys m + + +-- -- | List all processed passive items. +-- listDone :: Done n t -> [Item n t] +-- listDone done = ($ done) $ +-- M.elems >=> M.elems >=> +-- M.elems >=> S.toList + + +-------------------------------------------------- +-- New Automaton-Based Primitives +-------------------------------------------------- + + +-- | Follow the given terminal in the underlying automaton. +followTerm :: (Ord n, Ord t) => ID -> t -> P.ListT (Earley n t) ID +followTerm i c = do + -- get the underlying automaton + auto <- RWS.gets automat + -- follow the label + some $ A.follow auto i (A.Body $ Term c) + + +-- | Follow the given body transition in the underlying automaton. +-- It represents the transition function of the automaton. +-- +-- TODO: merge with `followTerm`. +follow :: (Ord n, Ord t) => ID -> Lab n t -> P.ListT (Earley n t) ID +follow i x = do + -- get the underlying automaton + auto <- RWS.gets automat + -- follow the label + some $ A.follow auto i (A.Body x) + + +-- | Rule heads outgoing from the given automaton state. +heads :: ID -> P.ListT (Earley n t) (Lab n t) +heads i = do + auto <- RWS.gets automat + let mayHead (x, _) = case x of + A.Body _ -> Nothing + A.Head y -> Just y + each $ mapMaybe mayHead $ A.edges auto i + + +-- -- | Rule body elements outgoing from the given automaton state. +-- elems :: ID -> P.ListT (Earley n t) (Lab n t) +-- elems i = do +-- auto <- RWS.gets automat +-- let mayBody (x, _) = case x of +-- A.Body y -> Just y +-- A.Head _ -> Nothing +-- each $ mapMaybe mayBody $ A.edges auto i + + +-- | Check if any element leaves the given state. +hasElems :: ID -> Earley n t Bool +hasElems i = do + auto <- RWS.gets automat + let mayBody (x, _) = case x of + A.Body y -> Just y + A.Head _ -> Nothing + return + . not . null + . mapMaybe mayBody + $ A.edges auto i + + +-------------------------------------------------- +-- SCAN +-------------------------------------------------- + + +-- | Try to perform SCAN on the given active state. +tryScan :: (SOrd t, SOrd n) => Active -> Earley n t () +tryScan p = void $ P.runListT $ do + -- read the word immediately following the ending position of + -- the state + c <- readInput $ getL (spanA >>> end) p + -- follow appropriate terminal transition outgoing from the + -- given automaton state + j <- followTerm (getL state p) c + -- construct the resultant active item + -- let q = p {state = j, end = end p + 1} + let q = setL state j + . modL' (spanA >>> end) (+1) + $ p +#ifdef Debug + -- print logging information + lift . lift $ do + putStr "[S] " >> printActive p + putStr " : " >> printActive q +#endif + -- push the resulting state into the waiting queue + lift $ pushInduced q $ Scan p c + + +-------------------------------------------------- +-- SUBST +-------------------------------------------------- + + +-- | Try to use the passive item `p` to complement +-- (=> substitution) other rules. +trySubst :: (SOrd t, SOrd n) => Passive n t -> Earley n t () +trySubst p = void $ P.runListT $ do + let pLab = getL label p + pSpan = getL spanP p + -- make sure that `p' represents regular rules + guard . regular $ pSpan + -- find active items which end where `p' begins and which + -- expect the non-terminal provided by `p' (ID included) + q <- expectEnd pLab (getL beg pSpan) + -- follow the transition symbol + j <- follow (getL state q) pLab + -- construct the resultant state + -- let q' = q {state = j, spanA = spanA p {end = end p}} + let q' = setL state j + . setL (end.spanA) (getL end pSpan) + $ q +#ifdef Debug + -- print logging information + lift . lift $ do + putStr "[U] " >> printPassive p + putStr " + " >> printActive q + putStr " : " >> printActive q' +#endif + -- push the resulting state into the waiting queue + lift $ pushInduced q' $ Subst p q + + +-------------------------------------------------- +-- FOOT ADJOIN +-------------------------------------------------- + + +-- | `tryAdjoinInit p q': +-- * `p' is a completed state (regular or auxiliary) +-- * `q' not completed and expects a *real* foot +tryAdjoinInit :: (SOrd n, SOrd t) => Passive n t -> Earley n t () +tryAdjoinInit p = void $ P.runListT $ do + let pLab = p ^. label + pSpan = p ^. spanP + -- make sure that the corresponding rule is either regular or + -- intermediate auxiliary ((<=) used as implication here) + guard $ auxiliary pSpan <= not (topLevel pLab) + -- find all active items which expect a foot with the given + -- symbol and which end where `p` begins + let foot = AuxFoot $ nonTerm pLab + q <- expectEnd foot (getL beg pSpan) + -- follow the foot + j <- follow (getL state q) foot + -- construct the resultant state + let q' = setL state j + . setL (spanA >>> end) (pSpan ^. end) + . setL (spanA >>> gap) (Just + ( pSpan ^. beg + , pSpan ^. end )) + $ q +#ifdef Debug + -- print logging information + lift . lift $ do + putStr "[A] " >> printPassive p + putStr " + " >> printActive q + putStr " : " >> printActive q' +#endif + -- push the resulting state into the waiting queue + lift $ pushInduced q' $ Foot q p -- -- $ nonTerm foot + + +-------------------------------------------------- +-- INTERNAL ADJOIN +-------------------------------------------------- + + +-- | `tryAdjoinCont p q': +-- * `p' is a completed, auxiliary state +-- * `q' not completed and expects a *dummy* foot +tryAdjoinCont :: (SOrd n, SOrd t) => Passive n t -> Earley n t () +tryAdjoinCont p = void $ P.runListT $ do + let pLab = p ^. label + pSpan = p ^. spanP + -- make sure the label is not top-level (internal spine + -- non-terminal) + guard . not $ topLevel pLab + -- make sure that `p' is an auxiliary item + guard . auxiliary $ pSpan + -- find all rules which expect a spine non-terminal provided + -- by `p' and which end where `p' begins + q <- expectEnd pLab (pSpan ^. beg) + -- follow the spine non-terminal + j <- follow (q ^. state) pLab + -- construct the resulting state; the span of the gap of the + -- inner state `p' is copied to the outer state based on `q' + let q' = setL state j + . setL (spanA >>> end) (pSpan ^. end) + . setL (spanA >>> gap) (pSpan ^. gap) + $ q +#ifdef Debug + -- logging info + lift . lift $ do + putStr "[B] " >> printPassive p + putStr " + " >> printActive q + putStr " : " >> printActive q' +#endif + -- push the resulting state into the waiting queue + lift $ pushInduced q' $ Subst p q + + +-------------------------------------------------- +-- ROOT ADJOIN +-------------------------------------------------- + + +-- | Adjoin a fully-parsed auxiliary state `p` to a partially parsed +-- tree represented by a fully parsed rule/state `q`. +tryAdjoinTerm :: (SOrd t, SOrd n) => Passive n t -> Earley n t () +tryAdjoinTerm q = void $ P.runListT $ do + let qLab = q ^. label + qSpan = q ^. spanP + -- make sure the label is top-level + guard $ topLevel qLab + -- make sure that it is an auxiliary item (by definition only + -- auxiliary states have gaps) + (gapBeg, gapEnd) <- each $ maybeToList $ qSpan ^. gap + -- take all passive items with a given span and a given + -- root non-terminal (IDs irrelevant) + p <- rootSpan (nonTerm qLab) (gapBeg, gapEnd) + let p' = setL (spanP >>> beg) (qSpan ^. beg) + . setL (spanP >>> end) (qSpan ^. end) + $ p +#ifdef Debug + lift . lift $ do + putStr "[C] " >> printPassive q + putStr " + " >> printPassive p + putStr " : " >> printPassive p' +#endif + lift $ pushPassive p' $ Adjoin q p + + +-------------------------------------------------- +-- Earley step +-------------------------------------------------- + + +-- | Step of the algorithm loop. `p' is the state popped up from +-- the queue. +step + :: (SOrd t, SOrd n) + => Binding (Item n t) (ExtPrio n t) + -> Earley n t () +step (ItemP p :-> e) = do + mapM_ ($ p) + [ trySubst + , tryAdjoinInit + , tryAdjoinCont + , tryAdjoinTerm ] + savePassive p $ prioTrav e +step (ItemA p :-> e) = do + mapM_ ($ p) + [ tryScan ] + saveActive p $ prioTrav e + + +--------------------------- +-- Extracting Parsed Trees +--------------------------- + + +-- | Extract the set of parsed trees obtained on the given input +-- sentence. Should be run on the result of the earley algorithm. +parsedTrees + :: forall n t. (Ord n, Ord t) + => Hype n t -- ^ Final state of the earley parser + -> n -- ^ The start symbol + -> Int -- ^ Length of the input sentence + -> S.Set (T.Tree n t) +parsedTrees earSt start n + + = S.fromList + $ concatMap fromPassive + $ finalFrom start n earSt + + where + + fromPassive :: Passive n t -> [T.Tree n t] + fromPassive p = concat + [ fromPassiveTrav p trav + | travSet <- maybeToList $ passiveTrav p earSt + , trav <- S.toList travSet ] + + fromPassiveTrav p (Scan q t) = + [ T.Branch + (nonTerm $ getL label p) + (reverse $ T.Leaf t : ts) + | ts <- fromActive q ] + +-- fromPassiveTrav p (Foot q x) = +-- [ T.Branch +-- (nonTerm $ getL label p) +-- (reverse $ T.Branch x [] : ts) +-- | ts <- fromActive q ] + + fromPassiveTrav p (Foot q _p') = + [ T.Branch + (nonTerm $ getL label p) + (reverse $ T.Branch (nonTerm $ p ^. label) [] : ts) + | ts <- fromActive q ] + + fromPassiveTrav p (Subst qp qa) = + [ T.Branch + (nonTerm $ getL label p) + (reverse $ t : ts) + | ts <- fromActive qa + , t <- fromPassive qp ] + + fromPassiveTrav _p (Adjoin qa qm) = + [ replaceFoot ini aux + | aux <- fromPassive qa + , ini <- fromPassive qm ] + + -- | Replace foot (the only non-terminal leaf) by the given + -- initial tree. + replaceFoot ini (T.Branch _ []) = ini + replaceFoot ini (T.Branch x ts) = T.Branch x $ map (replaceFoot ini) ts + replaceFoot _ t@(T.Leaf _) = t + + + fromActive :: Active -> [[T.Tree n t]] + fromActive p = case activeTrav p earSt of + Nothing -> error "fromActive: unknown active item" + Just travSet -> if S.null travSet + then [[]] + else concatMap + (fromActiveTrav p) + (S.toList travSet) + + fromActiveTrav _p (Scan q t) = + [ T.Leaf t : ts + | ts <- fromActive q ] + + fromActiveTrav _p (Foot q p) = + [ T.Branch (nonTerm $ p ^. label) [] : ts + | ts <- fromActive q ] + +-- fromActiveTrav _p (Foot q x) = +-- [ T.Branch x [] : ts +-- | ts <- fromActive q ] + + fromActiveTrav _p (Subst qp qa) = + [ t : ts + | ts <- fromActive qa + , t <- fromPassive qp ] + + fromActiveTrav _p (Adjoin _ _) = + error "parsedTrees: fromActiveTrav called on a passive item" + + +-------------------------------------------------- +-- EARLEY +-------------------------------------------------- + + +-- | Does the given grammar generate the given sentence? +-- Uses the `earley` algorithm under the hood. +recognize +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => FactGram n t -- ^ The grammar (set of rules) + -> [S.Set t] -- ^ Input sentence + -> IO Bool +recognize gram = + recognizeAuto (D.fromGram gram) + + +-- | Does the given grammar generate the given sentence from the +-- given non-terminal symbol (i.e. from an initial tree with this +-- symbol in its root)? Uses the `earley` algorithm under the +-- hood. +recognizeFrom +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => FactGram n t -- ^ The grammar (set of rules) + -> n -- ^ The start symbol + -> [S.Set t] -- ^ Input sentence + -> IO Bool +recognizeFrom gram = + recognizeFromAuto (D.fromGram gram) + + +-- | Parse the given sentence and return the set of parsed trees. +parse +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => FactGram n t -- ^ The grammar (set of rules) + -> n -- ^ The start symbol + -> [S.Set t] -- ^ Input sentence + -> IO (S.Set (T.Tree n t)) +parse gram = parseAuto $ D.fromGram gram + + +-- | Perform the earley-style computation given the grammar and +-- the input sentence. +earley +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => FactGram n t -- ^ The grammar (set of rules) + -> [S.Set t] -- ^ Input sentence + -> IO (Hype n t) +earley gram = earleyAuto $ D.fromGram gram + + +-------------------------------------------------- +-- Parsing with automaton +-------------------------------------------------- + + +-- | See `recognize`. +recognizeAuto +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => A.GramAuto n t -- ^ Grammar automaton + -> [S.Set t] -- ^ Input sentence + -> IO Bool +recognizeAuto auto xs = + isRecognized xs <$> earleyAuto auto xs + + +-- | See `recognizeFrom`. +recognizeFromAuto +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => A.GramAuto n t -- ^ Grammar automaton + -> n -- ^ The start symbol + -> [S.Set t] -- ^ Input sentence + -> IO Bool +recognizeFromAuto auto start xs = do + earSt <- earleyAuto auto xs + return $ (not.null) (finalFrom start (length xs) earSt) + + +-- | See `parse`. +parseAuto +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => A.GramAuto n t -- ^ Grammar automaton + -> n -- ^ The start symbol + -> [S.Set t] -- ^ Input sentence + -> IO (S.Set (T.Tree n t)) +parseAuto auto start xs = do + earSt <- earleyAuto auto xs + return $ parsedTrees earSt start (length xs) + + +-- | See `earley`. +earleyAuto +#ifdef Debug + :: (SOrd t, SOrd n) +#else + :: (Ord t, Ord n) +#endif + => A.GramAuto n t -- ^ Grammar automaton + -> [S.Set t] -- ^ Input sentence + -> IO (Hype n t) +earleyAuto dawg xs = + fst <$> RWS.execRWST loop (V.fromList xs) st0 + where + -- we put in the initial state all the states with the dot on + -- the left of the body of the rule (-> left = []) on all + -- positions of the input sentence. + st0 = mkHype dawg $ S.fromList + [ Active root Span + { _beg = i + , _end = i + , _gap = Nothing } + | i <- [0 .. length xs - 1] + , root <- S.toList (A.roots dawg) ] + -- the computation is performed as long as the waiting queue + -- is non-empty. + loop = popItem >>= \mp -> case mp of + Nothing -> return () + Just p -> step p >> loop + + +-------------------------------------------------- +-- New utilities +-------------------------------------------------- + + +-- | Return the list of final passive chart items. +finalFrom + :: (Ord n, Eq t) + => n -- ^ The start symbol + -> Int -- ^ The length of the input sentence + -> Hype n t -- ^ Result of the earley computation + -> [Passive n t] +finalFrom start n Hype{..} = + case M.lookup (0, start, n) donePassive of + Nothing -> [] + Just m -> + [ p + | p <- M.keys m + , p ^. label == NonT start Nothing ] + + +-- -- | Return the list of final passive chart items. +-- final +-- :: (Ord n, Eq t) +-- -> Int -- ^ The length of the input sentence +-- -> Hype n t -- ^ Result of the earley computation +-- -> [Passive n t] +-- final start n Hype{..} = +-- case M.lookup (0, start, n) donePassive of +-- Nothing -> [] +-- Just m -> +-- [ p +-- | p <- M.keys m +-- , p ^. label == NonT start Nothing ] + + +-- | Check whether the given sentence is recognized +-- based on the resulting state of the earley parser. +-- +-- TODO: The function returns `True` also when a subtree +-- of an elementary tree is recognized, it seems. +isRecognized + :: (SOrd t, SOrd n) + => [S.Set t] -- ^ Input sentence + -> Hype n t -- ^ Earley parsing result + -> Bool +isRecognized xs Hype{..} = + (not . null) + (complete + (agregate donePassive)) + where + n = length xs + complete done = + [ True | item <- S.toList done + , item ^. spanP ^. beg == 0 + , item ^. spanP ^. end == n + , isNothing (item ^. spanP ^. gap) ] + agregate = S.unions . map M.keysSet . M.elems + + +-------------------------------------------------- +-- Utilities +-------------------------------------------------- + + +-- | Strict modify (in mtl starting from version 2.2). +modify' :: RWS.MonadState s m => (s -> s) -> m () +modify' f = do + x <- RWS.get + RWS.put $! f x + + +-- -- | MaybeT transformer. +-- maybeT :: Monad m => Maybe a -> MaybeT m a +-- maybeT = MaybeT . return + + +-- | ListT from a list. +each :: Monad m => [a] -> P.ListT m a +each = P.Select . P.each + + +-- | ListT from a maybe. +some :: Monad m => Maybe a -> P.ListT m a +some = each . maybeToList + + +-- | Is the rule with the given head top-level? +topLevel :: Lab n t -> Bool +topLevel x = case x of + NonT{..} -> isNothing labID + AuxRoot{} -> True + _ -> False + + +-- -- | Pipe all values from the set corresponding to the given key. +-- listValues +-- :: (Monad m, Ord a) +-- => a -> M.Map a (S.Set b) +-- -> P.ListT m b +-- listValues x m = each $ case M.lookup x m of +-- Nothing -> [] +-- Just s -> S.toList s diff --git a/src/NLP/Partage/FactGram.hs b/src/NLP/Partage/FactGram.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/FactGram.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + + +-- | TAG conversion into flat production rules. + + +module NLP.Partage.FactGram +( +-- * Factorized grammar + FactGram +, Rule (..) +, Lab (..) + +-- * Grammar flattening +, flattenNoSharing +, flattenWithSharing +) where + + +import NLP.Partage.FactGram.Internal +import NLP.Partage.SubtreeSharing diff --git a/src/NLP/Partage/FactGram/Internal.hs b/src/NLP/Partage/FactGram/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/FactGram/Internal.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + + +-- | TAG conversion into flat production rules. + + +module NLP.Partage.FactGram.Internal +( +-- * Grammar + FactGram +, Rule (..) +, Lab (..) +, SymID + +-- * Grammar flattening +, flattenNoSharing +-- , compileWeights + +-- * Showing +, viewLab + +-- * Internal +, runRM +, treeRules +, auxRules +) where + + +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.State.Strict as E + +import qualified Data.Set as S +-- import qualified Data.Map.Strict as M +import qualified Data.Tree as T + +import qualified Pipes as P + +import qualified NLP.Partage.Tree as G + + +-------------------------------------------------- +-- CORE TYPES +-------------------------------------------------- + + +-- | 'SymID' is used to mark internal (non-leaf, non-root) +-- non-terminals with unique (up to subtree sharing) identifiers so +-- that incompatible rule combinations are not possible. +type SymID = Int + + +-- -- | Cost (weight, probability) of employing an elementary +-- -- unit (tree, rule) in a parse tree. +-- type Cost = Double + + +---------------------- +-- Factorized grammar +---------------------- + + +-- | Factorized grammar: a set of flat production rules. +type FactGram n t = S.Set (Rule n t) + + +---------------------- +-- Grammar compilation +---------------------- + + +-- | Compile the given grammar into the list of rules. +-- No structure sharing takes place here. +flattenNoSharing + :: (Monad m, Ord n, Ord t) + => [ Either + (G.Tree n t) + (G.AuxTree n t) ] + -> m (FactGram n t) +flattenNoSharing ts = + flip E.execStateT S.empty $ runRM $ P.runEffect $ + P.for rules $ \rule -> + lift . lift $ E.modify $ S.insert rule + where + rules = mapM_ getRules ts + getRules (Left t) = treeRules t + getRules (Right t) = auxRules t + + +-- -- | Compile the given probabilistic grammar into the list of rules. No +-- -- structure sharing takes place. Weights are evenly distributed over all +-- -- rules representing the corresponding elementary trees. +-- compileWeights +-- :: (Monad m, Ord n, Ord t) +-- => [ Either +-- (G.Tree n t, Cost) +-- (G.AuxTree n t, Cost) ] +-- -> m (M.Map (Rule n t) Cost) +-- compileWeights ts = +-- flip E.execStateT M.empty $ runRM $ P.runEffect $ +-- P.for rules $ \(rule, cost) -> +-- lift . lift $ E.modify $ M.insert rule cost +-- where +-- rules = mapM_ getRules ts +-- getRules (Left (t, c0)) = do +-- labTree <- lift $ labelTree True t +-- keepRules labTree c0 +-- return $ T.rootLabel labTree +-- getRules (Right (t, c0)) = do +-- labTree <- lift $ labelAux True t +-- keepRules labTree c0 +-- return $ T.rootLabel labTree +-- keepRules labTree c0 = do +-- let rs = collect labTree +-- c = c0 / fromIntegral (length rs) +-- mapM_ keepRule [ (r, c) | r <- rs ] + + +---------------------- +-- Initial Trees +---------------------- + + +-- | A label is a data type over which flat production rules are +-- constructed. In particular, it describes what information is +-- stored in the heads of rules, as well as in the elements of the +-- their bodies. +data Lab n t + = NonT + { nonTerm :: n + , labID :: Maybe SymID } + -- ^ A non-terminal symbol originating from a branching, + -- non-spine node, optionally marked with a `SymID` if + -- originating from an internal (non-root, non-leaf) node + | Term t + -- ^ A terminal symbol + | AuxRoot + { nonTerm :: n } + -- ^ A non-terminal originating from a /root/ of an auxiliary tree + | AuxFoot + { nonTerm :: n } + -- ^ A non-terminal originating from a /foot/ of an auxiliary tree + | AuxVert + { nonTerm :: n + , symID :: SymID } + -- ^ A non-terminal originating from a /spine/ of an auxiliary + -- tree (unless root or foot) + deriving (Show, Eq, Ord) + + +-- | Show full info about the label. +viewLab :: (Show n, Show t) => Lab n t -> String +viewLab lab = case lab of + NonT{..} -> "N(" ++ show nonTerm + ++ ( case labID of + Nothing -> "" + Just i -> ", " ++ show i ) ++ ")" + Term t -> "T(" ++ show t ++ ")" + AuxRoot{..} -> "A(" ++ show nonTerm ++ ")" + AuxFoot x -> "F(" ++ show x ++ ")" + AuxVert{..} -> "V(" ++ show nonTerm ++ ", " ++ show symID ++ ")" + + +-- -- | Show the label. +-- viewLab :: (View n, View t) => Lab n t -> String +-- viewLab (NonT s) = "N" ++ viewSym s +-- viewLab (Term t) = "T(" ++ view t ++ ")" +-- viewLab (Foot s) = "F" ++ viewSym s + + +-- | A production rule, responsible for recognizing a specific +-- (unique) non-trivial (of height @> 0@) subtree of an elementary +-- grammar tree. Due to potential subtree sharing, a single rule can +-- be responsible for recognizing a subtree common to many different +-- elementary trees. +-- +-- Invariants: +-- +-- * `headR` is neither `Term` nor `AuxFoot` +data Rule n t = Rule { + -- | Head of the rule + headR :: Lab n t + -- | Body of the rule + , bodyR :: [Lab n t] + } deriving (Show, Eq, Ord) + + +-- -- | Print the rule. +-- printRule +-- :: ( View n, View t ) +-- => Rule n t -> IO () +-- printRule Rule{..} = do +-- putStr $ viewLab headR +-- putStr " -> " +-- putStr . unwords $ map viewLab bodyR + + +-------------------------- +-- Rule generation monad +-------------------------- + + +-- | Identifier generation monad. +type ID m = E.StateT Int m + + +-- | Generating rules in a pipe. +type RM r m = P.Producer r (ID m) + + +-- | Pull the next identifier. +nextSymID :: E.MonadState SymID m => m SymID +nextSymID = E.state $ \i -> (i, i + 1) + + +-- | Save the rule in the writer component of the monad. +keepRule :: Monad m => r -> RM r m () +keepRule = P.yield + + +-- | Evaluate the state part of the RM monad. +-- runRM :: Monad m => P.Effect (E.StateT Int m) a -> m a +-- runRM = flip E.evalStateT 0 . P.runEffect +runRM :: Monad m => E.StateT Int m a -> m a +runRM = flip E.evalStateT 0 + + +----------------------------------------- +-- Tree Factorization +----------------------------------------- + + +-- instance (ToString a, ToString b) => ToString (Either a b) where +-- toString (Left x) = "L " ++ toString x +-- toString (Right x) = "R " ++ toString x + + +-- | Take an initial tree and factorize it into a list of rules. +treeRules + :: (Monad m) + => G.Tree n t -- ^ The tree itself + -> RM (Rule n t) m (Lab n t) +treeRules t = do + labTree <- lift $ labelTree True t + mapM_ keepRule $ collect labTree + return $ T.rootLabel labTree + + +-- | Take an initial tree and factorize it into a tree of labels. +labelTree + :: (Monad m) + => Bool -- ^ Is it a top level tree? `True' for + -- an entire initial tree, `False' otherwise. + -> G.Tree n t -- ^ The tree itself + -> ID m (T.Tree (Lab n t)) +labelTree isTop G.Branch{..} = case (subTrees, isTop) of + -- Foot or substitution node: + ([], _) -> return . flip T.Node [] $ NonT + { nonTerm = labelI + , labID = Nothing } + -- Root node: + (_, True) -> do + let x = NonT + { nonTerm = labelI + , labID = Nothing } + xs <- mapM (labelTree False) subTrees + return $ T.Node x xs + -- Internal node: + (_, False) -> do + i <- nextSymID + let x = NonT + { nonTerm = labelI + , labID = Just i } + xs <- mapM (labelTree False) subTrees + return $ T.Node x xs +labelTree _ G.Leaf{..} = return $ T.Node (Term labelF) [] + + +----------------------------------------- +-- Auxiliary Tree Factorization +----------------------------------------- + + +-- | Take an auxiliary tree and factorize it into a tree of labels. +auxRules + :: (Monad m) + => G.AuxTree n t + -> RM (Rule n t) m (Lab n t) +auxRules t = do + labTree <- lift $ labelAux True t + mapM_ keepRule $ collect labTree + return $ T.rootLabel labTree + + +-- | Take an auxiliary tree and factorize it into a tree of labels. +labelAux + :: (Monad m) + => Bool + -> G.AuxTree n t + -> ID m (T.Tree (Lab n t)) +labelAux b G.AuxTree{..} = + doit b auxTree auxFoot + where + doit _ G.Branch{..} [] = return . flip T.Node [] $ + AuxFoot {nonTerm = labelI} + doit isTop G.Branch{..} (k:ks) = do + let (ls, bt, rs) = split k subTrees + ls' <- mapM (labelTree False) ls + bt' <- doit False bt ks + rs' <- mapM (labelTree False) rs + -- In case of an internal node `xt` and `xb` are slighly + -- different; for a root, they are the same: + x0 <- if isTop + then return AuxRoot + { nonTerm = labelI } + else nextSymID >>= \i -> + return AuxVert + { nonTerm = labelI + , symID = i } + -- keepRule $ Rule x0 $ ls' ++ (bt' : rs') + -- return x0 + return $ T.Node x0 $ ls' ++ (bt' : rs') + doit _ _ _ = error "auxRules: incorrect path" + + +----------------------------------------- +-- Utils +----------------------------------------- + + +-- | Split the given list on the given position. +split :: Int -> [a] -> ([a], a, [a]) +split = + doit [] + where + doit acc 0 (x:xs) = (reverse acc, x, xs) + doit acc k (x:xs) = doit (x:acc) (k-1) xs + doit _ _ [] = error "auxRules.split: index to high" + + +-- | Collect rules present in the tree produced by `labelTree`. +collect :: T.Tree (Lab n t) -> [Rule n t] +collect T.Node{..} = case subForest of + [] -> [] + -- WARNING! It is crucial for substructure-sharing (at least in + -- the current implementation, that indexes (SymIDs) are + -- generated in the ascending order. This stems from the fact + -- that `Data.Partition.rep` returns the minimum element of the + -- given partition, thus making it impossible to choose a custom + -- representant of the given partition. + -- + -- Note that this solution should be changed and that + -- substructure sharing should be implemented differently. + -- The current solution seems too error prone. + _ -> concatMap collect subForest + ++ [ Rule rootLabel + (map T.rootLabel subForest) ] diff --git a/src/NLP/Partage/Gen.hs b/src/NLP/Partage/Gen.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Gen.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + + +-- | A simple, experimental tree generation module, with the aim +-- to generate /all/, or /randomly/, language trees satisfying +-- certain simple constraints. +-- +-- One of the possible usecases where such a functionality can be +-- useful is to automatically generate test sets over which +-- efficiency of a parser can be measured. + + +module NLP.Partage.Gen +( Gram + +-- * Generation +, generateAll +-- ** Randomized generation +, generateRand +, GenConf (..) +) where + + + +import Control.Applicative ((<$>), (<*>)) +import qualified Control.Monad.State.Strict as E +import Control.Monad.Trans.Maybe (MaybeT (..)) + +import Pipes +import qualified Pipes.Prelude as Pipes +import System.Random (randomRIO) + +import qualified Data.Foldable as F +import Data.Maybe (maybeToList) +import qualified Data.Set as S +import qualified Data.Map.Strict as M +import qualified Data.PSQueue as Q +import Data.PSQueue (Binding(..)) +import qualified Data.Tree as R + +import NLP.Partage.Tree.Other + + +-------------------------- +-- Basic types +-------------------------- + + +deriving instance (Ord n, Ord t) => (Ord (Tree n t)) + + +-- | A TAG grammar: a set of (elementary) initial and auxiliary +-- trees. +type Gram n t = S.Set (Tree n t) + + +-------------------------- +-- Tree size +-------------------------- + + +-- | Size of a tree, i.e. number of nodes. +treeSize :: Tree n t -> Int +treeSize = length . R.flatten + + +-------------------------- +-- Generation state +-------------------------- + + +-- | Map of visited trees. +type DoneMap n t = M.Map Int (S.Set (Tree n t)) + + +-- | Underlying state of the generation pipe. +data GenST n t = GenST { + waiting :: Q.PSQ (Tree n t) Int + -- ^ Queue of the derived trees yet to be visited. + , doneFinal :: DoneMap n t + -- ^ Set of visited, final trees divided by size + , doneActive :: DoneMap n t + -- ^ Set of visited, active (not final) trees divided by size + } + + +-- | Construct new generation state with all trees in the priority queue. +newGenST :: (Ord n, Ord t) => Gram n t -> GenST n t +newGenST gramSet = GenST { + waiting = Q.fromList + [ t :-> treeSize t + | t <- S.toList gramSet ] + , doneFinal = M.empty + , doneActive = M.empty } + + +-- | Pop the tree with the lowest score from the queue. +pop + :: (E.MonadState (GenST n t) m, Ord n, Ord t) + -- => m (Maybe (Tree n t)) + => ListT m (Tree n t) +pop = do + mayTree <- E.state $ \s@GenST{..} -> case Q.minView waiting of + Nothing -> (Nothing, s) + Just (t :-> _, q) -> (Just t, s {waiting=q}) + -- return mayTree + some $ maybeToList mayTree + + +-- | Push tree into the waiting queue. +push :: (E.MonadState (GenST n t) m, Ord n, Ord t) => Tree n t -> m () +push t = E.modify $ \s -> s + {waiting = Q.insert t (treeSize t) (waiting s)} + + +-- | Save tree as visited. +save :: (E.MonadState (GenST n t) m, Ord n, Ord t) => Tree n t -> m () +save t = if isFinal t + then E.modify $ \s -> s + { doneFinal = M.insertWith S.union + (treeSize t) (S.singleton t) (doneFinal s) } + else E.modify $ \s -> s + { doneActive = M.insertWith S.union + (treeSize t) (S.singleton t) (doneActive s) } + + +-- | Check if tree already visited. +visited + :: (E.MonadState (GenST n t) m, Ord n, Ord t) + => Tree n t -> m Bool +visited t = if isFinal t + then isVisited doneFinal + else isVisited doneActive + where + isVisited doneMap = do + done <- E.gets doneMap + return $ case M.lookup (treeSize t) done of + Just ts -> S.member t ts + Nothing -> False + + +-- | Retrieve all trees from the given map with the size satsifying +-- the given condition. +visitedWith + :: (E.MonadState (GenST n t) m, Ord n, Ord t) + => (GenST n t -> DoneMap n t) + -> (Int -> Bool) + -> ListT m (Tree n t) +visitedWith doneMap cond = do + done <- E.gets doneMap + some [ t + | (k, treeSet) <- M.toList done + , cond k, t <- S.toList treeSet ] + + +-- -- | Retrieve all visited final trees with a size satsifying the +-- -- given condition. +-- finalWith +-- :: (E.MonadState (GenST n t) m, Ord n, Ord t) +-- => (Int -> Bool) -> ListT m (Tree n t) +-- finalWith = visitedWith doneFinal +-- +-- +-- -- | Retrieve all visited trees with a size satsifying +-- -- the given condition. +-- activeWith +-- :: (E.MonadState (GenST n t) m, Ord n, Ord t) +-- => (Int -> Bool) -> ListT m (Tree n t) +-- activeWith cond = visitedWith doneActive + + +-------------------------- +-- Higher-level generation +-------------------------- + + +-- | Randomized generation configuration. +-- First all derivable trees up to the size `genAllSize` are +-- generated, and on this basis other derived trees (with adjunction +-- probability controlled by `adjProb`) are constructed. +data GenConf = GenConf { + genAllSize :: Int + -- ^ Generate all derivable trees up to the given size + , adjProb :: Double + -- ^ Adjunction probability + } deriving (Show, Eq, Ord) + + +-- | Randomly generate derived trees from the grammar, according to +-- the given configuration. +generateRand + :: (MonadIO m, Ord n, Ord t) + => Gram n t + -> GenConf + -> Producer (Tree n t) m () +generateRand gramSet cfg = E.forever $ do + finalSet <- collect basePipe + mayTree <- drawTree gramSet finalSet cfg + F.forM_ mayTree yield +-- case mayTree of +-- Nothing -> return () +-- Just t -> yield t + where + -- first compute the base set of final trees + basePipe = generateAll gramSet (genAllSize cfg) + >-> Pipes.filter isFinal + + +-- | Try to construct randomly a tree based on the TAG grammar and +-- on the pre-built set of derived final trees. +drawTree + :: (MonadIO m, Ord n, Ord t) + => Gram n t -- ^ The grammar + -> Gram n t -- ^ Final trees + -> GenConf -- ^ Global config + -> m (Maybe (Tree n t)) +drawTree gramSet finalSet GenConf{..} = runMaybeT $ do + -- randomly draw an elementary tree + t0 <- drawFrom $ limitTo isInitial gramSet + -- recursivey modify the tree + modify t0 + where + modify t@(R.Node (Term _) []) = + return t + modify (R.Node (NonTerm x) []) = + let cond = (&&) <$> hasRoot x <*> isInitial + in drawFrom (limitTo cond finalSet) + modify (R.Node (NonTerm x) xs0) = do + -- modify subtrees + xs <- mapM modify xs0 + -- construct the new tree + let t = R.Node (NonTerm x) xs + -- adjoin some tree if lucky + lottery adjProb (return t) $ do + let cond = (&&) <$> hasRoot x <*> isAuxiliary + auxTree <- drawFrom $ limitTo cond finalSet + return $ replaceFoot t auxTree + modify _ = error "drawTree.modify: unhandled node type" + drawFrom s = do + E.guard $ S.size s > 0 + i <- liftIO $ randomRIO (0, S.size s - 1) + -- return $ S.elemAt i s <- works starting from containers 0.5.2 + return $ S.toList s !! i + limitTo f = S.fromList . filter f . S.toList + + + +-------------------------- +-- Generation +-------------------------- + + +-- | Type of the generator. +type Gen m n t = E.StateT (GenST n t) (Producer (Tree n t) m) () + + +-- | Generate all trees derivable from the given grammar up to the +-- given size. +generateAll + :: (MonadIO m, Ord n, Ord t) + => Gram n t -> Int -> Producer (Tree n t) m () +generateAll gram0 sizeMax = + -- gram <- subGram gram0 + E.evalStateT + (genPipe sizeMax) + (newGenST gram0) + + +-- -- | Select sub-grammar rules. +-- subGram +-- :: (MonadIO m, Ord n, Ord t) => Double -> Gram n t -> m (Gram n t) +-- subGram probMax gram = do +-- stdGen <- liftIO getStdGen +-- let ps = randomRs (0, 1) stdGen +-- return $ S.fromList +-- [t | (t, p) <- zip (S.toList gram) ps, p <= probMax] + + +-- | A function which generates trees derived from the grammar. The +-- second argument allows to specify a probability of ignoring a tree +-- popped up from the waiting queue. When set to `1`, all derived +-- trees up to the given size should be generated. +genPipe :: (MonadIO m, Ord n, Ord t) => Int -> Gen m n t +genPipe sizeMax = runListT $ do + -- pop best-score tree from the queue + t <- pop + lift $ do + genStep sizeMax t + genPipe sizeMax + + +-- | Generation step. +genStep + :: (MonadIO m, Ord n, Ord t) + => Int -- ^ Tree size limit + -> Tree n t -- ^ Tree from the queue + -> Gen m n t +genStep sizeMax t = runListT $ do + -- check if it's not in the set of visited trees yet + -- TODO: is it even necessary? + E.guard . not =<< visited t + + -- save tree `t` and yield it + save t + lift . lift $ yield t + + -- choices based on whether 't' is final + let doneMap = if isFinal t + then doneActive + else doneFinal + + -- find all possible combinations of 't' and some visited 'u', + -- and add them to the waiting queue; + -- note that `t` is now in the set of visited trees -- + -- this allows the process to generate `combinations t t`; + u <- visitedWith doneMap $ + let n = treeSize t + in \k -> k + n <= sizeMax + 1 + + -- NOTE: at this point we know that `v` cannot yet be visited; + -- it must be larger than any tree in the set of visited trees. + let combine x y = some $ + inject x y ++ + inject y x + v <- combine t u + + -- we only put to the queue trees which do not exceed + -- the specified size + E.guard $ treeSize v <= sizeMax + push v + + +--------------------------------------------------------------------- +-- Composition +--------------------------------------------------------------------- + + +-- | Identify all possible ways to inject (i.e. substitute +-- or adjoin) the first tree to the second one. +inject :: (Eq n, Eq t) => Tree n t -> Tree n t -> [Tree n t] +inject s t = if isAuxiliary s + then adjoin s t + else subst s t + + +-- | Compute all possible ways of adjoining the first tree into the +-- second one. +adjoin :: (Eq n, Eq t) => Tree n t -> Tree n t -> [Tree n t] +adjoin _ (R.Node (NonTerm _) []) = [] +adjoin s (R.Node n ts) = + here ++ below + where + -- perform adjunction here + here = [replaceFoot (R.Node n ts) s | R.rootLabel s == n] + -- consider to perform adjunction lower in the tree + below = map (R.Node n) (doit ts) + doit [] = [] + doit (x:xs) = + [u : xs | u <- adjoin s x] ++ + [x : us | us <- doit xs] + + +-- | Replace foot of the second tree with the first tree. +-- If there is no foot in the second tree, it will be returned +-- unchanged. +replaceFoot :: Tree n t -> Tree n t -> Tree n t +replaceFoot t (R.Node (Foot _) []) = t +replaceFoot t (R.Node x xs) = R.Node x $ map (replaceFoot t) xs + + +-- | Compute all possible ways of substituting the first tree into +-- the second one. +subst :: (Eq n, Eq t) => Tree n t -> Tree n t -> [Tree n t] +subst s = take 1 . _subst s + + +-- | Compute all possible ways of substituting the first tree into +-- the second one. +_subst :: (Eq n, Eq t) => Tree n t -> Tree n t -> [Tree n t] +_subst s (R.Node n []) = + [s | R.rootLabel s == n] +_subst s (R.Node n ts) = + map (R.Node n) (doit ts) + where + doit [] = [] + doit (x:xs) = + [u : xs | u <- subst s x] ++ + [x : us | us <- doit xs] + + +-------------------------- +-- Utils +-------------------------- + + +-- -- | MaybeT constructor. +-- maybeT :: Monad m => Maybe a -> MaybeT m a +-- maybeT = MaybeT . return + + +-- | ListT from a list. +some :: Monad m => [a] -> ListT m a +some = Select . each + + +-- -- | Draw a number between 0 and 1, and check if it is <= the given +-- -- maximal probability. +-- lottery :: (MonadPlus m, MonadIO m) => Double -> m () +-- lottery probMax = do +-- p <- liftIO $ randomRIO (0, 1) +-- E.guard $ p <= probMax + + +-- | Collect elements from the pipe into a set. +collect :: (Monad m, Ord a) => Producer a m () -> m (S.Set a) +collect inputPipe = + flip E.execStateT S.empty + $ runEffect + $ hoist lift inputPipe >-> collectPipe + where + collectPipe = E.forever $ do + x <- await + lift . E.modify $ S.insert x + + +-- | Run `my` if lucky, `mx` otherwise. +lottery :: (MonadIO m, MonadPlus m) => Double -> m a -> m a -> m a +lottery probMax mx my = do + p <- liftIO $ randomRIO (0, 1) + if p > probMax + then mx + else my diff --git a/src/NLP/Partage/SOrd.hs b/src/NLP/Partage/SOrd.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/SOrd.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} + + +-- | Internal typeclass representing `Show` + `Ord`. + + +module NLP.Partage.SOrd +( SOrd +) where + + +-- | 'Show' + 'Ord' +#ifdef Debug +class (Show a, Ord a) => SOrd a where +instance (Show a, Ord a) => SOrd a where +#else +class Ord a => SOrd a where +instance Ord a => SOrd a where +#endif diff --git a/src/NLP/Partage/SubtreeSharing.hs b/src/NLP/Partage/SubtreeSharing.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/SubtreeSharing.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE RecordWildCards #-} + + +-- | TAG conversion into flat production rules. +-- Due to subtree sharing provided by `flattenWithSharing`, a single +-- rule can be responsible for recognizing a subtree common to many +-- different elementary trees. +-- + + +module NLP.Partage.SubtreeSharing +( +-- * Grammar flattening + flattenWithSharing +) where + + +import Control.Applicative ((<$>)) +import Control.Arrow (second) +import Control.Monad (guard, forever) +import qualified Control.Monad.State.Strict as E +import Control.Monad.Trans.Class (lift) +import Control.Monad.Identity (Identity(..)) +import Control.Monad.Morph (generalize) + +import Data.Function (on) +import Data.Monoid (mappend, mconcat) +import Data.Maybe (isJust) +import qualified Data.Set as S +import qualified Data.Partition as Part +import qualified Pipes as P +import Pipes (hoist, (>->)) + +import NLP.Partage.FactGram.Internal + ( FactGram, Lab(..), Rule(..), SymID ) +import qualified NLP.Partage.FactGram.Internal as Rule +import qualified NLP.Partage.Tree as G + + +-------------------------------------------------- +-- Compilation +-------------------------------------------------- + + +-- | Compile the given grammar into the list of rules. +-- Common subtrees are shared. +flattenWithSharing + :: (Functor m, Monad m, Ord n, Ord t) + => [ Either + (G.Tree n t) + (G.AuxTree n t) ] + -> m (FactGram n t) +flattenWithSharing ts = + fmap snd $ runDupT $ Rule.runRM $ P.runEffect $ + P.for shared (const $ return ()) + where + shared = hoist (hoist (hoist generalize)) + ( hoist (hoist lift) rules + >-> hoist lift rmDups ) + rules = mapM_ getRules ts + getRules (Left t) = Rule.treeRules t + getRules (Right t) = Rule.auxRules t + + +-------------------------------------------------- +-- Eq/Ord Instances for RuleP +-------------------------------------------------- + + +-- | We define a newtype in order to define a custom Eq/Ord instances +-- take the symbol of the head into account in a different manner. +newtype RuleP n t = RuleP + { unRuleP :: Rule n t + } deriving (Show) + + +-- | Ordinary label equality. +labEq + :: (Eq n, Eq t) + => Lab n t -> Lab n t -> Bool +labEq p q = p == q + + +-- | Label equality. Concerning the `SymID` values, it is only +-- checkes if either both are `Nothing` or both are `Just`. +labEq' :: (Eq n, Eq t) => Lab n t -> Lab n t -> Bool +labEq' p q = + eq p q + where + eq x@NonT{} y@NonT{} + = eqOn nonTerm x y + && eqOn (isJust . labID) x y + eq x@AuxVert{} y@AuxVert{} + = eqOn nonTerm x y + eq _ _ = p == q + eqOn f x y = f x == f y + + +-- | Ordinary label comparison. +labCmp :: (Ord n, Ord t) => Lab n t -> Lab n t -> Ordering +labCmp p q = compare p q + + +-- | Label comparison. Concerning the `SymID` values, it is only +-- checked if either both are `Nothing` or both are `Just`. +labCmp' :: (Ord n, Ord t) => Lab n t -> Lab n t -> Ordering +labCmp' p q = + cmp p q + where + cmp x@NonT{} y@NonT{} = + cmpOn nonTerm x y `mappend` + cmpOn (isJust . labID) x y + cmp x@AuxVert{} y@AuxVert{} = + cmpOn nonTerm x y + cmp _ _ = compare p q + cmpOn f x y = compare (f x) (f y) + + +instance (Eq n, Eq t) => Eq (RuleP n t) where + r == s = (hdEq `on` headP) r s + && ((==) `on` length.bodyP) r s + && and [eq x y | (x, y) <- zip (bodyP r) (bodyP s)] + where + eq x y = labEq x y + hdEq x y = labEq' x y + headP = headR . unRuleP + bodyP = bodyR . unRuleP + + +instance (Ord n, Ord t) => Ord (RuleP n t) where + r `compare` s = (hdCmp `on` headP) r s `mappend` + (compare `on` length.bodyP) r s `mappend` + mconcat [cmp x y | (x, y) <- zip (bodyP r) (bodyP s)] + where + cmp x y = labCmp x y + hdCmp x y = labCmp' x y + headP = headR . unRuleP + bodyP = bodyR . unRuleP + + +-------------------------------------------------- +-- Substructure Sharing +-------------------------------------------------- + + +-- | Duplication-removal state serves to share common +-- substructures. +-- +-- The idea is to remove redundant rules equivalent to other +-- rules already present in the set of processed rules +-- `rulDepo`(sit). +-- +-- Note that rules have to be processed in an appropriate order +-- so that lower-level rules are processed before the +-- higher-level rules from which they are referenced. +data DupS n t = DupS { + -- | A disjoint set for `SymID`s + symDisj :: Part.Partition SymID + -- | Rules already saved + , rulDepo :: S.Set (RuleP n t) + } + + +-- Let us take a rule and let us assume that all identifiers it +-- contains references to rules which have already been processed +-- (for this assumption to be valid we just need to order the +-- input set of rules properly). So we have a rule `r`, a set of +-- processed rules `rs` and a clustering (disjoint-set) over +-- `SymID`s present in `rs`. +-- +-- Now we want to process `r` and, in particular, check if it is +-- not already in `rs` and update its `SymID`s. +-- +-- First we translate the body w.r.t. the existing clustering of +-- `SymID`s (thanks to our assumption, these `SymID`s are already +-- known and processed). The `SymID` in the root of the rule (if +-- present) is the new one and it should not yet have been mentioned +-- in `rs`. Even when `SymID` is not present in the root, we can +-- still try to check if `r` is not present in `rs` -- after all, +-- there may be some duplicates in the input grammar. +-- +-- Case 1: we have a rule with a `SymID` in the root. We want to +-- check if there is already a rule in `rs` which: +-- * Has identical body (remember that we have already +-- transformed `SymID`s of the body of the rule in question) +-- * Has the same non-terminal in the root and some `SymID` +-- +-- Case 2: the same as case 1 with the difference that we look +-- for the rules which have an empty `SymID` in the root. +-- +-- For this to work we just need a specific comparison function +-- which works as specified in the two cases desribed above +-- (i.e. either there are some `SymID`s in the rule heads, or +-- there are no `SymID`s in both heads.) +-- +-- Once we have this comparison (which is provided by the +-- function `labCmp'` above), we simply process the set of rules +-- incrementally. + + +-- | Duplication-removal transformer. +type DupT n t m = E.StateT (DupS n t) m + + +-- | Duplication-removal monad. +type DupM n t = DupT n t Identity + + +-- | Run the transformer. +runDupT + :: (Functor m, Monad m, Ord t, Ord n) + => DupT n t m b + -> m (b, S.Set (Rule n t)) +runDupT = fmap (second getRules) . flip E.runStateT + (DupS Part.empty S.empty) + where + getRules + = S.fromList . map unRuleP + . S.toList. rulDepo + + +-- | Update the body of the rule by replacing old `SymID`s with +-- their representatives. +updateBody + :: RuleP n t + -> DupM n t (RuleP n t) +updateBody (RuleP r) = do + d <- E.gets symDisj + let body' = map (updLab d) (bodyR r) + return . RuleP $ r { bodyR = body' } + where + updLab d x@NonT{..} = x { labID = updSym d <$> labID } + updLab d x@AuxVert{..} = x { symID = updSym d symID } + updLab _ x = x + updSym = Part.rep + + +-- | Find a rule if already present. +findRule + :: (Ord n, Ord t) + => RuleP n t + -> DupM n t (Maybe (RuleP n t)) +findRule x = do + s <- E.gets rulDepo + return $ lookupSet x s + + +-- | Join two `SymID`s. +joinSym :: SymID -> SymID -> DupM n t () +joinSym x y = E.modify $ \s@DupS{..} -> s + { symDisj = Part.joinElems x y symDisj } + + + +-- | Save the rule in the underlying deposit. +keepRule + :: (Ord n, Ord t) + => RuleP n t + -> DupM n t () +keepRule r = E.modify $ \s@DupS{..} -> s + { rulDepo = S.insert r rulDepo } + + +-- | Retrieve the symbol of the head of the rule. +headSym :: RuleP n t -> Maybe SymID +headSym r = case headR (unRuleP r) of + NonT{..} -> labID + AuxVert{..} -> Just symID + _ -> Nothing + + +-- | Removing duplicates updating `SymID`s at the same time. +-- WARNING: The pipe assumes that `SymID`s to which the present +-- rule refers have already been processed -- in other words, +-- that rule on which the present rule depends have been +-- processed earlier. +-- +-- This function is responsible for basic sharing of common +-- subtrees. +rmDups + :: (Ord n, Ord t) + => P.Pipe + (Rule n t) -- Input + (Rule n t) -- Output + (DupM n t) -- Underlying state + () -- No result +rmDups = forever $ do + r <- P.await >>= lift . updateBody . RuleP + lift (findRule r) >>= \mr -> case mr of + Nothing -> do + lift $ keepRule r + P.yield $ unRuleP r + Just r' -> case (headSym r, headSym r') of + (Just x, Just y) -> lift $ joinSym x y + _ -> return () + + +-------------------------------------------------- +-- Utilities +-------------------------------------------------- + + +-- | Lookup an element in a set. +lookupSet :: Ord a => a -> S.Set a -> Maybe a +lookupSet x s = do + y <- S.lookupLE x s + guard $ x == y + return y diff --git a/src/NLP/Partage/Tree.hs b/src/NLP/Partage/Tree.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Tree.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE RecordWildCards #-} + + +-- | This module provides datatypes representing TAG trees. +-- `Tree` is an initial tree, while `AuxTree` represents an auxiliary +-- tree. + + +module NLP.Partage.Tree +( +-- * Initial tree + Tree (..) +-- , showTree +-- , showTree' +, project + +-- * Auxiliary tree +, AuxTree (..) +-- ** Path +, Path +, follow + +-- -- * Combining operations +-- -- ** Substitution +-- , subst +-- -- ** Adjoining +-- , adjoin + +-- -- * Derivation +-- , Deriv +-- , Trans +-- , derive +-- -- * Traversal +-- , walk +) where + + +-- import Control.Applicative ((<$>)) +-- import Control.Arrow (first) +import Control.Monad (foldM) + + +-- | A tree with values of type @a@ (/non-termianls/) kept in +-- branching nodes, and values of type @b@ (/terminals/) kept in leaf +-- nodes +data Tree a b + -- | Branching node with a non-terminal symbol + = Branch + { labelI :: a + -- ^ The non-terminal kept in the branching node + , subTrees :: [Tree a b] + -- ^ The list of subtrees + } + -- | Leaf node with a terminal symbol + | Leaf + { labelF :: b + -- ^ The terminal symbol + } + deriving (Show, Eq, Ord) + + +-- | List of frontier values. +toWord :: Tree a b -> [b] +toWord t = case t of + Branch{..} -> concatMap toWord subTrees + Leaf{..} -> [labelF] + + +-- | Projection of a tree: the list of terminal symbols in its +-- leaves +project :: Tree a b -> [b] +project = toWord + + +-- -- | Replace the tree on the given position. +-- replaceChild :: Tree a b -> Int -> Tree a b -> Tree a b +-- replaceChild t@INode{..} k t' = t { subTrees = replace subTrees k t' } +-- replaceChild _ _ _ = error "replaceChild: frontier node" + + +-- -- | Show a tree given the showing functions for label values. +-- showTree :: (a -> String) -> (b -> String) -> Tree a b -> String +-- showTree f g = unlines . go +-- where +-- go t = case t of +-- INode{..} -> ("INode " ++ f labelI) +-- : map (" " ++) (concatMap go subTrees) +-- FNode{..} -> ["FNode " ++ g labelF] +-- +-- +-- -- | Like `showTree`, but using the default `Show` instances +-- -- to present label values. +-- showTree' :: (Show a, Show b) => Tree a b -> String +-- showTree' = showTree show show + + +--------------------------------------------------------------------- +-- Path +--------------------------------------------------------------------- + + +-- | A path indicates a particular node in a tree and can be used to +-- extract a particular subtree of the tree (see `follow`). +-- For instance, @[]@ designates the entire tree, @[0]@ the first +-- child, and @[1,3]@ the fourth child of the second child of the +-- underlying tree. +type Path = [Int] + + +-- | Follow the path to a particular subtree. +follow :: Path -> Tree a b -> Maybe (Tree a b) +follow = flip $ foldM step + + +-- | Follow one step of the `Path`. +step :: Tree a b -> Int -> Maybe (Tree a b) +step (Leaf _) _ = Nothing +step (Branch _ xs) k = xs !? k + + +--------------------------------------------------------------------- +-- Substitution +--------------------------------------------------------------------- + + +-- -- | Perform substitution on a tree. It is neither whether +-- -- the path indicates a leaf, nor if its symbol is identical to the +-- -- symbol of the root of the substituted tree. +-- subst +-- :: Path -- ^ Place of the substitution +-- -> Tree a b -- ^ Tree to be substituted +-- -> Tree a b -- ^ Original tree +-- -> Maybe (Tree a b) -- ^ Resulting tree (or `Nothing` +-- -- if substitution not possible) +-- subst (k:ks) st t = do +-- replaceChild t k <$> (step t k >>= subst ks st) +-- subst [] st _ = Just st + + +--------------------------------------------------------------------- +-- Adjoining +--------------------------------------------------------------------- + + +-- | An auxiliary tree +data AuxTree a b = AuxTree + { auxTree :: Tree a b + -- ^ The underlying initial tree + , auxFoot :: Path + -- ^ The path to the foot node. Beware that currently it is + -- possible to use the `AuxTree` constructor to build an invalid + -- auxiliary tree, i.e. with an incorrect `auxFoot` value. + } deriving (Show, Eq, Ord) + + +-- -- | Perform adjoining operation on a tree. +-- adjoin +-- :: Path -- ^ Where to adjoin +-- -> AuxTree a b -- ^ Tree to be adjoined +-- -> Tree a b -- ^ Tree with the node to be modified +-- -> Maybe (Tree a b) -- ^ Resulting tree +-- adjoin (k:ks) aux t = do +-- replaceChild t k <$> (step t k >>= adjoin ks aux) +-- adjoin [] AuxTree{..} t = do +-- subst auxFoot t auxTree + + +-- --------------------------------------------------------------------- +-- -- Derivation +-- --------------------------------------------------------------------- +-- +-- +-- -- | A derived tree is constructed by applying a sequence of +-- -- transforming (substitution or adjoining) rules on particular +-- -- positions of a tree. The `Deriv` sequence represents a +-- -- derivation process. One could also construct a derivation +-- -- tree, which to some extent abstracts over the particular order +-- -- of derivations (when it doesn't matter). +-- type Deriv a b = [(Path, Trans a b)] +-- +-- +-- -- | Transformation of a tree. +-- type Trans a b = Either (Tree a b) (AuxTree a b) +-- +-- +-- -- | Derive a tree. +-- derive :: Deriv a b -> Tree a b -> Maybe (Tree a b) +-- derive = +-- flip $ foldM m +-- where +-- m t (pos, op) = case op of +-- Left x -> subst pos x t +-- Right x -> adjoin pos x t + + +--------------------------------------------------------------------- +-- Traversal +--------------------------------------------------------------------- + + +-- -- | Return all tree paths with corresponding subtrees. +-- walk :: Tree a b -> [(Path, Tree a b)] +-- walk = +-- map (first reverse) . go [] +-- where +-- go acc n@INode{..} = (acc, n) : concat +-- [ go (k:acc) t +-- | (k, t) <- zip [0..] subTrees ] +-- go acc n@FNode{..} = [(acc, n)] + + +--------------------------------------------------------------------- +-- Misc +--------------------------------------------------------------------- + + +-- | Maybe a k-th element of a list. +(!?) :: [a] -> Int -> Maybe a +(x:xs) !? k + | k > 0 = xs !? (k-1) + | otherwise = Just x +[] !? _ = Nothing + + +-- -- | Replace the k-th element of a list. If the given position is +-- -- outside of the list domain, the returned list will be unchanged. +-- -- It the given index is negative, the first element will be +-- -- replaced. +-- replace :: [a] -> Int -> a -> [a] +-- replace (x:xs) k y +-- | k > 0 = x : replace xs (k - 1) y +-- | otherwise = y : xs +-- replace [] _ _ = [] diff --git a/src/NLP/Partage/Tree/Other.hs b/src/NLP/Partage/Tree/Other.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Partage/Tree/Other.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE RecordWildCards #-} + + +-- | Alternative (to "NLP.Partage.Tree") representation of TAG +-- trees, in which information about the foot is present in the tree +-- itself. + + +module NLP.Partage.Tree.Other +( +-- * TAG Tree + Tree +, Node (..) +-- ** Base representation +, SomeTree + +-- * Conversion +, encode +, decode + +-- * Utils +, isTerm +, isFinal +, isInitial +, isAuxiliary +, hasRoot +, project +) where + + +-- import Control.Applicative ((<$>)) +import Control.Monad (msum) +-- import Data.Maybe (isJust) +import qualified Data.Foldable as F + +import qualified Data.Tree as R + +import qualified NLP.Partage.Tree as T + + +--------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------- + + +-- | Node of a TAG tree. +data Node n t + = NonTerm n -- ^ Standard non-terminal + | Foot n -- ^ Foot non-terminal + | Term t -- ^ Terminal + deriving (Show, Eq, Ord) + + +-- | Is it a teminal? +isTerm :: Node n t -> Bool +isTerm (Term _) = True +isTerm _ = False + + +-- | An initial or auxiliary TAG tree. Note that the type doesn't +-- ensure that the foot is placed in a leaf, nor that there is at +-- most one foot node. On the other hand, and in contrast to +-- "NLP.Partage.Tree", information about the foot is available at +-- the level of the corresponding foot node. +type Tree n t = R.Tree (Node n t) + + +-- | An original tree representation (see "NLP.Partage.Tree"). +type SomeTree n t = Either (T.Tree n t) (T.AuxTree n t) + + +--------------------------------------------------------------------- +-- Encoding +--------------------------------------------------------------------- + + +-- | Encode the tree using the alternative representation. +encode :: SomeTree n t -> Tree n t +encode (Left t) = unTree t +encode (Right T.AuxTree{..}) = markFoot auxFoot (unTree auxTree) + + +-- | Encode the initial tree using the alternative representation. +unTree :: T.Tree n t -> Tree n t +unTree (T.Branch x xs) = R.Node (NonTerm x) (map unTree xs) +unTree (T.Leaf x) = R.Node (Term x) [] + + +-- | Mark non-terminal under the path as a foot. +markFoot :: T.Path -> Tree n t -> Tree n t +markFoot [] (R.Node (NonTerm x) []) = R.Node (Foot x) [] +markFoot (i:is) (R.Node y ys) = + R.Node y $ doit i ys + where + doit 0 (x:xs) = markFoot is x : xs + doit k (x:xs) = x : doit (k-1) xs + doit _ _ = error "markFoot.doit: unhandled case" +markFoot _ _ = error "markFoot: unhandled case" + + +--------------------------------------------------------------------- +-- Decoding +--------------------------------------------------------------------- + + +-- | Decode the tree represented with the alternative representation. +decode :: Tree n t -> SomeTree n t +decode t = case findFoot t of + Just is -> Right $ T.AuxTree (mkTree t) is + Nothing -> Left $ mkTree t + + +-- | Convert the parsed tree into an LTAG tree. +mkTree :: Tree n t -> T.Tree n t +mkTree (R.Node n xs) = case n of + Term x -> T.Leaf x + Foot x -> T.Branch + { T.labelI = x + , T.subTrees = [] } + NonTerm x -> T.Branch + { T.labelI = x + , T.subTrees = map mkTree xs } + + +-- | Find the path of the foot (if present) in the tree. +findFoot :: Tree n t -> Maybe T.Path +findFoot (R.Node n xs) = case n of + Foot _ -> Just [] + _ -> msum + $ zipWith addID [0..] + $ map findFoot xs + where + addID i (Just is) = Just (i:is) + addID _ Nothing = Nothing + + +--------------------------------------------------------------------- +-- Utils +--------------------------------------------------------------------- + + +-- | Is it an initial (i.e. non-auxiliary) tree? +isInitial :: Tree n t -> Bool +isInitial = not . isAuxiliary + + +-- | Is it an auxiliary (i.e. with a foot) tree? +isAuxiliary :: Tree n t -> Bool +isAuxiliary (R.Node (Foot _) _) = True +isAuxiliary (R.Node _ xs) = any isAuxiliary xs + + +-- | Is it a final tree (i.e. does it contain only terminals +-- in its leaves)? +isFinal :: Tree n t -> Bool +isFinal (R.Node n []) = isTerm n +isFinal (R.Node _ xs) = all isFinal xs + + +-- | Projection of a tree, i.e. a list of its terminals. +project :: Tree n t -> [t] +project = + F.foldMap term + where + term (Term x) = [x] + term _ = [] + + +-- | Is it a root label of the given tree? +hasRoot :: Eq n => n -> Tree n t -> Bool +hasRoot x (R.Node (NonTerm y) _) = x == y +hasRoot _ _ = False diff --git a/tests/Parser.hs b/tests/Parser.hs new file mode 100644 --- /dev/null +++ b/tests/Parser.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +-- | Testing the automata-based Earley-style TAG parser. + + +module Parser where + + +import Control.Applicative ((<$>)) +import Control.Monad (forM_) +import Test.Tasty (TestTree) +import qualified Data.Set as S + +import qualified NLP.Partage.Earley as E + +import qualified TestSet as T + + +-- | All the tests of the parsing algorithm. +tests :: TestTree +tests = T.testTree "Parser" + recFrom (Just parseFrom) + where + recFrom gram start + = E.recognizeFrom gram start + . map S.singleton + parseFrom gram start + = E.parse gram start + . map S.singleton diff --git a/tests/TestSet.hs b/tests/TestSet.hs new file mode 100644 --- /dev/null +++ b/tests/TestSet.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + + +-- | The module collects the sample grammars used for testing and +-- unit test examples themselves. + + +module TestSet +( Test (..) +, TestRes (..) +, mkGram1 +, gram1Tests +, mkGram2 +, gram2Tests +, mkGram3 +, gram3Tests + +, Gram +, testTree +) where + + +import Control.Applicative ((<$>), (<*>)) + +import qualified Data.Set as S +import qualified Data.Map.Strict as M + +import Test.Tasty (TestTree, testGroup, withResource) +import Test.HUnit (Assertion, (@?=)) +import Test.Tasty.HUnit (testCase) + +import NLP.Partage.Tree (Tree (..), AuxTree (..)) +import NLP.Partage.FactGram (Rule, flattenWithSharing) + + +--------------------------------------------------------------------- +-- Prerequisites +--------------------------------------------------------------------- + + +type Tr = Tree String String +type AuxTr = AuxTree String String +type Rl = Rule String String +-- type WRl = W.Rule String String + + +-- | A compiled grammar. +type Gram = S.Set Rl + +-- -- | A compiled grammar with weights. +-- type WeightedTree = (Tr, Cost) +-- type WeightedAux = (AuxTr, Cost) +-- type WeightedGram = S.Set WRl + + +--------------------------------------------------------------------- +-- Tests +--------------------------------------------------------------------- + + +-- | A single test case. +data Test = Test { + -- | Starting symbol + startSym :: String + -- | The sentence to parse (list of words) + , testSent :: [String] + -- | The expected recognition result + , testRes :: TestRes + } deriving (Show, Eq, Ord) + + +-- | The expected test result. The set of parsed trees can be optionally +-- specified. +data TestRes + = No + -- ^ No parse + | Yes + -- ^ Parse + | Trees (S.Set Tr) +-- -- ^ Parsing results +-- | WeightedTrees (M.Map Tr Cost) +-- -- ^ Parsing results with weights + deriving (Show, Eq, Ord) + + +--------------------------------------------------------------------- +-- Grammar1 +--------------------------------------------------------------------- + + +tom :: Tr +tom = Branch "NP" + [ Branch "N" + [Leaf "Tom"] + ] + + +sleeps :: Tr +sleeps = Branch "S" + [ Branch "NP" [] + , Branch "VP" + [Branch "V" [Leaf "sleeps"]] + ] + + +caught :: Tr +caught = Branch "S" + [ Branch "NP" [] + , Branch "VP" + [ Branch "V" [Leaf "caught"] + , Branch "NP" [] ] + ] + + +almost :: AuxTr +almost = AuxTree (Branch "V" + [ Branch "Ad" [Leaf "almost"] + , Branch "V" [] + ]) [1] + + +quickly :: AuxTr +quickly = AuxTree (Branch "V" + [ Branch "Ad" [Leaf "quickly"] + , Branch "V" [] + ]) [1] + + +a :: Tr +a = Branch "D" [Leaf "a"] + + +mouse :: Tr +mouse = Branch "NP" + [ Branch "D" [] + , Branch "N" + [Leaf "mouse"] + ] + + +-- | Compile the first grammar. +mkGram1 :: IO Gram +mkGram1 = flattenWithSharing $ + map Left [tom, sleeps, caught, a, mouse] ++ + map Right [almost, quickly] + + +--------------------------------------------------------------------- +-- Grammar1 Tests +--------------------------------------------------------------------- + + +gram1Tests :: [Test] +gram1Tests = + -- group 1 + [ Test "S" ["Tom", "sleeps"] . Trees . S.singleton $ + Branch "S" + [ Branch "NP" + [ Branch "N" + [Leaf "Tom"] + ] + , Branch "VP" + [Branch "V" [Leaf "sleeps"]] + ] + , Test "S" ["Tom"] No + , Test "NP" ["Tom"] Yes + -- group 2 + , Test "S" ["Tom", "almost", "caught", "a", "mouse"] . Trees . S.singleton $ + Branch "S" + [ Branch "NP" + [ Branch "N" + [ Leaf "Tom" ] ] + , Branch "VP" + [ Branch "V" + [ Branch "Ad" + [Leaf "almost"] + , Branch "V" + [Leaf "caught"] + ] + , Branch "NP" + [ Branch "D" + [Leaf "a"] + , Branch "N" + [Leaf "mouse"] + ] + ] + ] + , Test "S" ["Tom", "caught", "almost", "a", "mouse"] No + , Test "S" ["Tom", "quickly", "almost", "caught", "Tom"] Yes + , Test "S" ["Tom", "caught", "a", "mouse"] Yes + , Test "S" ["Tom", "caught", "Tom"] Yes + , Test "S" ["Tom", "caught", "a", "Tom"] No + , Test "S" ["Tom", "caught"] No + , Test "S" ["caught", "a", "mouse"] No ] + + +--------------------------------------------------------------------- +-- Grammar2 +--------------------------------------------------------------------- + + +alpha :: Tr +alpha = Branch "S" + [ Branch "X" + [Leaf "e"] ] + + +beta1 :: AuxTr +beta1 = AuxTree (Branch "X" + [ Leaf "a" + , Branch "X" + [ Branch "X" [] + , Leaf "a" ] ] + ) [1,0] + + +beta2 :: AuxTr +beta2 = AuxTree (Branch "X" + [ Leaf "b" + , Branch "X" + [ Branch "X" [] + , Leaf "b" ] ] + ) [1,0] + + +mkGram2 :: IO Gram +mkGram2 = flattenWithSharing $ + map Left [alpha] ++ + map Right [beta1, beta2] + + +--------------------------------------------------------------------- +-- Grammar2 Tests +--------------------------------------------------------------------- + + +-- | What we test is not really a copy language but rather a +-- language in which there is always the same number of `a`s and +-- `b`s on the left and on the right of the empty `e` symbol. +-- To model the real copy language with a TAG we would need to +-- use either adjunction constraints or feature structures. +gram2Tests :: [Test] +gram2Tests = + [ Test "S" (words "a b e a b") Yes + , Test "S" (words "a b e a a") No + , Test "S" (words "a b a b a b a b e a b a b a b a b") Yes + , Test "S" (words "a b a b a b a b e a b a b a b a ") No + , Test "S" (words "a b e b a") Yes + , Test "S" (words "b e a") No + , Test "S" (words "a b a b") No ] + + +--------------------------------------------------------------------- +-- Grammar 3 +--------------------------------------------------------------------- + + +mkGram3 :: IO Gram +mkGram3 = flattenWithSharing $ + map Left [sent] ++ + map Right [xtree] + where + sent = Branch "S" + [ Leaf "p" + , Branch "X" + [Leaf "e"] + , Leaf "b" ] + xtree = AuxTree (Branch "X" + [ Leaf "a" + , Branch "X" [] + , Leaf "b" ] + ) [1] + + +-- | Here we check that the auxiliary tree must be fully +-- recognized before it can be adjoined. +gram3Tests :: [Test] +gram3Tests = + [ Test "S" (words "p a e b b") Yes + , Test "S" (words "p a e b") No ] + + +--------------------------------------------------------------------- +-- Resources +--------------------------------------------------------------------- + + +-- | Compiled grammars. +data Res = Res + { gram1 :: Gram + , gram2 :: Gram + , gram3 :: Gram } + + +-- | Construct the shared resource (i.e. the grammars) used in +-- tests. +mkGrams :: IO Res +mkGrams = Res <$> mkGram1 <*> mkGram2 <*> mkGram3 + + +--------------------------------------------------------------------- +-- Test Tree +--------------------------------------------------------------------- + + +-- | All the tests of the parsing algorithm. +testTree + :: String + -- ^ Name of the tested module + -> (Gram -> String -> [String] -> IO Bool) + -- ^ Recognition function + -> Maybe (Gram -> String -> [String] -> IO (S.Set Tr)) + -- ^ Parsing function (optional) + -> TestTree +testTree modName reco parse = withResource mkGrams (const $ return ()) $ + \resIO -> testGroup modName $ + map (testIt resIO gram1) gram1Tests ++ + map (testIt resIO gram2) gram2Tests ++ + map (testIt resIO gram3) gram3Tests + where + testIt resIO getGram test = testCase (show test) $ do + gram <- getGram <$> resIO + doTest gram test + + doTest gram test@Test{..} = case (parse, testRes) of + (Nothing, _) -> + reco gram startSym testSent @@?= simplify testRes + (Just pa, Trees ts) -> + pa gram startSym testSent @@?= ts + _ -> + reco gram startSym testSent @@?= simplify testRes + + simplify No = False + simplify Yes = True + simplify (Trees _) = True +-- simplify (WeightedTrees _) +-- = True + +--------------------------------------------------------------------- +-- Utils +--------------------------------------------------------------------- + + +(@@?=) :: (Show a, Eq a) => IO a -> a -> Assertion +mx @@?= y = do + x <- mx + x @?= y diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,10 @@ +import Test.Tasty (defaultMain, testGroup, localOption) + +import TestSet +import qualified Parser + + +main :: IO () +main = defaultMain $ testGroup "Tests" + [ Parser.tests + ]