twentefp-graphs (empty) → 0.1.0.0
raw patch · 4 files changed
+293/−0 lines, 4 filesdep +basedep +twentefp-eventloop-graphicssetup-changed
Dependencies added: base, twentefp-eventloop-graphics
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/FPPrac/Graphs.hs +243/−0
- twentefp-graphs.cabal +18/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Christiaan Baaij & Sebastiaan la Fleur + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Christiaan Baaij & Sebastiaan la Fleur nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ src/FPPrac/Graphs.hs view
@@ -0,0 +1,243 @@+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)
+ twentefp-graphs.cabal view
@@ -0,0 +1,18 @@+name: twentefp-graphs +version: 0.1.0.0 +synopsis: Lab Assignments Environment at Univeriteit Twente +description: Lab Assignments Environment at Univeriteit Twente +license: BSD3 +license-file: LICENSE +author: Christiaan Baaij & Sebastiaan la Fleur +maintainer: sebastiaan.la.fleur@gmail.com +category: Education +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: FPPrac.Graphs + other-modules: + build-depends: base >=4.6.0.0 && < 5, + twentefp-eventloop-graphics >= 0.1.0.2 + hs-source-dirs: src