Skip to content

Instantly share code, notes, and snippets.

@fnordomat
Last active June 2, 2018 12:15
Show Gist options
  • Save fnordomat/1328b3004d2acd91809ebfdef408c3c2 to your computer and use it in GitHub Desktop.
Save fnordomat/1328b3004d2acd91809ebfdef408c3c2 to your computer and use it in GitHub Desktop.
Something like Cocke-Younger-Kasami in Haskell (no Chomsky Normal Form required). Not well optimized, but appears to work.
module Main where
import Data.Either
import Data.List
import Data.Array.IArray as A
import Control.Arrow (second)
import Control.Monad.Except
-- Partition a number n into exactly l parts of sizes \in \{1..f\}
-- 1st arg: the number to be partitioned
-- 2nd arg: = no. of elts in a partitioning
-- 3rd arg: max size of a single element of a partitioning
posPartitionsL :: (Integral a) => a -> a -> a -> [[a]]
posPartitionsL 0 _ _ = []
posPartitionsL _ 0 _ = [[]]
posPartitionsL n 1 f | f < n = []
posPartitionsL n 1 _ = [[n]]
posPartitionsL n l f =
concat [ map (k:) (posPartitionsL (n-k) (l-1) f) | k <- [1..min n f] ]
listcorrespondences :: Eq a => [[a]] -> [[a]] -> [[a]]
listcorrespondences as bs = zipWith (Data.List.intersect) as bs
-- Epsilon excluded.
data CFG a =
CFG { numnt :: Integer,
rules :: [(Integer, Either [Integer] [a])] }
deriving (Show)
cykparse :: (Eq a) => CFG a -> [a] -> Except [Char] [Integer]
cykparse cfg w = do
c <- cyk cfg w
return $ fst $ (A.!) c (length w, 1)
-- A list of unique nonterminals and a detailed resolution of the ambiguity
type CykStruct = Array (Int, Int) ([Integer], [(Integer, [(Int, Int)])])
cyk :: Eq a => CFG a -> [a] -> Except [Char] CykStruct
cyk _ [] = throwError "CYK called on empty string"
cyk cfg (h:t) =
let
crules = [(x',i) | (i,x) <- rules cfg, isRight x, let x' = fromRight [] x]
n = length (h:t)
arr = A.array ((1,1), (n,n)) entries
entries = [ ((1,i), (suitablents, map (\x -> (x,[])) suitablents))
| i <- [1..n] | c <- (h:t)
, let suitablents = [j | (x',j) <- crules, c`elem`x' ] ]
in
return $ cykparse' cfg arr n 2
fromRight :: b -> Either a b -> b
fromRight _ (Right x) = x
fromRight d (Left _) = d
fromLeft :: a -> Either a b -> a
fromLeft _ (Left x) = x
fromLeft d (Right _) = d
cykparse' :: CFG a -> CykStruct
-> Int -> Int -> CykStruct
cykparse' _ a n j | n < j = a
cykparse' cfg a n j =
let
syntacticRules = [(x',i) | (i,x) <- rules cfg, isLeft x, let x' = fromLeft [] x]
a' = a // [ ((j,i),
(nub $ map fst contents, contents))
| i <- [1..n-j+1]
, let contents = [ (nt, origins)
| (x',nt) <- syntacticRules
, length x' <= j
, partit <- posPartitionsL j (length x') (j-1)
, let origins = map (second (+i)) (zip partit (scanl (+) 0 partit))
, let ntsequence :: [[Integer]] = map (\(k,s') -> fst ((A.!) a (k,s'))) origins
, let intersects :: [[Integer]] = (listcorrespondences (map return x') ntsequence)
, any (const True) intersects && not (any null intersects) ]
]
// [ ((j,i), ([],[])) | i <- [n-j+2..n] ]
in
cykparse' cfg a' n (j+1)
-- Example: Dyck_2 grammar
dyckab :: CFG Char
dyckab = CFG 3 [(0, Left [0,0]), (0, Left [1,2]), (0, Left [1,0,2]), (1, Right "a"), (2, Right "b")]
main :: IO ()
main = do
putStrLn "~ Ready ~"
s <- getLine
let g = dyckab
let result = runExcept (cykparse g s)
case result of
Right x -> putStrLn (show x)
Left y -> putStrLn ("Error: " ++ y)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment