Fri Nov 18 17:10:05 WET 2005 Malcolm.Wallace@cs.york.ac.uk
* Store node palette in the network document rather than in the GUI state.
Change the representation of the palette of node shapes very slightly.
The palette is now stored as a part of the document (network) itself,
rather than in the state of the GUI. This means when you load a new
document, you automatically get the palette it was built with. Also, a
node can now store either the name of its shape (for lookup in the
palette), or its full description, with the shape name being preferred
in most circumstances.
{
hunk ./Makefile 98
-src/State.o : src/Palette.hi
hunk ./Makefile 125
+src/Network.o : src/Palette.hi
hunk ./Makefile 131
+src/NetworkFile.o : src/Palette.hi
hunk ./Makefile 169
+src/NetworkView.o : src/Palette.hi
hunk ./simple.blobpalette 3
- , Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 1
+ , ( Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 1
hunk ./simple.blobpalette 8
- , Just [] )
+ , Just [] ))
hunk ./simple.blobpalette 10
- , Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 2
+ , ( Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 2
hunk ./simple.blobpalette 18
- , Just [] )
+ , Just [] ))
hunk ./simple.blobpalette 20
- , Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1
+ , ( Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1
hunk ./simple.blobpalette 27
- , Just [] )
+ , Just [] ))
hunk ./simple.blobpalette 29
- , Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1
+ , ( Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1
hunk ./simple.blobpalette 36
- , Just [] )
+ , Just [] ))
hunk ./simple.blobpalette 38
- , Composite { shapeSegments =
+ , ( Composite { shapeSegments =
hunk ./simple.blobpalette 54
- , Just [] )
+ , Just [] ))
hunk ./src/ContextMenu.hs 90
+ palette = getPalette network
+ theShape = getShape theNode
hunk ./src/ContextMenu.hs 95
+ , checked := labelAbove
hunk ./src/ContextMenu.hs 100
+ , checked := not labelAbove
hunk ./src/ContextMenu.hs 103
- ; set (if labelAbove then aboveItem else belowItem) [ checked := True ]
+-- ; set (if labelAbove then aboveItem else belowItem) [ checked := True ]
hunk ./src/ContextMenu.hs 114
- ; palette <- getPalette state
- ; mapM_ (shapeItem contextMenu) (shapes palette)
+ ; mapM_ (shapeItem theShape contextMenu) (shapes palette)
hunk ./src/ContextMenu.hs 128
- shapeItem contextMenu (name,shape,info) =
+ shapeItem curShape contextMenu (name,(shape,info)) =
hunk ./src/ContextMenu.hs 131
- , on command := safetyNet theFrame $ changeNodeShape shape newinfo state
+ , checked := case curShape of { Left n -> n==name; Right s -> False; }
+ , on command := safetyNet theFrame $ changeNodeShape name newinfo state
hunk ./src/Network.hs 17
+ , getPalette, setPalette
hunk ./src/Network.hs 57
+import Palette hiding (delete)
hunk ./src/Network.hs 64
+ , networkPalette :: Palette n
hunk ./src/Network.hs 80
- , nodeShape :: Shape
+ , nodeShape :: Either String Shape -- ^ name from palette, or shape
hunk ./src/Network.hs 93
+ , networkPalette = Palette.empty
hunk ./src/Network.hs 101
-mapNodeNetwork :: (Node n->Node m) -> Network g n e -> Network g m e
+mapNodeNetwork :: InfoKind m g =>
+ (Node n->Node m) -> Network g n e -> Network g m e
hunk ./src/Network.hs 109
+ , networkPalette = fmap (const blank) $ networkPalette network
hunk ./src/Network.hs 149
-constructNode :: (InfoKind n g) => String -> DoublePoint -> Bool -> Shape -> n -> Node n
+constructNode :: (InfoKind n g) => String -> DoublePoint -> Bool
+ -> Either String Shape -> n -> Node n
hunk ./src/Network.hs 184
-getNodeShape :: Network g n e -> NodeNr -> Shape
+getNodeShape :: Network g n e -> NodeNr -> Either String Shape
hunk ./src/Network.hs 187
-setNodeShape :: NodeNr -> Shape -> Network g n e -> Network g n e
+setNodeShape :: NodeNr -> Either String Shape -> Network g n e -> Network g n e
hunk ./src/Network.hs 189
- network { networkNodes = insert nodeNr (node { nodeShape = shape }) (networkNodes network) }
+ network { networkNodes = insert nodeNr (node { nodeShape = shape })
+ (networkNodes network) }
hunk ./src/Network.hs 207
-getShape :: Node a -> Shape
+getShape :: Node a -> Either String Shape
hunk ./src/Network.hs 223
-setShape :: Shape -> Node a -> Node a
+setShape :: Either String Shape -> Node a -> Node a
hunk ./src/Network.hs 300
+getPalette :: Network g n e -> Palette n
+getPalette network = networkPalette network
+
hunk ./src/Network.hs 373
- Shape.circle
+ (Right Shape.circle)
hunk ./src/Network.hs 386
-addNodeEx :: InfoKind n g => String -> DoublePoint -> Bool -> Shape -> n
- -> Network g n e -> (NodeNr, Network g n e)
+addNodeEx :: InfoKind n g =>
+ String -> DoublePoint -> Bool -> Either String Shape -> n
+ -> Network g n e -> (NodeNr, Network g n e)
hunk ./src/Network.hs 460
+
+setPalette :: Palette n -> Network g n e -> Network g n e
+setPalette palette network = network { networkPalette = palette }
hunk ./src/NetworkControl.hs 48
-changeNodeShape :: InfoKind n g => Shape -> n -> State g n e -> IO ()
-changeNodeShape shape info state = [_$_]
+changeNodeShape :: InfoKind n g => String -> n -> State g n e -> IO ()
+changeNodeShape shapename info state = [_$_]
hunk ./src/NetworkControl.hs 57
- (setInfo info . setShape shape))) pDoc
+ (setInfo info . setShape (Left shapename)))) pDoc
hunk ./src/NetworkFile.hs 9
+import Palette
hunk ./src/NetworkFile.hs 95
+ , makeTag "Palette" (toContents (getPalette network))
hunk ./src/NetworkFile.hs 109
+ ; p <- inElement "Palette"$ parseContents
hunk ./src/NetworkFile.hs 114
+ . setPalette p
hunk ./src/NetworkFile.hs 294
+
+{- 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) }
hunk ./src/NetworkUI.hs 170
- [ text := "Open shape palette..."
+ [ text := "Change shape palette..."
hunk ./src/NetworkUI.hs 400
- Right p -> setPalette p state
+ Right p -> do{ pDoc <- getDocument state
+ ; PD.updateDocument "change palette"
+ (updateNetwork (setPalette p))
+ -- really ought to go through network and
+ -- change all nodes' stored shape.
+ pDoc
+ }
hunk ./src/NetworkView.hs 15
+import Palette
hunk ./src/NetworkView.hs 86
- network = getNetwork doc
- theSelection = getSelection doc
+ network = getNetwork doc
+ theSelection = getSelection doc
+ (Palette palette) = getPalette network
hunk ./src/NetworkView.hs 110
- shape = getShape node
+ shape = either (\name-> maybe Shape.circle fst
+ (Prelude.lookup name palette))
+ id (getShape node)
hunk ./src/Palette.hs 7
-data Palette a = Palette [ (String, Shape, Maybe a) ]
+data Palette a = Palette [ (String, (Shape, Maybe a)) ]
hunk ./src/Palette.hs 10
-shapes :: Palette a -> [ (String,Shape,Maybe a) ]
+shapes :: Palette a -> [ (String,(Shape,Maybe a)) ]
hunk ./src/Palette.hs 21
-empty = Palette [("circle", Shape.circle, Nothing)]
+empty = Palette [("circle", (Shape.circle, Nothing))]
+
+instance Functor Palette where
+ fmap _ (Palette p) = Palette (map (\ (n,(s,i))-> (n,(s,Nothing))) p)
hunk ./src/Palette.hs 27
- parse = do{ isWord "Palette"; fmap Palette $ parse }
+ parse = do{ isWord "Palette"; fmap Palette $ parse }
+
hunk ./src/Shape.hs 9
+--import Text.XML.HaXml.XmlContent
+--import NetworkFile
hunk ./src/Shape.hs 67
+{-
+instance HTypeable Shape where
+ toHType s = Defined "Shape" [] [ Constr "Circle" [] []
+ , Constr "Polygon" [] []
+ , Constr "Lines" [] []
+ , Constr "Composite" [] []
+ ]
+instance XmlContent Shape where
+ toContents s@(Circle{}) =
+ [ mkElemC "Circle" (toContents (shapeStyle s)
+ ++ [mkElemC "radius" (toContents (shapeRadius s))]) ]
+ toContents s@(Polygon{}) =
+ [ mkElemC "Polygon" (toContents (shapeStyle s)
+ ++ [mkElemC "perimeter" (concatMap toContents
+ (shapePerimeter s))]) ]
+ toContents s@(Lines{}) =
+ [ mkElemC "Lines" (toContents (shapeStyle s)
+ ++ [mkElemC "perimeter" (concatMap toContents
+ (shapePerimeter s))]) ]
+ toContents s@(Composite{}) =
+ [ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ]
+ parseContents = do
+ { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]
+ ; case t of
+ "Circle" -> interior e $
+ do{ style <- parseContents
+ ; r <- inElement "radius" parseContents
+ ; return (Circle {shapeStyle=style, shapeRadius=r})
+ }
+ "Polygon" -> interior e $
+ do{ style <- parseContents
+ ; p <- inElement "perimeter" $ many1 parseContents
+ ; return (Polygon {shapeStyle=style, shapePerimeter=p})
+ }
+ "Lines" -> interior e $
+ do{ style <- parseContents
+ ; p <- inElement "perimeter" $ many1 parseContents
+ ; return (Lines {shapeStyle=style, shapePerimeter=p})
+ }
+ "Composite" -> interior e $ do{ ss <- many1 parseContents
+ ; return (Composite {shapeSegments=ss})
+ }
+ }
+
+instance HTypeable ShapeStyle where
+ toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []]
+instance XmlContent ShapeStyle where
+ toContents s =
+ [ mkElemC "ShapeStyle"
+ [ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s))
+ , mkElemC "StrokeColour" (toContents (styleStrokeColour s))
+ , mkElemC "Fill" (toContents (styleFill s))
+ ]
+ ]
+ parseContents = inElement "ShapeStyle" $ do
+ { w <- inElement "StrokeWidth" parseContents
+ ; c <- inElement "StrokeColour" parseContents
+ ; f <- inElement "Fill" parseContents
+ ; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c
+ , styleFill=f })
+ }
+-}
+
hunk ./src/Shape.hs 147
-logicalLineSegments _ _ [p] options = return ()
+logicalLineSegments _ _ [_p] _options = return ()
hunk ./src/State.hs 11
- , getPalette, setPalette
hunk ./src/State.hs 18
-import Palette
hunk ./src/State.hs 31
- , stPalette :: Palette.Palette n -- available node shapes/types
hunk ./src/State.hs 49
- , stPalette = Palette.empty
hunk ./src/State.hs 70
-getPalette :: State g n e -> IO (Palette.Palette n)
-getPalette = getFromState stPalette
-
hunk ./src/State.hs 90
-
-setPalette :: Palette.Palette n -> State g n e -> IO ()
-setPalette palette stateRef =
- varUpdate_ stateRef (\state -> state { stPalette = palette })
}