CFG.hs

module CFG where

type NT = String
type T  = String

data RightSide = NTs (NT, NT) | Term T deriving (Show, Eq, Ord)

type Rule = (NT, RightSide)
type CFG = [Rule]

leftSide :: Rule -> NT
leftSide = fst

rightSide :: Rule -> RightSide
rightSide = snd

rulesFor :: RightSide -> CFG -> [Rule]
-- ^ returns all the rules that can derive the given right side
rulesFor r = filter ((r==) . rightSide)

ntGens :: CFG -> (NT, NT) -> [NT]
ntGens g r = map leftSide $ rulesFor (NTs r) g

termGens :: CFG -> T -> [NT]
termGens g r = map leftSide $ rulesFor (Term r) g

parseRule :: String -> Rule
-- ^ Takes a string of the form "S -> A B" or "S -> a" and returns a corresponding rule
parseRule ws = f $ words ws
    where f [nt, "->", t] = (nt, Term t)
          f [nt, "->", nt1, nt2] = (nt, NTs (nt1, nt2))

parseCFG :: [String] -> CFG
-- ^ Takes a list of rule-formatted strings and returns a grammar
parseCFG = map parseRule

grammarFromFile :: String -> IO CFG
-- ^ Takes a filename and returns a CFG, read in from that file.
grammarFromFile fs = do f <- readFile fs; return $ parseCFG $ lines f

cfg_grammar.txt

S -> A B
S -> A A
A -> A A
A -> a
B -> B B
B -> b

compiler_msg.txt

GHCi, version 8.2.2: http://www.haskell.org/ghc/  :? for help
[1 of 2] Compiling CFG              ( CFG.hs, interpreted )
[2 of 2] Compiling Main             ( CYK.hs, interpreted )

CYK.hs:11:13: error:
    * Couldn't match type `Char' with `[Char]'
      Expected type: Array (Int, Int) [[NT]]
        Actual type: Array (Int, Int) [NT]
    * In the expression:
        array ((0, 0), (n, n))
          $ [((x, x + i), generators (x, (x + i))) |
               i <- [0 .. n], x <- [0 .. n - i]]
              ++ [((x, y), []) | x <- [0 .. n], y <- [0 .. n], x > y]
      In an equation for `m':
          m = array ((0, 0), (n, n))
                $ [((x, x + i), generators (x, (x + i))) |
                     i <- [0 .. n], x <- [0 .. n - i]]
                    ++ [((x, y), []) | x <- [0 .. n], y <- [0 .. n], x > y]
            where
                generators :: (Int, Int) -> [NT]
                generators (x, y)
                  = if x == y then
                        termGens cfg [...]
                    else
                        nub $ concat $ [ntGens' a b | t <- ..., a <- m ! ..., b <- m ! ...]
                  where
                      ntGens' :: [NT] -> [NT] -> [NT]
                      ntGens' xs ys = concat $ concat $ map (\ x -> ...) xs
      In the expression:
        let
          n = - 1 + length s
          m = array ((0, 0), (n, n))
                $ [... | i <- ..., x <- ...] ++ [... | x <- ..., y <- ..., x > y]
            where
                generators :: (Int, Int) -> [NT]
                ....
        in m
   |
11 |         m = array ((0,0), (n, n)) $
   |             ^^^^^^^^^^^^^^^^^^^^^^^...

CYK.hs:32:8: error:
    * Couldn't match type `[Char]' with `Char'
      Expected type: Array (Int, Int) [NT]
        Actual type: Array (Int, Int) [[NT]]
    * In the expression: m
      In the expression:
        let
          n = - 1 + length s
          m = array ((0, 0), (n, n))
                $ [... | i <- ..., x <- ...] ++ [... | x <- ..., y <- ..., x > y]
            where
                generators :: (Int, Int) -> [NT]
                ....
        in m
      In an equation for cyk':
          cyk' cfg s
            = let
                n = ... + length s
                m = array ... $ ... ++ ...
                  where
                      ...
              in m
   |
32 |     in m
   |        ^
Failed, one module loaded.

CYK.hs

import CFG
import Data.Array -- for Array
import Data.List  -- for nub

type CYKMatrix a = Array (Int, Int) a

cyk' :: CFG -> String -> Array (Int, Int) [NT]
-- ^ creates cyk matrix based on cyk algorithm
cyk' cfg s =
    let n = -1 + length s
        m = array ((0,0), (n, n)) $
          [ ((x, x + i), generators (x, (x + i))) | i <- [0..n],
                                                    x <- [0..n-i] ] ++  -- upper triangular + diagonal
          [ ((x, y), []) | x <- [0..n],
                           y <- [0..n],
                           x > y]                                       -- lower triangular

            where generators :: (Int, Int) -> [NT]
                  -- ^ returns NTs which generate string indexed from x to y
                  generators (x, y) =
                    if x == y then termGens cfg [s!!x]                  -- diagonal only direct rules
                    else nub $ concat $ [ntGens' a b | t <- [0..y - 1],
                                                       a <- m ! (x, x + t),
                                                       b <- m ! (x + t + 1, y)]

                        where ntGens' :: [NT] -> [NT] -> [NT]
                              -- ^ takes two lists of NTs and returns list of NT generating 
                              --   ordered combinations of original lists
                              ntGens' xs ys = concat $ concat $ map
                                  (\x -> map (\y -> ntGens cfg (x, y)) ys) xs

    in m


cyk :: CFG -> String -> Bool
-- ^ CYK algorithm for CFG grammar in CHNF parsing String s
cyk cfg s =
    "S" `elem` (cyk' cfg s) ! (0, (length s) - 1)


main = do
    putStrLn "--- CYK algorithm ---"
    putStrLn "Name of file with CFG in Chomsky Normal Form:"
    file <- getLine
    cfg <- grammarFromFile file
    putStrLn "Insert the string to parse:"
    print $ fmap (cyk cfg) getLine