content: Extended Inside-Outside Algorithm Implementation
  Donya Quick
  donyavq@netscape.net
  Last modified: 22-Jan-2016
  
  This module is an implementation of the inside-outside algorithm using 
  the notations described in the following document by Michael Collins:
  http://www.cs.columbia.edu/~mcollins/io.pdf
  
  The learnProbs function will take a set of starting conditions, 
  iteratively learn production probabilities, and return them. The 
  qNew function will calculate a new production probability for a 
  single rule.
  
  The implementation here also contains several EXTENSIONS to the original
  inside-outside algorithm, although it will perform normally given a 
  CFG in Chomsky normal form. 
  
  Modifications to original algorithm:
  1. Supports rules of rank 1, A->B where A=/=B in alpha, beta, and mu
  2. Supports rules of rank 3, A->BCD
  3. Supports rrules of the form A->A in mu function (heuristic)
  4. Supports abstract rules via an oracle to answer certain things about 
     the grammar.
  
  The first two extensions follow directly from the equations for alpha 
  and beta in the standard inside-outside algorithm. Extensions 2 will cause
  a larger worst-case runtime if rules of the form A->BCD are present in the 
  grammar, being O(n^4) instead of O(n^3) for the CKY/CYK parsing step. 
  
  Extension 3 is a HEURISTIC to allow the presence of self-productions in 
  the rule set. It makes the assumption that self-productions can happen but
  are unlikely. In fact, it is not possible to know exactly how self-
  productions should be handled without knowing the details of the generative
  algorithm that produced the data set.
  
  Extension 4 means that rules can have any form you want as long as you 
  can define a function to find suitable left-hand sides given a candidate
  right-hand side. The rules still need to be context-free in the sense that
  you cannot account for things like AB->ACD this way. However, you can learn
  parameterized grammars over infinite alphabets and rules with conditional
  behavior using this approach. This is further described in my forthcoming
  doctoral thesis.
  
  The ORACLE in extension four is accounted for by the data structure TOracle.
  A TOracle allows the algorithm to interact with a rule set without knowing 
  its exact structure. It requires four things:
  
  1. A list of production probabilities. It is assumed that they are ordered
     by "rule ID" or "rule index." In other words, rule 0 will have probability 
     phis !! 0.
  
  2. The start symbol.
  
  3. A list of "rule IDs" or "rule indices" grouped by matching left-hand sides.
     So, if we had the rules A->AA, A->B, and B->C listed in that order, then 
     the grouping would be [[0,1],[2]].
     
  4. The main part of the oracle: a function to reverse rule production. If the
     rule set has the rules A->AA, A->B, and B->C, the function findByRHS should
     return the INSTANCE (TRuleInst 0 A [A,A]) when given [A,A] as input. For 
     parameterized grammars, the rule instance must have the particular parameters
     that were involved in the production. 
     
  NOTE: This implementation is parallelized! To compile a program using the
  learnProbs function in parallel, use:
  
  ghc -O2 Main.lhs -rtsopts -threaded
  
  and then run the program by:
  
  Main [arguments] +RTS -Nx
  
  where x is the number of threads you want. For example, if you have 2 cores, 
  you will want to use -N2. If you have a quad core i7 with hyperthreading, 
  you will get the best performance using -N8.
  
  > module Kulitta.Learning.InsideOutside (RuleIndex, TStr, TCell, TParse, 
  >                TRuleInst(TRuleInst), rule, lhs, rhs,
  >                TOracle(TOracle), phis, startSym, ruleGroups, findByRHS,
  >                makeAlphas, makeBetas, learnProbs, qNew,
  >                uniQs, randQs, printTable) where
  > import Data.List
  > import Kulitta.Learning.CykParser -- for mkSegs' function
  > import System.Random -- for random initialization of production probs
  > import Control.Parallel.Strategies 
  
  ================================
  CONSTANTS
  
  > parCounts = True -- set to True to perform inner parallelization
  
  
  ================================
  TYPE DEFINITIONS
  
  > type RuleIndex = Int -- index into a list of rules
  > type TStr a = [a] -- a string of parameterized symbols
  
  > -- A rule "instance." There can be many instances per abstract rule.
  > data TRuleInst a = TRuleInst { 
  >    rule :: RuleIndex, -- index to which this instance belongs
  >    lhs :: a, -- the left-hand side
  >    rhs :: TStr a} -- the right-hand side
  >    deriving(Eq, Show)
  
  > type TCell a = [TRuleInst a] -- one cell in a parse table
  > type TParse a = [[TCell a]] -- a full parse
  > type Row = Int -- row of a parse table. Row 0 is assumed to be "terminal"-level.
  > type Col = Int -- col of a parse table
  > type Coord = (Row, Col) -- a particular point in a table, corresponding to one cell.
  
  > -- A learning "environment:" acts as an oracle to describe the grammar
  > data TOracle a = TOracle {
  >     phis :: [Double], -- production probabilities sorted by rule index
  >     startSym :: a, -- start symbol
  >     ruleGroups :: [[RuleIndex]], -- which rule indexes have the same left-hand side?
  >     findByRHS :: [a] -> [TRuleInst a]} -- which rules have a particular right-hand side?
  
  > type Alpha a = ((a, Int, Int), Double) -- a single alpha value tagged with its symbol and span
  > type Beta a = ((a, Int, Int), Double) -- a single beta value tagged with its symbol and span
  
  Controlled product function that stops when a zero is encountered to 
  avoid evaluating unnecessary terms. The prod function will terminate on
  on infinite list if it contains a zero, whereas product will not.
  
  > prod :: (Num a, Eq a) => [a] -> a
  > prod [] = error "(prod) Nothing to multiply."
  > prod [x] = x
  > prod (x:xs) = if x==0 then 0 else x * prod xs
  
  Conversions in an out of row/column vs. span representation to 
  determine what span a cell in a parse table has and visa versa.
  
  > toRC, toIJ :: (Int,Int) -> (Int, Int)
  > toRC (i, j) = (j-i, i)
  > toIJ (row,col) = (col,col+row)
  
  For backward compatibility:
  
  > getParse :: (Eq a) => TOracle a -> TStr a -> TParse a
  > getParse = buildTable 
  
  > idRule :: (Eq a) => TRuleInst a -> Bool
  > idRule (TRuleInst id lhs [rhs]) = rhs==lhs
  > idRule _ = False
  
  ===========
  ALPHA CALC
  
  Symbol enumeration function. Symbols are ordered for most efficient
  computation of alpha values.
  
  > symEnum :: (Eq a) => TOracle a -> TStr a -> [(a, Int, Int)]
  > symEnum env xs = 
  >     let p = getParse env xs -- get the parse of the string
  >         n = length xs
  >         f (r,c) =  map (toAIJ (r,c)) $ p !! r !! c -- synonyms are originally stacked higher to left
  >         rcs = [(r,c) | r<-[0..n-1], c<-[0..n-1], r+c<n]
  >     in  concatMap f rcs where
  >     toAIJ :: Coord -> TRuleInst a -> (a, Int, Int)
  >     toAIJ coord t = 
  >         let (i,j) = toIJ coord
  >         in  (lhs t, i, j)
  
  Function for initial generation of alpha values. Values that are 
  calculated are then stored in a list for use in recursive calls.
  
  > makeAlphas :: (Eq a) => TOracle a -> TStr a -> [Alpha a]
  > makeAlphas env xs = 
  >     let syms = symEnum env xs -- (symEnum env) xs 
  >     in filter ((>0).snd) $ makeRec env [] xs syms where
  >     makeRec env as xs [] = as
  >     makeRec env as xs (v@(a,i,j):vs) = 
  >        let aNew = alpha env as xs a i j 
  >        in  makeRec env ((v,aNew):as) xs vs
  
  Helper function to determine what a symbol can produce.
  
  > traceDown :: (Eq a) => TOracle a -> TStr a -> a -> Int -> Int -> [TRuleInst a]
  > traceDown env xs a i j = 
  >     let p = getParse env xs
  >         (row,col) = toRC (i, j)
  >     in  filter (\r -> lhs r == a) $ p !! row !! col
  
  Generating a single alpha value.
  
  > alpha :: (Eq a) => TOracle a -> [Alpha a] -> TStr a -> a -> Int -> Int -> Double
  > alpha env as xs a i j = case (lookup (a,i,j) as) of 
  >     Just v -> v
  >     Nothing -> 
  >         let rInsts = filter (not.idRule) $ -- cases of A->A are not allowed (but A->B is ok)
  >                      traceDown env xs a i j -- get possible children of A as rule instances
  >             subAs = sum $ map (alphaRec env as xs i j) rInsts
  >         in  if i==j && a == (xs !! i) then 1.0 -- check for found terminal
  >             else if null rInsts then 0.0 -- check for dead end on wrong terminal
  >             else subAs where -- recursive case
  
  > alphaRec :: (Eq a) => TOracle a -> [Alpha a] -> TStr a -> Int -> Int -> TRuleInst a -> Double
  > alphaRec env as xs i j (TRuleInst id lhs [rhs]) = 
  >     prod [phis env !! id, alpha env as xs rhs i j]
  > alphaRec env as xs i j (TRuleInst id lhs [s1, s2]) = 
  >     let ks = [i..j-1]
  >         f k = prod [alpha env as xs s1 i k, alpha env as xs s2 (k+1) j]
  >     in  if i == j then 0.0 -- dead end, no way to split 
  >         else prod [phis env !! id, sum $ map f ks] -- phi multiplication moved here for efficiency
  > alphaRec env as xs i j (TRuleInst id lhs [s1, s2, s3]) = 
  >     let ks = [(k,l) | k<-[i..j-2], l<-[i+1..j-1], k<l]
  >         f (k,l) = prod [alpha env as xs s1 i k, alpha env as xs s2 (k+1) l, alpha env as xs s3 (l+1) j]
  >     in  if j - i < 2 then 0.0 -- dead end, no way to split 
  >         else prod [phis env !! id, sum $ map f ks]
  > alphaRec env as xs i j tr = error 
  >     ("(alphaRec) Unable to handle rule of rank "++show (length $ rhs tr))
  
  
  Function to lookup a value after they've been calculated. Only values >0 are stored 
  to avoid storing lots of garbage values.
  
  > alpha' :: (Eq a) => [Alpha a] -> a -> Int -> Int -> Double
  > alpha' as a i j = case (lookup (a,i,j) as) of
  >     Just v -> v
  >     Nothing -> 0.0
  
  ===========
  BETA CALC
  
  Function for initial generation of beta values.  Values that are 
  calculated are then stored in a list for use in recursive calls.
  
  > makeBetas :: (Eq a) => TOracle a -> [Alpha a] -> TStr a -> [Beta a]
  > makeBetas env as xs = 
  >     let syms = reverse $ symEnum env xs -- reverse of alpha's order
  >     in  filter ((>0).snd) $ makeRec' env [] as xs syms where
  >     makeRec' env bs as xs [] = bs
  >     makeRec' env bs as xs (v@(a,i,j):vs) = 
  >        let bNew = beta env bs as xs a i j 
  >        in  makeRec' env ((v,bNew):bs) as xs vs
  
  Helper function to determine what rule instances could have produced a 
  particular symbol.
  
  > traceUp :: (Eq a) => TOracle a -> TStr a -> a -> Int -> Int -> [TRuleInst a]
  > traceUp env xs a i j = 
  >     let p = getParse env xs
  >         n = length xs
  >         otherSpans = [toRC (i, j) | i<-[0..i], j<-[j..n-1]]
  >         cands = concatMap (\(r',c') -> p !! r' !! c') otherSpans
  >     in  nub $ filter (\ru -> elem a (rhs ru)) $ cands
  
  Calculate a single beta value.
  
  > beta :: (Eq a) => TOracle a -> [Beta a] -> [Alpha a] -> TStr a -> a -> Int -> Int -> Double
  > beta env bs as xs a i j = case (lookup (a,i,j) bs) of 
  >     Just v -> v
  >     Nothing -> if alpha' as a i j <= 0 then 0.0 else -- added for optimization purposes
  >         let rInsts = filter (not.idRule) $ -- cases of A->A are not allowed (but A->B is ok)
  >                      traceUp env xs a i j -- get possible parents of A as rule instances
  >             subBs = sum $ map (betaRec env bs as xs a i j) rInsts
  >         in  if i==0 && j==(length xs - 1) && a == startSym env then 1.0 -- check for found terminal
  >             else if null rInsts then 0.0 -- check for dead end on wrong terminal
  >             else subBs where -- recursive case            
  
  Recursive beta calculation.
  
  > betaRec :: (Eq a) => TOracle a -> [Beta a] -> [Alpha a] -> TStr a -> 
  >            a -> Int -> Int -> TRuleInst a -> Double
  > betaRec env bs as xs a i j (TRuleInst id lhs [rhs]) = 
  >     prod [phis env !! id, beta env bs as xs lhs i j] -- travel up to a synonym
  > betaRec env bs as xs a i j (TRuleInst id lhs [s1, s2]) = -- a is s1, s2, or both 
  >     let ks1 = [j+1..length xs-1] -- for B -> AC
  >         ks2 = [0..i-1] -- for B -> CA
  >         f1 k = prod [beta env bs as xs lhs i k, alpha' as s2 (j+1) k] -- for B -> AC
  >         f2 k = prod [beta env bs as xs lhs k j, alpha' as s1 k (i-1)] -- for B -> CA
  >         parts = sum $ map snd $filter (fst) $ zip [a==s1, a==s2] 
  >                 [sum $ map f1 ks1, sum $ map f2 ks2]
  >     in  prod [phis env !! id, parts]
  > betaRec env bs as xs a i j (TRuleInst id lhs [s1, s2, s3]) = 
  >     let ks1 = [(k,l) | k<-[j+1..length xs-2], 
  >                l<-[j+2..length xs-1], k<l] -- for B -> ACD
  >         f1 (k,l) = prod [beta env bs as xs lhs i l, alpha' as s2 (j+1) k, 
  >                          alpha' as s3 (k+1) l] -- for B -> ACD
  >         ks2 = [(k,l) | k<-[0..i-1], l<-[j+1..length xs-1]] -- for B -> CAD
  >         f2 (k,l) = prod [beta env bs as xs lhs k l, alpha' as s1 k (i-1), 
  >                          alpha' as s3 (j+1) l] -- for B -> CAD
  >         ks3 = [(k,l) | k<-[0..i-2], l<-[1..i-1], k<l] -- for B -> CDA
  >         f3 (k,l) = prod [beta env bs as xs lhs k j, alpha' as s1 k (l-1), 
  >                          alpha' as s2 l (i-1)] -- for B -> CDA
  >         parts = sum $ map snd $filter (fst) $ zip [a==s1, a==s2, a==s3] 
  >                 [sum $ map f1 ks1, sum $ map f2 ks2, sum $ map f3 ks3]
  >     in  prod [phis env !! id, parts]
  > betaRec env bs as xs a i j tr = error 
  >     ("(betaec) Unable to handle rule of rank "++show (length $ rhs tr))
  
  Function for lookup of calculated beta values. Only non-zero values are stored.
  
  > beta' :: (Eq a) => [Beta a] -> a -> Int -> Int -> Double
  > beta' bs a i j = case (lookup (a,i,j) bs) of
  >     Just v -> v
  >     Nothing -> 0.0
  
  
  ===========
  MU CALC
  
  Calculate mu for a particular rule with a particular span.
  NOTE: mu allows for ONE instance of A->A in the parse tree. This is a heuristic
  to account for the presence of such rules but avoids over-abundance (otherwise 
  they could occur infinitely often).
  
  > mu :: (Eq a) => TOracle a -> [Alpha a] -> [Beta a] -> TStr a -> 
  >                       TRuleInst a -> [Int] -> Double
  > mu env as bs xs (TRuleInst id a [b]) [i,j] = prod[phis env !! id, beta' bs a i j, alpha' as b i j]
  > mu env as bs xs (TRuleInst id a [b,c]) [i,k,j] = 
  >     prod[phis env !! id, beta' bs a i j, alpha' as b i k, alpha' as c (k+1) j]
  > mu env as bs xs (TRuleInst id a [b,c,d]) [i,k,l,j] = 
  >     prod[phis env !! id, beta' bs a i j, alpha' as b i k, alpha' as c (k+1) l, alpha' as d (l+1) j]
  > mu env as bs xs _ _ = error "(mu) Bad TRuleInst or index list."
  
  Calculate z, the probability of the entire tree for normalization.
  
  > z :: (Eq a) => TOracle a -> [Alpha a] -> TStr a -> Double
  > z env as xs = alpha' as (startSym env) 0 (length xs - 1)
  
  
  ===========
  NEW Q CALC
  
  Count algorithm implementation that uses the parse tree for efficiency.
  
  > count env as bs xs rID = 
  >     let p = getParse env xs 
  >         n = length xs
  >         f (i,j) = map (\r -> (r,i,j)) $ p !! i !! j -- get all rules out of a cell
  >         coords = [(i,j) | i<-[0..n-1], j<-[0..n-1], i+j<n]  -- find cells with the right span
  >         -- find only rules with the right ID (and span)
  >         insts = map toIJs $ filter (\(r,i,j) -> rule r == rID) $ concatMap f coords 
  >         result = sum (map (countB env as bs xs) insts) / denom
  >         denom = z env as xs
  >     in  if denom<=0 then error "(count) z value of <=0" else result where
  >     toIJs (r, row,col) = (r, col, col+row)
  
  > countB :: (Eq a) => TOracle a -> [Alpha a] -> [Beta a] -> TStr a -> (TRuleInst a, Int, Int) -> Double
  > countB env as bs xs (r@(TRuleInst id a [b]), i, j) = sum $ map (mu env as bs xs r) [[i,j]]
  > countB env as bs xs (r@(TRuleInst id a [b,c]), i, j) = sum $ 
  >     map (mu env as bs xs r) [[i,k,j] | k<-[i..j-1]]
  > countB env as bs xs (r@(TRuleInst id a [b,c,d]), i, j) = sum $ 
  >     map (mu env as bs xs r) [[i,k,l,j] | k<-[i..j-2], l<-[i+1..j-1], k<l, l<j]
  > countB env as bs xs _ = error "(countB) Bad TRuleInst or mismatched index list."
  
  Sum counts over all strings in the data set. If usePar==True, then
  the parallelized version is used.
  
  > f usePar env triples rID = 
  >     let exprs = map (\(xs,as,bs) -> count env as bs xs rID) triples
  >     in  if usePar then sum $ seq (triples) (exprs `using` parList rdeepseq)
  >         else sum $ exprs
  
  Find the normalization factor for a given rule.
  
  > qNorm :: (Eq a) => TOracle a -> [(TStr a, [Alpha a], [Beta a])] -> RuleIndex -> Double
  > qNorm env triples rID = sum $ map (f parCounts env triples) $ 
  >                         findGroup (ruleGroups env) rID where
  >     findGroup [] rID = error ("(qNorm) Uknown rule: "++show rID)
  >     findGroup (g:gs) rID = if elem rID g then g else findGroup gs rID
  
  Re-estimate the probability of a rule. It is possible that a rule will not occurr 
  anywhere in the data set, and that can cause a zero denominator that would give 
  NaN as a result instead of 0.0, hence the check on the denominator below. 
  
  > qNew :: (Eq a) => TOracle a -> [(TStr a, [Alpha a], [Beta a])] -> RuleIndex -> Double
  > qNew env triples rID = 
  >     let denom = qNorm env triples rID -- if this is zero then the rule hasn't occurred
  >         result = f parCounts env triples rID / denom
  >     in  if denom <= 0 then 0.0 else result 
  
  Iteratively compute the production probabilities over a data set given a 
  maximum number of iterations to run, aminimum probability (in case a rule 
  doesn't appear) and a threshold of change between two iterations' 
  distributions under which to stop.
  
  NOTE: this version does NOT check for cycles, such as a rule set that has
  both A->B and B->A. Rule sets with cycles will spin infinitely.
  
  > learnProbs :: (Eq a, Show a) => TOracle a -> [TStr a] -> Int -> Double -> Double -> IO [[Double]]
  > learnProbs env strs i minP dThresh = if i<=0 then return [] else do
  >     let as = map (makeAlphas env) strs
  >         bs = zipWith (\a s -> makeBetas env a s) as strs
  >         xab = zip3 strs as bs
  >     putStrLn "Calculating production probs..."
  >     let qs0 = phis env -- starting probabilities
  >         qs1s = map (qNew env xab) [0..length qs0 - 1] -- new probabilities
  >         qs1 = seq (as, bs, env) (qs1s `using` parList rdeepseq) -- parallelize computation of qs1
  >         qf' =  if minP > 0.0 then normalize2 (ruleGroups env) minP qs1 -- adjust minimum probs
  >                else normalize (ruleGroups env) qs1
  >         env' = env{phis = qf'} -- environment for the next iteration (updated probs)
  >         diff = totalDiff qs0 qf' -- total change in probability mass
  >     putStrLn ("Total probability mass changed: "++show diff)
  >     putStrLn $ concat $ intersperse ", " $ map show qf' 
  >     let badInds = findIndices (\x -> x<=0) qs1 -- are there any rules with prob <= 0?
  >         badStr = if null badInds then "ok" -- all are ok
  >                  else "Zero-prob rules: "++show badInds -- some rules are prob <=0
  >         (iNext, skipping) = if diff <= dThresh then (0, True) -- check for convergence
  >                             else (i-1, False) 
  >         itrStr = if skipping then ("Q has converged with "++show (i-1)++" iterations left.")
  >                  else ("Iterations left: "++show (i-1))
  >     putStrLn itrStr
  >     qNext <- learnProbs env' strs iNext minP dThresh -- compute next iteration
  >     return (qf' : qNext) -- return all iterations' probability distributions
  
  
  Helper function to correct probabilities that are too small. It performs
  normalization at the same time.
  
  > normalize2 :: [[Int]] -> Double -> [Double] -> [Double]
  > normalize2 gs minP qs = 
  >     let gqs = map (map (qs !!)) gs -- collect probabilities by rule group
  >         gqs' = map (fixMins minP) gqs -- correct for non-zero values
  >         gqsi = zip (concat gs) (concat gqs') -- flatten the list
  >     in  map snd $ sort gqsi -- place the list back in its original order
   
  > fixMins minP xs = 
  >     let isOk = findIndices (>=minP) xs 
  >         isZ = findIndices (<minP) xs 
  >         okVals = map (xs !!) isOk -- collect all of the values that are ok
  >         newSum = sum okVals + (fromIntegral (length isZ) * minP) -- adjust the normalization factor
  >     in  map (\x -> if x<=0 then minP else x/newSum) xs -- normalize everything
  
  Produce uniform initial probabilities.
  
  > uniQs :: [[RuleIndex]] -> [Double]
  > uniQs gs = normalize gs $ take (length $ concat gs) $ repeat 1.0
  
  Produce random initial probabilities.
  
  > randQs :: [[RuleIndex]] -> StdGen -> [Double]
  > randQs gs g = normalize gs $ take (length $ concat gs) $ vals g where
  >     vals g = let (d,g') = randomR (0.0, 1.0) g in d : vals g'
  
  Normalization function for production probabilities.
  
  > normalize :: [[RuleIndex]] -> [Double] -> [Double]
  > normalize gs qs = concatMap (\g -> map (/sum g) g) $ map (map (qs !!)) gs
  
  Compute the total difference in two distributions of production probabilities.
  The result is the total change in probability mass (NOT a percentage). 
  
  > totalDiff :: [Double] -> [Double] -> Double
  > totalDiff d1 d2 = sum $ map abs $ zipWith subtract d1 d2 
  
  
  ============================
  
  PARAM-BASED PARSING
  
  The following is an implementation of standard CKY/CYK parsing
  with extensions to allow rules of the form A->BCD, A->B, and 
  self productions of the form A->A. It uses the same oracle approach
  as the code above to parse using rule instances rather than the
  rule set itself.
  
  The updateTable function will take a partially filled parse table and 
  update the particular cell in question with any rules that will fit.
  
  > blankTable :: Int -> TParse a
  > blankTable i = if i<=0 then [] else 
  >     take i (repeat []) : blankTable (i-1)
  
  The startTable function builds an initial table. The rest is blank.
  
  > startTable :: TStr a -> TParse a 
  > startTable xs = 
  >     let row0 = map (\x -> [TRuleInst (-1) x []]) xs
  >     in   row0 : blankTable (length xs - 1)
  
  Given an environment and a string, buid a parse table.
  
  > buildTable :: (Eq a) => TOracle a -> TStr a -> TParse a
  > buildTable env xs = 
  >     let st = startTable xs
  >         n = length xs
  >         rowCols = [(r,c) | r<-[0..n-1], c<-[0..n-1], c<=n-(r+1)]
  >     in  foldl' (\pt rc -> updateTable' env pt xs rc) st rowCols
  
  Iteratively update the table. Individual cells must be checked at least
  twice each to ensure that all synonyms get added.
  
  > updateTable' env pTable xs (row,col) = 
  >     let pTable' = updateTable env pTable xs (row,col)
  >     in  if pTable == pTable' then pTable else updateTable' env pTable' xs (row, col)
  
  > updateTable :: (Eq a) => TOracle a -> TParse a -> TStr a -> Coord -> TParse a
  > updateTable env pTable xs (row,col) = 
  >     let cellPats = getCellCombos (row,col) 3 :: [[Coord]]
  >         cellStrs = concatMap (toStr pTable) cellPats -- :: [TStr a]
  >         newRules = concatMap (findByRHS env) cellStrs -- :: [TRuleInst a]
  >     in  updateCell pTable (row,col) newRules 
  
  Function to update an individual cell in a table with a new value.
  
  > updateCell :: (Eq a) => TParse a -> (Int, Col) -> [TRuleInst a] -> TParse a
  > updateCell pTable (row,col) v = 
  >     let preRows = take row pTable
  >         postRows = drop (row+1) pTable
  >         preCols = take col (pTable !! row)
  >         postCols = drop (col+1) (pTable !! row)
  >         newVal = nub (v ++ (pTable !! row !! col)) -- concat vals onto existing cell
  >     in  preRows ++ [preCols ++ [newVal] ++ postCols] ++ postRows
  
  
  Given a starting cell and a maximum number of segments to which it can 
  belong (this will be the rank of the grammar), return a series of other
  coordinates to investigate. The starting cell is presumed to be the 
  "generator" of the other segments.
  
  > getCellCombos :: Coord -> Int -> [[Coord]]
  > getCellCombos (row,col) maxSegs = if maxSegs <=0 then [] else
  >     let symCount = row+1 -- total number of symbols
  >         maxSegs' = min symCount maxSegs -- maximum number of segments
  >         segs = mkSegs' symCount maxSegs' -- symbol divisions 
  >     in  nub $ map (toInds col) segs
  
  Turn a series of coordinates into a string of symbols. For grammars with a 
  terminal/nonterminal division, this will be a potentially mixed string of 
  terminals and nonterminals.
  
  > toStr :: TParse a -> [Coord] -> [TStr a]
  > toStr pTable coords = 
  >     let f (r,c) = if r < length pTable && c < length (pTable !! r) 
  >                   then pTable !! r !! c else error ("(toStr) Bad coord: "++show (r,c))
  >         cells = allCombos $ map f coords
  >     in  map (map lhs) cells
  
  Given a set of collections of items (e:es), find all combinations 
  with one item from each collection in sequence.
  
  > allCombos :: [[a]] -> [[a]]
  > allCombos [] = [[]]
  > allCombos (e:es) = [(e':es') | e'<-e, es'<-allCombos es]
  
  Display functions for the parts of a parse table. When printing the
  parse table, although rules are stored in each cell, only the lefthand
  side of each rule will be printed to correspond to the more standard 
  CKY/CYK representation.
  
  > showCell :: (Show a) => TCell a -> String
  > showCell trs = show $ map lhs trs
  
  > showRow :: (Show a) => [TCell a] -> String
  > showRow trs = concat (intersperse "  " $ map showCell trs)
  
  > showTable :: (Show a) => TParse a -> String
  > showTable rs = concat $ intersperse "\n" $ map showRow rs
  
  > printTable ::(Show a) => TParse a -> IO()
  > printTable = putStrLn . showTable
  