7 , getDragging, setDragging
9 , getLHSCanvas, setLHSCanvas
10 , getRHSCanvas, setRHSCanvas
11 , getPalettePanel, setPalettePanel
12 , getNetworkFrame, setNetworkFrame
13 , getPageSetupDialog, setPageSetupDialog
14 , getDisplayOptions, setDisplayOptions
15 , changeDisplayOptions
16 , getCurrentShape, setCurrentShape
17 , getActiveCanvas, setActiveCanvas
18 , getActiveRule, setActiveRule
20 , getShape1, setShape1
21 , getShape2, setShape2
22 , getOkButton, setOkButton
23 , getReduceButton, setReduceButton
24 , getContinueReduction, setContinueReduction
32 import qualified PersistentDocument as PD
36 import Graphics.UI.WXCore hiding (Document, ToolWindow)
40 type State g n e = Var (StateRecord g n e)
42 data StateRecord g n e = St
43 { stDocument :: PD.PersistentDocument (Document g n e)
44 , stDragging :: Maybe (Bool, DoublePoint) -- ^ (really moved?, offset from center of node)
45 , stNetworkFrame :: Frame ()
46 , stCanvas :: ScrolledWindow ()
47 , stLHSCanvas :: ScrolledWindow ()
48 , stRHSCanvas :: ScrolledWindow ()
49 , stPalettePanel :: Panel ()
50 , stPageSetupDialog :: PageSetupDialog ()
51 , stDisplayOptions :: DisplayOptions
52 , stShape :: String -- ^ the name of the shape in the palette
53 , stActiveCanvas :: ActiveCanvas -- ^ which canvas is active
54 , stActiveRule :: RuleName -- ^ a interaction rule's name
55 , stTree :: TreeCtrl () -- ^ the treeCtrl that lists the rules
56 , stShape1 :: Maybe String -- ^ a shape name
57 , stShape2 :: Maybe String -- ^ a shape name
58 , stOkButton :: Button ()
59 , stReduceButton :: Button ()
60 , stContinueReduct :: Bool -- ^ reduction process should continue or stop
68 empty :: IO (State g n e)
74 , stNetworkFrame = error "State.empty: network frame has not been set"
75 , stDragging = Nothing
76 , stCanvas = error "State.empty: canvas has not been set"
77 , stLHSCanvas = error "State.empty: canvasLHS has not been set"
78 , stRHSCanvas = error "State.empty: canvasRHS has not been set"
79 , stPalettePanel = error "State.empty: panel has not been set"
80 , stPageSetupDialog = error "State.empty: page setup dialog has not been set"
81 , stDisplayOptions = DisplayOptions.standard
83 , stActiveCanvas = Net
86 , stOkButton = error "State.empty: Ok button has not been set"
87 , stReduceButton = error "State.empty: Reduce button has not been set"
88 , stContinueReduct = True
94 getDocument :: State g n e -> IO (PD.PersistentDocument (Document g n e))
95 getDocument = getFromState stDocument
97 getDragging :: State g n e -> IO (Maybe (Bool, DoublePoint))
98 getDragging = getFromState stDragging
100 getNetworkFrame :: State g n e -> IO (Frame ())
101 getNetworkFrame = getFromState stNetworkFrame
103 getCanvas :: State g n e -> IO (ScrolledWindow ())
104 getCanvas = getFromState stCanvas
106 getLHSCanvas :: State g n e -> IO (ScrolledWindow ())
107 getLHSCanvas = getFromState stLHSCanvas
109 getRHSCanvas :: State g n e -> IO (ScrolledWindow ())
110 getRHSCanvas = getFromState stRHSCanvas
112 getPalettePanel :: State g n e -> IO (Panel ())
113 getPalettePanel = getFromState stPalettePanel
115 getPageSetupDialog :: State g n e -> IO (PageSetupDialog ())
116 getPageSetupDialog = getFromState stPageSetupDialog
118 getDisplayOptions :: State g n e -> IO DisplayOptions
119 getDisplayOptions = getFromState stDisplayOptions
121 getCurrentShape :: State g n e -> IO String
122 getCurrentShape = getFromState stShape
124 getActiveCanvas :: State g n e -> IO ActiveCanvas
125 getActiveCanvas = getFromState stActiveCanvas
127 getActiveRule :: State g n e -> IO RuleName
128 getActiveRule = getFromState stActiveRule
130 getTree :: State g n e -> IO (TreeCtrl () )
131 getTree = getFromState stTree
133 getShape1 :: State g n e -> IO (Maybe String )
134 getShape1 = getFromState stShape1
136 getShape2 :: State g n e -> IO (Maybe String )
137 getShape2 = getFromState stShape2
139 getOkButton :: State g n e -> IO (Button () )
140 getOkButton = getFromState stOkButton
142 getReduceButton :: State g n e -> IO (Button () )
143 getReduceButton = getFromState stReduceButton
145 getContinueReduction :: State g n e -> IO Bool
146 getContinueReduction = getFromState stContinueReduct
151 setDragging :: Maybe (Bool, DoublePoint) -> State g n e -> IO ()
152 setDragging theDragging stateRef =
153 varUpdate_ stateRef (\state -> state { stDragging = theDragging })
155 setNetworkFrame :: Frame () -> State g n e -> IO ()
156 setNetworkFrame networkFrame stateRef =
157 varUpdate_ stateRef (\state -> state { stNetworkFrame = networkFrame })
159 setCanvas :: ScrolledWindow () -> State g n e -> IO ()
160 setCanvas canvas stateRef =
161 varUpdate_ stateRef (\state -> state { stCanvas = canvas })
163 setLHSCanvas :: ScrolledWindow () -> State g n e -> IO ()
164 setLHSCanvas canvas stateRef =
165 varUpdate_ stateRef (\state -> state { stLHSCanvas = canvas })
167 setRHSCanvas :: ScrolledWindow () -> State g n e -> IO ()
168 setRHSCanvas canvas stateRef =
169 varUpdate_ stateRef (\state -> state { stRHSCanvas = canvas })
171 setPalettePanel :: Panel () -> State g n e -> IO ()
172 setPalettePanel panel stateRef =
173 varUpdate_ stateRef (\state -> state { stPalettePanel = panel })
175 setPageSetupDialog :: PageSetupDialog () -> State g n e -> IO ()
176 setPageSetupDialog thePageSetupDialog stateRef =
177 varUpdate_ stateRef (\state -> state { stPageSetupDialog = thePageSetupDialog })
179 setDisplayOptions :: DisplayOptions -> State g n e -> IO ()
180 setDisplayOptions dp stateRef =
181 varUpdate_ stateRef (\state -> state { stDisplayOptions = dp })
183 changeDisplayOptions :: (DisplayOptions->DisplayOptions) -> State g n e -> IO ()
184 changeDisplayOptions dpf stateRef =
186 (\state -> state { stDisplayOptions = dpf (stDisplayOptions state) })
188 setCurrentShape :: String -> State g n e -> IO ()
189 setCurrentShape shapeName stateRef =
190 varUpdate_ stateRef (\state -> state { stShape = shapeName })
192 setActiveCanvas :: ActiveCanvas -> State g n e -> IO ()
193 setActiveCanvas activeCanvas stateRef =
194 do rule <- getActiveRule stateRef
195 let activeCanvas' = case activeCanvas of
197 LHS str | null str -> LHS rule
198 | otherwise -> LHS str
199 RHS str | null str -> RHS rule
200 | otherwise -> RHS str
201 varUpdate_ stateRef (\state -> state { stActiveCanvas = activeCanvas' })
203 setActiveRule :: RuleName -> State g n e -> IO ()
204 setActiveRule activeRule stateRef =
205 varUpdate_ stateRef (\state -> state { stActiveRule = activeRule })
207 setTree :: TreeCtrl () -> State g n e -> IO ()
208 setTree tree stateRef =
209 varUpdate_ stateRef (\state -> state { stTree = tree })
211 setShape1 :: Maybe String -> State g n e -> IO ()
212 setShape1 shape1 stateRef =
213 varUpdate_ stateRef (\state -> state { stShape1 = shape1 })
215 setShape2 :: Maybe String -> State g n e -> IO ()
216 setShape2 shape2 stateRef =
217 varUpdate_ stateRef (\state -> state { stShape2 = shape2 })
219 setOkButton :: Button () -> State g n e -> IO ()
220 setOkButton okButton stateRef =
221 varUpdate_ stateRef (\state -> state { stOkButton = okButton })
223 setReduceButton :: Button () -> State g n e -> IO ()
224 setReduceButton reduceButton stateRef =
225 varUpdate_ stateRef (\state -> state { stReduceButton = reduceButton })
227 setContinueReduction :: Bool -> State g n e -> IO ()
228 setContinueReduction continue stateRef =
229 varUpdate_ stateRef (\state -> state { stContinueReduct = continue })
232 disableReduce :: State g n e -> IO ()
233 disableReduce state = return ()
234 -- do button <- getReduceButton state
235 -- set button [enabled := False]
237 stopReduction :: State g n e -> IO ()
238 stopReduction = setContinueReduction False
242 getFromState :: (StateRecord g n e -> a) -> State g n e -> IO a
243 getFromState selector stateRef = do
244 state <- varGet stateRef
245 return (selector state)
247 varUpdate_ :: Var a -> (a -> a) -> IO ()
248 varUpdate_ var fun = do { varUpdate var fun; return () }