Thu Jul 28 15:09:58 WEST 2005 Malcolm.Wallace@cs.york.ac.uk
* improve control points
When adding a control point, make sure it is in the correct segment
of the line, not necessarily at one end. (from Arjan van IJzendoorn)
{
hunk ./src/Network.hs 269
-newViaEdge :: ZeroProb a => EdgeNr -> DoublePoint -> Network a -> Network a
-newViaEdge edgeNr point network =
- network { networkEdges = adjust (\e->e{ edgeVia=(point:edgeVia e) })
+newViaEdge :: ZeroProb a => EdgeNr -> ViaNr -> DoublePoint
+ -> Network a -> Network a
+newViaEdge edgeNr viaNr point network =
+ network { networkEdges = adjust (\e->e{ edgeVia= take viaNr (edgeVia e)
+ ++[point]
+ ++drop viaNr (edgeVia e) })
hunk ./src/NetworkControl.hs 17
+import NetworkView (edgeContains)
hunk ./src/NetworkControl.hs 105
+ ; let network = getNetwork doc
hunk ./src/NetworkControl.hs 107
- EdgeSelection edgeNr -> [_$_]
- do{ PD.updateDocument "add control point to edge"
- ( setSelection (ViaSelection edgeNr 0)
- . updateNetwork (newViaEdge edgeNr mousepoint)
- ) pDoc
- ; repaintAll state
+ EdgeSelection edgeNr ->
+ do{ ifJust (edgeContains (getEdge edgeNr network) mousepoint network)
+ $ \viaNr->
+ do{ PD.updateDocument "add control point to edge"
+ ( setSelection (ViaSelection edgeNr viaNr)
+ . updateNetwork (newViaEdge edgeNr viaNr mousepoint)
+ ) pDoc
+ ; repaintAll state
+ }
hunk ./src/NetworkView.hs 6
+ , edgeContains
hunk ./src/NetworkView.hs 163
- in case filter (\(_, edge) -> edgeContains edge clickedPoint network) assocs of
+ in case filter (\(_, edge) -> isJust (edgeContains edge clickedPoint network)) assocs of
hunk ./src/NetworkView.hs 167
-edgeContains :: Edge -> DoublePoint -> Network a -> Bool
+edgeContains :: Edge -> DoublePoint -> Network a -> Maybe Int
hunk ./src/NetworkView.hs 174
- in any (< kEDGE_CLICK_RANGE)
- (zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p)
- (p0:via) (via++[p1]))
+ numberedDistancesToSegments = zip [0..] $
+ zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p)
+ (p0:via) (via++[p1])
+ in case [ nr | (nr,dist) <- numberedDistancesToSegments
+ , dist < kEDGE_CLICK_RANGE ] of
+ [] -> Nothing
+ nrs -> Just (head nrs)
}