152 lines
5.6 KiB
Haskell
152 lines
5.6 KiB
Haskell
{-# 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 (_,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
|
||
|
||
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 (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]]
|
||
}
|
||
|
||
|
||
-- 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 ]
|