67 lines
1.9 KiB
Haskell
67 lines
1.9 KiB
Haskell
|
{-# 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
|
|||
|
|
|
|||
|
|
-- sat :: Grammar m τ κ γ => γ -> Node τ κ -> Bool
|
|||
|
|
-- sat = const . const True
|
|||
|
|
|
|||
|
|
pass :: γ -> Node τ κ -> Bool
|
|||
|
|
pass = const . const True
|
|||
|
|
-- pass g n = sat g n --all (sat g) ((preds<>pure) n)
|
|||
|
|
|
|||
|
|
link :: γ -> κ -> κ -> m (τ, [Constraint τ κ])
|
|||
|
|
|
|||
|
|
|
|||
|
|
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 τ κ])
|
|||
|
|
|