{- | Module Main 
Emping 0.6 (provisional)

Module Main performs the GUI and I\/O tasks for the reduction and abduction of heuristic rules. The input is a table in a comma separated file (.csv) format as produced by the Open Office Calc spreadsheet. The reduction output is in the same format and can be read by OO Calc. Dependencies between reduced rules are shown as a graph in .dot format, which can be viewed with a GraphViz viewer like dotty or gzviewer.

The user can open a .csv file, select an attribute which is to be the consequent, and Emping will find all shortest rules which predict the values of the selected attribute.
For the same attribute, the user can select a value, and Emping will find implications (entailments) between the reduced rules.

For example, in a table containing the name of a disease, and 'yes' and 'no' in its column,  with a list of symptoms and values like 'yes', 'no', or 'absent', 'mild', 'severe', and so on, in the table rows, Emping will find the smallest sets of symptoms that predict that disease, and also those that predict its absence. 
Selecting 'yes' will then produce a graph of all relationships between the groups of symptoms that predict the disease. Selecting 'no' will find the relationships between the syptom sets that disprove that disease.

See the white paper \"Deriving Heuristic Rules from Facts\" (January 2007) for more on the foundation and algorithm. 

Tue 26 May 2009 05:23:44 PM CEST -}

module Main (main) where
import Graphics.UI.Gtk
import Control.Concurrent
import Data.Maybe (fromJust)
import Data.Array
import CsvParse
import Codec
import DefRules
import CsvTable
import Reduce
import Abduce

