GeBoP 1.7.4 → 1.7.4.1
raw patch · 4 files changed
+971/−952 lines, 4 filesdep ~arraydep ~basedep ~directory
Dependency ranges changed: array, base, directory, random, wxcore
Files
- GUI.hs +800/−799
- GeBoP.cabal +12/−7
- Reversi.hs +146/−146
- changelog.txt +13/−0
GUI.hs view
@@ -1,799 +1,800 @@-{-# LANGUAGE ExistentialQuantification #-}-------------- GUI -- ------------module GUI (gui, version) where--import Game -- hiding (name)-import Graphics.UI.WX hiding (bitmap, children, click, next, selections, stop)-import Graphics.UI.WXCore hiding (win)-import Data.Char-import Tools hiding (field)-import Data.List--import Data.Version (versionBranch) -import qualified Paths_GeBoP as Paths -- (version) - - -version :: String-version = a ++ "." ++ b ++ "." ++ c - where - (a : b : c : _) = map show $ versionBranch Paths.version ++ repeat 0 ---gui :: [GeneralGame] -> IO ()-gui games = do-- {--== CREATION PHASE ==--}- - f <- mdiParentFrame []- c <- mdiParentFrameGetClientWindow f- - mGame <- menuPane []- iNew <- menuItem mGame []- () <- menuLine mGame - iQuit <- menuQuit mGame []- - mHelp <- menuHelp []- iHelp <- menuItem mHelp []- iAbout <- menuAbout mHelp []-- field <- statusField []-- logo <- bitmapCreateLoad "images\\gebop.bmp" wxBITMAP_TYPE_ANY-- {--== DEFINITION PHASE ==--}- - let onpaint :: DC () -> Rect -> IO ()- onpaint dc r = do- tileBitmap dc r logo-- {--== MODIFICATION PHASE ==--}- - set mGame [ text := "&Game" ]- set iNew [ text := "&New Game\tCtrl+N", help := "Start a new game" , on command := newgame f games] - set iQuit [ help := "Quit the application" , on command := close f] - set iHelp [ text := "&Contents" , help := "Show the contents of GeBoP" , on command := html f "help\\index.html"]- set iAbout [ help := "Information about this program", on command := infoDialog f "About GeBoP" about]-- set f [ visible := True- , clientSize := sz 640 480- , picture := "gebop.ico"- , text := "GeBoP"- , menuBar := [mGame, mHelp] - , statusBar := [field]- ]- - set c [ on paint := onpaint- , on resize ::= repaint- ]- - return ()--newgame :: MDIParentFrame () -> [GeneralGame] -> IO ()-newgame mdiparent games = do - mi <- askGame- case mi of - Nothing -> return ()- Just i -> do- let gc = games !! i- pr = (\(Game g) -> standard g) gc- ra = (\(Game g) -> possible g) gc- msettings <- askSettings pr ra- case msettings of - Nothing -> return ()- Just settings -> do- (\(Game g) -> game mdiparent g settings (newgame mdiparent games)) $ gc- return ()- - where- - askGame :: IO (Maybe Int)- askGame = do- d <- dialog mdiparent [text := "Choose a game"]- mes <- staticText d [text := "There are currently " ++ numberword (length games) ++ " games you can play."]- ok <- button d [text := "Play", tooltip := "click to proceed"]- can <- button d [text := "Cancel", tooltip := "click to cancel"]- r <- radioBox d Vertical (map (\(Game g) -> name g) games) [tooltip := "select a game"]- set d [ layout := margin 4 $ column 4- [ widget mes- , hfill $ widget r- , hfloatCentre $ row 4 [widget ok, widget can]- ]- ]- showModal d (\stop -> do- set ok [on command := get r selection >>= stop . Just]- set can [on command := stop Nothing]- )- - askSettings :: Properties -> PropertyRange -> IO (Maybe Properties)- askSettings pr ra = do- let pra = playersrange ra- bra = sort $ boardsizerange ra- d <- dialog mdiparent [text := "Settings"]- mes <- staticText d [text := "Select the settings."]- ok <- button d [text := "Play", tooltip := "click to start the game"]- can <- button d [text := "Cancel", tooltip := "click to cancel"]- cbs <- sequence $ replicate (maximum pra) $ checkBox d [tooltip := "should this player participate?"]- sts <- sequence $ map (\i -> staticText d [text := "player " ++ show i]) [1 .. maximum pra]- rbs <- sequence $ replicate (maximum pra) $ radioBox d Horizontal ["Human", "Computer"] [tooltip := "will you play this player?"]- sequence_ $ map (\i -> set (cbs !!! (i - 1)) [enabled := False]) [1 .. minimum pra]- let check b i = do set (cbs !!! (i - 1)) [checked := b]- set (sts !!! (i - 1)) [enabled := b]- set (rbs !!! (i - 1)) [enabled := b]- click True i | i `elem` pra = do for 1 i $ check True- | otherwise = click True (i + 1)- click False i | (i - 1) `elem` pra = do for i (maximum pra) $ check False- | otherwise = click False (i - 1)- for 1 (maximum pra) (\i -> check False i)- click True $ players pr- sequence_ $ zipWith (\i h -> set (rbs !!! (i - 1)) [selection := if h then 0 else 1]) [1 ..] (human pr)- sequence_ $ map (\i -> set (cbs !!! (i - 1)) [on command ::= \cb -> get cb checked >>= flip click i]) [1 .. maximum pra]- sli <- if length (bra) == 1 then return Nothing- else fmap Just $ hslider d False 0 (length bra - 1) [selection := maybe 0 id $ elemIndex (boardsize pr) bra, tooltip := "select the size of the board"]- let hcselection = map (\i -> [vfloatCentre $ widget $ cbs !!! (i - 1), vfloatCentre $ widget $ sts !!! (i - 1), widget $ rbs !!! (i - 1)]) [1 .. maximum pra]- selections = case sli of- Nothing -> grid 4 4 hcselection- Just s -> column 4 [ grid 4 4 hcselection- , hfill $ widget s- , row 4 [label "small", glue, label "large"]- ]- set d [ layout := margin 4 $ column 4- [ widget mes- , selections- , hfloatCentre $ row 4 [widget ok, widget can]- ]- ]- showModal d (\stop -> do- set ok [on command := do- p <- fmap (length . takeWhile id) $ sequence $ map (flip get checked) cbs- h <- sequence $ (map.fmap) (== 0) $ map (flip get selection) rbs- b <- case sli of Nothing -> return $ boardsize pr- Just s -> fmap (bra !!!) $ get s selection- stop $ Just Properties {players = p, human = h, boardsize = b}]- set can [on command := stop Nothing]- )--game :: Game g => MDIParentFrame () -> g -> Properties -> IO () -> IO ()-game mdiparent g pr newg = do-- {--== CREATION PHASE ==--}-- f <- mdiChildFrame mdiparent []- - mGame <- menuPane []- iNew <- menuItem mGame []- iAgain <- menuItem mGame []- () <- menuLine mGame - iClose <- menuItem mGame []- iQuit <- menuQuit mGame []- mBrain <- menuPane []- iOpen <- menuItem mBrain []- mHelp <- menuHelp []- iHelp <- menuItem mHelp []- iRules <- menuItem mHelp []- iInfo <- menuItem mHelp []- iAbout <- menuAbout mHelp []-- logoblue <- bitmap "blue"- logored <- bitmap "red"- logogreen <- bitmap "green"- logopurple <- bitmap "purple"- logobrown <- bitmap "brown"- logogrey <- bitmap "grey"-- turn <- bitmap "turn"- winner <- bitmap "winner"-- humanbmp <- bitmap "human"- computerbmp <- bitmap "computer"-- vart <- varCreate $ createtree g pr- varb <- varCreate $ emptyBrain-- p <- panel f []-- clock <- timer f []- - ps <- sequence $ replicate (players pr) $ panel f []- ss <- sequence $ map (\p' -> hslider p' False 0 10 []) ps- bs <- sequence $ map (\p' -> singleListBox p' []) ps----{ field <- statusField []-- {--== DEFINITION PHASE ==--}-- let - - stopClock :: IO ()- stopClock = do timerStop clock- info "clock stopped"-- ifhuman :: IO () -> IO ()- ifhuman io = do t <- getTree- if human pr !!! player t && movesnr t > 0 then io else return ()-- ifcomputer :: IO () -> IO ()- ifcomputer io = do t <- getTree- if human pr !!! player t || movesnr t == 0 then return () else io- - getTree = varGet vart- setTree = varSet vart- updateTree = varUpdate vart- - logo :: Int -> Bitmap ()- logo 0 = logoblue- logo 1 = logored- logo 2 = logogreen- logo 3 = logopurple- logo 4 = logobrown- logo 5 = logogrey- logo _ = error "logo: Unexpected value"- - onpaintplayer :: Int -> DC () -> Rect -> IO ()- onpaintplayer i dc (Rect _x _y w _h) = do- let xi = (w - 40) `div` 2- drawBitmap dc (logo i) (pt xi 10) True []- t <- getTree- drawRect dc (Rect xi 60 40 40) [brushKind := BrushTransparent]- for 0 (floor $ 19 * val t !!! i) (\j -> line dc (pt (xi + 1) (80 - j)) (pt (xi + 39) (80 - j)) [penColor := green])- for (floor $ 18 * val t !!! i) 0 (\j -> line dc (pt (xi + 1) (80 - j)) (pt (xi + 39) (80 - j)) [penColor := red ])- line dc (pt xi 80) (pt (xi + 40) 80) []- if player t == i && movesnr t > 0- then drawBitmap dc turn (pt xi 110) True []- else return ()- drawBitmap dc (if human pr !!! i then humanbmp else computerbmp) (pt xi 160) True []- ifIO (win i) $ drawBitmap dc winner (pt xi 110) True []-- oncommand i = do- t <- getTree- when (player t == i) $ send clock-- playerpanel i p' sli box = do- but <- button p' []- stt <- staticText p' []- itemAppend box $ ""-- set sli [ clientSize := Size 60 20- , color := setLum 0.25 $ colorplayer i- , bgcolor := setLum 0.95 $ colorplayer i- , on command := do v <- sliderGetValue sli- set stt [text := show ((2 :: Int) ^ v) ++ " sec"]- , visible := not (human pr !!! i)- , selection := 3- ]- set stt [ clientSize := Size 70 20- , text := "8 sec"- , color := setLum 0.25 $ colorplayer i- , bgcolor := setLum 0.95 $ colorplayer i- , visible := not (human pr !!! i)- ]- set but [ text := "move now"- , color := setLum 0.25 $ colorplayer i- , bgcolor := setLum 0.95 $ colorplayer i- , on command := oncommand i- , visible := not (human pr !!! i)- ] - set box [ clientSize := Size 60 20- , color := setLum 0.25 $ colorplayer i- , bgcolor := setLum 0.95 $ colorplayer i- , on select := do info ("select " ++ show i)- s <- get box selection- mapM_ (\b -> set b [selection := s]) bs- ]- set p' [ bgcolor := setLum 0.95 $ colorplayer i- , clientSize := Size 80 0- , on paint := onpaintplayer i- , layout := margin 4 $ column 4- [ space 72 210- , hfill $ widget sli- , hfloatCentre $ widget stt- , hfloatCentre $ widget but- , vfill $ hfloatCentre $ widget box- ]- ]- return ()-- boxInsert :: Player -> String -> IO ()- boxInsert p' s = do- let b = (bs !!! p')- i <- get b itemCount- vs <- mapM (\p'' -> get (bs !!! p'') (item $ i - 1)) [p' .. length bs - 1]- when (not $ all null vs) $- mapM_ (\b' -> itemAppend b' "") bs- i' <- get b itemCount- set b [item (i' - 1) := s]- mapM_ (\b' -> set b' [selection := i' - 1]) bs-- win :: Int -> IO Bool- win i' = do- t <- getTree- return $ (movesnr t == 0) && (val t !!! i' == 1)-- gamename = (\(c : cs) -> toUpper c : cs) $ name g-- repaintall :: IO ()- repaintall = do repaint p- sequence_ $ map repaint ps- - startClock :: IO ()- startClock = do t <- getTree- v <- sliderGetValue $ ss !!! player t- let int = 1000 * 2 ^ v- _ <- timerStart clock int True- info "clock started"- - next :: Int -> IO ()- next n = do t <- getTree- _ <- updateTree (shear n)- u <- getTree- b <- varGet varb- bRefresh b- boxInsert (player t) $ showmove pr (player t) (state t) (childid u)- repaintall- if movesnr t == 0- then do infoDialog f "End of Game" $ "The game ended with value " ++ show (val u)- info "end of this game"- else do ifcomputer $ info "computer's turn" >> think >> startClock- ifhuman $ info "player's turn"-- onidle :: IO Bool- onidle = do ifcomputer $ do think- u <- getTree- when (movesnr u == 1) movenow- when (closed u) movenow- --{ andere constructie (ook denken in spelertijd?)- t <- getTree- return $ human pr !!! player t-- think :: IO ()- think = do t <- getTree- js <- randomList- let p' = path followcombination js t---{ let p = path followbest js t- _ <- updateTree $ step p'- u <- getTree-- when (val t /= val u) $ sequence_ $ map repaint ps- b <- varGet varb- bUpdatePath b p'-- return ()-- movenow :: IO ()- movenow = ifcomputer $ do- stopClock- t <- getTree- i <- randomElement $ best t- info "computer moves"- next i-- newquick :: IO ()- newquick = do stopClock- setTree $ createtree g pr- info "new game started"- sequence_ $ map (\b -> set b [items := [" "]]) bs- repaintall- ifcomputer $ info "computer's turn" >> startClock- return ()-- showRules :: IO ()- showRules = html f $ "help\\rules_" ++ gamename ++ ".html"- - showInfo :: IO ()- showInfo = html f $ "help\\info_" ++ gamename ++ ".html"-- playerinput :: Int -> IO ()- playerinput i = do- info $ "moverequest: " ++ show i- ifhuman $ do- t <- getTree- when (0 <= i && i < movesnr t) $ info "correct move" >> next i-- {--== MODIFICATION PHASE ==--}-- sequence_ $ zipWith4 playerpanel [0..] ps ss bs-- board p pr vart True playerinput-- set mGame [ text := "&Game" ]- set iNew [ text := "&New Game\tCtrl+N" , help := "Start a new game" , on command := newg ]- set iAgain [ text := "Play &Again\tCtrl+A" , help := "Play again with the same settings" , on command := newquick >> varGet varb >>= bRefresh ]- set iClose [ text := "&Close\tCtrl+C" , help := "Close this game" , on command := close f ]- set iQuit [ help := "Quit the application" , on command := close mdiparent ]- set mBrain [ text := "&Brain" ]- set iOpen [ text := "&Open\tCtrl+B" , help := "Open the brain for " ++ gamename , on command := brain mdiparent pr vart varb newg ]- set iHelp [ text := "&Contents" , help := "Show the contents of GeBoP" , on command := html f "help\\index.html" ]- set iRules [ text := gamename ++ " &Rules" , help := "Display the rules of this game" , on command := showRules ]- set iInfo [ text := gamename ++ " &Information", help := "Display some background information on this game" , on command := showInfo ]- set iAbout [ help := "Information about this program" , on command := infoDialog f "About GeBoP" about ]-- set clock [ on command := info "alarm" >> movenow ]-- set p [ clientSize := sz 400 400 ]-- set f [ text := gamename- , menuBar := [mGame, mBrain, mHelp] - , layout := row 0 ( fill (widget p)- : map (vfill . widget) ps- )- , on idle := onidle- , picture := "gebop.ico"- , on closing :~ \io -> do b <- varGet varb- bClose b- io---{ , statusBar := [field]- ]-- ifhuman $ stopClock-- return ()--data Brain- = Brain { bClose :: IO ()- , bUpdatePath :: [Int] -> IO ()- , bRefresh :: IO ()- }--emptyBrain :: Brain-emptyBrain- = Brain { bClose = return ()- , bUpdatePath = const $ return ()- , bRefresh = return ()- }--brain :: Game g => MDIParentFrame () -> Properties -> Var (Tree g) -> Var Brain -> IO () -> IO ()-brain mdiparent pr vart varb newg = do-- {--== CREATION PHASE ==--}-- let extraInfo = \_ -> return () -- "info" if you want tracing- f <- mdiChildFrame mdiparent []- extraInfo "mdiChildFrame"- sw <- splitterWindow f []- extraInfo "splitterWindow"- - pLeft <- panel sw []- pRight <- panel sw []- pBoard <- panel pRight []- pValue <- panel pRight []- pInfo <- panel pRight []- extraInfo "panel"-- mGame <- menuPane []- iNew <- menuItem mGame []- () <- menuLine mGame- iQuit <- menuQuit mGame []- mBrain <- menuPane []- iClose <- menuItem mBrain []- iMini <- menuItem mBrain []- iLarge <- menuItem mBrain []- mHelp <- menuHelp []- iHelp <- menuItem mHelp []- iBrain <- menuItem mHelp []- iAbout <- menuAbout mHelp []- extraInfo "menu"-- logos <- mapM (bitmap.nameplayer) [0 .. 5]- winner <- bitmap "winner"- leeg <- bitmap "empty"-- bPlayer <- staticBitmapCreate pRight (-1) (logos !!! 0) rectNull 0x00200000 -- 0x00200000 == wxBORDER_NONE- extraInfo "staticBitmapCreate"-- -- tPlayer <- staticText pRight []- tMind <- staticText pInfo []- tMaxd <- staticText pInfo []- tVolume <- staticText pInfo []- extraInfo "staticText"-- tc <- treeCtrl pLeft []- extraInfo "treeCtrl"-- g <- varGet vart >>= return . state- varu <- varCopy vart-- {--== DEFINITION PHASE ==--}-- let -- gamename :: String- gamename = (\(c : cs) -> toUpper c : cs) $ name g-- getData :: TreeItem -> IO [Int]- getData treeItem = do- mmovs <- unsafeTreeCtrlGetItemClientData tc treeItem - case mmovs of Just movs -> return movs- Nothing -> return []-- setImages :: Bool -> IO ()- setImages True = do- il <- imageListCreate (Size 40 40) True 0- sequence_ $ map (bitmapImageList il) $ map nameplayer [0 .. 5]- sequence_ $ map (bitmapHighImageList il) $ map nameplayer [0 .. 5]- bitmapImageList il "brain"- treeCtrlAssignImageList tc il- setImages False = do- il <- imageListCreate (Size 10 10) True 0- sequence_ $ map (bitmapImageList il) $ map ("small_" ++) $ map nameplayer [0 .. 5]- sequence_ $ map (bitmapHighImageList il) $ map ("small_" ++) $ map nameplayer [0 .. 5]- bitmapImageList il "small_brain"- treeCtrlAssignImageList tc il-- onmini :: IO ()- onmini = do- set f [clientSize := sz 256 100]- splitterWindowSetSashPosition sw 128 True- - onpaintValue :: DC () -> Rect -> IO ()- onpaintValue dc (Rect x y w_ h) = do- let pl = players pr- w = min (w_) (20 * pl)- r = Rect x y w h---{ line dc (pt 0 0) (pt w h) []---{ line dc (pt 0 h) (pt w 0) []- u <- varGet varu- for 0 (pl - 1) (\i -> do- let xi = x + w * i `div` pl- xi1 = x + w * (i + 1) `div` pl- for 0 (floor $ 19 * val u !!! i) (\j -> line dc (pt (xi + 1) (20 - j)) (pt (xi1) (20 - j)) [penColor := colorplayer i])- for (floor $ 18 * val u !!! i) 0 (\j -> line dc (pt (xi + 1) (20 - j)) (pt (xi1) (20 - j)) [penColor := setLum 0.4 $ colorplayer i])- )- drawRect dc r [brushKind := BrushTransparent]- line dc (pt x 20) (pt (x + w) 20) []-- onTreeEvent :: EventTree -> IO ()- onTreeEvent (TreeItemExpanding treeItem _veto) | treeItemIsOk treeItem = do- wxcBeginBusyCursor- children' <- treeCtrlGetChildren tc treeItem - mapM_ visualise children'- wxcEndBusyCursor- propagateEvent- onTreeEvent (TreeSelChanged treeItem _olditem) | treeItemIsOk treeItem = do- wxcBeginBusyCursor- selectRight treeItem - wxcEndBusyCursor- propagateEvent- onTreeEvent _ = propagateEvent-- visualise :: TreeItem -> IO ()- visualise treeItem = do- c <- treeCtrlItemHasChildren tc treeItem - when (c == 0) $ giveBirth treeItem - updateThickness treeItem - updateImages treeItem -- selectRight :: TreeItem -> IO ()- selectRight treeItem = do- updateRight treeItem - t <- varGet varu- staticBitmapSetBitmap bPlayer (logos !!! player t)- when (movesnr t == 0) $ staticBitmapSetBitmap bPlayer (if any (== 1) (val t) then winner else leeg)- repaint pBoard-- updateRight :: TreeItem -> IO ()- updateRight treeItem = do- t <- gametree treeItem - varSet varu t- set tMind [text := "complete depth: " ++ show (mind t)]- set tMaxd [text := "maximum depth: " ++ show (maxd t)]- set tVolume [text := "volume: " ++ show (volume t)]- repaint pValue-- bClose' :: IO ()- bClose' = close f-- bUpdatePath' :: [Int] -> IO ()- bUpdatePath' path' = do- root <- treeCtrlGetRootItem tc- updatePath root path'- where- updatePath :: TreeItem -> [Int] -> IO ()- updatePath treeItem path'' = do- updateThickness treeItem - updateImages treeItem - ifIO (treeCtrlIsSelected tc treeItem) $ updateRight treeItem - ifIO (treeCtrlIsExpanded tc treeItem) $ case path'' of- (i:is) -> do cs <- treeCtrlGetChildren tc treeItem - updatePath (cs !! i) is- [] -> return ()-- bRefresh' :: IO ()- bRefresh' = do- treeCtrlDeleteAllItems tc---{ root <- treeCtrlAddRoot tc "current situation" 5 (-1) objectNull- root <- treeCtrlAddRoot tc "current situation" 12 12 objectNull- treeCtrlSetItemClientData tc root (return ()) []- giveBirth root- updateThickness root- updateImages root- treeCtrlSelectItem tc root- selectRight root-- giveBirth :: TreeItem -> IO ()- giveBirth treeItem = do- movs <- getData treeItem - t <- gametree treeItem - for 0 (movesnr t - 1) (\i -> do- let -- u = shear i t- m = showmove pr (player t) (state t) i---{ jtem <- treeCtrlAppendItem tc treeItem (show i ++ " (" ++ m ++ ")") (player t) (-1) objectNull - jtem <- treeCtrlAppendItem tc treeItem (show i ++ " (" ++ m ++ ")") (-1) (-1) objectNull - treeCtrlSetItemClientData tc jtem (return ()) (movs ++ [i])- updateThickness jtem- )- treeCtrlSetItemHasChildren tc treeItem (movesnr t > 0)-- updateThickness :: TreeItem -> IO ()- updateThickness treeItem = do- t <- gametree treeItem - let itemcolor | filled t = black- | otherwise = grey- treeCtrlSetItemTextColour tc treeItem itemcolor- treeCtrlSetItemBold tc treeItem (closed t)- - updateImages :: TreeItem -> IO ()- updateImages treeItem = do- t <- gametree treeItem - c <- treeCtrlItemHasChildren tc treeItem - cs <- treeCtrlGetChildren tc treeItem - when (c > 0) $ for 0 (movesnr t - 1) (\i -> do- let offset | i `elem` best t = 6- | otherwise = 0- setImage (cs !! i) (offset + player t)- )-- setImage :: TreeItem -> Int -> IO ()- setImage treeItem i = do- j <- treeCtrlGetItemImage tc treeItem 0 --{ wxTreeItemIcon_Normal- when (i /= j) $ do- treeCtrlSetItemImage tc treeItem i 0 --{ wxTreeItemIcon_Normal- treeCtrlSetItemImage tc treeItem i 1 --{ wxTreeItemIcon_Selected---{ treeCtrlSetItemImage tc treeItem i 2 --{ wxTreeItemIcon_Expanded---{ treeCtrlSetItemImage tc treeItem i 3 --{ wxTreeItemIcon_SelectedExpanded---- gametree :: TreeItem -> IO (Tree g)- gametree treeItem = do- t <- varGet vart- movs <- getData treeItem - return $ gametree_ movs t- where--- gametree_ :: [Int] -> Tree g -> Tree g- gametree_ (i:is) t | i >= 0 && i < movesnr t = gametree_ is $ shear i t- gametree_ _ t = t--- playerinput :: Int -> IO ()- playerinput i = do- info $ "brain moverequest: " ++ show i- treeItem <- treeCtrlGetSelection tc- t <- gametree treeItem - cs <- treeCtrlGetChildren tc treeItem - when (0 <= i && i < movesnr t) $ do- treeCtrlExpand tc treeItem - treeCtrlSelectItem tc (cs !! i)-- {--== MODIFICATION PHASE ==--}-- board pBoard pr varu False playerinput-- bRefresh'--- setImages True- setImages False- -- varSet varb $ Brain bClose' bUpdatePath' bRefresh'-- set mGame [ text := "&Game" ] - set iNew [ text := "&New Game\tCtrl+N" , help := "Start a new game" , on command := newg ]- set iQuit [ help := "Quit the application" , on command := close mdiparent ] - set mBrain [ text := "&Brain" ] - set iClose [ text := "&Close\tCtrl+C" , help := "Close the brain for " ++ gamename , on command := close f ] - set iMini [ text := "&Minimal\tCtrl+M" , help := "Minimize the brain size" , on command := onmini ] - set iLarge [ text := "&Large Icons\tCtrl+L" , checkable := True, checked := False , on command ::= (>>= setImages) . flip get checked ] - set iHelp [ text := "&Contents" , help := "Show the contents of GeBoP" , on command := html f "help\\index.html" ]- set iBrain [ text := "The &Brain" , help := "Shows help about the brain viewer" , on command := html f "help\\brain.html" ]- set iAbout [ help := "Information about this program" , on command := infoDialog f "About GeBoP" about ]-- set tc [ on treeEvent := onTreeEvent- ] -- set pLeft [ layout := fill $ widget tc- ]-- set pValue [ clientSize := Size 40 40- , on paint := onpaintValue- , on resize ::= repaint- ]-- set pInfo [ layout := fill $ column 4 $- [ widget tMind - , widget tMaxd - , widget tVolume - ]- ]-- set pBoard [ on resize ::= repaint- ] -- set pRight [ layout := margin 4 $ column 4 $- [ row 4 [widget bPlayer, fill $ widget pValue]- , hfill $ widget pInfo- , fill $ widget pBoard- ]- ]-- set f [ text := gamename ++ " Brain"- , menuBar := [mGame, mBrain, mHelp] - , layout := fill $ vsplit sw 4 200 (widget pLeft) (widget pRight)- , picture := "brain.ico"- , clientSize := Size 480 360- , on closing :~ (varSet varb emptyBrain >>)- ]- -colorplayer :: Int -> Color-colorplayer 0 = hsl 0.66 1 0.5-colorplayer 1 = hsl 0 1 0.5-colorplayer 2 = hsl 0.33 1 0.5-colorplayer 3 = hsl 0.82 1 0.5-colorplayer 4 = hsl 0.11 0.7 0.5-colorplayer 5 = hsl 0 0 0.5-colorplayer _ = hsl 0 0 0--nameplayer :: Int -> String-nameplayer 0 = "blue"-nameplayer 1 = "red"-nameplayer 2 = "green"-nameplayer 3 = "purple"-nameplayer 4 = "brown"-nameplayer 5 = "grey"-nameplayer _ = "black"--info :: String -> IO ()-info s = do- putStrLn $ "[" ++ s ++ "]"- return ()- -html :: Window a -> FilePath -> IO ()-html w f = do- d <- dialog w [text := "Help"]- -- w <- htmlWindowCreate d (-1) (rect (point 0 0) (size 640 480)) 0 []- w' <- htmlWindowCreate d (-1) (rect (point 0 0) (Size 640 480)) 0 []- _ <- htmlWindowLoadPage w' f- set d [layout := widget w', visible := True]- return ()--about :: String-about = "GeBoP - General Boardgames Player"- ++ "\nversion " ++ version- ++ "\n"- ++ "\nby Maarten Löffler"- ++ "\nmloffler@cs.uu.nl"- ++ "\n"- ++ "\nGeBoP was written using wxHaskell"- -bitmap :: String -> IO (Bitmap ())-bitmap name' = do bmp <- bitmapCreateLoad ("images\\" ++ name' ++ ".bmp") wxBITMAP_TYPE_ANY- mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY - bitmapSetDepth mskbmp 1- msk <- maskCreate mskbmp- bitmapSetMask bmp msk- return bmp--bitmapImageList :: ImageList () -> String -> IO ()-bitmapImageList il name' = do- bmp <- bitmapCreateLoad ("images\\" ++ name' ++ ".bmp") wxBITMAP_TYPE_ANY- mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY - bitmapSetDepth mskbmp 1- _ <- imageListAddBitmap il bmp mskbmp- return ()--bitmapHighImageList :: ImageList () -> String -> IO ()-bitmapHighImageList il name' = do- bmp <- bitmapCreateLoad ("images\\high_" ++ name' ++ ".bmp") wxBITMAP_TYPE_ANY- mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY - bitmapSetDepth mskbmp 1- _ <- imageListAddBitmap il bmp mskbmp- return ()+{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} + +--------- +-- GUI -- +--------- + +module GUI (gui, version) where + +import Game -- hiding (name) +import Graphics.UI.WX hiding (bitmap, children, click, next, selections, stop) +import Graphics.UI.WXCore hiding (win) +import Data.Char +import Tools hiding (field) +import Data.List + +import Data.Version (versionBranch) +import qualified Paths_GeBoP as Paths -- (version) + + +version :: String +version = a ++ "." ++ b ++ "." ++ c + where + (a : b : c : _) = map show $ versionBranch Paths.version ++ repeat 0 + + +gui :: [GeneralGame] -> IO () +gui games = do + + {--== CREATION PHASE ==--} + + f <- mdiParentFrame [] + c <- mdiParentFrameGetClientWindow f + + mGame <- menuPane [] + iNew <- menuItem mGame [] + () <- menuLine mGame + iQuit <- menuQuit mGame [] + + mHelp <- menuHelp [] + iHelp <- menuItem mHelp [] + iAbout <- menuAbout mHelp [] + + field <- statusField [] + + logo <- bitmapCreateLoad "images\\gebop.bmp" wxBITMAP_TYPE_ANY + + {--== DEFINITION PHASE ==--} + + let onpaint :: DC () -> Rect -> IO () + onpaint dc r = do + tileBitmap dc r logo + + {--== MODIFICATION PHASE ==--} + + set mGame [ text := "&Game" ] + set iNew [ text := "&New Game\tCtrl+N", help := "Start a new game" , on command := newgame f games] + set iQuit [ help := "Quit the application" , on command := close f] + set iHelp [ text := "&Contents" , help := "Show the contents of GeBoP" , on command := html f "help\\index.html"] + set iAbout [ help := "Information about this program", on command := infoDialog f "About GeBoP" about] + + set f [ visible := True + , clientSize := sz 640 480 + , picture := "gebop.ico" + , text := "GeBoP" + , menuBar := [mGame, mHelp] + , statusBar := [field] + ] + + set c [ on paint := onpaint + , on resize ::= repaint + ] + + return () + +newgame :: MDIParentFrame () -> [GeneralGame] -> IO () +newgame mdiparent games = do + mi <- askGame + case mi of + Nothing -> return () + Just i -> do + let gc = games !! i + pr = (\(Game g) -> standard g) gc + ra = (\(Game g) -> possible g) gc + msettings <- askSettings pr ra + case msettings of + Nothing -> return () + Just settings -> do + (\(Game g) -> game mdiparent g settings (newgame mdiparent games)) $ gc + return () + + where + + askGame :: IO (Maybe Int) + askGame = do + d <- dialog mdiparent [text := "Choose a game"] + mes <- staticText d [text := "There are currently " ++ numberword (length games) ++ " games you can play."] + ok <- button d [text := "Play", tooltip := "click to proceed"] + can <- button d [text := "Cancel", tooltip := "click to cancel"] + r <- radioBox d Vertical (map (\(Game g) -> name g) games) [tooltip := "select a game"] + set d [ layout := margin 4 $ column 4 + [ widget mes + , hfill $ widget r + , hfloatCentre $ row 4 [widget ok, widget can] + ] + ] + showModal d (\stop -> do + set ok [on command := get r selection >>= stop . Just] + set can [on command := stop Nothing] + ) + + askSettings :: Properties -> PropertyRange -> IO (Maybe Properties) + askSettings pr ra = do + let pra = playersrange ra + bra = sort $ boardsizerange ra + d <- dialog mdiparent [text := "Settings"] + mes <- staticText d [text := "Select the settings."] + ok <- button d [text := "Play", tooltip := "click to start the game"] + can <- button d [text := "Cancel", tooltip := "click to cancel"] + cbs <- sequence $ replicate (maximum pra) $ checkBox d [tooltip := "should this player participate?"] + sts <- sequence $ map (\i -> staticText d [text := "player " ++ show i]) [1 .. maximum pra] + rbs <- sequence $ replicate (maximum pra) $ radioBox d Horizontal ["Human", "Computer"] [tooltip := "will you play this player?"] + sequence_ $ map (\i -> set (cbs !!! (i - 1)) [enabled := False]) [1 .. minimum pra] + let check b i = do set (cbs !!! (i - 1)) [checked := b] + set (sts !!! (i - 1)) [enabled := b] + set (rbs !!! (i - 1)) [enabled := b] + click True i | i `elem` pra = do for 1 i $ check True + | otherwise = click True (i + 1) + click False i | (i - 1) `elem` pra = do for i (maximum pra) $ check False + | otherwise = click False (i - 1) + for 1 (maximum pra) (\i -> check False i) + click True $ players pr + sequence_ $ zipWith (\i h -> set (rbs !!! (i - 1)) [selection := if h then 0 else 1]) [1 ..] (human pr) + sequence_ $ map (\i -> set (cbs !!! (i - 1)) [on command ::= \cb -> get cb checked >>= flip click i]) [1 .. maximum pra] + sli <- if length (bra) == 1 then return Nothing + else fmap Just $ hslider d False 0 (length bra - 1) [selection := maybe 0 id $ elemIndex (boardsize pr) bra, tooltip := "select the size of the board"] + let hcselection = map (\i -> [vfloatCentre $ widget $ cbs !!! (i - 1), vfloatCentre $ widget $ sts !!! (i - 1), widget $ rbs !!! (i - 1)]) [1 .. maximum pra] + selections = case sli of + Nothing -> grid 4 4 hcselection + Just s -> column 4 [ grid 4 4 hcselection + , hfill $ widget s + , row 4 [label "small", glue, label "large"] + ] + set d [ layout := margin 4 $ column 4 + [ widget mes + , selections + , hfloatCentre $ row 4 [widget ok, widget can] + ] + ] + showModal d (\stop -> do + set ok [on command := do + p <- fmap (length . takeWhile id) $ sequence $ map (flip get checked) cbs + h <- sequence $ (map.fmap) (== 0) $ map (flip get selection) rbs + b <- case sli of Nothing -> return $ boardsize pr + Just s -> fmap (bra !!!) $ get s selection + stop $ Just Properties {players = p, human = h, boardsize = b}] + set can [on command := stop Nothing] + ) + +game :: Game g => MDIParentFrame () -> g -> Properties -> IO () -> IO () +game mdiparent g pr newg = do + + {--== CREATION PHASE ==--} + + f <- mdiChildFrame mdiparent [] + + mGame <- menuPane [] + iNew <- menuItem mGame [] + iAgain <- menuItem mGame [] + () <- menuLine mGame + iClose <- menuItem mGame [] + iQuit <- menuQuit mGame [] + mBrain <- menuPane [] + iOpen <- menuItem mBrain [] + mHelp <- menuHelp [] + iHelp <- menuItem mHelp [] + iRules <- menuItem mHelp [] + iInfo <- menuItem mHelp [] + iAbout <- menuAbout mHelp [] + + logoblue <- bitmap "blue" + logored <- bitmap "red" + logogreen <- bitmap "green" + logopurple <- bitmap "purple" + logobrown <- bitmap "brown" + logogrey <- bitmap "grey" + + turn <- bitmap "turn" + winner <- bitmap "winner" + + humanbmp <- bitmap "human" + computerbmp <- bitmap "computer" + + vart <- varCreate $ createtree g pr + varb <- varCreate $ emptyBrain + + p <- panel f [] + + clock <- timer f [] + + ps <- sequence $ replicate (players pr) $ panel f [] + ss <- sequence $ map (\p' -> hslider p' False 0 10 []) ps + bs <- sequence $ map (\p' -> singleListBox p' []) ps + +--{ field <- statusField [] + + {--== DEFINITION PHASE ==--} + + let + + stopClock :: IO () + stopClock = do timerStop clock + info "clock stopped" + + ifhuman :: IO () -> IO () + ifhuman io = do t <- getTree + if human pr !!! player t && movesnr t > 0 then io else return () + + ifcomputer :: IO () -> IO () + ifcomputer io = do t <- getTree + if human pr !!! player t || movesnr t == 0 then return () else io + + getTree = varGet vart + setTree = varSet vart + updateTree = varUpdate vart + + logo :: Int -> Bitmap () + logo 0 = logoblue + logo 1 = logored + logo 2 = logogreen + logo 3 = logopurple + logo 4 = logobrown + logo 5 = logogrey + logo _ = error "logo: Unexpected value" + + onpaintplayer :: Int -> DC () -> Rect -> IO () + onpaintplayer i dc (Rect _x _y w _h) = do + let xi = (w - 40) `div` 2 + drawBitmap dc (logo i) (pt xi 10) True [] + t <- getTree + drawRect dc (Rect xi 60 40 40) [brushKind := BrushTransparent] + for 0 (floor $ 19 * val t !!! i) (\j -> line dc (pt (xi + 1) (80 - j)) (pt (xi + 39) (80 - j)) [penColor := green]) + for (floor $ 18 * val t !!! i) 0 (\j -> line dc (pt (xi + 1) (80 - j)) (pt (xi + 39) (80 - j)) [penColor := red ]) + line dc (pt xi 80) (pt (xi + 40) 80) [] + if player t == i && movesnr t > 0 + then drawBitmap dc turn (pt xi 110) True [] + else return () + drawBitmap dc (if human pr !!! i then humanbmp else computerbmp) (pt xi 160) True [] + ifIO (win i) $ drawBitmap dc winner (pt xi 110) True [] + + oncommand i = do + t <- getTree + when (player t == i) $ send clock + + playerpanel i p' sli box = do + but <- button p' [] + stt <- staticText p' [] + itemAppend box $ "" + + set sli [ clientSize := Size 60 20 + , color := setLum 0.25 $ colorplayer i + , bgcolor := setLum 0.95 $ colorplayer i + , on command := do v <- sliderGetValue sli + set stt [text := show ((2 :: Int) ^ v) ++ " sec"] + , visible := not (human pr !!! i) + , selection := 3 + ] + set stt [ clientSize := Size 70 20 + , text := "8 sec" + , color := setLum 0.25 $ colorplayer i + , bgcolor := setLum 0.95 $ colorplayer i + , visible := not (human pr !!! i) + ] + set but [ text := "move now" + , color := setLum 0.25 $ colorplayer i + , bgcolor := setLum 0.95 $ colorplayer i + , on command := oncommand i + , visible := not (human pr !!! i) + ] + set box [ clientSize := Size 60 20 + , color := setLum 0.25 $ colorplayer i + , bgcolor := setLum 0.95 $ colorplayer i + , on select := do info ("select " ++ show i) + s <- get box selection + mapM_ (\b -> set b [selection := s]) bs + ] + set p' [ bgcolor := setLum 0.95 $ colorplayer i + , clientSize := Size 80 0 + , on paint := onpaintplayer i + , layout := margin 4 $ column 4 + [ space 72 210 + , hfill $ widget sli + , hfloatCentre $ widget stt + , hfloatCentre $ widget but + , vfill $ hfloatCentre $ widget box + ] + ] + return () + + boxInsert :: Player -> String -> IO () + boxInsert p' s = do + let b = (bs !!! p') + i <- get b itemCount + vs <- mapM (\p'' -> get (bs !!! p'') (item $ i - 1)) [p' .. length bs - 1] + when (not $ all null vs) $ + mapM_ (\b' -> itemAppend b' "") bs + i' <- get b itemCount + set b [item (i' - 1) := s] + mapM_ (\b' -> set b' [selection := i' - 1]) bs + + win :: Int -> IO Bool + win i' = do + t <- getTree + return $ (movesnr t == 0) && (val t !!! i' == 1) + + gamename = (\(c : cs) -> toUpper c : cs) $ name g + + repaintall :: IO () + repaintall = do repaint p + sequence_ $ map repaint ps + + startClock :: IO () + startClock = do t <- getTree + v <- sliderGetValue $ ss !!! player t + let int = 1000 * 2 ^ v + _ <- timerStart clock int True + info "clock started" + + next :: Int -> IO () + next n = do t <- getTree + _ <- updateTree (shear n) + u <- getTree + b <- varGet varb + bRefresh b + boxInsert (player t) $ showmove pr (player t) (state t) (childid u) + repaintall + if movesnr t == 0 + then do infoDialog f "End of Game" $ "The game ended with value " ++ show (val u) + info "end of this game" + else do ifcomputer $ info "computer's turn" >> think >> startClock + ifhuman $ info "player's turn" + + onidle :: IO Bool + onidle = do ifcomputer $ do think + u <- getTree + when (movesnr u == 1) movenow + when (closed u) movenow + --{ andere constructie (ook denken in spelertijd?) + t <- getTree + return $ human pr !!! player t + + think :: IO () + think = do t <- getTree + js <- randomList + let p' = path followcombination js t +--{ let p = path followbest js t + _ <- updateTree $ step p' + u <- getTree + + when (val t /= val u) $ sequence_ $ map repaint ps + b <- varGet varb + bUpdatePath b p' + + return () + + movenow :: IO () + movenow = ifcomputer $ do + stopClock + t <- getTree + i <- randomElement $ best t + info "computer moves" + next i + + newquick :: IO () + newquick = do stopClock + setTree $ createtree g pr + info "new game started" + sequence_ $ map (\b -> set b [items := [" "]]) bs + repaintall + ifcomputer $ info "computer's turn" >> startClock + return () + + showRules :: IO () + showRules = html f $ "help\\rules_" ++ gamename ++ ".html" + + showInfo :: IO () + showInfo = html f $ "help\\info_" ++ gamename ++ ".html" + + playerinput :: Int -> IO () + playerinput i = do + info $ "moverequest: " ++ show i + ifhuman $ do + t <- getTree + when (0 <= i && i < movesnr t) $ info "correct move" >> next i + + {--== MODIFICATION PHASE ==--} + + sequence_ $ zipWith4 playerpanel [0..] ps ss bs + + board p pr vart True playerinput + + set mGame [ text := "&Game" ] + set iNew [ text := "&New Game\tCtrl+N" , help := "Start a new game" , on command := newg ] + set iAgain [ text := "Play &Again\tCtrl+A" , help := "Play again with the same settings" , on command := newquick >> varGet varb >>= bRefresh ] + set iClose [ text := "&Close\tCtrl+C" , help := "Close this game" , on command := close f ] + set iQuit [ help := "Quit the application" , on command := close mdiparent ] + set mBrain [ text := "&Brain" ] + set iOpen [ text := "&Open\tCtrl+B" , help := "Open the brain for " ++ gamename , on command := brain mdiparent pr vart varb newg ] + set iHelp [ text := "&Contents" , help := "Show the contents of GeBoP" , on command := html f "help\\index.html" ] + set iRules [ text := gamename ++ " &Rules" , help := "Display the rules of this game" , on command := showRules ] + set iInfo [ text := gamename ++ " &Information", help := "Display some background information on this game" , on command := showInfo ] + set iAbout [ help := "Information about this program" , on command := infoDialog f "About GeBoP" about ] + + set clock [ on command := info "alarm" >> movenow ] + + set p [ clientSize := sz 400 400 ] + + set f [ text := gamename + , menuBar := [mGame, mBrain, mHelp] + , layout := row 0 ( fill (widget p) + : map (vfill . widget) ps + ) + , on idle := onidle + , picture := "gebop.ico" + , on closing :~ \io -> do b <- varGet varb + bClose b + io +--{ , statusBar := [field] + ] + + ifhuman $ stopClock + + return () + +data Brain + = Brain { bClose :: IO () + , bUpdatePath :: [Int] -> IO () + , bRefresh :: IO () + } + +emptyBrain :: Brain +emptyBrain + = Brain { bClose = return () + , bUpdatePath = const $ return () + , bRefresh = return () + } + +brain :: Game g => MDIParentFrame () -> Properties -> Var (Tree g) -> Var Brain -> IO () -> IO () +brain mdiparent pr vart varb newg = do + + {--== CREATION PHASE ==--} + + let extraInfo = \_ -> return () -- "info" if you want tracing + f <- mdiChildFrame mdiparent [] + extraInfo "mdiChildFrame" + sw <- splitterWindow f [] + extraInfo "splitterWindow" + + pLeft <- panel sw [] + pRight <- panel sw [] + pBoard <- panel pRight [] + pValue <- panel pRight [] + pInfo <- panel pRight [] + extraInfo "panel" + + mGame <- menuPane [] + iNew <- menuItem mGame [] + () <- menuLine mGame + iQuit <- menuQuit mGame [] + mBrain <- menuPane [] + iClose <- menuItem mBrain [] + iMini <- menuItem mBrain [] + iLarge <- menuItem mBrain [] + mHelp <- menuHelp [] + iHelp <- menuItem mHelp [] + iBrain <- menuItem mHelp [] + iAbout <- menuAbout mHelp [] + extraInfo "menu" + + logos <- mapM (bitmap.nameplayer) [0 .. 5] + winner <- bitmap "winner" + leeg <- bitmap "empty" + + bPlayer <- staticBitmapCreate pRight (-1) (logos !!! 0) rectNull 0x00200000 -- 0x00200000 == wxBORDER_NONE + extraInfo "staticBitmapCreate" + + -- tPlayer <- staticText pRight [] + tMind <- staticText pInfo [] + tMaxd <- staticText pInfo [] + tVolume <- staticText pInfo [] + extraInfo "staticText" + + tc <- treeCtrl pLeft [] + extraInfo "treeCtrl" + + g <- varGet vart >>= return . state + varu <- varCopy vart + + {--== DEFINITION PHASE ==--} + + let + + gamename :: String + gamename = (\(c : cs) -> toUpper c : cs) $ name g + + getData :: TreeItem -> IO [Int] + getData treeItem = do + mmovs <- unsafeTreeCtrlGetItemClientData tc treeItem + case mmovs of Just movs -> return movs + Nothing -> return [] + + setImages :: Bool -> IO () + setImages True = do + il <- imageListCreate (Size 40 40) True 0 + sequence_ $ map (bitmapImageList il) $ map nameplayer [0 .. 5] + sequence_ $ map (bitmapHighImageList il) $ map nameplayer [0 .. 5] + bitmapImageList il "brain" + treeCtrlAssignImageList tc il + setImages False = do + il <- imageListCreate (Size 10 10) True 0 + sequence_ $ map (bitmapImageList il) $ map ("small_" ++) $ map nameplayer [0 .. 5] + sequence_ $ map (bitmapHighImageList il) $ map ("small_" ++) $ map nameplayer [0 .. 5] + bitmapImageList il "small_brain" + treeCtrlAssignImageList tc il + + onmini :: IO () + onmini = do + set f [clientSize := sz 256 100] + splitterWindowSetSashPosition sw 128 True + + onpaintValue :: DC () -> Rect -> IO () + onpaintValue dc (Rect x y w_ h) = do + let pl = players pr + w = min (w_) (20 * pl) + r = Rect x y w h +--{ line dc (pt 0 0) (pt w h) [] +--{ line dc (pt 0 h) (pt w 0) [] + u <- varGet varu + for 0 (pl - 1) (\i -> do + let xi = x + w * i `div` pl + xi1 = x + w * (i + 1) `div` pl + for 0 (floor $ 19 * val u !!! i) (\j -> line dc (pt (xi + 1) (20 - j)) (pt (xi1) (20 - j)) [penColor := colorplayer i]) + for (floor $ 18 * val u !!! i) 0 (\j -> line dc (pt (xi + 1) (20 - j)) (pt (xi1) (20 - j)) [penColor := setLum 0.4 $ colorplayer i]) + ) + drawRect dc r [brushKind := BrushTransparent] + line dc (pt x 20) (pt (x + w) 20) [] + + onTreeEvent :: EventTree -> IO () + onTreeEvent (TreeItemExpanding treeItem _veto) | treeItemIsOk treeItem = do + wxcBeginBusyCursor + children' <- treeCtrlGetChildren tc treeItem + mapM_ visualise children' + wxcEndBusyCursor + propagateEvent + onTreeEvent (TreeSelChanged treeItem _olditem) | treeItemIsOk treeItem = do + wxcBeginBusyCursor + selectRight treeItem + wxcEndBusyCursor + propagateEvent + onTreeEvent _ = propagateEvent + + visualise :: TreeItem -> IO () + visualise treeItem = do + c <- treeCtrlItemHasChildren tc treeItem + when (c == 0) $ giveBirth treeItem + updateThickness treeItem + updateImages treeItem + + selectRight :: TreeItem -> IO () + selectRight treeItem = do + updateRight treeItem + t <- varGet varu + staticBitmapSetBitmap bPlayer (logos !!! player t) + when (movesnr t == 0) $ staticBitmapSetBitmap bPlayer (if any (== 1) (val t) then winner else leeg) + repaint pBoard + + updateRight :: TreeItem -> IO () + updateRight treeItem = do + t <- gametree treeItem + varSet varu t + set tMind [text := "complete depth: " ++ show (mind t)] + set tMaxd [text := "maximum depth: " ++ show (maxd t)] + set tVolume [text := "volume: " ++ show (volume t)] + repaint pValue + + bClose' :: IO () + bClose' = close f + + bUpdatePath' :: [Int] -> IO () + bUpdatePath' path' = do + root <- treeCtrlGetRootItem tc + updatePath root path' + where + updatePath :: TreeItem -> [Int] -> IO () + updatePath treeItem path'' = do + updateThickness treeItem + updateImages treeItem + ifIO (treeCtrlIsSelected tc treeItem) $ updateRight treeItem + ifIO (treeCtrlIsExpanded tc treeItem) $ case path'' of + (i:is) -> do cs <- treeCtrlGetChildren tc treeItem + updatePath (cs !! i) is + [] -> return () + + bRefresh' :: IO () + bRefresh' = do + treeCtrlDeleteAllItems tc +--{ root <- treeCtrlAddRoot tc "current situation" 5 (-1) objectNull + root <- treeCtrlAddRoot tc "current situation" 12 12 objectNull + treeCtrlSetItemClientData tc root (return ()) [] + giveBirth root + updateThickness root + updateImages root + treeCtrlSelectItem tc root + selectRight root + + giveBirth :: TreeItem -> IO () + giveBirth treeItem = do + movs <- getData treeItem + t <- gametree treeItem + for 0 (movesnr t - 1) (\i -> do + let -- u = shear i t + m = showmove pr (player t) (state t) i +--{ jtem <- treeCtrlAppendItem tc treeItem (show i ++ " (" ++ m ++ ")") (player t) (-1) objectNull + jtem <- treeCtrlAppendItem tc treeItem (show i ++ " (" ++ m ++ ")") (-1) (-1) objectNull + treeCtrlSetItemClientData tc jtem (return ()) (movs ++ [i]) + updateThickness jtem + ) + treeCtrlSetItemHasChildren tc treeItem (movesnr t > 0) + + updateThickness :: TreeItem -> IO () + updateThickness treeItem = do + t <- gametree treeItem + let itemcolor | filled t = black + | otherwise = grey + treeCtrlSetItemTextColour tc treeItem itemcolor + treeCtrlSetItemBold tc treeItem (closed t) + + updateImages :: TreeItem -> IO () + updateImages treeItem = do + t <- gametree treeItem + c <- treeCtrlItemHasChildren tc treeItem + cs <- treeCtrlGetChildren tc treeItem + when (c > 0) $ for 0 (movesnr t - 1) (\i -> do + let offset | i `elem` best t = 6 + | otherwise = 0 + setImage (cs !! i) (offset + player t) + ) + + setImage :: TreeItem -> Int -> IO () + setImage treeItem i = do + j <- treeCtrlGetItemImage tc treeItem 0 --{ wxTreeItemIcon_Normal + when (i /= j) $ do + treeCtrlSetItemImage tc treeItem i 0 --{ wxTreeItemIcon_Normal + treeCtrlSetItemImage tc treeItem i 1 --{ wxTreeItemIcon_Selected +--{ treeCtrlSetItemImage tc treeItem i 2 --{ wxTreeItemIcon_Expanded +--{ treeCtrlSetItemImage tc treeItem i 3 --{ wxTreeItemIcon_SelectedExpanded + +-- gametree :: TreeItem -> IO (Tree g) + gametree treeItem = do + t <- varGet vart + movs <- getData treeItem + return $ gametree_ movs t + where +-- gametree_ :: [Int] -> Tree g -> Tree g + gametree_ (i:is) t | i >= 0 && i < movesnr t = gametree_ is $ shear i t + gametree_ _ t = t + + + playerinput :: Int -> IO () + playerinput i = do + info $ "brain moverequest: " ++ show i + treeItem <- treeCtrlGetSelection tc + t <- gametree treeItem + cs <- treeCtrlGetChildren tc treeItem + when (0 <= i && i < movesnr t) $ do + treeCtrlExpand tc treeItem + treeCtrlSelectItem tc (cs !! i) + + {--== MODIFICATION PHASE ==--} + + board pBoard pr varu False playerinput + + bRefresh' +-- setImages True + setImages False + + + varSet varb $ Brain bClose' bUpdatePath' bRefresh' + + set mGame [ text := "&Game" ] + set iNew [ text := "&New Game\tCtrl+N" , help := "Start a new game" , on command := newg ] + set iQuit [ help := "Quit the application" , on command := close mdiparent ] + set mBrain [ text := "&Brain" ] + set iClose [ text := "&Close\tCtrl+C" , help := "Close the brain for " ++ gamename , on command := close f ] + set iMini [ text := "&Minimal\tCtrl+M" , help := "Minimize the brain size" , on command := onmini ] + set iLarge [ text := "&Large Icons\tCtrl+L" , checkable := True, checked := False , on command ::= (>>= setImages) . flip get checked ] + set iHelp [ text := "&Contents" , help := "Show the contents of GeBoP" , on command := html f "help\\index.html" ] + set iBrain [ text := "The &Brain" , help := "Shows help about the brain viewer" , on command := html f "help\\brain.html" ] + set iAbout [ help := "Information about this program" , on command := infoDialog f "About GeBoP" about ] + + set tc [ on treeEvent := onTreeEvent + ] + + set pLeft [ layout := fill $ widget tc + ] + + set pValue [ clientSize := Size 40 40 + , on paint := onpaintValue + , on resize ::= repaint + ] + + set pInfo [ layout := fill $ column 4 $ + [ widget tMind + , widget tMaxd + , widget tVolume + ] + ] + + set pBoard [ on resize ::= repaint + ] + + set pRight [ layout := margin 4 $ column 4 $ + [ row 4 [widget bPlayer, fill $ widget pValue] + , hfill $ widget pInfo + , fill $ widget pBoard + ] + ] + + set f [ text := gamename ++ " Brain" + , menuBar := [mGame, mBrain, mHelp] + , layout := fill $ vsplit sw 4 200 (widget pLeft) (widget pRight) + , picture := "brain.ico" + , clientSize := Size 480 360 + , on closing :~ (varSet varb emptyBrain >>) + ] + +colorplayer :: Int -> Color +colorplayer 0 = hsl 0.66 1 0.5 +colorplayer 1 = hsl 0 1 0.5 +colorplayer 2 = hsl 0.33 1 0.5 +colorplayer 3 = hsl 0.82 1 0.5 +colorplayer 4 = hsl 0.11 0.7 0.5 +colorplayer 5 = hsl 0 0 0.5 +colorplayer _ = hsl 0 0 0 + +nameplayer :: Int -> String +nameplayer 0 = "blue" +nameplayer 1 = "red" +nameplayer 2 = "green" +nameplayer 3 = "purple" +nameplayer 4 = "brown" +nameplayer 5 = "grey" +nameplayer _ = "black" + +info :: String -> IO () +info s = do + putStrLn $ "[" ++ s ++ "]" + return () + +html :: Window a -> FilePath -> IO () +html w f = do + d <- dialog w [text := "Help"] + -- w <- htmlWindowCreate d (-1) (rect (point 0 0) (size 640 480)) 0 [] + w' <- htmlWindowCreate d (-1) (rect (point 0 0) (Size 640 480)) 0 [] + _ <- htmlWindowLoadPage w' f + set d [layout := widget w', visible := True] + return () + +about :: String +about = "GeBoP - General Boardgames Player" + ++ "\nversion " ++ version + ++ "\n" + ++ "\nby Maarten Löffler" + ++ "\nmloffler@cs.uu.nl" + ++ "\n" + ++ "\nGeBoP was written using wxHaskell" + +bitmap :: String -> IO (Bitmap ()) +bitmap name' = do bmp <- bitmapCreateLoad ("images\\" ++ name' ++ ".bmp") wxBITMAP_TYPE_ANY + mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY + bitmapSetDepth mskbmp 1 + msk <- maskCreate mskbmp + bitmapSetMask bmp msk + return bmp + +bitmapImageList :: ImageList () -> String -> IO () +bitmapImageList il name' = do + bmp <- bitmapCreateLoad ("images\\" ++ name' ++ ".bmp") wxBITMAP_TYPE_ANY + mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY + bitmapSetDepth mskbmp 1 + _ <- imageListAddBitmap il bmp mskbmp + return () + +bitmapHighImageList :: ImageList () -> String -> IO () +bitmapHighImageList il name' = do + bmp <- bitmapCreateLoad ("images\\high_" ++ name' ++ ".bmp") wxBITMAP_TYPE_ANY + mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY + bitmapSetDepth mskbmp 1 + _ <- imageListAddBitmap il bmp mskbmp + return ()
GeBoP.cabal view
@@ -3,13 +3,13 @@ Description: The games: Ataxx, Bamp, Halma, Hez, Kram, Nim, Reversi, TicTacToe, and Zenix Homepage: http://www.haskell.org/haskellwiki/GeBoP-Version: 1.7.4+Version: 1.7.4.1 License: BSD3 License-file: LICENSE.txt Author: Maarten Löffler Maintainer: wxHaskell developer mailing list <wxhaskell-devel@lists.sourceforge.net> Stability: Stable-Cabal-Version: >= 1.2+Cabal-Version: >= 1.18 Build-type: Simple Category: Game Tested-with: GHC == 7.6.3, GHC == 7.8.3@@ -108,14 +108,19 @@ help/rules_tictactoe.html, help/rules_zenix.html +Source-repository head+ Type: git+ Location: git://github.com/wxHaskell/GeBoP.git+ Executable gebop+ Default-language: Haskell2010 Build-Depends:- array >= 0.4 && < 0.6,- base >= 4.5 && < 4.8, - directory >= 1.1 && < 1.3,- random >= 1.0 && < 1.1,+ array >= 0.4,+ base >= 4.5 && < 5, + directory >= 1.1,+ random >= 1.0, wx >= 0.11,- wxcore >= 0.11+ wxcore Main-Is: Main.hs GHC-Options: -Wall -optc-static-libgcc
Reversi.hs view
@@ -1,146 +1,146 @@------------------ Reversi ------------------module Reversi (Reversi, reversi) where--import Game-import Data.Array-import Graphics.UI.WX hiding (border)-import Graphics.UI.WXCore-import Tools--data Reversi = Reversi (Array (Int, Int) (Maybe Player)) deriving (Eq, Show)--reversi :: Reversi-reversi = undefined--instance Game Reversi where-- name _ = "reversi"-- standard _ = Properties { players = 2, boardsize = 8, human = [True, False] }-- possible _ = PropertyRange { playersrange = [2], boardsizerange = [6, 8, 10] }-- new pr = let s = boardsize pr- h = s `div` 2- in Reversi $ array ((0, 0), (s - 1, s - 1))- [((x, y), Nothing) | x <- [0 .. s - 1], y <- [0 .. s - 1]]- // [ ((h - 1, h - 1), Just 0)- , ((h , h - 1), Just 1)- , ((h - 1, h ), Just 1)- , ((h , h ), Just 0)- ]- - moves pr p (Reversi s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s)-- showmove pr p (Reversi s) i = case allMoves (boardsize pr) p s !! i- of Nothing -> "skip turn"- Just (x, y) -> "abcdefghij" !! x : show (boardsize pr - y)- - value pr p (Reversi s) - | null $ moves pr p (Reversi s) = (\i -> [i, -i]) $ (fromInteger . toInteger) $ signum $ count $ elems s- | otherwise = (\i -> let f = (fromInteger . toInteger) i / (fromInteger . toInteger) (sqr $ boardsize pr) in [f, -f]) $ count $ elems s- where- count :: [Maybe Player] -> Int- count [] = 0- count (Nothing : fs) = count fs- count (Just 0 : fs) = 1 + count fs- count (Just 1 : fs) = -1 + count fs- count _ = error "value: Unexpected value"-- board p pr vart ia move' = do-- marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY- varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero-- let - - onpaint :: DC () -> Rect -> IO ()- onpaint dc r = do- t <- varGet vart- let Reversi st = state t- bsz = boardsize pr- b <- border dc (bsz, bsz)- let g = grate r b (bsz, bsz) (Size 1 1)- varSet varg g- tileBitmap dc r marble- for 0 (bsz - 1) (\i -> do- drawTextRect dc [['A' ..] !! i] $ edge g (i, -1)- drawTextRect dc [['A' ..] !! i] $ edge g (i, bsz)- drawTextRect dc (show (bsz - i)) $ edge g ( -1, i)- drawTextRect dc (show (bsz - i)) $ edge g (bsz, i)- )- drawGrate dc g [brushKind := BrushTransparent]- for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->- case st ! (i, j) of Just p' -> drawPiece p' dc $ field g (i, j)- Nothing -> return ()- ))- if human pr !! player t && allMoves (boardsize pr) (player t) st == [Nothing]- then wait p 1 $ do- when ia $ infoDialog p "You can't move!" "You have to skip this turn, since there are no possible moves."- move' 0- else return ()-- onclick :: Point -> IO ()- onclick point' = do - t <- varGet vart- g <- varGet varg- let Reversi st = state t- n = Just $ locate g point' - case lookup n $ zip (allMoves (boardsize pr) (player t) st) [0..] of- Nothing -> return ()- Just i -> move' i-- set p [ on click := onclick- , on paint := onpaint- , on resize ::= repaint- ]--drawPiece :: Player -> DC () -> Rect -> IO ()-drawPiece p dc (Rect x y w h) = do- case p of 0 -> set dc [brushColor := rgb 96 16 (255 :: Int) ]- 1 -> set dc [brushColor := rgb 192 64 (16 :: Int) ]- _ -> set dc [brushColor := white]- circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) []--(+-) :: Num a => (a, a) -> (a, a) -> (a, a)-(a, b) +- (c, d) = (a + c, b + d)--allMoves :: Int -> Player -> Array (Int, Int) (Maybe Player) -> [Maybe (Int, Int)]-allMoves _bsz p s - | (null $ valid p s) && (not $ null $ valid (1 - p) s) = [Nothing]- | otherwise = map Just $ valid p s- where- valid :: Player -> Array (Int, Int) (Maybe Player) -> [(Int, Int)]- valid p' s' = filter (\xy -> or $ map (scan xy) dirs) . filter ((== Nothing) . (s' !)) $ indices s' - where- dirs :: [(Int, Int)]- dirs = [(x, y) | x <- [-1 .. 1], y <- [-1 .. 1]]- scan :: (Int, Int) -> (Int, Int) -> Bool- scan xy dxy = check (xy +- dxy) (Just $ 1 - p') && scan1 (xy +- dxy) dxy- scan1 :: (Int, Int) -> (Int, Int) -> Bool- scan1 xy dxy = check (xy +- dxy) (Just p')- || (check (xy +- dxy) (Just $ 1 - p') && scan1 (xy +- dxy) dxy)- check :: (Int, Int) -> Maybe Player -> Bool- check m f | not $ inRange (bounds s') m = False- | otherwise = s' ! m == f--move :: Int -> Maybe (Int, Int) -> (Player, Reversi) -> (Player, Reversi)-move _bsz (Just m) (p, Reversi s) = (1 - p, Reversi $ s // ((m, Just p) : concatMap (scan m) dirs))- where- dirs :: [(Int, Int)]- dirs = [(x, y) | x <- [-1 .. 1], y <- [-1 .. 1]]- scan :: (Int, Int) -> (Int, Int) -> [((Int, Int), Maybe Player)]- scan xy dxy | check (xy +- dxy) (Just $ 1 - p) = scan1 (xy +- dxy) dxy [(xy +- dxy, Just p)]- | otherwise = []- scan1 :: (Int, Int) -> (Int, Int) -> [((Int, Int), Maybe Player)] -> [((Int, Int), Maybe Player)]- scan1 xy dxy cs | check (xy +- dxy) (Just p) = cs- | check (xy +- dxy) (Just $ 1 - p) = scan1 (xy +- dxy) dxy $ (xy +- dxy, Just p) : cs- | otherwise = []- check :: (Int, Int) -> Maybe Player -> Bool- check m' f | not $ inRange (bounds s) m' = False- | otherwise = s ! m' == f-move _ Nothing (p, rs) = (1 - p, rs)+ +------------- +-- Reversi -- +------------- + +module Reversi (Reversi, reversi) where + +import Game +import Data.Array +import Graphics.UI.WX hiding (border) +import Graphics.UI.WXCore +import Tools + +data Reversi = Reversi (Array (Int, Int) (Maybe Player)) deriving (Eq, Show) + +reversi :: Reversi +reversi = undefined + +instance Game Reversi where + + name _ = "reversi" + + standard _ = Properties { players = 2, boardsize = 8, human = [True, False] } + + possible _ = PropertyRange { playersrange = [2], boardsizerange = [6, 8, 10] } + + new pr = let s = boardsize pr + h = s `div` 2 + in Reversi $ array ((0, 0), (s - 1, s - 1)) + [((x, y), Nothing) | x <- [0 .. s - 1], y <- [0 .. s - 1]] + // [ ((h - 1, h - 1), Just 0) + , ((h , h - 1), Just 1) + , ((h - 1, h ), Just 1) + , ((h , h ), Just 0) + ] + + moves pr p (Reversi s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s) + + showmove pr p (Reversi s) i = case allMoves (boardsize pr) p s !! i + of Nothing -> "skip turn" + Just (x, y) -> "abcdefghij" !! x : show (boardsize pr - y) + + value pr p (Reversi s) + | null $ moves pr p (Reversi s) = (\i -> [i, -i]) $ (fromInteger . toInteger) $ signum $ count $ elems s + | otherwise = (\i -> let f = (fromInteger . toInteger) i / (fromInteger . toInteger) (sqr $ boardsize pr) in [f, -f]) $ count $ elems s + where + count :: [Maybe Player] -> Int + count [] = 0 + count (Nothing : fs) = count fs + count (Just 0 : fs) = 1 + count fs + count (Just 1 : fs) = -1 + count fs + count _ = error "value: Unexpected value" + + board p pr vart ia move' = do + + marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY + varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero + + let + + onpaint :: DC () -> Rect -> IO () + onpaint dc r = do + t <- varGet vart + let Reversi st = state t + bsz = boardsize pr + b <- border dc (bsz, bsz) + let g = grate r b (bsz, bsz) (Size 1 1) + varSet varg g + tileBitmap dc r marble + for 0 (bsz - 1) (\i -> do + drawTextRect dc [['A' ..] !! i] $ edge g (i, -1) + drawTextRect dc [['A' ..] !! i] $ edge g (i, bsz) + drawTextRect dc (show (bsz - i)) $ edge g ( -1, i) + drawTextRect dc (show (bsz - i)) $ edge g (bsz, i) + ) + drawGrate dc g [brushKind := BrushTransparent] + for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j -> + case st ! (i, j) of Just p' -> drawPiece p' dc $ field g (i, j) + Nothing -> return () + )) + if human pr !! player t && allMoves (boardsize pr) (player t) st == [Nothing] + then wait p 1 $ do + when ia $ infoDialog p "You can't move!" "You have to skip this turn, since there are no possible moves." + move' 0 + else return () + + onclick :: Point -> IO () + onclick point' = do + t <- varGet vart + g <- varGet varg + let Reversi st = state t + n = Just $ locate g point' + case lookup n $ zip (allMoves (boardsize pr) (player t) st) [0..] of + Nothing -> return () + Just i -> move' i + + set p [ on click := onclick + , on paint := onpaint + , on resize ::= repaint + ] + +drawPiece :: Player -> DC () -> Rect -> IO () +drawPiece p dc (Rect x y w h) = do + case p of 0 -> set dc [brushColor := rgb 96 16 (255 :: Int) ] + 1 -> set dc [brushColor := rgb 192 64 (16 :: Int) ] + _ -> set dc [brushColor := white] + circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [] + +(+-) :: Num a => (a, a) -> (a, a) -> (a, a) +(a, b) +- (c, d) = (a + c, b + d) + +allMoves :: Int -> Player -> Array (Int, Int) (Maybe Player) -> [Maybe (Int, Int)] +allMoves _bsz p s + | (null $ valid p s) && (not $ null $ valid (1 - p) s) = [Nothing] + | otherwise = map Just $ valid p s + where + valid :: Player -> Array (Int, Int) (Maybe Player) -> [(Int, Int)] + valid p' s' = filter (\xy -> or $ map (scan xy) dirs) . filter ((== Nothing) . (s' !)) $ indices s' + where + dirs :: [(Int, Int)] + dirs = [(x, y) | x <- [-1 .. 1], y <- [-1 .. 1]] + scan :: (Int, Int) -> (Int, Int) -> Bool + scan xy dxy = check (xy +- dxy) (Just $ 1 - p') && scan1 (xy +- dxy) dxy + scan1 :: (Int, Int) -> (Int, Int) -> Bool + scan1 xy dxy = check (xy +- dxy) (Just p') + || (check (xy +- dxy) (Just $ 1 - p') && scan1 (xy +- dxy) dxy) + check :: (Int, Int) -> Maybe Player -> Bool + check m f | not $ inRange (bounds s') m = False + | otherwise = s' ! m == f + +move :: Int -> Maybe (Int, Int) -> (Player, Reversi) -> (Player, Reversi) +move _bsz (Just m) (p, Reversi s) = (1 - p, Reversi $ s // ((m, Just p) : concatMap (scan m) dirs)) + where + dirs :: [(Int, Int)] + dirs = [(x, y) | x <- [-1 .. 1], y <- [-1 .. 1]] + scan :: (Int, Int) -> (Int, Int) -> [((Int, Int), Maybe Player)] + scan xy dxy | check (xy +- dxy) (Just $ 1 - p) = scan1 (xy +- dxy) dxy [(xy +- dxy, Just p)] + | otherwise = [] + scan1 :: (Int, Int) -> (Int, Int) -> [((Int, Int), Maybe Player)] -> [((Int, Int), Maybe Player)] + scan1 xy dxy cs | check (xy +- dxy) (Just p) = cs + | check (xy +- dxy) (Just $ 1 - p) = scan1 (xy +- dxy) dxy $ (xy +- dxy, Just p) : cs + | otherwise = [] + check :: (Int, Int) -> Maybe Player -> Bool + check m' f | not $ inRange (bounds s) m' = False + | otherwise = s ! m' == f +move _ Nothing (p, rs) = (1 - p, rs)
changelog.txt view
@@ -1,4 +1,17 @@ +2015-01-29++Version 1.7.4.1+ Changes in .cabal file+ - Removed upper limits for versions of Haskell Platform packages (except base)+ - Added address of repository+ - Removed lower limit for wxcore, as the wxcore version is defined by wx+ - Added "Default-language: Haskell2010"+ Other changes+ - Added FlexibleContexts pragma to GUI.hs, to satisfy GHC 7.10+ - Removed Byte Order Mark from GUI.hs, to satisfy GHC 7.10+ + 2014-08-13 Version 1.7.4