Blobs 0.2 → 0.3
raw patch · 24 files changed
+800/−548 lines, 24 filesdep −haskell98dep ~HaXml
Dependencies removed: haskell98
Dependency ranges changed: HaXml
Files
- Blobs.cabal +12/−7
- README.md +19/−0
- src/Graphics/Blobs/Colors.hs +24/−0
- src/Graphics/Blobs/Common.hs +2/−3
- src/Graphics/Blobs/CommonIO.hs +42/−17
- src/Graphics/Blobs/ContextMenu.hs +9/−1
- src/Graphics/Blobs/DisplayOptions.hs +1/−1
- src/Graphics/Blobs/GUIEvents.hs +2/−2
- src/Graphics/Blobs/InfoKind.hs +47/−2
- src/Graphics/Blobs/Math.hs +73/−7
- src/Graphics/Blobs/Network.hs +248/−11
- src/Graphics/Blobs/NetworkControl.hs +152/−27
- src/Graphics/Blobs/NetworkFile.hs +0/−401
- src/Graphics/Blobs/NetworkUI.hs +15/−18
- src/Graphics/Blobs/NetworkView.hs +25/−24
- src/Graphics/Blobs/Operations.hs +0/−1
- src/Graphics/Blobs/PDDefaults.hs +4/−4
- src/Graphics/Blobs/Palette.hs +18/−3
- src/Graphics/Blobs/PersistentDocument.hs +1/−1
- src/Graphics/Blobs/SafetyNet.hs +1/−1
- src/Graphics/Blobs/Shape.hs +79/−6
- src/Graphics/Blobs/State.hs +7/−3
- src/Graphics/Blobs/StateUtil.hs +1/−1
- src/Main.hs +18/−7
Blobs.cabal view
@@ -1,5 +1,5 @@ Name: Blobs-Version: 0.2+Version: 0.3 License: LGPL License-file: LICENCE-LGPL Author: Arjan van IJzendoorn, Martijn Schrage, Malcolm Wallace@@ -32,8 +32,14 @@ simple.blobpalette, wiring.blobs library- Build-Depends: base >= 4 && < 5, haskell98, wx >= 0.9, wxcore >= 0.9, HaXml >= 1.14- , polyparse, directory, pretty, containers+ Build-Depends: base >= 4 && < 5+ , wx >= 0.9+ , wxcore >= 0.9+ , HaXml >= 1.22.5+ , polyparse+ , directory+ , pretty+ , containers Hs-Source-Dirs: src lib/DData exposed-modules: Graphics.Blobs.Colors , Graphics.Blobs.Common@@ -58,16 +64,15 @@ , Graphics.Blobs.Shape , Graphics.Blobs.State , Graphics.Blobs.StateUtil- -- , Graphics.Blobs.XTC -- other-modules: Graphics.Blobs- ghc-options: -Wall+ ghc-options: -Wall -fno-warn-unused-do-bind executable blobs main-is: Main.hs- Build-Depends: base >= 4 && < 5, haskell98, wx >= 0.9, wxcore >= 0.9, HaXml >= 1.14+ Build-Depends: base >= 4 && < 5, wx >= 0.9, wxcore >= 0.9, HaXml >= 1.14 , polyparse, directory, pretty, containers Hs-Source-Dirs: src lib/DData- ghc-options: -Wall+ ghc-options: -Wall -fno-warn-unused-do-bind source-repository head type: git
README.md view
@@ -3,7 +3,26 @@ Blobs from http://www.cs.york.ac.uk/fp/darcs/Blobs/ +Note: wxc-0.90.0.3 fails to compile, see+https://sourceforge.net/tracker/?func=detail&atid=536845&aid=3536406&group_id=73133+++A workaround: wxc install fails with eljpen.cpp not compiling.++Change line 159 to++ *_ref = ((const char* const*)NULL);++from++ *_ref = NULL;+++ Changes++0.3 Introduce class GuiEdit and GuiGlobalEdit to allow custom dialogs+ for editing the global,node and edge attributes 0.2 Move the contents into the Graphics.Blobs namespace
src/Graphics/Blobs/Colors.hs view
@@ -3,7 +3,9 @@ import Graphics.UI.WX import Text.Parse +import qualified Text.XML.HaXml.XmlContent.Haskell as XML + -- Different spelling of colour/color to distinguish local/wx datatypes. data Colour = RGB !Int !Int !Int deriving (Eq,Show,Read) @@ -84,3 +86,25 @@ orangeRed = RGB 255 69 0 gold = RGB 255 215 0 darkSlateGray = RGB 47 79 79++-- ---------------------------------------------------------------------+-- Migrating orphan instances home++{- derived by DrIFT -}+instance XML.HTypeable Colour where+ toHType v = XML.Defined "Colour" []+ [XML.Constr "RGB" [] [XML.toHType aa,XML.toHType ab,XML.toHType ac]]+ where (RGB aa ab ac) = v+instance XML.XmlContent Colour where+ parseContents = do+ { XML.inElement "RGB" $ do+ { aa <- XML.parseContents+ ; ab <- XML.parseContents+ ; ac <- XML.parseContents+ ; return (RGB aa ab ac)+ }+ }+ toContents v@(RGB aa ab ac) =+ [XML.mkElemC (XML.showConstr 0 (XML.toHType v))+ (concat [XML.toContents aa, XML.toContents ab, XML.toContents ac])]+
src/Graphics/Blobs/Common.hs view
@@ -1,12 +1,11 @@ module Graphics.Blobs.Common (module Graphics.Blobs.Common {-, module IOExts-}, module Graphics.Blobs.Colors) where import Graphics.Blobs.Colors--- import IOExts(trace) import Debug.Trace (trace) import qualified Data.IntMap as IntMap-import Char(isSpace)+import Data.Char(isSpace) import GHC.Float(formatRealFloat, FFFormat(FFFixed))-import List+import Data.List -- | return a list of all cartesian products for a list of lists -- e.g. products [[1,2],[3,4]] = [[1,3],[1,4],[2,3],[2,4]]
src/Graphics/Blobs/CommonIO.hs view
@@ -1,14 +1,15 @@ module Graphics.Blobs.CommonIO where -import Graphics.Blobs.Math+import Data.Char+import Data.List(elemIndex) import Graphics.Blobs.Common(ifJust, internalError, tabDelimited, safeIndex, systemGrey)+import Graphics.Blobs.Math import Graphics.Blobs.SafetyNet- import Graphics.UI.WX import Graphics.UI.WXCore-import List(elemIndex) import System.Directory import System.IO+import Text.Parse ignoreResult :: IO a -> IO () ignoreResult action = do { action; return () }@@ -64,10 +65,10 @@ myTextDialog :: Window a -> TextCtrlSize -> String -> String -> Bool -> IO (Maybe String)-myTextDialog parentWindow size dialogTitle initial selectAll =+myTextDialog parentWindow lineSize dialogTitle initial selectAll = do{ d <- dialog parentWindow [text := dialogTitle]- ; textInput <- (case size of SingleLine -> textEntry;- MultiLine -> textCtrl)+ ; textInput <- (case lineSize of SingleLine -> textEntry;+ MultiLine -> textCtrl) d [ alignment := AlignLeft, text := initial ] ; ok <- button d [text := "Ok"] ; can <- button d [text := "Cancel", identity := wxID_CANCEL]@@ -77,17 +78,17 @@ ] -- ,clientSize := case size of SingleLine -> sz 300 40 -- MultiLine -> sz 500 200- ,area := case size of SingleLine -> rect (pt 50 50) (sz 300 80)- MultiLine -> rect (pt 50 50) (sz 500 250)+ ,area := case lineSize of SingleLine -> rect (pt 50 50) (sz 300 80)+ MultiLine -> rect (pt 50 50) (sz 500 250) ] ; when (selectAll) $ do textCtrlSetSelection textInput 0 250 ; when (not selectAll) $ do textCtrlSetInsertionPointEnd textInput set d [ visible := True ]- ; showModal d $ \stop ->+ ; showModal d $ \stop1 -> do set ok [on command := safetyNet parentWindow $ do theText <- get textInput text- stop (Just theText)]- set can [on command := safetyNet parentWindow $ stop Nothing]+ stop1 (Just theText)]+ set can [on command := safetyNet parentWindow $ stop1 Nothing] } -- Dialog for selecting a multiple Strings (0 or more)@@ -129,12 +130,12 @@ ] , clientSize := sz 300 400 ]- ; showModal d $ \stop ->+ ; showModal d $ \stop1 -> do set ok [on command := safetyNet parentWindow $ do indices <- get theListBox selections- stop (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))]+ stop1 (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))] set can [on command := safetyNet parentWindow $- stop Nothing]+ stop1 Nothing] } -- Dialog for selecting a single String@@ -162,12 +163,12 @@ ] , clientSize := sz 300 400 ]- ; showModal d $ \stop ->+ ; showModal d $ \stop1 -> do set ok [on command := safetyNet parentWindow $ do index <- get theListBox selection- stop (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))]+ stop1 (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))] set can [on command := safetyNet parentWindow $- stop Nothing]+ stop1 Nothing] } -- | Fill a grid from a list of lists of texts. Each list inside the@@ -337,3 +338,27 @@ do { fixIO fIO ; return () }++-- ---------------------------------------------------------------------++aTextDialog :: (Show a, Parse a1) =>+ Window a2 -> String -> a -> IO (Maybe a1)+aTextDialog parentWindow dialogTitle initial = do+ result <- myTextDialog parentWindow MultiLine dialogTitle (show initial) True+ case result of+ Just str ->+ case runParser parse str of+ (Right x, s) ->+ do{ when (not (null s || all isSpace s)) $+ (errorDialog parentWindow "Edit warning"+ ("Excess text after parsed value."+ ++"\nRemaining text: "++s))+ ; return (Just x);+ }+ (Left err, s) -> do+ errorDialog parentWindow "Edit warning"+ ("Cannot parse entered text."+ ++"\nReason: "++err+ ++"\nRemaining text: "++s)+ return Nothing+ Nothing -> return Nothing
src/Graphics/Blobs/ContextMenu.hs view
@@ -70,6 +70,10 @@ [ text := "Edit info (i)" , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state ]+ ; menuItem contextMenu+ [ text := "Edit info userfunc (u)"+ , on command := safetyNet theFrame $ reinfoNodeOrEdgeUser theFrame state+ ] ; menuLine contextMenu ; menuItem contextMenu [ text := "from port "++show fromPort@@ -119,6 +123,10 @@ , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state ] ; menuItem contextMenu+ [ text := "Edit info userfunc (u)"+ , on command := safetyNet theFrame $ reinfoNodeOrEdgeUser theFrame state+ ]+ ; menuItem contextMenu [ text := "Change arity (in/"++show i++", out/"++show o++")" , on command := safetyNet theFrame $ reArityNode theFrame state ]@@ -152,7 +160,7 @@ Left n -> case lookup n (shapes palette) of Nothing -> const theInfo Just (_,Nothing) -> const theInfo- Just (_,Just i) -> if i==theInfo then id+ Just (_,Just info) -> if info==theInfo then id else const theInfo Right _ -> const theInfo ; menuItem contextMenu
src/Graphics/Blobs/DisplayOptions.hs view
@@ -1,6 +1,6 @@ module Graphics.Blobs.DisplayOptions where -import List ((\\))+import Data.List ((\\)) type ShowInfo = [What] data What = GlobalInfo | NodeLabel | NodeInfo | EdgeInfo deriving (Eq)
src/Graphics/Blobs/GUIEvents.hs view
@@ -1,6 +1,6 @@ module Graphics.Blobs.GUIEvents where -import List (nub,(\\))+import Data.List (nub,(\\)) import Graphics.Blobs.NetworkView(clickedNode, clickedEdge, clickedVia) import Graphics.Blobs.NetworkControl import Graphics.Blobs.State@@ -13,7 +13,7 @@ import Text.Parse import Graphics.UI.WX-import Graphics.UI.WXCore+--import Graphics.UI.WXCore mouseDown :: (InfoKind n g, InfoKind e g, Show g, Parse g, Descriptor g) => Bool -> Point -> Frame () -> State g n e -> IO ()
src/Graphics/Blobs/InfoKind.hs view
@@ -5,30 +5,55 @@ module Graphics.Blobs.InfoKind where import Text.Parse---import Text.XML.HaXml.XmlContent import Text.XML.HaXml.XmlContent.Haskell+import Graphics.UI.WX+import Graphics.Blobs.CommonIO -- | The @InfoKind@ class is a predicate that ensures we can always create -- at least a blank (empty) information element, that we can read and -- write them to/from the user, and that there exists some method of -- determining the correctness of the value (completeness/consistency etc) -- against some global type.-class (Eq a, Show a, Parse a, XmlContent a) => InfoKind a g | a -> g where+class (Eq a, Show a, Parse a, XmlContent a, XmlContent g, {- GuiEdit a,-} GuiEdit g, GuiGlobalEdit a g) =>+ InfoKind a g | a -> g where blank :: a check :: String -> g -> a -> [String] -- returns warnings -- ^ first arg is container label for error reporting. -- second arg is global value + -- A basic instance representing "no info" instance InfoKind () () where blank = () check _ _ () = []++instance GuiEdit () where+ editDialog parentWindow dialogTitle initial = aTextDialog parentWindow dialogTitle initial++instance GuiGlobalEdit () g where+ editDialogWithGlobal parentWindow dialogTitle initial _global = aTextDialog parentWindow dialogTitle initial++ -- Assume that info is mandatory, but not supplied a priori. instance InfoKind a b => InfoKind (Maybe a) b where blank = Nothing check n _ Nothing = ["No info value stored with "++n] check n g (Just a) = check n g a +instance Descriptor a => Descriptor (Maybe a) where+ descriptor Nothing = "Nothing"+ descriptor (Just x) = "Just (" ++ (descriptor x) ++ ")"++{-+instance (Show a,Parse a, Descriptor a) => GuiEdit (Maybe a) where+ editDialog _a = undefined+-}+++instance (Show a,Parse a, Descriptor a) => GuiGlobalEdit (Maybe a) b where+ editDialogWithGlobal _a _b = undefined++ -- A "showType"-style class. Descriptor should always ignore its argument, -- and return a constant string describing the type instead. class (Show a) => Descriptor a where@@ -36,6 +61,26 @@ descriptor _ = "type descriptor was left undefined" instance Descriptor () where descriptor _ = "null global info type"++-- -----------------------------------------------++-- A class of things that can be edited in a GUI, falling back to a+-- simple text editor using Parse/Show+class (Show a,Parse a,Descriptor a) => GuiEdit a where+ editDialog :: Window a1 -- ^ Parent frame+ -> String -- ^ Window title+ -> a -- ^ Existing value+ -> IO (Maybe a) -- ^ Updated value if changed++-- A class of things that can be edited in a GUI, falling back to a+-- simple text editor using Parse/Show+class (Show a,Parse a,Descriptor a) => GuiGlobalEdit a g where+ editDialogWithGlobal :: Window a1 -- ^ Parent frame+ -> String -- ^ Window title+ -> a -- ^ Existing value+ -> g -- ^ Global value, for reference+ -> IO (Maybe a) -- ^ Updated value if changed+ -- ----------------------------------------------- {-
src/Graphics/Blobs/Math.hs view
@@ -13,18 +13,26 @@ , origin , translate , enclosedInRectangle++ -- For XML I/O+ , makeTag+ , tagWithId+ , simpleString+ , escapeString+ , comment+ , commentEscape ) where import Graphics.UI.WX(Point, point, pointX, pointY) import Text.Parse -{--data DoublePoint = DoublePoint- { doublePointX :: !Double- , doublePointY :: !Double- }- deriving (Show, Eq, Read)--}+import qualified Text.XML.HaXml.XmlContent.Haskell as XML+import Data.Char+import Text.XML.HaXml.Escape+import Text.XML.HaXml.Types++-- ---------------------------------------------------------------------+ data DoublePoint = DoublePoint !Double !Double deriving (Show, Eq, Read) @@ -35,7 +43,10 @@ data Vector = Vector !Double !Double +doublePointX :: DoublePoint -> Double doublePointX (DoublePoint x _) = x++doublePointY :: DoublePoint -> Double doublePointY (DoublePoint _ y) = y origin :: DoublePoint@@ -108,3 +119,58 @@ where between i j k | j <= k = j <= i && i <= k | otherwise = k <= i && i <= j++-- ---------------------------------------------------------------------+-- Moving orphan instances home+instance XML.HTypeable DoublePoint where+ toHType _ = XML.Defined "DoublePoint" [] [XML.Constr "X" [] [], XML.Constr "Y" [] []]+instance XML.XmlContent DoublePoint where+ toContents (DoublePoint x y) =+ [ simpleString "X" (show x)+ , simpleString "Y" (show y)+ ]+ parseContents = do+ { x <- XML.inElement "X" $ fmap read XML.text+ ; y <- XML.inElement "Y" $ fmap read XML.text+ ; return (DoublePoint x y)+ }+++---- UTILITY FUNCTIONS++-- Abbreviations+makeTag :: String -> [XML.Content i] -> XML.Content i+makeTag tagName children = XML.CElem (XML.Elem (N tagName) [] children) undefined++tagWithId :: String -> String -> [XML.Content i] -> XML.Content i+tagWithId tagName identity children =+ XML.CElem (XML.Elem (N tagName) [(N "id", XML.AttValue [Left identity])] children) undefined++-- | A simple string contains no spaces or unsafe characters+simpleString :: String -> String -> XML.Content i+simpleString tag value =+ XML.CElem (XML.Elem (N tag) [] [ XML.CString False value undefined ]) undefined++-- | The string value may contain spaces and unsafe characters+escapeString :: String -> String -> XML.Content i+escapeString key value =+ XML.CElem ((if isSafe value then id else escape) $+ XML.Elem (N key) [] [ XML.CString (any isSpace value) value undefined ])+ undefined+ where+ isSafe cs = all isSafeChar cs+ isSafeChar c = isAlpha c || isDigit c || c `elem` "- ."++ escape :: XML.Element i -> XML.Element i+ escape = xmlEscape stdXmlEscaper++comment :: String -> XML.Content i+comment s = XML.CMisc (Comment (commentEscape s)) undefined++-- Replace occurences of "-->" with "==>" in a string so that the string+-- becomes safe for an XML comment+commentEscape :: String -> String+commentEscape [] = []+commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs+commentEscape (x:xs) = x : commentEscape xs+
src/Graphics/Blobs/Network.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} module Graphics.Blobs.Network ( -- * Types@@ -53,6 +54,7 @@ , setEdgeFrom, setEdgeTo, setEdgeVia, setEdgeInfo , getEdgeFromPort, getEdgeToPort , setEdgeFromPort, setEdgeToPort+ ) where import Graphics.Blobs.Common@@ -63,6 +65,13 @@ import qualified Data.IntMap as IntMap -- hiding (map) +import Text.XML.HaXml.Combinators (replaceAttrs)+import Text.XML.HaXml.Types+import Text.XML.HaXml.Verbatim+import qualified Text.XML.HaXml.XmlContent.Haskell as XML+import Data.List(nub)+import Control.Monad(when)+ data Network g n e = Network { networkNodes :: !(IntMap.IntMap (Node n)) -- ^ maps node numbers to nodes , networkEdges :: !(IntMap.IntMap (Edge e)) -- ^ maps edge numbers to edges@@ -122,12 +131,12 @@ constructEdge :: NodeNr -> PortNr -> NodeNr -> PortNr -> [DoublePoint] -> e -> Edge e-constructEdge fromNr fromPort toNr toPort via info =+constructEdge fromNr fromPort toNr toPort via einfo = Edge { edgeFrom = fromNr , edgeTo = toNr , edgeVia = via- , edgeInfo = info+ , edgeInfo = einfo , edgeFromPort = fromPort , edgeToPort = toPort }@@ -166,18 +175,18 @@ setEdgeVia via edge = edge { edgeVia = via } setEdgeInfo :: e -> Edge oldInfo -> Edge e-setEdgeInfo info edge = edge { edgeInfo = info }+setEdgeInfo einfo edge = edge { edgeInfo = einfo } constructNode :: (InfoKind n g) => String -> DoublePoint -> Bool -> Either String Shape.Shape -> n -> Maybe (PortNr,PortNr) -> Node n-constructNode name position nameAbove shape info arity =+constructNode name position nameAbove shape ninfo arity = Node { nodeName = name , nodePosition = position , nodeNameAbove = nameAbove , nodeShape = shape- , nodeInfo = info+ , nodeInfo = ninfo , nodeArity = arity } @@ -218,8 +227,8 @@ getNodeInfo network nodeNr = nodeInfo (networkNodes network IntMap.! nodeNr) setNodeInfo :: NodeNr -> n -> Network g n e -> Network g n e-setNodeInfo nodeNr info network =- network { networkNodes = IntMap.insert nodeNr (node { nodeInfo = info }) (networkNodes network) }+setNodeInfo nodeNr ninfo network =+ network { networkNodes = IntMap.insert nodeNr (node { nodeInfo = ninfo }) (networkNodes network) } where node = networkNodes network IntMap.! nodeNr getNodeArity :: Network g n e -> NodeNr -> Maybe (PortNr,PortNr)@@ -264,7 +273,7 @@ setPosition position node = node { nodePosition = position } setInfo :: a -> Node a -> Node a-setInfo info node = node { nodeInfo = info }+setInfo ninfo node = node { nodeInfo = ninfo } setArity :: Maybe (PortNr,PortNr) -> Node a -> Node a setArity arity node = node { nodeArity = arity }@@ -430,13 +439,13 @@ String -> DoublePoint -> Bool -> Either String Shape.Shape -> n -> Maybe (PortNr,PortNr) -> Network g n e -> (NodeNr, Network g n e)-addNodeEx name position labelAbove shape info arity network =+addNodeEx name position labelAbove shape ninfo arity network = ( nodeNr , network { networkNodes = IntMap.insert nodeNr node (networkNodes network) } ) where nodeNr = getUnusedNodeNr network- node = constructNode name position labelAbove shape info arity+ node = constructNode name position labelAbove shape ninfo arity -- | Add an edge to the network.@@ -544,7 +553,7 @@ setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize } setGlobalInfo :: g -> Network g n e -> Network g n e-setGlobalInfo info network = network { networkInfo = info }+setGlobalInfo ninfo network = network { networkInfo = ninfo } {----------------------------------- Local functions@@ -577,3 +586,231 @@ IntMap.adjust (\e-> e { edgeVia = take viaNr (edgeVia e) ++[v]++drop (viaNr+1) (edgeVia e) }) edgeNr (networkEdges network) }++-- ---------------------------------------------------------------------+-- Orphan instances moved from NetworkFile++instance (XML.HTypeable g, XML.HTypeable n, XML.HTypeable e)+ => XML.HTypeable (Network g n e) where+ toHType _ = XML.Defined "Network" [] [XML.Constr "Network" [] []]+ -- toHType g = Defined "Network" [] [Constr "Network" []+ -- [ Tagged "Width" [String]+ -- , Tagged "Height" [String]+ -- , toHType (getGlobalInfo g)+ -- , toHType (getPalette g)+ -- , toHType (getNodeAssocs g)+ -- , toHType (getEdgeAssocs g)+ -- ]]+instance (InfoKind n g, InfoKind e g, XML.XmlContent g) =>+ XML.XmlContent (Network g n e) where+ toContents network =+ [XML.CElem (XML.Elem (N "Network") []+ [ simpleString "Width" (show width)+ , simpleString "Height" (show height)+ , makeTag "Info" (XML.toContents netInfo)+ , makeTag "Palette" (XML.toContents (getPalette network))+ , makeTag "Nodes" (concatMap XML.toContents nodeAssocs)+ , makeTag "Edges" (concatMap XML.toContents edgeAssocs)+ ]) () ]+ where+ nodeAssocs = map (uncurry AssocN) $ getNodeAssocs network+ edgeAssocs = map (uncurry AssocE) $ getEdgeAssocs network+ (width, height) = getCanvasSize network+ netInfo = getGlobalInfo network+ parseContents = do+ { XML.inElement "Network" $ do+ { w <- XML.inElement "Width" $ fmap read XML.text+ ; h <- XML.inElement "Height" $ fmap read XML.text+ ; i <- XML.inElement "Info" $ XML.parseContents+ ; p <- XML.inElement "Palette"$ XML.parseContents+ ; ns <- XML.inElement "Nodes" $ XML.many1 XML.parseContents+ ; es <- XML.inElement "Edges" $ XML.many1 XML.parseContents+ ; networkValid ns es+ ; return ( setCanvasSize (w,h)+ . setPalette p+ . setNodeAssocs (map deAssocN ns)+ . setEdgeAssocs (map deAssocE es)+ $ empty i undefined undefined)+ }+ }+++peekAttributes :: String -> XML.XMLParser [(QName,AttValue)]+peekAttributes t =+ do{ (p, e@(Elem _ as _)) <- XML.posnElement [t]+ ; XML.reparse [CElem e p]+ ; return as+ --; return fmap (\(N a,[Right v]) -> (a,v)) as+ }++instance XML.HTypeable (AssocN n) where+ toHType _ = XML.Defined "Node" [] [XML.Constr "Node" [] []]+instance (InfoKind n g) => XML.XmlContent (AssocN n) where+ toContents (AssocN n node) =+ concatMap (replaceAttrs [("id",'N':show n)]) (XML.toContents node)+ parseContents = do+ { [(N "id",n)] <- peekAttributes "Node"+ ; n' <- num n+ ; node <- XML.parseContents+ ; return (AssocN n' node)+ }+ where num (AttValue [Left ('N':n)]) = return (read n)+ num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)++instance XML.HTypeable (AssocE e) where+ toHType _ = XML.Defined "Edge" [] [XML.Constr "Edge" [] []]+instance (InfoKind e g) => XML.XmlContent (AssocE e) where+ toContents (AssocE n edge) =+ concatMap (replaceAttrs [("id",'E':show n)]) (XML.toContents edge)+ parseContents = do+ { [(N "id",n)] <- peekAttributes "Edge"+ ; n' <- num n+ ; edge <- XML.parseContents+ ; return (AssocE n' edge)+ }+ where num (AttValue [Left ('E':n)]) = return (read n)+ num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s)++instance XML.HTypeable (Node n) where+ toHType _ = XML.Defined "Node" [] [XML.Constr "Node" [] []]+instance (InfoKind n g) => XML.XmlContent (Node n) where+ toContents node =+ [ makeTag "Node"+ (XML.toContents (getPosition node) +++ [ escapeString "Name" (getName node)+ , simpleString "LabelAbove" (show (getNameAbove node))+ , makeTag "Shape" (XML.toContents (getShape node))+ , makeTag "Info" (XML.toContents (getInfo node))+ , makeTag "Arity" (XML.toContents (getArity node))+ ])+ ]+ parseContents = do+ { XML.inElement "Node" $ do+ { p <- XML.parseContents -- position+ ; n <- XML.inElement "Name" $ XML.text+ ; a <- XML.inElement "LabelAbove" $ fmap read XML.text+ ; s <- XML.inElement "Shape" $ XML.parseContents+ ; i <- XML.inElement "Info" $ XML.parseContents+ ; r <- (XML.inElement "Arity" $ XML.parseContents)+ `XML.onFail` (return Nothing)+ ; return (constructNode n p a s i r)+ }+ }+{-+instance XML.HTypeable DoublePoint where+ toHType _ = XML.Defined "DoublePoint" [] [XML.Constr "X" [] [], XML.Constr "Y" [] []]+instance XML.XmlContent DoublePoint where+ toContents (DoublePoint x y) =+ [ simpleString "X" (show x)+ , simpleString "Y" (show y)+ ]+ parseContents = do+ { x <- XML.inElement "X" $ fmap read XML.text+ ; y <- XML.inElement "Y" $ fmap read XML.text+ ; return (DoublePoint x y)+ }+-}+instance XML.HTypeable (Edge e) where+ toHType _ = XML.Defined "Edge" [] [XML.Constr "Edge" [] []]+instance InfoKind e g => XML.XmlContent (Edge e) where+ toContents edge =+ [ makeTag "Edge"+ [ simpleString "From" (show (getEdgeFrom edge))+ , simpleString "To" (show (getEdgeTo edge))+ , makeTag "Via" (concatMap XML.toContents (getEdgeVia edge))+ , makeTag "Info" (XML.toContents (getEdgeInfo edge))+ , makeTag "FromPort" (XML.toContents (getEdgeFromPort edge))+ , makeTag "ToPort" (XML.toContents (getEdgeToPort edge))+ ]+ ]+ parseContents = do+ { XML.inElement "Edge" $ do+ { f <- XML.inElement "From" $ fmap read XML.text+ ; t <- XML.inElement "To" $ fmap read XML.text+ ; v <- XML.inElement "Via" $ XML.many XML.parseContents+ ; i <- XML.inElement "Info" $ XML.parseContents+ ; fp <- (XML.inElement "FromPort" $ XML.parseContents)+ `XML.onFail` (return 0)+ ; tp <- (XML.inElement "ToPort" $ XML.parseContents)+ `XML.onFail` (return 0)+ ; return (constructEdge f fp t tp v i)+ }+ }++---------------------------------------------------------+-- Internal type isomorphic to (index,value) pairs+-- (but permits instances of classes)+---------------------------------------------------------+data AssocN n = AssocN Int (Node n)+deAssocN :: AssocN n -> (Int,Node n)+deAssocN (AssocN n v) = (n,v)+data AssocE e = AssocE Int (Edge e)+deAssocE :: AssocE e -> (Int,Edge e)+deAssocE (AssocE n v) = (n,v)++---------------------------------------------------------+-- Check whether the network read from file is valid+---------------------------------------------------------++networkValid :: [AssocN n] -> [AssocE e] -> XML.XMLParser ()+networkValid nodeAssocs edgeAssocs+ | containsDuplicates nodeNrs =+ fail "Node numbers should be unique"+ | containsDuplicates edgeNrs =+ fail "Edge numbers should be unique"+ | otherwise =+ do{ mapM_ (checkEdge nodeNrs) edgeAssocs+ ; -- determine whether there are multiple edges between any two nodes+ ; let multipleEdges = duplicatesBy betweenSameNodes edges+ ; when (not (null multipleEdges)) $+ fail $ "There are multiple edges between the following node pairs: " +++ commasAnd [ "(" ++ show (getEdgeFrom e) ++ ", "+ ++ show (getEdgeTo e) ++ ")"+ | e <- multipleEdges+ ]+ ; return ()+ }+ where+ nodeNrs = map (fst . deAssocN) nodeAssocs+ (edgeNrs, edges) = unzip (map deAssocE edgeAssocs)++-- Check whether edges refer to existing node numbers and whether+-- there are no edges that start and end in the same node+checkEdge :: [NodeNr] -> AssocE e -> XML.XMLParser ()+checkEdge nodeNrs (AssocE edgeNr edge)+ | fromNr == toNr =+ fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"+ | fromNr `notElem` nodeNrs = nonExistingNode fromNr+ | toNr `notElem` nodeNrs = nonExistingNode toNr+ | otherwise = return ()+ where+ fromNr = getEdgeFrom edge+ toNr = getEdgeTo edge+ nonExistingNode nodeNr =+ fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node "+ ++ show nodeNr++containsDuplicates :: Eq a => [a] -> Bool+containsDuplicates xs = length (nub xs) /= length xs++-- Partial equality on edges+betweenSameNodes :: Edge e -> Edge e -> Bool+betweenSameNodes e1 e2 =+ (getEdgeFrom e1 == getEdgeFrom e2 && getEdgeTo e1 == getEdgeTo e2)+ ||+ (getEdgeFrom e1 == getEdgeTo e2 && getEdgeTo e1 == getEdgeFrom e1)++-- Returns elements that appear more than once in a list+duplicates :: Eq a => [a] -> [a]+duplicates [] = []+duplicates (x:xs)+ | x `elem` xs = x : duplicates (filter (/= x) xs)+ | otherwise = duplicates xs++-- Returns elements that appear more than once in a list, using given Eq op+duplicatesBy :: (a->a->Bool) -> [a] -> [a]+duplicatesBy _ [] = []+duplicatesBy eq (x:xs)+ | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs)+ | otherwise = duplicatesBy eq xs+
src/Graphics/Blobs/NetworkControl.hs view
@@ -10,7 +10,7 @@ , deleteSelection , changeNamePosition , changeNodeShape- , renameNode, reinfoNodeOrEdge+ , renameNode, reinfoNodeOrEdge, reinfoNodeOrEdgeUser , reArityNode , changeGlobalInfo ) where@@ -28,10 +28,9 @@ import Graphics.Blobs.InfoKind import Graphics.Blobs.Palette (shapes) import Text.Parse-import Char (isSpace)+import Data.Char (isSpace) import Graphics.UI.WX hiding (Selection)-import Graphics.UI.WXCore changeNamePosition :: Bool -> State g n e -> IO () changeNamePosition above state =@@ -259,10 +258,10 @@ selectMultiple :: Maybe (DoublePoint,DoublePoint) -> [Int] -> [(Int,Int)] -> State g n e -> IO ()-selectMultiple area nodeNrs viaNrs state =+selectMultiple areaRect nodeNrs viaNrs state = do{ pDoc <- getDocument state ; PD.superficialUpdateDocument- (setSelection (MultipleSelection area nodeNrs viaNrs))+ (setSelection (MultipleSelection areaRect nodeNrs viaNrs)) pDoc ; repaintAll state }@@ -278,9 +277,9 @@ dragMultiple nodeNrs viaNrs mousePoint canvas state = do{ pDoc <- getDocument state -- ; doc <- PD.getDocument pDoc- ; Just (hasMoved, origin) <- getDragging state- ; let offset = mousePoint `subtractDoublePoint` origin- ; when (mousePoint /= origin) $+ ; Just (hasMoved, originPoint) <- getDragging state+ ; let offset = mousePoint `subtractDoublePoint` originPoint+ ; when (mousePoint /= originPoint) $ do{ -- The first time the point is moved we have to remember -- the document in the undo history ; (if not hasMoved then PD.updateDocument "move control point"@@ -306,13 +305,13 @@ dropMultiple :: Bool -> [Int] -> [(Int,Int)] -> DoublePoint -> DoublePoint -> State g n e -> IO ()-dropMultiple hasMoved nodeNrs viaNrs origin mousePoint state =+dropMultiple hasMoved nodeNrs viaNrs originPoint mousePoint state = do{ when hasMoved $ do{ pDoc <- getDocument state ; PD.superficialUpdateDocument (updateNetwork (updateMultiple nodeNrs viaNrs- (mousePoint`subtractDoublePoint`origin)))+ (mousePoint`subtractDoublePoint`originPoint))) pDoc } ; canvas <- getCanvas state@@ -332,9 +331,9 @@ dragArea mousePoint state = do{ pDoc <- getDocument state ; doc <- PD.getDocument pDoc- ; Just (_, origin) <- getDragging state- ; let (ns,vs) = itemsEnclosedWithin mousePoint origin (getNetwork doc)- ; selectMultiple (Just (origin,mousePoint)) ns vs state+ ; Just (_, originPoint) <- getDragging state+ ; let (ns,vs) = itemsEnclosedWithin mousePoint originPoint (getNetwork doc)+ ; selectMultiple (Just (originPoint,mousePoint)) ns vs state } where itemsEnclosedWithin p0 p1 network =@@ -484,30 +483,156 @@ _ -> return () } -changeGlobalInfo :: (Show g, Parse g, Descriptor g) =>+reinfoNodeOrEdgeUser :: (InfoKind n g, InfoKind e g) => Frame () -> State g n e -> IO ()+reinfoNodeOrEdgeUser theFrame state =+ do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; let network = getNetwork doc+ globalInfo = getGlobalInfo network+ ; case getSelection doc of+ NodeSelection nodeNr ->+ do{ let oldInfo = getNodeInfo network nodeNr+ ; result <- editDialogWithGlobal theFrame "Edit node info" oldInfo globalInfo+ -- ; result <- myTextDialog theFrame MultiLine+ -- "Edit node info" (show oldInfo) True+ ; case result of+ Just newInfo ->+ do {+ case check (getNodeName network nodeNr)+ (getGlobalInfo network) newInfo of+ [] -> return ()+ e -> errorDialog theFrame "Validity warning"+ ("Validity check fails:\n"+ ++unlines e)+ ; PD.updateDocument "edit node info"+ (updateNetwork+ (updateNode nodeNr (setInfo newInfo))) pDoc+ ; repaintAll state+ }+ Nothing ->+ return ()+ }+ EdgeSelection edgeNr ->+ do{ let oldInfo = getEdgeInfo (getEdge edgeNr network)+ ; result <- editDialogWithGlobal theFrame "Edit edge info" oldInfo globalInfo+ ; ifJust result $ \newInfo ->+ do { case check "edge"+ (getGlobalInfo network) newInfo of+ [] -> return ()+ e -> errorDialog theFrame "Validity warning"+ ("Validity check fails:\n"+ ++unlines e)+ ; PD.updateDocument "edit edge info"+ (updateNetwork+ (updateEdge edgeNr (setEdgeInfo newInfo))) pDoc+ ; repaintAll state+ }+ }+ {-+ do{ let oldInfo = getEdgeInfo (getEdge edgeNr network)+ ; result <- myTextDialog theFrame MultiLine+ "Edit edge info" (show oldInfo) True+ ; ifJust result $ \newInfo ->+ -- do repaintAll state -- Until we sort out the parser+ case runParser parse newInfo of+ (Right x, s) ->+ do{ when (not (null s || all isSpace s)) $+ errorDialog theFrame "Edit warning"+ ("Excess text after parsed value."+ ++"\nRemaining text: "++s)+ ; case check "edge"+ (getGlobalInfo network) x of+ [] -> return ()+ e -> errorDialog theFrame "Validity warning"+ ("Validity check fails:\n"+ ++unlines e)+ ; PD.updateDocument "edit edge info"+ (updateNetwork+ (updateEdge edgeNr (setEdgeInfo x))) pDoc+ ; repaintAll state+ }+ (Left err, s) -> errorDialog theFrame "Edit warning"+ ("Cannot parse entered text."+ ++"\nReason: "++err+ ++"\nRemaining text: "++s)+ }+-}+ _ -> return ()+ }++-- ---------------------------------------------------------------------+++editEdgeInfo :: (Show g, Parse g, Descriptor g) =>+ Frame () -> String -> g -> IO (Maybe g)+editEdgeInfo theFrame _title info =++ do{ result <- myTextDialog theFrame MultiLine+ "Edit edge info" (show info) True+ ; case result of+ Just newInfo ->+ case runParser parse newInfo of+ (Right x, s) ->+ do{ when (not (null s || all isSpace s)) $+ errorDialog theFrame "Edit warning"+ ("Excess text after parsed value."+ ++"\nRemaining text: "++s)+ ; return (Just x)+ }+ (Left err, s) -> do { errorDialog theFrame "Edit warning"+ ("Cannot parse entered text."+ ++"\nReason: "++err+ ++"\nRemaining text: "++s)+ ; return Nothing+ }+ Nothing -> return Nothing++ }++-- ---------------------------------------------------------------------++changeGlobalInfo :: (Show g, Parse g, Descriptor g, GuiEdit g) =>+ Frame () -> State g n e -> IO () changeGlobalInfo theFrame state = do{ pDoc <- getDocument state ; doc <- PD.getDocument pDoc ; let network = getNetwork doc info = getGlobalInfo network- ; result <- myTextDialog theFrame MultiLine ("Edit "++descriptor info)- (show info) True+ -- ; result <- editGlobalInfo theFrame ("Edit "++descriptor info) info+ ; result <- editDialog theFrame ("Edit "++descriptor info) info ; ifJust result $ \newInfo->- --do repaintAll state -- Until we sort out the parser+ do {+ PD.updateDocument ("edit "++descriptor info)+ (updateNetwork (setGlobalInfo newInfo)) pDoc+ ; repaintAll state -- no visible change?+ }+ }++-- ---------------------------------------------------------------------++editGlobalInfo :: (Show g, Parse g, Descriptor g) =>+ Frame () -> String -> g -> IO (Maybe g)+editGlobalInfo theFrame _title info =+ do{ result <- myTextDialog theFrame MultiLine ("Edit "++descriptor info)+ (show info) True+ ; case result of+ Just newInfo-> case runParser parse newInfo of (Right x, s) ->- do{ when (not (null s || all isSpace s)) $- errorDialog theFrame "Edit warning"+ do{ when (not (null s || all isSpace s)) $+ errorDialog theFrame "Edit warning" ("Excess text after parsed value." ++"\nRemaining text: "++s)- ; PD.updateDocument ("edit "++descriptor info)- (updateNetwork (setGlobalInfo x)) pDoc- ; repaintAll state -- no visible change?- }- (Left err, s) -> errorDialog theFrame "Edit warning"- ("Cannot parse entered text."- ++"\nReason: "++err- ++"\nRemaining text: "++s)+ ; return (Just x)+ }+ (Left err, s) -> do { errorDialog theFrame "Edit warning"+ ("Cannot parse entered text."+ ++"\nReason: "++err+ ++"\nRemaining text: "++s)+ ; return Nothing+ }+ Nothing -> return Nothing } +-- EOF
src/Graphics/Blobs/NetworkFile.hs view
@@ -2,28 +2,14 @@ module Graphics.Blobs.NetworkFile where import qualified Graphics.Blobs.Network as N-import Graphics.Blobs.Math-import Graphics.Blobs.Common-import Graphics.Blobs.Colors-import Graphics.Blobs.Shape import Graphics.Blobs.InfoKind-import Graphics.Blobs.Palette import Text.XML.HaXml.Types-import Text.XML.HaXml.Escape import Text.XML.HaXml.Posn (noPos) import Text.XML.HaXml.Parse hiding (element)--- import Text.XML.HaXml.XmlContent as XML import Text.XML.HaXml.XmlContent.Haskell as XML-import Text.XML.HaXml.Combinators (replaceAttrs)-import Text.XML.HaXml.Verbatim-import Text.XML.HaXml.TypeMapping (toDTD,toHType) import Text.PrettyPrint.HughesPJ import qualified Text.XML.HaXml.Pretty as Pretty-import Char-import Maybe-import Monad(when)-import List(nub,isPrefixOf) -- | Print the network data structure to an XML text toString :: (InfoKind n g, InfoKind e g, XmlContent g) =>@@ -48,391 +34,4 @@ case runParser parseContents [CElem e noPos] of (Left err, _) -> Left err -- secondary (typeful) parse error (Right v, _) -> Right (v,[],False)--{---- non-XML output-toStringShow :: (Show g, Show n, Show e) => Network g n e -> String-toStringShow network =- show ( getNodeAssocs network- , getEdgeAssocs network- , getCanvasSize network- , getGlobalInfo network- )--fromStringShow :: (Read g, InfoKind n g, InfoKind e g) =>- String -> Either String (Network g n e)-fromStringShow txt =- case reads txt of- ((tuple,[]):_) ->- let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple- in Right ( setNodeAssocs nodeAssocs- . setEdgeAssocs edgeAssocs- . setCanvasSize canvasSize- $ Network.empty globalInfo undefined undefined- )- _ -> Left "File is not a Blobs network"--}-------------------------------------------------------------- Internal type isomorphic to (index,value) pairs--- (but permits instances of classes)-----------------------------------------------------------data AssocN n = AssocN Int (N.Node n)-deAssocN :: AssocN n -> (Int,N.Node n)-deAssocN (AssocN n v) = (n,v)-data AssocE e = AssocE Int (N.Edge e)-deAssocE :: AssocE e -> (Int,N.Edge e)-deAssocE (AssocE n v) = (n,v)-------------------------------------------------------------- Convert our data type to/from an XML tree-----------------------------------------------------------instance (HTypeable g, HTypeable n, HTypeable e)- => HTypeable (N.Network g n e) where- toHType _ = Defined "Network" [] [Constr "Network" [] []]- -- toHType g = Defined "Network" [] [Constr "Network" []- -- [ Tagged "Width" [String]- -- , Tagged "Height" [String]- -- , toHType (getGlobalInfo g)- -- , toHType (getPalette g)- -- , toHType (getNodeAssocs g)- -- , toHType (getEdgeAssocs g)- -- ]]-instance (InfoKind n g, InfoKind e g, XmlContent g) =>- XmlContent (N.Network g n e) where- toContents network =- [CElem (Elem "Network" []- [ simpleString "Width" (show width)- , simpleString "Height" (show height)- , makeTag "Info" (toContents netInfo)- , makeTag "Palette" (toContents (N.getPalette network))- , makeTag "Nodes" (concatMap toContents nodeAssocs)- , makeTag "Edges" (concatMap toContents edgeAssocs)- ]) () ]- where- nodeAssocs = map (uncurry AssocN) $ N.getNodeAssocs network- edgeAssocs = map (uncurry AssocE) $ N.getEdgeAssocs network- (width, height) = N.getCanvasSize network- netInfo = N.getGlobalInfo network- parseContents = do- { inElement "Network" $ do- { w <- inElement "Width" $ fmap read XML.text- ; h <- inElement "Height" $ fmap read XML.text- ; i <- inElement "Info" $ parseContents- ; p <- inElement "Palette"$ parseContents- ; ns <- inElement "Nodes" $ many1 parseContents- ; es <- inElement "Edges" $ many1 parseContents- ; networkValid ns es- ; return ( N.setCanvasSize (w,h)- . N.setPalette p- . N.setNodeAssocs (map deAssocN ns)- . N.setEdgeAssocs (map deAssocE es)- $ N.empty i undefined undefined)- }- }--peekAttributes :: String -> XMLParser [(String,AttValue)]-peekAttributes t =- do{ (p, e@(Elem _ as _)) <- posnElement [t]- ; reparse [CElem e p]- ; return as- }--instance HTypeable (AssocN n) where- toHType _ = Defined "Node" [] [Constr "Node" [] []]-instance (InfoKind n g) => XmlContent (AssocN n) where- toContents (AssocN n node) =- concatMap (replaceAttrs [("id",'N':show n)]) (toContents node)- parseContents = do- { [("id",n)] <- peekAttributes "Node"- ; n' <- num n- ; node <- parseContents- ; return (AssocN n' node)- }- where num (AttValue [Left ('N':n)]) = return (read n)- num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)--instance HTypeable (AssocE e) where- toHType _ = Defined "Edge" [] [Constr "Edge" [] []]-instance (InfoKind e g) => XmlContent (AssocE e) where- toContents (AssocE n edge) =- concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge)- parseContents = do- { [("id",n)] <- peekAttributes "Edge"- ; n' <- num n- ; edge <- parseContents- ; return (AssocE n' edge)- }- where num (AttValue [Left ('E':n)]) = return (read n)- num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s)--instance HTypeable (N.Node n) where- toHType _ = Defined "Node" [] [Constr "Node" [] []]-instance (InfoKind n g) => XmlContent (N.Node n) where- toContents node =- [ makeTag "Node"- (toContents (N.getPosition node) ++- [ escapeString "Name" (N.getName node)- , simpleString "LabelAbove" (show (N.getNameAbove node))- , makeTag "Shape" (toContents (N.getShape node))- , makeTag "Info" (toContents (N.getInfo node))- , makeTag "Arity" (toContents (N.getArity node))- ])- ]- parseContents = do- { inElement "Node" $ do- { p <- parseContents -- position- ; n <- inElement "Name" $ XML.text- ; a <- inElement "LabelAbove" $ fmap read XML.text- ; s <- inElement "Shape" $ parseContents- ; i <- inElement "Info" $ parseContents- ; r <- (inElement "Arity" $ parseContents)- `onFail` (return Nothing)- ; return (N.constructNode n p a s i r)- }- }--instance HTypeable DoublePoint where- toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []]-instance XmlContent DoublePoint where- toContents (DoublePoint x y) =- [ simpleString "X" (show x)- , simpleString "Y" (show y)- ]- parseContents = do- { x <- inElement "X" $ fmap read XML.text- ; y <- inElement "Y" $ fmap read XML.text- ; return (DoublePoint x y)- }--instance HTypeable (N.Edge e) where- toHType _ = Defined "Edge" [] [Constr "Edge" [] []]-instance InfoKind e g => XmlContent (N.Edge e) where- toContents edge =- [ makeTag "Edge"- [ simpleString "From" (show (N.getEdgeFrom edge))- , simpleString "To" (show (N.getEdgeTo edge))- , makeTag "Via" (concatMap toContents (N.getEdgeVia edge))- , makeTag "Info" (toContents (N.getEdgeInfo edge))- , makeTag "FromPort" (toContents (N.getEdgeFromPort edge))- , makeTag "ToPort" (toContents (N.getEdgeToPort edge))- ]- ]- parseContents = do- { inElement "Edge" $ do- { f <- inElement "From" $ fmap read XML.text- ; t <- inElement "To" $ fmap read XML.text- ; v <- inElement "Via" $ many parseContents- ; i <- inElement "Info" $ parseContents- ; fp <- (inElement "FromPort" $ parseContents)- `onFail` (return 0)- ; tp <- (inElement "ToPort" $ parseContents)- `onFail` (return 0)- ; return (N.constructEdge f fp t tp v i)- }- }--{- derived by DrIFT -}-instance HTypeable Colour where- toHType v = Defined "Colour" []- [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]]- where (RGB aa ab ac) = v-instance XmlContent Colour where- parseContents = do- { inElement "RGB" $ do- { aa <- parseContents- ; ab <- parseContents- ; ac <- parseContents- ; return (RGB aa ab ac)- }- }- toContents v@(RGB aa ab ac) =- [mkElemC (showConstr 0 (toHType v))- (concat [toContents aa, toContents ab, toContents ac])]--{- derived by DrIFT -}-instance HTypeable Shape where- toHType v = Defined "Shape" []- [Constr "Circle" [] [toHType aa,toHType ab]- ,Constr "Polygon" [] [toHType ac,toHType ad]- ,Constr "Lines" [] [toHType ae,toHType af]- ,Constr "Composite" [] [toHType ag]]- where- (Circle aa ab) = v- (Polygon ac ad) = v- (Lines ae af) = v- (Composite ag) = v-instance XmlContent Shape where- parseContents = do- { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]- ; case t of- _ | "Polygon" `isPrefixOf` t -> interior e $- do { ac <- parseContents- ; ad <- parseContents- ; return (Polygon ac ad)- }- | "Lines" `isPrefixOf` t -> interior e $- do { ae <- parseContents- ; af <- parseContents- ; return (Lines ae af)- }- | "Composite" `isPrefixOf` t -> interior e $- fmap Composite parseContents- | "Circle" `isPrefixOf` t -> interior e $- do { aa <- parseContents- ; ab <- parseContents- ; return (Circle aa ab)- }- }- toContents v@(Circle aa ab) =- [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,- toContents ab])]- toContents v@(Polygon ac ad) =- [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac,- toContents ad])]- toContents v@(Lines ae af) =- [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae,- toContents af])]- toContents v@(Composite ag) =- [mkElemC (showConstr 3 (toHType v)) (toContents ag)]--{- derived by DrIFT -}-instance HTypeable ShapeStyle where- toHType v = Defined "ShapeStyle" []- [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]]- where (ShapeStyle aa ab ac) = v-instance XmlContent ShapeStyle where- parseContents = do- { inElement "ShapeStyle" $ do- { aa <- parseContents- ; ab <- parseContents- ; ac <- parseContents- ; return (ShapeStyle aa ab ac)- }- }- toContents v@(ShapeStyle aa ab ac) =- [mkElemC (showConstr 0 (toHType v))- (concat [toContents aa, toContents ab, toContents ac])]--{- handwritten -}-instance HTypeable a => HTypeable (Palette a) where- toHType p = Defined "Palette" [toHType a] [Constr "Palette" [] []]- where (Palette ((_,(_,Just a)):_)) = p-instance XmlContent a => XmlContent (Palette a) where- toContents (Palette shapes) =- [ mkElemC "Palette" (concatMap toContents shapes) ]- parseContents = do- { inElement "Palette" $ fmap Palette (many1 parseContents) }--{--instance XmlContent a => XmlContent (Either String a) where- toContents (Left str) = [ simpleString "ShapeName" (show str) ]- toContents (Right shape) = (toContents shape)-- parseContents = do- return () -- Need to implement this--}----- UTILITY FUNCTIONS---- Abbreviations-makeTag :: String -> [Content i] -> Content i-makeTag name children = CElem (Elem name [] children) undefined--tagWithId :: String -> String -> [Content i] -> Content i-tagWithId name identity children =- CElem (Elem name [("id", AttValue [Left identity])] children) undefined---- | A simple string contains no spaces or unsafe characters-simpleString :: String -> String -> Content i-simpleString tag value =- CElem (Elem tag [] [ CString False value undefined ]) undefined---- | The string value may contain spaces and unsafe characters-escapeString :: String -> String -> Content i-escapeString key value =- CElem ((if isSafe value then id else escape) $- Elem key [] [ CString (any isSpace value) value undefined ])- undefined- where- isSafe cs = all isSafeChar cs- isSafeChar c = isAlpha c || isDigit c || c `elem` "- ."-- escape :: Element i -> Element i- escape = xmlEscape stdXmlEscaper--comment :: String -> Content i-comment s = CMisc (Comment (commentEscape s)) undefined---- Replace occurences of "-->" with "==>" in a string so that the string--- becomes safe for an XML comment-commentEscape :: String -> String-commentEscape [] = []-commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs-commentEscape (x:xs) = x : commentEscape xs-------------------------------------------------------------- Check whether the network read from file is valid------------------------------------------------------------networkValid :: [AssocN n] -> [AssocE e] -> XMLParser ()-networkValid nodeAssocs edgeAssocs- | containsDuplicates nodeNrs =- fail "Node numbers should be unique"- | containsDuplicates edgeNrs =- fail "Edge numbers should be unique"- | otherwise =- do{ mapM_ (checkEdge nodeNrs) edgeAssocs- ; -- determine whether there are multiple edges between any two nodes- ; let multipleEdges = duplicatesBy betweenSameNodes edges- ; when (not (null multipleEdges)) $- fail $ "There are multiple edges between the following node pairs: " ++- commasAnd [ "(" ++ show (N.getEdgeFrom e) ++ ", "- ++ show (N.getEdgeTo e) ++ ")"- | e <- multipleEdges- ]- ; return ()- }- where- nodeNrs = map (fst . deAssocN) nodeAssocs- (edgeNrs, edges) = unzip (map deAssocE edgeAssocs)---- Check whether edges refer to existing node numbers and whether--- there are no edges that start and end in the same node-checkEdge :: [N.NodeNr] -> AssocE e -> XMLParser ()-checkEdge nodeNrs (AssocE edgeNr edge)- | fromNr == toNr =- fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"- | fromNr `notElem` nodeNrs = nonExistingNode fromNr- | toNr `notElem` nodeNrs = nonExistingNode toNr- | otherwise = return ()- where- fromNr = N.getEdgeFrom edge- toNr = N.getEdgeTo edge- nonExistingNode nodeNr =- fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node "- ++ show nodeNr--containsDuplicates :: Eq a => [a] -> Bool-containsDuplicates xs = length (nub xs) /= length xs---- Partial equality on edges-betweenSameNodes :: N.Edge e -> N.Edge e -> Bool-betweenSameNodes e1 e2 =- (N.getEdgeFrom e1 == N.getEdgeFrom e2 && N.getEdgeTo e1 == N.getEdgeTo e2)- ||- (N.getEdgeFrom e1 == N.getEdgeTo e2 && N.getEdgeTo e1 == N.getEdgeFrom e1)---- Returns elements that appear more than once in a list-duplicates :: Eq a => [a] -> [a]-duplicates [] = []-duplicates (x:xs)- | x `elem` xs = x : duplicates (filter (/= x) xs)- | otherwise = duplicates xs---- Returns elements that appear more than once in a list, using given Eq op-duplicatesBy :: (a->a->Bool) -> [a] -> [a]-duplicatesBy _ [] = []-duplicatesBy eq (x:xs)- | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs)- | otherwise = duplicatesBy eq xs
src/Graphics/Blobs/NetworkUI.hs view
@@ -3,30 +3,27 @@ , getConfig, Config ) where -import Graphics.Blobs.GUIEvents-import Graphics.Blobs.SafetyNet-import qualified Graphics.Blobs.State as State-import Graphics.Blobs.StateUtil-import qualified Graphics.Blobs.Network as Network-import Graphics.Blobs.NetworkView-import qualified Graphics.Blobs.NetworkFile as NetworkFile-import qualified Graphics.Blobs.Document as Document+ import Graphics.Blobs.Common import Graphics.Blobs.CommonIO-import qualified Graphics.Blobs.PersistentDocument as PD-import qualified Graphics.Blobs.PDDefaults as PD-import Graphics.Blobs.Palette-import Graphics.Blobs.InfoKind import Graphics.Blobs.DisplayOptions---import Text.XML.HaXml.XmlContent (XmlContent)-import Text.XML.HaXml.XmlContent.Haskell (XmlContent)-import Text.Parse-import Graphics.Blobs.Operations+import Graphics.Blobs.GUIEvents+import Graphics.Blobs.InfoKind import Graphics.Blobs.NetworkControl (changeGlobalInfo)-+import Graphics.Blobs.NetworkView+import Graphics.Blobs.Operations+import Graphics.Blobs.SafetyNet+import Graphics.Blobs.StateUtil import Graphics.UI.WX hiding (Child, upKey, downKey) import Graphics.UI.WXCore-import Maybe+import Text.Parse+import Text.XML.HaXml.XmlContent.Haskell (XmlContent)+import qualified Graphics.Blobs.Document as Document+import qualified Graphics.Blobs.Network as Network+import qualified Graphics.Blobs.NetworkFile as NetworkFile+import qualified Graphics.Blobs.PDDefaults as PD+import qualified Graphics.Blobs.PersistentDocument as PD+import qualified Graphics.Blobs.State as State data Config = NFC { nfcWinDimensions :: (Int, Int, Int, Int) -- x, y, width, height
src/Graphics/Blobs/NetworkView.hs view
@@ -11,14 +11,14 @@ import qualified Graphics.Blobs.Network as Network import Graphics.Blobs.Document import Graphics.Blobs.Colors-import Graphics.Blobs.Common+-- import Graphics.Blobs.Common import Graphics.Blobs.Palette import Graphics.Blobs.Math import Graphics.UI.WX as WX hiding (Vector) import Graphics.UI.WXCore hiding (Document, screenPPI, Colour)-import Graphics.UI.WXCore.Draw-import Maybe+-- import Graphics.UI.WXCore.Draw+import Data.Maybe import qualified Graphics.Blobs.Shape as Shape import Graphics.Blobs.DisplayOptions import Graphics.Blobs.InfoKind@@ -67,7 +67,8 @@ ; let (width, _height) = Network.getCanvasSize network ; when (GlobalInfo `elem` dpShowInfo opt) $ drawLabel 0 False- (descriptor global++": "++(unwords.lines.show) global)+ -- (descriptor global++": "++(unwords.lines.show) global)+ (descriptor global) (DoublePoint (width/2) 1) (Justify CentreJ TopJ) [ textColor := wxcolor kNodeLabelColour ] -- draw edges, highlight the selected ones (if any)@@ -126,7 +127,7 @@ (justif above) [ textColor := wxcolor kNodeLabelColour ] -- draw info ; when (NodeInfo `elem` dpShowInfo opt) $- drawLabel (offset (not above)) False (show (Network.getInfo node))+ drawLabel (offset (not above)) False (descriptor (Network.getInfo node)) center (justif (not above)) [ textColor := wxcolor kNodeInfoColour ] }@@ -142,10 +143,10 @@ drawLabel :: Double -> Bool -> String -> DoublePoint -> Justify -> [Prop (DC ())] -> IO ()- drawLabel voffset boxed text (DoublePoint x y) justify opts =+ drawLabel voffset isBoxed labelText (DoublePoint x y) justify opts = do{ -- draw background- when boxed $ do- { (textWidth, textHeight) <- logicalGetTextExtent ppi dc text+ when isBoxed $ do+ { (textWidth, textHeight) <- logicalGetTextExtent ppi dc labelText ; let horizontalMargin = 0.2 -- centimeters verticalMargin = 0.01 -- centimeters topleftY = y+voffset - case justify of@@ -158,8 +159,8 @@ (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin) (solidFill labelBackgroundColor) }- -- draw text- ; logicalText ppi dc (DoublePoint x (y+voffset)) text justify opts+ -- draw labelText+ ; logicalText ppi dc (DoublePoint x (y+voffset)) labelText justify opts } drawEdge :: InfoKind e g => Network.Edge e -> [Prop (DC ())] -> IO ()@@ -171,7 +172,7 @@ ; when (EdgeInfo `elem` dpShowInfo opt) $ -- logicalTextRotated ppi dc (middle via) (show info) 45 -- [ textColor := wxcolor kEdgeInfoColour ]- drawLabel 0 False (show (Network.getEdgeInfo edge)) (middle via)+ drawLabel 0 False (descriptor (Network.getEdgeInfo edge)) (middle via) (Justify CentreJ BottomJ) [ textColor := wxcolor kEdgeInfoColour ] }@@ -185,7 +186,7 @@ fstEdgeVector = (head (via++[toPoint])) `subtractDoublePointVector` fromPoint- fstTotalLen = vectorLength fstEdgeVector+ -- fstTotalLen = vectorLength fstEdgeVector fstAngle = vectorAngle fstEdgeVector penultimatePt = head (reverse (fromPoint:via))@@ -206,8 +207,8 @@ drawVia :: Network.Edge e -> Network.ViaNr -> [Prop (DC ())] -> IO () drawVia e n options =- let pt = (Network.getEdgeVia e)!!n in- do logicalCircle ppi dc pt kEDGE_CLICK_RANGE+ let centrePoint = (Network.getEdgeVia e)!!n in+ do logicalCircle ppi dc centrePoint kEDGE_CLICK_RANGE (options ++ solidFill violet) solidFill :: Colour -> [Prop (DC ())]@@ -245,7 +246,7 @@ via= Network.getEdgeVia edge p = clickedPoint numberedDistancesToSegments = zip [0..] $- zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p)+ zipWith (\pa pb-> distanceSegmentPoint pa pb p) (p0:via) (via++[p1]) in case [ nr | (nr,dist) <- numberedDistancesToSegments , dist < kEDGE_CLICK_RANGE ] of@@ -293,20 +294,20 @@ MiddleJ -> (x, y-height/2) BottomJ -> (x, y-height) eachLine _ _ [] = return ()- eachLine maxwidth (x,y) (txt:txts) =- do{ (w,h) <- logicalGetTextExtent ppi dc txt- ; let thisX = case horiz of LeftJ -> x-maxwidth/2- CentreJ -> x-w/2- RightJ -> x+(maxwidth/2)-w- ; drawText dc txt (logicalToScreenPoint ppi (DoublePoint thisX y))+ eachLine maxwidth (x1,y1) (txt1:txts) =+ do{ (w,h) <- logicalGetTextExtent ppi dc txt1+ ; let thisX = case horiz of LeftJ -> x1-maxwidth/2+ CentreJ -> x1-w/2+ RightJ -> x1+(maxwidth/2)-w+ ; drawText dc txt1 (logicalToScreenPoint ppi (DoublePoint thisX y1)) options- ; eachLine maxwidth (x,y+h) txts+ ; eachLine maxwidth (x1,y1+h) txts } -- currently assumes only single line of text-logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double+_logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double -> [Prop (DC ())] -> IO ()-logicalTextRotated ppi dc pos txt angle options =+_logicalTextRotated ppi dc pos txt angle options = draw dc txt (logicalToScreenPoint ppi pos) options where draw = if angle<1 && angle>(-1) then drawText
src/Graphics/Blobs/Operations.hs view
@@ -1,6 +1,5 @@ module Graphics.Blobs.Operations where -import Graphics.Blobs.InfoKind import Graphics.Blobs.Network import Graphics.Blobs.State import Graphics.Blobs.Document
src/Graphics/Blobs/PDDefaults.hs view
@@ -73,10 +73,10 @@ ] -- ; set p [ defaultButton := saveB ] ; set d [ defaultButton := saveB ]- ; showModal d $ \stop ->- do set dontsaveB [on command := stop (Just False) ]- set saveB [on command := stop (Just True) ]- set cancelB [on command := stop Nothing ]+ ; showModal d $ \stop1 ->+ do set dontsaveB [on command := stop1 (Just False) ]+ set saveB [on command := stop1 (Just True) ]+ set cancelB [on command := stop1 Nothing ] } defaultSaveAsDialog :: Frame () -> Extensions -> Maybe String -> IO (Maybe String)
src/Graphics/Blobs/Palette.hs view
@@ -1,10 +1,11 @@ module Graphics.Blobs.Palette where -import List (nub, (\\))--- import qualified Graphics.Blobs.Shape as Shape+import Data.List (nub, (\\)) import qualified Graphics.Blobs.Shape as Shape import Text.Parse +import qualified Text.XML.HaXml.XmlContent.Haskell as XML+ data Palette a = Palette [ (String, (Shape.Shape, Maybe a)) ] deriving (Eq, Show, Read) @@ -22,9 +23,23 @@ empty = Palette [("circle", (Shape.circle, Nothing))] instance Functor Palette where- fmap _ (Palette p) = Palette (map (\ (n,(s,i))-> (n,(s,Nothing))) p)+ fmap _ (Palette p) = Palette (map (\ (n,(s,_i))-> (n,(s,Nothing))) p) instance Parse a => Parse (Palette a) where parse = do{ isWord "Palette"; fmap Palette $ parse }+++-- ---------------------------------------------------------------------+-- orphan instances coming home++{- handwritten -}+instance XML.HTypeable a => XML.HTypeable (Palette a) where+ toHType p = XML.Defined "Palette" [XML.toHType a] [XML.Constr "Palette" [] []]+ where (Palette ((_,(_,Just a)):_)) = p+instance XML.XmlContent a => XML.XmlContent (Palette a) where+ toContents (Palette xs) =+ [ XML.mkElemC "Palette" (concatMap XML.toContents xs) ]+ parseContents = do+ { XML.inElement "Palette" $ fmap Palette (XML.many1 XML.parseContents) }
src/Graphics/Blobs/PersistentDocument.hs view
@@ -57,7 +57,7 @@ --import IOExts(IORef, newIORef, writeIORef, readIORef) import Data.IORef(IORef, newIORef, writeIORef, readIORef)-import Monad(when)+import Control.Monad(when) -- | A persistent document is a mutable variable. This way functions -- operating on a document do not have to return the new value but
src/Graphics/Blobs/SafetyNet.hs view
@@ -2,7 +2,7 @@ import Graphics.UI.WX hiding (window) import Prelude hiding (catch)-import Control.Exception (SomeException,Exception,catch)+import Control.Exception (SomeException,catch) safetyNet :: Window a -> IO b -> IO ()
src/Graphics/Blobs/Shape.hs view
@@ -10,7 +10,7 @@ import Graphics.Blobs.CommonIO import qualified Graphics.UI.WX as WX import Graphics.UI.WXCore hiding (Colour)-import Graphics.UI.WXCore.Draw+--import Graphics.UI.WXCore.Draw import Graphics.Blobs.Math import Text.Parse --import Text.XML.HaXml.XmlContent@@ -19,6 +19,10 @@ import Graphics.Blobs.Colors import Graphics.Blobs.Constants +import Text.XML.HaXml.Types+import qualified Text.XML.HaXml.XmlContent.Haskell as XML+import Data.List(isPrefixOf)+ data Shape = Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double } | Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }@@ -135,23 +139,24 @@ -} logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [WX.Prop (DC ())] -> IO ()-logicalDraw ppi dc centre shape options =+logicalDraw ppi dc centrePoint shape options = case shape of- Circle {} -> WX.circle dc (logicalToScreenPoint ppi centre)+ Circle {} -> WX.circle dc (logicalToScreenPoint ppi centrePoint) (logicalToScreenX ppi (shapeRadius shape)) (style2options (shapeStyle shape)++options) Polygon {} -> WX.polygon dc (map (logicalToScreenPoint ppi- . translate centre)+ . translate centrePoint) (shapePerimeter shape)) (style2options (shapeStyle shape)++options)- Lines {} -> logicalLineSegments ppi dc (map (translate centre)+ Lines {} -> logicalLineSegments ppi dc (map (translate centrePoint) (shapePerimeter shape)) (style2options (shapeStyle shape)++options)- Composite {}-> mapM_ (\s-> logicalDraw ppi dc centre s options)+ Composite {}-> mapM_ (\s-> logicalDraw ppi dc centrePoint s options) (shapeSegments shape) logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [WX.Prop (DC ())] -> IO () logicalLineSegments _ _ [_p] _options = return ()+logicalLineSegments _ _ [ ] _options = return () logicalLineSegments ppi dc (fromPoint:toPoint:ps) options = do{ WX.line dc (logicalToScreenPoint ppi fromPoint) (logicalToScreenPoint ppi toPoint) options@@ -175,3 +180,71 @@ ShapeStyle { styleStrokeWidth = 1 , styleStrokeColour = licorice , styleFill = nodeColor }++-- ---------------------------------------------------------------------+-- Orphan instances coming home++{- derived by DrIFT -}+instance XML.HTypeable Shape where+ toHType v = XML.Defined "Shape" []+ [XML.Constr "Circle" [] [XML.toHType aa,XML.toHType ab]+ ,XML.Constr "Polygon" [] [XML.toHType ac,XML.toHType ad]+ ,XML.Constr "Lines" [] [XML.toHType ae,XML.toHType af]+ ,XML.Constr "Composite" [] [XML.toHType ag]]+ where+ (Circle aa ab) = v+ (Polygon ac ad) = v+ (Lines ae af) = v+ (Composite ag) = v+instance XML.XmlContent Shape where+ parseContents = do+ { e@(Elem (N t) _ _) <- XML.element ["Circle","Polygon","Lines","Composite"]+ ; case t of+ _ | "Polygon" `isPrefixOf` t -> XML.interior e $+ do { ac <- XML.parseContents+ ; ad <- XML.parseContents+ ; return (Polygon ac ad)+ }+ | "Lines" `isPrefixOf` t -> XML.interior e $+ do { ae <- XML.parseContents+ ; af <- XML.parseContents+ ; return (Lines ae af)+ }+ | "Composite" `isPrefixOf` t -> XML.interior e $+ fmap Composite XML.parseContents+ | "Circle" `isPrefixOf` t -> XML.interior e $+ do { aa <- XML.parseContents+ ; ab <- XML.parseContents+ ; return (Circle aa ab)+ }+ }+ toContents v@(Circle aa ab) =+ [XML.mkElemC (XML.showConstr 0 (XML.toHType v)) (concat [XML.toContents aa,+ XML.toContents ab])]+ toContents v@(Polygon ac ad) =+ [XML.mkElemC (XML.showConstr 1 (XML.toHType v)) (concat [XML.toContents ac,+ XML.toContents ad])]+ toContents v@(Lines ae af) =+ [XML.mkElemC (XML.showConstr 2 (XML.toHType v)) (concat [XML.toContents ae,+ XML.toContents af])]+ toContents v@(Composite ag) =+ [XML.mkElemC (XML.showConstr 3 (XML.toHType v)) (XML.toContents ag)]++{- derived by DrIFT -}+instance XML.HTypeable ShapeStyle where+ toHType v = XML.Defined "ShapeStyle" []+ [XML.Constr "ShapeStyle" [] [XML.toHType aa,XML.toHType ab,XML.toHType ac]]+ where (ShapeStyle aa ab ac) = v+instance XML.XmlContent ShapeStyle where+ parseContents = do+ { XML.inElement "ShapeStyle" $ do+ { aa <- XML.parseContents+ ; ab <- XML.parseContents+ ; ac <- XML.parseContents+ ; return (ShapeStyle aa ab ac)+ }+ }+ toContents v@(ShapeStyle aa ab ac) =+ [XML.mkElemC (XML.showConstr 0 (XML.toHType v))+ (concat [XML.toContents aa, XML.toContents ab, XML.toContents ac])]+
src/Graphics/Blobs/State.hs view
@@ -14,12 +14,13 @@ import Graphics.Blobs.Document import Graphics.Blobs.Math-import qualified Graphics.Blobs.PersistentDocument as PD-import qualified Graphics.Blobs.DisplayOptions as DisplayOptions- import Graphics.UI.WX import Graphics.UI.WXCore hiding (Document, ToolWindow)+import qualified Graphics.Blobs.DisplayOptions as DisplayOptions+import qualified Graphics.Blobs.PersistentDocument as PD +-- ---------------------------------------------------------------------+ type State g n e = Var (StateRecord g n e) data StateRecord g n e = St@@ -28,6 +29,8 @@ , stNetworkFrame :: Frame () , stCanvas :: ScrolledWindow () , stPageSetupDialog :: PageSetupDialog ()+ -- , stNodeEditDialog :: (EditDialog n) ()+ -- , stEdgeEditDialog :: (EditDialog e) () , stDisplayOptions :: DisplayOptions.DisplayOptions } @@ -49,6 +52,7 @@ , stDisplayOptions = DisplayOptions.standard }) }+ -- Getters
src/Graphics/Blobs/StateUtil.hs view
@@ -7,7 +7,7 @@ import Graphics.Blobs.Common import qualified Graphics.Blobs.PersistentDocument as PD -import Maybe+-- import Maybe import Graphics.UI.WX repaintAll :: State g n e -> IO ()
src/Main.hs view
@@ -2,17 +2,16 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Main (main, gain) where -import qualified Graphics.Blobs.NetworkUI as NetworkUI-import Graphics.UI.WX-import qualified Graphics.Blobs.State as State+import Data.List (nub)+import Data.Maybe (fromJust)+import Graphics.Blobs.CommonIO import Graphics.Blobs.InfoKind- import Graphics.Blobs.Network import Graphics.Blobs.Operations---import IntMap (IntMap)+import Graphics.UI.WX import qualified Data.IntMap as IntMap-import List (nub)-import Maybe (fromJust)+import qualified Graphics.Blobs.NetworkUI as NetworkUI+import qualified Graphics.Blobs.State as State main :: IO () main = start $@@ -31,6 +30,18 @@ instance InfoKind [Int] () where blank = [] check _ _ _ = []++instance Descriptor [Int] where+ descriptor xs = {- "[Int]=" ++ -} (show xs)++instance Descriptor Int where+ descriptor x = "Int=" ++ (show x)++instance GuiGlobalEdit [Int] () where+ editDialogWithGlobal parentWindow dialogTitle initial global = aTextDialog parentWindow dialogTitle initial++instance GuiGlobalEdit Int () where+ editDialogWithGlobal parentWindow dialogTitle initial global = aTextDialog parentWindow dialogTitle initial -- A simple range of operations on a graph network. graphOps :: GraphOps () [Int] [Int]