2017-01-14 16:13:50 +01:00
|
|
|
|
{-# 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
|
2017-03-16 09:03:46 +01:00
|
|
|
|
import Weighted
|
2017-01-14 16:13:50 +01:00
|
|
|
|
|
|
|
|
|
type Constraint τ κ = (τ, Node τ κ, Node τ κ) -> Bool
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
-- class (MonadPlus m, Eq τ {- , Eq κ -}) => Grammar m τ κ γ where
|
2017-01-14 16:13:50 +01:00
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
-- 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 τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
heads g n = [ (r,h) | h <- visible g n,
|
|
|
|
|
(r,cs) <- link g (cat h) (cat n),
|
|
|
|
|
all ($ (r,h,n)) cs ]
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
deps :: γ -> Node τ κ -> WeightedList (τ, Node τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
deps g n = [ (r,d) | d <- visible g n,
|
|
|
|
|
(r,cs) <- link g (cat n) (cat d),
|
|
|
|
|
all ($ (r,n,d)) cs ]
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
visible :: γ -> Node τ κ -> WeightedList (Node τ κ)
|
2017-01-14 16:13:50 +01:00
|
|
|
|
visible _ = mfromList . lv
|
|
|
|
|
|
|
|
|
|
pass :: γ -> Node τ κ -> Bool
|
|
|
|
|
pass = const . const True
|
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
link :: γ -> κ -> κ -> WeightedList (τ, [Constraint τ κ])
|
2017-01-14 16:13:50 +01:00
|
|
|
|
|
2017-03-16 09:03:46 +01:00
|
|
|
|
-- type WeightedGrammar = Grammar WeightedList
|
2017-01-14 16:13:50 +01:00
|
|
|
|
|
|
|
|
|
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 τ κ])
|
|
|
|
|
|