diff --git a/GUI.hs b/GUI.hs --- a/GUI.hs +++ b/GUI.hs @@ -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 () diff --git a/GeBoP.cabal b/GeBoP.cabal --- a/GeBoP.cabal +++ b/GeBoP.cabal @@ -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 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 diff --git a/Reversi.hs b/Reversi.hs --- a/Reversi.hs +++ b/Reversi.hs @@ -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) diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -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