2017-01-14 16:13:50 +01:00
|
|
|
|
{-# LANGUAGE MonadComprehensions #-}
|
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
|
|
|
|
|
|
module ParserW (
|
|
|
|
|
module Parse,
|
|
|
|
|
WeightedList,
|
|
|
|
|
step,
|
2017-03-16 09:03:46 +01:00
|
|
|
|
parses,
|
2017-01-14 16:13:50 +01:00
|
|
|
|
parse,
|
|
|
|
|
shift,
|
|
|
|
|
connect,
|
|
|
|
|
addHead,
|
|
|
|
|
addDep) where
|
|
|
|
|
|
|
|
|
|
import Lexicon
|
|
|
|
|
import Grammar
|
|
|
|
|
import Parse
|
|
|
|
|
import Node
|
|
|
|
|
|
|
|
|
|
import Data.List
|
|
|
|
|
import Data.Maybe
|
|
|
|
|
import Data.Sequence
|
|
|
|
|
import Data.Foldable
|
|
|
|
|
import Toolbox
|
|
|
|
|
import Control.Monad
|
|
|
|
|
import Control.Monad.Trans.State
|
|
|
|
|
import Control.Monad.Trans.Class
|
|
|
|
|
import Control.Monad.Plus
|
|
|
|
|
import Base
|
|
|
|
|
import Weighted
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
shift :: (WeightedLexicon κ δ) => δ -> String -> Parse τ κ -> WeightedList (Parse τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
shift d w p = [ p << Step (nextId p) c [] [] | c <- dic d w ]
|
|
|
|
|
where
|
|
|
|
|
nextId [] = 1
|
|
|
|
|
nextId (Step i _ _ _:_) = i + 1
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
addHead, addDep :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (Parse τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
addHead g p = [ p +-> Head r (ind v') | let v = lastNode p, headless v, (r,v') <- heads g v ]
|
|
|
|
|
addDep g p = [ p +<- Dep r (ind v') | let v = lastNode p, (r,v') <- deps g v, headless v' ]
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
connect :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (Parse τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
connect g = (addDep g >=> connect g) <> addHead g <> return
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
step :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> Wordform -> Parse τ κ -> WeightedList (Parse τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
step d g w = shift d w >=> connect g |? (<= 4) . trees
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
steps :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
steps d g = foldM (flip (step d g)) mzero
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
parses :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
|
|
|
|
|
parses d g = steps d g
|
2017-01-14 16:13:50 +01:00
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
parse :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
|
|
|
|
|
parse d g = parses d g |? (==1) . trees |? pass g . lastNode
|
2017-01-14 16:13:50 +01:00
|
|
|
|
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
-- parseA' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ))
|
|
|
|
|
-- parseA' d g = parser' d g . words
|
2017-01-14 16:13:50 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- type WeightedList = StateT Int (WeightedT [])
|
|
|
|
|
|
|
|
|
|
-- LEXER I PARSER ODDZIELNIE
|
|
|
|
|
|
|
|
|
|
-- step :: (Ind,String) -> [Step]
|
|
|
|
|
-- step (i,w) = [ Step i c [] [] | c <- dic w ]
|
|
|
|
|
|
|
|
|
|
-- steps :: [(Ind,String)] -> [[Step]]
|
|
|
|
|
-- steps [] = [[]]
|
|
|
|
|
-- _steps ((i,w):t) = [ Step i c [] [] : ss | c <- dic w, ss <- _steps t ]
|
|
|
|
|
|
|
|
|
|
-- _lexer = words >>> zip [1..] >>> _steps
|
|
|
|
|
|
|
|
|
|
-- -- lexer3 s = map (Node []) (stes s)
|
|
|
|
|
|
|
|
|
|
-- -- back = (lng >=> back) <?> pure
|
|
|
|
|
-- _parser = connect >=> (rng >=> _parser) <?> pure
|
|
|
|
|
|
|
|
|
|
-- -- --parser'' ws = shifts ws ep >>= back >>= pa
|
|
|
|
|
|
|
|
|
|
-- _parse = _lexer >=> _parser
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- shift :: (MonadPlus m) => Wordform -> Parse -> m Parse
|
|
|
|
|
-- shift w p = [ p << Step (nextId p) c [] [] | c <- mfromList (dic w) ]
|
|
|
|
|
-- where
|
|
|
|
|
-- nextId [] = 1
|
|
|
|
|
-- nextId (Step i _ _ _:_) = i + 1
|
|
|
|
|
|
|
|
|
|
-- shifts :: (MonadPlus m) => [String] -> Parse -> m Parse
|
|
|
|
|
-- shifts (s:ss) p = shift s p >>= shifts ss
|
|
|
|
|
-- shifts [] p = return p
|
|
|
|
|
|
|
|
|
|
-- addHead, addDep :: (MonadPlus m) => Parse -> m Parse
|
|
|
|
|
-- addHead p = [ p +-> Arc r (ind v') | let v = lastNode p, headless v, (r,v') <- mfromList (heads v) ]
|
|
|
|
|
-- addDep p = [ p +<- Arc r (ind v') | let v = lastNode p, (r,v') <- mfromList (deps v), headless v' ]
|
|
|
|
|
|
|
|
|
|
-- connect :: (MonadPlus m) => Parse -> m Parse
|
|
|
|
|
-- connect = (addDep >=> connect) <> addHead <> return
|
|
|
|
|
|
|
|
|
|
-- step :: (MonadPlus m) => Wordform -> Parse -> m Parse
|
|
|
|
|
-- step w = shift w >=> connect
|
|
|
|
|
|
|
|
|
|
-- steps :: (MonadPlus m) => [Wordform] -> m Parse
|
|
|
|
|
-- steps = foldM (flip step) mzero
|
|
|
|
|
|
|
|
|
|
-- parser :: (MonadPlus m) => [Wordform] -> m Parse
|
|
|
|
|
-- parser = steps |? pass.lastNode |? (==1).trees
|
|
|
|
|
|
|
|
|
|
-- parse :: String-> [Parse]
|
|
|
|
|
-- parse = parser . words
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- stepSel :: (Parse -> [Parse]) -> Wordform -> Parse -> [Parse]
|
|
|
|
|
-- stepSel s w = (shift w >=> connect >=> s)
|
|
|
|
|
|
|
|
|
|
-- stepsSel :: (Parse -> [Parse]) -> [Wordform] -> [Parse]
|
|
|
|
|
-- stepsSel s = foldM (flip (stepSel s)) []
|
|
|
|
|
|
|
|
|
|
-- parserSel :: (Parse -> [Parse]) -> [Wordform] -> [Parse]
|
|
|
|
|
-- parserSel s = stepsSel s >=> selectWith (pass.lastNode) >=> selectSize (==1)
|
|
|
|
|
|
|
|
|
|
-- parseSel :: (Parse -> [Parse]) -> String-> [Parse]
|
|
|
|
|
-- parseSel s = parserSel s . words
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- EXTENSIONS
|
|
|
|
|
|
|
|
|
|
-- type Selector = Parse -> [Parse]
|
|
|
|
|
|
|
|
|
|
-- sAny :: (Parse -> [Parse])
|
|
|
|
|
-- sAny v = pure v
|
|
|
|
|
|
|
|
|
|
-- selectWith :: (Parse -> Bool) -> (Parse -> [Parse])
|
|
|
|
|
-- selectWith f v = if f v then [v] else []
|
|
|
|
|
|
|
|
|
|
-- selectSize :: (Int -> Bool) -> (Parse -> [Parse])
|
|
|
|
|
-- selectSize f = selectWith (f . trees)
|
|
|
|
|
-- sForestSize f p = if f (trees p) then [p] else []
|
|
|
|
|
|
|
|
|
|
-- shift' :: (Ind,Word) -> Parse -> [Parse]
|
|
|
|
|
-- shift' (i,w) p = [ p << (i,c) | c <- dic w]
|
|
|
|
|
|
|
|
|
|
-- addHead', addDep' :: Parse -> [Parse]
|
|
|
|
|
-- addHead' n = [ n +-> (r,ind n') | headless n, (r,n') <- heads' n ]
|
|
|
|
|
-- addDep' n = [ n +<- (r,ind n') | (r,n') <- deps' n, headless n' ]
|
|
|
|
|
|
|
|
|
|
-- connect' :: Parse -> [Parse]
|
|
|
|
|
-- -- connect = ((addDep <> addHead) >=> connect) <> pure
|
|
|
|
|
-- connect' = addDep' <> addHead' <> pure
|
|
|
|
|
|
|
|
|
|
-- step' :: (Parse -> [Parse]) -> (Ind,Word) -> Parse -> [Parse]
|
|
|
|
|
-- step' s w = shift' w >=> connect >=> s
|
|
|
|
|
|
|
|
|
|
-- step'''' w = shift' w >=> connect
|
|
|
|
|
|
|
|
|
|
-- stepS s w = step'''' w >=> s
|
|
|
|
|
|
|
|
|
|
-- parser' s = foldM (flip (stepS s)) ep >=> accept'
|
|
|
|
|
-- parse' s = words >>> zip [1..] >>> parser' s
|
|
|
|
|
|
|
|
|
|
-- parserRL s = foldrM ((step' s)) ep >=> accept'
|
|
|
|
|
-- parseRL s = words >>> zip [1..] >>> parserRL s
|
|
|
|
|
|
|
|
|
|
-- type Filter = [Parse] -> [Parse]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- -- takeWith :: (Parse -> Bool) -> ([Parse] -> [Parse])
|
|
|
|
|
-- -- takeWith f = filter f
|
|
|
|
|
|
|
|
|
|
-- -- takeBestN = mapM (sForestSize)
|