INblobs-0.1.1: src/State.hs

module State
    ( State
    , State.empty
    , ToolWindow(..)

    , getDocument
    , getDragging,          setDragging
    , getCanvas,            setCanvas
    , getLHSCanvas,         setLHSCanvas
    , getRHSCanvas,         setRHSCanvas
    , getPalettePanel,      setPalettePanel
    , getNetworkFrame,      setNetworkFrame
    , getPageSetupDialog,   setPageSetupDialog
    , getDisplayOptions,    setDisplayOptions
    , changeDisplayOptions
    , getCurrentShape,      setCurrentShape
    , getActiveCanvas,      setActiveCanvas
    , getActiveRule,        setActiveRule
    , getTree,              setTree
    , getShape1,            setShape1
    , getShape2,            setShape2
    , getOkButton,          setOkButton
    , getReduceButton,      setReduceButton
    , getContinueReduction,    setContinueReduction

    , stopReduction
    , disableReduce
    ) where

import Document
import Math
import qualified PersistentDocument as PD
import DisplayOptions

import Graphics.UI.WX
import Graphics.UI.WXCore hiding (Document, ToolWindow)

 

type State g n e = Var (StateRecord g n e)

data StateRecord g n e = St
    { stDocument        :: PD.PersistentDocument (Document g n e)
    , stDragging        :: Maybe (Bool, DoublePoint) -- ^ (really moved?, offset from center of node)
    , stNetworkFrame    :: Frame ()
    , stCanvas          :: ScrolledWindow ()
    , stLHSCanvas       :: ScrolledWindow ()
    , stRHSCanvas       :: ScrolledWindow ()
    , stPalettePanel    :: Panel ()
    , stPageSetupDialog :: PageSetupDialog ()
    , stDisplayOptions  :: DisplayOptions
    , stShape           :: String       -- ^ the name of the shape in the palette
    , stActiveCanvas    :: ActiveCanvas -- ^ which canvas is active
    , stActiveRule      :: RuleName     -- ^ a interaction rule's name 
    , stTree            :: TreeCtrl ()  -- ^ the treeCtrl that lists the rules
    , stShape1          :: Maybe String -- ^ a shape name
    , stShape2          :: Maybe String -- ^ a shape name
    , stOkButton        :: Button ()    
    , stReduceButton    :: Button ()    
    , stContinueReduct  :: Bool         -- ^ reduction process should continue or stop    
    }

data ToolWindow = TW
    { twRepaint :: IO ()
    , twFrame   :: Frame ()
    }

empty :: IO (State g n e)
empty =
  do{ dummy <- PD.dummy

    ; varCreate (St
        { stDocument        = dummy
        , stNetworkFrame    = error "State.empty: network frame has not been set"
        , stDragging        = Nothing
        , stCanvas          = error "State.empty: canvas has not been set"
        , stLHSCanvas       = error "State.empty: canvasLHS has not been set"
        , stRHSCanvas       = error "State.empty: canvasRHS has not been set"
        , stPalettePanel    = error "State.empty: panel has not been set"
        , stPageSetupDialog = error "State.empty: page setup dialog has not been set"
        , stDisplayOptions  = DisplayOptions.standard
        , stShape           = "circle"
        , stActiveCanvas    = Net
        , stShape1          = Nothing
        , stShape2          = Nothing
        , stOkButton        = error "State.empty: Ok button has not been set"   
        , stReduceButton    = error "State.empty: Reduce button has not been set"
        , stContinueReduct  = True
        })
    }

-- Getters

getDocument :: State g n e -> IO (PD.PersistentDocument (Document g n e))
getDocument = getFromState stDocument

getDragging :: State g n e -> IO (Maybe (Bool, DoublePoint))
getDragging = getFromState stDragging

getNetworkFrame :: State g n e -> IO (Frame ())
getNetworkFrame = getFromState stNetworkFrame

getCanvas :: State g n e -> IO (ScrolledWindow ())
getCanvas = getFromState stCanvas

getLHSCanvas :: State g n e -> IO (ScrolledWindow ())
getLHSCanvas = getFromState stLHSCanvas

getRHSCanvas :: State g n e -> IO (ScrolledWindow ())
getRHSCanvas = getFromState stRHSCanvas

getPalettePanel :: State g n e -> IO (Panel ())
getPalettePanel = getFromState stPalettePanel

getPageSetupDialog :: State g n e -> IO (PageSetupDialog ())
getPageSetupDialog = getFromState stPageSetupDialog

getDisplayOptions :: State g n e -> IO DisplayOptions
getDisplayOptions = getFromState stDisplayOptions

getCurrentShape :: State g n e -> IO String
getCurrentShape = getFromState stShape

getActiveCanvas :: State g n e -> IO ActiveCanvas
getActiveCanvas = getFromState stActiveCanvas

getActiveRule :: State g n e -> IO RuleName
getActiveRule = getFromState stActiveRule

