diff --git a/app/FeatureTableEditor.hs b/app/FeatureTableEditor.hs --- a/app/FeatureTableEditor.hs +++ b/app/FeatureTableEditor.hs @@ -13,6 +13,8 @@ import Control.Monad import Control.Exception import Data.Tuple +import Data.List +import Data.Maybe import Text.PhonotacticLearner.PhonotacticConstraints import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -57,6 +59,22 @@ slook = M.fromList (fmap swap (assocs segs)) flook = M.fromList (fmap swap (assocs fnames)) +resegft :: [String] -> FeatureTable String -> FeatureTable String +resegft segs oldft = FeatureTable ftarr fnames segsarr flook slook where + fnames = featNames oldft + flook = featLookup oldft + (fa,fb) = bounds fnames + uniqsegs = nub segs + nsegs = length uniqsegs + segsarr = listArray (Seg 1, Seg nsegs) uniqsegs + slook = M.fromList (fmap swap (assocs segsarr)) + ftarr = array ((Seg 1,fa), (Seg nsegs,fb)) $ do + f <- indices fnames + (sr,s) <- assocs segsarr + let fs = fromMaybe FOff $ do + sr' <- M.lookup s (segLookup oldft) + return $ ftlook oldft sr' f + return ((sr,f),fs) setFTContents :: TreeView -> FeatureTable String -> IO (Array SegRef String, ListStore FTRow) setFTContents editor newft = do @@ -115,6 +133,32 @@ bincsv <- B.readFile fp evaluate $ force . csvToFeatureTable id . T.unpack =<< either (const Nothing) Just (T.decodeUtf8' bincsv) +runTextDialog :: Maybe Window -> T.Text -> T.Text -> Now (Event (Maybe T.Text)) +runTextDialog transwin q defa = do + (retev, cb) <- callback + dia <- sync $ dialogNew + ent <- sync $ entryNew + sync $ do + case transwin of + Just win -> set dia [windowTransientFor := win, windowModal := True] + Nothing -> return () + dialogAddButton dia "gtk-ok" ResponseOk + dialogAddButton dia "gtk-cancel" ResponseCancel + ca <- castToBox <$> dialogGetContentArea dia + entrySetText ent defa + lbl <- createLabel q + boxPackStart ca lbl PackGrow 0 + boxPackStart ca ent PackNatural 0 + on dia response $ \resp -> do + case resp of + ResponseOk -> do + txt <- entryGetText ent + cb (Just txt) + _ -> cb Nothing + widgetDestroy dia + widgetShowAll dia + return retev + createEditableFT :: Maybe Window -> FeatureTable String -> Now (VBox, Behavior (FeatureTable String)) createEditableFT transwin initft = do editor <- sync treeViewNew @@ -126,6 +170,7 @@ (addButton, addPressed) <- createButton (Just "list-add") Nothing (delButton, delPressed) <- createButton (Just "list-remove") Nothing (editButton, isEditing) <- createToggleButton (Just "accessories-text-editor") (Just "Edit Table") False + (segButton, segPressed) <- createButton Nothing (Just "Change Segments") setAttr widgetSensitive addButton isEditing setAttr widgetSensitive delButton isEditing @@ -140,15 +185,6 @@ viewer <- displayDynFeatureTable currentft - bar <- createHBox 2 $ do - bpack addButton - bpack delButton - bspacer - bpack editButton - bpack loadButton - bpack saveButton - - top <- sync stackNew sync $ do stackAddNamed top viewer "False" @@ -157,20 +193,29 @@ vb <- createVBox 2 $ do bstretch =<< createFrame ShadowIn top - bpack bar + bpack <=< createHBox 2 $ do + bpack addButton + bpack delButton + bspacer + bpack segButton + bpack editButton + bpack loadButton + bpack saveButton - csvfilter <- sync fileFilterNew + {-csvfilter <- sync fileFilterNew allfilter <- sync fileFilterNew sync $ do fileFilterAddMimeType csvfilter "text/csv" fileFilterSetName csvfilter "CSV" fileFilterAddPattern allfilter "*" fileFilterSetName allfilter "All Files" + -} loadDialog <- sync $ fileChooserDialogNew (Just "Open Feature Table") transwin FileChooserActionOpen [("gtk-cancel", ResponseCancel), ("gtk-open", ResponseAccept)] - sync $ fileChooserAddFilter loadDialog csvfilter - sync $ fileChooserAddFilter loadDialog allfilter + --sync $ fileChooserAddFilter loadDialog csvfilter + --sync $ fileChooserAddFilter loadDialog allfilter + sync $ set loadDialog [windowModal := True] flip callStream loadPressed $ \_ -> do filePicked <- runFileChooserDialog loadDialog emft <- planNow . ffor filePicked $ \case @@ -186,8 +231,9 @@ saveDialog <- sync $ fileChooserDialogNew (Just "Save Feature Table") transwin FileChooserActionSave [("gtk-cancel", ResponseCancel), ("gtk-save", ResponseAccept)] - sync $ fileChooserAddFilter saveDialog csvfilter - sync $ fileChooserAddFilter saveDialog allfilter + --sync $ fileChooserAddFilter saveDialog csvfilter + --sync $ fileChooserAddFilter saveDialog allfilter + sync $ set saveDialog [windowModal := True] flip callStream savePressed $ \_ -> do savePicked <- runFileChooserDialog saveDialog planNow . ffor savePicked $ \case @@ -201,6 +247,22 @@ putStrLn $ "Wrote Feature Table " ++ fn return () return () + + flip callStream segPressed $ \_ -> do + oldft <- sample currentft + let oldsegs = T.pack . unwords . elems . segNames $ oldft + enewsegs <- runTextDialog transwin "Enter a new set of segments." oldsegs + planNow . ffor enewsegs $ \case + Nothing -> return () + Just newsegs -> let segs = words (T.unpack newsegs) in case segs of + [] -> return () + _ -> sync $ do + let newft = resegft segs oldft + newmodel <- setFTContents editor newft + replaceModel newmodel + putStrLn "Segments Changed." + return () + flip callStream addPressed $ \_ -> do (segs, store) <- sample currentModel diff --git a/app/GrammarEditor.hs b/app/GrammarEditor.hs --- a/app/GrammarEditor.hs +++ b/app/GrammarEditor.hs @@ -27,7 +27,7 @@ import Numeric import qualified Graphics.Rendering.Cairo as C -import Graphics.Rendering.Chart.Easy hiding (indices, set') +import Graphics.Rendering.Chart.Easy hiding (indices, set', set) import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing @@ -107,7 +107,7 @@ bpack loadButton bpack saveButton - txtfilter <- sync fileFilterNew + {-txtfilter <- sync fileFilterNew allfilter <- sync fileFilterNew sync $ do @@ -115,11 +115,13 @@ fileFilterSetName txtfilter "Text Files" fileFilterAddPattern allfilter "*" fileFilterSetName allfilter "All Files" + -} loadDialog <- sync $ fileChooserDialogNew (Just "Load Grammar") transwin FileChooserActionOpen [("gtk-cancel", ResponseCancel), ("gtk-open", ResponseAccept)] - sync $ fileChooserAddFilter loadDialog txtfilter - sync $ fileChooserAddFilter loadDialog allfilter + --sync $ fileChooserAddFilter loadDialog txtfilter + --sync $ fileChooserAddFilter loadDialog allfilter + sync $ set loadDialog [windowModal := True] flip callStream loadPressed $ \_ -> do filePicked <- runFileChooserDialog loadDialog planNow . ffor filePicked $ \case @@ -135,8 +137,9 @@ saveDialog <- sync $ fileChooserDialogNew (Just "Save Grammar") transwin FileChooserActionSave [("gtk-cancel", ResponseCancel), ("gtk-save", ResponseAccept)] - sync $ fileChooserAddFilter saveDialog txtfilter - sync $ fileChooserAddFilter saveDialog allfilter + --sync $ fileChooserAddFilter saveDialog txtfilter + --sync $ fileChooserAddFilter saveDialog allfilter + sync $ set saveDialog [windowModal := True] flip callStream savePressed $ \_ -> do mg <- sample currentGrammar case mg of diff --git a/app/LexiconEditor.hs b/app/LexiconEditor.hs --- a/app/LexiconEditor.hs +++ b/app/LexiconEditor.hs @@ -126,18 +126,20 @@ [i] -> listStoreRemove store i _ -> return () - txtfilter <- sync fileFilterNew + {- txtfilter <- sync fileFilterNew allfilter <- sync fileFilterNew sync $ do fileFilterAddMimeType txtfilter "text/*" fileFilterSetName txtfilter "Text Files" fileFilterAddPattern allfilter "*" fileFilterSetName allfilter "All Files" + -} saveDialog <- sync $ fileChooserDialogNew (Just "Save Lexicon") transwin FileChooserActionSave [("gtk-cancel", ResponseCancel), ("gtk-save", ResponseAccept)] - sync $ fileChooserAddFilter saveDialog txtfilter - sync $ fileChooserAddFilter saveDialog allfilter + --sync $ fileChooserAddFilter saveDialog txtfilter + --sync $ fileChooserAddFilter saveDialog allfilter + sync $ set saveDialog [windowModal := True] flip callStream savePressed $ \_ -> do (_,segs,rows) <- sample currentLex savePicked <- runFileChooserDialog saveDialog @@ -154,8 +156,9 @@ loadListDialog <- sync $ fileChooserDialogNew (Just "Load Lexicon") transwin FileChooserActionOpen [("gtk-cancel", ResponseCancel), ("gtk-open", ResponseAccept)] - sync $ fileChooserAddFilter loadListDialog txtfilter - sync $ fileChooserAddFilter loadListDialog allfilter + --sync $ fileChooserAddFilter loadListDialog txtfilter + --sync $ fileChooserAddFilter loadListDialog allfilter + sync $ set loadListDialog [windowModal := True] flip callStream loadListPressed $ \_ -> do filePicked <- runFileChooserDialog loadListDialog loaded <- planNow . ffor filePicked $ \case @@ -178,8 +181,9 @@ loadTextDialog <- sync $ fileChooserDialogNew (Just "Load Text For New Lexicon") transwin FileChooserActionOpen [("gtk-cancel", ResponseCancel), ("gtk-open", ResponseAccept)] - sync $ fileChooserAddFilter loadTextDialog allfilter - sync $ fileChooserAddFilter loadTextDialog txtfilter + --sync $ fileChooserAddFilter loadTextDialog allfilter + --sync $ fileChooserAddFilter loadTextDialog txtfilter + sync $ set loadTextDialog [windowModal := True] flip callStream loadTextPressed $ \_ -> do filePicked <- runFileChooserDialog loadTextDialog loaded <- planNow . ffor filePicked $ \case diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeOperators, RecursiveDo, ScopedTypeVariables, TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +{-# LANGUAGE TypeOperators, RecursiveDo, ScopedTypeVariables, TemplateHaskell, QuasiQuotes, OverloadedStrings, ExtendedDefaultRules #-} module Main where @@ -28,10 +28,12 @@ import LearnerControls import System.IO +default (T.Text) + ipaft :: FeatureTable String ipaft = fromJust . csvToFeatureTable id . T.unpack . T.decodeUtf8 $ $(embedFile "app/ft-ipa.csv") -css :: String +css :: T.Text css = [r| #featuretable{ background-color: @theme_base_color; @@ -57,6 +59,7 @@ -- example gtk app -- initialization code window <- sync $ windowNew + sync $ set window [windowTitle := "Hayes/Wilson Phonotactic Learner."] rec (fteditor, dynft) <- createEditableFT (Just window) ipaft (lexeditor, dynlex) <- createEditableLexicon (Just window) (fmap segsFromFt dynft) lexout @@ -69,9 +72,9 @@ thescreen <- widgetGetScreen window styleContextAddProviderForScreen thescreen sp 600 - centerpanes <- set' [panedWideHandle := False] =<< createVPaned controls fteditor - rpanes <- set' [panedWideHandle := False] =<< createHPaned centerpanes grammareditor - lpanes <- set' [panedWideHandle := False] =<< createHPaned lexeditor rpanes + centerpanes <- set' [panedWideHandle := True] =<< createVPaned controls fteditor + rpanes <- set' [panedWideHandle := True] =<< createHPaned centerpanes grammareditor + lpanes <- set' [panedWideHandle := True] =<< createHPaned lexeditor rpanes box <- createVBox 0 $ do bstretch lpanes bpack =<< liftIO (vSeparatorNew) diff --git a/maxent-learner-hw-gui.cabal b/maxent-learner-hw-gui.cabal --- a/maxent-learner-hw-gui.cabal +++ b/maxent-learner-hw-gui.cabal @@ -1,5 +1,5 @@ name: maxent-learner-hw-gui -version: 0.2.0 +version: 0.2.1 synopsis: GUI for maxent-learner-hw description: This is a GUI frontent for maxent-learner-hw using GTK. homepage: https://github.com/george-steel/maxent-learner @@ -22,7 +22,7 @@ LexiconEditor ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >= 4.7 && < 5 - , maxent-learner-hw == 0.2.0 + , maxent-learner-hw == 0.2.1 , containers == 0.5.* , text == 1.2.* , file-embed