> module Kulitta.Learning.CykParser where
> import Data.List
> import Kulitta.Learning.Parser

CYK Implementation
Donya Quick
Last modified: 22-Jan-2016



type Rule a = (a, [a])

> findProducers :: (Eq a) => [Rule a] -> [a] -> [Rule a]
> findProducers rs str = filter (\(l,r) -> r==str) rs

> cat :: [a] -> [a] -> [[a]]
> cat xs ys = [[x,y] | x<-xs, y<-ys]
 
 
> nextRow :: (Eq a) => [Rule a] -> [[[a]]] -> [[a]]
> nextRow rs rows = 
>     let n = length rows + 1 -- we assume terminal level is not included
>         segs = map (\i -> (i,n-i)) [1..n-1]
>         strs offset (i,j) = cat
>             (rows !! (i-1) !! offset)
>             (rows !! (j-1) !! (offset + i)) 
>         rules offset (i,j) = concatMap (map fst. findProducers rs) 
>                              (strs offset (i,j)) 
>         f offset = nub $ concatMap (rules offset) segs 
>     in  map f [0..length (rows !! 0) - n]


> mkSegs' :: Int -> Int -> [[Int]]
> mkSegs' n m = filter (\s -> sum s == n) $ 
>     makeRange $ take m $ repeat (0,n) where
>     makeRange = foldr (\(l,u) xs -> [(a:b) | a<-[l..u], b<-xs]) [[]]

> mkSegs :: Int -> Int -> [[Int]]
> mkSegs n m = filter (\s -> length s > 1) $ map (filter (>0)) $ mkSegs' n m

mkSegs must be called with:
n = the maximum length of the string in question.
m = the maximum possible number of substrings

n needs to be controlled by both the level (row+1) and
the offset. The formula should be:

n = min (length rows) (length (rows !! 0) - offset)

> toInds :: Int -> [Int] -> [(Int, Int)]
> toInds offset [] = []
> toInds offset (l:ls) = 
>     let row = l - 1
>         col = offset
>     in  if l <= 0 then toInds offset ls 
>         else (row, col) : toInds (offset+l) ls

> toStrs :: [[[a]]] -> [(Int, Int)] -> [[a]]
> toStrs rows [] = [[]]
> toStrs rows ((i,j):cs) = 
>     let strs = toStrs rows cs
>         theCell = if i < length rows && j < length (rows !! i)
>                  then rows !! i !! j
>                  else error ("(toStr) Bad box: ("++show i++", "++show j++")")
>     in  [(x:y) | x<-theCell, y<-strs]

> nextRowM m rs rows = -- m is the # of subdivisions
>     let n = length rows +1 -- the "level"
>         m' = min n m -- the number of substrings (or nonterms)
>         segs = mkSegs n m' -- this is ok
>         offsets = [0..length (rows !! 0) - n] -- all offsets
>         nts o s = concatMap (map fst . findProducers rs) (toStrs rows (toInds o s))
>         f o = concatMap (nts o) segs
>     in  map f offsets

> nextRowM2 m rs rows = -- m is the # of subdivisions
>     let n = length rows +1 -- the "level"
>         m' = min n m -- the number of substrings (or nonterms)
>         segs = mkSegs n m' -- this is ok
>         offsets = [0..length (rows !! 0) - n] -- all offsets
>         nts o s = concatMap (map fst . findProducers rs) (toStrs rows (toInds o s))
>         f o = concatMap (nts o) segs
>     in  map f offsets

> allRowsMS :: (Eq a) => Int -> [Rule a] -> [a] -> [[[a]]]
> allRowsMS m rs str = allRows' rs [fixRow rs $ firstRow' rs str] where
>     allRows' rs rows = if length rows == length (head rows) then rows
>                        else allRows' rs (rows ++ [fixRow rs $ nextRowM m rs rows])

> allRows :: (Eq a) => [Rule a] -> [a] -> [[[a]]]
> allRows rs str = allRows' rs [firstRow rs str] where 
>     allRows' rs rows = if length rows == length (head rows) then rows
>                        else allRows' rs (rows ++ [nextRow rs rows])


> showRows :: (Show a) => [[[a]]] -> String
> showRows rs = 
>     let f line = concatMap g line ++ "\n"
>         g bucket = show bucket ++ "\t"
>     in  concatMap f (reverse rs)