getTree :: State g n e -> IO (TreeCtrl () )
getTree = getFromState stTree

getShape1 :: State g n e -> IO (Maybe String )
getShape1 = getFromState stShape1

getShape2 :: State g n e -> IO (Maybe String )
getShape2 = getFromState stShape2

getOkButton :: State g n e -> IO (Button () )
getOkButton = getFromState stOkButton

getReduceButton :: State g n e -> IO (Button () )
getReduceButton = getFromState stReduceButton

getContinueReduction :: State g n e -> IO Bool
getContinueReduction = getFromState stContinueReduct


-- Setters

setDragging :: Maybe (Bool, DoublePoint)  -> State g n e -> IO ()
setDragging theDragging stateRef =
    varUpdate_ stateRef (\state -> state { stDragging = theDragging })

setNetworkFrame :: Frame () -> State g n e -> IO ()
setNetworkFrame networkFrame stateRef =
    varUpdate_ stateRef (\state -> state { stNetworkFrame = networkFrame })

setCanvas :: ScrolledWindow () -> State g n e -> IO ()
setCanvas canvas stateRef =
    varUpdate_ stateRef (\state -> state { stCanvas = canvas })

setLHSCanvas :: ScrolledWindow () -> State g n e -> IO ()
setLHSCanvas canvas stateRef =
    varUpdate_ stateRef (\state -> state { stLHSCanvas = canvas })

setRHSCanvas :: ScrolledWindow () -> State g n e -> IO ()
setRHSCanvas canvas stateRef =
    varUpdate_ stateRef (\state -> state { stRHSCanvas = canvas })

setPalettePanel :: Panel () -> State g n e -> IO ()
setPalettePanel panel stateRef =
    varUpdate_ stateRef (\state -> state { stPalettePanel = panel })

setPageSetupDialog :: PageSetupDialog () -> State g n e -> IO ()
setPageSetupDialog thePageSetupDialog stateRef =
    varUpdate_ stateRef (\state -> state { stPageSetupDialog = thePageSetupDialog })

setDisplayOptions :: DisplayOptions -> State g n e -> IO ()
setDisplayOptions dp stateRef =
    varUpdate_ stateRef (\state -> state { stDisplayOptions = dp })

changeDisplayOptions :: (DisplayOptions->DisplayOptions) -> State g n e -> IO ()
changeDisplayOptions dpf stateRef =
    varUpdate_ stateRef
        (\state -> state { stDisplayOptions = dpf (stDisplayOptions state) })

setCurrentShape :: String -> State g n e -> IO ()
setCurrentShape shapeName stateRef =
    varUpdate_ stateRef (\state -> state { stShape = shapeName })

setActiveCanvas :: ActiveCanvas -> State g n e -> IO ()
setActiveCanvas activeCanvas stateRef =
 do rule <- getActiveRule stateRef
    let activeCanvas' = case activeCanvas of
                           Net                 -> Net
                           LHS str | null str  -> LHS rule
                                   | otherwise -> LHS str
                           RHS str | null str  -> RHS rule
                                   | otherwise -> RHS str
    varUpdate_ stateRef (\state -> state { stActiveCanvas = activeCanvas' })

setActiveRule :: RuleName -> State g n e -> IO ()
setActiveRule activeRule stateRef =
    varUpdate_ stateRef (\state -> state { stActiveRule = activeRule })

setTree :: TreeCtrl () -> State g n e -> IO ()
setTree tree stateRef =
    varUpdate_ stateRef (\state -> state { stTree = tree })

setShape1 :: Maybe String -> State g n e -> IO ()
setShape1 shape1 stateRef =
    varUpdate_ stateRef (\state -> state { stShape1 = shape1 })

setShape2 :: Maybe String -> State g n e -> IO ()
setShape2 shape2 stateRef =
    varUpdate_ stateRef (\state -> state { stShape2 = shape2 })

setOkButton :: Button () -> State g n e -> IO ()
setOkButton okButton stateRef =
    varUpdate_ stateRef (\state -> state { stOkButton = okButton })

setReduceButton :: Button () -> State g n e -> IO ()
setReduceButton reduceButton stateRef =
    varUpdate_ stateRef (\state -> state { stReduceButton = reduceButton })

setContinueReduction :: Bool -> State g n e -> IO ()
setContinueReduction continue stateRef =
    varUpdate_ stateRef (\state -> state { stContinueReduct = continue })
--

disableReduce :: State g n e -> IO ()
disableReduce state = return ()
--  do button <- getReduceButton state
--     set button [enabled := False]

stopReduction :: State g n e  -> IO ()
stopReduction = setContinueReduction False

-- Utility functions

getFromState :: (StateRecord g n e -> a) -> State g n e -> IO a
getFromState selector stateRef = do
    state <- varGet stateRef
    return (selector state)

varUpdate_ :: Var a -> (a -> a) -> IO ()
varUpdate_ var fun = do { varUpdate var fun; return () }