Added exception handling + improved response quality of chatbot

Author: jugrajb

.stack-work/install/x86_64-osx/e84c8ad8d8bb3370e9a352676bb26703752eda667e2ea564117ad883c9cd9779/8.6.5/bin/chatbot-exe

@@ -1,35 +1,46 @@
+    -- CODE REFERENCE: http://vishnumenon.com/2012/06/07/naive-bayes-classifier-in-haskell/
+    -- Source for the code listed below
+    
     module BayesClassifier where
     -- Text Classifier Using Bayes Formula
     import Data.List
     import Data.Char
     type Category = String
     newtype Classifier = Classifier { training :: [(Category, [String])] } deriving (Eq, Show)
+
     -- Get a new classifer with no training
     classifier :: Classifier
     classifier = Classifier []
+
     -- classifier probabilities
     probabilityOfWordInCategory :: Classifier -> String -> Category -> Double
-    probabilityOfCategory :: Classifier -> Category -> Double
     -- Adding + 1 for Laplacian Correction
     probabilityOfWordInCategory (Classifier training) word category = let allInCategory = filter (\(cat, _) -> cat == category) training
                                                                           allInCategoryContainingWord = filter (\(_, text) -> word `elem` text) allInCategory
                                                                       in (fromIntegral $ length allInCategoryContainingWord + 1) / (fromIntegral $ length allInCategory + 1)
+
+    probabilityOfCategory :: Classifier -> Category -> Double
     probabilityOfCategory (Classifier training) category =  let allInCategory = filter (\(cat, _) -> cat == category) training 
                                                             in (fromIntegral $ length allInCategory) / (fromIntegral $ length training)
+
     -- Train a classifier
     train :: Classifier -> String -> Category -> Classifier 
     train (Classifier training ) text category = Classifier $ (category, cleanInput $ text):training
+
     -- Categorize text with a classifier
     classify :: Classifier -> String -> Category
     classify classifier text = fst $ head $ sortBy (\(_, a) (_, b)  -> b `compare` a) $ probabilities classifier text
+
     -- Get Probability for each Category
     probabilities :: Classifier ->  String -> [(Category, Double)] 
     probabilities classifier@(Classifier training) text =  map (\cat -> (cat, probabilityForCategory classifier text cat)) $ nub $ map (\(cat, _) -> cat) training
+
     -- Get Probability for a passage in a certain category
     probabilityForCategory :: Classifier -> String -> Category -> Double
     probabilityForCategory classifier text category = (+) (log $ probabilityOfCategory classifier category)  (sum $ map (\word -> log $ probabilityOfWordInCategory classifier word category) $ cleanInput text) 
+
     -- Lowercase, Remove Punctuation
     cleanInput :: String -> [String]
     cleanInput text = filter (\w -> not (w `elem` stopWords)) $ words $ filter (`elem` ' ':['a'..'z']) $ map toLower text 
-                      where stopWords = ["a","about","above","after","again","against","all","am","an","and","any","are","aren't","as","at","be","because","been","before","being","below","between","both","but","by","can't","cannot","could","couldn't","did","didn't","do","does","doesn't","doing","don't","down","during","each","few","for","from","further","had","hadn't","has","hasn't","have","haven't","having","he","he'd","he'll","he's","her","here","here's","hers","herself","him","himself","his","how","how's","i","i'd","i'll","i'm","i've","if","in","into","is","isn't","it","it's","its","itself","let's","me","more","most","mustn't","my","myself","no","nor","not","of","off","on","once","only","or","other","ought","our","ours ","ourselves","out","over","own","same","shan't","she","she'd","she'll","she's","should","shouldn't","so","some","such","than","that","that's","the","their","theirs","them","themselves","then","there","there's","these","they","they'd","they'll","they're","they've","this","those","through","to","too","under","until","up","very","was","wasn't","we","we'd","we'll","we're","we've","were","weren't","what","what's","when","when's","where","where's","which","while","who","who's","whom","why","why's","with","won't","would","wouldn't","you","you'd","you'll","you're","you've","your","yours","yourself","yourselves"]
+                      where stopWords = [",","'","a","about","above","after","again","against","all","am","an","and","any","are","aren't","as","at","be","because","been","before","being","below","between","both","but","by","can't","cant","cannot","could","couldn't","did","didn't","do","does","doesn't","doing","don't","down","during","each","few","for","from","further","had","hadn't","has","hasn't","have","haven't","having","he","he'd","he'll","he's","her","here","here's","hers","herself","him","himself","his","how","how's","i","i'd","i'll","i'm","i've","if","in","into","is","isn't","it","it's","its","itself","let's","me","more","most","mustn't","my","myself","no","nor","not","of","off","on","once","only","or","other","ought","our","ours ","ourselves","out","over","own","same","shan't","she","she'd","she'll","she's","should","shouldn't","so","some","such","than","that","that's","the","their","theirs","them","themselves","then","there","there's","these","they","they'd","they'll","they're","they've","this","those","through","to","too","under","until","up","very","was","wasn't","we","we'd","we'll","we're","we've","were","weren't","what","what's","when","when's","where","where's","which","while","who","who's","whom","why","why's","with","won't","would","wouldn't","you","you'd","you'll","you're","you've","your","yours","yourself","yourselves"]
 

