Permalink
Browse files

GUI complete (almost, config dialog missing and some more tweakings n…

…eed to be done)
  • Loading branch information...
1 parent 032592f commit 9e05baf5f296af0f62748060ccfb5cf2f12008db Mihai Maruseac committed May 14, 2011
Showing with 113 additions and 57 deletions.
  1. +107 −5 Maze/GUI.hs
  2. +2 −2 Maze/Maze.hs
  3. +3 −49 Maze/Plan.hs
  4. +1 −1 Maze/Types.hs
View
112 Maze/GUI.hs
@@ -1,8 +1,13 @@
module Maze.GUI
where
+import Control.Monad.State
import Control.Monad.Trans (liftIO)
+import Graphics.Rendering.Cairo
import Graphics.UI.Gtk
+import System.Random
+
+import Maze.Maze
{-
Used to construct and update the GUI.
@@ -22,21 +27,23 @@ mazeGUI = do
window `on` deleteEvent $ liftIO mainQuit >> return False
-- 3. Populate and set window's attributes.
pbuff <- pixbufNewFromFile gLOGO
- populateWindow window
set window
- [ windowDefaultWidth := 200
- , windowDefaultHeight := 200
+ [ windowDefaultWidth := 400
+ , windowDefaultHeight := 300
, windowTitle := gTITLE
, windowIcon := Just pbuff
]
+ drawing <- populateWindow window
-- 4. Show everything
widgetShowAll window
- -- 5. Run GUI loop
+ -- 5. Set the drawing callbacks TODO
+ -- 6. Run GUI loop
mainGUI
{-
Constructs all widgets found in the window.
-}
+populateWindow :: Window -> IO DrawingArea
populateWindow w = do
{-
1. Build one vertical box for splitting the screen in two and add it to
@@ -48,6 +55,7 @@ populateWindow w = do
-- 2. Build the toolbar
buildToolbar vBox
-- 3. Build the main area
+ buildMainArea vBox
{-
Builds the application's toolbar.
@@ -88,13 +96,107 @@ addSeparator tb = do
toolbarInsert tb s $ -1
{-
+Builds the application main area.
+-}
+buildMainArea :: VBox -> IO DrawingArea
+buildMainArea b = do
+ -- 1. New HBox
+ box <- hBoxNew False 10
+ boxPackStart b box PackGrow 10
+ -- 2. Build statistics table
+ buildPopulationInfo box
+ -- 3. Build maze area
+ buildMazeArea box
+
+{-
+Builds the population info table
+-}
+buildPopulationInfo b = do
+ -- 1. A nice frame
+ f <- frameNew
+ f `frameSetLabel` "Statistics"
+ boxPackEnd b f PackNatural 10
+ -- 2. Another VBox
+ box <- vBoxNew False 10
+ f `containerAdd` box
+ -- 3. A table
+ t <- tableNew 2 2 True
+ boxPackStart box t PackNatural 10
+ -- 4. Current generation number display
+ l <- labelNew $ Just "Generation:"
+ tableAttachDefaults t l 0 1 0 1
+ gl <- labelNew $ Just "0"
+ tableAttachDefaults t gl 1 2 0 1
+ -- 5. Fitness display
+ l' <- labelNew $ Just "Best fitness:"
+ tableAttachDefaults t l' 0 1 1 2
+ fl <- labelNew $ Just "0"
+ tableAttachDefaults t fl 1 2 1 2
+ -- 6. Population display
+ buildPopulationDisplay box
+
+{-
+Builds the tree view for population display.
+-}
+buildPopulationDisplay b = do
+ -- 1. The model
+ model <- listStoreNew ([] :: [(Int, Int)])-- empty for now
+ -- 2. The view
+ view <- treeViewNewWithModel model
+ treeViewSetHeadersVisible view True
+ boxPackStart b view PackGrow 10
+ -- 3. Columns, accessors, etc
+ buildColumn model view (show.fst) "Chromosome number"
+ buildColumn model view (show.snd) "Fitness"
+
+{-
+Builds one column for the tree view.
+-}
+buildColumn :: ListStore a -> TreeView -> (a -> String) -> String -> IO ()
+buildColumn model view f title = do
+ c <- treeViewColumnNew
+ cr <- cellRendererTextNew
+ treeViewColumnPackStart c cr False
+ cellLayoutSetAttributes c cr model $ \x -> [cellText := f x ]
+ c `treeViewColumnSetTitle` title
+ view `treeViewAppendColumn` c
+ return ()
+
+{-
+Builds the area where the maze will be drawn.
+-}
+buildMazeArea :: HBox -> IO DrawingArea
+buildMazeArea b = do
+ -- 1. Get a frame around the maze
+ f <- aspectFrameNew 0.5 0.5 Nothing
+ f `frameSetLabel` "Maze"
+ boxPackStart b f PackGrow 10
+ -- 2. Return the canvas where the maze will be drawn
+ canvas <- drawingAreaNew
+ f `containerAdd` canvas
+ return canvas
+
+{-
+The actual drawing of the maze.
+-}
+drawMaze :: Render()
+drawMaze = do
+ return ()
+
+{-
Action to do when clicking the New button.
-}
-onNew = undefined
+onNew :: IO ()
+onNew = do
+ -- 1. present config dialog and get options TODO
+ -- 2. get maze
+ let (maze, g) = (runState $ genMaze (5, 5)) (mkStdGen 42)
+ print maze
{-
Action to do when clicking the about button.
-}
+onAbout :: IO ()
onAbout = do
d <- aboutDialogNew
pbuff <- pixbufNewFromFile gLOGO
View
4 Maze/Maze.hs
@@ -1,4 +1,4 @@
-module Maze
+module Maze.Maze
where
import Array
@@ -7,7 +7,7 @@ import Control.Monad.State
import Data.Array.ST
import System.Random
-import Types
+import Maze.Types
{- A cell. The list contains the openings. -}
newtype Cell = C [Cardinal] deriving (Show, Read)
View
52 Maze/Plan.hs
@@ -1,17 +1,13 @@
-module Plan
+module Maze.Plan
where
import Control.Arrow
-import Control.Monad.State
-import System.Random
import qualified Array as A
import qualified Data.Vector as V
-import Maze
-import Types
-
-import Debug.Trace
+import Maze.Maze
+import Maze.Types
{- Type synonim for the fitness. -}
type Fitness = Integer
@@ -51,51 +47,9 @@ move S = first (+ 1)
move W = second (subtract 1)
{-
-{-
-A plan to leave the maze. If the plane ends and the time is not spent, the
-plan is restarted. This allows for simple plans while having complicated
-mazes.
--}
-data Plan
- = Go Cardinal -- go in one direction
- | Seq Plan Plan -- do one plan, then another
- | If Cond Plan Plan -- do one plan or another
- deriving (Show, Read)
-
-{-
-A condition to use in a plan. The only input is the neighborhood.
--}
-data Cond
- = Free Cardinal -- cell in that direction is reachable
- | Blocked Cardinal -- way blocked
- | Or Cond Cond -- one condition or another
- | And Cond Cond -- both conditions
- deriving (Show, Read)
-
-{-
-The state used while patrolling the maze:
- * the original plan (used for plan looping)
- * the actual plan
- * the maze used in evolution
- * start point
- * end point
--}
-type MazeState = (Plan, Plan, Maze, Point, Point)
--}
-
m = fst $ (runState $ genMaze (5, 5)) (mkStdGen 42)
p = V.fromList [E, E, S, E, S, S, S, E, W, S, E, W, S, N]
pos = (1, 1) :: Point
t = 0 :: Time
-
-{-
-getFitness :: Plan -> (Plan, Fitness)
-getFitness p = undefined
-
---executePlan :: Plan -> Maze
-executePlan = undefined
-
-f = do
- state $ \(m, p, e, cp) -> ((cp, 0), (m, p, e, cp))
-}
View
2 Maze/Types.hs
@@ -1,4 +1,4 @@
-module Types
+module Maze.Types
where
{-

0 comments on commit 9e05baf

Please sign in to comment.