Models.hs

module Models where
import ARC/ExampleRules
import Data.List
import ARC/Syntax2
import ARC/FrontEnd

dropList :: [Int]  -> Int -> [Int]
dropList list x = [i  | i <- list, i /= x]
dropM :: M -> Int -> M
dropM m x = M { noun = (noun m), items = (dropList (items m) x) }
dropVb :: Vb -> Int -> Vb
dropVb v x = Vb { verb = (verb v), verb_items = [(i,j) | (i,j) <- verb_items v, i/= x, j/= x]}
dropModel :: Model -> Int -> Model
dropModel m x = Model { universe = (dropList (universe m) x), cnDict = map (\ n -> (dropM n x)) (cnDict m) ,    verbDict = map (\ v -> (dropVb v x))  (verbDict m) }

consecutiveDropList  :: [Int]  -> Int -> [Int]
helpForConsecutiveDrop :: Int -> Int -> Int
helpForConsecutiveDrop k l =   if k < l then k else k -1 
consecutiveDropList list x = [helpForConsecutiveDrop i x  | i <- list, i /= x]
consecutiveDropM m x = M { noun = (noun m), items = (consecutiveDropList (items m) x) }
consecutiveDropVb :: Vb -> Int -> Vb
consecutiveDropVb v x = Vb { verb = (verb v), verb_items = [(helpForConsecutiveDrop i x, helpForConsecutiveDrop j x) | (i,j) <- verb_items v, i/= x, j/= x]}
consecutiveDropModel :: Model -> Int -> Model
consecutiveDropModel m x = Model { universe = (consecutiveDropList (universe m) x), cnDict = map (\ n -> (consecutiveDropM n x)) (cnDict m) ,    verbDict = map (\ v -> (consecutiveDropVb v x))  (verbDict m) }

maybeDrop model x gamma =
     let
         mNew =  consecutiveDropModel model x   --- was dropModel, not consecutiveDropModel
         tvs = map (\ s  -> (semanticsSent s mNew)) gamma
     in 
         if (and tvs) then mNew else model

shorten :: Model -> [Sent] -> Model
shorten model gamma = foldl  (\ m -> (\ x -> maybeDrop m x gamma)) model (universe model)

iterativelyShorten model gamma = if (model == shorten model gamma) then model else (iterativelyShorten (shorten model gamma) gamma)

{--dropALot m gamma = foldl (\acc x -> listU m) (listU m)
--}
data SentencesInModel = SentencesInModel { sentFromModels :: String,  truthvalueOfSent :: [Bool]}
    deriving Show

data M = M { noun  :: CN,  items :: [Int] }
    deriving (Eq, Show) 

data Vb = Vb { verb  :: V,  verb_items :: [(Int,Int)] }
    deriving (Eq,Show)     

type Universe = [Int]
data Model  = Model {universe::Universe, cnDict ::  [M], verbDict :: [Vb]} 
      deriving (Eq,Show)

semanticsTerm :: Term -> Model -> [Int]
semanticsTerm (CNasTerm (PCN Pos cn)) m  =  helper (CNasTerm (PCN Pos cn)) (cnDict m)
semanticsTerm (CNasTerm (PCN Neg cn)) m =    (universe m) \\ semanticsTerm (CNasTerm (PCN Pos cn)) m 
semanticsTerm (TermMaker (PV Pos tv) (TermNP All t)) m  =
    let 
        u = universe m
        tt = semanticsTerm t m
        vv = verbHelper tv (verbDict m)
    in
        [ x | x <- u, and (map (\ y -> implies (y `elem` tt) ((x,y) `elem` vv)) u)] 

semanticsTerm (TermMaker (PV Pos tv) (TermNP Some t)) m  =
    let 
        u = universe m
        tt = semanticsTerm t m
        vv = verbHelper tv (verbDict m)
    in
        [ x | x <- u, or (map (\ y -> (y `elem` tt) && ((x,y) `elem` vv)) u)] 

