Tue Jul 26 11:47:43 WEST 2005 Malcolm.Wallace@cs.york.ac.uk
* Edges can have control points
The concept of a "control point" on an edge is introduced, to aid the
clarity of diagrams. A control point is just an intermediate coordinate
that the line must pass through when drawn. In the code these are known
as "via" points for short. They can be added through a context menu on
an edge; they can be dragged and dropped; they can be deleted through a
context menu on the point itself.
{
hunk ./src/ContextMenu.hs 2
- ( canvas, edge, node ) where
+ ( canvas, edge, node, via ) where
hunk ./src/ContextMenu.hs 11
+import Math (DoublePoint)
hunk ./src/ContextMenu.hs 40
-edge :: Frame () -> State -> IO ()
-edge theFrame state =
+edge :: Frame () -> DoublePoint -> State -> IO ()
+edge theFrame mousepoint state =
hunk ./src/ContextMenu.hs 44
+ [ text := "Add control point"
+ , on command := safetyNet theFrame $ createVia mousepoint state
+ ]
+ ; menuItem contextMenu
hunk ./src/ContextMenu.hs 49
+ , on command := safetyNet theFrame $ deleteSelection state
+ ]
+ ; pointWithinWindow <- windowGetMousePosition theFrame
+ ; menuPopup contextMenu pointWithinWindow theFrame
+ ; objectDelete contextMenu
+ }
+
+-- | Context menu for a 'via' point
+via :: Frame () -> State -> IO ()
+via theFrame state =
+ do{ contextMenu <- menuPane []
+ ; menuItem contextMenu
+ [ text := "Delete control point (Del)"
hunk ./src/Document.hs 33
+ | ViaSelection Int Int
hunk ./src/GUIEvents.hs 3
-import NetworkView(clickedNode, clickedEdge)
+import NetworkView(clickedNode, clickedEdge, clickedVia)
hunk ./src/GUIEvents.hs 24
- case clickedEdge doubleMousePoint network of
+ case clickedVia doubleMousePoint network of
hunk ./src/GUIEvents.hs 26
- when (not leftButton) $ ContextMenu.canvas theFrame state
- Just edgeNr ->
+ case clickedEdge doubleMousePoint network of
+ Nothing ->
+ when (not leftButton) $
+ ContextMenu.canvas theFrame state
+ Just edgeNr ->
+ if leftButton then
+ selectEdge edgeNr state
+ else
+ do{ selectEdge edgeNr state
+ ; ContextMenu.edge theFrame doubleMousePoint state
+ }
+ Just (edgeNr,viaNr) ->
hunk ./src/GUIEvents.hs 39
- selectEdge edgeNr state
+ pickupVia edgeNr viaNr doubleMousePoint state
hunk ./src/GUIEvents.hs 41
- do{ selectEdge edgeNr state
- ; ContextMenu.edge theFrame state
+ do{ selectVia edgeNr viaNr state
+ ; ContextMenu.via theFrame state
hunk ./src/GUIEvents.hs 85
+ ViaSelection edgeNr viaNr ->
+ dragVia edgeNr viaNr doubleMousePoint canvas state
hunk ./src/GUIEvents.hs 102
+ ViaSelection edgeNr viaNr ->
+ dropVia hasMoved edgeNr viaNr offset doubleMousePoint state
hunk ./src/Network.hs 5
- , NodeNr, EdgeNr, ZeroProb
+ , NodeNr, EdgeNr, ViaNr, ZeroProb
+ , networkEdges
hunk ./src/Network.hs 29
+ , updateVia
hunk ./src/Network.hs 34
- , addEdge, addEdges, removeEdge,
+ , addEdge, addEdges, removeEdge
hunk ./src/Network.hs 36
+ , newViaEdge, removeVia
hunk ./src/Network.hs 54
+ , edgeVia :: [DoublePoint] -- ^ intermediate vertices when drawing
hunk ./src/Network.hs 59
+type ViaNr = Int
hunk ./src/Network.hs 171
- (sameFromAndTo (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr }))
+ (sameFromAndTo (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = [] }))
hunk ./src/Network.hs 261
- edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr }
+ edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = [] }
hunk ./src/Network.hs 268
+-- | Insert a new 'via' control point in the middle of an edge.
+newViaEdge :: ZeroProb a => EdgeNr -> DoublePoint -> Network a -> Network a
+newViaEdge edgeNr point network =
+ network { networkEdges = adjust (\e->e{ edgeVia=(point:edgeVia e) })
+ edgeNr
+ (networkEdges network) }
+
hunk ./src/Network.hs 300
+-- | Remove a control point from an edge.
+removeVia :: ZeroProb a => EdgeNr -> ViaNr -> Network a -> Network a
+removeVia edgeNr viaNr network =
+ let remove n e = e { edgeVia = take n (edgeVia e)
+ ++ drop (n+1) (edgeVia e) } in
+ network { networkEdges = adjust (remove viaNr)
+ edgeNr (networkEdges network) }
+
hunk ./src/Network.hs 329
+
+updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network a -> Network a
+updateVia edgeNr viaNr v network =
+ network { networkEdges =
+ adjust (\e-> e { edgeVia = take viaNr (edgeVia e)
+ ++[v]++drop (viaNr+1) (edgeVia e) })
+ edgeNr (networkEdges network) }
hunk ./src/NetworkControl.hs 4
+ , createVia, selectVia
hunk ./src/NetworkControl.hs 6
+ , pickupVia, dragVia, dropVia
hunk ./src/NetworkControl.hs 14
-import Network(getNode, updateNode, addEdge, removeEdge, removeNode, addNode)
+import Network(getNode, updateNode, addEdge, removeEdge
+ , newViaEdge, removeVia, Edge(..), getEdge, updateVia
+ , removeNode, addNode)
hunk ./src/NetworkControl.hs 61
+ ViaSelection edgeNr viaNr ->
+ do{ PD.updateDocument "delete control point"
+ ( setSelection NoSelection
+ . updateNetwork (removeVia edgeNr viaNr)
+ ) pDoc
+ ; repaintAll state
+ }
hunk ./src/NetworkControl.hs 99
+
+createVia :: DoublePoint -> State -> IO ()
+createVia mousepoint state =
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; case getSelection doc of
+ EdgeSelection edgeNr -> [_$_]
+ do{ PD.updateDocument "add control point to edge"
+ ( setSelection (ViaSelection edgeNr 0)
+ . updateNetwork (newViaEdge edgeNr mousepoint)
+ ) pDoc
+ ; repaintAll state
+ }
+ _ -> return ()
+ }
+
+selectVia :: Int -> Int -> State -> IO ()
+selectVia edgeNr viaNr state = [_$_]
+ do{ pDoc <- getDocument state
+ ; PD.superficialUpdateDocument (setSelection (ViaSelection edgeNr viaNr))
+ pDoc
+ ; repaintAll state
+ }
+
+pickupVia :: Int -> Int -> DoublePoint -> State -> IO ()
+pickupVia edgeNr viaNr mousePoint state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ viaPos = (edgeVia (getEdge edgeNr network))!!viaNr
+ ; setDragging (Just (False, mousePoint `subtractDoublePoint` viaPos)) state
+ ; selectVia edgeNr viaNr state
+ }
hunk ./src/NetworkControl.hs 185
+dragVia :: Int -> Int -> DoublePoint -> ScrolledWindow () -> State -> IO ()
+dragVia edgeNr viaNr mousePoint canvas state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; Just (hasMoved, offset) <- getDragging state
+ ; let newPosition = mousePoint `subtractDoublePoint` offset
+ oldPosition = (edgeVia (getEdge edgeNr (getNetwork doc)))!!viaNr
+ ; when (newPosition /= oldPosition) $
+ 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" [_$_]
+ else PD.superficialUpdateDocument)
+ (updateNetwork (updateVia edgeNr viaNr newPosition))
+ pDoc
+ ; Graphics.UI.WX.repaint canvas
+ ; setDragging (Just (True, offset)) state [_$_]
+ -- yes, the point has really moved [_$_]
+ }
+ }
+
+dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State -> IO ()
+dropVia hasMoved edgeNr viaNr offset mousePoint state = [_$_]
+ do{ when hasMoved $
+ do{ let newPosition = mousePoint `subtractDoublePoint` offset
+ ; pDoc <- getDocument state
+ ; PD.superficialUpdateDocument
+ (updateNetwork (updateVia edgeNr viaNr newPosition))
+ pDoc
+ }
+ ; canvas <- getCanvas state
+ ; Graphics.UI.WX.repaint canvas
+ ; setDragging Nothing state
+ }
+
hunk ./src/NetworkControl.hs 239
+
hunk ./src/NetworkFile.hs 101
+ , simpleString "Via" (show (edgeVia edge))
hunk ./src/NetworkFile.hs 265
+ ; via <- getStringInsideTag "Via" contents "Edge"
hunk ./src/NetworkFile.hs 267
- ; warnAboutSuperfluousContents ["From", "To"] contents "Edge"
+ ; warnAboutSuperfluousContents ["From", "To", "Via"] contents "Edge"
hunk ./src/NetworkFile.hs 269
- ; return (nr, Edge { edgeFrom = fromNr, edgeTo = toNr })
+ ; return (nr, Edge { edgeFrom = fromNr, edgeTo = toNr
+ , edgeVia = (read via) })
hunk ./src/NetworkFile.hs 430
- | Edge f t <- multipleEdges
+ | Edge f t _ <- multipleEdges
hunk ./src/NetworkFile.hs 441
-checkEdge nodeNrs (edgeNr, Edge fromNr toNr)
+checkEdge nodeNrs (edgeNr, Edge fromNr toNr _)
hunk ./src/NetworkFile.hs 457
-sortEdge (Edge f t) | f < t = Edge f t
- | otherwise = Edge t f
+sortEdge (Edge f t v) | f < t = Edge f t v
+ | otherwise = Edge t f v
hunk ./src/NetworkView.hs 5
+ , clickedVia
hunk ./src/NetworkView.hs 24
+import qualified IntMap
hunk ./src/NetworkView.hs 54
+ ViaSelection edgeNr viaNr -> do
+ drawVia (getEdge edgeNr network) viaNr kSELECTED_OPTIONS
hunk ./src/NetworkView.hs 104
- (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr })
+ (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = via })
hunk ./src/NetworkView.hs 106
- do{ logicalLine ppi dc pt1 pt2 options
+ do{ logicalLineSegments ppi dc (pt1:via++[pt2]) options
hunk ./src/NetworkView.hs 116
- edgeVector = toPoint `subtractDoublePointVector` fromPoint
- totalLen = vectorLength edgeVector
- angle = vectorAngle edgeVector
+ fstEdgeVector = (head (via++[toPoint]))
+ `subtractDoublePointVector` fromPoint
+ fstTotalLen = vectorLength fstEdgeVector
+ fstAngle = vectorAngle fstEdgeVector
hunk ./src/NetworkView.hs 121
- pt1 = translatePolar angle kNODE_RADIUS fromPoint
- pt2 = translatePolar angle (totalLen - kNODE_RADIUS) fromPoint
+ penultimatePt = head (reverse (fromPoint:via))
+ endEdgeVector = toPoint `subtractDoublePointVector` penultimatePt
+ endTotalLen = vectorLength endEdgeVector
+ endAngle = vectorAngle endEdgeVector
hunk ./src/NetworkView.hs 126
- tr1 = translatePolar (angle + pi + pi / 6) kARROW_SIZE pt2
- tr2 = translatePolar (angle + pi - pi / 6) kARROW_SIZE pt2
+ pt1 = translatePolar fstAngle kNODE_RADIUS fromPoint
+ pt2 = translatePolar endAngle (endTotalLen - kNODE_RADIUS) penultimatePt
+
+ tr1 = translatePolar (endAngle + pi + pi / 6) kARROW_SIZE pt2
+ tr2 = translatePolar (endAngle + pi - pi / 6) kARROW_SIZE pt2
+
+ drawVia :: Edge -> ViaNr -> [Prop (DC ())] -> IO ()
+ drawVia e n options =
+ let pt = (edgeVia e)!!n in
+ do logicalCircle ppi dc pt kEDGE_CLICK_RANGE
+ (options ++ solidFill violet)
hunk ./src/NetworkView.hs 168
- (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr })
+ (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = via })
hunk ./src/NetworkView.hs 173
- in distanceSegmentPoint p0 p1 p < kEDGE_CLICK_RANGE
+ in any (< kEDGE_CLICK_RANGE)
+ (zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p)
+ (p0:via) (via++[p1]))
+
+-- | Finds which 'via' control point is clicked by the mouse, if any
+clickedVia :: DoublePoint -> Network a -> Maybe (Int,Int)
+clickedVia clickedPoint network =
+ let allVia = concatMap (\ (k,e)-> zipWith (\n v->((k,n),v))
+ [0..] (edgeVia e))
+ (IntMap.toList (networkEdges network))
+ in case filter (\ (_,v)-> distancePointPoint v clickedPoint
+ < kEDGE_CLICK_RANGE) allVia of
+ [] -> Nothing
+ ((kn,_):_) -> Just kn
hunk ./src/NetworkView.hs 210
+
+logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()
+logicalLineSegments _ _ [p] options = return ()
+logicalLineSegments ppi dc (fromPoint:toPoint:ps) options =
+ do{ line dc (logicalToScreenPoint ppi fromPoint)
+ (logicalToScreenPoint ppi toPoint) options
+ ; logicalLineSegments ppi dc (toPoint:ps) options
+ }
}