Emping-0.5: src/Main.hs
{- | Module Main
Emping 0.5 (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 rule output is in the same
format and can be read by OO Calc. Dependencies between reduced rules may be 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.
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). Graph may be displayed as entailments (top down) or implications (the reversed graph).
See the white paper \"Deriving Heuristic Rules from Facts\" (January 2007) for more on the foundation and algorithm.
Wed 16 Apr 2008 01:14:12 PM CEST
-}
module Main (main) where
import Graphics.UI.Gtk
import Control.Concurrent
import Data.IORef
import Data.Array
import Data.Graph.Inductive
import Aux
import CSVParse
import Codec
import CSVTable
import Reduce
import Abduce
main :: IO ()
main = do
initGUI
timeoutAddFull (yield >> return True) priorityDefaultIdle 50
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)
abdutop <- actionNew "AbduTop" "Top" (Just "Get only the top level of all implications") (Just stockGotoTop)
filemen <- actionNew "FileMenu" "File" (Just "Open and exit") (Just stockFile)
quitact <- actionNew "QuitAct" "Quit" Nothing (Just stockQuit)
grphmen <- actionNew "GrphMen" "Rule Graphs" (Just "Display rule graphs or legend") (Just stockGotoBottom)
attgrph <- actionNew "AttGrph" "Attribute" (Just "Get the graph of implications for the attribute") (Just stockZoom100)
valgrph <- actionNew "ValGrph" "Per Value" (Just "Get the graph of implications for an attribute value") (Just stockZoomIn)
glegend <- actionNew "GleGend" "Legend" (Just "Legend of all nodes in the implication graph") (Just stockUnderline)
duptogg <- toggleActionNew "DupCheck" "Check Data" (Just "Check facts for duplicates") Nothing
ambtogg <- toggleActionNew "AmbCheck" "Check Rules" (Just "Check rules for ambiguity") Nothing
revtogg <- toggleActionNew "RevGraph" "Reverse" (Just "Get the graphs in reverse direction") Nothing
toggleActionSetActive duptogg True
toggleActionSetActive ambtogg True
actgrp <- actionGroupNew "ActGrp"
mapM_ (actionGroupAddAction actgrp) [opensrc,options,selcons,reduact,abdutop,filemen,quitact,grphmen,attgrph,valgrph,glegend]
mapM_ (actionGroupAddAction actgrp) [duptogg,ambtogg,revtogg]
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 File") (Just window)
FileChooserActionSave
[("Cancel", ResponseCancel), ("Save", ResponseAccept)]
fileChooserSetDoOverwriteConfirmation filesave True
csvfilt <- fileFilterNew
fileFilterAddPattern csvfilt "*.csv"
fileFilterSetName csvfilt "CSV Source"
fileChooserAddFilter filesrc csvfilt
attpopman <- uiManagerNew
attpopgrp <- actionGroupNew "Popup Att Select"
valpopman <- uiManagerNew
valpopgr <- actionGroupNew "Popup Value Select"
mapM_ ((flip actionSetSensitive) False) [selcons, reduact,abdutop,attgrph,valgrph,glegend]
mvrNameArray <- newEmptyMVar
mvrSingleFacts <- newEmptyMVar
mvrSelCons <- newEmptyMVar
mvrRules <- newEmptyMVar
mvrReductions <- newEmptyMVar
mvrNodeGroup <- newEmptyMVar
mvrValPopup <- newEmptyMVar
hasValPopup <- newIORef False
onActionActivate opensrc $ do
mbf1 <- mygetFileName filesrc
case mbf1 of
Nothing -> return ()
Just fpath1 -> do { statusbarPush status gencontext "Reading and parsing source..."
;forkIO $ do {
;strl <- getTable fpath1
;let stfacts = tableCode strl
stnamearray = tableToArray strl
;stsinglefacts <- getNoDuplicates duptogg filesave status gencontext stnamearray stfacts
;putMVar mvrNameArray stnamearray
;putMVar mvrSingleFacts stsinglefacts
;actionSetSensitive selcons True
}
;actionSetSensitive opensrc False
}
onActionActivate selcons $ do {
slnamearray <- readMVar mvrNameArray
;singlefacts <- readMVar mvrSingleFacts
;let choice = map (\ind -> (RadioActionEntry (show ind) (fst (slnamearray ! ind)) Nothing Nothing Nothing ind)) (indices slnamearray)
-- 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 slnamearray)
dumchoice = concat [choice,dummy]
popmstr = "<ui><popup>" ++ (concatMap itstr dumchoice) ++ "</popup></ui>"
itstr x = "<menuitem action=\"" ++ (radioActionName x) ++ "\" />"
myChange ra = do { cons <- radioActionGetCurrentValue ra
;let consname = (fst (slnamearray ! cons))
;statusbarPush status gencontext ("The consequent attribute is: " ++ consname)
;let rules = facts2Rules cons singlefacts
;noamb <- noAmbiguities ambtogg filesave status gencontext slnamearray cons rules
;if noamb then do { putMVar mvrSelCons cons
;putMVar mvrRules rules
;actionSetSensitive selcons False
;actionSetSensitive reduact True
}
else return ()
}
;uiManagerInsertActionGroup attpopman attpopgrp 0
;actionGroupAddRadioActions attpopgrp dumchoice ((length dumchoice) -1) myChange
;uiManagerAddUiFromString attpopman popmstr
;mbpopup <- uiManagerGetWidget attpopman "/ui/popup"
;let attpopup = case mbpopup of
Nothing -> error "Main: no popup menu for consequent attribute selection"
Just x -> x
;menuPopup (castToMenu attpopup) Nothing
;return ()
}
onActionActivate reduact $ do
mbf2 <- mygetFileName filesave
case mbf2 of
Nothing -> return ()
Just fpath2 -> do { statusbarPush status gencontext "Reducing rules, this may take a while..."
;forkIO $ do {
rdnamearray <- readMVar mvrNameArray
;rdrules <- readMVar mvrRules
;rdcons <- readMVar mvrSelCons
;let rdconsname = (fst (rdnamearray ! rdcons))
reductions = reduceAll rdrules
;writeFile fpath2 (rnf2CSVTb rdnamearray rdrules reductions)
;statusbarPush status gencontext ("Finished reduction for " ++ rdconsname)
;putMVar mvrReductions reductions
;actionSetSensitive abdutop True
;actionSetSensitive glegend True
}
;actionSetSensitive reduact False
}
onActionActivate abdutop $ do
mbf3 <- mygetFileName filesave
case mbf3 of
Nothing -> return ()
Just fpath3 -> do { statusbarPush status gencontext "Checking for rule dependencies.."
;forkIO $ do {
abnamearray <- readMVar mvrNameArray
;abrules <- readMVar mvrRules
;abcons <- readMVar mvrSelCons
;abreductions <- readMVar mvrReductions
;let abconsname = (fst (abnamearray ! abcons))
topsgroup = abduceTopAll abrules abreductions
;if not (hasDependencies topsgroup abreductions) then do
{ statusbarPush status gencontext ("There are no dependencies in reductions for " ++ abconsname)
;actionSetSensitive abdutop False
}
else do {
writeFile fpath3 (allTops2CSVTb abnamearray abrules topsgroup)
;statusbarPush status gencontext ("Saved most general reductions for " ++ abconsname)
;return ()
}
}
;actionSetSensitive abdutop False
}
onActionActivate glegend $ do
mbf4 <- mygetFileName filesave
;case mbf4 of
Nothing -> return ()
Just fpath4 -> do { forkIO $ do {
glnamearray <- readMVar mvrNameArray
;glcons <- readMVar mvrSelCons
;glrules <- readMVar mvrRules
;glreductions <- readMVar mvrReductions
;let glconsname = (fst (glnamearray ! glcons))
nodegroup = orgReg2Ndg glrules glreductions
;statusbarPush status gencontext "Getting graph legend, this may take a while..."
;let graphlegend = nodeLegend glreductions nodegroup
;writeFile fpath4 (allNodes2CSVTb glnamearray glrules graphlegend)
;statusbarPush status gencontext ("Saved graph legend for " ++ glconsname)
;putMVar mvrNodeGroup nodegroup
}
;actionSetSensitive attgrph True
;actionSetSensitive valgrph True
;actionSetSensitive glegend False
}
onActionActivate attgrph $ do
mbf5 <- mygetFileName filesave
case mbf5 of
Nothing -> return ()
Just fpath5 -> do { statusbarPush status gencontext "Building rule dependency graph..."
;forkIO $ do {
agnamearray <- readMVar mvrNameArray
;agcons <- readMVar mvrSelCons
;agnodegroup <- readMVar mvrNodeGroup
;let agconsname = (fst (agnamearray ! agcons))
;revset <- get revtogg toggleActionActive
;let fullgraph = implicGraphAll agnodegroup
displaygraph | revset = grev fullgraph
| otherwise = fullgraph
;writeFile fpath5 (graph2DOT displaygraph agconsname)
;statusbarPush status gencontext ("Saved rule dependency graph for " ++ agconsname)
;return ()
}
;return ()
}
onActionActivate valgrph $ do { ppres <- readIORef hasValPopup
;if ppres then return ()
else do {
vgnamearray <- readMVar mvrNameArray
;vgcons <- readMVar mvrSelCons
;vgnodegroup <- readMVar mvrNodeGroup
;let grphvalues = snd (vgnamearray ! vgcons) -- define the value menu for valgrph here
valindices = [0..((length grphvalues)-1)]
valchoice = map (\ind -> (RadioActionEntry (show ind) (grphvalues !! ind) Nothing Nothing Nothing ind)) valindices
-- dummy value, as with selcons
valdummy = [RadioActionEntry (show lst) "None" Nothing Nothing Nothing lst] where lst = length valindices
valdumchoice = concat [valchoice,valdummy]
valpopmstr = "<ui><popup>" ++ (concatMap vitstr valdumchoice) ++ "</popup></ui>" -- itstr defined above
vitstr x = "<menuitem action=\"" ++ (radioActionName x) ++ "\" />"
;actionGroupAddRadioActions valpopgr valdumchoice ((length valdumchoice) -1)
(myValChange vgnodegroup filesave status gencontext vgnamearray vgcons revtogg)
;uiManagerAddUiFromString valpopman valpopmstr
;uiManagerInsertActionGroup valpopman valpopgr 0
;mbvalpopup <- uiManagerGetWidget valpopman "/ui/popup"
;let valpopup = case mbvalpopup of
Nothing -> error "Main: no popup menu for value selection of graph"
Just x -> x
;putMVar mvrValPopup valpopup
;writeIORef hasValPopup True
} -- end else
;vgvalpopup <- readMVar mvrValPopup
;menuPopup (castToMenu vgvalpopup) Nothing
;return ()
}
widgetShowAll window
onActionActivate quitact (widgetDestroy window)
onDestroy window mainQuit
mainGUI
uiDecl :: String
uiDecl = "<ui>\
\ <menubar>\
\ <menu action=\"FileMenu\">\
\ <menuitem action=\"OpenSrc\" />\
\ <menuitem action=\"QuitAct\" />\
\ </menu>\
\ <menu action=\"OptionMenu\">\
\ <menuitem action=\"DupCheck\" />\
\ <menuitem action=\"AmbCheck\" />\
\ </menu>\
\ <menu action=\"GrphMen\">\
\ <menuitem action=\"RevGraph\" />\
\ <menuitem action=\"AttGrph\" />\
\ <menuitem action=\"ValGrph\" />\
\ <menuitem action=\"GleGend\" />\
\ </menu>\
\ </menubar>\
\ <toolbar>\
\ <toolitem action=\"OpenSrc\" />\
\ <toolitem action=\"SelCons\" />\
\ <toolitem action=\"ReduAct\" />\
\ <toolitem action=\"AbduTop\" />\
\ </toolbar>\
\ </ui>"
-- | test for duplicates if the user wants, let the user save a .csv file of duplicates with frequencies, finally remove duplicates from facts
getNoDuplicates :: ToggleAction -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> [[AVp]] -> IO [[AVp]]
getNoDuplicates check fs status dupcontext attvarr rawfcts = do
{ duptrue <- get check toggleActionActive
; if duptrue then do {
;statusbarPush status dupcontext "Checking for duplicates..."
; let prt = partDups rawfcts
;if checkNoDups prt then do {
statusbarPush status dupcontext "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 dupcontext "Duplicates have been removed from the fact list"
;return ()
}
;return (factsUniques prt)
}
else do { statusbarPush status dupcontext "Source file read and parsed"
;return rawfcts
}
}
-- returns True if there are NO ambiguous rules for the selected consequent attribute (and if the test was skipped)
noAmbiguities :: ToggleAction -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String]) -> Int -> [[Rule]] -> IO Bool
noAmbiguities check fs status ambcontext attvarr consatt rules = do {
let cnsnm = (fst (attvarr ! consatt))
;ambtest <- get check toggleActionActive
; if ambtest then do {
let ambs = getAmbiguous rules
; if ambs == [] then do { statusbarPush status ambcontext ("No ambiguous rules for " ++ (fst (attvarr ! consatt)))
;return True
}
else do { statusbarPush status ambcontext ( "Ambiguities: " ++ (show (length ambs)) ++ " for " ++ (fst (attvarr ! consatt)))
;mbf <- mygetFileName fs
;case mbf of
Nothing -> return ()
Just fpath -> writeFile fpath (allAmb2CSVTb attvarr ambs)
;return False
}
}
else do { statusbarPush status ambcontext ("No ambiguities check. The consequent attribute is: " ++ cnsnm)
;return True
}
}
mygetFileName :: FileChooserDialog -> IO (Maybe FilePath)
mygetFileName fs = do resp <- dialogRun fs
widgetHide fs
case resp of
ResponseAccept -> fileChooserGetFilename fs
(_) -> return Nothing
myValChange :: [[LNode RuRe]] -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> Int -> ToggleAction -> RadioAction -> IO ()
myValChange ndgrp fs status valcontext attvarr cns check ra = do {
statusbarPush status valcontext "Building value rule graph.."
;valind <- radioActionGetCurrentValue ra
;revset <- get check toggleActionActive
;let valuegraph = implicGraphOne (ndgrp !! valind)
displaygraph | revset = grev valuegraph
| otherwise = valuegraph
;mbf <- mygetFileName fs
;case mbf of
Nothing -> do { statusbarPush status valcontext "Cancelled"
;return ()
}
Just fpath -> do { forkIO $ do {
let consname = (fst (attvarr ! cns))
valname = (snd (attvarr ! cns)) !! valind
;writeFile fpath (graph2DOT displaygraph "ValueGraph")
;statusbarPush status valcontext (consname ++ " : " ++ valname ++ " rule graph saved")
;return ()
}
;return ()
}
}