semanticsTerm (TermMaker (PV Neg tv) (TermNP All t)) m  =
    let 
        u = universe m
        tt = semanticsTerm t m
        vv = verbHelper tv (verbDict m)
    in
        [ x | x <- u, and (map (\ y -> implies (y `elem` tt) (not ((x,y) `elem` vv))   ) u)] 

semanticsTerm (TermMaker (PV Neg tv) (TermNP Some t)) m  =
    let 
        u = universe m
        tt = semanticsTerm t m
        vv = verbHelper tv (verbDict m)
    in
        [ x | x <- u, or (map (\ y ->  (y `elem` tt) && (not ((x,y) `elem` vv))   ) u)] 

helper (CNasTerm (PCN Pos cn))  partialList  
    | null partialList                                  =  []
    | cn == (noun $ head $ partialList)    =  items $ head  partialList
    | otherwise                                         = helper (CNasTerm (PCN Pos cn))  (tail partialList)

implies b c = (not b) ||  c

verbHelper v  vList  
    | null vList                                  =  []
    | v == (verb $ head $ vList)    =  verb_items $ head  vList
    | otherwise                                         = verbHelper v  (tail vList)

semanticsSent :: Sent -> Model -> Bool
semanticsSent (Sent All t1 t2) m  = and ( map (\ x -> x `elem` s2) s1)
     where 
                s1 = semanticsTerm t1 m
                s2 = semanticsTerm t2 m

semanticsSent (Sent Some t1 t2) m  = or (map (\ x -> x `elem` s2) s1)
     where
                s1 = semanticsTerm t1 m
                s2 = semanticsTerm t2 m

semanticsSent (Sent No t1 t2) m =  and ( map (\ x -> not (x `elem` s2)) s1)
     where 
                s1 = semanticsTerm t1 m
                s2 = semanticsTerm t2 m

semanticsSent (Sent Most t1 t2)  m = 
   let   
      s1 = semanticsTerm t1 m
      s2 = semanticsTerm t2 m
      intersection = s1 `intersect` s2
      n = length s1
      k = length intersection
   in
      n < 2 * k  

semanticsSent (Sent Atleast t1 t2)  m = 
   let   
      s1 = semanticsTerm t1 m
      s2 = semanticsTerm t2 m
   in
      s2 <= s1        

semanticsSent (Sent More t1 t2)  m = 
   let   
      s1 = semanticsTerm t1 m
      s2 = semanticsTerm t2 m
   in
      s2 < s1                    

---------   pretty printing of models below

data U = U {name::String, itemsU :: [Int] }
    deriving Show     

transMtoU t  = (U (show(noun t)) (items t))

data Vextra = Vextra { verbextra  :: String,  verb_items_extra :: [(Int,Int)] }
    deriving Show     

transVtoVextra t  = (Vextra (show(verb t)) (verb_items t))

{-
-- 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
  }
-}

-- test data
test =
    [ M Cats     [1,2,3],
     M Dogs    [4,5,6],
     M Skunks [1,3,5,6], 
     M Chordates  [ ]
    ]
    
vTest = [Vb Sees [(1,1),(1,4),(3,4),(2,5)]]    

model1 = Model {universe = [1,2,3,4,5,6], cnDict = test, verbDict = vTest}

{-
-- 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
-}

showModelNounsPlusJustifications m gamma phi = do
  putStrLn ("The universe is the set of numbers in " ++ show(universe m)++".")   
  putStrLn " "
  putStrLn "The nouns are interpreted as follows:"
  putStrLn " "
  showNouns m
  putStrLn " "
  putStrLn "Here is how the assumptions and purported conclusion fare in this model:"
  putStrLn " "
  showSentenceTruthValues m $ gamma++[phi]

showModelNounsVerbsPlusJustifications m gamma phi = do
  putStrLn ("The universe is the set of numbers in " ++ show(universe m)++".")   
  putStrLn " "
  putStrLn "The nouns and verbs are interpreted as follows:"
  putStrLn " "
  showNouns m
  putStrLn " "     
  showVerbs m   
  putStrLn "Here is how the assumptions and purported conclusion fare in this model:"
  putStrLn " "
  showSentenceTruthValues m $ gamma++[phi]

