fdp2/PL1.hs

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