project/app/BayesClassifier.hs

@@ -3,6 +3,7 @@ module ChatClassifier where
 
 import System.IO
 import BayesClassifier
+import Data.List (intersect)
 
 splitsep :: (a -> Bool) -> [a] -> [[a]]
 splitsep s = foldr (\e (h:t) -> if s e then []:(h:t) else (e:h):t) [[]] 
@@ -15,6 +16,9 @@ readCsv filename = do
 writeCsv :: FilePath -> [Char] -> [Char] -> IO ()
 writeCsv filename c q = appendFile filename ("\n" ++ c ++ "," ++ q)
 
+writeCsvR :: FilePath -> [Char] -> [Char] -> IO ()
+writeCsvR filename c q = appendFile filename ("\n" ++ q ++ "," ++ c)
+
 fetchAnswer :: FilePath -> Category -> IO String
 fetchAnswer filename c = do
     file <- readFile filename
@@ -32,4 +36,6 @@ trainedClassifier fp = do
     let trained_classifier = foldl trainline classifier trainingData
     return trained_classifier
 
-        
+-- from https://stackoverflow.com/questions/27471710/checking-if-2-list-have-any-equal-element-haskell
+compareList :: (Eq a) => [a] -> [a] -> Bool
+compareList a = not . null . intersect a

project/app/ChatClassifier.hs

@@ -1,3 +1,5 @@
+-- CODE REFERENCE: https://wiki.haskell.org/Implement_a_chat_server
+
 module Main where
 
   import Network.Socket
@@ -10,6 +12,7 @@ module Main where
   import ChatClassifier
   import BayesClassifier
 
+  -- intialize socket and create channel for reading responses
   main :: IO ()
   main = do
     sock <- socket AF_INET Stream 0
@@ -24,56 +27,108 @@ module Main where
 
   type Msg = (Int, String)
 
+  -- create a thread to read the responses
   mainLoop :: Socket -> Chan Msg -> Int -> IO ()
   mainLoop sock chan msgNum = do
     conn <- accept sock
     forkIO (runConn conn chan msgNum)
     mainLoop sock chan $! msgNum + 1
 
+  -- run thread and listen for any response
   runConn :: (Socket, SockAddr) -> Chan Msg -> Int -> IO ()
   runConn (sock, _) chan msgNum = do
       let broadcast msg = writeChan chan (msgNum, msg)
       hdl <- socketToHandle sock ReadWriteMode
       curdDir <- getCurrentDirectory
-      chat_classifier <- trainedClassifier (curdDir ++ "/project/src/questions.csv")
+      
       hSetBuffering hdl NoBuffering
 
+      -- All code below is written by our group
+      hPutStrLn hdl "Would you like to enable training mode (y/n)?"
+      training <- fmap init (hGetLine hdl)
+
       -- Initial Message
       hPutStrLn hdl "Chatbot: Hello, what did you need assistance with?"
 
       -- Message Loop
       handle (\(SomeException _) -> return ()) $ fix $ \loop -> do
+          -- fetch question from command line
           question <- fmap init (hGetLine hdl)
           case question of
                -- If an exception is caught, send a message and break the loop
                "quit" -> hPutStrLn hdl "Chatbot: Goodbye!"
                -- else, continue looping.
                _ -> do
+                  -- reload the classifier with updated training data
+                  chat_classifier <- trainedClassifier (curdDir ++ "/project/src/questions.csv")
                   hPutStrLn hdl ("User: " ++ question)
 
-                  -- get answer
-                  let category = classify chat_classifier question
-                  hPutStrLn hdl ("Category: " ++ category)
-
-                  let prob = probabilityForCategory chat_classifier question category
-                  -- hPutStrLn hdl ("Prob: " ++ (show prob))
+                  -- clean input by removing connectives and fetch categories
+                  let cleanq = cleanInput question 
+                  cats <- readCsv (curdDir ++ "/project/src/categories.csv")      
 
-                  let ansDir = (curdDir ++ "/project/src/answers.csv")
-                  str <- fetchAnswer ansDir (dropWhile (==' ') category)
+                  -- check if question contains a reference to a category
+                  let incat = compareList (cats !! 0) cleanq
 
-                  hPutStrLn hdl ("Prob: " ++ show prob)
-                  hPutStrLn hdl ("Chatbot: " ++ str)
-
-                  hPutStrLn hdl "Chatbot: To help us improve, was this answer helpful? (y/n)"
-                  answer <- fmap init (hGetLine hdl)
-                  if answer == "y"
+                  -- if it does not contain a reference we can not give a valid answer so return and reloop]
+                  -- otherwise get appropriate response
+                  if (not incat)
                     then do
