partage (empty) → 0.1.0.0

raw patch · 20 files changed

+3983/−0 lines, 20 filesdep +HUnitdep +PSQueuedep +basesetup-changed

Dependencies added: HUnit, PSQueue, base, containers, data-lens-light, data-partition, dawg-ord, mmorph, mtl, partage, pipes, random, tasty, tasty-hunit, transformers, vector

Files

• LICENSE +23/−0
• Setup.lhs +4/−0
• partage.cabal +80/−0
• src/NLP/Partage/Auto.hs +90/−0
• src/NLP/Partage/Auto/DAWG.hs +106/−0
• src/NLP/Partage/Auto/List.hs +111/−0
• src/NLP/Partage/Auto/Set.hs +173/−0
• src/NLP/Partage/Auto/Trie.hs +140/−0
• src/NLP/Partage/Earley.hs +41/−0
• src/NLP/Partage/Earley/AutoAP.hs +1275/−0
• src/NLP/Partage/FactGram.hs +22/−0
• src/NLP/Partage/FactGram/Internal.hs +357/−0
• src/NLP/Partage/Gen.hs +437/−0
• src/NLP/Partage/SOrd.hs +21/−0
• src/NLP/Partage/SubtreeSharing.hs +308/−0
• src/NLP/Partage/Tree.hs +233/−0
• src/NLP/Partage/Tree/Other.hs +172/−0
• tests/Parser.hs +31/−0
• tests/TestSet.hs +349/−0
• tests/test.hs +10/−0

@@ -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.

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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`.+-}

@@ -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

@@ -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

@@ -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) ]

@@ -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

@@ -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

@@ -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

@@ -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 [] _ _  = []

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,10 @@+import           Test.Tasty (defaultMain, testGroup, localOption)++import           TestSet+import qualified Parser+++main :: IO ()+main = defaultMain $ testGroup "Tests"+    [ Parser.tests+    ]