GeBoP-1.7: GUI.hs
{-# OPTIONS -fglasgow-exts #-}
---------
-- GUI --
---------
module GUI (gui, version) where
import Game
-- import Graphics.UI.WX
import Graphics.UI.WX hiding (bitmap)
import Graphics.UI.WXCore
import Random
import Char
import Tools
import List
version :: String
version = "1.7"
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
{--== DEFENITION 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 []
{--== DEFENITION 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
onpaintplayer :: Int -> DC () -> Rect -> IO ()
onpaintplayer i dc r@(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 ^ 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 [ clientSize := sz 60 20
, 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 ==--}
f <- mdiChildFrame mdiparent []
sw <- splitterWindow f []
pLeft <- panel sw []
pRight <- panel sw []
pBoard <- panel pRight []
pValue <- panel pRight []
pInfo <- panel pRight []
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 []
logos <- mapM (bitmap.nameplayer) [0 .. 5]
winner <- bitmap "winner"
leeg <- bitmap "empty"
bPlayer <- staticBitmapCreate pRight (-1) (logos !!! 0) rectNull (-1)
tPlayer <- staticText pRight []
tMind <- staticText pInfo []
tMaxd <- staticText pInfo []
tVolume <- staticText pInfo []
tc <- treeCtrl pLeft []
g <- varGet vart >>= return . state
varu <- varCopy vart
{--== DEFENITION PHASE ==--}
let
gamename :: String
gamename = (\(c : cs) -> toUpper c : cs) $ name g
getData :: TreeItem -> IO [Int]
getData item = do
mmovs <- unsafeTreeCtrlGetItemClientData tc item
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 item veto) | treeItemIsOk item = do
wxcBeginBusyCursor
children <- treeCtrlGetChildren tc item
mapM_ visualise children
wxcEndBusyCursor
propagateEvent
onTreeEvent (TreeSelChanged item olditem) | treeItemIsOk item = do
wxcBeginBusyCursor
selectRight item
wxcEndBusyCursor
propagateEvent
onTreeEvent _ = propagateEvent
visualise :: TreeItem -> IO ()
visualise item = do
c <- treeCtrlItemHasChildren tc item
when (c == 0) $ giveBirth item
updateThickness item
updateImages item
selectRight :: TreeItem -> IO ()
selectRight item = do
updateRight item
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 item = do
t <- gametree item
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 item path = do
updateThickness item
updateImages item
ifIO (treeCtrlIsSelected tc item) $ updateRight item
ifIO (treeCtrlIsExpanded tc item) $ case path of
(i:is) -> do cs <- treeCtrlGetChildren tc item
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 item = do
movs <- getData item
t <- gametree item
for 0 (movesnr t - 1) (\i -> do
let u = shear i t
m = showmove pr (player t) (state t) i
--{ jtem <- treeCtrlAppendItem tc item (show i ++ " (" ++ m ++ ")") (player t) (-1) objectNull
jtem <- treeCtrlAppendItem tc item (show i ++ " (" ++ m ++ ")") (-1) (-1) objectNull
treeCtrlSetItemClientData tc jtem (return ()) (movs ++ [i])
updateThickness jtem
)
treeCtrlSetItemHasChildren tc item (movesnr t > 0)
updateThickness :: TreeItem -> IO ()
updateThickness item = do
t <- gametree item
let itemcolor | filled t = black
| otherwise = grey
treeCtrlSetItemTextColour tc item itemcolor
treeCtrlSetItemBold tc item (closed t)
updateImages :: TreeItem -> IO ()
updateImages item = do
t <- gametree item
c <- treeCtrlItemHasChildren tc item
cs <- treeCtrlGetChildren tc item
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 item i = do
j <- treeCtrlGetItemImage tc item 0 --{ wxTreeItemIcon_Normal
when (i /= j) $ do
treeCtrlSetItemImage tc item i 0 --{ wxTreeItemIcon_Normal
treeCtrlSetItemImage tc item i 1 --{ wxTreeItemIcon_Selected
--{ treeCtrlSetItemImage tc item i 2 --{ wxTreeItemIcon_Expanded
--{ treeCtrlSetItemImage tc item i 3 --{ wxTreeItemIcon_SelectedExpanded
-- gametree :: TreeItem -> IO (Tree g)
gametree item = do
t <- varGet vart
movs <- getData item
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
item <- treeCtrlGetSelection tc
t <- gametree item
cs <- treeCtrlGetChildren tc item
when (0 <= i && i < movesnr t) $ do
treeCtrlExpand tc item
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 = "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 ()