twentefp (empty) → 0.4
raw patch · 16 files changed
+1801/−0 lines, 16 filesdep +basedep +glossdep +parsecsetup-changed
Dependencies added: base, gloss, parsec, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/CreateGraph.hs +314/−0
- examples/Graphics.hs +202/−0
- examples/RBgraphics.hs +148/−0
- examples/RBrun.hs +67/−0
- examples/RoseTree.hs +130/−0
- examples/prac6.hs +46/−0
- src/FPPrac.hs +8/−0
- src/FPPrac/Events.hs +352/−0
- src/FPPrac/GUI/Panel.hs +154/−0
- src/FPPrac/GUI/Prompt.hs +53/−0
- src/FPPrac/Graphics.hs +25/−0
- src/FPPrac/Prelude.hs +92/−0
- src/FPPrac/Prelude/Number.hs +137/−0
- twentefp.cabal +41/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Christiaan Baaij + +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 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
+ examples/CreateGraph.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Rank2Types #-}+module CreateGraph where++import Prelude+import FPPrac.Graphics+import FPPrac.Events+import Graphics++import Data.Char+import Data.List(sort,(\\))++import Debug.Trace++data Process = MakingNode | MakingEdge | DoingNothing+ deriving (Eq,Show)++data Store a = Store+ { graph :: Graph+ , startNode :: Node+ , endNode :: Node+ , process :: Process+ , userHandler :: a -> Input -> (a,[Output])+ , userHandlerEnabled :: Bool+ , userState :: a+ , userStateInit :: Graph -> a+ , userGraphLens :: a -> Graph+ , userBottomLine :: Graph -> Picture+ }++startGraph = Graph {name="",directed=False,weighted=False,nodes=[],edges=[]}+nullNode = ('-',white,(0,0))+clearStore s = s {startNode=nullNode, endNode=nullNode, process=DoingNothing, userHandlerEnabled = False}+startStore h i l b = Store + { graph = startGraph+ , startNode = nullNode+ , endNode = nullNode+ , process = DoingNothing+ , userHandler = h+ , userHandlerEnabled = False+ , userState = i startGraph+ , userStateInit = i+ , userGraphLens = l+ , userBottomLine = b+ }++distance (x0,y0) (x1,y1) = sqrt ((x1-x0)^2 + (y1-y0)^2)++freespace graph p = nodes==[] || minimum [distance p (x,y) | (_,_,(x,y)) <- nodes] > distfactor*nodeRadius+ where+ Graph {directed=directed,weighted=weighted,nodes=nodes}=graph+ distfactor | directed && weighted = 7+ | directed || weighted = 5+ | otherwise = 3+++node2text (lbl,col,(x,y)) = lbl : (show $ rgbaOfColor col) ++ ":" ++ show x ++ "," ++ show y ++ "\n"++edge2text (lbl1,lbl2,col,wght)+ = [lbl1,lbl2] ++ show (rgbaOfColor col) ++ ":" ++ show wght ++ "\n"++text2node :: String -> Node+text2node line = (lbl, col, (read x, read (tail y)))+ where+ lbl = head line+ col = (\(r,g,b,a) -> makeColor r g b a) $ read $ takeWhile (/=':') (tail line)+ (x,y) = span (/=',') (tail (dropWhile (/=':') line))+ +text2edge :: String -> Edge +text2edge line = (lbl1,lbl2, col, read (tail awght))+ where+ (lbl1,lbl2) = (head line, head (tail line))+ (acol,awght) = span (/=':') (drop 2 line)+ col = (\(r,g,b,a) -> makeColor r g b a) $ read acol+ +createGraph :: + forall a + . Store a + -> Input + -> (Store a,[Output])+ +createGraph store@(Store {userHandlerEnabled=True,..}) (KeyIn 'q') + = (s', [DrawPicture $ drawBottomLine graph'])+ where+ graph' = userGraphLens userState+ userState' = userStateInit graph'+ s' = clearStore $ store {graph=graph',userState=userState'}++createGraph store@(Store {userHandlerEnabled=True, ..}) i+ = (store {userState = userState'}, o) + where+ (userState',o) = userHandler userState i++createGraph store (MouseDown (x,y))+ | nodeClicked /= Nothing = (newStoreE, [DrawOnBuffer False])+ | otherwise = (newStoreN, [])+ where+ Store {graph=graph} = store+ Graph {nodes=nodes} = graph+ + nodeClicked = onNode nodes (x,y)+ Just newNode = nodeClicked+ + newStoreN = store {process=MakingNode}+ newStoreE = store {startNode=newNode, process=MakingEdge}++createGraph store (MouseMotion (x,y))+ | process == MakingEdge = (store,[DrawOnBuffer False, DrawPicture $ drawEdgeTemp black (startPoint,(x,y))])+ | otherwise = (store,[])+ where+ Store {startNode=(_,_,startPoint),process=process} = store++createGraph store (MouseUp (x,y))+ | process == MakingNode+ , freespace graph (x,y)+ , freeLabels /= ""+ = (newStoreN, [DrawPicture $ drawNode newNode])+ + | process == MakingEdge+ , nodeClicked == Nothing+ = (storeCl, [DrawOnBuffer True, DrawPicture $ Pictures [drawGraph graph, drawBottomLine graph]])+ + | process == MakingEdge+ , weighted+ , lblE /= lblS+ , not alreadyConnected+ = (newStoreE1, [DrawOnBuffer True, GraphPrompt ("weight", "maximum 99")])+ + | process == MakingEdge+ , not weighted+ , lblE /= lblS+ , not alreadyConnected+ = (newStoreE2, [DrawOnBuffer True, DrawPicture $ Pictures [drawGraph newGraphE2, drawBottomLine newGraphE2]])+ + | otherwise+ = (storeCl, [DrawOnBuffer True, DrawPicture $ Pictures [drawGraph graph, drawBottomLine graph]])+ + where+ Store {startNode=(lblS,colS,crdsS),..} = store+ Graph {..} = graph+ + -- New node+ freeLabels = alphabet \\ [lbl | (lbl,_,_) <- nodes]+ newLabel = head (sort freeLabels)+ newNode = (newLabel, white, (x,y))+ + newGraphN = graph {nodes=newNode:nodes}+ newStoreN = clearStore $ store {graph=newGraphN}+ + -- New edge+ nodeClicked = onNode nodes (x,y)+ Just (lblE,colE,crdsE) = nodeClicked+ + alreadyConnected | directed = elem lblE [ lbl2 | (lbl1,lbl2,col,wght) <- edges+ , lbl1 == lblS ]+ | otherwise = not $ null + [lbl1 | (lbl1,lbl2,coll,wght) <- edges+ , (lbl1 == lblS && lbl2 == lblE)+ || (lbl1 == lblE && lbl2 == lblS)+ ]+ + newStoreE1 = store {endNode = (lblE,colE,crdsE)}+ + newEdge = (lblS, lblE, black, 0)+ newGraphE2 = graph {edges = newEdge:edges}+ newStoreE2 = clearStore $ store {graph = newGraphE2}+ + -- Clear store+ storeCl = clearStore store++createGraph store (MouseDoubleClick (x,y))+ | nodeClicked /= Nothing+ = (newStore, [DrawPicture $ Pictures [drawGraph newGraph, drawBottomLine newGraph]])+ | otherwise+ = (store, [])+ where+ Store {graph=graph} = store+ Graph {nodes=nodes,edges=edges} = graph+ + nodeClicked = onNode nodes (x,y)+ Just (lblClicked,_,_) = nodeClicked+ + newNodes = [ (lbl,col,(x,y)) | (lbl,col,(x,y)) <- nodes , lbl /= lblClicked ]+ newEdges = [ (lbl1,lbl2,c,w) | (lbl1,lbl2,c,w) <- edges + , lbl1 /= lblClicked+ , lbl2 /= lblClicked + ]+ + newGraph = graph {nodes=newNodes, edges=newEdges}+ newStore = store {graph = newGraph}++createGraph store (Prompt ("weight", weight))+ | weight /= ""+ , all isDigit weight+ = (newStoreE, [DrawPicture $ Pictures [drawGraph newGraph, drawBottomLine newGraph]])+ | otherwise+ = (newStore, [DrawPicture $ Pictures [drawGraph graph, drawBottomLine graph]])+ where+ Store {graph=graph, startNode=(lblS,_,_), endNode=(lblE,_,_)} = store+ Graph {edges=edges} = graph+ + newEdge = (lblS, lblE, black, read weight)+ + newGraph = graph {edges = newEdge:edges}+ newStoreE = store {graph=newGraph, startNode = nullNode, endNode = nullNode, process=DoingNothing}+ + newStore = store {startNode = nullNode, endNode = nullNode, process = DoingNothing}++createGraph store (KeyIn 'n')+ = (store,[newPanel,newPanelVisible])+ +createGraph store (Panel 1 [(60,dir), (70,wghtd)])+ = (newStore,[newPanelInvisible,DrawPicture $ Pictures [drawGraph newGraph,drawBottomLine newGraph]])+ where+ newGraph = Graph+ { name = ""+ , directed = dir == "Y"+ , weighted = wghtd == "Y"+ , nodes = []+ , edges = []+ }+ newStore = store {graph=newGraph}++createGraph store (KeyIn 'r')+ = (store,[GraphPrompt ("Read graph", "filename")])++createGraph store (Prompt ("Read graph", fileName))+ | fileName /= "" = (store, [ReadFile fileName (TXTFile "")])+ | otherwise = (store, [])+ +createGraph store (File fileName (TXTFile input))+ | input /= "" + = (newStore, [DrawPicture $ Pictures [drawGraph newGraph, drawBottomLine newGraph]])+ | otherwise + = (store,[])+ where+ (ns,bs) = (span (/="--") . drop 2 . lines) input+ directed = (head . lines) input == "directed:yes"+ weighted = (head . tail . lines) input == "weighted:yes"+ + newGraph = Graph + { name = fileName+ , directed = directed+ , weighted = weighted+ , nodes = map text2node ns+ , edges = map text2edge (tail bs)+ }+ + newStore = clearStore $ store {graph=newGraph}++createGraph store (KeyIn 's')+ | nm /= "" = (store, [SaveFile nm (TXTFile savetext)])+ | otherwise = (store, [GraphPrompt ("save as", "filename")])+ where+ Graph {name=nm,directed=directed,weighted=weighted,nodes=nodes,edges=edges} = graph store+ + dirweight | directed && weighted = "directed:yes\nweighted:yes\n"+ | directed = "directed:yes\nweighted:no\n"+ | weighted = "directed:no\nweighted:yes\n"+ | otherwise = "directed:no\nweighted:no\n"++ savetext = dirweight+ ++ concat (map node2text nodes) ++ "--\n"+ ++ concat (map edge2text edges)++createGraph store (KeyIn 'a')+ = (store,[GraphPrompt ("save as", "filename")])++createGraph store (Prompt ("save as", nm))+ = (newStore, [SaveFile nm (TXTFile savetext), DrawPicture $ drawBottomLine newGraph])+ where+ Graph {name=nm0,directed=directed,weighted=weighted,nodes=nodes,edges=edges} = graph store+ + dirweight | directed && weighted = "directed:yes\nweighted:yes\n"+ | directed = "directed:yes\nweighted:no\n"+ | weighted = "directed:no\nweighted:yes\n"+ | otherwise = "directed:no\nweighted:no\n"++ savetext = dirweight+ ++ concat (map node2text nodes) ++ "--\n"+ ++ concat (map edge2text edges)+ + newGraph = (graph store) {name=nm}+ newStore = store {graph=newGraph}++createGraph store@(Store {..}) (KeyIn '6') + = (store {userHandlerEnabled = True, userState = userStateInit graph}, [DrawPicture $ userBottomLine graph])++createGraph store _ = (store,[])++newPanel+ = PanelCreate + ("New Graph", 160, 45+ ,[]+ ,[ (60, "directed", CheckButton, -65, 20, 10, 10)+ , (70, "weighted", CheckButton, 5 , 20, 10, 10)+ , (1 , "OK" , Button , 0 , 0 , 60, 20)+ ]+ )+ +newPanelVisible = PanelUpdate True []+newPanelInvisible = PanelUpdate False []+ +onNode :: [Node] -> Point -> Maybe Node+onNode [] p = Nothing+onNode (n@(_,_,q):ns) p | distance p q <= nodeRadius = Just n+ | otherwise = onNode ns p++doGraph h i l b = installEventHandler "createGraph" createGraph (startStore h i l b) startPic 10+ where+ startPic = Pictures+ [ drawGraph startGraph+ , drawBottomLine startGraph+ ]
+ examples/Graphics.hs view
@@ -0,0 +1,202 @@+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
+ examples/RBgraphics.hs view
@@ -0,0 +1,148 @@+module RBgraphics where+-- Grafische weergave van rood-zwart bomen. Werkt alleen voor *binaire* bomen.+--+-- Jan Kuper, 5 mei 2008+-- ============================================================================+import FPPrac.Graphics+import Prelude++data RbTreeG = RBnode Color String [RbTreeG]+ deriving Eq++---------------schalingsfactoren----------------------------------------------++letterheight = 2+nodewidth = 30+hfactor = 1++---------------aspecten ve boom berekenen-------------------------------------+++verticalstep (RBnode _ "" _) = 25+verticalstep (RBnode _ _ _ ) = 30++nodespace (RBnode _ "" _) = nodewidth / 4+nodespace (RBnode _ _ _ ) = nodewidth+1+++ycrd m y t | colour t == red && m = y+ | otherwise = y - verticalstep t++leftTree (RBnode _ _ [t0,_]) = t0+rightTree (RBnode _ _ [_,t1]) = t1++subtrees (RBnode _ _ ts) = ts++colour (RBnode c _ _ ) = c++treeheight _ (RBnode _ _ []) = 0+treeheight m (RBnode _ _ ts) | not m = 1 + maximum (map (treeheight m) ts)+ | otherwise = maximum [ if (colour t == red) then+ (treeheight m t) else+ (1 + treeheight m t)+ | t <- ts+ ]++treewidth :: RbTreeG -> Float+treewidth (RBnode c a ts) = sum (map treewidth ts) + nodespace (RBnode c a ts)++xPosleft x t | subtrees t /= [] = x - treewidth (rightTree t) - nodespace t+ | otherwise = x - nodespace t+xPosright x t | subtrees t /= [] = x + treewidth (leftTree t) + nodespace t+ | otherwise = x + nodespace t++++---------------graphics-------------------------------------------------------++drawnode :: Color -> (Float,Float) -> String -> Picture+drawnode c (x,y) a | a /= "" = Pictures+ [ Translate xcentre y $ Color c $ circleSolid rbig+ , Translate xlabel (y-h) $ Scale 0.1 0.1 $ Color (if (c == black) then white else black) $ Text a+ ]+ | otherwise = Translate xcentre y $ Color c $ circleSolid rsmall+ where+ xcentre = hfactor * x+ xlabel = hfactor * (x - 3 * (fromIntegral $ length a))+ rbig = hfactor*nodewidth/2+ rsmall = hfactor*nodewidth/5+ h = letterheight/1.5++++drawrootedge (x,y) = Color black $ Line [(hfactor*x,y), (hfactor*x,y+hfactor*nodewidth)]+++drawedge :: (Float,Float) -> (Float,Float) -> Picture+drawedge (x,y) (x1,y1) = Color red $ Line [(hfactor*x,y), (hfactor*x1,y1)]+++drawbridge :: (Float,Float) -> (Float,Float) -> Picture+drawbridge (x,y) (x1,y1) = Color red $ Line (map (\(x,y)->(hfactor*x,y)) [(x,y), (x+d, yh), (x1-d,yh), (x1,y1)])+ where+ d = (x1-x)/3+ yh = y+hfactor*nodewidth/1.5+++drawTree :: Bool -> ((Float,Float) , RbTreeG) -> Picture+drawTree m ((x,y), (RBnode c a [ ] )) = drawnode c (x,y) a+drawTree m ((x,y), (RBnode c a [tl,tr]))++ = Pictures $ + [ drawGenEdgeL (x,y) (xleft , yleft )+ , drawGenEdgeR (x,y) (xright, yright)++ , drawTree m ((xleft ,yleft ) , tl)+ , drawTree m ((xright,yright) , tr)++ , drawnode c (x,y) a+ ]+ where+ xleft = xPosleft x tl+ xright = xPosright x tr++ yleft = ycrd m y tl+ yright = ycrd m y tr++ drawGenEdgeL | m &&+ colour tl == red &&+ subtrees tl /= [] &&+ colour (rightTree tl) == red = drawbridge+ | otherwise = drawedge++ drawGenEdgeR | m+ && colour tr == red+ && subtrees tr /= []+ && colour (leftTree tr) == red = drawbridge+ | otherwise = drawedge++++drawTrees :: Bool -> Float -> [RbTreeG] -> Picture+drawTrees m y0 [] = Blank+drawTrees m y0 (t:ts) = Pictures+ [ drawrootedge (x0,y0)+ , drawTree m ((x0,y0), t)+ , drawTrees m (y0 - (treeheight m t + 1) * verticalstep t) ts+ ]+ where+ x0 = xcoordMainRoot t++++drawTreesTxts :: Bool -> Float -> [String] -> [RbTreeG] -> Picture+drawTreesTxts m y0 [] [] = Blank+drawTreesTxts m y0 (str:strs) (t:ts) = Pictures+ [ drawrootedge (x0,y0)+ , drawTree m ((x0,y0), t)+ , Translate (-150) y0 $ Scale 0.1 0.1 $ Color black $ Text str+ , drawTreesTxts m (y0 - (treeheight m t + 1) * verticalstep t) strs ts+ ]+ where+ x0 = xcoordMainRoot t+++++xcoordMainRoot (RBnode c a [tl,tr]) = (treewidth tl - treewidth tr)/2+xcoordMainRoot t = 0
+ examples/RBrun.hs view
@@ -0,0 +1,67 @@+module RBrun where+-- Grafische weergave van rood-zwart bomen. Werkt alleen voor *binaire* bomen.+--+-- Jan Kuper, 5 mei 2008+-- ============================================================================++import FPPrac.Events+import FPPrac.Graphics+import RBgraphics+import Prelude++-- ============= types ========================================================+-- RBnode c v ts: c=colour, v=value, ts=subtrees++data StateTp = StateTp { mode :: Bool+ , rbts :: [RbTreeG]+ }++initstate = StateTp { mode = False+ , rbts = [ exampleTree, exampleTree, exampleTree ]+ }++main = installEventHandler "RBrun" doE initstate (drawTrees m 200 ts) 25+ where+ StateTp { mode = m, rbts = ts} = initstate++---- ============= event handler ================================================++doE :: StateTp -> Input -> (StateTp, [Output])+doE s (KeyIn 'm') = (s {mode = not (mode s)}, [ScreenClear , DrawPicture (drawTrees (not (mode s)) 200 (rbts s))])+doE s e = (s, [])++-- ======voorbeeldboom=========================================================+-- Let op: deze boom is slechts ter illustratie van de grafische weergave,+-- hij voldoet *niet* aan de rood-zwart eis++exampleTree = RBnode black "9"+ [ RBnode red "99"+ [ RBnode red "99"+ [ RBnode black "9" []+ , RBnode black "99" []+ ]+ , RBnode red "ii"+ [ RBnode black "99" []+ , RBnode black "9" []+ ]+ ]+ , RBnode red "k"+ [ RBnode black "ll" [],+ RBnode black "m"+ [ RBnode red "nn"+ [ RBnode red "q" [ RBnode black "nn" []+ , RBnode black "q" []+ ]+ , RBnode red "r" []+ ]+ , RBnode red "pp"+ [ RBnode black "r" [ RBnode red "nn" []+ , RBnode (dark $ dark white) "" []+ ]+ , RBnode black "r" [ RBnode red "nn" []+ , RBnode (dark white) "" []+ ]+ ]+ ]+ ]+ ]
+ examples/RoseTree.hs view
@@ -0,0 +1,130 @@+module RoseTree where+-- Grafische weergave van tamelijk algemene bomen (zie typedef).+-- Aanroepen:+-- voor enkele boom t: showTree t+-- voor lijst bomen ts: showTreeList ts+--+-- Jan Kuper, 10 januari 2003++import Prelude+import FPPrac.Graphics++---------------boomtype-----------------------------------------+data RoseTree = RoseNode String [RoseTree]+ deriving (Show, Eq)++---------------schalingsfactoren--------------------------------++verticaleftshift = 50.0+leftshift = 5.0+horizontalfactor = 19.0+letterheight = 16.0++---------------breedte ve boom berekenen------------------------+-- in principe: breedte = het aantal characters (fixed font)+-- opletten: string aan interne knoop kan meer ruimte nodig hebben+-- dan alle subbomen op dat punt samen.+-- opletten: ook bij de lege string een positieve treewidth (1) opleveren++treewidth :: RoseTree -> Float+treewidth (RoseNode a ts) = maximum [1.0, fromIntegral $ length a, sum (map treewidth ts)]++---------------coordinaten van de wortels ve (sub)boom----------+-- hor_pos berekent de horizontale positie van de wortel van de+-- i-de boom uit een lijst ts van bomen - BINNEN die lijst van bomen.+-- Die positie is de totale breedte van alle bomen links van+-- boom i, plus de halve breedte van boom i zelf (in gehele getallen).+-- hor_poss berekent de horizontale posities van alle bomen in een+-- lijst ts - uitgaande van het midden van de lijst ts.++hor_pos :: [RoseTree] -> Int -> Float+hor_pos ts i = (sum . map treewidth . take i) ts + treewidth (ts!!i) / 2.0++hor_poss :: Float -> [RoseTree] -> [Float]+hor_poss midden ts -- (x,y): midden+ = ( map (+links) . map (hor_pos ts) ) [0..(length ts)-1]+ where+ links = midden - sum (map treewidth ts) / 2.0++---------------deelgraphics-------------------------------------+-- textgraphical, linegraphical produceren graphics-waarden voor+-- een string, resp edge ve boom.+-- Zetten bovendien de horizontale positie om in een+-- x-coordinaat in het grafische vlak (bij Amanda 1.29+-- loopt dat vlak van x=-1 tot x=+1, en van y=-1 tot y=+1).++textgraphical :: (Float,Float) -> String -> Picture+textgraphical (x,y) a = Translate xlabel (y - 12.0) $ Scale 0.1 0.1 $ Color black $ Text a+ where+ xlabel = horizontalfactor * (x - (fromIntegral $ length a) / leftshift)++linegraphical :: (Float,Float) -> (Float,Float) -> Picture+linegraphical (x,y) (x1,y1) = Color red $ Line [(horizontalfactor*x,y), (horizontalfactor*x1,y1)]++---------------graphics ve boom, resp lijst v bomen-------------+-- drawTree, drawTreeList zetten een boom (bomen) om in grafische waarden,+-- uitgaande van de coordinaten (x,y) van de wortel van de boom.+-- Daarbij maakt drawTree recursief gebruik van drawTreeList, met een+-- kleinere y-coordinaat (rekening houdend met een eventuele+-- lege string aan een knoop).+-- Op zijn beurt maakt drawTreeList gebruik van drawTree voor elke boom+-- uit een lijst van bomen apart.++drawTree :: ((Float,Float) , RoseTree) -> Picture+drawTree ((x,y), (RoseNode a ts))+ = Pictures ((textgraphical (x,y) a+ : map (linegraphical (x,yc)) (zip (hor_poss x ts) [y-verticaleftshift|i<-[1..]]))+ ++ [drawTreeList ((x,y-verticaleftshift), ts)])+ where+ yc | a == "" = y+ | otherwise = y-letterheight++drawTreeList :: ((Float,Float) , [RoseTree]) -> Picture+drawTreeList ((x,y), ts)+ = (Pictures . map drawTree) (zip xy_coords ts)+ where+ xy_coords = zip (hor_poss x ts) [y|i<-[1.0 ..]]++-- =============output===========================================+-- Let op: keuzes voor GraphResize, GraphFont, en bovenstaande+-- schalingsfactoren zijn op elkaar afgestemd. Verandering daarvan+-- kan de netheid van de output beinvloeden.++startpuntMainRoot = (0, 200) -- midden bovenaan het scherm++showTreeList :: [RoseTree] -> IO ()+showTreeList ts = graphicsout $ drawTreeList (startpuntMainRoot, ts)++showTree :: RoseTree -> IO ()+showTree t = showTreeList [t]+++-- ======voorbeeldboom===========================================++exampleTree = RoseNode "z"+ [ RoseNode "aaa"+ [ RoseNode "bbb"+ [ RoseNode "ccc" [],+ RoseNode "ddd" []+ ],+ RoseNode ""+ [RoseNode "fff" [],+ RoseNode "ggg" [],+ RoseNode "hhh" []+ ],+ RoseNode "iii"+ [RoseNode "" []+ ]+ ],+ RoseNode "kkk"+ [RoseNode "lll" [],+ RoseNode "mmm"+ [RoseNode "nnn"+ [RoseNode "q" [],+ RoseNode "r" []+ ],+ RoseNode "ooo" [],+ RoseNode "ppp" []+ ]+ ]+ ]
+ examples/prac6.hs view
@@ -0,0 +1,46 @@+module Prac6 where++import Prelude+import FPPrac.Graphics+import FPPrac.Events+import Graphics++import System.FilePath (splitPath, dropExtension)++import CreateGraph+import Debug.Trace++data MyStore = MyStore+ { myGraph :: Graph+ }++initPrac6 graph = MyStore {myGraph = graph}++main = doGraph doPrac6 initPrac6 myGraph drawMypracBottomLine++doPrac6 :: MyStore -> Input -> (MyStore,[Output])+-- =======================================+-- = Voeg hier extra doPrac6 clauses toe =+-- =======================================+-- doPrac6 myStore (KeyIn 'r') = (myStore', o)+-- where+-- myStore' = ...+-- o = ...+--++doPrac6 myStore i = (myStore,[])++drawMypracBottomLine :: Graph -> Picture+drawMypracBottomLine 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)]+ , Translate (-392) height2 $ Color black $ Scale 0.11 0.11 $ Text "myprac:"+ , Translate (-332) height2 $ Color red $ Scale 0.11 0.11 $ Text $ (case (name graph) of "" -> "" ; xs -> dropExtension $ last $ splitPath xs)+ -- Vervang onderstaande tekst, indien nodig, door extra informatie+ , Translate (-235) height2 $ Color black $ Scale 0.11 0.11 $ Text "Press 'q' to return to node-drawing"+ ]+ where+ height1 = -300 + bottomLineHeight+ height2 = -300 + bottomTextHeight
+ src/FPPrac.hs view
@@ -0,0 +1,8 @@+module FPPrac + ( module FPPrac.Prelude+ )+where++import FPPrac.Prelude++default (Number)
+ src/FPPrac/Events.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | The event mode lets you manage your own input.+-- Pressing ESC will still closes the window, but you don't get automatic+-- pan and zoom controls like with 'graphicsout'. Should only be called once+-- during the execution of a program!+module FPPrac.Events+ ( FileType (..)+ , Input (..)+ , Output (..)+ , PanelItemType (..)+ , PromptInfo+ , PanelContent+ , PanelItem+ , installEventHandler+ )+where++import Data.List (mapAccumL)+import FPPrac.Graphics+import FPPrac.GUI.Panel+import FPPrac.GUI.Prompt+import Graphics.Gloss.Interface.Pure.Game hiding (play)+import Graphics.Gloss.Interface.IO.Game (playIO)+import Data.Time (getCurrentTime,utctDayTime)+import Control.Exception as X++type PromptInfo = (String,String)++-- | Possible filetypes+data FileType+ -- | Text file+ = TXTFile String+ -- | Bitmap file+ | BMPFile Picture+ deriving (Eq,Show)++-- | Possible input events+data Input -- | No input+ --+ -- Generated every refresh of the eventhandler+ = NoInput+ -- | Keyboard key x is pressed down; ' ' for space, \\t for tab, \\n for enter+ | KeyIn Char+ -- | Left mouse button is pressed at location (x,y)+ | MouseDown (Float,Float)+ -- | Left mouse button is released at location (x,y)+ | MouseUp (Float,Float)+ -- | Mouse pointer is moved to location (x,y)+ | MouseMotion (Float,Float)+ -- | Mouse is double-clicked at location (x,y)+ | MouseDoubleClick (Float,Float)+ -- | Prompt (windowname,textbox content)+ --+ -- Content returned from textbox in promptwindow with 'windowname'+ | Prompt PromptInfo+ -- | Panel buttonId [(controlId, value)]+ --+ -- Event indicating that in the panel, the button with buttonId is+ -- pressed and that at the time the controls had the given value+ --+ -- Note: the list is ordered by controlId+ --+ -- - For checkboxes a value \"Y\" indicates that they are checked and+ -- a value of \"N\" indicates they are unchecked+ --+ -- - Buttons have no controlstate+ | Panel Int [(Int,String)]+ -- | File name content+ --+ -- The found file with given name, and found content+ | File FilePath FileType+ -- | Indicates if saving of file at filepath succeeded+ | Save FilePath Bool+ -- | Response to GetTime+ --+ -- The time from midnight, 0 <= t < 86401s (because of leap-seconds)+ -- It has a precision of 10^-12 s. Leap second is only added if day+ -- has leap seconds+ | Time Float+ -- | Invalid / Unknown input+ | Invalid+ deriving (Eq,Show)++data Output -- | Command to change the drawing mode+ --+ -- Pictures returned from the eventhandler will normally be drawn+ -- on the screen and in a buffer, so that the window can be quickly+ -- redrawn.+ --+ -- A DrawOnBuffer command can change this default behavior, If the+ -- parameter is False, pictures are only drawn on the screen. If the+ -- parameter is True, drawing will be down on both the buffer and the+ -- screen. This can be useful in response to MouseMotion Events.+ --+ -- Example of rubber banding in line drawing program:+ --+ -- @+ -- handler (p1:ps) (MouseDown p2)+ -- = (p1:ps, [DrawOnBuffer False, DrawPicture (Color black $ Line [p1,p2])])+ -- handler (p1:ps) (MouseMotion p2)+ -- = (p1:ps, [DrawOnBuffer False, DrawPicture (Color black $ Line [p1,p2])])+ -- handler (p1:ps) (MouseUp p2)+ -- = (p2:p1:ps, [DrawOnBuffer True, DrawPicture (Color black $ Line [p1,p2])])+ -- @+ = DrawOnBuffer Bool+ -- | Draw the picture+ | DrawPicture Picture+ -- | GraphPrompt (windowName,info)+ --+ -- Create a graphical prompt window which asks the user to enter+ -- a string in a textbox. The user can be informed about valid+ -- entries through the 'info' field.+ --+ -- Note: the entered string is recorded as the following input event:+ -- 'Prompt (windowName,enteredText)'+ | GraphPrompt PromptInfo+ -- | Command to create a panel with the given panel content, must be+ -- actived with the 'PanelUpdate' command+ | PanelCreate PanelContent+ -- | PanelUpdate visible [(identifier, value)]+ --+ -- Command to change visibility and the content of a panel.+ --+ -- Note: not all controls need to be listed, the order can be+ -- arbitrary+ --+ -- - For checkboxes, a value \"Y\" checks them, a value \"N\" unchecks them+ --+ -- - Buttons can not be altered+ | PanelUpdate Bool [(Int,String)]+ -- | Clear the screen and buffer+ | ScreenClear+ -- | ReadFile fileName default+ --+ -- Read the file of the given filetype at the filename, if it fails+ -- The default content is returned+ --+ -- Note: the read file command generates following input event:+ -- 'File fileName content'+ | ReadFile FilePath FileType+ -- | SaveFile fileName content+ --+ -- Save the file of the given filetype at the filename location+ --+ -- Note: the save file command generates following input event:+ -- Save fileName success (True/False)+ | SaveFile FilePath FileType+ -- | Request the current time of day in seconds+ --+ -- Note: the gettime command generates the following input event:+ -- 'Time timeOfDay'+ | GetTime+ deriving (Eq,Show)++data GUIMode = PanelMode | PromptMode PromptInfo String | FreeMode | PerformIO+ deriving (Eq,Show)++data EventState a = EventState { screen :: Picture+ , buffer :: Picture+ , drawOnBuffer :: Bool+ , storedInputs :: [Input]+ , storedOutputs :: [Output]+ , doubleClickT :: Int+ , guiMode :: GUIMode+ , panel :: Maybe (PanelContent,[(Int,String)])+ , userState :: a+ }++eventToInput ::+ Event+ -> Input+eventToInput (EventKey (Char x) Down _ _) = KeyIn x+eventToInput (EventKey (SpecialKey KeySpace) Down _ _) = KeyIn ' '+eventToInput (EventKey (SpecialKey KeyTab) Down _ _) = KeyIn '\t'+eventToInput (EventKey (SpecialKey KeyEnter) Down _ _) = KeyIn '\n'+eventToInput (EventKey (SpecialKey KeyBackspace) Down _ _) = KeyIn '\b'+eventToInput (EventKey (MouseButton LeftButton) Down _ p) = MouseDown p+eventToInput (EventKey (MouseButton LeftButton) Up _ p) = MouseUp p+eventToInput (EventMotion p) = MouseMotion p+eventToInput _ = Invalid++-- | The event mode lets you manage your own input.+-- Pressing ESC will still abort the program, but you don't get automatic+-- pan and zoom controls like with graphicsout. Should only be called once+-- during the execution of a program!+installEventHandler ::+ forall userState+ . String -- ^ Name of the window+ -> (userState -> Input -> (userState, [Output])) -- ^ Event handler that takes current state, input, and returns new state and maybe an updated picture+ -> userState -- ^ Initial state of the program+ -> Picture -- ^ Initial Picture+ -> Int -- ^ doubleclick speed+ -> IO ()+installEventHandler name handler initState p dcTime = playIO+ (InWindow name (800,600) (20,20))+ white+ 50+ (EventState p p True [] [] 0 FreeMode Nothing initState)+ (return . screen)+ (\e s -> handleInputIO handler dcTime s (eventToInput e))+ (\_ s -> handleInputIO handler dcTime s NoInput)++handleInputIO ::+ forall userState+ . (userState -> Input -> (userState, [Output]))+ -> Int+ -> EventState userState+ -> Input+ -> IO (EventState userState)+handleInputIO handler dcTime s@(EventState {guiMode = PerformIO,..}) i = do+ inps <- fmap (filter (/= Invalid)) $ mapM handleIO storedOutputs+ let s' = s {guiMode = FreeMode, storedOutputs = [], storedInputs = storedInputs ++ inps}+ return $ handleInput handler dcTime s' i++handleInputIO handler dcTime s i = return $ handleInput handler dcTime s i++handleInput ::+ forall userState+ . (userState -> Input -> (userState, [Output]))+ -> Int+ -> EventState userState+ -> Input+ -> EventState userState+handleInput handler dcTime s@(EventState {guiMode = FreeMode, ..}) i+ = s' {userState = userState', doubleClickT = doubleClickT', storedInputs = []}+ where+ (doubleClickT',dc) = registerDoubleClick dcTime doubleClickT i+ remainingInputs = storedInputs ++ (if null dc then [i] else dc)+ (userState',outps) = mapAccumL handler userState remainingInputs+ s' = foldl handleOutput s $ concat outps++handleInput handler _ s@(EventState {guiMode = PanelMode, panel = Just (panelContents,itemState), ..}) (MouseDown (x,y))+ | isClicked /= Nothing = s''+ | otherwise = s+ where+ isClicked = onItem panelContents (x,y)+ (Just itemClicked) = isClicked+ itemState' = toggleItem itemState itemClicked+ (userState',outps) = handler userState (Panel (fst itemClicked) $ filter ((/= "") . snd) itemState')+ s' = s {screen = Pictures [buffer,drawPanel panelContents itemState'], panel = Just (panelContents,itemState'), userState = userState'}+ s'' = foldl handleOutput s' outps+++handleInput _ _ s@(EventState {guiMode = PromptMode pInfo pContent, ..}) (KeyIn '\b')+ | pContent /= [] = s'+ | otherwise = s+ where+ pContent' = init pContent+ screen' = Pictures [buffer,drawPrompt pInfo pContent']+ s' = s {guiMode = PromptMode pInfo pContent', screen = screen'}++handleInput handler _ s@(EventState {guiMode = PromptMode (pName,_) pContent, ..}) (KeyIn '\n')+ = s''+ where+ (userState',outps) = handler userState (Prompt (pName,pContent))+ s' = s {guiMode = FreeMode, screen = buffer, userState = userState'}+ s'' = foldl handleOutput s' outps++handleInput _ _ s@(EventState {guiMode = PromptMode pInfo pContent, ..}) (KeyIn x)+ = s'+ where+ pContent' = pContent ++ [x]+ screen' = Pictures [buffer,drawPrompt pInfo pContent']+ s' = s {guiMode = PromptMode pInfo pContent', screen = screen'}++handleInput _ _ s _ = s++registerDoubleClick ::+ Int+ -> Int+ -> Input+ -> (Int,[Input])+registerDoubleClick d 0 (MouseDown _) = (d ,[])+registerDoubleClick _ _ (MouseDown (x,y)) = (0 ,[MouseDoubleClick (x,y)])+registerDoubleClick _ 0 NoInput = (0 ,[])+registerDoubleClick _ n NoInput = (n-1,[])+registerDoubleClick _ n _ = (n ,[])++handleOutput ::+ EventState a+ -> Output+ -> EventState a+handleOutput s (DrawOnBuffer b) = s {drawOnBuffer = b}+handleOutput s ScreenClear = s {buffer = Blank, screen = Blank}+handleOutput s@(EventState {..}) (DrawPicture p) =+ s { buffer = if drawOnBuffer+ then Pictures [buffer, p]+ else buffer+ , screen = Pictures [buffer, p]+ }++handleOutput s@(EventState {guiMode = FreeMode, ..}) i@(ReadFile _ _) =+ s {guiMode = PerformIO, storedOutputs = storedOutputs ++ [i]}++handleOutput s@(EventState {guiMode = FreeMode, ..}) i@(SaveFile _ _) =+ s {guiMode = PerformIO, storedOutputs = storedOutputs ++ [i]}++handleOutput s@(EventState {guiMode = FreeMode, ..}) i@(GetTime) =+ s {guiMode = PerformIO, storedOutputs = storedOutputs ++ [i]}++handleOutput s@(EventState {..}) (PanelCreate panelContent)+ = s {panel = Just (panelContent,defItemState)}+ where+ defItemState = createDefState panelContent++handleOutput s@(EventState {panel = Just (panelContents,itemState), ..}) (PanelUpdate True _)+ = s {guiMode = PanelMode, screen = Pictures [buffer,drawPanel panelContents itemState]}++handleOutput s@(EventState {panel = Nothing}) (PanelUpdate True _)+ = s++handleOutput s@(EventState {panel = Just (panelContents,_), ..}) (PanelUpdate False _)+ = s {guiMode = FreeMode, screen = buffer, panel = Just (panelContents,defItemState)}+ where+ defItemState = createDefState panelContents++handleOutput s@(EventState {panel = Nothing, ..}) (PanelUpdate False _)+ = s {guiMode = FreeMode, screen = buffer}++handleOutput s@(EventState {..}) (GraphPrompt promptInfo)+ = s {guiMode = PromptMode promptInfo "", screen = Pictures [buffer,drawPrompt promptInfo ""]}++handleOutput s _ = s++handleIO :: Output -> IO Input+handleIO (ReadFile filePath (TXTFile defContents)) =+ (do f <- readFile filePath+ return $ File filePath $ TXTFile f+ ) `X.catch`+ (\(_ :: IOException) -> return (File filePath $ TXTFile defContents))++handleIO (ReadFile filePath (BMPFile defContents)) =+ (do f <- loadBMP filePath+ return $ File filePath $ BMPFile f+ ) `X.catch`+ (\(_ :: IOException) -> return (File filePath $ BMPFile defContents))++handleIO (SaveFile filePath (TXTFile content)) =+ ( do writeFile filePath content+ return $ Save filePath True+ ) `X.catch`+ (\(_ :: IOException) -> return $ Save filePath False)++handleIO (SaveFile filePath (BMPFile _)) = return $ Save filePath False++handleIO GetTime = do+ t <- fmap utctDayTime $ getCurrentTime+ return $ Time (fromRational $ toRational t)++handleIO _ = return Invalid
+ src/FPPrac/GUI/Panel.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE PatternGuards #-}+module FPPrac.GUI.Panel+ ( PanelItemType(..)+ , PanelContent+ , PanelItem+ , drawPanel+ , onItem+ , toggleItem+ , createDefState+ )+where++import Graphics.Gloss+import Graphics.Gloss.Data.Point++titleshift :: Float+titleshift = 4++titlebarheight :: Float+titlebarheight = 16++titlebarShift :: Float+titlebarShift = 8++lblVshift :: Float+lblVshift = -6++data PanelItemType = CheckButton | Button+ deriving (Eq,Show)++-- | (Id, Title, Type, x-coord, y-coord, width, height)+type PanelItem = (Int,String,PanelItemType,Float,Float,Float,Float)++-- | (Title, width, height, menuItems, commandItems)+--+-- Note:+-- - panels are drawn in the center of the screen+--+-- - menu items are currently not supported+type PanelContent = (String+ ,Float, Float+ ,[(String,[(String,Int)])]+ ,[PanelItem]+ )++createDefState ::+ PanelContent+ -> [(Int,String)]+createDefState (_, _, _, _, items) = map createDefStateItem items++createDefStateItem ::+ PanelItem+ -> (Int,String)+createDefStateItem (i,_,CheckButton,_,_,_,_) = (i,"N")+createDefStateItem (i,_,_ ,_,_,_,_) = (i,"" )++drawPanel ::+ PanelContent+ -> [(Int,String)]+ -> Picture+drawPanel (title, w, h, _, items) itemStates+ = Pictures $+ [ Translate 0 titlebarShift $ Color white $ rectangleSolid w (h + titlebarheight)+ , Translate 0 titlebarShift $ Color black $ rectangleWire w (h + titlebarheight)+ , drawTitleBar w h title+ ] ++ zipWith (drawItem w h) items itemStates++drawTitleBar ::+ Float+ -> Float+ -> String+ -> Picture+drawTitleBar w h title+ = Pictures+ [ Color black $ Line [(negate w/2, h/2), (w/2,h/2)]+ , Translate ((negate w/2)+5) (h/2 + titleshift) $ Color black $ Scale 0.1 0.1 $ Text title+ ]++drawItem ::+ Float+ -> Float+ -> PanelItem+ -> (Int, String)+ -> Picture+drawItem bboxW bboxH (_, name, CheckButton, x, y, w, h) (_,itemState)+ | x < (bboxW / 2)+ , x > (negate bboxW / 2 )+ , (y - titlebarheight) < (bboxH / 2)+ , (y - titlebarheight) > (negate bboxH / 2)+ , (x + w) < (bboxW / 2)+ , ((y - titlebarheight) + h) < (bboxH / 2)+ = Pictures $+ [ Translate x (y - titlebarShift) $ Color black $ rectangleWire w h+ , Translate (x+w) (y - titlebarShift + lblVshift) $ Color black $ Scale 0.1 0.1 $ Text name+ ] ++ if (itemState == "Y") then+ [Translate 0 (-titlebarShift) $ Color black $ Line [(x-w/2,y-h/2),(x+w/2,y+h/2)]+ ,Translate 0 (-titlebarShift) $ Color black $ Line [(x-w/2,y+h/2),(x+w/2,y-h/2)]+ ]+ else []++ | otherwise+ = Blank++drawItem bboxW bboxH (_, name, Button, x, y, w, h) _+ | x < (bboxW / 2)+ , x > (negate bboxW / 2 )+ , (y - titlebarheight) < (bboxH / 2)+ , (y - titlebarheight) > (negate bboxH / 2)+ , (x + w) < (bboxW / 2)+ , ((y - titlebarheight) + h) < (bboxH / 2)+ = Pictures+ [ Translate x (y - titlebarShift) $ Color black $ rectangleWire w h+ , Translate xlabel (y - titlebarShift + lblVshift) $ Color black $ Scale 0.1 0.1 $ Text name+ ]++ | otherwise+ = Blank+ where+ xlabel = x - 3.5 * (fromIntegral $ length name)++-- drawItem _ _ _ _ = Blank++onItem ::+ PanelContent+ -> (Float,Float)+ -> Maybe (Int,PanelItemType)+onItem (_, _, _, _, items) (x,y) = onItem' items (x,y)++onItem' ::+ [PanelItem]+ -> (Float,Float)+ -> Maybe (Int,PanelItemType)+onItem' [] _ = Nothing+onItem' ((itemId, _, itemType, x, y, w, h):is) p+ | pointInBox p (x+w/2,y-h/2-titlebarShift) (x-w/2,y+h/2-titlebarShift)+ = Just (itemId,itemType)++ | otherwise = onItem' is p++toggleItem ::+ [(Int,String)]+ -> (Int,PanelItemType)+ -> [(Int,String)]+toggleItem [] _ = []+toggleItem ((i,val):is) (t,ttype) | i == t = (i, toggleVal ttype val):is+ | otherwise = (i,val):(toggleItem is (t,ttype))++toggleVal ::+ PanelItemType+ -> String+ -> String+toggleVal CheckButton "N" = "Y"+toggleVal CheckButton "Y" = "N"+toggleVal _ n = n
+ src/FPPrac/GUI/Prompt.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE PatternGuards #-}+module FPPrac.GUI.Prompt+ ( drawPrompt+ )+where++import Graphics.Gloss++titleshift :: Float+titleshift = 4++titlebarheight :: Float+titlebarheight = 16++titlebarShift :: Float+titlebarShift = 8++lblVshift :: Float+lblVshift = -6++drawPrompt ::+ (String,String)+ -> String+ -> Picture+drawPrompt (title, info) promptContents+ = Pictures $+ [ Translate 0 titlebarShift $ Color white $ rectangleSolid 200 (50 + titlebarheight)+ , Translate 0 titlebarShift $ Color black $ rectangleWire 200 (50 + titlebarheight)+ , drawTitleBar 200 50 title+ , drawPromptText info promptContents+ ]++drawTitleBar ::+ Float+ -> Float+ -> String+ -> Picture+drawTitleBar w h title+ = Pictures+ [ Color black $ Line [(negate w/2, h/2), (w/2,h/2)]+ , Translate ((negate w/2)+5) (h/2 + titleshift) $ Color black $ Scale 0.1 0.1 $ Text title+ ]++drawPromptText ::+ String+ -> String+ -> Picture+drawPromptText info promptContents+ = Pictures+ [ Translate (-90) ((20) - titlebarShift + lblVshift) $ Color black $ Scale 0.1 0.1 $ Text info+ , Translate (-30) ((0) - titlebarShift) $ Color black $ rectangleWire 120 20+ , Translate (-85) ((0) - titlebarShift + lblVshift) $ Color black $ Scale 0.1 0.1 $ Text promptContents+ ]
+ src/FPPrac/Graphics.hs view
@@ -0,0 +1,25 @@+-- | Open a new window and display the given picture. Should only be called+-- once during the execution of a program!+module FPPrac.Graphics+ ( module Graphics.Gloss+ , graphicsout+ )+where++import Graphics.Gloss hiding (display,animate,simulate,play)+import qualified Graphics.Gloss as Gloss++-- | Open a new window and display the given picture. Should only be called+-- once during the execution of a program!+--+-- Use the following commands once the window is open:+--+-- * Close Window - esc-key.+--+-- * Move Viewport - left-click drag, arrow keys.+--+-- * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys.+--+-- * Zoom Viewport - mouse wheel, or page up\/down-keys.+graphicsout :: Picture -> IO ()+graphicsout = Gloss.display (InWindow "graphicsout" (640,480) (20,20)) white
+ src/FPPrac/Prelude.hs view
@@ -0,0 +1,92 @@+-- | The 'FPPrac.Prelude' defines the 'Number' type (which is like Amanda's+-- 'num' type), and hides the intricacies of Haskell's Type Classes+-- from new users when dealing with number. Also defines corresponding+-- 'Prelude' functions that use this new 'Number' type.+module FPPrac.Prelude+ ( module Prelude+ , Number+ , ord+ , chr+ , length+ , (!!)+ , replicate+ , take+ , drop+ , splitAt+ )+where++import Prelude hiding (length,(!!),replicate,take,drop,splitAt)+import qualified Prelude as P+import Data.Char (ord,chr)++import FPPrac.Prelude.Number++default (Number)+infixl 9 !!++-- | /O(n)/. 'length' returns the length of a finite list as a 'Number'.+length :: [a] -> Number+length = I . toInteger . P.length++-- | List index (subscript) operator, starting from 0.+(!!) :: [a] -> Number -> a+xs !! (I i) = xs P.!! (fromInteger i)+_ !! _ = error "trying to index (!!) using a floating number"++-- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of+-- every element.+--+-- Fails when @n@ is not an integral number+replicate :: Number -> a -> [a]+replicate (I i) a = P.replicate (fromInteger i) a+replicate _ _ = error "replicate undefined for float"++-- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@+-- of length @n@, or @xs@ itself if @n > 'length' xs@:+--+-- > take 5 "Hello World!" == "Hello"+-- > take 3 [1,2,3,4,5] == [1,2,3]+-- > take 3 [1,2] == [1,2]+-- > take 3 [] == []+-- > take (-1) [1,2] == []+-- > take 0 [1,2] == []+--+-- Fails when @n@ is not an integral number+take :: Number -> [a] -> [a]+take (I i) xs = P.take (fromInteger i) xs+take _ _ = error "take undefined for float"++-- | 'drop' @n xs@ returns the suffix of @xs@+-- after the first @n@ elements, or @[]@ if @n > 'length' xs@:+--+-- > drop 6 "Hello World!" == "World!"+-- > drop 3 [1,2,3,4,5] == [4,5]+-- > drop 3 [1,2] == []+-- > drop 3 [] == []+-- > drop (-1) [1,2] == [1,2]+-- > drop 0 [1,2] == [1,2]+--+-- Fails when @n@ is not an integral number+drop :: Number -> [a] -> [a]+drop (I i) xs = P.drop (fromInteger i) xs+drop _ _ = error "drop undefined for float"++-- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of+-- length @n@ and second element is the remainder of the list:+--+-- > splitAt 6 "Hello World!" == ("Hello ","World!")+-- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5])+-- > splitAt 1 [1,2,3] == ([1],[2,3])+-- > splitAt 3 [1,2,3] == ([1,2,3],[])+-- > splitAt 4 [1,2,3] == ([1,2,3],[])+-- > splitAt 0 [1,2,3] == ([],[1,2,3])+-- > splitAt (-1) [1,2,3] == ([],[1,2,3])+--+-- It is equivalent to @('take' n xs, 'drop' n xs)@ when @n@ is not @_|_@+-- (@splitAt _|_ xs = _|_@).+--+-- Fails when @n@ is not an integral number+splitAt :: Number -> [a] -> ([a],[a])+splitAt (I i) xs = P.splitAt (fromInteger i) xs+splitAt _ _ = error "splitAt undefined for float"
+ src/FPPrac/Prelude/Number.hs view
@@ -0,0 +1,137 @@+module FPPrac.Prelude.Number+ ( Number(..)+ )+where++import Text.ParserCombinators.Parsec+import qualified Text.ParserCombinators.Parsec.Token as PT+import Text.ParserCombinators.Parsec.Language (emptyDef)++-- | Combined integral and floating number type+data Number+ = I Integer+ | F Double++instance Eq Number where+ (I i1) == (I i2) = i1 == i2+ (F f1) == (F f2) = f1 == f2+ (I i1) == (F f2) = fromIntegral i1 == f2+ (F f1) == (I i2) = f1 == fromIntegral i2++instance Ord Number where+ compare (I i1) (I i2) = compare i1 i2+ compare (F f1) (F f2) = compare f1 f2+ compare (I i1) (F f2) = compare (fromIntegral i1) f2+ compare (F f1) (I i2) = compare f1 (fromIntegral i2)++instance Show Number where+ show (I i) = show i+ show (F f) = show f++instance Num Number where+ (I i1) + (I i2) = I (i1 + i2)+ (F f1) + (F f2) = F (f1 + f2)+ (I i1) + (F f2) = F ((fromInteger i1) + f2)+ (F f1) + (I i2) = F (f1 + (fromInteger i2))+ (I i1) * (I i2) = I (i1 * i2)+ (F f1) * (F f2) = F (f1 * f2)+ (I i1) * (F f2) = F ((fromInteger i1) * f2)+ (F f1) * (I i2) = F (f1 * (fromInteger i2))+ negate (I i) = I (negate i)+ negate (F f) = F (negate f)+ abs (I i) = I (abs i)+ abs (F f) = F (abs f)+ signum (I i) = I (signum i)+ signum (F f) = F (signum f)+ fromInteger = I++instance Real Number where+ toRational (I i) = toRational i+ toRational (F f) = toRational f++instance Enum Number where+ toEnum = I . toInteger+ fromEnum (I i) = fromEnum i+ fromEnum (F f) = fromEnum f++instance Integral Number where+ quotRem (I i1) (I i2) = let (i1',i2') = quotRem i1 i2 in (I i1', I i2')+ quotRem (F _) _ = error "quotRem: first argument is not an integer"+ quotRem _ (F _) = error "quotRem: second argument is not an integer"+ divMod (I i1) (I i2) = let (i1',i2') = divMod i1 i2 in (I i1', I i2')+ divMod (F _) _ = error "divMod: first argument is not an integer"+ divMod _ (F _) = error "divMod: second argument is not an integer"+ toInteger (I i) = i+ toInteger (F _) = error "Can not use 'toInteger' to convert float to integer"++instance Fractional Number where+ (/) (I i1) (I i2) = F $ (fromInteger i1) / (fromInteger i2)+ (/) (F d1) (F d2) = F $ d1 / d2+ (/) (F d1) (I i2) = F $ d1 / (fromInteger i2)+ (/) (I i1) (F d2) = F $ (fromInteger i1) / d2+ fromRational = F . fromRational++instance RealFrac Number where+ properFraction (F f) = let (b,a) = properFraction f in (b, F a)+ properFraction (I i) = let (b,a) = properFraction (fromIntegral i) in (b, F a)+ truncate (F f) = truncate f+ truncate (I i) = truncate ((fromIntegral i) :: Float)+ round (F f) = round f+ round (I i) = round ((fromIntegral i) :: Float)+ ceiling (F f) = ceiling f+ ceiling (I i) = ceiling ((fromIntegral i) :: Float)+ floor (F f) = floor f+ floor (I i) = floor ((fromIntegral i) :: Float)++instance Floating Number where+ pi = F pi+ exp (F f) = F (exp f)+ exp (I i) = F (exp $ fromIntegral i)+ sqrt (F f) = F (sqrt f)+ sqrt (I i) = F (sqrt $ fromIntegral i)+ log (F f) = F (log f)+ log (I i) = F (log $ fromIntegral i)+ (F f1) ** (F f2) = F (f1 ** f2)+ (I i1) ** (I i2) = F ((fromIntegral i1) ** (fromIntegral i2))+ (F f1) ** (I i2) = F (f1 ** (fromIntegral i2))+ (I i1) ** (F f2) = F ((fromIntegral i1) ** f2)+ logBase (F f1) (F f2) = F (logBase f1 f2)+ logBase (I i1) (I i2) = F (logBase (fromIntegral i1) (fromIntegral i2))+ logBase (F f1) (I i2) = F (logBase f1 (fromIntegral i2))+ logBase (I i1) (F f2) = F (logBase (fromIntegral i1) f2)+ sin (F f) = F (sin f)+ sin (I i) = F (sin $ fromIntegral i)+ tan (F f) = F (tan f)+ tan (I i) = F (tan $ fromIntegral i)+ cos (F f) = F (cos f)+ cos (I i) = F (cos $ fromIntegral i)+ asin (F f) = F (asin f)+ asin (I i) = F (asin $ fromIntegral i)+ atan (F f) = F (atan f)+ atan (I i) = F (atan $ fromIntegral i)+ acos (F f) = F (acos f)+ acos (I i) = F (acos $ fromIntegral i)+ sinh (F f) = F (sinh f)+ sinh (I i) = F (sinh $ fromIntegral i)+ tanh (F f) = F (tanh f)+ tanh (I i) = F (tanh $ fromIntegral i)+ cosh (F f) = F (cosh f)+ cosh (I i) = F (cosh $ fromIntegral i)+ asinh (F f) = F (asinh f)+ asinh (I i) = F (asinh $ fromIntegral i)+ atanh (F f) = F (atanh f)+ atanh (I i) = F (atanh $ fromIntegral i)+ acosh (F f) = F (acosh f)+ acosh (I i) = F (acosh $ fromIntegral i)++lexer :: PT.TokenParser st+lexer = PT.makeTokenParser emptyDef++naturalOrFloat :: CharParser st (Either Integer Double)+naturalOrFloat = PT.naturalOrFloat lexer++instance Read Number where+ readsPrec _ = either (const []) id . parse parseRead' "" where+ parseRead' = do a <- naturalOrFloat+ rest <- getInput+ return [(either I F a, rest)]
+ twentefp.cabal view
@@ -0,0 +1,41 @@+Name: twentefp+Version: 0.4+Synopsis: Lab Assignments Environment at Univeriteit Twente+Description: Lab Assignments Environment at Univeriteit Twente+License: BSD3+License-file: LICENSE+Author: Christiaan Baaij+Maintainer: christiaan.baaij@gmail.com+Category: Education+Build-type: Simple+Cabal-version: >=1.6++Extra-Source-Files: examples/CreateGraph.hs,+ examples/Graphics.hs,+ examples/prac6.hs,+ examples/RBgraphics.hs,+ examples/RBrun.hs,+ examples/RoseTree.hs++Library+ Exposed-modules: FPPrac+ FPPrac.Prelude+ FPPrac.Graphics+ FPPrac.Events++ HS-Source-Dirs: src++ ghc-options: -Wall -fwarn-tabs++ Build-depends: base >= 4 && < 5,+ gloss >= 1.7.5.2,+ time > 1.2,+ parsec > 3++ Other-modules: FPPrac.Prelude.Number+ FPPrac.GUI.Panel+ FPPrac.GUI.Prompt++source-repository head+ type: git+ location: git://github.com/christiaanb/fpprac.git