84 lines
2.6 KiB
Haskell
84 lines
2.6 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
|
||
|
||
-- 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 τ κ])
|
||
|