initial
This commit is contained in:
commit
e2914d0ae8
|
|
@ -0,0 +1,12 @@
|
|||
module Base (
|
||||
Ind,
|
||||
Wordform,
|
||||
Arc (Head,Dep)
|
||||
) where
|
||||
|
||||
type Ind = Int
|
||||
type Wordform = String
|
||||
data Arc τ = Head { role :: τ, dst :: Ind }
|
||||
| Dep { role :: τ, dst :: Ind }
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
{-# 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
|
||||
|
||||
instance Show (WeightedList IPITag) where
|
||||
show = show . runWeightedT
|
||||
|
||||
main = do
|
||||
pm <- readPoliMorfHead1 200000 "pm.sorted.uniq.tsv"
|
||||
let l = length (parse' pm pl1' "dom" :: WeightedList (Parse Role (WeightedList IPITag)))
|
||||
putStrLn $ "READY (" ++ show l ++ ")"
|
||||
input <- getLine
|
||||
let WeightedT parses = parseA' pm pl1' input :: WeightedList (Parse Role (WeightedList IPITag))
|
||||
parselist = zip [1..] parses
|
||||
-- sequence_ $ map (\(n,p) -> do
|
||||
-- putStrLn $ "*** [" ++ show n ++ "] ***"
|
||||
-- putStrLn $ show p
|
||||
-- ) parselist
|
||||
|
||||
putStrLn $ "PARSES: " ++ show (length parselist)
|
||||
putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . bare . snd) parselist))
|
||||
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MonadComprehensions #-}
|
||||
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module G1 (
|
||||
module Grammar,
|
||||
G1 (G1),
|
||||
G1' (G1'),
|
||||
links,
|
||||
links',
|
||||
gcs,
|
||||
obl,
|
||||
gcs',
|
||||
obl',
|
||||
LINK (LINK),
|
||||
LINK' (LINK'),
|
||||
OBL (OBL),
|
||||
)where
|
||||
|
||||
import Control.Monad.Plus
|
||||
import Control.Monad.Trans.State
|
||||
import Grammar
|
||||
import Node
|
||||
import Weighted
|
||||
import Prelude.Unicode
|
||||
-- import Data.Foldable
|
||||
|
||||
data G1 τ κ = G1 { links :: WeightedT [] (LINK τ κ), gcs :: [Constraint τ κ], obl :: [OBL τ κ] }
|
||||
|
||||
instance (Eq τ) => Grammar (WeightedT []) τ κ (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 ]
|
||||
-- pass :: Grammar (WeightedT []) τ κ x => x -> Node τ κ -> Bool
|
||||
-- pass g n = and [ sat g x | x <- preds n ]
|
||||
pass g = all (sat g) . (pure <> preds)
|
||||
where
|
||||
sat g n = and [ r ∈ (roles n) | OBL p rs <- obl g, p (cat n), r <- rs ]
|
||||
|
||||
data G1' τ κ = G1' { links' :: WeightedT [] (LINK' τ κ), gcs' :: [Constraint' (WeightedT []) τ κ], obl' :: [OBL τ κ] }
|
||||
|
||||
instance (Eq τ) => Grammar' (WeightedT []) τ κ (G1' τ κ) where
|
||||
link' g hs ds = [ (r, gcs' g ++ cs) | LINK' r p q cs <- links' g, any p hs, any q ds ]
|
||||
-- sat' g n = and [ r ∈ (roles n) | OBL p rs <- obl' g, c <- (cat n), p c, r <- rs ]
|
||||
|
||||
|
||||
-- instance (Eq τ, Eq κ) => Grammar (StateT Int (WeightedT [])) τ κ (G1 τ κ) where
|
||||
-- link g h d = [ (r, gcs g ++ cs) | f <- links g, LINK r p q cs ← evalState f, p h, q d ]
|
||||
|
||||
data LINK τ κ = LINK τ (κ -> Bool) (κ -> Bool) [Constraint τ κ]
|
||||
data LINK' τ κ = LINK' τ (κ -> Bool) (κ -> Bool) [Constraint' (WeightedT []) τ κ]
|
||||
data OBL τ κ = OBL (κ -> Bool) [τ]
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
{-# LANGUAGE MonadComprehensions #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Grammar where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Plus
|
||||
import Control.Applicative
|
||||
import Data.List
|
||||
-- import Data.Monoid
|
||||
-- import Control.Monad.Unicode
|
||||
import Node
|
||||
-- import Weighted
|
||||
|
||||
type Constraint τ κ = (τ, Node τ κ, Node τ κ) -> Bool
|
||||
|
||||
class (MonadPlus m, Eq τ {- , Eq κ -}) => Grammar m τ κ γ where
|
||||
|
||||
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
|
||||
|
||||
-- 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 τ κ])
|
||||
|
||||
|
||||
type Constraint' m τ κ = (τ, Node τ (m κ), Node τ (m κ)) -> Bool
|
||||
|
||||
class (MonadPlus m, Eq τ) => Grammar' m τ κ γ where
|
||||
|
||||
heads' :: γ -> Node τ (m κ) -> m (τ, Node τ (m κ))
|
||||
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 κ) -> m (τ, Node τ (m κ))
|
||||
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 κ) -> m (Node τ (m κ))
|
||||
visible' _ = mfromList . lv
|
||||
|
||||
sat' :: γ -> Node τ (m κ) -> Bool
|
||||
sat' = const . const True
|
||||
|
||||
pass' :: γ -> Node τ (m κ) -> Bool
|
||||
pass' = const . const True
|
||||
|
||||
link' :: γ -> m κ -> m κ -> m (τ, [Constraint' m τ κ])
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Lexicon (Lexicon,dic)
|
||||
where
|
||||
|
||||
import Control.Monad.Plus
|
||||
|
||||
|
||||
class (MonadPlus m) => Lexicon m a d where
|
||||
dic :: d -> String -> m a
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
{-# LANGUAGE MonadComprehensions #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Node
|
||||
(Node (Node),
|
||||
module Toolbox,
|
||||
module Step,
|
||||
dArcs,hArc,ind, cat,
|
||||
cats,
|
||||
preds,succs,
|
||||
lng,rng,ng,ldp,rdp,dp,lhd,rhd,hd,lmdp,rmdp,lv,le,
|
||||
lhdBy,
|
||||
up,down,root,roots,
|
||||
roles,leftRoles,rightRoles,
|
||||
headless,
|
||||
lastNode)
|
||||
where
|
||||
|
||||
|
||||
import Control.Monad
|
||||
-- import Data.Monoid
|
||||
import Data.List (intercalate,intersperse,find)
|
||||
import Data.Maybe (maybeToList)
|
||||
import Toolbox
|
||||
import Step
|
||||
import Parse
|
||||
import Base
|
||||
|
||||
data Node τ κ = Node {past :: [Step τ κ], future :: [Step τ κ]} -- deriving (Eq)
|
||||
instance {- (Eq τ, Eq κ) => -} Eq (Node τ κ) where
|
||||
n₁ == n₂ = (ind n₁) == (ind n₂)
|
||||
instance {- (Eq τ, Eq κ) => -} Ord (Node τ κ) where
|
||||
compare n₁ n₂ = compare (ind n₁) (ind n₂)
|
||||
|
||||
ind :: Node τ κ -> Ind
|
||||
ind (Node (Step i _ _ _ : _) _) = i
|
||||
|
||||
cat :: Node τ κ -> κ
|
||||
cat (Node (Step _ c _ _ : _) _) = c
|
||||
|
||||
cats = map cat
|
||||
|
||||
hArc, dArcs :: Node τ κ -> [Arc τ]
|
||||
hArc (Node (Step _ _ h _ : _) _) = h
|
||||
dArcs (Node (Step _ _ _ d : _) _) = d
|
||||
|
||||
lastNode :: Parse τ κ -> Node τ κ
|
||||
lastNode p = Node p []
|
||||
|
||||
|
||||
lng, rng :: Node τ κ -> [Node τ κ]
|
||||
|
||||
lng (Node (s:s':p) q) = return (Node (s':p) (s:q))
|
||||
lng _ = mzero
|
||||
|
||||
rng (Node p (s:q)) = return (Node (s:p) q)
|
||||
rng _ = mzero
|
||||
|
||||
ng, preds, succs :: Node τ κ -> [Node τ κ]
|
||||
ng = lng <> rng
|
||||
|
||||
|
||||
preds (Node (s:s':p) q) = let prev = (Node (s':p) (s:q)) in (Node (s':p) (s:q)) : preds prev
|
||||
preds _ = []
|
||||
-- preds = clo lng
|
||||
succs = clo rng
|
||||
|
||||
lhd, rhd, hd, ldp, rdp, dp, le, lv, lmdp, rmdp, down, up, root, roots :: (Ord (Node τ κ)) => Node τ κ -> [Node τ κ]
|
||||
|
||||
ldp n = [ n' | n' <- preds n, Dep _ i <- dArcs n, ind n' == i ]
|
||||
rdp n = [ n' | n' <- succs n, Head _ i <- hArc n', ind n == i ]
|
||||
dp = ldp <> rdp
|
||||
|
||||
lhd v = [ v' | Head _ i <- hArc v, v' <- preds v, ind v' == i ]
|
||||
rhd v = [ v' | v' <- succs v, Dep _ i <- dArcs v', ind v == i ]
|
||||
hd = lhd <> rhd
|
||||
|
||||
ldpBy,rdpBy,dpBy :: (Ord (Node τ κ)) => τ -> Node τ κ -> [Node τ κ]
|
||||
ldpBy r n = [ n' | n' <- preds n, Dep r i <- dArcs n, ind n' == i ]
|
||||
rdpBy r n = [ n' | n' <- succs n, Head r i <- hArc n', ind n == i ]
|
||||
dpBy r = ldpBy r <> rdpBy r
|
||||
|
||||
lhdBy,rhdBy,hdBy :: (Ord (Node τ κ)) => τ -> Node τ κ -> [Node τ κ]
|
||||
lhdBy r n = [ n' | n' <- preds n, Head r i <- hArc n , ind n' == i ]
|
||||
rhdBy r n = [ n' | n' <- succs n, Dep r i <- dArcs n', ind n == i ]
|
||||
hdBy r = lhdBy r <> rhdBy r
|
||||
|
||||
|
||||
le = mrclo lmdp
|
||||
|
||||
lmdp = just minimum . ldp
|
||||
rmdp = just maximum . rdp
|
||||
|
||||
lv = mrclo lmdp >=> lng >=> rclo lhd
|
||||
|
||||
down = clo dp
|
||||
up = clo hd
|
||||
|
||||
root = mrclo hd
|
||||
roots = (filter headless) . preds
|
||||
|
||||
headless :: (Ord (Node τ κ)) => Node τ κ -> Bool
|
||||
headless = null . hd
|
||||
-- roots = preds |? headless
|
||||
|
||||
roles, leftRoles, rightRoles :: Node τ κ -> [τ]
|
||||
roles = leftRoles <> rightRoles
|
||||
leftRoles v = [ r | Dep r _ <- dArcs v ]
|
||||
rightRoles v = [ r | v' <- succs v, Head r i <- hArc v', i==ind v ]
|
||||
|
||||
|
||||
instance (Show τ, Show κ) => Show (Node τ κ) where
|
||||
show (Node p q) = showSteps p ++ " @ " ++ showStepsRev q ++ "\n"
|
||||
where
|
||||
showStepsRev = intercalate " * " . map show
|
||||
showSteps = showStepsRev . reverse
|
||||
|
|
@ -0,0 +1,173 @@
|
|||
{-# LANGUAGE MonadComprehensions #-}
|
||||
|
||||
module PL1 where
|
||||
|
||||
import G1
|
||||
import Data.ADTTag
|
||||
import Data.ADTTag.IPITag
|
||||
import Control.Applicative
|
||||
import Node
|
||||
import Algebra.Lattice
|
||||
import Prelude.Unicode
|
||||
import Weighted
|
||||
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
|
||||
|
||||
nominal = n ∪ ppron
|
||||
verbal = fin ∪ praet
|
||||
adjectival = adj ∪ pact ∪ ppas
|
||||
adverbial = adv ∪ pcon ∪ pant
|
||||
|
||||
cmpl'' = n ∩ (gen ∪ dat ∪ acc ∪ inst ∪ prep)
|
||||
|
||||
x = nominal ∪ verbal ∪ adjectival ∪ adverbial
|
||||
|
||||
v' = fin ∪ praet
|
||||
n' = subst ∪ ger
|
||||
|
||||
adj'' = adj ∪ pact ∪ ppas
|
||||
|
||||
adv'' = adv ∪ pcon ∪ pant
|
||||
|
||||
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) )
|
||||
|
||||
--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
|
||||
|
||||
nominalCoord (_,h,d) = nominal (cat d) ∧ or [ nominal (cat h₂) ∧ 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 ]
|
||||
|
||||
adjectivalCoord (_,h,d) = adjectival (cat d)
|
||||
∧ or [ adjectival (cat h₂)
|
||||
-- && agrNPG (undefined,h₂,d)
|
||||
∧ agrNumber (cat d) (cat h₂)
|
||||
∧ agrCase (cat d) (cat h₂)
|
||||
∧ agrGender (cat d) (cat h₂)
|
||||
| h₂ <- lhdBy Coord h
|
||||
]
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
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]
|
||||
|
||||
-- verbalCoord (_,h,d) = verbal (cat d) ∧ or [ verbal (cat h₂) ∧ agrNumber (cat d) (cat h₂) | h₂ <- lhdBy Coord h ]
|
||||
|
||||
-- adjectivalCoord (_,h,d) = adjectival (cat d)
|
||||
-- ∧ or [ adjectival (cat h₂)
|
||||
-- -- && agrNPG (undefined,h₂,d)
|
||||
-- ∧ agrNumber (cat d) (cat h₂)
|
||||
-- ∧ agrCase (cat d) (cat h₂)
|
||||
-- ∧ agrGender (cat d) (cat h₂)
|
||||
-- | h₂ <- lhdBy Coord 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 ]
|
||||
|
||||
|
||||
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]]
|
||||
}
|
||||
|
||||
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 ]
|
||||
|
||||
|
||||
|
||||
-- obligatoriness = const True
|
||||
--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)
|
||||
|
||||
sat''' n = and [ r ∈ (roles n) | OBL p rs <- obl pl1, (alt p) (cat n), r <- rs ]
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
module Parse -- (Step (Step),Parse,Ind,Arc,(+<-),(+->),(<<),nextId,size,len,trees,ep,eps)
|
||||
where
|
||||
|
||||
-- import Data.List (intercalate)
|
||||
import Base
|
||||
import Step
|
||||
|
||||
import Data.List
|
||||
|
||||
type Parse τ c = [Step τ c]
|
||||
|
||||
ep = []
|
||||
eps = [ep]
|
||||
|
||||
infixl 4 <<, +->, +<-
|
||||
(<<) :: Parse τ κ -> Step τ κ -> Parse τ κ
|
||||
p << s = s : p
|
||||
|
||||
addNode = (<<)
|
||||
|
||||
(+->),(+<-) :: Parse τ κ -> Arc τ -> Parse τ κ
|
||||
(Step i c [] d : p) +-> a = Step i c [a] d : p
|
||||
(Step i c h d : p) +<- a = Step i c h (a:d) : p
|
||||
|
||||
linkHead = (+->)
|
||||
linkDep = (+<-)
|
||||
|
||||
nextId :: Parse τ κ -> Ind
|
||||
nextId [] = 1
|
||||
nextId (Step i _ _ _:_) = i + 1
|
||||
|
||||
len :: Parse τ κ -> Int
|
||||
len p = length p
|
||||
|
||||
size :: Parse τ κ -> Int
|
||||
size p = sum (map stepSize p) where stepSize (Step _ _ h ds) = length (h ++ ds)
|
||||
|
||||
trees :: Parse τ κ -> Int
|
||||
trees p = len p - size p
|
||||
|
||||
|
||||
showParse :: (Show τ, Show κ) => Parse τ κ -> String
|
||||
showParse = concatMap shortStep
|
||||
where
|
||||
shortStep (Step i c h ds) = "<" ++ show i ++ "|" ++ showArcs h ++ "|" ++ showArcs ds ++ ">"
|
||||
showArcs = intercalate "," . map showArc
|
||||
showArc (Head r i) = show r ++ ":" ++ show i
|
||||
showArc (Dep r i) = show r ++ ":" ++ show i
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,245 @@
|
|||
{-# 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)
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module PoliMorf (
|
||||
module Data.ADTTag.IPITag,
|
||||
module PM -- Data.ADTTag.IPITag.PoliMorf
|
||||
) where
|
||||
|
||||
import Control.Monad.Plus
|
||||
import Lexicon
|
||||
import Data.ADTTag.IPITag
|
||||
import qualified Data.ADTTag.IPITag.PoliMorf as PM
|
||||
|
||||
instance (MonadPlus m) => Lexicon m IPITag PM.Dic where
|
||||
dic = PM.dic
|
||||
|
||||
|
||||
|
||||
-- data SynTag = SUBST' Name1
|
||||
-- | FIN'
|
||||
-- | PREP' Prep
|
||||
-- deriving (Show,Eq,Ord)
|
||||
|
||||
-- data Name1 = Common | Proper
|
||||
|
||||
-- data Prep = PrepPod | PrepDo | PrepNa | PrepW | PrepPrzez | PrepPod
|
||||
-- syn ::
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
module Role where
|
||||
|
||||
data Role = Subj
|
||||
| Cmpl
|
||||
| Mod
|
||||
| Poss
|
||||
| Prep
|
||||
| PCmpl
|
||||
| CCmpl
|
||||
| Coord
|
||||
| Conj
|
||||
| Num
|
||||
| Det
|
||||
deriving (Show,Eq,Ord)
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Step (Step (Step))
|
||||
where
|
||||
|
||||
import Data.List (intercalate)
|
||||
import Base
|
||||
|
||||
data Step τ κ = Step Ind κ [Arc τ] [Arc τ] deriving (Eq,Ord,Show)
|
||||
|
||||
|
||||
-- dst :: Arc
|
||||
-- instance Show Step where
|
||||
-- show (Step i c h d) = show i ++ "." ++ show c ++ showHead h ++ showDeps d
|
||||
-- where showHead [] = ""
|
||||
-- showHead [a] = "(" ++ showArc a ++ ")"
|
||||
-- showDeps [] = ""
|
||||
-- showDeps ds = "[" ++ intercalate " " (map showArc ds) ++ "]"
|
||||
-- showArc (r,i) = show r ++ ":" ++ show i
|
||||
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
module Toolbox
|
||||
( -- Applicative
|
||||
pure,
|
||||
|
||||
-- Monad
|
||||
(>>=), (>=>),
|
||||
|
||||
-- local
|
||||
(<>),
|
||||
(<!>),(|?),
|
||||
clo, rclo, mclo, mrclo,
|
||||
just
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Control.Monad ((>>=),(>=>),MonadPlus(mplus,mzero),mfilter)
|
||||
import Control.Applicative (pure)
|
||||
|
||||
import Data.Foldable
|
||||
|
||||
-- OR
|
||||
|
||||
infixr 6 <>
|
||||
(<>) :: (MonadPlus m) => (a -> m b) -> (a -> m b) -> (a -> m b)
|
||||
(f <> g) x = f x `mplus` g x
|
||||
|
||||
-- SHORT CIRCUIT OR
|
||||
|
||||
infixr 6 <!>
|
||||
(<!>) :: (MonadPlus m, Foldable m) => (a -> m b) -> (a -> m b) -> (a -> m b)
|
||||
(f <!> g) x = let fx = f x in if null fx then g x else fx
|
||||
|
||||
-- VALUE FILTER
|
||||
|
||||
infixl 4 |?
|
||||
(|?) :: (MonadPlus m) => (a -> m b) -> (b -> Bool) -> (a -> m b)
|
||||
f |? g = mfilter g . f
|
||||
|
||||
|
||||
|
||||
clo,mclo,rclo,mrclo:: (MonadPlus m, Foldable m) => (a -> m a) -> a -> m a
|
||||
clo f = f >=> ( pure <> clo f )
|
||||
rclo f = pure <> clo f
|
||||
mrclo f = (f >=> mrclo f) <!> pure
|
||||
mclo f = f >=> mrclo f
|
||||
|
||||
|
||||
-- INPUT: Function f returning element of a list or fails if list empty
|
||||
-- OUTPUT: Function returning the list containing the f value or empty list
|
||||
-- ex: the maximum, the head, the last, e.t.c
|
||||
|
||||
-- the :: ([a] -> b) -> ([a] -> [b])
|
||||
-- (the f) [] = []
|
||||
-- (the f) xs = [f xs]
|
||||
|
||||
just :: ([a] -> b) -> ([a] -> [b])
|
||||
(just f) [] = []
|
||||
(just f) xs = [f xs]
|
||||
|
||||
its :: (a->b) -> ([a]->b)
|
||||
its f = f.head
|
||||
|
||||
their :: (a->b) -> ([a]->[b])
|
||||
their = map
|
||||
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
module Weighted
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Foldable
|
||||
import Data.Monoid
|
||||
|
||||
newtype Weight = Weight Float deriving (Show,Eq,Ord)
|
||||
|
||||
instance Monoid Weight where
|
||||
mempty = Weight 1
|
||||
Weight w `mappend` Weight w' = Weight (w * w')
|
||||
|
||||
inv :: Weight -> Weight
|
||||
inv (Weight w) = (Weight (1.0 - w))
|
||||
|
||||
data Weighted a = Weighted Weight a
|
||||
|
||||
bare :: Weighted a -> a
|
||||
bare (Weighted _ x) = x
|
||||
|
||||
weight :: Weighted a -> Weight
|
||||
weight (Weighted w _) = w
|
||||
|
||||
instance Functor Weighted where
|
||||
fmap f (Weighted w x) = Weighted w (f x)
|
||||
|
||||
instance Applicative Weighted where
|
||||
pure = Weighted mempty
|
||||
Weighted w f <*> Weighted w' x = Weighted (w <> w') (f x)
|
||||
|
||||
instance Monad Weighted where
|
||||
return = pure
|
||||
(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
|
||||
|
||||
infix 9 #
|
||||
x#w = Weighted (Weight w) x
|
||||
|
||||
instance Eq (Weighted a) where
|
||||
Weighted w1 _ == Weighted w2 _ = w1 == w2
|
||||
|
||||
instance Ord (Weighted a) where
|
||||
Weighted w1 _ <= Weighted w2 _ = w1 <= w2
|
||||
|
||||
|
||||
|
||||
newtype WeightedT m a = WeightedT { runWeightedT :: m (Weighted a) }
|
||||
|
||||
instance Functor m => Functor (WeightedT m) where
|
||||
f `fmap` x = WeightedT (liftA f `fmap` runWeightedT x)
|
||||
|
||||
instance Applicative m => Applicative (WeightedT m) where
|
||||
pure = WeightedT . pure . pure
|
||||
f <*> x = WeightedT (liftA2 (<*>) (runWeightedT f) (runWeightedT x))
|
||||
|
||||
instance Alternative m => Alternative (WeightedT m) where
|
||||
empty = WeightedT empty
|
||||
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)
|
||||
|
||||
instance Monad m => Monad (WeightedT m) where
|
||||
return = WeightedT . return . return
|
||||
x >>= f = WeightedT $ do
|
||||
Weighted w a <- runWeightedT x
|
||||
Weighted w' b <- runWeightedT (f a)
|
||||
return (Weighted (w<>w') b)
|
||||
|
||||
instance (Alternative m, Monad m) => MonadPlus (WeightedT m)
|
||||
|
||||
-- instance (MonadPlus m, Traversable m) => Traversable (WeightedT m) where
|
||||
-- traverse f xs = return $ traverse (liftM f) (runWeightedT xs)
|
||||
|
||||
-- traverse f xs | null xs = pure mzero
|
||||
-- | otherwise = foldr (\x v -> mplus <$> f x <*> v) (pure mzero) xs
|
||||
|
||||
|
||||
-- (WeightedT x)= WeightedT $ sequenceA x
|
||||
|
||||
|
||||
Loading…
Reference in New Issue