> printRows :: (Show a) => [[[a]]] -> IO ()
> printRows = putStr . showRows

==============

SYNONYM EXTENION

> findSynonyms :: (Eq a) => [Rule a] -> a -> [a]
> findSynonyms rules x = map fst $ filter (\(l,r) -> r==[x]) rules

> findSynRec :: (Eq a) => [Rule a] -> [a] -> [a]
> findSynRec rules syns = 
>     let s = nub (syns ++ concatMap (findSynonyms rules) syns)
>     in  if s == syns then syns else findSynRec rules s


 findSynRec :: (Eq a) => [Rule a] -> a -> [a]
 findSynRec rules x = 
     let s = findSynonyms rules x
         s' = nub (s ++ concatMap (findSynonyms rules) s)
     in  if s == s' then s else nub $ s ++ concatMap (findSynRec rules) s'

> fixSyns :: (Eq a) => [Rule a] -> [a] -> [a]
> fixSyns rules bucket = nub (bucket ++ concatMap (findSynonyms rules) bucket)

> fixRow :: (Eq a) => [Rule a] -> [[a]] -> [[a]]
> fixRow rules row = map (findSynRec rules) row

> allRowsS :: (Eq a) => [Rule a] -> [a] -> [[[a]]]
> allRowsS rs str = allRows' rs [fixRow rs $ firstRow rs str] where
>     allRows' rs rows = if length rows == length (head rows) then rows
>                        else allRows' rs (rows ++ [fixRow rs $ nextRow rs rows])

> firstRowOld rs cs = map (nub . map fst . findProducers rs . \a -> [a]) cs

> firstRow rs cs = map (\c -> [c]) cs

> firstRow' rs [] = []
> firstRow' rs (c:cs) = 
>     let fr0 = nub $ c : (map fst $ findProducers rs [c])
>     in  (if null fr0 then [c] else fr0) : firstRow' rs cs



==============


GENERATING ALL PARSES

 allParses :: [Rule a] -> [[[a]]] -> Int -> Int [[Rule a]]
 allParses rules rows i j = -- i is the row, j is the column
     let f :: a -> [Rule a]
         f x = filter (\(l,r) -> l==x) rules 
     in  undefined

mkSegs :: Int -> Int -> [[Int]]
mkSegs n m = filter (\s -> length s > 1) $ map (filter (>0)) $ mkSegs' n m

mkSegs must be called with:
n = the maximum length of the string in question.
m = the maximum possible number of substrings

Given a rule that we know can be applied, pick the cells it generates.