main :: IO ()
main = do
  initGUI
  timeoutAddFull (yield >> return True) priorityDefaultIdle 50
  window <- windowNew
  set window [windowTitle := "Emping",  windowDefaultWidth := 470,
              windowDefaultHeight := 140]
  vbox1 <- vBoxNew False 0
  containerAdd window vbox1

  file <- actionNew "FileMenu" "File" (Just "Open and exit") (Just stockFile)
  newsrc <- actionNew "NewSrc" "New Table" (Just "Get a new source (.csv) file") (Just stockNew)
  open <- actionNew "OpenSrc" "Open" (Just "Open a source (.csv) file") (Just stockOpen)
  dupchk <- toggleActionNew "DupChck" "Table Check" (Just "Check table for duplicate rows") Nothing
  quit <- actionNew "QuitAct" "Quit" Nothing (Just stockQuit)

  rule <- actionNew "RuleMenu" "Rule" (Just "Construct a rule") (Just stockNew)
  newatt <- actionNew "NewAtt" "New Rules" (Just "Define a new consequent attribute") (Just stockNew)
  cons <- actionNew "SelCons" "Select" (Just "Select the attribute which is to be the consequent") (Just stockProperties)
  ambchk <- toggleActionNew "AmbChck" "Rule Check" (Just "Check whether some rules are ambiguous") Nothing

  rdmenu <- actionNew "RedMenu" "Reduction" (Just "Reduced normal form of all the rules") (Just stockConvert)
  reduce <- actionNew "Reduce" "Reduce All" (Just "Reduce all rules to shortest") (Just stockExecute)

  abmenu <- actionNew "AbduMenu" "Abduction" (Just "Entailments of rules with the same consequent")  (Just stockSortDescending)
  abdsel <- actionNew "SelAbd" "Choose" (Just "Select consequent value for rule abduction") (Just stockProperties)
  abduce <- actionNew "Abduce" "Abduce"  (Just "Show rule entailments for selected consequent") (Just stockZoom100)
  abdgsl <- toggleActionNew "AbdGsl" "Most General" (Just "Checked is most, unchecked is least general") Nothing
  abdmlg <- actionNew "AbdMgn" "M/L General"  (Just "Show most/least general rules for selected consequent") (Just stockGotoBottom) 

  infmenu <- actionNew "InfMenu"  "About"  (Just "Summary Information") Nothing
  about <- actionNew "About"  "About"  (Just "Summary Information") (Just stockAbout)

  actgrp <- actionGroupNew "ActGrp" 
  mapM_ (actionGroupAddAction actgrp) [file,newsrc,open,quit,rule,newatt, cons,rdmenu,reduce,abmenu,abdsel,abduce, abdmlg,infmenu,about]
  mapM_ (flip actionSetSensitive False) [newsrc,cons,newatt,reduce,abdsel,abduce,abdmlg]
  mapM_ (actionGroupAddAction actgrp) [dupchk,ambchk,abdgsl]
  toggleActionSetActive dupchk False 
  toggleActionSetActive ambchk True
  toggleActionSetActive abdgsl True

  manager <- uiManagerNew
  uiManagerAddUiFromString manager uiDecl
  uiManagerInsertActionGroup manager actgrp 0

  mbMenubar <- uiManagerGetWidget manager "ui/menubar"
  boxPackStart vbox1 (fromJust mbMenubar) PackNatural 0

  stbar <- statusbarNew
  boxPackEnd vbox1 stbar PackNatural 0
  stcx <- statusbarGetContextId stbar "General"    

  mbToolbar <- uiManagerGetWidget manager "ui/toolbar"
  boxPackEnd vbox1 (fromJust mbToolbar) PackNatural 0            

  filesrc <- fileChooserDialogNew   (Just "Source File in CSV") (Just window)
                                     FileChooserActionOpen
                                     [("Cancel", ResponseCancel), ("Open", ResponseAccept)]
  csvfilt <- fileFilterNew
  fileFilterAddPattern csvfilt "*.csv"
  fileFilterSetName csvfilt "CSV Source"   
  fileChooserAddFilter filesrc csvfilt

  filesave <- fileChooserDialogNew  (Just "Save File") (Just window)
                                     FileChooserActionSave
                                     [("Cancel", ResponseCancel), ("Save", ResponseAccept)]
  fileChooserSetDoOverwriteConfirmation filesave True

  apop <- windowNewPopup
  set apop [ windowDefaultWidth := 100, windowDefaultHeight := 100, 
             windowTypeHint := WindowTypeHintCombo, windowWindowPosition := WinPosMouse] 
  apbox <- vBoxNew False 0
  containerAdd apop apbox
  asb <- comboBoxNewText
  set asb [comboBoxHasFrame := True]
  boxPackStart apbox asb PackGrow 0

  vpop <- windowNewPopup
  set vpop [ windowDefaultWidth := 100, windowDefaultHeight := 100, 
             windowTypeHint := WindowTypeHintCombo, windowWindowPosition := WinPosMouse] 
  vpbox <- vBoxNew False 0
  containerAdd vpop vpbox
  vsb <- comboBoxNewText
  set vsb [comboBoxHasFrame := True]
  boxPackStart vpbox vsb PackGrow 0

  globNameArray <- newEmptyMVar 
  globTableCode <- newEmptyMVar 
  globRulesPartition <- newEmptyMVar
  globAttIndex <- newEmptyMVar 
  globAllReds <- newEmptyMVar 
  globAbduReds <- newEmptyMVar 
  globAbduOrigs <- newEmptyMVar
  globAbdGraph <- newEmptyMVar 
  globAttLength <- newEmptyMVar
  globValLength <- newEmptyMVar  

  abop <- windowNewPopup
  set abop [windowDefaultWidth := 100, windowDefaultHeight := 100, 
            windowTypeHint := WindowTypeHintNotification]
  abovb <- vBoxNew False 0
  containerAdd abop abovb 
  abclose <- buttonNewFromStock stockClose
  boxPackStart abovb abclose PackNatural 0
  frame <- frameNew
  boxPackStart abovb frame PackNatural 0
  label <- labelNew (Just "\n\n   Emping: version 0.6\n   (c) 2006-2009 Hans van Thiel  \n   Licence: GPL\n   www.muitovar.com\n\n")
  containerAdd frame label
  frameSetShadowType frame ShadowOut
  widgetModifyBg abop StateNormal (Color 0 0 35000)
  widgetModifyFg label StateNormal (Color 65535 65535 65535 )
  image <- imageNewFromFile "./HaskellM.png"
  boxPackStart abovb image PackNatural 0


  onActionActivate newsrc $ do {      -- reset everything
    mapM_ (flip actionSetSensitive False) [open,cons,reduce,abdsel,abduce,abdmlg]
    ;tryTakeMVar globNameArray 
    ;tryTakeMVar globTableCode
    ;tryTakeMVar globRulesPartition 
    ;tryTakeMVar globAttIndex 
    ;tryTakeMVar globAllReds 
    ;tryTakeMVar globAbduReds 
    ;tryTakeMVar globAbduOrigs
    ;tryTakeMVar globAbdGraph
    ;attln1 <- takeMVar globAttLength  -- at reset, there's always a combo initialised
    ;clearCombo asb attln1
    ;mbvalln1 <- tryTakeMVar globValLength
    ;case mbvalln1 of
       Nothing ->  return ()
       Just valln1 ->  clearCombo vsb valln1      
    ;statusbarPush stbar stcx "Open another source file..."
    ;actionSetSensitive open True
  } -- end newsrc

  onActionActivate open $ do  
    mbf1 <- empFileName filesrc
    case mbf1 of
       Nothing -> return () 
       Just fpath1 ->  do 
         { statusbarPush stbar stcx "Reading and parsing .csv table..." 
           ;dp <- get dupchk toggleActionActive
           ;forkIO $ do {                        
             ;tbstr <- getTable fpath1 
             ;let attvarr1 = tableToArray tbstr
                  tbcod1 = tableCode tbstr
             ;if dp then postGUIAsync $ saveDups  filesave stbar stcx attvarr1 tbcod1
                    else return ()
             ;let  als = (fst . unzip) (elems attvarr1)  
             ;postGUIAsync $ mapM_ (comboBoxAppendText asb) als 
             ;putMVar globAttLength (length als)               -- initialize new attribute list
             ;putMVar globNameArray attvarr1                   -- should be empty if reset by action new
             ;putMVar globTableCode (cleanFacts dp tbcod1)     -- only no dupplicates guaranteed if user checked the box! 
             ;postGUIAsync $ actionSetSensitive newsrc True
             ;postGUIAsync $ actionSetSensitive cons True   
             ;postGUIAsync $ statusbarPush stbar stcx ".csv table read and parsed.."  >> return ()  
             } -- end fork  
             ;actionSetSensitive open False
       } -- end Just

  onActionActivate newatt $ do { -- just like newsrc, except for the source table and its name array and the attribute length ??
    mapM_ (flip actionSetSensitive False) [reduce,abdsel,abduce,abdmlg]
    ;tryTakeMVar globRulesPartition 
    ;tryTakeMVar globAttIndex  
    ;tryTakeMVar globAllReds 
    ;tryTakeMVar globAbduReds 
    ;tryTakeMVar globAbduOrigs   
    ;tryTakeMVar globAbdGraph     
    ;mbvalln2 <- tryTakeMVar globValLength
    ;case mbvalln2 of
        Nothing -> return ()
        Just valln2 ->  clearCombo vsb valln2 
    ;comboBoxSetActive asb (-1)
    ;actionSetSensitive cons True
    ;statusbarPush stbar stcx "Define rules with another consequent attribute..." 
    ;return ()
  }

  onActionActivate cons $ do widgetShowAll apop
                          
  onChanged asb $ do { 
    mbasix1 <- comboBoxGetActive asb 
    ;ambp <- get ambchk toggleActionActive 
    ;if ambp then statusbarPush stbar stcx "Building rules and checking for ambiguities..."
             else statusbarPush stbar stcx "Building rules..."
    ;case mbasix1 of 
       Nothing -> return ()
       Just asix1 -> do {
         forkIO $ do {
         ;tbcod2 <- readMVar globTableCode  
         ;attvarr2 <- readMVar globNameArray
         ;let rlspart = factsToPartition asix1 tbcod2
              rsp = partitionToSets rlspart 
         ;if ambp 
             then postGUIAsync $ saveAmbs filesave stbar stcx attvarr2 rlspart
             else postGUIAsync $ (statusbarPush stbar stcx "Not checked for ambiguous rules...") >> return ()             
         ;putMVar globRulesPartition rsp -- write rules 
         ;putMVar globAttIndex asix1  -- write which attribute
         ;postGUIAsync $ actionSetSensitive reduce True
         ;postGUIAsync $ actionSetSensitive newatt True
         }  -- end forkIO
       ;actionSetSensitive cons False
       } -- end Just
      ;widgetHideAll apop
     } -- end onChange

  onActionActivate reduce $ do {
    statusbarPush stbar stcx  "Reducing all rules, this may take a while..."
    ;forkIO $ do { 
       asix2 <- readMVar globAttIndex
       ;attvarr3 <- readMVar globNameArray
       ;let attname = fst (attvarr3 ! asix2)  
       ;allorigs1 <- readMVar globRulesPartition 
       ;let allreds1 = reduceAll allorigs1
       ;mbf1 <- empFileName filesave                     
       ;case mbf1 of  
             Nothing -> postGUIAsync $ statusbarPush stbar stcx  ("Save of reduced rules for " ++ attname ++ " cancelled")  >> return ()
             Just fpath -> do writeFile (fpath ++ ".csv") (redTbShow allreds1 attvarr3)
                              postGUIAsync $ statusbarPush stbar stcx  ("Finished reduction for " ++ attname ) >> return ()
       ;putMVar globAllReds allreds1 
       ;mbvalln3 <- tryTakeMVar globValLength       
       ;case  mbvalln3 of
             Nothing  -> return ()
             Just valln3 -> postGUIAsync $ clearCombo vsb valln3 -- remove any previous value strings
       ;let vls =  snd (attvarr3 ! asix2)   
       ;postGUIAsync $ mapM_ (comboBoxAppendText vsb) vls 
       ;putMVar globValLength (length vls) -- initialize value selection for abduction 
       ;actionSetSensitive abdsel True
       } -- end forkIO 
     ;actionSetSensitive abduce False
     ;actionSetSensitive abdmlg False
     ;actionSetSensitive reduce False
    ;return ()
  } -- end reduce 

  onActionActivate abdsel $ widgetShowAll vpop

  onChanged vsb $ do { 
    mbvsix <- comboBoxGetActive vsb
    ;mbvnam1 <- comboBoxGetActiveText vsb
    ;if mbvsix == Nothing || mbvnam1 == Nothing 
       then return ()
       else  do {
         let vsix = fromJust mbvsix
             vnam1 = fromJust mbvnam1
         ;forkIO $ do {
         ;allreds2 <- readMVar globAllReds -- selection can be called more times
         ;allorigs2 <- readMVar globRulesPartition
         ;let abdr1 = filter (\r -> snd (snd r) == vsix) (concat allreds2) -- all reduced rules for that value
              orig1 =filter (\r -> snd (snd r) == vsix) (concat allorigs2) -- all original rules for that value 
         ;if abdr1 == [] 
            then postGUIAsync $ statusbarPush stbar stcx  ("No rules found, for " ++ vnam1 ++ " ,possibly because of ambiguity") >> return ()
            else do {  
              tryTakeMVar globAbduReds    -- user can select another without doing abduction on the prior one
              ;putMVar globAbduReds abdr1
              ;tryTakeMVar globAbduOrigs
              ;putMVar globAbduOrigs orig1
              ;postGUIAsync $ actionSetSensitive abduce True
            } -- end else
          } -- end forkIO
         ;return ()
        } -- end else
    ;actionSetSensitive abdsel False
    ;widgetHideAll vpop
   } -- end onChanged

  onActionActivate abduce $ do {
    statusbarPush stbar stcx "Searching for rule entailments"
    ;(Just vnam2) <- comboBoxGetActiveText vsb
    ;forkIO $ do {
      abdr2 <- readMVar globAbduReds     
      ;orig2 <- readMVar globAbduOrigs
      ;attvarr4 <- readMVar globNameArray
      ;asix3 <- readMVar globAttIndex
      ;let abg1 = abduceReds abdr2 orig2
           anam = fst (attvarr4 ! asix3 )
      ;tryTakeMVar globAbdGraph
      ;putMVar globAbdGraph abg1
      ;if graphHasImps abg1 == False 
         then postGUIAsync $ statusbarPush stbar stcx ("No entailments in " ++ anam ++ " : " ++ vnam2 ++ " rules") >> return ()
         else do {
           mbf2 <- empFileName filesave                     
           ;case mbf2 of  
              Nothing -> postGUIAsync $ statusbarPush stbar stcx ("Save of entailment results for " ++ anam ++ " : " ++ vnam2 ++ " cancelled") >> return ()
              Just fpath ->  do writeFile (fpath ++ ".dot") (eqivGraphShow abg1 "emping")
                                writeFile (fpath ++ ".csv") (legendGrTbShow abg1 attvarr4)  
                                postGUIAsync $ statusbarPush stbar stcx  ("Saved rule entailments for " ++ anam ++ " : " ++ vnam2 ) >> return ()
                                actionSetSensitive abdsel True
            } -- end else
    } -- end forkIO
   ;actionSetSensitive abduce False
   ;actionSetSensitive abdsel False
   ;actionSetSensitive abdmlg True
  } -- end abduce

  onActionActivate abdmlg $ do {
    mstg <- get abdgsl toggleActionActive
    ;let cs = if mstg then " most " else " least "
    ;statusbarPush stbar stcx ("Getting" ++ cs ++ "general rules")
    ;forkIO $ do {
       attvarr5 <- readMVar globNameArray
       ;abg2 <- readMVar globAbdGraph
       ;let mgg = graphMLGen mstg abg2
       ;mbf3 <- empFileName filesave
       ;case mbf3 of 
             Nothing -> postGUIAsync $ statusbarPush stbar stcx ("Save of" ++ cs ++ "general rules cancelled") >> return ()
             Just fpath ->  do  writeFile (fpath ++ ".csv") (legendGrTbShow mgg attvarr5)  
                                postGUIAsync $ statusbarPush stbar stcx  ("Saved" ++ cs ++ "general rules") >> return ()   
    } -- end fork
   ; return ()
  } -- end activate


  onActionActivate about $ widgetShowAll abop

  onClicked abclose $ widgetHideAll abop

  widgetShowAll window
  onActionActivate quit $ do {
    widgetDestroy window 
    ;widgetDestroy apop 
    ;widgetDestroy vpop
    ;widgetDestroy abop
                              }
  onDestroy window mainQuit
  mainGUI

