FrontEnd.hs

{-# LANGUAGE LambdaCase #-}
module FrontEnd where

import Data.List
import ARC/Syntax2
import ARC/ExampleSentences
import Control.Arrow
import Control.Monad (guard)
import Data.Maybe (listToMaybe,maybeToList)
import Data.Char (toLower)
import Data.List (transpose, intercalate)

type Parser a b = [a] -> [(b,[a])]
type PARSER a b = Parser a (ParseTree a b)

epsilonT :: PARSER a b 
epsilonT = succeed Ep

symbolT :: Eq a => a -> PARSER a b
symbolT s = (\ x -> Leaf x) <$$> symbol s

symbol :: Eq a => a -> Parser a a 
symbol c []                 = []
symbol c (x:xs) | c == x    = [(x,xs)]
                | otherwise = [] 

infixl 6 <:>

(<:>) :: Parser a b -> Parser a [b] -> Parser a [b]
(p <:> q) xs = [ (r:rs,zs) | (r,ys)  <- p xs, 
                             (rs,zs) <- q ys ]

(<|>) :: Parser a b -> Parser a b -> Parser a b 
(p1 <|> p2) xs = p1 xs ++ p2 xs 

(<**>) :: Parser a [b] -> Parser a [b] -> Parser a [b]
(p <**> q) xs = [ (r1 ++ r2,zs) | (r1,ys) <- p xs, 
                                 (r2,zs) <- q ys ]
infixl 7 <$$>

(<$$>) :: (a -> b) -> Parser s a -> Parser s b
(f <$$> p) xs = [ (f x,ys) | (x,ys) <- p xs ]

data ParseTree a b =  Ep | Leaf a | Branch b [ParseTree a b] 
                   deriving Eq
                   
instance (Show a, Show b) => Show (ParseTree a b) where
  show Ep            = "[]"
  show (Leaf t)      = show t
  show (Branch l ts) = "[." ++ show l  ++ " " 
                            ++ show ts ++ "]"                   


succeed :: b -> Parser a b 
succeed r xs = [(r,xs)]

collect :: [Parser a b] -> Parser a [b] 
collect []     = succeed []
collect (p:ps) = p <:> collect ps 

parseAs :: b -> [PARSER a b] -> PARSER a b
parseAs label ps = (\ xs -> Branch label xs) <$$> collect ps

sent, tv, cn, det, t, int, intOrT, neg, np :: PARSER String String
cn   =              symbolT "skunks" 
                 <|> symbolT "mammals"  
                 <|> symbolT "chordates" 
                 <|> symbolT "boys" <|> symbolT "girls" <|> symbolT "animals"
                 
tv = symbolT "see" <|> symbolT "love" <|> symbolT "admire"  <|> symbolT "hate"

det  =        symbolT "every"  
           <|> symbolT "some" 
           <|> symbolT "no" 
           <|> symbolT "all"
           <|> symbolT "most"
           
t = parseAs "Term" [cn] 
           <|>  parseAs "Term" [symbolT "non" ,cn]  
           <|> parseAs "Term" [tv, det, intOrT] 
           <|> parseAs "Term" [tv, det, symbolT "who", intOrT]
           
--pcn = parseAs "PCN" [pol, cn]
neg = symbolT "non"

np   =  parseAs "NP" [det,intOrT]
--pv = parseAs "PV" [pol, tv] 

sent =  parseAs "S" [det,intOrT,intOrT] 


int = parseAs "Int" [cn,symbolT "who",t]

intOrT = int <|> t

move :: ParseTree String String  -> Term
move (Branch "Term" [Leaf "skunks"]) =  (CNasTerm skunks)
move (Branch "Term" [Leaf "mammals"]) =  (CNasTerm mammals)
move (Branch "Term" [Leaf "animals"]) =  (CNasTerm animals)
move (Branch "Term" [Leaf "chordates"]) =  (CNasTerm chordates)
move (Branch "Term" [Leaf "sneetches"]) =  (CNasTerm sneetches)
move (Branch "Term" [(Leaf "non"), (Leaf "skunks")]) =  (CNasTerm non_skunks)
move (Branch "Term" [(Leaf "non"), Leaf "mammals"]) =  (CNasTerm non_mammals)
move (Branch "Term" [(Leaf "non"), Leaf "animals"]) =  (CNasTerm non_animals)
move (Branch "Term" [(Leaf "non"), Leaf "chordates"]) =  (CNasTerm non_chordates)
move (Branch "Term" [(Leaf "non"), Leaf "sneetches"]) =  (CNasTerm non_sneetches)


move (Branch "Term" [(Leaf "see"), (Leaf "all"), (Leaf "who"), subtree])  
     =    (TermMaker sees   (TermNP All  (move subtree)))
move (Branch "Term" [(Leaf "see"), (Leaf "all"),  subtree])  
     =    (TermMaker sees   (TermNP All  (move subtree)))
move (Branch "Term" [(Leaf "love"), (Leaf "all"), (Leaf "who"), subtree])  
     =    (TermMaker loves   (TermNP All  (move subtree)))
move (Branch "Term" [(Leaf "love"), (Leaf "all"),  subtree])  
     =    (TermMaker loves   (TermNP All  (move subtree))) 
move (Branch "Term" [(Leaf "hate"), (Leaf "all"), (Leaf "who"), subtree])  
     =    (TermMaker hates   (TermNP All  (move subtree)))
move (Branch "Term" [(Leaf "hate"), (Leaf "all"),  subtree])  
     =    (TermMaker hates   (TermNP All  (move subtree)))     
move (Leaf "skunks") =  (CNasTerm skunks)
--move (Leaf ["mammals"]) =  (CNasTerm mammals)
--move (Leaf ["animals"]) =  (CNasTerm animals)

moveS :: ParseTree String String  -> Sent
moveS (Branch "S" [(Leaf "all"), ttree, ttree2])  =   (Sent All (move ttree) (move ttree2)) 
    
readMe  = moveS . fst . head . sent . words

sentParses :: String -> [Sent]
sentParses =
  map (moveS . fst)
  . filter (null . snd)
  . sent
  . words

-----USAGE:      moveS $ (fst.head) $ sent $ words "all see all see all skunks love all mammals"
---- ALSO  move $ (fst . head) $ t $ words "see all see all non skunks" 
--- note how 'non'  worls

split2 :: [t] -> [[[t]]]    ---- split2 takes any list $\ell$ and gives the list of all ways to split $\ell$ into two sublists 
    --- whose concatenation is $\ell$ again.
split2 []          = [[[],[]]]
split2 (x:xs)    =   [[ [], x:xs]]  ++  map (\z -> [x:(z!!0),z!!1]) (split2 xs)

split2' :: [t] -> [([t],[t])]
split2' = \case
  xs@(x : xs') -> ([],xs) : map (first (x :)) (split2' xs')

{-
[]     = [([],[])]
split2' (x:xs) =   [[ [], x:xs]]  ++  map (\z -> [x:(z!!0),z!!1]) (split2 xs)
-}

tF :: [String] -> [Term]
tF quoted    -- this parses terms
  | quoted == []                              = []
  | (quoted!! 0 == "who")   =  tF $ drop 1 quoted
  | (quoted!! 0 == "are")   =  tF $ drop 1 quoted
  | (quoted!! 0 == "also")   =  tF $ drop 1 quoted
  |  quoted == ["skunks"]               = [CNasTerm skunks]
  |  quoted == ["mammals"]           = [CNasTerm mammals]
  |  quoted == ["chordates"]               = [CNasTerm chordates]
  |  quoted == ["boys"]                      = [CNasTerm boys]
  |  quoted == ["girls"]                      = [CNasTerm girls]
  |  quoted == ["dogs"]                      = [CNasTerm dogs]
  |  quoted == ["cats"]                      = [CNasTerm cats]
  |  quoted == ["birds"]                      = [CNasTerm birds]
  |  quoted == ["animals"]                      = [CNasTerm animals] 
  |  quoted == ["sneetches"]                      = [CNasTerm sneetches]
  |  quoted == ["non-skunks"]               = [CNasTerm non_skunks]
  |  quoted == ["non-mammals"]           = [CNasTerm non_mammals]
  |  quoted == ["non-chordates"]               = [CNasTerm non_chordates]
  |  quoted == ["non-boys"]                      = [CNasTerm non_boys]
  |  quoted == ["non-girls"]                      = [CNasTerm non_girls]
  |  quoted == ["non-dogs"]                      = [CNasTerm non_dogs]
  |  quoted == ["non-cats"]                      = [CNasTerm non_cats]
  |  quoted == ["non-birds"]                      = [CNasTerm non_birds]
  |  quoted == ["non-animals"]                      = [CNasTerm non_animals]
  |  quoted == ["non-sneetches"]                      = [CNasTerm non_sneetches]  
  |  quoted == ["x"]                      = [CNasTerm x]  
  |  quoted == ["y"]                      = [CNasTerm y]  
  |  quoted == ["z"]                      = [CNasTerm z]  
  |  quoted == ["p"]                      = [CNasTerm p]  
  |  quoted == ["q"]                      = [CNasTerm q]  
  |  quoted == ["non-x"]                      = [CNasTerm non_x]  
  |  quoted == ["non-y"]                      = [CNasTerm non_y]  
  |  quoted == ["non-z"]                      = [CNasTerm non_z]  
  |  quoted == ["non-p"]                      = [CNasTerm non_p]  
  |  quoted == ["non-q"]                      = [CNasTerm non_q]  
  | (quoted!! 0 == "see")   = [(TermMaker sees r) | r <- (npF (drop 1 quoted))]  
  | (quoted!! 0 == "sees")   = [(TermMaker sees r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "admires")   = [(TermMaker admires r) | r <- (npF (drop 1 quoted))]  
    | (quoted!! 0 == "admire")   = [(TermMaker admires r) | r <- (npF (drop 1 quoted))] 
  | (quoted!! 0 == "loves")   = [(TermMaker loves r) | r <- (npF (drop 1 quoted))]
    | (quoted!! 0 == "love")   = [(TermMaker loves r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "helps")   = [(TermMaker helps r) | r <- (npF (drop 1 quoted))]  
  | (quoted!! 0 == "help")   = [(TermMaker helps r) | r <- (npF (drop 1 quoted))]  
  | (quoted!! 0 == "hates")   = [(TermMaker hates r) | r <- (npF (drop 1 quoted))]
    | (quoted!! 0 == "hate")   = [(TermMaker hates r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "doesn't-see")   = [(TermMaker not_sees r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "doesn't-admire")   = [(TermMaker not_admires r) | r <- (npF (drop 1 quoted))]  
  | (quoted!! 0 == "doesn't-love")   = [(TermMaker not_loves r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "doesn't-help")   = [(TermMaker not_helps r) | r <- (npF (drop 1 quoted))]  
  | (quoted!! 0 == "doesn't-hate")   = [(TermMaker not_hates r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "don't-see")   = [(TermMaker not_sees r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "don't-admire")   = [(TermMaker not_admires r) | r <- (npF (drop 1 quoted))]  
  | (quoted!! 0 == "don't-love")   = [(TermMaker not_loves r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "don't-help")   = [(TermMaker not_helps r) | r <- (npF (drop 1 quoted))]  
  | (quoted!! 0 == "don't-hate")   = [(TermMaker not_hates r) | r <- (npF (drop 1 quoted))]
  | (quoted!! 0 == "r")   = [(TermMaker r blurt) | blurt <- (npF (drop 1 quoted))]
  | otherwise = []

{--
intTF quoted 
  |  (quoted !! 0 == ["skunks"])              =  [(IntersectionTerm (PCN Pos Skunks)  x) |  x <- (map tF (drop 1 quoted))]
  |  quoted !! 0 == ["mammals"]           = [CNasTerm mammals]
  |  quoted  !! 0== ["chordates"]               = [CNasTerm chordates]
  |  quoted  !! 0== ["boys"]                      = [CNasTerm boys]
  |  quoted !! 0 == ["girls"]                      = [CNasTerm girls]
  |  quoted !! 0 == ["dogs"]                      = [CNasTerm dogs]
  |  quoted !! 0 == ["cats"]                      = [CNasTerm cats]
  |  quoted !! 0 == ["birds"]                      = [CNasTerm birds]
  |  quoted !! 0 == ["animals"]                      = [CNasTerm animals] 
  |  quoted !! 0 == ["sneetches"]                      = [CNasTerm sneetches]
  | otherwise = []
--}

npF x    --- this parses noun phrases
  | x == []                              = []
  | (x!! 0 == "all")         = [(TermNP All w)    |  w <- tF (drop 1 x)]
  | (x!! 0 == "some")         = [(TermNP Some w)    |  w <- tF (drop 1 x)] 
  | (x!! 0 == "no")         = [(TermNP No w)    |  w <- tF (drop 1 x)]
  | (x!! 0 == "most")         = [(TermNP Most w)    |  w <- tF (drop 1 x)] 
  | otherwise = []  
  
readS  input =    --- this parses sentences
   let
      w = words input
      firstWord = head w
      y = tail w
      sp = split2 y
      tr = [ x | x <- (map (map tF) sp), (x!!0) /= [], (x!!1) /= []]
      a =  head $ head $ head tr
      b = head $ head $ tail $ head tr
      output 
         | firstWord == "all"   =  Sent All a b
         | firstWord == "some"   =  Sent Some a b  
         | firstWord == "most"   =  Sent Most a b
         | firstWord == "atleast"  = Sent Atleast a b
         | firstWord == "more"  = Sent More a b
         | firstWord == "no"   =  Sent No a b
         | firstWord == "All"   =  Sent All a b
         | firstWord == "Some"   =  Sent Some a b  
         | firstWord == "Most"   =  Sent Most a b
         | firstWord == "No"   =  Sent No a b
         | otherwise = None
  in output
   
readSs = map readS

toMaybe :: Foldable t => t a -> Maybe a
toMaybe = foldl (maybe Just (const . Just)) Nothing
{-# INLINE toMaybe #-}

readS' :: String -> Maybe Sent
readS' input = case words input of
  w0:ws -> do
    q <- lookup (toLower <$> w0)
      [ ( "all"     , All     )
      , ( "some"    , Some    )
      , ( "most"    , Most    )
      , ( "atleast" , Atleast )
      , ( "more"    , More    )
      , ( "no"      , No      )
      ]
    (a,b) <- listToMaybe
      $ split2' ws >>= uncurry zip . (tF *** tF)
    return $ Sent q a b
  _ -> Nothing

-- return either the strings which failed to be parsed,
-- or the full set of parsed sentences.
readSs' :: [String] -> Either [String] [Sent]
readSs' = foldr rS $ Right []
  where
  rS :: String -> Either [String] [Sent] -> Either [String] [Sent]
  rS s es = case readS' s of
    Just s' -> case es of
      Left  bad  -> Left bad
      Right good -> Right $ s' : good
    Nothing   -> case es of
      Left  bad  -> Left $ s : bad
      Right good -> Left [s]

-- A few items used in display of models and proofs


-- a type for fill functions
type Filler = Int -> String -> String

-- a type for describing table columns
data ColDesc t = ColDesc { colTitleFill :: Filler
                         , colTitle     :: String
                         , colValueFill :: Filler
                         , colValue     :: t -> String
                         }



-- functions that fill a string (s) to a given width (n) by adding pad
-- character (c) to align left, right, or center
fillLeft c n s = s ++ replicate (n - length s) c
fillRight c n s = replicate (n - length s) c ++ s
fillCenter c n s = replicate l c ++ s ++ replicate r c
    where x = n - length s
          l = x `div` 2
          r = x - l

-- functions that fill with spaces

left = fillLeft ' '
right = fillRight ' '
center = fillCenter ' '
--showTable :: [ColDesc t] -> [t] -> String


showTable cs ts =
    let header = map colTitle cs
        rows = [[colValue c t | c <- cs] | t <- ts]
        widths = [maximum $ map length col | col <- transpose $ header : rows]
        separator = intercalate "-+-" [replicate width '-' | width <- widths]
        fillCols fill cols = intercalate " | " [fill c width col | (c, width, col) <- zip3 cs widths cols]
    in
        unlines $ fillCols colTitleFill header : separator : map (fillCols colValueFill) rows

showTableForProofs cs ts =
    let header = map colTitle cs
        rows = [[colValue c t | c <- cs] | t <- ts]
        widths = [maximum $ map length col | col <- transpose $ header : rows]
        separator = intercalate "  " [replicate width ' ' | width <- widths]
        fillCols fill cols = intercalate "  " [fill c width col | (c, width, col) <- zip3 cs widths cols]
    in
        -- unlines $ fillCols colTitleFill header : separator : map (fillCols colValueFill) rows
        unlines $ fillCols colTitleFill header : map (fillCols colValueFill) rows
{--
showTableForProofs cs ts =
    let header = map colTitle cs
        -- rows = [[colValue c t | c <- cs] | t <- ts]
        -- widths = [maximum $ map length col | col <- transpose $ header : rows]
        -- separator = intercalate "  " [replicate width ' ' | width <- widths]
        -- fillCols fill cols = intercalate "  " [fill c width col | (c, width, col) <- zip3 cs widths cols]
    in
        tableWithLegend
	    (("first", "second"), "third")
	    [((linum, prop), just)
	     | linum <- [1 .. (length header)]
	     , prop <- cs
	     , just <- ts] :: Table [(Int, String, String)]
--}