> getCells :: (Eq a) => [[[a]]] -> Rule a -> Int -> Int -> [[(Int, Int)]]
> getCells rows (lhs, rhs) level offset = 
>     let n = level + 1
>         m = length rhs -- number of syms to genererate
>         segs = mkSegs n m -- get all possible ways to chunk the string
>         inds = map (toInds offset) segs -- :: [[(Int, Int]] turn these into cells
>         -- need to filter the cells now! --
>     in  filter (goodCells rows rhs) inds

> goodCells :: (Eq a) => [[[a]]] -> [a] -> [(Int, Int)] -> Bool
> goodCells rows [] [] = True
> goodCells rows (x:xs) ((i,j):is) = 
>     elem x (rows !! i !! j) && goodCells rows xs is

> appendTo :: (Eq a) => [[[a]]] -> (Int, Int) -> a -> [[[a]]]
> appendTo [] (i,j) x = []
> appendTo xs (i,j) x = 
>     let (preRs, theRow, postRs) = (take i xs, xs !! i, drop (i+1) xs)
>         (preCs, theCell, postCs) = (take j theRow, theRow !! j, drop (j+1) theRow)
>         newCell = nub (x : theCell) -- ensure no duplicates
>     in  preRs ++ (preCs ++ newCell : postCs) : postRs

> appendTo2 :: (Eq a) => [[[a]]] -> (Int, Int) -> [a] -> [[[a]]]
> appendTo2 [] (i,j) x = []
> appendTo2 xs (i,j) x = 
>     let (preRs, theRow, postRs) = (take i xs, xs !! i, drop (i+1) xs)
>         (preCs, theCell, postCs) = (take j theRow, theRow !! j, drop (j+1) theRow)
>         newCell = nub (x ++ theCell) -- ensure no duplicates
>     in  preRs ++ (preCs ++ newCell : postCs) : postRs


The parseDown1 function completes a parse from a particular cell and symbol. We 
assume the symbol is a member of the cell in question.

> doAll = True
 
> parseDown1 :: (Eq a) => [[[a]]] -> [Rule a] -> [[[a]]] -> ((Int, Int), a) -> [[[[a]]]]
> parseDown1 rows rules newRows ((0,j),x) = [appendTo newRows (0,j) x]
> parseDown1 rows rules newRows ((i,j),x) = 
>     let newRows' = appendTo newRows (i,j) x -- put x in the current table
>         pRules = filter (\(l,r) -> l==x && length r > 0) rules -- rules of form A->BC...N
>         sRules = filter (\(l,r) -> l==x && length r == 1) rules -- rules of form A->B
>         f r = getCells rows r i j -- get a rule's target cells (CAN BE >1 LIST!)
>         f2 r@(lhs,rhs) = map (zipWith (\a (b,c) -> ((b,c),a)) rhs) (f r) -- group with coords
>         --pCells type is [[[((Int, Int), a)]]] 
>         pCells = filter (\l -> not $ null l) $ map f2 pRules -- get cells according to pRules 
>         recCall pCell = parseDown1 rows rules newRows' pCell -- recurse on rule expansions
>         pTabs = map (map (map recCall)) pCells -- gives one SET of tables per pCell
>         pTabs' = map (map combineSets) pTabs -- gives one SET of tables per inner pCell list (can be >1)
>         pTabs'' = concat $ concat pTabs' -- flatten lists, the parses are done
>         syns = filter (/=x) $ map (\(l,r) -> head r) $ sRules -- what synonym symbols are there?
>         synResults = concatMap (\a -> parseDown1 rows rules newRows' ((i,j),a)) syns -- recurse on syns
>     in  synResults ++ pTabs''


The parseDown function takes the cyk rows, the grammar's rules, and the start symbol.

> parseDown rows rules s =
>     let n = length $ head rows
>     in  map (map (map reverse)) $ parseDown1 rows rules (emptyRows n) ((n-1,0),s)

 xtrs = [(1,[1,1]), (1,[1,2]), (2,[2,2]), (3, [1]), (1, [1])] :: [Rule Int]
 xstr = [1,1,1,1] :: [Int]
 xp = allRowsMS 2 xtrs xstr
 xtest1 = parseDown xp xtrs 3

> emptyRows n = 
>     if n <= 0 then [] else take n (repeat []) : emptyRows (n-1)

2 x
1 x x
0 x x x
  0 1 2 
  
The combineSets function takes a bunch of table sets, one set per
cell that has been parsed, and finds every combination of them.
  
> combineSets :: (Eq a) => [[[[[a]]]]] -> [[[[a]]]]
> combineSets [] = error "(combineSets) No sets to combine!"
> combineSets [tset] = tset
> combineSets (tset:moreSets) = 
>     let pairs = [(a,b) | a<-tset, b<-combineSets moreSets]
>     in  map (\(a,b) -> combine1 a b) pairs
  

> -- merges N tables
> combineN :: (Eq a) => [[[[a]]]] -> [[[a]]]
> combineN [] = error "(combineN) No tables to combine!"
> combineN [t] = t
> combineN (t:ts) = combine1 t (combineN ts)

> -- merges two tables
> combine1 :: (Eq a) => [[[a]]] -> [[[a]]] -> [[[a]]]
> combine1 tab1 tab2 = 
>     let n = length $ head tab1
>         is = [(i,j) | i<-[0..n-1], j<-[0..n-1], j<=n-i-1]
>         xs = map (\(i,j) -> tab2 !! i !! j) is
>     in  foldUpdate2 tab1 (zip is xs)

> foldUpdate :: (Eq a) => [[[a]]] -> [((Int, Int), a)] -> [[[a]]]
> foldUpdate table [] = table
> foldUpdate table ((c,x):xs) = foldUpdate (appendTo table c x) xs


> foldUpdate2 :: (Eq a) => [[[a]]] -> [((Int, Int), [a])] -> [[[a]]]
> foldUpdate2 table [] = table
> foldUpdate2 table ((c,x):xs) = foldUpdate2 (appendTo2 table c x) xs