maingengui.hs

HTK系列的

    foldnm <- newEntry [pad Vertical 5, pad Horizontal 5, width 30,
                        background "white", parent foldnmbox,
                        text "(default)"] :: IO (Entry String)
    foldimgbox <- newHBox [parent foldentries]
    folderImg' <- folderImg
    standardfoldimg <- newButton [size (18, 18),
                                  pad Horizontal 3, photo folderImg',
                                  parent foldimgbox,
                                  command (\ () -> return ())]
                         :: IO (Button String)
    setRef lastactiveref standardfoldimg
    imgfolderImg' <- imgfolderImg
    imgfoldimg <- newButton [size (18, 18),
                             pad Horizontal 3, relief Sunken,
                             photo imgfolderImg', parent foldimgbox,
                             command (\ () -> return ())]
                    :: IO (Button String)
    txtfolderImg' <- txtfolderImg
    txtfoldimg <- newButton [size (18, 18),
                             pad Horizontal 3, relief Sunken,
                             photo txtfolderImg', parent foldimgbox,
                             command (\ () -> return ())]
                    :: IO (Button String)
    colorfolderImg' <- colorfolderImg
    colfoldimg <- newButton [size (18, 18),
                             pad Horizontal 3, relief Sunken,
                             photo colorfolderImg', parent foldimgbox,
                             command (\ () -> return ())]
                    :: IO (Button String)
    numfolderImg' <- numfolderImg
    numfoldimg <- newButton [size (18, 18),
                             pad Horizontal 3, relief Sunken,
                             photo numfolderImg', parent foldimgbox,
                             command (\ () -> return ())]
                    :: IO (Button String)
-}
    export <- newButton main [text "Export state"]
    pack export [PadX 10, PadY 5, Fill X, Expand On]
    clickedexport <- clicked export
    quit <- newButton main [text "Quit"]
    pack quit [PadX 10, PadY 5, Fill X, Expand On]
    clickedquit <- clicked quit


    (gui_ev, _) <- bindGenGUIEv gui

    let --react :: GenGUIEvent c -> IO ()
        react (SelectTreeList mitem) = selectedTl foldlab mitem
        react (Doubleclick item) = doubleClickNp item
        react _ = done

    spawnEvent (forever (clickedexport >>> exportState gui +>
                         clickedquit >>> destroy main +>
                         gui_ev >>>= react))
{-
                         selectedItemInTreeList gui >>>=
                           selectedTl foldlab +>
                         doubleClickInNotepad gui >>>= doubleClickNp))
-}

{-
    interactor (\i -> (triggered addimg >>> do
                                              nm <- getText imgnm
                                              val <- getRef imgpathref
                                              addImg nm val) +>
                      (triggered addtxt >>> do
                                              nm <- getText txtnm
                                              val <- getText txtval
                                              addTxt nm val
                                              done) +>
                      (triggered addnum >>> do
                                              nm <- getText numnm
                                              --val <- getText numval
                                              {-addNum nm val-}
                                              done) +>
                      (triggered addcol >>> do
                                              nm <- getText colnm
                                              val <- getText colmenu
                                              addCol nm val
                                              done) +>
                      (triggered imgbutton >>> chooseImageFile
                                                 imgbutton) +>
                      (triggered addfold >>> do
                                               nm <- getText foldnm
                                               addFolder nm
                                               done) +>
                      (triggered standardfoldimg >>>
                         imgSelected standardfoldimg folderImg) +>
                      (triggered imgfoldimg >>>
                         imgSelected imgfoldimg imgfolderImg) +>
                      (triggered txtfoldimg >>>
                         imgSelected txtfoldimg txtfolderImg) +>
                      (triggered colfoldimg >>>
                         imgSelected colfoldimg colorfolderImg) +>
                      (triggered numfoldimg >>>
                         imgSelected numfoldimg numfolderImg) +>
                      (triggered quit >>> destroy tk) +>
                      (selectedItemInTreeList gui >>>=
                         selectedTl foldlab) +>
                      (doubleClickInNotepad gui >>>= doubleClickNp))
-}
{-
    spawnEvent (forever ((selectedItemInTreeList gui >>>=
                            selectedTl foldlab) +>
                         (doubleClickInNotepad gui >>>=
                            doubleClickNp)))
-}
    addExampleFolders newID gui
    finishHTk

