Blobs-0.1: src/NetworkView.hs
module NetworkView
( drawCanvas
, clickedNode
, clickedEdge
, clickedVia
, edgeContains
) where
import Constants
import CommonIO
import Network
import Document
import Colors
import Common
import Palette
import 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 Shape
import DisplayOptions
import InfoKind
import Prelude hiding (catch)
import Control.Exception
import qualified Data.IntMap as IntMap
drawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) =>
Document g n e -> DC () -> DisplayOptions -> IO ()
drawCanvas doc 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 doc screenPPI dc opt)
(h1 dc dcPPI )
{-
(\e -> logicalText dcPPI dc (DoublePoint 50 50)
("Exception while drawing: "++show e)
(Justify LeftJ TopJ) [] )
-}
}
h1 :: DC () -> Size2D Int -> SomeException -> IO ()
h1 dc dcPPI e = logicalText dcPPI dc (DoublePoint 50 50)
("Exception while drawing: "++show e)
(Justify LeftJ TopJ) []
reallyDrawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) =>
Document g n e -> Size -> DC () -> DisplayOptions -> IO ()
reallyDrawCanvas doc ppi dc opt =
do{
-- draw global info on diagram
; let (width, _height) = Network.getCanvasSize network
; when (GlobalInfo `elem` dpShowInfo opt) $
drawLabel 0 False
(descriptor global++": "++(unwords.lines.show) global)
(DoublePoint (width/2) 1) (Justify CentreJ TopJ)
[ textColor := wxcolor kNodeLabelColour ]
-- draw edges, highlight the selected ones (if any)
; mapM_ (\edge -> drawEdge edge []) (getEdges network)
; case theSelection of
EdgeSelection edgeNr -> do
drawEdge (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 ->
drawNode nodeNr (kSELECTED_OPTIONS
++ [ penColor := wxcolor activeSelectionColor ])
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
network = getNetwork doc
theSelection = getSelection doc
(Palette palette) = getPalette network
global = getGlobalInfo network
drawNode :: Int -> [Prop (DC ())] -> IO ()
drawNode nodeNr options =
do{
-- draw node
; logicalDraw ppi dc center shape options
-- ; logicalCircle ppi dc center kNODE_RADIUS 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 ]
}
where
node = getNode nodeNr network
above = getNameAbove node
center = getPosition node
shape = either (\name-> maybe Shape.circle fst
(Prelude.lookup name palette))
id (getShape node)
offset b = (if b then negate else id) kNODE_RADIUS
justif b = Justify CentreJ (if b then BottomJ else TopJ)
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
}
drawEdge :: InfoKind e g => Edge e -> [Prop (DC ())] -> IO ()
drawEdge edge options =
do{ logicalLineSegments ppi dc (pt1:via++[pt2]) options
-- arrow on the end
; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill licorice)
-- 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
fromPoint = getPosition fromNode
toPoint = getPosition toNode
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 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 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 -> Maybe Int
clickedNode clickedPoint doc =
let network = getNetwork doc
nodeAssocs = case getSelection doc of
NodeSelection nodeNr -> [(nodeNr, getNode nodeNr network)]
_ -> []
++ reverse (getNodeAssocs network)
in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of
[] -> Nothing
((i, _):_) -> Just i
nodeContains :: Node n -> DoublePoint -> Bool
nodeContains node clickedPoint =
distancePointPoint (getPosition node) clickedPoint
< kNODE_RADIUS
-- | 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
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))
)
}