Thu Jan 19 18:39:55 WET 2006 Miguel Vilaca <jmvilaca@di.uminho.pt>
* New tool layout with new components
This patch adds several new graphical components to support features of the tool.
That includes a visible palette which builds a button for each shape, painting the button with the drawn shape.
The state also changes to have the current selected shape.
At start-up the first shape is chosen as the default one.
{
hunk ./src/Network.hs 60
+import qualified Data.List
+
hunk ./src/Network.hs 66
- , networkPalette :: Palette n
+ , networkPalette :: Palette n -- ^ the current 'Palette'
hunk ./src/Network.hs 368
- => Network g n e -- ^ the network to add the node to
+ => String -- ^ the current shape's name
+ -> Network g n e -- ^ the network to add the node to
hunk ./src/Network.hs 372
-addNode network =
+addNode shape network =
hunk ./src/Network.hs 376
- (Right Shape.circle)
+ (Left shape)
hunk ./src/Network.hs 381
+ palette = shapes $ getPalette network
+
hunk ./src/Network.hs 384
-addNodes :: InfoKind n g => Int -> Network g n e -> ([NodeNr], Network g n e)
-addNodes 0 network = ([], network)
-addNodes n network1 =
- let (nodeNr, network2) = addNode network1
- (nodeNrs, network3) = addNodes (n-1) network2
+addNodes :: InfoKind n g => String -> Int -> Network g n e -> ([NodeNr], Network g n e)
+addNodes _ 0 network = ([], network)
+addNodes shapeName n network1 =
+ let (nodeNr, network2) = addNode shapeName network1
+ (nodeNrs, network3) = addNodes shapeName (n-1) network2
hunk ./src/NetworkControl.hs 96
- ; doc1 <- PD.getDocument pDoc
- ; let (nodeNr, doc2) = updateNetworkEx addNode doc1
- doc3 = updateNetwork (updateNode nodeNr (setPosition mousePoint)) doc2
+ ; shapeName <- getCurrentShape state
+ ; doc1 <- PD.getDocument pDoc [_$_]
+ ; let (nodeNr, doc2) = updateNetworkEx (addNode shapeName) doc1
+ doc3 = updateNetwork (updateNode nodeNr ( setPosition mousePoint) ) doc2
hunk ./src/NetworkUI.hs 19
+import Shape
+import Math
hunk ./src/NetworkUI.hs 59
- do{ theFrame <- frame [ text := "Diagram editor"
+
+{-^ Containment structure of widgets: [_$_]
+
+ * theFrame :: Frame ()
+ ** mainPan :: Panel ()
+ *** sp :: SplitterWindow ()
+ **** sp1 :: SplitterWindow ()
+ ***** sp2 :: SplitterWindow ()
+ ****** palettePan :: Panel ()
+ ****** rulesTreePan :: Panel ()
+ ***** sp3 :: SplitterWindow ()
+ ****** sp4 :: SplitterWindow ()
+ ******* ruleLHSPan :: Panel ()
+ ******* ruleRHSPan :: Panel ()
+ ****** canvas
+ **** textlog :: TextCtrl ()
+-} [_$_]
+
+ do{ theFrame <- frame [ text := "Diagram editor"
hunk ./src/NetworkUI.hs 81
+
+ -- Panels and SplitterWindows
+ ; mainPan <- panel theFrame []
+ ; sp <- splitterWindow mainPan []
+ ; sp1 <- splitterWindow sp []
+ ; sp2 <- splitterWindow sp1 []
+ ; sp3 <- splitterWindow sp1 []
+ [_$_]
+ -- create a panel and put the Visible Palette with buttons on it [_$_]
+ ; palettePan <- panel sp2 [] [_$_]
+ ; setPalettePanel palettePan state
+
+ ; rulesTreePan <- panel sp2 [layout := label "rules Tree"]
+ ; sp4 <- splitterWindow sp3 []
+ ; ruleLHSPan <- panel sp4 [layout := label "LHS of a rule" ] [_$_]
+ ; ruleRHSPan <- panel sp4 [layout := label "RHS of a rule" ] [_$_]
hunk ./src/NetworkUI.hs 107
- ; canvas <- scrolledWindow theFrame
+ ; canvas <- scrolledWindow sp3
hunk ./src/NetworkUI.hs 279
+ [_$_]
+ [_$_]
+ ; openPaletteFile palette state (Just theFrame) [_$_]
+ [_$_]
+
+ -- to debug purposes [_$_]
+ ; textlog <- textCtrl sp [enabled := False, wrap := WrapNone] [_$_]
+ -- use text control as logger
+ ; textCtrlMakeLogActiveTarget textlog
+ ; logMessage "logging enabled"
hunk ./src/NetworkUI.hs 293
- , layout := minsize (sz 300 240) $ fill $ widget canvas
+ , layout := container mainPan $ margin 5 $ fill $
+ hsplit sp 5 350 ( -- to remove. just for debug [_$_]
+ vsplit sp1 5 200 [_$_]
+ (hsplit sp2 5 200 [_$_]
+ (widget palettePan) [_$_]
+ (widget rulesTreePan) )
+ (hsplit sp3 5 150
+ (vsplit sp4 5 300
+ (widget ruleLHSPan)
+ (widget ruleRHSPan) )
+ (fill $ widget canvas) ) [_$_]
+ )(widget textlog) -- to remove. just for debug [_$_]
+
+
+ , clientSize := sz 400 440
+ , statusBar := []
hunk ./src/NetworkUI.hs 474
+ ; let palette = removeQuotesFromNames p
hunk ./src/NetworkUI.hs 476
- (updateNetwork (setPalette p))
+ (updateNetwork (setPalette palette))
hunk ./src/NetworkUI.hs 480
+ --; put here code to rebuild Visible Palette
+ -- the shape name of the first palette element is choosed
+ -- as the default one
+ ; setCurrentShape (fst . head . shapes $ palette) state
+
+ ; buildVisiblePalette state
hunk ./src/NetworkUI.hs 488
+ where remQuot = init . tail
+ removeQuotesFromNames = Palette . map (\(a,b) -> (remQuot a, b) ) . shapes [_$_]
hunk ./src/NetworkUI.hs 515
+
+-- Code for build the Visible Palette
+
+buildVisiblePalette :: InfoKind n g => State g n e -> IO ()
+buildVisiblePalette state =
+ do{ pDoc2 <- getDocument state
+ ; pp <- getPalettePanel state
+ ; doc <- PD.getDocument pDoc2
+ ; let palette = getPalette (getNetwork doc)
+ ; list <- mapM (drawNodeButton pp state) . shapes $ palette
+ ; let table = list2Table 2 list [_$_]
+
+ ; set pp [layout := boxed "Palette" (grid 4 4 table) ]
+ --; refit pp
+
+ -- should redraw the all window acordingly
+ --; windo <- getNetworkFrame state
+ --; refit windo
+
+ ; return ()
+ }
+
+drawNodeButton :: InfoKind n g => Window w -> State g n e -> (String, (Shape, Maybe n)) -> IO Layout
+drawNodeButton w state (name, (shape, _info)) = [_$_]
+ do{ frame <- getNetworkFrame state
+ ; doc <- getDocument state
+ ; node <- button w [ text := name
+ -- , clientSize := sz 50 50 -- due to a wxHaskell problem forcing the size don't works
+ , on command := setCurrentShape name state
+ , bgcolor := white [_$_]
+ , on paint := \dc r -> safetyNet frame $ logicalDraw ppi dc (center r) shape []
+
+ -- , checked := True
+ ]
+ ; return (widget node)
+ }
+ where factor f (DoublePoint x y) = DoublePoint (x/f) (y/f)
+ ppi = (sz 40 40) -- (rectSize r) this is the correct code if
+ center r = factor 14.0 $ intPointToDoublePoint $ rectCentralPoint r
+
+
+-- | Transforms a list in a table of n columns
+list2Table :: Int -> [a] -> [[a]]
+list2Table n l | null l = []
+ | otherwise = a : list2Table n b [_$_]
+ where (a,b) = splitAt n l
+
hunk ./src/State.hs 9
+ , getPalettePanel, setPalettePanel
hunk ./src/State.hs 14
+ , getCurrentShape, setCurrentShape
hunk ./src/State.hs 32
+ , stPalettePanel :: Panel ()
hunk ./src/State.hs 35
+ , stShape :: String -- the name of the shape in the palette
hunk ./src/State.hs 52
+ , stPalettePanel = error "State.empty: panel has not been set"
hunk ./src/State.hs 72
+getPalettePanel :: State g n e -> IO (Panel ())
+getPalettePanel = getFromState stPalettePanel
+
hunk ./src/State.hs 81
+getCurrentShape :: State g n e -> IO String
+getCurrentShape = getFromState stShape
+
hunk ./src/State.hs 98
+setPalettePanel :: Panel () -> State g n e -> IO ()
+setPalettePanel panel stateRef =
+ varUpdate_ stateRef (\state -> state { stPalettePanel = panel })
+
hunk ./src/State.hs 109
+
+setCurrentShape :: String -> State g n e -> IO ()
+setCurrentShape shapeName stateRef =
+ varUpdate_ stateRef (\state -> state { stShape = shapeName })
addfile ./startghc.bat
hunk ./startghc.bat 1
+ghc -ffi -package wx -package HaXml -package lang -Wall -fglasgow-exts -ilib\DData:src src\Main.hs --make -o INblobs.exe [_$_]
+@rem voor GHC 6.4: -ignore-package network-1.0
+
}