fdp2/G1.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonadComprehensions #-}

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 :: WeightedList (LINK τ κ), gcs :: [Constraint τ κ], obl :: [OBL τ κ] }

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 ]
    -- 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) [τ]