diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/CreateGraph.hs b/examples/CreateGraph.hs new file mode 100644 --- /dev/null +++ b/examples/CreateGraph.hs @@ -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 + ] diff --git a/examples/Graphics.hs b/examples/Graphics.hs new file mode 100644 --- /dev/null +++ b/examples/Graphics.hs @@ -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 diff --git a/examples/RBgraphics.hs b/examples/RBgraphics.hs new file mode 100644 --- /dev/null +++ b/examples/RBgraphics.hs @@ -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 diff --git a/examples/RBrun.hs b/examples/RBrun.hs new file mode 100644 --- /dev/null +++ b/examples/RBrun.hs @@ -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) "" [] + ] + ] + ] + ] + ] diff --git a/examples/RoseTree.hs b/examples/RoseTree.hs new file mode 100644 --- /dev/null +++ b/examples/RoseTree.hs @@ -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" [] + ] + ] + ] diff --git a/examples/prac6.hs b/examples/prac6.hs new file mode 100644 --- /dev/null +++ b/examples/prac6.hs @@ -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 diff --git a/src/FPPrac.hs b/src/FPPrac.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac.hs @@ -0,0 +1,8 @@ +module FPPrac + ( module FPPrac.Prelude + ) +where + +import FPPrac.Prelude + +default (Number) diff --git a/src/FPPrac/Events.hs b/src/FPPrac/Events.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/Events.hs @@ -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 diff --git a/src/FPPrac/GUI/Panel.hs b/src/FPPrac/GUI/Panel.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/GUI/Panel.hs @@ -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 diff --git a/src/FPPrac/GUI/Prompt.hs b/src/FPPrac/GUI/Prompt.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/GUI/Prompt.hs @@ -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 + ] diff --git a/src/FPPrac/Graphics.hs b/src/FPPrac/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/Graphics.hs @@ -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 diff --git a/src/FPPrac/Prelude.hs b/src/FPPrac/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/Prelude.hs @@ -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" diff --git a/src/FPPrac/Prelude/Number.hs b/src/FPPrac/Prelude/Number.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/Prelude/Number.hs @@ -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)] diff --git a/twentefp.cabal b/twentefp.cabal new file mode 100644 --- /dev/null +++ b/twentefp.cabal @@ -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