fdp2/Grammar.hs

{-# 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
 
--   pass :: γ -> Node τ κ -> Bool
--   pass = const . const True

--   link :: γ -> κ -> κ -> m (τ, [Constraint τ κ])

class (Eq τ) => WeightedGrammar τ κ γ where

  heads   :: γ -> Node τ κ -> WeightedList (τ, 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 τ κ -> WeightedList (τ, 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 τ κ -> WeightedList (Node τ κ)
  visible _ = mfromList . lv
 
  pass :: γ -> Node τ κ -> Bool
  pass = const . const True

  link :: γ -> κ -> κ -> WeightedList (τ, [Constraint τ κ])

-- type WeightedGrammar = Grammar WeightedList

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