imgSelected :: Button -> IO Image -> IO ()
imgSelected but img =
  do
    but' <- getRef lastactiveref
    if but' == but then done else
      do
        but' # relief Sunken
        but # relief Raised
        setRef lastactiveref but
        setRef imgref img

selectedTl :: Label -> Maybe (Item Obj) -> IO ()
selectedTl foldlab mitem =
  case mitem of
    Nothing -> foldlab # text "no folder selected" >> done
    Just item -> let val = content item
                     (nm, _, _) = val
                 in do
                      foldlab # text ("'" ++ full nm ++ "'")
                      setRef foldref (Just item)

doubleClickNp :: Item Obj -> IO ()
doubleClickNp item =
  let (_, _, myobj) = content item
  in case myobj of
       MyImage _ ioimg -> do
                            main <- createToplevel [text "Image"]
                            img <- ioimg
                            lab <- newLabel main [anchor Center,
                                                  photo img]
                            pack lab []
                            quit <- newButton main [text "Close"]
                            pack quit []
                            clickedquit <- clicked quit
                            spawnEvent (clickedquit >>> destroy main)
                            done
       MyTxt _ str -> do
                        main <- createToplevel [text "Text"]
                        lab <- newLabel main
                                 [anchor Center,
                                  text ("     " ++ str ++ "     "),
                                  height 5, relief Sunken,
                                  font (Helvetica, 12 :: Int)]
                        pack lab []
                        quit <- newButton main [text "Close"]
                        pack quit []
                        clickedquit <- clicked quit
                        spawnEvent (clickedquit >>> destroy main)
                        done
       MyColor _ mycol -> do
                            main <- createToplevel [text "Color"]
                            lab <- newLabel main
                                     [relief Sunken, size (20,8),
                                      anchor Center,
                                      font (Helvetica, 18 :: Int),
                                      bg (case mycol of
                                            Red -> "red"
                                            Green -> "green"
                                            Blue -> "blue"
                                            Yellow -> "yellow"),
                                      text (case mycol of
                                               Red -> "Red"
                                               Green -> "Green"
                                               Blue -> "Blue"
                                               Yellow -> "Yellow")]
                            pack lab []
                            quit <- newButton main [text "Close"]
                            pack quit []
                            clickedquit <- clicked quit
                            spawnEvent (clickedquit >>> destroy main)
                            done
       MyNum _ n -> do
                      main <- createToplevel [text "Number"]
                      lab <- newLabel main
                               [anchor Center, text (show n),
                                relief Sunken, size (20,8),
                                font (Helvetica, 18 :: Int)]
                      pack lab []
                      quit <- newButton main [text "Close"]
                      pack quit []
                      clickedquit <- clicked quit
                      spawnEvent (clickedquit >>> destroy main)
                      done

exportState :: GenGUI Obj -> IO ()
exportState gui =
  do
    st <- exportGenGUIState gui
    putStrLn "state exported"
    gui_clone <- newGenGUI (Just st) True
    putStrLn "state imported"


------------
-- images --
------------

