module FPPrac.Graphs
( Label
, Weight
, Node
, Edge
, Graph(..)
, ColorG(..)
, Thickness(..)
, Directed(..)
, Weighted(..)
, GraphOutput(..)
, GraphInput(..)
, Pos
, MouseButton(..)
, KeyboardButton
, onNode
, preEventloop
) where
import EventLoop
import EventLoop.Input as EI
import EventLoop.Output
type Vector = (Float, Float)
type Label = Char
type Weight = Int
type Node = (Label, Pos, ColorG)
type Edge = (Label, Label, ColorG, Weight)
data Graph = Graph
{ nodes :: [Node]
, edges :: [Edge]
, directed :: Directed
, weighted :: Weighted
} deriving (Eq, Show)
data ColorG = Red
| Blue
| Green
| Purple
| Grey
| Yellow
| Orange
| Black
| White
deriving (Eq, Show)
data Thickness = Thin
| Thick
data Directed = Directed
| Undirected
deriving (Eq, Show)
data Weighted = Weighted
| Unweighted
deriving (Eq, Show)
data GraphOutput = NodeG Label Pos ColorG
| LineG Node Node ColorG Thickness Directed
| WeightedLineG Node Node Weight ColorG Thickness Directed
| Instructions [String]
| RemoveNodeG Label
| RemoveEdgeG Label Label
nodeRadius = 20 :: Float
textSize = 16 :: Float
textFont = "Courier"
xArrowSize = 6 :: Float
yArrowSize = 6 :: Float
weightHeight = 10 :: Float
topInstructions = 440
dimCanvas = (840,840)
canvasWidth = fst dimCanvas
canvasHeight = snd dimCanvas
data GraphInput = MouseUp MouseButton Pos
| MouseDown MouseButton Pos
| MouseClick MouseButton Pos
| KeyPress KeyboardButton
| Start
onNode :: [Node] -> Pos -> Maybe Node
onNode [] _ = Nothing
onNode (n@(_, (nx, ny), _):ns) (x,y) | difference <= nodeRadius = Just n
| otherwise = onNode ns (x,y)
where
dx = nx x
dy = ny y
difference = sqrt (dx^2 + dy^2)
preEventloop :: (a -> GraphInput -> ([GraphOutput], a)) -> a -> IO ()
preEventloop handler beginState = start handler' beginState
where
handler' = changeTypes handler
changeTypes :: (a -> GraphInput -> ([GraphOutput], a)) -> a -> EI.InputEvent -> ([OutputEvent], a)
changeTypes _ state (EI.InSysMessage Setup) = ([OutSysMessage [CanvasSetup dimCanvas]],state)
changeTypes handler state inputE = (out, state')
where
inputE' = inputEventToGraphIn inputE
(graphOut, state') = handler state inputE'
out = map (\a -> OutGraphical a) $ concat $ map graphOutputToGraphical graphOut
inputEventToGraphIn :: EI.InputEvent -> GraphInput
inputEventToGraphIn (EI.InKeyboard k) = keyboardToGraphIn k
inputEventToGraphIn (EI.InMouse m ) = mouseToGraphIn m
inputEventToGraphIn (EI.InSysMessage Background) = Start
mouseToGraphIn :: EI.Mouse -> GraphInput
mouseToGraphIn (EI.MouseClick mb p _) = FPPrac.Graphs.MouseClick mb p
mouseToGraphIn (EI.MouseUp mb p _) = FPPrac.Graphs.MouseUp mb p
mouseToGraphIn (EI.MouseDown mb p _) = FPPrac.Graphs.MouseDown mb p
keyboardToGraphIn :: EI.Keyboard -> GraphInput
keyboardToGraphIn (EI.KeyPress k) = FPPrac.Graphs.KeyPress k
graphOutputToGraphical :: GraphOutput -> [Graphical]
graphOutputToGraphical (NodeG l pos colG) = [Draw (Container [nodeG, textG]) [l]]
where
col = colorGToColor colG
nodeG = GObject [l] (Arc black 1 col pos nodeRadius 0 360) []
textG = GObject [l] (Text white 1 white pos textSize textFont [l] True) []
graphOutputToGraphical (LineG (l1, pos1, _) (l2, pos2, _) colG thick direct) | direct == Directed = [Draw (Container [line, arrow1, arrow2]) name]
| direct == Undirected = [Draw line name]
where
name = lineName l1 l2
col = colorGToColor colG
thick' = thicknessToFloat thick
line = GObject name (Line col thick' [lineStart, lineEnd]) []
arrow1 = GObject name (Line col thick' [arrowStart, arrow1End]) []
arrow2 = GObject name (Line col thick' [arrowStart, arrow2End]) []
lineVector = vectorize pos1 pos2
lineVector' = vectorize pos2 pos1
lineStart = posOnVector nodeRadius lineVector pos1
lineEnd = posOnVector nodeRadius lineVector' pos2
arrowPerpStart = posOnVector xArrowSize lineVector' lineEnd
upPerpLineVector = upPerpendicularTo pos1 pos2
downPerpLineVector = downPerpendicularTo pos1 pos2
arrowStart = lineEnd
arrow1End = posOnVector yArrowSize upPerpLineVector arrowPerpStart
arrow2End = posOnVector yArrowSize downPerpLineVector arrowPerpStart
graphOutputToGraphical (WeightedLineG n1@(l1, pos1, _) n2@(l2, pos2, _) w colG thick direct) = lineGraphical ++ [Draw text name]
where
name = lineName l1 l2
col = colorGToColor colG
lineGraphical = graphOutputToGraphical (LineG n1 n2 colG thick direct)
text = GObject name (Text col 1 col textPos textSize textFont (show w) True) []
lineVector' = vectorize pos2 pos1
halfSize = vectorSize lineVector' / 2
upPerpLineVector = upPerpendicularTo pos2 pos1
textPerpStart = posOnVector halfSize lineVector' pos2
textPos = posOnVector weightHeight upPerpLineVector textPerpStart
graphOutputToGraphical (Instructions is) = [RemoveGroup "instructions", Draw isG' "instructions"]
where
lineG = GObject "instructions" (Line black lineHeight [(0,topInstructions), (canvasWidth, topInstructions)]) []
defaultText = (\str pos -> GObject "instructions" (Text black 1 black pos textSize textFont str False) [])
lineHeight = 2
textMargin = 2
positions = iterate ((+) (textSize + textMargin)) (topInstructions + lineHeight)
isWithPos = zip is positions
isG = map (\(str, top) -> defaultText str (0, top)) isWithPos
isG' = Container (lineG:isG)
graphOutputToGraphical (RemoveNodeG l) = [RemoveGroup [l]]
graphOutputToGraphical (RemoveEdgeG l1 l2) = [RemoveGroup (lineName l1 l2)]
lineName :: Char -> Char -> String
lineName l1 l2 = "line."++[l1]++"."++[l2]
thicknessToFloat :: Thickness -> Float
thicknessToFloat Thick = 2.0
thicknessToFloat Thin = 1.0
colorGToColor :: ColorG -> Color
colorGToColor Red = (255, 0, 0)
colorGToColor Blue = (0, 0, 255)
colorGToColor Green = (0, 255, 0)
colorGToColor Purple = (255, 0, 255)
colorGToColor Grey = (125, 125, 125)
colorGToColor Yellow = (255, 255, 0)
colorGToColor Orange = (255, 125, 0)
colorGToColor Black = (0, 0, 0)
colorGToColor White = (255, 255, 255)
black = colorGToColor Black
white = colorGToColor White
posOnVector :: Float -> Vector -> Pos -> Pos
posOnVector f (xv, yv) (xStart, yStart) = (x, y)
where
x = xStart + fraction * xv
y = yStart + fraction * yv
fraction = f / size
size = vectorSize (xv, yv)
vectorize :: Pos -> Pos -> Vector
vectorize (x1, y1) (x2, y2) = (x2 x1, y2 y1)
upPerpendicularTo :: Pos -> Pos -> Vector
upPerpendicularTo (x1, y1) (x2, y2) | y2 > y1 = (yv1 / size1, xv1 / size1)
| otherwise = (yv2 / size2, xv2 / size2)
where
(xv1, yv1) = vectorize (x1, y1) (x2, y2)
(xv2, yv2) = vectorize (x2, y2) (x1, y1)
size1 = vectorSize (xv1, yv1)
size2 = vectorSize (xv2, yv2)
downPerpendicularTo :: Pos -> Pos -> Vector
downPerpendicularTo (x1, y1) (x2, y2) | y1 > y2 = (yv1 / size1, xv1 / size1)
| otherwise = (yv2 / size2, xv2 / size2)
where
(xv1, yv1) = vectorize (x1, y1) (x2, y2)
(xv2, yv2) = vectorize (x2, y2) (x1, y1)
size1 = vectorSize (xv1, yv1)
size2 = vectorSize (xv2, yv2)
vectorSize :: Vector -> Float
vectorSize (x, y) = sqrt (x^2 + y^2)