showModelNounsOnly m = do
  putStrLn ("The universe is the set of numbers in " ++ show(universe m)++".")   
  putStrLn " "
  putStrLn "The nouns are interpreted as follows:"
  putStrLn " "
  showNouns m

showModel m = do
  putStrLn ("The universe is the set of numbers in " ++ show(universe m)++".")   
  putStrLn " "
  putStrLn "The nouns are interpreted as follows:"
  putStrLn " "
  showNouns m
  putStrLn "The transitive verbs are interpreted as follows:"
  putStrLn " "     
  showVerbs m     

showNouns m = putStrLn $
  showTable
    [ ColDesc center "Noun"  left  name
    , ColDesc center "Interpretation"  left (intercalate ", " . map show . itemsU)
    ]
    $ map transMtoU (cnDict m)

showVerbs m = putStrLn $
  showTable
    [ ColDesc center "Verb"  left  verbextra
    , ColDesc center "Interpretation"  left (intercalate ", " . map show . verb_items_extra)
    ]
    $ map transVtoVextra (verbDict m)

--- showGeneric below is used in showModelPlus             
showGeneric m nameLabel contentLabel recordList = putStrLn $
  showTable
    [ ColDesc center "Term"  left  nameLabel
    , ColDesc center "Interpretation"  left (intercalate ", " . map show . contentLabel)
    ] recordList        

makeSentenceEntry s m = SentencesInModel (show s)  [semanticsSent s m]

showSentenceTruthValues m gamma = putStrLn $
  showTable
    [ ColDesc center "Sentence"  left  sentFromModels
    , ColDesc center "Truth Value" left (intercalate ", "  . map show .  truthvalueOfSent )
    ] (map (\ x -> makeSentenceEntry x m) (gamma))

showModelPlus mod tList = do
  showModel mod
  putStrLn " "
  putStrLn "Extra information on the relevant terms:"
  putStrLn " "
  let rrrList = map (\ z ->   (U { name = (show z) ,  itemsU =  (semanticsTerm z mod) }) ) tList 
  showGeneric mod name itemsU rrrList

showModelNounsVerbsPlusJustificationsARC :: Model -> [Sent] -> Sent -> [Term] -> IO ()
showModelNounsVerbsPlusJustificationsARC m gamma phi tList = do
  putStrLn ("The universe is the set of numbers in " ++ show(universe m)++".")   
  putStrLn " "
  putStrLn "The nouns and verbs are interpreted as follows:"
  putStrLn " "
  showNouns m
  putStrLn " "     
  showVerbs m   
  putStrLn "Extra information on the relevant terms:"
  putStrLn " "
  let rrrList = map (\ z ->   (U { name = (show z) ,  itemsU =  (semanticsTerm z m) }) ) tList 
  showGeneric m name itemsU rrrList
  putStrLn "Here is how the assumptions and purported conclusion fare in this model:"
  putStrLn " "
  showSentenceTruthValues m (gamma++[phi])

{-
m gamma phi tList
-----------------
show (universe m)
showNouns n:
  showTable
    [ ColDesc center "Noun"  left  name
    , ColDesc center "Interpretation"  left (intercalate ", " . map show . itemsU)
    ]
    $ map transMtoU (cnDict m)
showVerbs m:
  showTable
    [ ColDesc center "Verb"  left  verbextra
    , ColDesc center "Interpretation"  left (intercalate ", " . map show . verb_items_extra)
    ]
    $ map transVtoVextra (verbDict m)
showGeneric m name itemsU (...):
  showTable
    [ ColDesc center "Term"  left  name
    , ColDesc center "Interpretation"  left (intercalate ", " . map show . itemsU)
    ] $ map (\ z -> U { name = show z, itemsU = semanticsTerm z m }) tList
showSentenceTruthValues m $ gamma ++ [phi]:
  showTable
    [ ColDesc center "Sentence"  left  sentFromModels
    , ColDesc center "Truth Value" left (intercalate ", "  . map show .  truthvalueOfSent )
    ]
    $ map (\ x -> makeSentenceEntry x m) $ gamma ++ [phi]
-}