some past changes
This commit is contained in:
parent
e2914d0ae8
commit
ac0169cf20
3
Base.hs
3
Base.hs
@ -1,12 +1,13 @@
|
||||
module Base (
|
||||
Ind,
|
||||
Wordform,
|
||||
Arc (Head,Dep)
|
||||
Arc (Head,Dep,Root)
|
||||
) where
|
||||
|
||||
type Ind = Int
|
||||
type Wordform = String
|
||||
data Arc τ = Head { role :: τ, dst :: Ind }
|
||||
| Dep { role :: τ, dst :: Ind }
|
||||
| Root
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
|
43
FDP.hs
Normal file
43
FDP.hs
Normal file
@ -0,0 +1,43 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Main (
|
||||
module ParserW,
|
||||
module Parse,
|
||||
module Step,
|
||||
module G1,
|
||||
module PoliMorf,
|
||||
module Data.ADTTag.IPITag.PoliMorf,
|
||||
module PL1,
|
||||
main
|
||||
) where
|
||||
|
||||
|
||||
import ParserW
|
||||
import Parse
|
||||
import Step
|
||||
import G1
|
||||
import Data.ADTTag.IPITag.PoliMorf
|
||||
import PoliMorf
|
||||
import PL1
|
||||
import Weighted
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
instance Show (WeightedList IPITag) where
|
||||
show = show . runWeightedT
|
||||
|
||||
main = do
|
||||
input <- words <$> getLine
|
||||
pm <- readPoliMorfForms input "pm.tsv"
|
||||
let WeightedT allparses = parse pm pl1 input :: WeightedList (Parse Role IPITag)
|
||||
parselist = zip [1..] allparses
|
||||
putStrLn $ "### PARSES: " ++ show (length parselist)
|
||||
sequence_ $ map (\(n,Weighted w p) -> do
|
||||
putStrLn $ "### " ++ show n ++ "#" ++ show w
|
||||
-- putStrLn $ show p
|
||||
sequence_ $ map (putStrLn . show) (conll input p)
|
||||
) parselist
|
||||
|
||||
-- putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . unweighted . snd) parselist))
|
||||
|
6
FDP1.hs
6
FDP1.hs
@ -27,10 +27,10 @@ instance Show (WeightedList IPITag) where
|
||||
|
||||
main = do
|
||||
pm <- readPoliMorfHead1 200000 "pm.sorted.uniq.tsv"
|
||||
let l = length (parse' pm pl1' "dom" :: WeightedList (Parse Role (WeightedList IPITag)))
|
||||
let l = length (parse pm pl1 "dom" :: WeightedList (Parse Role IPITag))
|
||||
putStrLn $ "READY (" ++ show l ++ ")"
|
||||
input <- getLine
|
||||
let WeightedT parses = parseA' pm pl1' input :: WeightedList (Parse Role (WeightedList IPITag))
|
||||
let WeightedT parses = parseA pm pl1 input :: WeightedList (Parse Role IPITag)
|
||||
parselist = zip [1..] parses
|
||||
-- sequence_ $ map (\(n,p) -> do
|
||||
-- putStrLn $ "*** [" ++ show n ++ "] ***"
|
||||
@ -38,5 +38,5 @@ main = do
|
||||
-- ) parselist
|
||||
|
||||
putStrLn $ "PARSES: " ++ show (length parselist)
|
||||
putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . bare . snd) parselist))
|
||||
putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . unweighted . snd) parselist))
|
||||
|
||||
|
7
G1.hs
7
G1.hs
@ -2,9 +2,6 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MonadComprehensions #-}
|
||||
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module G1 (
|
||||
module Grammar,
|
||||
G1 (G1),
|
||||
@ -28,9 +25,9 @@ import Weighted
|
||||
import Prelude.Unicode
|
||||
-- import Data.Foldable
|
||||
|
||||
data G1 τ κ = G1 { links :: WeightedT [] (LINK τ κ), gcs :: [Constraint τ κ], obl :: [OBL τ κ] }
|
||||
data G1 τ κ = G1 { links :: WeightedList (LINK τ κ), gcs :: [Constraint τ κ], obl :: [OBL τ κ] }
|
||||
|
||||
instance (Eq τ) => Grammar (WeightedT []) τ κ (G1 τ κ) where
|
||||
instance (Eq τ) => WeightedGrammar τ κ (G1 τ κ) where
|
||||
link g h d = [ (r, gcs g ++ cs) | LINK r p q cs <- links g, p h, q d ]
|
||||
-- sat :: G1 τ κ -> Node τ κ -> Bool
|
||||
-- sat g n = and [ r ∈ (roles n) | OBL p rs <- obl g, p (cat n), r <- rs ]
|
||||
|
37
Grammar.hs
37
Grammar.hs
@ -10,34 +10,51 @@ import Data.List
|
||||
-- import Data.Monoid
|
||||
-- import Control.Monad.Unicode
|
||||
import Node
|
||||
-- import Weighted
|
||||
import Weighted
|
||||
|
||||
type Constraint τ κ = (τ, Node τ κ, Node τ κ) -> Bool
|
||||
|
||||
class (MonadPlus m, Eq τ {- , Eq κ -}) => Grammar m τ κ γ where
|
||||
-- class (MonadPlus m, Eq τ {- , Eq κ -}) => Grammar m τ κ γ where
|
||||
|
||||
heads :: γ -> Node τ κ -> m (τ, Node τ κ)
|
||||
-- heads :: γ -> Node τ κ -> m (τ, Node τ κ)
|
||||
-- heads g n = [ (r,h) | h <- visible g n,
|
||||
-- (r,cs) <- link g (cat h) (cat n),
|
||||
-- all ($ (r,h,n)) cs ]
|
||||
|
||||
-- deps :: γ -> Node τ κ -> m (τ, Node τ κ)
|
||||
-- deps g n = [ (r,d) | d <- visible g n,
|
||||
-- (r,cs) <- link g (cat n) (cat d),
|
||||
-- all ($ (r,n,d)) cs ]
|
||||
|
||||
-- visible :: γ -> Node τ κ -> m (Node τ κ)
|
||||
-- visible _ = mfromList . lv
|
||||
|
||||
-- pass :: γ -> Node τ κ -> Bool
|
||||
-- pass = const . const True
|
||||
|
||||
-- link :: γ -> κ -> κ -> m (τ, [Constraint τ κ])
|
||||
|
||||
class (Eq τ) => WeightedGrammar τ κ γ where
|
||||
|
||||
heads :: γ -> Node τ κ -> WeightedList (τ, Node τ κ)
|
||||
heads g n = [ (r,h) | h <- visible g n,
|
||||
(r,cs) <- link g (cat h) (cat n),
|
||||
all ($ (r,h,n)) cs ]
|
||||
|
||||
deps :: γ -> Node τ κ -> m (τ, Node τ κ)
|
||||
deps :: γ -> Node τ κ -> WeightedList (τ, Node τ κ)
|
||||
deps g n = [ (r,d) | d <- visible g n,
|
||||
(r,cs) <- link g (cat n) (cat d),
|
||||
all ($ (r,n,d)) cs ]
|
||||
|
||||
visible :: γ -> Node τ κ -> m (Node τ κ)
|
||||
visible :: γ -> Node τ κ -> WeightedList (Node τ κ)
|
||||
visible _ = mfromList . lv
|
||||
|
||||
-- sat :: Grammar m τ κ γ => γ -> Node τ κ -> Bool
|
||||
-- sat = const . const True
|
||||
|
||||
pass :: γ -> Node τ κ -> Bool
|
||||
pass = const . const True
|
||||
-- pass g n = sat g n --all (sat g) ((preds<>pure) n)
|
||||
|
||||
link :: γ -> κ -> κ -> m (τ, [Constraint τ κ])
|
||||
link :: γ -> κ -> κ -> WeightedList (τ, [Constraint τ κ])
|
||||
|
||||
-- type WeightedGrammar = Grammar WeightedList
|
||||
|
||||
type Constraint' m τ κ = (τ, Node τ (m κ), Node τ (m κ)) -> Bool
|
||||
|
||||
|
@ -1,10 +1,13 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Lexicon (Lexicon,dic)
|
||||
module Lexicon (WeightedLexicon,dic)
|
||||
where
|
||||
|
||||
import Control.Monad.Plus
|
||||
import Weighted
|
||||
|
||||
-- class (MonadPlus m) => Lexicon m a d where
|
||||
-- dic :: d -> String -> m a
|
||||
|
||||
class (MonadPlus m) => Lexicon m a d where
|
||||
dic :: d -> String -> m a
|
||||
class WeightedLexicon a d where
|
||||
dic :: d -> String -> WeightedList a
|
||||
|
88
PL1.hs
88
PL1.hs
@ -17,9 +17,6 @@ import Control.Monad.Identity
|
||||
data Role = Subj | Cmpl | Mod | Poss | Prep | PCmpl | CCmpl | Coord | Conj | Num | Det
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
|
||||
|
||||
|
||||
ppron = ppron12 ∪ ppron3
|
||||
n = subst ∪ ger
|
||||
|
||||
@ -43,14 +40,14 @@ n'' = subst ∪ ppron12 ∪ ppron3
|
||||
|
||||
|
||||
agrNPG, agrC :: Constraint Role IPITag
|
||||
agrNPG = \(_,h,d) -> agrNumber (cat h) (cat d) ∧ agrPerson (cat h) (cat d) ∧ agrGender (cat h) (cat d)
|
||||
agrNCG = \(_,h,d) -> agrNumber (cat h) (cat d) ∧ agrCase (cat h) (cat d) ∧ agrGender (cat h) (cat d)
|
||||
agrC = \(_,h,d) -> test ( agrCase<$>Identity (cat h)<*>Identity (cat d) )
|
||||
agrNPG (_,x,y) = agrNumber (cat x) (cat y) ∧ agrPerson (cat x) (cat y) ∧ agrGender (cat x) (cat y)
|
||||
agrNCG (_,x,y) = agrNumber (cat x) (cat y) ∧ agrCase (cat x) (cat y) ∧ agrGender (cat x) (cat y)
|
||||
agrC (_,x,y) = agrCase (cat x) (cat y)
|
||||
|
||||
--right, left, sgl :: Constraint Role IPITag
|
||||
right = \(_,h,d) -> h < d
|
||||
left = \(_,h,d) -> d < h
|
||||
sgl = \(r,h,_) -> r ∉ roles h
|
||||
right, left, sgl :: Constraint Role IPITag
|
||||
right (_,h,d) = h < d
|
||||
left (_,h,d) = d < h
|
||||
sgl (r,h,_) = r ∉ roles h
|
||||
|
||||
coord = nominalCoord \/ verbalCoord \/ adjectivalCoord
|
||||
|
||||
@ -60,7 +57,7 @@ verbalCoord (_,h,d) = verbal (cat d) ∧ or [ verbal (cat h₂) ∧ agrNumb
|
||||
|
||||
adjectivalCoord (_,h,d) = adjectival (cat d)
|
||||
∧ or [ adjectival (cat h₂)
|
||||
-- && agrNPG (undefined,h₂,d)
|
||||
-- && agrNPG (h₂,d)
|
||||
∧ agrNumber (cat d) (cat h₂)
|
||||
∧ agrCase (cat d) (cat h₂)
|
||||
∧ agrGender (cat d) (cat h₂)
|
||||
@ -73,9 +70,9 @@ adjectivalCoord (_,h,d) = adjectival (cat d)
|
||||
|
||||
|
||||
|
||||
coord' = nominalCoord' -- \/ verbalCoord' \/ adjectivalCoord'
|
||||
-- coord' = nominalCoord' -- \/ verbalCoord' \/ adjectivalCoord'
|
||||
|
||||
nominalCoord' (_,h,d) = (alt nominal) (cat d) ∧ or [ (alt nominal) (cat h₂) ∧ (alt2 agrCase) (cat d) (cat h₂) | h₂ <- lhdBy Coord h]
|
||||
-- nominalCoord' (_,h,d) = (alt nominal) (cat d) ∧ or [ (alt nominal) (cat h₂) ∧ (alt2 agrCase) (cat d) (cat h₂) | h₂ <- lhdBy Coord h]
|
||||
|
||||
-- verbalCoord (_,h,d) = verbal (cat d) ∧ or [ verbal (cat h₂) ∧ agrNumber (cat d) (cat h₂) | h₂ <- lhdBy Coord h ]
|
||||
|
||||
@ -92,28 +89,28 @@ nominalCoord' (_,h,d) = (alt nominal) (cat d) ∧ or [ (alt nominal) (cat h
|
||||
-- amb f (r,Node i₁ cs₁ h₁ ds₁,Node i₂ cs₂ h₂ ds₂) = or [ c (r,Node i₁ c₁ h,Node t c₂) | c₁ <- cs₁, c₂ <- cs₂ ]
|
||||
|
||||
|
||||
right' = \(_,h,d) -> h < d
|
||||
left' = \(_,h,d) -> d < h
|
||||
|
||||
-- agrNPG', agrC' :: Constraint' (WeightedT []) Role IPITag
|
||||
agrNPG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrPerson) (cat h) (cat d) ∧ (alt2 agrGender) (cat h) (cat d)
|
||||
agrNCG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrCase (cat h) (cat d)) ∧ (alt2 agrGender) (cat h) (cat d)
|
||||
-- agrNCG'' = amb argNCG
|
||||
agrC' = \(_,h,d) -> (alt2 agrCase) (cat h) (cat d)
|
||||
|
||||
agrC''' :: Constraint' (WeightedT []) Role IPITag
|
||||
agrC''' = \(_,h,d) -> test ( agrCase<$>(cat h)<*>(cat d) )
|
||||
|
||||
test :: (Foldable m) => m Bool -> Bool
|
||||
test = foldl (∨) False
|
||||
|
||||
-- right', left', sgl' :: Constraint' (WeightedT []) Role IPITag
|
||||
-- right' = \(_,h,d) -> h < d
|
||||
-- left' = \(_,h,d) -> d < h
|
||||
-- sgl' = \(r,h,_) -> r ∉ roles h
|
||||
|
||||
alt f xs = or [ f x | x <- xs ]
|
||||
alt2 f xs ys = or [ f x y | x <- xs , y <- ys ]
|
||||
-- -- agrNPG', agrC' :: Constraint' (WeightedT []) Role IPITag
|
||||
-- agrNPG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrPerson) (cat h) (cat d) ∧ (alt2 agrGender) (cat h) (cat d)
|
||||
-- agrNCG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrCase (cat h) (cat d)) ∧ (alt2 agrGender) (cat h) (cat d)
|
||||
-- -- agrNCG'' = amb argNCG
|
||||
-- agrC' = \(_,h,d) -> (alt2 agrCase) (cat h) (cat d)
|
||||
|
||||
-- agrC''' :: Constraint' (WeightedT []) Role IPITag
|
||||
-- agrC''' = \(_,h,d) -> test ( agrCase<$>(cat h)<*>(cat d) )
|
||||
|
||||
-- test :: (Foldable m) => m Bool -> Bool
|
||||
-- test = foldl (∨) False
|
||||
|
||||
-- -- right', left', sgl' :: Constraint' (WeightedT []) Role IPITag
|
||||
-- -- right' = \(_,h,d) -> h < d
|
||||
-- -- left' = \(_,h,d) -> d < h
|
||||
-- -- sgl' = \(r,h,_) -> r ∉ roles h
|
||||
|
||||
-- alt f xs = or [ f x | x <- xs ]
|
||||
-- alt2 f xs ys = or [ f x y | x <- xs , y <- ys ]
|
||||
|
||||
|
||||
pl1 = G1 { links =
|
||||
@ -134,25 +131,6 @@ pl1 = G1 { links =
|
||||
obl = [OBL prep [PCmpl]]
|
||||
}
|
||||
|
||||
pl1' = G1' { links' =
|
||||
WeightedT $ concat
|
||||
[
|
||||
[ LINK' Subj v' (n ∩ nom) [agrNPG',sgl,d] #w | (d,w) <- [(left',0.8),(right',0.2)] ],
|
||||
[ LINK' Cmpl v' cmpl'' [d] #w | (d,w) <- [(left',0.3),(right',0.7)] ],
|
||||
[ LINK' Mod n adjectival [agrNCG'] #1 ],
|
||||
[ LINK' Prep n' prep [d] #w | (d,w) <- [(left',0.1),(right',0.8)] ],
|
||||
[ LINK' Prep v' prep [] #1 ],
|
||||
[ LINK' PCmpl prep n [agrC',right'] #1 ],
|
||||
[ LINK' PCmpl prep (ppron ∩ akc) [agrC',right'] #1 ],
|
||||
[ LINK' Coord x conj [right'] #1 ],
|
||||
[ LINK' CCmpl conj x [right',coord'] #1 ]
|
||||
],
|
||||
gcs' = [obligatoriness'],
|
||||
-- sat = saturated,
|
||||
obl' = [OBL prep [PCmpl]]
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- saturated :: Grammar -> Node Role IPITag -> Bool
|
||||
-- sat g n = and [ r ∈ (roles n) | OBL p rs <- obl g, p n, r <- rs ]
|
||||
@ -160,14 +138,14 @@ pl1' = G1' { links' =
|
||||
|
||||
|
||||
-- obligatoriness = const True
|
||||
--obligatoriness :: (Eq τ) => Constraint τ κ
|
||||
-- obligatoriness :: (Eq τ) => Constraint τ κ
|
||||
obligatoriness (r,h,d) | h < d = all sat'' (pure h >>= clo rmdp)
|
||||
| d < h = all sat'' (pure d >>= rclo rmdp)
|
||||
|
||||
sat'' n = and [ r ∈ (roles n) | OBL p rs <- obl pl1, p (cat n), r <- rs ]
|
||||
|
||||
|
||||
obligatoriness' (r,h,d) | h < d = all sat''' (pure h >>= clo rmdp)
|
||||
| d < h = all sat''' (pure d >>= rclo rmdp)
|
||||
-- obligatoriness' (r,h,d) | h < d = all sat''' (pure h >>= clo rmdp)
|
||||
-- | d < h = all sat''' (pure d >>= rclo rmdp)
|
||||
|
||||
sat''' n = and [ r ∈ (roles n) | OBL p rs <- obl pl1, (alt p) (cat n), r <- rs ]
|
||||
-- sat''' n = and [ r ∈ (roles n) | OBL p rs <- obl pl1, (alt p) (cat n), r <- rs ]
|
||||
|
40
Parse.hs
40
Parse.hs
@ -1,4 +1,4 @@
|
||||
module Parse -- (Step (Step),Parse,Ind,Arc,(+<-),(+->),(<<),nextId,size,len,trees,ep,eps)
|
||||
module Parse -- (Step (Step),Parse,Ind,Arc,(+<-),(+->),(<<),nextId,size,len,trees,ep,eps,arcs)
|
||||
where
|
||||
|
||||
-- import Data.List (intercalate)
|
||||
@ -6,6 +6,7 @@ import Base
|
||||
import Step
|
||||
|
||||
import Data.List
|
||||
import GHC.Exts
|
||||
|
||||
type Parse τ c = [Step τ c]
|
||||
|
||||
@ -48,3 +49,40 @@ showParse = concatMap shortStep
|
||||
showArc (Dep r i) = show r ++ ":" ++ show i
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-- arclist :: Parse τ κ -> [(Int,Arc τ)]
|
||||
-- arclist p = concatMap stepArcs p
|
||||
-- where
|
||||
-- indexes = [1..(length p)]
|
||||
-- stepArcs (Step i _ hs ds) = [(i,Head t j) | Head t j <- hs ] ++ [(j,Head t i) | Dep t j <- ds ]
|
||||
-- complete [] _ = []
|
||||
-- complete (i:is) (a@(i',_):as) | i == i' = a : complete is as
|
||||
-- | otherwise = (i,Root) : complete is (a:as)
|
||||
|
||||
arclist :: Parse τ κ -> [(Int,Arc τ)]
|
||||
arclist p = complete indexes $ sortWith (\(i,_)->i) $ concatMap stepArcs p
|
||||
where
|
||||
indexes = [1..(length p)]
|
||||
stepArcs (Step i _ hs ds) = [(i,Head t j) | Head t j <- hs ] ++ [(j,Head t i) | Dep t j <- ds ]
|
||||
complete [] _ = []
|
||||
complete (i:is) (a@(i',_):as) | i == i' = a : complete is as
|
||||
| otherwise = (i,Root) : complete is (a:as)
|
||||
complete (i:is) [] = (i,Root) : complete is []
|
||||
|
||||
|
||||
conll :: [String] -> Parse τ κ -> [Conll τ κ]
|
||||
conll words parse = let steps = reverse parse
|
||||
arcs = arclist parse
|
||||
in
|
||||
conll' words steps arcs
|
||||
where
|
||||
conll' [] [] [] = []
|
||||
conll' (w:ws) (Step _ c _ _ : ss) ((i,a):as) = Conll i w c a : conll' ws ss as
|
||||
|
||||
|
||||
data Conll τ κ = Conll Int String κ (Arc τ)
|
||||
instance (Show τ, Show κ) => Show (Conll τ κ) where
|
||||
show (Conll i w c Root) = intercalate "\t" [show i,w,show c,"0","Root"]
|
||||
show (Conll i w c (Head t j)) = intercalate "\t" [show i,w,show c,show j,show t]
|
||||
|
85
ParserW.hs
85
ParserW.hs
@ -5,15 +5,9 @@ module ParserW (
|
||||
module Parse,
|
||||
WeightedList,
|
||||
step,
|
||||
parses,
|
||||
parse,
|
||||
parseA,
|
||||
parse',
|
||||
parseA',
|
||||
-- parseSel,
|
||||
-- selectSize,
|
||||
shift,
|
||||
shift',
|
||||
-- shifts,
|
||||
connect,
|
||||
addHead,
|
||||
addDep) where
|
||||
@ -35,88 +29,35 @@ import Control.Monad.Plus
|
||||
import Base
|
||||
import Weighted
|
||||
|
||||
|
||||
shift :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ κ -> m (Parse τ κ)
|
||||
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
|
||||
|
||||
|
||||
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, 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' ]
|
||||
|
||||
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 :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (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 :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> Wordform -> Parse τ κ -> WeightedList (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 :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (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
|
||||
parses :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
|
||||
parses d g = steps d g
|
||||
|
||||
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
|
||||
parse :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
|
||||
parse d g = parses d g |? (==1) . trees |? pass g . lastNode
|
||||
|
||||
|
||||
type WeightedList = WeightedT []
|
||||
-- parseA' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ))
|
||||
-- parseA' d g = parser' d g . words
|
||||
|
||||
|
||||
-- type WeightedList = StateT Int (WeightedT [])
|
||||
|
||||
|
@ -11,7 +11,7 @@ import Lexicon
|
||||
import Data.ADTTag.IPITag
|
||||
import qualified Data.ADTTag.IPITag.PoliMorf as PM
|
||||
|
||||
instance (MonadPlus m) => Lexicon m IPITag PM.Dic where
|
||||
instance WeightedLexicon IPITag PM.Dic where
|
||||
dic = PM.dic
|
||||
|
||||
|
||||
|
15
Weighted.hs
15
Weighted.hs
@ -17,8 +17,8 @@ inv (Weight w) = (Weight (1.0 - w))
|
||||
|
||||
data Weighted a = Weighted Weight a
|
||||
|
||||
bare :: Weighted a -> a
|
||||
bare (Weighted _ x) = x
|
||||
unweighted :: Weighted a -> a
|
||||
unweighted (Weighted _ x) = x
|
||||
|
||||
weight :: Weighted a -> Weight
|
||||
weight (Weighted w _) = w
|
||||
@ -35,6 +35,9 @@ instance Monad Weighted where
|
||||
(Weighted w x) >>= f = let (Weighted w' y) = f x
|
||||
in Weighted (w<>w') y
|
||||
|
||||
|
||||
|
||||
|
||||
instance (Show a) => Show (Weighted a) where
|
||||
show (Weighted (Weight w) x) = show x ++ "#" ++ show w
|
||||
|
||||
@ -63,9 +66,9 @@ instance Alternative m => Alternative (WeightedT m) where
|
||||
x <|> y = WeightedT ( runWeightedT x <|> runWeightedT y )
|
||||
|
||||
instance (MonadPlus m, Foldable m) => Foldable (WeightedT m) where
|
||||
-- foldr f z c = foldr f z (map bare $ toList $ runWeightedT c)
|
||||
foldr f z c = foldr f z (fmap bare $ runWeightedT c)
|
||||
-- foldr f z c = foldr (f . bare) z (runWeightedT c)
|
||||
-- foldr f z c = foldr f z (map unweighted $ toList $ runWeightedT c)
|
||||
foldr f z c = foldr f z (fmap unweighted $ runWeightedT c)
|
||||
-- foldr f z c = foldr (f . unweighted) z (runWeightedT c)
|
||||
|
||||
instance Monad m => Monad (WeightedT m) where
|
||||
return = WeightedT . return . return
|
||||
@ -86,3 +89,5 @@ instance (Alternative m, Monad m) => MonadPlus (WeightedT m)
|
||||
-- (WeightedT x)= WeightedT $ sequenceA x
|
||||
|
||||
|
||||
|
||||
type WeightedList = WeightedT []
|
||||
|
Loading…
Reference in New Issue
Block a user