-                      --- if answer is good, add question with category to questions.csv
-                      write <- writeCsv (curdDir ++ "/project/src/questions.csv") (dropWhile (==' ') category) question
-                      hPutStrLn hdl "Chatbot: If you need anymore help feel free to ask another question, otherwise type 'quit' to exit"
-                    else
-                      -- nothing
-                      hPutStrLn hdl "Chatbot: Sorry, please ask the question again for a more relevant answer"
+                      hPutStrLn hdl "Sorry, I can't answer that please make sure your question is part of acceptable categories"
+                      hPutStrLn hdl (show (cats !! 0))
+                    else do
+                      -- DEBUG CODE: REMOVE BEFORE DEMO
+                      --let probs = foldr (\h acc -> ((classify chat_classifier question),(probabilityForCategory chat_classifier question (classify chat_classifier question))):acc) [] cleanq
+                      --hPutStrLn hdl (show probs)
+
+                      -- get category, prob of valid answer
+                      let category = classify chat_classifier question
+                      let prob = probabilityForCategory chat_classifier question category
+                      let ansDir = (curdDir ++ "/project/src/answers.csv")
 
+                      -- if prob of answer is above a threshold return a response
+                      -- otherwise return fail message for no valid response found with training data
+                      if prob > -5.0
+                        then do
+                          -- fetch answer
+                          str <- fetchAnswer ansDir (dropWhile (==' ') category)
+                          hPutStrLn hdl ("Chatbot: " ++ str)
+                        
+                          -- check if answer was good to improve training data
+                          hPutStrLn hdl "Chatbot: To help us improve, was this answer helpful? (y/n)"
+                          answer <- fmap init (hGetLine hdl)
+                        
+                          if answer == "y"
+                            then do
+                              --- if answer is good, add question with category to questions.csv to improve future responses
+                              write <- writeCsvR (curdDir ++ "/project/src/questions.csv") (dropWhile (==' ') category) question
+                              hPutStrLn hdl "Chatbot: If you need anymore help feel free to ask another question, otherwise type 'quit' to exit"
+                            else
+                              -- nothing
+                              hPutStrLn hdl "Chatbot: Sorry, please ask the question again for a more relevant answer"
+                        else do
+                          -- if training mode is enabled we can directly add new categories/questions/answers
+                          if training == "y" 
+                            then do
+                              hPutStrLn hdl "Add to existing category (y/n)?"
+                              existing <- fmap init (hGetLine hdl)
+                              if existing == "y"
+                                then do
+                                  hPutStrLn hdl "Training Enabled please enter a Category"
+                                  cat <- fmap init (hGetLine hdl)
+                                  write <- writeCsvR (curdDir ++ "/project/src/questions.csv") cat question
+                                  hPutStrLn hdl "Question added under category, you may ask another question"
+                                else do
+                                  hPutStrLn hdl "Training Enabled please enter a answer"
+                                  ans <- fmap init (hGetLine hdl)
+                                  hPutStrLn hdl "Training Enabled please enter a Category"
+                                  cat <- fmap init (hGetLine hdl)
+                                  hPutStrLn hdl ("Category: " ++ cat)
+                                  write <- writeCsvR (curdDir ++ "/project/src/questions.csv") cat question
+                                  write <- writeCsv (curdDir ++ "/project/src/answers.csv") cat ans
+                                  hPutStrLn hdl "Question answer pair added, you may ask another question"
+                            else 
+                              hPutStrLn hdl "No relevant answer found, you may ask another question"
+                  -- finally reloop to continue waiting for respones from the socket
                   loop
       hClose hdl                             -- close the handle

project/app/Main.hs

@@ -1,5 +1,5 @@
 login,Try logging in again
-password,Please reenter your password
+password,Please re-enter your password
 email,Please make sure your entering your email correctly
-leaving_flight,9:30pm
-flight_number,22
+leaving flight,9:30pm
+flight number,22

project/src/answers.csv

@@ -0,0 +1 @@
+login,password,email,flight

project/src/categories.csv

@@ -1,10 +1,30 @@
-I can't login, login
-login, login
-my login dosen't work, login
-I completely forgot what password i used to login was, login
-I forgot my password, password
-Whats my password, password
-My email doesn't work, email
-When is my flight, leaving_flight
-What is my flight number, flight_number
-password,My password
+login,login
+cant login,login
+how do i login to my account,login
+password,password
+password,password
+I cant login to my password,login
+I forgot my password,password
+I forgot my password,password
+I cant login,login
+How do I enter the login,login
+how do I password my login account,login
+How do i access my password,password
+flight number,flight number
+flight number,flight number
+how to find my flight number,flight number
+what is my flight number,flight number
+flight time,leaving flight
+leaving flight,leaving flight
+what time is my flight leaving,leaving flight
+when does my flight leave,leaving flight
+when does my flight leave,leaving flight
+something leave,leaving flight
+how do i login,login
+how do i login,login
+when do i enter the flight to leave,leaving flight
+What time is my flight,leaving flight
+login,login
+can i login,login
+how do i login,login
+sorry when does my flight leave,leaving flight