uiDecl :: String
uiDecl = "<ui>\
\            <menubar>\
\             <menu action=\"FileMenu\">\
\                <menuitem action=\"NewSrc\" />\
\                <menuitem action=\"OpenSrc\" />\
\                <menuitem action=\"DupChck\" />\
\                <menuitem action=\"QuitAct\" />\
\              </menu>\
\             <menu action=\"RuleMenu\">\
\                <menuitem action=\"NewAtt\" />\
\                <menuitem action=\"SelCons\" />\
\                <menuitem action=\"AmbChck\" />\
\             </menu>\
\            <menu action=\"RedMenu\">\
\                <menuitem action=\"Reduce\" />\
\            </menu>\
\            <menu action=\"AbduMenu\">\
\                <menuitem action=\"SelAbd\" />\
\                <menuitem action=\"Abduce\" />\
\                <menuitem action=\"AbdGsl\" />\
\                <menuitem action=\"AbdMgn\" />\
\            </menu>\
\            <menu action=\"InfMenu\">\
\                <menuitem action=\"About\" />\
\            </menu>\
\            </menubar>\
\            <toolbar>\
\              <toolitem action=\"OpenSrc\" />\
\              <toolitem action=\"SelCons\" />\
\              <toolitem action=\"Reduce\" />\
\              <toolitem action=\"SelAbd\" />\
\              <toolitem action=\"Abduce\" />\
\            </toolbar>\
\         </ui>"


