INblobs-0.1.1: src/NetworkView.hs
module NetworkView
( drawCanvas
, clickedNode
, clickedNodePort
, clickedEdge
, clickedVia
, edgeContains
) where
import Constants
import CommonIO
import Network
import Document
import Colors
import Common
import Palette
import Ports
import Math
import Graphics.UI.WX as WX hiding (Vector, Selection)
import Graphics.UI.WXCore hiding (Document, screenPPI, Colour, Palette)
import Graphics.UI.WXCore.Draw
import Data.Maybe
import Shape
import DisplayOptions
import InfoKind
import Prelude hiding (catch)
import Control.Exception
import qualified Data.IntMap as IntMap
import Data.List
drawCanvas :: (InfoKind n g, InfoKind e g) =>
Network g n e -> Palette n -> Selection -> [NodeNr] -- interface nodes mapped
-> DC () -> DisplayOptions -> IO ()
drawCanvas net palette selec p dc opt =
do{
-- Scale if the DC we are drawing to has a different PPI from the screen
-- Printing, nudge, nudge
; dcPPI <- dcGetPPI dc
; screenPPI <- getScreenPPI
; when (dcPPI /= screenPPI) $
dcSetUserScale dc
(fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI ))
(fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI ))
-- Set font
; set dc [ fontFamily := FontDefault, fontSize := 10 ]
; catch (reallyDrawCanvas net palette selec p screenPPI dc opt)
(\e -> logicalText dcPPI dc (DoublePoint 50 50)
("Exception while drawing: "++show e)
(Justify LeftJ TopJ) [] )
}
reallyDrawCanvas :: (InfoKind n g, InfoKind e g) =>
Network g n e -> Palette n -> Selection -> [NodeNr]
-> Size -> DC () -> DisplayOptions -> IO ()
reallyDrawCanvas network palette theSelection mapp ppi dc opt =
do{
-- draw edges, highlight the selected ones (if any)
; mapM_ (\edge -> drawEdge edge []) (getEdgeAssocs network)
; case theSelection of
EdgeSelection _ edgeNr -> do
drawEdge (edgeNr, getEdge edgeNr network) kSELECTED_OPTIONS
ViaSelection _ edgeNr viaNr -> do
drawVia (getEdge edgeNr network) viaNr kSELECTED_OPTIONS
MultipleSelection _ _ _ viaNrs -> do
mapM_ (\ (e,v)-> drawVia (getEdge e network) v kSELECTED_OPTIONS)
viaNrs
_ -> return ()
-- draw nodes, highlight the selected ones (if any)
; mapM_ (\(nodeNr, _) -> drawNode nodeNr [ ]) (getNodeAssocs network)
; case theSelection of
NodeSelection _ nodeNr mPort ->
do drawNode nodeNr (kSELECTED_OPTIONS
++ [ penColor := wxcolor activeSelectionColor ])
case mPort of
Nothing -> return ()
Just str -> drawPort ppi dc
(getPosition $ getNode nodeNr network)
[brushKind := BrushSolid
, brushColor := kPortSelectedColor]
$ snd $ takeJust "inexistent port" $ getPort palette network (nodeNr, str)
MultipleSelection _ _ nodeNrs _ ->
mapM_ (\n-> drawNode n (kSELECTED_OPTIONS
++ [ penColor := wxcolor activeSelectionColor ]))
nodeNrs
_ -> return ()
-- multiple selection drag area rectangle
; case theSelection of
MultipleSelection _ (Just (p,q)) _ _ ->
logicalRect ppi dc (doublePointX p) (doublePointY p)
(doublePointX q - doublePointX p)
(doublePointY q - doublePointY p)
[ penColor := wxcolor lightGrey
, brushKind := BrushTransparent]
_ -> return ()
-- canvas size rectangle
-- ; let (width, height) = Network.getCanvasSize (getNetwork doc)
-- ; logicalRect ppi dc 0 0 width height [brushKind := BrushTransparent]
}
where
drawNode :: Int -> [Prop (DC ())] -> IO ()
drawNode nodeNr options =
do{
-- draw node
; logicalDraw ppi dc center shape options
-- ; logicalCircle ppi dc center kNODE_RADIUS options
; drawPorts ppi dc center ports options
-- draw label
; when (NodeLabel `elem` dpShowInfo opt) $
drawLabel (offset above) False (getName node) center
(justif above) [ textColor := wxcolor kNodeLabelColour ]
-- draw info
; when (NodeInfo `elem` dpShowInfo opt) $
drawLabel (offset (not above)) False (show (getInfo node))
center (justif (not above))
[ textColor := wxcolor kNodeInfoColour ]
-- draw mapping numbering when needed
; maybe ( return () )
showInterfaceMap
$ findIndex (nodeNr ==) mapp
}
where
node = getNode nodeNr network
above = getNameAbove node
center = getPosition node
symbol = takeJust "No symbol definition"
$ getSymbol (getShape node) palette
shape = fst3 symbol
ports = snd3 symbol
offset b = (if b then negate else id) kNODE_RADIUS
justif b = Justify CentreJ (if b then BottomJ else TopJ)
showInterfaceMap n =
drawLabel 0.15 True (show $ succ n) center
(justif above) [ textColor := wxcolor kNodeMapColour ]
drawLabel :: Double -> Bool -> String -> DoublePoint -> Justify
-> [Prop (DC ())] -> IO ()
drawLabel voffset boxed text (DoublePoint x y) justify opts =
do{ -- draw background
when boxed $ do
{ (textWidth, textHeight) <- logicalGetTextExtent ppi dc text
; let horizontalMargin = 0.2 -- centimeters
verticalMargin = 0.01 -- centimeters
topleftY = y+voffset - case justify of
Justify _ TopJ -> 0
Justify _ MiddleJ -> textHeight/2
Justify _ BottomJ -> textHeight
; logicalRect ppi dc
(x - textWidth/2 - horizontalMargin) (topleftY)
(textWidth+2*horizontalMargin) (textHeight+2*verticalMargin)
(solidFill labelBackgroundColor)
}
-- draw text
; logicalText ppi dc (DoublePoint x (y+voffset)) text justify opts
}
isPrincipalPort' (nodeNr, port) =
isPrincipalPort palette network nodeNr port && not (isInterfacePort port)
isPrincipalPort' _ = False
drawEdge :: InfoKind e g => (EdgeNr, Edge e) -> [Prop (DC ())] -> IO ()
drawEdge (edgeNr, edge) options =
do{ logicalLineSegments ppi dc (pt1:via++[pt2]) options
-- arrow on the end
-- ; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill licorice)
-- arrow(s) on principal ports
; when hasPrincipalPorts
$ do when (isPrincipalPort' fromPort)
$ logicalLine ppi dc [tw1, pw1, tw2] options
when (isPrincipalPort' toPort)
$ logicalLine ppi dc [tw3, pw2, tw4] options
-- draw label
; when (EdgeLabel `elem` dpShowInfo opt) $
drawLabel 0 False (int2name edgeNr)
(translate (DoublePoint 0.2 0.1 )$ middle via)
(Justify LeftJ TopJ)
[ textColor := wxcolor kEdgeLabelColour ]
-- draw info
; when (EdgeInfo `elem` dpShowInfo opt) $
-- logicalTextRotated ppi dc (middle via) (show info) 45
-- [ textColor := wxcolor kEdgeInfoColour ]
drawLabel 0 False (show (getEdgeInfo edge)) (middle via)
(Justify CentreJ BottomJ)
[ textColor := wxcolor kEdgeInfoColour ]
}
where
fromNode = getNode (getEdgeFrom edge) network
toNode = getNode (getEdgeTo edge) network
fromPort = getFullPortFrom edge
toPort = getFullPortTo edge
radius = kPortRadius
fromNodePoint = getPosition fromNode
toNodePoint = getPosition toNode
fromPortPosition = snd . takeJust "Inexistent port" $ getPort palette network fromPort
toPortPosition = snd . takeJust "Inexistent port" $ getPort palette network toPort
fromPoint = translate fromNodePoint fromPortPosition
toPoint = translate toNodePoint toPortPosition
via = getEdgeVia edge
fstEdgeVector = (head (via++[toPoint]))
`subtractDoublePointVector` fromPoint
fstTotalLen = vectorLength fstEdgeVector
fstAngle = vectorAngle fstEdgeVector
penultimatePt = head (reverse (fromPoint:via))
endEdgeVector = toPoint `subtractDoublePointVector` penultimatePt
endTotalLen = vectorLength endEdgeVector
endAngle = vectorAngle endEdgeVector
middle [] = DoublePoint ((doublePointX pt1 + doublePointX pt2)/2)
((doublePointY pt1 + doublePointY pt2)/2)
middle [p] = p
middle ps = middle (tail (reverse ps))
pt1 = translatePolar fstAngle radius fromPoint
pt2 = translatePolar endAngle (endTotalLen - radius) penultimatePt
tr1 = translatePolar (endAngle + pi + pi / 6) kARROW_SIZE pt2
tr2 = translatePolar (endAngle + pi - pi / 6) kARROW_SIZE pt2
pw1 = translatePolar fstAngle (radius + kARROW_SIZE) fromPoint
pw2 = translatePolar endAngle (endTotalLen - radius - kARROW_SIZE) penultimatePt
tw1 = translatePolar (fstAngle + pi + pi / 6) kARROW_SIZE pw1
tw2 = translatePolar (fstAngle + pi - pi / 6) kARROW_SIZE pw1
tw3 = translatePolar (endAngle + pi / 6) kARROW_SIZE pw2
tw4 = translatePolar (endAngle - pi / 6) kARROW_SIZE pw2
drawVia :: Edge e -> ViaNr -> [Prop (DC ())] -> IO ()
drawVia e n options =
let pt = (getEdgeVia e)!!n in
do logicalCircle ppi dc pt kEDGE_CLICK_RANGE
(options ++ solidFill violet)
solidFill :: Colour -> [Prop (DC ())]
solidFill colour = [ brushKind := BrushSolid, brushColor := wxcolor colour ]
-- | Finds which node of the network is clicked by the mouse, if any
clickedNode :: DoublePoint -> Document g n e -> ActiveCanvas -> Maybe Int
clickedNode clickedPoint doc canvas =
let network = selectNetwork doc canvas
nodeAssocs = case getSelection doc of
NodeSelection canv nodeNr _
| canv == canvas -> [(nodeNr, getNode nodeNr network)]
| otherwise -> []
_ -> []
++ reverse (getNodeAssocs network)
in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of
[] -> Nothing
((i, _):_) -> Just i
-- | Finds which node and port of the network is clicked by the mouse, if any
clickedNodePort :: DoublePoint -> Document g n e -> ActiveCanvas
-> Maybe (NodeNr, Maybe PortName)
clickedNodePort clickedPoint doc canvas =
let network = selectNetwork doc canvas
nodeAssocs = case getSelection doc of
NodeSelection canv nodeNr _
| canv == canvas -> [(nodeNr, getNode nodeNr network)]
| otherwise -> []
_ -> []
++ reverse (getNodeAssocs network)
in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of
[] -> Nothing
((i, n):_) -> case getPorts (getPalette doc) network i of
Nothing -> Nothing -- no symbol definition. Shouldn't occur
Just ps ->
case filter (\p -> portContains n p clickedPoint) ps of
[] -> Just (i, Nothing) -- if the mouse is over a node
-- with ports but not over any
-- of its ports the node is selected
(port:_) -> Just (i, Just $ fst port)
nodeContains :: Node n -> DoublePoint -> Bool
nodeContains node clickedPoint =
distancePointPoint (getPosition node) clickedPoint
< kNODE_RADIUS
portContains :: Node n -> Port -> DoublePoint -> Bool
portContains node (_, portP) clickedPoint =
distancePointPoint portCenter clickedPoint
< kPortSelectionRadius
where portCenter = translate (getPosition node) portP
-- | Finds which edge of the network is clicked by the mouse, if any
clickedEdge :: DoublePoint -> Network g n e -> Maybe Int
clickedEdge clickedPoint network =
let assocs = getEdgeAssocs network
in case filter (\(_, edge) -> isJust (edgeContains edge clickedPoint network)) assocs of
[] -> Nothing
((i, _):_) -> Just i
edgeContains :: Edge e -> DoublePoint -> Network g n e -> Maybe Int
edgeContains edge clickedPoint network =
let p0 = getNodePosition network (getEdgeFrom edge)
p1 = getNodePosition network (getEdgeTo edge)
via= getEdgeVia edge
p = clickedPoint
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)
-- | Finds which 'via' control point is clicked by the mouse, if any
clickedVia :: DoublePoint -> Network g n e -> Maybe (Int,Int)
clickedVia clickedPoint network =
let allVia = concatMap (\ (k,e)-> zipWith (\n v->((k,n),v))
[0..] (getEdgeVia e))
(IntMap.toList (networkEdges network))
in case filter (\ (_,v)-> distancePointPoint v clickedPoint
< kEDGE_CLICK_RANGE) allVia of
[] -> Nothing
((kn,_):_) -> Just kn
-- Drawing operations in logical coordinates
logicalCircle :: Size -> DC () -> DoublePoint -> Double -> [Prop (DC ())] -> IO ()
logicalCircle ppi dc center radius options =
WX.circle dc (logicalToScreenPoint ppi center) (logicalToScreenX ppi radius) options
logicalRect :: Size -> DC () -> Double -> Double -> Double -> Double -> [Prop (DC ())] -> IO ()
logicalRect ppi dc x y width height options =
drawRect dc
(rect
(pt (logicalToScreenX ppi x) (logicalToScreenY ppi y))
(sz (logicalToScreenX ppi width) (logicalToScreenY ppi height)))
options
data Justify = Justify Horizontal Vertical deriving Eq
data Horizontal = LeftJ | CentreJ | RightJ deriving Eq
data Vertical = TopJ | MiddleJ | BottomJ deriving Eq
-- can deal with multi-line text
logicalText :: Size -> DC () -> DoublePoint -> String -> Justify
-> [Prop (DC ())] -> IO ()
logicalText ppi dc (DoublePoint x y) txt (Justify horiz vert) options =
do{ (width,height) <- logicalGetTextExtent ppi dc txt
; eachLine width (startPos height) (lines txt)
}
where
startPos height = case vert of TopJ -> (x, y)
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))
options
; eachLine maxwidth (x,y+h) txts
}
-- currently assumes only single line of text
logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double
-> [Prop (DC ())] -> IO ()
logicalTextRotated ppi dc pos txt angle options =
draw dc txt (logicalToScreenPoint ppi pos) options
where
draw = if angle<1 && angle>(-1) then drawText
else (\a b c e -> rotatedText a b c angle e)
{-
logicalLine :: Size -> DC () -> DoublePoint -> DoublePoint -> [Prop (DC ())] -> IO ()
logicalLine ppi dc fromPoint toPoint options =
line dc (logicalToScreenPoint ppi fromPoint)
(logicalToScreenPoint ppi toPoint) options
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
}
-}
logicalPoly :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()
logicalPoly ppi dc points options =
polygon dc (map (logicalToScreenPoint ppi) points) options
logicalLine :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()
logicalLine ppi dc points options =
polyline dc (map (logicalToScreenPoint ppi) points) options
logicalGetTextExtent :: Size -> DC () -> String -> IO (Double, Double)
logicalGetTextExtent ppi dc txt =
do{ textSizes <- mapM (getTextExtent dc) (lines txt)
; return
( screenToLogicalX ppi (maximum (map sizeW textSizes))
, screenToLogicalY ppi (sum (map sizeH textSizes))
)
}