yellowImg = newImage [imgData GIF "R0lGODlhDAAMAIQAAOfkFuTgHOHdId3aJtrXLNbTMdPQNtDNPMzKQcnGRsXDS8LAUb+9Vru5W7i2
YbSzZrGva62scKqpdqeme6OigKCfhpyci5aWlpaWlpaWlpaWlpaWlpaWlpaWlpaWlpaWliH+FUNy
ZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAfACwAAAAADAAMAAAFPyAQCANRGAeSKMtYnum6MKSJ
qizTvLesO7ZYruF4wHAz4gPSGxYhEWHyGZEgf8vqxKeESiYUZ/ZLqUzH4IolBAA7"]

greenImg = newImage [imgData GIF "R0lGODlhDAAMAIQAAAD/IQb6Jgz2KxLxMBntNR/pOiXkPyvgQzLcSDjXTT7TUkTOV0vKXFHGYFfB
ZV29amS4b2q0dHCweXarfX2ngoOjh4mejJaWlpaWlpaWlpaWlpaWlpaWlpaWlpaWlpaWliH+FUNy
ZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAfACwAAAAADAAMAAAFPyAQCANRGAeSKMtYnum6MKSJ
qizTvLesO7ZYruF4wHAz4gPSGxYhEWHyGZEgf8vqxKeESiYUZ/ZLqUzH4IolBAA7"]

blueImg = newImage [imgData GIF "R0lGODlhDAAMAIQAAAA//wZC+gxG9hJJ8RlN7R9R6SVU5CtY4DJc3Dhf1z5j00RmzktqylFuxldx
wV11vWR5uGp8tHCAsHaDq32Hp4OLo4mOnpaWlpaWlpaWlpaWlpaWlpaWlpaWlpaWlpaWliH+FUNy
ZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAfACwAAAAADAAMAAAFPyAQCANRGAeSKMtYnum6MKSJ
qizTvLesO7ZYruF4wHAz4gPSGxYhEWHyGZEgf8vqxKeESiYUZ/ZLqUzH4IolBAA7"]

redImg = newImage [imgData GIF "R0lGODlhDAAMAIQAAP8UAPoaBvYfDPElEu0qGekvH+Q1JeA6K9xAMtdFONNKPs5QRMpVS8ZaUcFg
V71lXbhrZLRwarB1cKt7dqeAfaOFg56LiZaWlpaWlpaWlpaWlpaWlpaWlpaWlpaWlpaWliH+FUNy
ZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAfACwAAAAADAAMAAAFPyAQCANRGAeSKMtYnum6MKSJ
qizTvLesO7ZYruF4wHAz4gPSGxYhEWHyGZEgf8vqxKeESiYUZ/ZLqUzH4IolBAA7"]

txtImg = newImage [imgData GIF "R0lGODlhDAAMAKEAAAAAAP///9jY2NjY2CH5BAEKAAIALAAAAAAMAAwAAAIjlIEJduEflgAwxUXh
Q/Pa22kORyEemIlk5JWYOErKLE00UgAAOw=="]

numImg = newImage [imgData GIF "R0lGODlhDAAMAKUAAP////v7+/j4+PX19fHx8e7u7uvr6+jo6OXl5eHh4d7e3tvb2/ba2vWgoPOe
nvGcnOTIyOWtrfw2Nvs1Nf8AAO21teuWlvRKSv03N/LW1vkzM/vf3/tRUfdNTfNmZumUlPynp/sZ
GfVLS/e/v/KBge59feKqqv0bG/S8vPOCguqysu5hYfjc3PptbflPT+rOzueSktjY2NjY2NjY2NjY
2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAD8ALAAAAAAMAAwAAAZlQEBA
MCAUDAdEQrEQChgNxyMJiTSHkomDUkFYLleMJHPUIChgwIbCMRo6HsqnCaIUjwdKyAqo35EUIkx9
FCNuJBQlg3VtRx2BCiZCFCcoBSkUKiEXK0IsLScuFC9eFDBOf0lLC0EAOw=="]

imgImg = newImage [imgData GIF "R0lGODlhDAAMAMIAAHq86Oz8FP///wAAAHqk/yrMS1XRYP///yH+FUNyZWF0ZWQgd2l0aCBUaGUg
R0lNUAAh+QQBCgAHACwAAAAADAAMAAADL3i6vPAwKhjimyBoIQ8YBCEI4nUMYCiAZlGgMNEWRl0P
ra3jiuvqhkHPR3Q1jooEADs="]