246 lines
7.6 KiB
Haskell
246 lines
7.6 KiB
Haskell
|
{-# LANGUAGE MonadComprehensions #-}
|
|||
|
{-# LANGUAGE FlexibleContexts #-}
|
|||
|
|
|||
|
module ParserW (
|
|||
|
module Parse,
|
|||
|
WeightedList,
|
|||
|
step,
|
|||
|
parse,
|
|||
|
parseA,
|
|||
|
parse',
|
|||
|
parseA',
|
|||
|
-- parseSel,
|
|||
|
-- selectSize,
|
|||
|
shift,
|
|||
|
shift',
|
|||
|
-- shifts,
|
|||
|
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
|
|||
|
|
|||
|
|
|||
|
shift :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ κ -> m (Parse τ κ)
|
|||
|
shift d w p = [ p << Step (nextId p) c [] [] | c <- dic d w ]
|
|||
|
where
|
|||
|
nextId [] = 1
|
|||
|
nextId (Step i _ _ _:_) = i + 1
|
|||
|
|
|||
|
|
|||
|
shift' :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ (m κ) -> m (Parse τ (m κ))
|
|||
|
shift' d w p = return $ p << Step (nextId p) (dic d w) [] []
|
|||
|
where
|
|||
|
nextId [] = 1
|
|||
|
nextId (Step i _ _ _:_) = i + 1
|
|||
|
|
|||
|
|
|||
|
|
|||
|
-- shift :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ κ -> StateT Int m (Parse τ κ)
|
|||
|
-- shift d w p = do nextId <- get
|
|||
|
-- c <- lift (dic d w)
|
|||
|
-- let ret = p << Step nextId c [] []
|
|||
|
-- modify (+ 1)
|
|||
|
-- return ret
|
|||
|
|
|||
|
-- 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, Grammar m τ κ γ) => γ -> Parse τ κ -> m (Parse τ κ)
|
|||
|
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' ]
|
|||
|
|
|||
|
addHead', addDep' :: (MonadPlus m, Grammar' m τ κ γ) => γ -> Parse τ (m κ) -> m (Parse τ (m κ))
|
|||
|
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' ]
|
|||
|
|
|||
|
|
|||
|
connect :: (MonadPlus m, Grammar m τ κ γ) => γ -> Parse τ κ -> m (Parse τ κ)
|
|||
|
connect g = (addDep g >=> connect g) <> addHead g <> return
|
|||
|
|
|||
|
connect' :: (MonadPlus m, Grammar' m τ κ γ) => γ -> Parse τ (m κ) -> m (Parse τ (m κ))
|
|||
|
connect' g = (addDep' g >=> connect' g) <> addHead' g <> return
|
|||
|
|
|||
|
|
|||
|
step :: (MonadPlus m, Lexicon m κ δ, Grammar m τ κ γ) => δ -> γ -> Wordform -> Parse τ κ -> m (Parse τ κ)
|
|||
|
step d g w = shift d w >=> connect g |? (<= 4) . trees
|
|||
|
|
|||
|
step' :: (MonadPlus m, Lexicon m κ δ, Grammar' m τ κ γ) => δ -> γ -> Wordform -> Parse τ (m κ) -> m (Parse τ (m κ))
|
|||
|
step' d g w = shift' d w >=> connect' g |? (<= 4) . trees
|
|||
|
|
|||
|
steps :: (MonadPlus m, Lexicon m κ δ, Grammar m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ κ)
|
|||
|
steps d g = foldM (flip (step d g)) mzero
|
|||
|
|
|||
|
steps' :: (MonadPlus m, Lexicon m κ δ, Grammar' m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ (m κ))
|
|||
|
steps' d g = foldM (flip (step' d g)) mzero
|
|||
|
|
|||
|
parser :: (MonadPlus m, Lexicon m κ δ, Grammar m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ κ)
|
|||
|
parser d g = steps d g -- |? (==1) . trees
|
|||
|
|
|||
|
parser' :: (MonadPlus m, Lexicon m κ δ, Grammar' m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ (m κ))
|
|||
|
parser' d g = steps' d g -- |? (==1) . trees
|
|||
|
-- parser = steps |? pass.lastNode
|
|||
|
|
|||
|
-- parse :: (Lexicon WeightedList κ δ, Grammar WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ κ)
|
|||
|
parse d g = (parser d g |? (==1) . trees |? pass g . lastNode) . words
|
|||
|
|
|||
|
parse' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ))
|
|||
|
parse' d g = (parser' d g |? (==1) . trees) . words
|
|||
|
|
|||
|
parseA :: (Lexicon WeightedList κ δ, Grammar WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ κ)
|
|||
|
parseA d g = parser d g . words
|
|||
|
|
|||
|
parseA' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ))
|
|||
|
parseA' d g = parser' d g . words
|
|||
|
|
|||
|
|
|||
|
type WeightedList = WeightedT []
|
|||
|
|
|||
|
-- 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)
|