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) ----- Graph ----- 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) ----- Graph Graphical ----- 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 ----- Abstracted Input ------ 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]) [] --Vector stuff 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) [] --Vector stuff 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 -- The length between Start pos and Result pos is always f 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) -- Vector from p1 to p2 vectorize :: Pos -> Pos -> Vector vectorize (x1, y1) (x2, y2) = (x2 - x1, y2 - y1) -- Always has positive y and vector length 1 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) -- Always has negative y and vector length 1 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)