twentefp-0.4: examples/Graphics.hs
module Graphics where
import Prelude
import FPPrac.Graphics
import System.FilePath (splitPath, dropExtension)
data Thickness = Thin | Thick
deriving (Eq,Show)
alphabet = ['a'..'z']
type Node = (Char,Color,Point)
type Edge = (Char,Char,Color,Int)
data Graph = Graph
{ name :: String
, directed :: Bool
, weighted :: Bool
, nodes :: [Node]
, edges :: [Edge]
} deriving (Eq,Show)
data EdgeDrawingData = EdgeDrawingData
{ edgeStartpunt :: Point -- | (tx,ty): startpunt van edge
, edgeEndpunt :: Point -- | (px,py): eindpunt van edge
, innerPijlpunt :: Point -- | (qx,qy): binnenhoek van pijlpunt
, achterPijlpunt :: Point -- | (sx,sy): achterpunten van pijlpunt
, breedtePijlpunt :: Point -- | (wx,wy): breedte pijlputn
, edgeDikte :: Point -- | (dx,dy): dikte van de edge
, weightAfstand :: Point -- | (ax,ay): afstand gewicht tot pijlpunt
, weightMidden :: Point -- | (mx,my): midden van edge
}
edgeWidthThin = 1
edgeWidthThick = 1.5
nodeRadius = 15
weightDistance = 6
arrowHeight = 20
arrowDepth = 9
arrowWidth = 9
lblBoxW = 20
lblBoxH = 19
lblHshift = 8
lblVshift = -6
bottomLineHeight = 25
bottomTextHeight = 10
allEdgeDrawingData thickness graph (lbl1,lbl2,col,wght)
= EdgeDrawingData
{ edgeStartpunt = (tx,ty) -- startpunt van edge
, edgeEndpunt = (px,py) -- eindpunt van edge
, innerPijlpunt = (qx,qy) -- binnenhoek van pijlpunt
, achterPijlpunt = (sx,sy) -- achterpunten van pijlpunt
, breedtePijlpunt = (wx,wy) -- breedte pijlpunt
, edgeDikte = (dx,dy) -- dikte van de edge
, weightAfstand = (ax,ay) -- afstand gewicht tot pijlpunt
, weightMidden = (mx,my) -- midden van edge
}
where
Graph {directed=directed,nodes=nodes} = graph
(x1,y1) = head [ (x,y) | (lbl,_,(x,y)) <- nodes, lbl==lbl1 ]
(x2,y2) = head [ (x,y) | (lbl,_,(x,y)) <- nodes, lbl==lbl2 ]
rico = (y2-y1) / (x2-x1)
alpha | x2 > x1 = atan rico
| x2 == x1 && y2 > y1 = pi/2
| x2 < x1 = pi + atan rico
| x2 == x1 && y2 <= y1 = 3*pi/2
sina = sin alpha
cosa = cos alpha
(xr1,yr1) = (nodeRadius * cosa , nodeRadius * sina)
(tx ,ty ) = (x1+xr1,y1+yr1) -- start of edge
(px ,py ) = (x2-xr1,y2-yr1) -- outer arrow point
(xr2,yr2) = (arrowDepth * cosa , arrowDepth * sina)
(qx,qy) = (px-xr2,py-yr2) -- inner arrow point
(xh ,yh ) = (arrowHeight * cosa , arrowHeight * sina)
(sx ,sy ) = (px-xh,py-yh) -- back arrowpoints
(wx ,wy ) = (arrowWidth * sina , arrowWidth * cosa) -- width of arrowpoint
(dx ,dy ) | thickness == Thick = (edgeWidthThick * sina , edgeWidthThick * cosa)
| otherwise = (edgeWidthThin * sina , edgeWidthThin * cosa) -- edge thickness
(xwd,ywd) = (weightDistance * cosa , weightDistance * sina)
(ax ,ay ) = (px-xwd,py-ywd) -- distance of weight from arrowpoint
(mx ,my ) = ((x2+x1)/2,(y2+y1)/2) -- mid of (undirected) edge
drawNode :: Node -> Picture
drawNode (lbl,col,(x,y))
= Pictures
[ Translate x y $ Color col $ circleSolid r
, Translate x y $ Color black $ Circle r
, Translate (x-lblHshift) (y+lblVshift) $ Color black $ Scale 0.15 0.15 $ Text [lbl]
]
where
r = nodeRadius
drawEdgeTemp :: Color -> (Point,Point) -> Picture
drawEdgeTemp col (p1,p2)
= Color col $ Line [p1,p2]
drawEdge :: Graph -> Edge -> Picture
drawEdge graph edge
| directed =
Pictures
[ Color col $ Polygon [ (tx+dx,ty-dy), (tx-dx,ty+dy), (qx-dx,qy+dy), (qx+dx,qy-dy), (tx+dx,ty-dy) ]
, Color white $ Polygon [ (px+dx,py-dy), (px-dx,py+dy), (qx-dx,qy+dy), (qx+dx,qy-dy), (px+dx,py-dy) ]
, Color col $ Polygon [ (px,py), (sx-wx,sy+wy), (qx,qy), (sx+wx,sy-wy), (px,py) ]
]
| otherwise =
Color col $ Polygon [ (tx+dx,ty-dy), (tx-dx,ty+dy), (px-dx,py+dy), (px+dx,py-dy), (tx+dx,ty-dy) ]
where
Graph {directed=directed} = graph
(_,_,col,_) = edge
EdgeDrawingData
{ edgeStartpunt = (tx,ty) -- startpunt van edge
, edgeEndpunt = (px,py) -- eindpunt van edge
, innerPijlpunt = (qx,qy) -- binnenhoek van pijlpunt
, achterPijlpunt = (sx,sy) -- achterpunten van pijlpunt
, breedtePijlpunt = (wx,wy) -- breedte pijlpunt
, edgeDikte = (dx,dy) -- dikte van de edge
} = allEdgeDrawingData Thin graph edge
drawThickEdge :: Graph -> Edge -> Picture
drawThickEdge graph edge
| directed =
Pictures
[ Color col $ Polygon [ (tx+dx,ty-dy), (tx-dx,ty+dy), (qx-dx,qy+dy), (qx+dx,qy-dy), (tx+dx,ty-dy) ]
, Color white $ Polygon [ (px+dx,py-dy), (px-dx,py+dy), (qx-dx,qy+dy), (qx+dx,qy-dy), (px+dx,py-dy) ]
, Color col $ Polygon [ (px,py), (sx-wx,sy+wy), (qx,qy), (sx+wx,sy-wy), (px,py) ]
]
| otherwise =
Color col $ Polygon [ (tx+dx,ty-dy), (tx-dx,ty+dy), (px-dx,py+dy), (px+dx,py-dy), (tx+dx,ty-dy) ]
where
Graph {directed=directed} = graph
(_,_,col,_) = edge
EdgeDrawingData
{ edgeStartpunt = (tx,ty) -- startpunt van edge
, edgeEndpunt = (px,py) -- eindpunt van edge
, innerPijlpunt = (qx,qy) -- binnenhoek van pijlpunt
, achterPijlpunt = (sx,sy) -- achterpunten van pijlpunt
, breedtePijlpunt = (wx,wy) -- breedte pijlpunt
, edgeDikte = (dx,dy) -- dikte van de edge
} = allEdgeDrawingData Thick graph edge
drawWeight :: Graph -> Edge -> Picture
drawWeight graph edge
| not weighted = Blank
| directed = Pictures
[ Translate ax ay $ Color white $ rectangleSolid lblBoxW lblBoxH
, Translate (ax-lblHshift) (ay+lblVshift) $ Color black $ Scale 0.11 0.11 $ Text (show wght)
]
| otherwise = Pictures
[ Translate mx my $ Color white $ rectangleSolid lblBoxW lblBoxH
, Translate (mx-lblHshift) (my+lblVshift) $ Color black $ Scale 0.11 0.11 $ Text (show wght)
]
where
Graph {directed=directed,weighted=weighted}=graph
(_,_,_,wght) = edge
EdgeDrawingData
{ weightAfstand = (ax,ay) -- afstand gewicht tot pijlpunt
, weightMidden = (mx,my) -- midden van edge
}
= allEdgeDrawingData Thin graph edge
drawGraph :: Graph -> Picture
drawGraph graph
= Pictures $
Color white (rectangleSolid 800 564)
: (map drawNode nodes)
++ (map (drawEdge graph) edges)
++ (map (drawWeight graph) edges)
where
Graph {name=name,nodes=nodes,edges=edges}=graph
drawBottomLine :: Graph -> Picture
drawBottomLine graph
= Pictures
[ Translate 0 (-300 + bottomLineHeight / 2) $ Color white $ rectangleSolid 800 bottomLineHeight
, Color black $ Line [(-400,height1),(400,height1)]
, Color black $ Line [(-240,height1),(-240,-300)]
, Color black $ Line [(100,height1),(100,-300)]
, Translate (-392) height2 $ Color black $ Scale 0.11 0.11 $ Text "create:"
, Translate (-332) height2 $ Color red $ Scale 0.11 0.11 $ Text $ (case (name graph) of "" -> "" ; xs -> dropExtension $ last $ splitPath xs)
, Translate (-235) height2 $ Color black $ Scale 0.11 0.11 $ Text "click: node; drag: edge; double: remove node"
, Translate 120 height2 $ Color black $ Scale 0.11 0.11 $ Text "[n]ew; [r]ead; [s]ave; save [a]s; prac[6]"
]
where
height1 = -300 + bottomLineHeight
height2 = -300 + bottomTextHeight