MemoChart.hs

{-# LANGUAGE FlexibleContexts #-}

import           Control.Monad.State.Lazy
import           Data.Map                 hiding (map, splitAt)
import           Prelude                  hiding (lookup)

memoize2 f p@(x, _) = do -- only uses 1st arg as key
  v <- gets $ lookup x
  case v of
    Just y -> return y
    _      -> do
      y <- f p
      modify $ insert x y
      return y

memo2 f x = evalState (fix (memoize2 . f) x) empty

-- chart parsing for free!
parse _ ([x], g) = return [ n | n :- y <- g, y==x ]
parse f (xs,  g) = concat <$> (sequence $ map help (breaks xs)) where
  breaks u = [splitAt i u | i <- [1..length u - 1]]
  help (ls, rs) = do
    nls <- f (ls, g) -- left to
    nrs <- f (rs, g) -- right!
    return [n | nl <- nls, nr <- nrs, n :< (l,r) <- g, l==nl, r==nr]

memoParse :: String -> CFG Cat String -> [Cat]
memoParse str g = memo2 parse (words str, g)

data CNFRule n x = n :- x | n :< (n, n)
type CFG n x = [CNFRule n x] -- re-implement via nondet Maps

data Cat = S | D | DP | NP | VT | VD | VP | P | PP
  deriving (Eq, Show)

eng :: CFG Cat String
eng = [ S  :< (DP, VP)    ,
        VP :< (VT, DP)    ,
        VT :< (VD, DP)    ,
        DP :< (D , NP)    ,
        NP :< (NP, PP)    ,
        PP :< (P , DP)    ,
        VP :< (VP, PP)    ,
        DP :- "Mary"      ,
        DP :- "John"      ,
        VT :- "saw"       ,
        VD :- "gave"      ,
        VP :- "left"      ,
        D  :- "the"       ,
        NP :- "binoculars",
        NP :- "elk"       ,
        P  :- "with"      ]