fdp2/PL1.hs

152 lines
5.6 KiB
Haskell
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{-# 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 ]