-- helper function to get file path
empFileName :: FileChooserDialog ->  IO (Maybe FilePath)
empFileName fs = 
  do resp <- dialogRun fs 
     widgetHide fs                     
     case resp of 
          ResponseAccept -> fileChooserGetFilename fs  
          (_) -> return Nothing

-- let the user save a .csv file of duplicate table rows with counts
saveDups :: FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> [[AVp]] -> IO  ()
saveDups  fs dupstat dupcontext attvarr cfac = do {
  statusbarPush dupstat dupcontext "Checking for duplicates..."
  ;let dups = getDups cfac
  ;if dups == [] 
     then statusbarPush dupstat dupcontext "No duplicate rows found in the table" >> return ()
     else do {mbf <- empFileName fs                      
       ;case mbf of  
          Nothing -> statusbarPush dupstat dupcontext "Save of row duplicates cancelled" >> return ()
          Just fpath -> do 
            { writeFile (fpath ++ ".csv") (dupTbShow  dups attvarr) 
              ;statusbarPush dupstat dupcontext ("Duplicate rows written to " ++ fpath ++ ".csv")
              ;return ()
            } -- end Just                    
      } -- end else
  } -- end saveDups

-- let the user save ambiguous rules in .csv format
saveAmbs :: FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> [[([AVp], AVp)]] -> IO  ()
saveAmbs  fs ambstat ambcontext attvarr rpart = do {
  let allambs = getAmbiguousRules rpart
  ;if allambs == [] 
     then statusbarPush ambstat ambcontext "No ambiguous rules found" >>  return ()
     else do { mbf <- empFileName fs                      
       ;case mbf of  
          Nothing -> statusbarPush ambstat ambcontext "Save of ambiguous rules cancelled" >> return ()
          Just fpath -> do {
            writeFile  (fpath ++ ".csv") (ambigTbShow  allambs attvarr)
            ;statusbarPush ambstat ambcontext ("Ambiguous rules written to " ++ fpath ++ ".csv")
            ;return ()
          } -- end Just                    
       } -- end else
  } -- end saveAmbs

-- helper function to clear combo box
clearCombo :: ComboBoxClass self => self -> Int -> IO ()
clearCombo cb ln = mapM_  (comboBoxRemoveText cb) (reverse [0..(ln-1)])