fdp2/ParserW.hs

{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE FlexibleContexts #-}

module ParserW (
               module Parse,
               WeightedList,
               step,
               parses,
               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
  
shift :: (WeightedLexicon κ δ) => δ -> String -> Parse τ κ -> WeightedList (Parse τ κ)
shift d w p = [ p << Step (nextId p) c [] [] | c <- dic d w ]
  where
    nextId [] = 1
    nextId (Step i _ _ _:_) = i + 1

addHead, addDep :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (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' ]
                                                
connect :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (Parse τ κ)
connect g = (addDep g >=> connect g) <> addHead g <> return

step :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> Wordform -> Parse τ κ -> WeightedList (Parse τ κ)
step d g w = shift d w >=> connect g |? (<= 4) . trees

steps :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
steps d g = foldM (flip (step d g)) mzero

parses :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
parses d g = steps d g

parse :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
parse d g = parses d g |? (==1) . trees |? pass g . lastNode


-- parseA' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ))
-- parseA' d g = parser' d g . words


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