Emping-0.4: src/Main.hs
{- | Module Main
Emping 0.4 (provisional)
Module Main performs the GUI and I\/O tasks for the reduction of heuristic rules. The input consists of facts
in a comma separated file (.csv) format as produced by the Open Office Calc spreadsheet. The output is in the same
format and can be read by OO Calc.
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. Some rules, which imply a consequent value, may be interdependent, and
the user can save all such implications and equivalences, or just the top level.
The user can set whether the facts will be checked for duplicates, and for ambiguous rules (those with the same
antecedent but a different consequent).
See the white paper \"Deriving Heuristic Rules from Facts\" (January 2007) for more on the foundation and algorithm.
-}
module Main where
import Graphics.UI.Gtk
import Data.IORef
import Data.Array
import Aux
import CSVParse
import Codec
import CSVTable
import Reduce
import Abduce
main :: IO ()
main = do
initGUI
window <- windowNew
set window [windowTitle := "Emping", windowDefaultWidth := 400,
windowDefaultHeight := 100]
vbox1 <- vBoxNew False 0
containerAdd window vbox1
opensrc <- actionNew "OpenSrc" "Open" (Just "Open a source .csv file") (Just stockOpen)
options <- actionNew "OptionMenu" "Options" (Just "Check for duplicates and ambiguities") (Just stockProperties)
selcons <- actionNew "SelCons" "Consequent" (Just "Select the attribute which will be the rule consequent") (Just stockNew)
reduact <- actionNew "ReduAct" "Reduce" (Just "Get the reduced normal form of the rules") (Just stockConvert)
abducem <- actionNew "AbduceMenu" "Abduce" (Just "Get implications of reduced rules") (Just stockSortAscending)
abdutop <- actionNew "AbduTop" "Top" (Just "Get only the top level of all implications") (Just stockGotoTop)
abduall <- actionNew "AbduAll" "All" (Just "Get all implications from the abduction") (Just stockGotoBottom)
filemen <- actionNew "FileMenu" "File" (Just "Open and exit") (Just stockFile)
quitact <- actionNew "QuitAct" "Quit" Nothing (Just stockQuit)
dupcheck <- newIORef True -- workaround for bug in ToggleActionEntry: user changing checkbox has no effect on toggleActionIsActive field
ambcheck <- newIORef True
let duptogg = ToggleActionEntry "DupCheck" "Check Data" (Just stockConvert) Nothing
(Just "Check facts for duplicates") (myTog dupcheck) True
ambtogg = ToggleActionEntry "AmbCheck" "Check Rules" (Just stockInfo) Nothing
(Just "Check rules for ambiguity") (myTog ambcheck) True
actgrp <- actionGroupNew "ActGrp"
actionGroupAddAction actgrp opensrc
actionGroupAddAction actgrp options
actionGroupAddToggleActions actgrp [duptogg, ambtogg]
actionGroupAddAction actgrp selcons
actionGroupAddAction actgrp reduact
actionGroupAddAction actgrp abducem
actionGroupAddAction actgrp abdutop
actionGroupAddAction actgrp abduall
actionGroupAddAction actgrp filemen
actionGroupAddAction actgrp quitact
manager <- uiManagerNew
uiManagerAddUiFromString manager uiDecl
uiManagerInsertActionGroup manager actgrp 0
mbMenubar <- uiManagerGetWidget manager "ui/menubar"
let menubar = case mbMenubar of
Just x -> x
Nothing -> error "Main: Cannot get menubar from String"
boxPackStart vbox1 menubar PackNatural 0
mbToolbar <- uiManagerGetWidget manager "ui/toolbar"
let toolbar = case mbToolbar of
Just x -> x
Nothing -> error "Main: Cannot get toolbar from String"
boxPackStart vbox1 toolbar PackNatural 0
status <- statusbarNew
boxPackStart vbox1 status PackNatural 0
gencontext <- statusbarGetContextId status "General"
filesrc <- fileChooserDialogNew (Just "Source File in CSV") (Just window)
FileChooserActionOpen
[("Cancel", ResponseCancel), ("Open", ResponseAccept)]
filesave <- fileChooserDialogNew (Just "Save .csv File") (Just window)
FileChooserActionSave
[("Cancel", ResponseCancel), ("Save (.csv)", ResponseAccept)]
fileChooserSetDoOverwriteConfirmation filesave True
csvfilt <- fileFilterNew
fileFilterAddPattern csvfilt "*.csv"
fileFilterSetName csvfilt "CSV Source"
fileChooserAddFilter filesrc csvfilt
onActionActivate opensrc $
do mbf1 <- mygetFileName filesrc
case mbf1 of
{ Just fpath1 -> do { -- user has selected a source file
-- start selection of consequent
strl <- getTable fpath1
; let facts = tableCode strl
namearray = tableToArray strl
; singlefacts <- getNoDuplicates dupcheck filesave status gencontext namearray facts
;let choice = map (\ind -> (RadioActionEntry (show ind) (fst (namearray ! ind)) Nothing Nothing Nothing ind)) (indices namearray)
-- dummy because of radioActionGetCurrentValue and RadioActionEntry. Selection of already selected does nothing.
dummy = [RadioActionEntry (show lst) "None" Nothing Nothing Nothing lst] where lst = length (indices namearray)
dumchoice = concat [choice,dummy]
popmstr = "<ui><popup>" ++ (concatMap itstr dumchoice) ++ "</popup></ui>"
itstr x = "<menuitem action=\"" ++ (radioActionName x) ++ "\" />"
myChange ra = do { -- start reduction with selected consequent
cons <- radioActionGetCurrentValue ra
;let consname = (fst (namearray ! cons))
;statusbarPush status gencontext ("The consequent attribute is: " ++ consname)
;let rules = facts2Rules cons singlefacts
;saveAmbiguities ambcheck filesave status gencontext namearray cons rules
;let reductions = reduceAll rules
;onActionActivate reduact $ do { -- start activate reduction
;mbf2 <- mygetFileName filesave
;case mbf2 of
Just fpath2 -> do { -- start save reduction
statusbarPush status gencontext "Starting reduction, this may take a while..."
;writeFile fpath2 (rnf2CSVTb namearray rules reductions)
;statusbarPush status gencontext ("Finished reduction for " ++ consname)
;return ()
} -- end save reduction
Nothing -> return ()
;let abductions = abduceAll rules reductions
(deptreenum, singlenum) = cntEDAbduction abductions
;if deptreenum == 0 then do { statusbarPush status gencontext ("There are no dependencies in reductions for " ++ consname)
;return ()
}
else do { -- start:there are dependencies
;onActionActivate abdutop $ do { -- start activat abdutop
mbf3 <- mygetFileName filesave
;case mbf3 of
Just fpath3 -> writeFile fpath3 (topAbd2CSVTb namearray rules abductions)
Nothing -> return ()
} -- end activate abdutop
;onActionActivate abduall $ do { -- start activat abduall
mbf4 <- mygetFileName filesave
;case mbf4 of
Just fpath4 -> writeFile fpath4 (allAbd2CSVTb namearray rules abductions)
Nothing -> return ()
} -- end activate abduall
;return ()
} -- end: there are dependencies
;statusbarPush status gencontext ( consname ++ ":"
++ " Dependency Trees: "
++ (show deptreenum)
++ ", Unconnected Rules: "
++ (show singlenum))
;return ()
} -- end activate reduction
; return ()
} -- end myChange
;popgrp <- actionGroupNew "Popup Att Select"
-- bug in RadioActionEntry: regardless of the Int, the last is always displayed as initially selected
;actionGroupAddRadioActions popgrp dumchoice ((length dumchoice) -1) myChange
;popman <- uiManagerNew
;uiManagerAddUiFromString popman popmstr
;uiManagerInsertActionGroup popman popgrp 0
;mbpopup <- uiManagerGetWidget popman "/ui/popup"
;let popup = case mbpopup of
Nothing -> error "Main: no popup menu for consequent attribute selection"
Just x -> x
;onActionActivate selcons $ do {
menuPopup (castToMenu popup) Nothing
; return ()
} -- part when user selected a consequent ends here
; return ()
} -- part when user selected a source file ends here
;Nothing -> return ()
} -- end of case for source file opening (user does not accept)
onActionActivate quitact (widgetDestroy window)
onDestroy window mainQuit
widgetShowAll window
mainGUI
uiDecl :: String
uiDecl = "<ui>\
\ <menubar>\
\ <menu action=\"FileMenu\">\
\ <menuitem action=\"QuitAct\" />\
\ <menuitem action=\"OpenSrc\" />\
\ </menu>\
\ <menu action=\"OptionMenu\">\
\ <menuitem action=\"DupCheck\" />\
\ <menuitem action=\"AmbCheck\" />\
\ </menu>\
\ <menu action=\"AbduceMenu\">\
\ <menuitem action=\"AbduTop\" />\
\ <menuitem action=\"AbduAll\" />\
\ </menu>\
\ </menubar>\
\ <toolbar>\
\ <toolitem action=\"OpenSrc\" />\
\ <toolitem action=\"SelCons\" />\
\ <toolitem action=\"ReduAct\" />\
\ <toolitem action=\"AbduTop\" />\
\ </toolbar>\
\ </ui>"
-- | workaround for bug in ToggleActionEntry
myTog :: IORef Bool -> IO ()
myTog chk = do old <- readIORef chk
writeIORef chk (not old)
-- | test for duplicates if the user wants, let the user save a .csv file of duplicates with frequencies, finally remove duplicates from facts
getNoDuplicates :: IORef Bool -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> [[AVp]] -> IO [[AVp]]
getNoDuplicates check fs status context attvarr rawfcts = do
{ duptrue <- readIORef check
; if duptrue then do {
let prt = partDups rawfcts
;if checkNoDups prt then do {
statusbarPush status context "No duplicates found in the facts"
;return () }
else
do { mbf <- mygetFileName fs
;case mbf of
Just fpath -> writeFile fpath (((allDup2CSVTb attvarr) . factsDups) prt)
Nothing -> return ()
;statusbarPush status context "Duplicates have been removed from the fact list"
;return ()
}
;return (factsUniques prt)
}
else
return rawfcts
}
saveAmbiguities :: IORef Bool -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String]) -> Int -> [[Rule]] -> IO ()
saveAmbiguities check fs status context attvarr consatt rules = do {
ambtest <- readIORef check
; if ambtest then do {
let ambs = getAmbiguous rules
; if ambs == [] then do { statusbarPush status context ("No ambiguous rules for " ++ (fst (attvarr ! consatt)))
;return ()
}
else do { mbf <- mygetFileName fs
;case mbf of
Just fpath -> writeFile fpath (allAmb2CSVTb attvarr ambs)
Nothing -> return ()
;statusbarPush status context ( "Ambiguities: " ++ (show (length ambs)) ++ " for " ++ (fst (attvarr ! consatt)))
;return ()
}
}
else return ()
}
mygetFileName :: FileChooserDialog -> IO (Maybe FilePath)
mygetFileName fs = do resp <- dialogRun fs
widgetHide fs
case resp of
ResponseAccept -> fileChooserGetFilename fs
(_) -> return Nothing