module Parse2 where

import List (transpose, tails)
infixr 2 |||
infixr 3 &&&

-- List utility functions

zipWithDefault :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithDefault d e f [] ys = zipWith f (repeat d) ys
zipWithDefault d e f xs [] = zipWith f xs (repeat e)
zipWithDefault d e f (x:xs) (y:ys) = f x y : zipWithDefault d e f xs ys

prefixes :: [a] -> [[a]]
prefixes [] = []
prefixes (x:xs) = [x] : map (x:) (prefixes xs)

innerProd :: [Bool] -> [Bool] -> Bool
innerProd as bs = or (zipWith (&&) as bs)

transposeDefault :: a -> [[a]] -> [[a]]
transposeDefault x xss | all null xss = []
transposeDefault d xss = let f []     = (d,[])
                             f (x:xs) = (x,xs)
                             (ys,yss) = unzip (map f xss)
                         in ys : transposeDefault d yss

-- Combinators for parsing pyramids

word :: (Eq a) => a -> [a] -> [[Bool]]
word w str = [map (w==) str]

(|||) :: [[Bool]] -> [[Bool]] -> [[Bool]]
(|||) = zipWithDefault [] [] (zipWithDefault False False (||))

(&&&) :: [[Bool]] -> [[Bool]] -> [[Bool]]
pyramid1 &&& pyramid2 = [] : rows
  where
    trapezoids = prefixes (zipWithDefault [] [] (,) pyramid1 pyramid2)
    rows = map (row . unzip) trapezoids
    row (left,right) = zipWith innerProd
                        (transposeDefault False left)
                        (transposeDefault False (zipWith drop [1..] (reverse right)))

-- The grammar, finally

sentence str = nounPhrase str &&& verbPhrase str
nounPhrase str = word "time" str ||| word "fruit" str ||| word "flies" str ||| determiner str &&& noun str ||| noun str &&& noun str
verbPhrase str = word "flies" str ||| verbPhrase str &&& prepositionPhrase str ||| transitiveVerb str &&& nounPhrase str
determiner str = word "a" str ||| word "an" str
noun str = word "time" str ||| word "fruit" str ||| word "flies" str ||| word "arrow" str ||| word "banana" str ||| noun str &&& noun str
transitiveVerb str = word "time" str ||| word "like" str
preposition str = word "like" str
prepositionPhrase str = preposition str &&& nounPhrase str

-- The grammar, with memoization

parse str = take (length str) sentence
  where
    sentence = nounPhrase &&& verbPhrase
    nounPhrase = word "time" str ||| word "fruit" str ||| word "flies" str ||| determiner &&& noun ||| noun &&& noun
    verbPhrase = word "flies" str ||| verbPhrase &&& prepositionPhrase ||| transitiveVerb &&& nounPhrase
    determiner = word "a" str ||| word "an" str
    noun = word "time" str ||| word "fruit" str ||| word "flies" str ||| word "arrow" str ||| word "banana" str ||| noun &&& noun
    transitiveVerb = word "time" str ||| word "like" str
    preposition = word "like" str
    prepositionPhrase = preposition &&& nounPhrase