GeBoP 1.7.2 → 1.7.3
raw patch · 40 files changed
+3575/−3473 lines, 40 filesdep +arraydep +randomdep −haskell98dep ~basedep ~directorydep ~wxsetup-changed
Dependencies added: array, random
Dependencies removed: haskell98
Dependency ranges changed: base, directory, wx, wxcore
Files
- Ataxx.hs +186/−186
- Bamp.hs +182/−182
- GUI.hs +793/−782
- Game.hs +165/−165
- GeBoP.cabal +125/−123
- HSL.hs +94/−94
- Halma.hs +278/−278
- Hex.hs +180/−180
- Inf.hs +55/−55
- Kram.hs +129/−129
- LICENSE.txt +23/−23
- Main.hs +44/−44
- Nim.hs +81/−81
- Reversi.hs +146/−147
- Setup.lhs +5/−5
- TicTacToe.hs +127/−114
- Tools.hs +228/−228
- Zenix.hs +198/−198
- changelog.txt +33/−22
- help/brain.html +70/−32
- help/index.html +38/−38
- help/info_ataxx.html +20/−20
- help/info_bamp.html +24/−19
- help/info_halma.html +19/−19
- help/info_hex.html +15/−15
- help/info_kram.html +15/−15
- help/info_nim.html +18/−15
- help/info_reversi.html +17/−17
- help/info_tictactoe.html +17/−17
- help/info_zenix.html +13/−13
- help/rules_ataxx.html +21/−15
- help/rules_bamp.html +27/−19
- help/rules_halma.html +19/−19
- help/rules_hex.html +19/−19
- help/rules_kram.html +20/−20
- help/rules_nim.html +16/−15
- help/rules_reversi.html +20/−20
- help/rules_tictactoe.html +17/−17
- help/rules_zenix.html +24/−19
- readme.txt +54/−54
Ataxx.hs view
@@ -1,186 +1,186 @@- -------------- --- Ataxx -- -------------- - -module Ataxx (Ataxx, ataxx) where - -import Game -import Array --- import Graphics.UI.WX -import Graphics.UI.WX hiding (border, point) -import Graphics.UI.WXCore hiding (point) -import Tools - -data Ataxx = Ataxx (Array (Int, Int) (Maybe Player)) deriving (Eq, Show) - -type AtaxxMove = Maybe ((Int, Int), (Int, Int)) - -ataxx :: Ataxx -ataxx = undefined - -instance Game Ataxx where - - name _ = "ataxx" - - standard _ = Properties { players = 2, boardsize = 7, human = [True, False] } - - possible _ = PropertyRange { playersrange = [2], boardsizerange = [5 .. 9] } - - new pr = let s = boardsize pr - in Ataxx $ array ((0, 0), (s - 1, s - 1)) - [((x, y), Nothing) | x <- [0 .. s - 1], y <- [0 .. s - 1]] - // [ ((0 , 0 ), Just 0) - , ((0 , s - 1), Just 1) - , ((s - 1, 0 ), Just 1) - , ((s - 1, s - 1), Just 0) - ] - - moves pr p (Ataxx s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s) - - showmove pr p (Ataxx s) i = case allMoves (boardsize pr) p s !! i - of Nothing -> "skip turn" - Just ((x1, y1), (x2, y2)) -> "abcdefghi" !! x1 : show (boardsize pr - y1) - ++ "-" ++ "abcdefghi" !! x2 : show (boardsize pr - y2) - - value pr p (Ataxx s) - | null $ moves pr p (Ataxx 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 - vare <- varCreate (Nothing :: Maybe (Int, Int)) - - let - - onpaint :: DC () -> Rect -> IO () - onpaint dc r = do - t <- varGet vart - e <- varGet vare - let Ataxx 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 () - )) - case e of - Nothing -> return () - Just (i, j) -> drawBrightPiece dc $ field g (i, j) - 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 Ataxx st = state t - n = locate g point - when (inRange (bounds st) n) $ when (st ! n == Just (player t)) $ do - varSet vare $ Just n - repaint p - - onunclick :: Point -> IO () - onunclick point = do - t <- varGet vart - g <- varGet varg - e <- varGet vare - case e of - Nothing -> return () - Just m -> do - let Ataxx st = state t - n = locate g point - varSet vare Nothing - repaint p - case lookup (Just (m, n)) $ zip (allMoves (boardsize pr) (player t) st) [0..] of - Nothing -> return () - Just i -> move' i - - set p [ on click := onclick - , on unclick := onunclick - , on paint := onpaint - , on resize ::= repaint - ] - -allMoves :: Int -> Player -> Array (Int, Int) (Maybe Player) -> [AtaxxMove] -allMoves _bsz p s - | (null $ valid p s) && (not $ null $ valid (1 - p) s) = [Nothing] - | dead (1 - p) (elems s) = [] - | otherwise = map (Just) $ valid p s - where - valid :: Player -> Array (Int, Int) (Maybe Player) -> [((Int, Int), (Int, Int))] - valid p' s' = concatMap complete $ filter ((== Just p') . (s' !)) $ indices s' - where - complete :: (Int, Int) -> [((Int, Int), (Int, Int))] - complete xy = zip (repeat xy) (from xy) - - from :: (Int, Int) -> [(Int, Int)] - from xy = filter (flip check Nothing) $ map (xy +-) $ grows ++ jumps - - check :: (Int, Int) -> Maybe Player -> Bool - check m f | not $ inRange (bounds s) m = False - | otherwise = s ! m == f - - dead :: Player -> [Maybe Player] -> Bool - dead p' (Just q : fs) = p' /= q && dead p' fs - dead p' (Nothing : fs) = dead p' fs - dead _ [] = True - -move :: Int -> AtaxxMove -> (Player, Ataxx) -> (Player, Ataxx) -move _bsz (Just (f, t)) (p, Ataxx s) = (1 - p, Ataxx $ s // (phase1 ++ phase2)) - where - phase1 :: [((Int, Int), Maybe Player)] - phase1 | t `elem` map (+- f) jumps = [(f, Nothing), (t, Just p)] - | otherwise = [ (t, Just p)] - - phase2 :: [((Int, Int), Maybe Player)] - phase2 = zip (filter (flip check $ Just $ 1 - p) $ map (+- t) grows) $ repeat $ Just p - - 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) - -grows :: [(Int, Int)] -grows = concat [[(x, 1), (-x, -1), (-1, x), (1, -x)] | x <- [ 0 .. 1]] - -jumps :: [(Int, Int)] -jumps = concat [[(x, 2), (-x, -2), (-2, x), (2, -x)] | x <- [-1 .. 2]] - -(+-) :: Num a => (a, a) -> (a, a) -> (a, a) -(a, b) +- (c, d) = (a + c, b + d) - -drawPiece :: Player -> DC () -> Rect -> IO () -drawPiece p dc (Rect x y w h) = do - case p of 0 -> set dc [brushColor := rgb 32 96 (192 :: Int)] - 1 -> set dc [brushColor := rgb 192 96 (32 :: Int)] - _ -> set dc [brushColor := white] - circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [] - -drawBrightPiece :: DC () -> Rect -> IO () -drawBrightPiece dc (Rect x y w h) = do - set dc [penWidth := 2, penColor := yellow, brushKind := BrushTransparent] - circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [] - ++-------------+-- Ataxx --+-------------++module Ataxx (Ataxx, ataxx) where++import Game+import Data.Array+-- import Graphics.UI.WX+import Graphics.UI.WX hiding (border, point)+import Graphics.UI.WXCore hiding (point)+import Tools++data Ataxx = Ataxx (Array (Int, Int) (Maybe Player)) deriving (Eq, Show)++type AtaxxMove = Maybe ((Int, Int), (Int, Int))++ataxx :: Ataxx+ataxx = undefined++instance Game Ataxx where++ name _ = "ataxx"++ standard _ = Properties { players = 2, boardsize = 7, human = [True, False] }+ + possible _ = PropertyRange { playersrange = [2], boardsizerange = [5 .. 9] }+ + new pr = let s = boardsize pr+ in Ataxx $ array ((0, 0), (s - 1, s - 1))+ [((x, y), Nothing) | x <- [0 .. s - 1], y <- [0 .. s - 1]]+ // [ ((0 , 0 ), Just 0)+ , ((0 , s - 1), Just 1)+ , ((s - 1, 0 ), Just 1)+ , ((s - 1, s - 1), Just 0)+ ]+ + moves pr p (Ataxx s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s)++ showmove pr p (Ataxx s) i = case allMoves (boardsize pr) p s !! i+ of Nothing -> "skip turn"+ Just ((x1, y1), (x2, y2)) -> "abcdefghi" !! x1 : show (boardsize pr - y1)+ ++ "-" ++ "abcdefghi" !! x2 : show (boardsize pr - y2)+ + value pr p (Ataxx s) + | null $ moves pr p (Ataxx 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+ vare <- varCreate (Nothing :: Maybe (Int, Int))++ let + + onpaint :: DC () -> Rect -> IO ()+ onpaint dc r = do+ t <- varGet vart+ e <- varGet vare+ let Ataxx 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 ()+ ))+ case e of+ Nothing -> return ()+ Just (i, j) -> drawBrightPiece dc $ field g (i, j)+ 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 Ataxx st = state t+ n = locate g point + when (inRange (bounds st) n) $ when (st ! n == Just (player t)) $ do+ varSet vare $ Just n+ repaint p++ onunclick :: Point -> IO ()+ onunclick point = do + t <- varGet vart+ g <- varGet varg+ e <- varGet vare+ case e of+ Nothing -> return ()+ Just m -> do+ let Ataxx st = state t+ n = locate g point + varSet vare Nothing+ repaint p+ case lookup (Just (m, n)) $ zip (allMoves (boardsize pr) (player t) st) [0..] of+ Nothing -> return ()+ Just i -> move' i++ set p [ on click := onclick+ , on unclick := onunclick+ , on paint := onpaint+ , on resize ::= repaint+ ]++allMoves :: Int -> Player -> Array (Int, Int) (Maybe Player) -> [AtaxxMove]+allMoves _bsz p s+ | (null $ valid p s) && (not $ null $ valid (1 - p) s) = [Nothing]+ | dead (1 - p) (elems s) = []+ | otherwise = map (Just) $ valid p s+ where+ valid :: Player -> Array (Int, Int) (Maybe Player) -> [((Int, Int), (Int, Int))]+ valid p' s' = concatMap complete $ filter ((== Just p') . (s' !)) $ indices s'+ where+ complete :: (Int, Int) -> [((Int, Int), (Int, Int))]+ complete xy = zip (repeat xy) (from xy)++ from :: (Int, Int) -> [(Int, Int)]+ from xy = filter (flip check Nothing) $ map (xy +-) $ grows ++ jumps++ check :: (Int, Int) -> Maybe Player -> Bool+ check m f | not $ inRange (bounds s) m = False+ | otherwise = s ! m == f++ dead :: Player -> [Maybe Player] -> Bool+ dead p' (Just q : fs) = p' /= q && dead p' fs+ dead p' (Nothing : fs) = dead p' fs+ dead _ [] = True++move :: Int -> AtaxxMove -> (Player, Ataxx) -> (Player, Ataxx)+move _bsz (Just (f, t)) (p, Ataxx s) = (1 - p, Ataxx $ s // (phase1 ++ phase2))+ where + phase1 :: [((Int, Int), Maybe Player)]+ phase1 | t `elem` map (+- f) jumps = [(f, Nothing), (t, Just p)]+ | otherwise = [ (t, Just p)]++ phase2 :: [((Int, Int), Maybe Player)]+ phase2 = zip (filter (flip check $ Just $ 1 - p) $ map (+- t) grows) $ repeat $ Just p++ 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)++grows :: [(Int, Int)]+grows = concat [[(x, 1), (-x, -1), (-1, x), (1, -x)] | x <- [ 0 .. 1]]++jumps :: [(Int, Int)]+jumps = concat [[(x, 2), (-x, -2), (-2, x), (2, -x)] | x <- [-1 .. 2]]++(+-) :: Num a => (a, a) -> (a, a) -> (a, a)+(a, b) +- (c, d) = (a + c, b + d)++drawPiece :: Player -> DC () -> Rect -> IO ()+drawPiece p dc (Rect x y w h) = do+ case p of 0 -> set dc [brushColor := rgb 32 96 (192 :: Int)]+ 1 -> set dc [brushColor := rgb 192 96 (32 :: Int)]+ _ -> set dc [brushColor := white]+ circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) []++drawBrightPiece :: DC () -> Rect -> IO ()+drawBrightPiece dc (Rect x y w h) = do+ set dc [penWidth := 2, penColor := yellow, brushKind := BrushTransparent]+ circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) []+
Bamp.hs view
@@ -1,182 +1,182 @@- ----------- --- Bamp -- ----------- - -module Bamp (Bamp, bamp) where - -import Game -import Array -import Graphics.UI.WX hiding (border, point) -import Graphics.UI.WXCore hiding (point) -import Tools - -data BampField - = Empty - | Portal Player - | Piece Player - | Ball - deriving (Eq, Show) - -isPortal :: BampField -> Bool -isPortal (Portal _) = True -isPortal _ = False - -{- -isPiece :: BampField -> Bool -isPiece (Piece _) = True -isPiece _ = False --} - -data Bamp = Bamp (Array (Int, Int) BampField) deriving (Eq, Show) - -bamp :: Bamp -bamp = undefined - -instance Game Bamp where - - name _ = "bamp" - - standard _ = Properties { players = 4, boardsize = 8, human = [True, False, False, False] } - - possible _ = PropertyRange { playersrange = [4], boardsizerange = [6, 8 .. 12] } - - new pr = let s = boardsize pr - h = s `div` 2 - in Bamp $ array ((0, 0), (s - 1, s - 1)) - [((x, y), Empty) | x <- [0 .. s - 1], y <- [0 .. s - 1]] - // concat [[((0 , i), Piece 0), (( i, 0 ), Piece 0)] | i <- [0 .. h - 1]] - // concat [[((0 , h + i), Piece 1), (( i, s - 1), Piece 1)] | i <- [0 .. h - 1]] - // concat [[((s - 1, h + i), Piece 2), ((h + i, s - 1), Piece 2)] | i <- [0 .. h - 1]] - // concat [[((s - 1, i), Piece 3), ((h + i, 0 ), Piece 3)] | i <- [0 .. h - 1]] - // [((1 , 1 ), Ball )] -{-{ - // [ ((0 , 0 ), Portal 0) - , ((0 , s - 1), Portal 1) - , ((s - 1, s - 1), Portal 2) - , ((s - 1, 0 ), Portal 3) - , ((1 , 1 ), Ball ) - ] -}-} - moves pr p (Bamp s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s) - - showmove pr p (Bamp s) i = let (x, y) = allMoves (boardsize pr) p s !! i - in ['a' ..] !! x : show (boardsize pr - y) - - value pr p (Bamp s) - | null $ moves pr p (Bamp s) = let bsz = boardsize pr - in owner bsz (findBall s) |> 1 $ replicate 4 (-1) -{-{ - in case findBall s - of (x, y) | (x, y) == (0 , 0 ) -> [ 1, -1, -1, -1] - | (x, y) == (0 , bsz - 1) -> [-1, 1, -1, -1] - | (x, y) == (bsz - 1, bsz - 1) -> [-1, -1, 1, -1] - | (x, y) == (bsz - 1, 0 ) -> [-1, -1, -1, 1] - _ -> [0, 0, 0, 0] -}-} - | otherwise = [0, 0, 0, 0] - - 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 - return () - t <- varGet vart - let Bamp 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) - ) - for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j -> - drawRect dc (field g (i, j)) [brushKind := BrushTransparent, penColor := setLum 0.2 $ colorplayer $ owner bsz (i, j)] - )) - for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j -> - drawField dc (field g (i, j)) (st ! (i, j)) - )) - - onclick :: Point -> IO () - onclick point = do - t <- varGet vart - g <- varGet varg - let Bamp st = state t - n = 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 - ] - -owner :: Int -> (Int, Int) -> Player -owner bsz (i, j) - | 2 * i < bsz && 2 * j < bsz = 0 - | 2 * i < bsz && 2 * j >= bsz = 1 - | 2 * i >= bsz && 2 * j >= bsz = 2 - | 2 * i >= bsz && 2 * j < bsz = 3 - | otherwise = error "owner: Unexpected value" - -drawField :: DC () -> Rect -> BampField -> IO () -drawField _ (Rect _ _ _ _) Empty = return () -drawField dc (Rect x y w h) (Portal p) = circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [penColor := colorplayer p, penWidth := 2, brushKind := BrushTransparent] -drawField dc (Rect x y w h) (Piece p) = drawRect dc (Rect (x + w `div` 10) (y + h `div` 10) (w - w `div` 5) (h - h `div` 5)) [brushColor := colorplayer p] -drawField dc (Rect x y w h) Ball = circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [brushColor := rgb 100 80 (40 :: Int)] - -allMoves :: Int -> Player -> Array (Int, Int) BampField -> [(Int, Int)] -allMoves _bsz p s = filter valid $ filter (\i -> s ! i == Piece p) $ indices s - where - (a, b) = findBall s - - valid :: (Int, Int) -> Bool - valid (x, y) | x /= a && y /= b = False - | x < a = all (\i -> ok (i, y)) [x + 1 .. a + 1] - | x > a = all (\i -> ok (i, y)) [a - 1 .. x - 1] - | y < b = all (\j -> ok (x, j)) [y + 1 .. b + 1] - | y > b = all (\j -> ok (x, j)) [b - 1 .. y - 1] - | otherwise = error "allMoves: Unexpected value" - - ok :: (Int, Int) -> Bool - ok t = inRange (bounds s) t - && case s ! t of Piece _ -> False - _ -> True - -move :: Int -> (Int, Int) -> (Player, Bamp) -> (Player, Bamp) -move bsz (x, y) (p, Bamp s) = let (a, b) = findBall s - new' = follow (a, b) (signum (a - x), signum (b - y)) - in (owner bsz new', Bamp $ s // [((x, y), Empty), ((a, b), Piece p), (new', Ball)]) - where - follow :: (Int, Int) -> (Int, Int) -> (Int, Int) - follow (x', y') (dx, dy) - | not $ inRange (bounds s) (x' + dx, y' + dy) = (x', y') - | s ! (x' + dx, y' + dy) == Empty = follow (x' + dx, y' + dy) (dx, dy) - | isPortal $ s ! (x' + dx, y' + dy) = follow (x' + dx, y' + dy) (dx, dy) - | otherwise = (x', y') - -findBall :: Array (Int, Int) BampField -> (Int, Int) -findBall s = case dropWhile (not.(== Ball).snd) $ assocs s - of ((i, Ball):_) -> i - [] -> (0, 0) - _ -> error "findBall: Unexpected value" - -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 - ++----------+-- Bamp --+----------++module Bamp (Bamp, bamp) where++import Game+import Data.Array+import Graphics.UI.WX hiding (border, point)+import Graphics.UI.WXCore hiding (point)+import Tools++data BampField+ = Empty+ | Portal Player+ | Piece Player+ | Ball+ deriving (Eq, Show)++isPortal :: BampField -> Bool+isPortal (Portal _) = True+isPortal _ = False++{-+isPiece :: BampField -> Bool+isPiece (Piece _) = True+isPiece _ = False+-}++data Bamp = Bamp (Array (Int, Int) BampField) deriving (Eq, Show)++bamp :: Bamp+bamp = undefined++instance Game Bamp where++ name _ = "bamp"++ standard _ = Properties { players = 4, boardsize = 8, human = [True, False, False, False] }++ possible _ = PropertyRange { playersrange = [4], boardsizerange = [6, 8 .. 12] }+ + new pr = let s = boardsize pr+ h = s `div` 2+ in Bamp $ array ((0, 0), (s - 1, s - 1))+ [((x, y), Empty) | x <- [0 .. s - 1], y <- [0 .. s - 1]]+ // concat [[((0 , i), Piece 0), (( i, 0 ), Piece 0)] | i <- [0 .. h - 1]]+ // concat [[((0 , h + i), Piece 1), (( i, s - 1), Piece 1)] | i <- [0 .. h - 1]]+ // concat [[((s - 1, h + i), Piece 2), ((h + i, s - 1), Piece 2)] | i <- [0 .. h - 1]]+ // concat [[((s - 1, i), Piece 3), ((h + i, 0 ), Piece 3)] | i <- [0 .. h - 1]]+ // [((1 , 1 ), Ball )]+{-{+ // [ ((0 , 0 ), Portal 0)+ , ((0 , s - 1), Portal 1)+ , ((s - 1, s - 1), Portal 2)+ , ((s - 1, 0 ), Portal 3)+ , ((1 , 1 ), Ball )+ ]+}-} + moves pr p (Bamp s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s)++ showmove pr p (Bamp s) i = let (x, y) = allMoves (boardsize pr) p s !! i+ in ['a' ..] !! x : show (boardsize pr - y)+ + value pr p (Bamp s)+ | null $ moves pr p (Bamp s) = let bsz = boardsize pr+ in owner bsz (findBall s) |> 1 $ replicate 4 (-1)+{-{+ in case findBall s+ of (x, y) | (x, y) == (0 , 0 ) -> [ 1, -1, -1, -1]+ | (x, y) == (0 , bsz - 1) -> [-1, 1, -1, -1]+ | (x, y) == (bsz - 1, bsz - 1) -> [-1, -1, 1, -1]+ | (x, y) == (bsz - 1, 0 ) -> [-1, -1, -1, 1]+ _ -> [0, 0, 0, 0]+}-}+ | otherwise = [0, 0, 0, 0]++ 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+ return ()+ t <- varGet vart+ let Bamp 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)+ )+ for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->+ drawRect dc (field g (i, j)) [brushKind := BrushTransparent, penColor := setLum 0.2 $ colorplayer $ owner bsz (i, j)]+ ))+ for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->+ drawField dc (field g (i, j)) (st ! (i, j))+ ))++ onclick :: Point -> IO ()+ onclick point = do + t <- varGet vart+ g <- varGet varg+ let Bamp st = state t+ n = 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+ ]++owner :: Int -> (Int, Int) -> Player+owner bsz (i, j)+ | 2 * i < bsz && 2 * j < bsz = 0+ | 2 * i < bsz && 2 * j >= bsz = 1+ | 2 * i >= bsz && 2 * j >= bsz = 2+ | 2 * i >= bsz && 2 * j < bsz = 3+ | otherwise = error "owner: Unexpected value"++drawField :: DC () -> Rect -> BampField -> IO ()+drawField _ (Rect _ _ _ _) Empty = return ()+drawField dc (Rect x y w h) (Portal p) = circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [penColor := colorplayer p, penWidth := 2, brushKind := BrushTransparent]+drawField dc (Rect x y w h) (Piece p) = drawRect dc (Rect (x + w `div` 10) (y + h `div` 10) (w - w `div` 5) (h - h `div` 5)) [brushColor := colorplayer p]+drawField dc (Rect x y w h) Ball = circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [brushColor := rgb 100 80 (40 :: Int)]++allMoves :: Int -> Player -> Array (Int, Int) BampField -> [(Int, Int)]+allMoves _bsz p s = filter valid $ filter (\i -> s ! i == Piece p) $ indices s+ where+ (a, b) = findBall s++ valid :: (Int, Int) -> Bool+ valid (x, y) | x /= a && y /= b = False+ | x < a = all (\i -> ok (i, y)) [x + 1 .. a + 1]+ | x > a = all (\i -> ok (i, y)) [a - 1 .. x - 1]+ | y < b = all (\j -> ok (x, j)) [y + 1 .. b + 1]+ | y > b = all (\j -> ok (x, j)) [b - 1 .. y - 1]+ | otherwise = error "allMoves: Unexpected value"++ ok :: (Int, Int) -> Bool+ ok t = inRange (bounds s) t+ && case s ! t of Piece _ -> False+ _ -> True++move :: Int -> (Int, Int) -> (Player, Bamp) -> (Player, Bamp)+move bsz (x, y) (p, Bamp s) = let (a, b) = findBall s+ new' = follow (a, b) (signum (a - x), signum (b - y))+ in (owner bsz new', Bamp $ s // [((x, y), Empty), ((a, b), Piece p), (new', Ball)])+ where+ follow :: (Int, Int) -> (Int, Int) -> (Int, Int)+ follow (x', y') (dx, dy)+ | not $ inRange (bounds s) (x' + dx, y' + dy) = (x', y')+ | s ! (x' + dx, y' + dy) == Empty = follow (x' + dx, y' + dy) (dx, dy)+ | isPortal $ s ! (x' + dx, y' + dy) = follow (x' + dx, y' + dy) (dx, dy)+ | otherwise = (x', y')++findBall :: Array (Int, Int) BampField -> (Int, Int)+findBall s = case dropWhile (not.(== Ball).snd) $ assocs s+ of ((i, Ball):_) -> i+ [] -> (0, 0)+ _ -> error "findBall: Unexpected value"++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+
GUI.hs view
@@ -1,782 +1,793 @@-{-# OPTIONS -fglasgow-exts #-} - ---------- --- GUI -- ---------- - -module GUI (gui, version) where - -import Game -- hiding (name) -import Graphics.UI.WX hiding (bitmap, children, click, selections, stop) -import Graphics.UI.WXCore -import Char -import Tools hiding (field) -import List - -version :: String -version = "1.7.2" - -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 - 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 [ 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 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 #-}++---------+-- GUI -- +---------++module GUI (gui, version) where++import Game -- hiding (name)+import Graphics.UI.WX hiding (bitmap, children, click, selections, stop)+import Graphics.UI.WXCore+import Data.Char+import Tools hiding (field)+import Data.List++version :: String+version = "1.7.3" +++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 ()
Game.hs view
@@ -1,166 +1,166 @@-{-# OPTIONS -fglasgow-exts #-} - -module Game where - -import Graphics.UI.WX hiding (children, value) -import Array -import Tools - ----------------- --- class Game -- ----------------- - -type Player = Int -type Move g = (Player, g) -> (Player, g) -type Value = [Float] - -data Properties - = Properties { players :: Int - , boardsize :: Int - , human :: [Bool] - } - deriving Show - -data PropertyRange - = PropertyRange { playersrange :: [Int] - , boardsizerange :: [Int] - } - -class (Eq g, Show g) => Game g where - - name :: g -> String ---{ rules :: g -> String ---{ information :: g -> String - - standard :: g -> Properties - possible :: g -> PropertyRange - - new :: Properties -> g - - moves :: Properties -> Player -> g -> [Move g] - showmove :: Properties -> Player -> g -> Int -> String - - value :: Properties -> Player -> g -> Value - - board :: Panel () -> Properties -> Var (Tree g) -> Bool -> (Int -> IO ()) -> IO () - -data GeneralGame = forall g. Game g => Game g - ---------------- --- data Tree -- ---------------- - -data Game g => Tree g - = Node { player :: Player - , state :: g - , movesnr :: Int - , childid :: Int - , mov :: Array Int (Move g) --{ onnodig? - , children :: Array Int (Tree g) - , val :: Value -- should be equally good for the current player - --{ misschien handig om een set te nemen ipv list? - --{ maar: voor gemiddeldes juist weer niet! (ook in algoritme?) - --{ in dat geval: maar een entry per zet! (dus length best = length val) - --{ > nee! we doen gewoon 1 value, het gemiddelde van alle bests - --{ val = average $ map val best - , best :: [Int] - , filled :: Bool - , closed :: Bool - , mind :: Inf Int - , maxd :: Int - , volume :: Int - } - -buildtree :: Game g => Properties -> Player -> g -> Tree g -buildtree prop p g = let ms = moves prop p g - nr = length ms - in Node { player = p - , state = g - , movesnr = nr - , childid = 0 - , mov = array (0, nr - 1) $ zip [0 ..] $ ms - , children = array (0, nr - 1) $ map (\(i, m) -> (i, (child m) {childid = i})) $ zip [0 ..] ms - , val = value prop p g - , best = [] - , filled = False - , closed = False - , mind = 0 - , maxd = 0 - , volume = 0 - } - where --- child :: Move g -> Tree g - child m = uncurry (buildtree prop) (m (p, g)) - -createtree :: Game g => g -> Properties -> Tree g -createtree _ p = buildtree p 0 $ new p - ------------------------ --- Tree manipulation -- ------------------------ - -better :: Player -> Value -> Value -> Ordering -better p v w | p < 0 || p >= length v || p >= length w = error $ "Game.better: index " ++ show p ++ " out of bounds" - | otherwise = compare (v !! p) (w !! p) - -computeVal :: Game g => Tree g -> Tree g -computeVal t = let kids = assocs $ children t - vals = map (\(i, k) -> (i, val k)) kids - good = maximumWith (\(_,v) (_,w) -> better (player t) v w) vals - in t { best = map fst good - , val = zipWithn average $ map snd good --{ veranderen als val set is ipv list - } - --- shear cuts a branch off and makes it the new tree -shear :: Game g => Int -> Tree g -> Tree g -shear i t = children t ! i - --- grow makes the tree grow at its root (which should be a leaf) -grow :: Game g => Tree g -> Tree g -grow t | movesnr t == 0 = t {closed = True, filled = True, mind = inf, maxd = 1, volume = 1} - | otherwise = computeVal $ t {filled = True, mind = 1 , maxd = 1, volume = 1} - --- update recomputes val, best, mind and maxd given the index of the altered child ---{ update moet efficienter dan altijd computeVal! -update :: Game g => Int -> Tree g -> Tree g -update _i t = computeVal - $ t { closed = and $ map closed $ elems $ children t - , mind = case filter (not . closed) $ elems $ children t - of [] -> inf - kids -> minimum $ map ((+ 1) . mind) kids - , maxd = maximum $ map ((+ 1) . maxd) $ elems $ children t - , volume = 1 + sum (map volume $ elems $ children t) - } - --- path computes a path to a leaf to update, given a leaf-choosing algorithm f -path :: Game g => (Tree g -> [Int]) -> [Int] -> Tree g -> [Int] -path f (j:js) t = case f t of [] -> [] - is -> let i = is !! (j `mod` length is) - in i : path f js (children t ! i) -path _ [] _ = error "path: empty list" - --- step makes the tree grow at exactly one leaf, given a path -step :: Game g => [Int] -> Tree g -> Tree g -step [] t = grow t -step (i:is) t - | filled t = let u = step is (children t ! i) - in update i $ t {children = children t // [(i, u)]} - | otherwise = grow t - -followcombination :: Game g => Tree g -> [Int] -followcombination t = followshortest t ++ followbest t - -followshortest :: Game g => Tree g -> [Int] -followshortest t | not $ filled t = [] - | closed t = [] - | otherwise = let open = filter (\(_i, k) -> not $ closed k) $ assocs $ children t - minds = map (\(i, k) -> (i, mind k)) open - in map fst $ minimumWith (\(_, p) (_, q) -> compare p q) minds - -followbest :: Game g => Tree g -> [Int] -followbest t = case filter (\i -> not $ closed $ children t ! i) $ best t of - [] -> followopen t - b -> b - -followopen :: Game g => Tree g -> [Int] +{-# LANGUAGE ExistentialQuantification #-}++module Game where++import Graphics.UI.WX hiding (children, value)+import Data.Array+import Tools++----------------+-- class Game --+----------------++type Player = Int+type Move g = (Player, g) -> (Player, g)+type Value = [Float]++data Properties+ = Properties { players :: Int+ , boardsize :: Int+ , human :: [Bool]+ }+ deriving Show++data PropertyRange+ = PropertyRange { playersrange :: [Int]+ , boardsizerange :: [Int]+ }++class (Eq g, Show g) => Game g where++ name :: g -> String+--{ rules :: g -> String+--{ information :: g -> String++ standard :: g -> Properties+ possible :: g -> PropertyRange+ + new :: Properties -> g++ moves :: Properties -> Player -> g -> [Move g]+ showmove :: Properties -> Player -> g -> Int -> String++ value :: Properties -> Player -> g -> Value++ board :: Panel () -> Properties -> Var (Tree g) -> Bool -> (Int -> IO ()) -> IO ()++data GeneralGame = forall g. Game g => Game g++---------------+-- data Tree --+---------------++data Game g => Tree g+ = Node { player :: Player+ , state :: g+ , movesnr :: Int+ , childid :: Int+ , mov :: Array Int (Move g) --{ onnodig?+ , children :: Array Int (Tree g)+ , val :: Value -- should be equally good for the current player+ --{ misschien handig om een set te nemen ipv list?+ --{ maar: voor gemiddeldes juist weer niet! (ook in algoritme?)+ --{ in dat geval: maar een entry per zet! (dus length best = length val)+ --{ > nee! we doen gewoon 1 value, het gemiddelde van alle bests+ --{ val = average $ map val best+ , best :: [Int]+ , filled :: Bool+ , closed :: Bool+ , mind :: Inf Int+ , maxd :: Int+ , volume :: Int+ }++buildtree :: Game g => Properties -> Player -> g -> Tree g+buildtree prop p g = let ms = moves prop p g+ nr = length ms+ in Node { player = p+ , state = g+ , movesnr = nr+ , childid = 0+ , mov = array (0, nr - 1) $ zip [0 ..] $ ms+ , children = array (0, nr - 1) $ map (\(i, m) -> (i, (child m) {childid = i})) $ zip [0 ..] ms+ , val = value prop p g+ , best = []+ , filled = False+ , closed = False+ , mind = 0+ , maxd = 0+ , volume = 0+ }+ where+-- child :: Move g -> Tree g+ child m = uncurry (buildtree prop) (m (p, g))+ +createtree :: Game g => g -> Properties -> Tree g+createtree _ p = buildtree p 0 $ new p++-----------------------+-- Tree manipulation --+-----------------------++better :: Player -> Value -> Value -> Ordering+better p v w | p < 0 || p >= length v || p >= length w = error $ "Game.better: index " ++ show p ++ " out of bounds"+ | otherwise = compare (v !! p) (w !! p)++computeVal :: Game g => Tree g -> Tree g+computeVal t = let kids = assocs $ children t + vals = map (\(i, k) -> (i, val k)) kids+ good = maximumWith (\(_,v) (_,w) -> better (player t) v w) vals+ in t { best = map fst good+ , val = zipWithn average $ map snd good --{ veranderen als val set is ipv list+ }++-- shear cuts a branch off and makes it the new tree+shear :: Game g => Int -> Tree g -> Tree g+shear i t = children t ! i++-- grow makes the tree grow at its root (which should be a leaf)+grow :: Game g => Tree g -> Tree g+grow t | movesnr t == 0 = t {closed = True, filled = True, mind = inf, maxd = 1, volume = 1}+ | otherwise = computeVal $ t {filled = True, mind = 1 , maxd = 1, volume = 1}++-- update recomputes val, best, mind and maxd given the index of the altered child+--{ update moet efficienter dan altijd computeVal!+update :: Game g => Int -> Tree g -> Tree g+update _i t = computeVal+ $ t { closed = and $ map closed $ elems $ children t+ , mind = case filter (not . closed) $ elems $ children t+ of [] -> inf+ kids -> minimum $ map ((+ 1) . mind) kids+ , maxd = maximum $ map ((+ 1) . maxd) $ elems $ children t+ , volume = 1 + sum (map volume $ elems $ children t)+ }++-- path computes a path to a leaf to update, given a leaf-choosing algorithm f+path :: Game g => (Tree g -> [Int]) -> [Int] -> Tree g -> [Int]+path f (j:js) t = case f t of [] -> []+ is -> let i = is !! (j `mod` length is)+ in i : path f js (children t ! i)+path _ [] _ = error "path: empty list"++-- step makes the tree grow at exactly one leaf, given a path+step :: Game g => [Int] -> Tree g -> Tree g+step [] t = grow t+step (i:is) t + | filled t = let u = step is (children t ! i)+ in update i $ t {children = children t // [(i, u)]}+ | otherwise = grow t++followcombination :: Game g => Tree g -> [Int]+followcombination t = followshortest t ++ followbest t++followshortest :: Game g => Tree g -> [Int]+followshortest t | not $ filled t = []+ | closed t = []+ | otherwise = let open = filter (\(_i, k) -> not $ closed k) $ assocs $ children t+ minds = map (\(i, k) -> (i, mind k)) open+ in map fst $ minimumWith (\(_, p) (_, q) -> compare p q) minds++followbest :: Game g => Tree g -> [Int]+followbest t = case filter (\i -> not $ closed $ children t ! i) $ best t of+ [] -> followopen t+ b -> b+ +followopen :: Game g => Tree g -> [Int] followopen t = map fst $ filter (not.closed.snd) $ assocs $ children t
GeBoP.cabal view
@@ -1,123 +1,125 @@-Name: GeBoP -Synopsis: Several games -Description: - The games: Ataxx, Bamp, Halma, Hez, Kram, Nim, Reversi, TicTacToe, and Zenix -Homepage: http://www.haskell.org/haskellwiki/GeBoP -Version: 1.7.2 -License: BSD3 -License-file: LICENSE.txt -Author: Maarten Löffler -Maintainer: Maarten Löffler <loffler@cs.uu.nl> -Stability: Stable -Cabal-Version: >= 1.2 -Build-type: Simple -Category: Game -Tested-with: GHC == 6.10.4, GHC == 6.12.1, GHC == 6.12.3 -Extra-Source-Files: - changelog.txt - readme.txt, - Ataxx.hs, - Bamp.hs, - Game.hs, - GUI.hs, - Halma.hs, - Hex.hs, - HSL.hs, - Inf.hs, - Kram.hs, - Nim.hs, - Reversi.hs, - TicTacToe.hs, - Tools.hs, - Zenix.hs - -Data-dir: . -Data-files: gebop.ico, - brain.ico, - images/blue.bmp, - images/blue_mask.bmp, - images/brain.bmp, - images/brain_mask.bmp, - images/brown.bmp, - images/brown_mask.bmp, - images/computer.bmp, - images/computer_mask.bmp, - images/empty.bmp, - images/empty_mask.bmp, - images/gebop.bmp, - images/green.bmp, - images/green_mask.bmp, - images/grey.bmp, - images/grey_mask.bmp, - images/high_blue.bmp, - images/high_brown.bmp, - images/high_green.bmp, - images/high_grey.bmp, - images/high_purple.bmp, - images/high_red.bmp, - images/high_small_blue.bmp, - images/high_small_brown.bmp, - images/high_small_green.bmp, - images/high_small_grey.bmp, - images/high_small_purple.bmp, - images/high_small_red.bmp, - images/human.bmp, - images/human_mask.bmp, - images/marble.bmp, - images/purple.bmp, - images/purple_mask.bmp, - images/red.bmp, - images/red_mask.bmp, - images/small_blue.bmp, - images/small_blue_mask.bmp, - images/small_brain.bmp, - images/small_brain_mask.bmp, - images/small_brown.bmp, - images/small_brown_mask.bmp, - images/small_green.bmp, - images/small_green_mask.bmp, - images/small_grey.bmp, - images/small_grey_mask.bmp, - images/small_purple.bmp, - images/small_purple_mask.bmp, - images/small_red.bmp, - images/small_red_mask.bmp, - images/turn.bmp, - images/turn_mask.bmp, - images/winner.bmp, - images/winner_mask.bmp - help/brain.html - help/gebop.bmp - help/index.html - help/info_ataxx.html - help/info_bamp.html - help/info_halma.html - help/info_hex.html - help/info_kram.html - help/info_nim.html - help/info_reversi.html - help/info_tictactoe.html - help/info_zenix.html - help/rules_ataxx.html - help/rules_bamp.html - help/rules_halma.html - help/rules_hex.html - help/rules_kram.html - help/rules_nim.html - help/rules_reversi.html - help/rules_tictactoe.html - help/rules_zenix.html - -Executable gebop - Build-Depends: - base < 5, - wxcore >= 0.11 && < 0.13, - wx >= 0.11 && < 0.13, - haskell98 < 1.1, - directory < 1.1 - Main-Is: Main.hs - GHC-Options: "-Wall" - --- The following can only work, when GeBoP stops printing trace data: --- if os(mingw32) --- GHC-Options: "-optl-mwindows" +Name: GeBoP+Synopsis: Several games+Description: + The games: Ataxx, Bamp, Halma, Hez, Kram, Nim, Reversi, TicTacToe, and Zenix+Homepage: http://www.haskell.org/haskellwiki/GeBoP+Version: 1.7.3+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+Build-type: Simple+Category: Game+Tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.3+Extra-Source-Files:+ changelog.txt+ readme.txt,+ Ataxx.hs,+ Bamp.hs,+ Game.hs,+ GUI.hs,+ Halma.hs,+ Hex.hs,+ HSL.hs,+ Inf.hs,+ Kram.hs,+ Nim.hs,+ Reversi.hs,+ TicTacToe.hs,+ Tools.hs,+ Zenix.hs++Data-dir: .+Data-files: gebop.ico, + brain.ico,+ images/blue.bmp,+ images/blue_mask.bmp,+ images/brain.bmp,+ images/brain_mask.bmp,+ images/brown.bmp,+ images/brown_mask.bmp,+ images/computer.bmp,+ images/computer_mask.bmp,+ images/empty.bmp,+ images/empty_mask.bmp,+ images/gebop.bmp,+ images/green.bmp,+ images/green_mask.bmp,+ images/grey.bmp,+ images/grey_mask.bmp,+ images/high_blue.bmp,+ images/high_brown.bmp,+ images/high_green.bmp,+ images/high_grey.bmp,+ images/high_purple.bmp,+ images/high_red.bmp,+ images/high_small_blue.bmp,+ images/high_small_brown.bmp,+ images/high_small_green.bmp,+ images/high_small_grey.bmp,+ images/high_small_purple.bmp,+ images/high_small_red.bmp,+ images/human.bmp,+ images/human_mask.bmp,+ images/marble.bmp,+ images/purple.bmp,+ images/purple_mask.bmp,+ images/red.bmp,+ images/red_mask.bmp,+ images/small_blue.bmp,+ images/small_blue_mask.bmp,+ images/small_brain.bmp,+ images/small_brain_mask.bmp,+ images/small_brown.bmp,+ images/small_brown_mask.bmp,+ images/small_green.bmp,+ images/small_green_mask.bmp,+ images/small_grey.bmp,+ images/small_grey_mask.bmp,+ images/small_purple.bmp,+ images/small_purple_mask.bmp,+ images/small_red.bmp,+ images/small_red_mask.bmp,+ images/turn.bmp,+ images/turn_mask.bmp,+ images/winner.bmp,+ images/winner_mask.bmp,+ help/brain.html,+ help/gebop.bmp,+ help/index.html,+ help/info_ataxx.html,+ help/info_bamp.html,+ help/info_halma.html,+ help/info_hex.html,+ help/info_kram.html,+ help/info_nim.html,+ help/info_reversi.html,+ help/info_tictactoe.html,+ help/info_zenix.html,+ help/rules_ataxx.html,+ help/rules_bamp.html,+ help/rules_halma.html,+ help/rules_hex.html,+ help/rules_kram.html,+ help/rules_nim.html,+ help/rules_reversi.html,+ help/rules_tictactoe.html,+ help/rules_zenix.html++Executable gebop+ Build-Depends:+ array >= 0.4 && < 0.5,+ base >= 4.5 && < 4.7, + directory >= 1.1 && < 1.3,+ random >= 1.0 && < 1.1,+ wx >= 0.11 && < 0.91,+ wxcore >= 0.11 && < 0.91++ Main-Is: Main.hs+ GHC-Options: -Wall -optc-static-libgcc++-- The following can only work, when GeBoP stops printing trace data:+-- if os(mingw32)+-- GHC-Options: "-optl-mwindows"
HSL.hs view
@@ -1,94 +1,94 @@- ---------- --- HSL -- ---------- - -module HSL - ( hsl - , colorHSL, colorHue, colorSat, colorLum - , setHue, setSat, setLum - ) where - -import Graphics.UI.WX - -hsl :: Float -> Float -> Float -> Color -colorHSL :: Color -> (Float, Float, Float) -colorHue :: Color -> Float -colorSat :: Color -> Float -colorLum :: Color -> Float -setHue :: Float -> Color -> Color -setSat :: Float -> Color -> Color -setLum :: Float -> Color -> Color - -hsl h s l - | h < 0 || h > 1 || s < 0 || s > 1 || l < 0 || l > 1 = error "hsl: out of range" - | s == 0 = let v :: Int - v = round $ 255 * l - in rgb v v v - | otherwise = let var_2 | l < 0.5 = l * (1 + s) - | otherwise = (l + s) - (s * l) - var_1 = 2 * l - var_2 - r :: Int - r = round $ 255 * hue2rgb var_1 var_2 (h + 1/3) - g :: Int - g = round $ 255 * hue2rgb var_1 var_2 h - b :: Int - b = round $ 255 * hue2rgb var_1 var_2 (h - 1/3) - in rgb r g b - -hue2rgb :: Float -> Float -> Float -> Float -hue2rgb v1 v2 vh = let vh_ | vh < 0 = vh + 1 - | vh > 1 = vh - 1 - | otherwise = vh - v | 6 * vh_ < 1 = v1 + (v2 - v1) * 6 * vh_ - | 2 * vh_ < 1 = v2 - | 3 * vh_ < 2 = v1 + (v2 - v1) * (2/3 - vh_) * 6 - | otherwise = v1 - in v - -colorHSL c = - let var_r :: Float - var_r = (fromInteger $ colorRed c) / 255 - var_g :: Float - var_g = (fromInteger $ colorGreen c) / 255 - var_b :: Float - var_b = (fromInteger $ colorBlue c) / 255 - var_min = minimum [var_r, var_g, var_b] - var_max = maximum [var_r, var_g, var_b] - del_max = var_max - var_min - l = (var_max + var_min) / 2 - s | del_max == 0 = 0 - | l < 0.5 = del_max / ( var_max + var_min) - | otherwise = del_max / (2 - var_max - var_min) - del_r = ((var_max - var_r) / 6 + del_max / 2) / del_max - del_g = ((var_max - var_g) / 6 + del_max / 2) / del_max - del_b = ((var_max - var_b) / 6 + del_max / 2) / del_max - h_ | del_max == 0 = 0 - | var_r == var_max = del_b - del_g - | var_g == var_max = 1/3 + del_r - del_b - | var_b == var_max = 2/3 + del_g - del_r - | otherwise = error "Unexpected value" -{- - h | h_ < 0 = h_ + 1 - | h_ > 1 = h_ - 1 - | otherwise = error "Unexpected value" --} - in (h_, s, l) - -colorHue = (\(h, _, _) -> h) . colorHSL - -colorSat = (\(_, s, _) -> s) . colorHSL - -colorLum = (\(_, _, l) -> l) . colorHSL - -setHue h c - | h < 0 || h > 1 = error "setHue: out of range" - | otherwise = let (_, s, l) = colorHSL c in hsl h s l - -setSat s c - | s < 0 || s > 1 = error "setSat: out of range" - | otherwise = let (h, _, l) = colorHSL c in hsl h s l - -setLum l c - | l < 0 || l > 1 = error "setLum: out of range" - | otherwise = let (h, s, _) = colorHSL c in hsl h s l ++---------+-- HSL -- +---------++module HSL + ( hsl+ , colorHSL, colorHue, colorSat, colorLum+ , setHue, setSat, setLum+ ) where++import Graphics.UI.WX++hsl :: Float -> Float -> Float -> Color+colorHSL :: Color -> (Float, Float, Float)+colorHue :: Color -> Float+colorSat :: Color -> Float+colorLum :: Color -> Float+setHue :: Float -> Color -> Color+setSat :: Float -> Color -> Color+setLum :: Float -> Color -> Color++hsl h s l+ | h < 0 || h > 1 || s < 0 || s > 1 || l < 0 || l > 1 = error "hsl: out of range"+ | s == 0 = let v :: Int+ v = round $ 255 * l+ in rgb v v v+ | otherwise = let var_2 | l < 0.5 = l * (1 + s)+ | otherwise = (l + s) - (s * l)+ var_1 = 2 * l - var_2+ r :: Int+ r = round $ 255 * hue2rgb var_1 var_2 (h + 1/3)+ g :: Int+ g = round $ 255 * hue2rgb var_1 var_2 h+ b :: Int+ b = round $ 255 * hue2rgb var_1 var_2 (h - 1/3)+ in rgb r g b++hue2rgb :: Float -> Float -> Float -> Float+hue2rgb v1 v2 vh = let vh_ | vh < 0 = vh + 1+ | vh > 1 = vh - 1+ | otherwise = vh+ v | 6 * vh_ < 1 = v1 + (v2 - v1) * 6 * vh_+ | 2 * vh_ < 1 = v2+ | 3 * vh_ < 2 = v1 + (v2 - v1) * (2/3 - vh_) * 6+ | otherwise = v1+ in v++colorHSL c =+ let var_r :: Float+ var_r = (fromInteger $ colorRed c) / 255+ var_g :: Float+ var_g = (fromInteger $ colorGreen c) / 255+ var_b :: Float+ var_b = (fromInteger $ colorBlue c) / 255+ var_min = minimum [var_r, var_g, var_b]+ var_max = maximum [var_r, var_g, var_b]+ del_max = var_max - var_min+ l = (var_max + var_min) / 2+ s | del_max == 0 = 0+ | l < 0.5 = del_max / ( var_max + var_min)+ | otherwise = del_max / (2 - var_max - var_min)+ del_r = ((var_max - var_r) / 6 + del_max / 2) / del_max+ del_g = ((var_max - var_g) / 6 + del_max / 2) / del_max+ del_b = ((var_max - var_b) / 6 + del_max / 2) / del_max+ h_ | del_max == 0 = 0+ | var_r == var_max = del_b - del_g+ | var_g == var_max = 1/3 + del_r - del_b+ | var_b == var_max = 2/3 + del_g - del_r+ | otherwise = error "Unexpected value"+{-+ h | h_ < 0 = h_ + 1+ | h_ > 1 = h_ - 1+ | otherwise = error "Unexpected value"+-}+ in (h_, s, l)++colorHue = (\(h, _, _) -> h) . colorHSL++colorSat = (\(_, s, _) -> s) . colorHSL++colorLum = (\(_, _, l) -> l) . colorHSL++setHue h c + | h < 0 || h > 1 = error "setHue: out of range"+ | otherwise = let (_, s, l) = colorHSL c in hsl h s l++setSat s c + | s < 0 || s > 1 = error "setSat: out of range"+ | otherwise = let (h, _, l) = colorHSL c in hsl h s l++setLum l c + | l < 0 || l > 1 = error "setLum: out of range"+ | otherwise = let (h, s, _) = colorHSL c in hsl h s l
Halma.hs view
@@ -1,279 +1,279 @@- ------------ --- Halma -- ------------ - -module Halma (Halma, halma) where - -import Game -import Array --- import Graphics.UI.WX -import Graphics.UI.WX hiding (border, empty, point) -import Graphics.UI.WXCore hiding (empty, point) -import Tools - -data Halma = Halma (Array (Int, Int) (Maybe Player)) deriving (Eq, Show) - -type HalmaMove = ((Int, Int), (Int, Int)) - -halma :: Halma -halma = undefined - -instance Game Halma where - - name _ = "halma" - - standard _ = Properties { players = 2, boardsize = 8, human = [True, False, False, False, False, False] } - possible _ = PropertyRange { playersrange = [2, 3, 4, 6], boardsizerange = [8] } - - new pr = let empty = [((x, y), Nothing) | x <- [-8 .. 8], y <- [-8 .. 8]] - in Halma $ array ((-8, -8), (8, 8)) empty // concatMap (\p -> map (\t -> (t, Just p)) $ startpos $ pos pr p) [0 .. players pr - 1] - - moves pr p (Halma s) = map (move pr) (allMoves pr p s) - - showmove pr p (Halma s) i = let ((x1, y1), (x2, y2)) = allMoves pr p s !! i - in "abcdefghijklmnopq" !! (x1 + 8) : show (9 - y1) ++ "-" ++ "abcdefghijklmnopq" !! (x2 + 8) : show (9 - y2) - - value pr p (Halma st) | null $ allMoves pr p st = let winners = map snd $ filter (\(d, _) -> d == 20) $ zip totaldists [0..] - in foldr ($) (replicate (players pr) (-1)) $ map (|> 1) winners - | otherwise = map myvalue [0 .. players pr - 1] - where - totaldists :: [Int] - totaldists = map totaldist [0 .. players pr - 1] - - totaldist :: Player -> Int - totaldist p' = let mypieces = map (\(i, _e) -> i) $ filter (\(_i, e) -> e == Just p') $ assocs st - in sum $ map (dist pr p') mypieces - - myvalue :: Player -> Float - myvalue p' = let d = sum (map totaldist [0 .. players pr - 1]) - (players pr) * totaldist p' - in (fromInteger . toInteger) d / (fromInteger . toInteger) (120 * (players pr)) - - board p pr vart _ia move' = do - - marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY - varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero - vare <- varCreate (Nothing :: Maybe (Int, Int)) - - let - - onpaint :: DC () -> Rect -> IO () - onpaint dc r = do - t <- varGet vart - e <- varGet vare - b_ <- border dc (16, 16) - let g_ = grate r b_ (26, 17) (Size 4 7) - b <- fit dc (16, 16) $ rectWidth (field g_ (0, 0)) - let Halma st = state t - g = grate r b (26, 17) (Size 4 7) - radius = rectHeight (field g (0, 0)) `div` 3 - lin' :: Rect -> Rect -> IO () - lin' (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = do - line dc (pt (x1 + w1) (y1 + h1 `div` 2)) (pt (x2 + w2) (y2 + h2 `div` 2)) [] - lin :: (Int, Int) -> (Int, Int) -> IO () - lin p' q = lin' (field g $ tograte p') (field g $ tograte q) - varSet varg g - tileBitmap dc r marble ---{ drawGrate dc g [penColor := yellow] - for 0 16 (\j -> do - let i = head $ dropWhile (\i' -> inside $ fromgrate (i', j)) [13 ..] - drawTextRect dc (show $ 17 - j) $ field g ( i - 1, j) |#| field g ( i, j) - drawTextRect dc (show $ 17 - j) $ field g (25 - i, j) |#| field g (26 - i, j) - let d = (i - 1 + 3 * j) `div` 2 - 18 - e' = (25 - i + 3 * j) `div` 2 - 18 - drawTextRect dc [['A' ..] !! (16 - j)] $ field g (i - 1 - d, j - d) |#| field g (i - 1 - d, j - 1 - d) - drawTextRect dc [['A' ..] !! (16 - j)] $ field g (25 - i - e', j - e') |#| field g (25 - i - e', j - 1 - e') - ) - for 0 4 (\n -> do - lin ( - 4, n - 8) (n - 4, n - 8) - lin (n - 8, n - 4) ( 4, n - 4) - lin ( - 4, n ) (n + 4, n ) - lin (n , n + 4) ( 4, n + 4) - lin (n - 8, - 4) (n - 8, n - 4) - lin (n - 4, n - 8) (n - 4, 4) - lin (n , - 4) (n , n + 4) - lin (n + 4, n ) (n + 4, 4) - lin ( - 4, -n + 4) (n - 4, 4) - lin (n - 8, - 4) ( 4, -n + 8) - lin ( - 4, -n - 4) (n + 4, 4) - lin (n , - 4) ( 4, -n ) - ) - for 0 24 (\i -> for 0 16 (\j -> - when (even (i + j)) $ when (inside $ fromgrate (i, j)) $ - drawPiece dc (field g (i, j)) radius (st ! fromgrate (i, j)) - ) ) - case e of Just p' -> drawBrightPiece dc (field g $ tograte p') radius - Nothing -> return () - - onclick :: Point -> IO () - onclick point = do - t <- varGet vart - e <- varGet vare - g <- varGet varg - let Halma st = state t - n = fromgrate $ locate g point - case (e, inside n) of - (Nothing, True ) -> when (st ! n == Just (player t)) $ varSet vare (Just n) >> repaint p - (_ , False) -> varSet vare Nothing >> repaint p - (Just te, True ) -> case lookup (te, n) $ zip (allMoves pr (player t) st) [0..] of - Nothing -> varSet vare Nothing >> repaint p - Just i -> varSet vare Nothing >> repaint p >> move' i - - set p [ on click := onclick - , on unclick := onclick - , on paint := onpaint - , on resize ::= repaint - ] - - return () - -fit :: DC () -> (Int, Int) -> Int -> IO Int -fit dc t m = do - s <- get dc fontSize - fit_ dc (s + 6) - where - fit_ :: DC () -> Int -> IO Int - fit_ _dc 1 = border dc t - fit_ dc' s = do - set dc' [fontSize := s - 1] - b <- border dc t - if b <= m then return b - else fit_ dc' (s - 1) - -drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO () -drawPiece dc (Rect x y w h) r mp = circle dc (pt (x + w) (y + h `div` 2)) r [brushColor := col mp] - -drawBrightPiece :: DC () -> Rect -> Int -> IO () -drawBrightPiece dc (Rect x y w h) r = circle dc (pt (x + w) (y + h `div` 2)) r [brushKind := BrushTransparent, penWidth := 3, penColor := yellow] - -tograte :: (Int, Int) -> (Int, Int) -tograte (i, j) = (12 + 2 * i - j, 8 + j) - -fromgrate :: (Int, Int) -> (Int, Int) -fromgrate (i, j) = (-10 + (i + j) `div` 2, -8 + j) - --- x = ½ (i + j) - 10 --- y = j - 8 - -col :: Maybe Player -> Color -col p = case p of - Nothing -> white - Just 0 -> blue - Just 1 -> red - Just 2 -> green - Just 3 -> rgb 160 0 (192 :: Int) - Just 4 -> rgb 192 128 (0 :: Int) - Just 5 -> grey - _ -> black - -(+-) :: Num a => (a, a) -> (a, a) -> (a, a) -(a, b) +- (c, d) = (a + c, b + d) - -allMoves :: Properties -> Player -> Array (Int, Int) (Maybe Player) -> [HalmaMove] -allMoves pr p st | p == 0 && 20 `elem` (map totaldist [0 .. players pr - 1]) = [] - | otherwise = stepmoves ++ jumpmoves - where - mypieces :: Player -> [(Int, Int)] - mypieces p' = map (\(i, _e) -> i) $ filter (\(_i, e) -> e == Just p') $ assocs st - - stepmoves :: [HalmaMove] - stepmoves = let potmoves = concatMap (\t -> map (\s -> (t, t +- s)) $ steps pr p) (mypieces p) - in filter (\(_f, t) -> inside t && st ! t == Nothing) potmoves - - jumpmoves :: [HalmaMove] - jumpmoves = concatMap (\t -> map (\s -> (t, s)) $ floodfill t []) (mypieces p) - - floodfill :: (Int, Int) -> [(Int, Int)] -> [(Int, Int)] - floodfill t fs = let news = map (\j -> t +- j +- j) - $ filter (\j -> let u = t +- j +- j - in inside u - && st ! (t +- j) /= Nothing - && st ! u == Nothing - && not (u `elem` fs) - ) - $ halfjumps - in foldr ($) fs $ map (\u -> floodfill u . (u :)) news - totaldist :: Player -> Int - totaldist p' = sum $ map (dist pr p') $ mypieces p' - -steps :: Properties -> Player -> [(Int, Int)] -steps pr p = steppos (pos pr p) - where - steppos 0 = [( 1, 1), ( 1, 0), ( 0, -1), (-1, -1)] - steppos 1 = [( 0, 1), ( 1, 1), ( 1, 0), ( 0, -1)] - steppos 2 = [(-1, 0), ( 0, 1), ( 1, 1), ( 1, 0)] - steppos 3 = [(-1, -1), (-1, 0), ( 0, 1), ( 1, 1)] - steppos 4 = [( 0, -1), (-1, -1), (-1, 0), ( 0, 1)] - steppos 5 = [( 1, 0), ( 0, -1), (-1, -1), (-1, 0)] - steppos _ = error "steps: Unexpected value" - -{- -jumps :: [(Int, Int)] -jumps = map (\(x, y) -> (2 * x, 2 * y)) halfjumps --} - -halfjumps :: [(Int, Int)] -halfjumps = [(1, 1), (1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1)] - -dist :: Properties -> Player -> (Int, Int) -> Int -dist pr p t = distpos (pos pr p) t - where - distpos 0 (x, y) = 8 - x + y + max 0 (-4 + x ) + max 0 (-4 - y ) - distpos 1 (x, y) = 8 - x + max 0 (-4 + x - y) + max 0 (-4 + y ) - distpos 2 (x, y) = 8 - y + max 0 (-4 + x ) + max 0 (-4 + y - x) - distpos 3 (x, y) = 8 + x - y + max 0 (-4 - x ) + max 0 (-4 + y ) - distpos 4 (x, y) = 8 + x + max 0 (-4 - x + y) + max 0 (-4 - y ) - distpos 5 (x, y) = 8 + y + max 0 (-4 - x ) + max 0 (-4 - y + x) - distpos _ _ = error "dist: Unexpected value" - -move :: Properties -> HalmaMove -> (Player, Halma) -> (Player, Halma) -move pr (f, t) (p, Halma s) = ( (p + 1) `mod` players pr - , Halma $ s // [(f, Nothing), (t, Just p)] - ) - -startpos :: (Num t, Num t1, Enum t1) => t -> [(t1, t1)] -startpos 0 = [(x, y) | x <- [-4 .. -1], y <- [x + 5 .. 4]] -startpos 1 = [(x, y) | x <- [-8 .. -5], y <- [ - 4 .. x + 4]] -startpos 2 = [(x, y) | x <- [-4 .. -1], y <- [x - 4 .. - 5]] -startpos 3 = [(x, y) | x <- [ 1 .. 4], y <- [ - 4 .. x - 5]] -startpos 4 = [(x, y) | x <- [ 5 .. 8], y <- [x - 4 .. 4]] -startpos 5 = [(x, y) | x <- [ 1 .. 4], y <- [ 5 .. x + 4]] -startpos _ = error "startpos: Unexpected value" - -pos :: Properties -> Player -> Int -pos pr p | players pr == 2 = [0, 3 ] !! p - | players pr == 3 = [0, 2, 4 ] !! p - | players pr == 4 = [0, 1, 3, 4] !! p - | players pr == 6 = p - | otherwise = error "pos: Unexpected value" - -inside :: (Int, Int) -> Bool -inside (x, y) = (x >= -4 && y <= 4 && x <= y + 4) - || (y >= -4 && x <= 4 && y <= x + 4) - -{- the halmaboard internally looks like this: - -y/j - --8 ....x............ --7 ....xx........... --6 ....xxx.......... --5 ....xxxx......... --4 xxxx*****xxxx.... --3 .xxx******xxx.... --2 ..xx*******xx.... --1 ...x********x.... - 0 ....*********.... - 1 ....x********x... - 2 ....xx*******xx.. - 3 ....xxx******xxx. - 4 ....xxxx*****xxxx - 5 .........xxxx.... - 6 ..........xxx.... - 7 ...........xx.... - 8 ............x.... - - 87654321012345678 x/i - -------- - ++-----------+-- Halma --+-----------++module Halma (Halma, halma) where++import Game+import Data.Array+-- import Graphics.UI.WX+import Graphics.UI.WX hiding (border, empty, point)+import Graphics.UI.WXCore hiding (empty, point)+import Tools++data Halma = Halma (Array (Int, Int) (Maybe Player)) deriving (Eq, Show)++type HalmaMove = ((Int, Int), (Int, Int))++halma :: Halma+halma = undefined++instance Game Halma where++ name _ = "halma"++ standard _ = Properties { players = 2, boardsize = 8, human = [True, False, False, False, False, False] }+ possible _ = PropertyRange { playersrange = [2, 3, 4, 6], boardsizerange = [8] }++ new pr = let empty = [((x, y), Nothing) | x <- [-8 .. 8], y <- [-8 .. 8]]+ in Halma $ array ((-8, -8), (8, 8)) empty // concatMap (\p -> map (\t -> (t, Just p)) $ startpos $ pos pr p) [0 .. players pr - 1]+ + moves pr p (Halma s) = map (move pr) (allMoves pr p s)++ showmove pr p (Halma s) i = let ((x1, y1), (x2, y2)) = allMoves pr p s !! i+ in "abcdefghijklmnopq" !! (x1 + 8) : show (9 - y1) ++ "-" ++ "abcdefghijklmnopq" !! (x2 + 8) : show (9 - y2)+ + value pr p (Halma st) | null $ allMoves pr p st = let winners = map snd $ filter (\(d, _) -> d == 20) $ zip totaldists [0..]+ in foldr ($) (replicate (players pr) (-1)) $ map (|> 1) winners+ | otherwise = map myvalue [0 .. players pr - 1]+ where+ totaldists :: [Int]+ totaldists = map totaldist [0 .. players pr - 1]++ totaldist :: Player -> Int+ totaldist p' = let mypieces = map (\(i, _e) -> i) $ filter (\(_i, e) -> e == Just p') $ assocs st+ in sum $ map (dist pr p') mypieces++ myvalue :: Player -> Float+ myvalue p' = let d = sum (map totaldist [0 .. players pr - 1]) - (players pr) * totaldist p'+ in (fromInteger . toInteger) d / (fromInteger . toInteger) (120 * (players pr))++ board p pr vart _ia move' = do++ marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY+ varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero+ vare <- varCreate (Nothing :: Maybe (Int, Int))++ let + + onpaint :: DC () -> Rect -> IO ()+ onpaint dc r = do+ t <- varGet vart+ e <- varGet vare+ b_ <- border dc (16, 16)+ let g_ = grate r b_ (26, 17) (Size 4 7)+ b <- fit dc (16, 16) $ rectWidth (field g_ (0, 0))+ let Halma st = state t+ g = grate r b (26, 17) (Size 4 7)+ radius = rectHeight (field g (0, 0)) `div` 3+ lin' :: Rect -> Rect -> IO ()+ lin' (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = do+ line dc (pt (x1 + w1) (y1 + h1 `div` 2)) (pt (x2 + w2) (y2 + h2 `div` 2)) []+ lin :: (Int, Int) -> (Int, Int) -> IO ()+ lin p' q = lin' (field g $ tograte p') (field g $ tograte q)+ varSet varg g+ tileBitmap dc r marble+--{ drawGrate dc g [penColor := yellow]+ for 0 16 (\j -> do+ let i = head $ dropWhile (\i' -> inside $ fromgrate (i', j)) [13 ..]+ drawTextRect dc (show $ 17 - j) $ field g ( i - 1, j) |#| field g ( i, j)+ drawTextRect dc (show $ 17 - j) $ field g (25 - i, j) |#| field g (26 - i, j)+ let d = (i - 1 + 3 * j) `div` 2 - 18+ e' = (25 - i + 3 * j) `div` 2 - 18+ drawTextRect dc [['A' ..] !! (16 - j)] $ field g (i - 1 - d, j - d) |#| field g (i - 1 - d, j - 1 - d)+ drawTextRect dc [['A' ..] !! (16 - j)] $ field g (25 - i - e', j - e') |#| field g (25 - i - e', j - 1 - e')+ )+ for 0 4 (\n -> do+ lin ( - 4, n - 8) (n - 4, n - 8)+ lin (n - 8, n - 4) ( 4, n - 4)+ lin ( - 4, n ) (n + 4, n )+ lin (n , n + 4) ( 4, n + 4)+ lin (n - 8, - 4) (n - 8, n - 4)+ lin (n - 4, n - 8) (n - 4, 4)+ lin (n , - 4) (n , n + 4)+ lin (n + 4, n ) (n + 4, 4)+ lin ( - 4, -n + 4) (n - 4, 4)+ lin (n - 8, - 4) ( 4, -n + 8)+ lin ( - 4, -n - 4) (n + 4, 4)+ lin (n , - 4) ( 4, -n )+ )+ for 0 24 (\i -> for 0 16 (\j ->+ when (even (i + j)) $ when (inside $ fromgrate (i, j)) $+ drawPiece dc (field g (i, j)) radius (st ! fromgrate (i, j))+ ) )+ case e of Just p' -> drawBrightPiece dc (field g $ tograte p') radius+ Nothing -> return ()+ + onclick :: Point -> IO ()+ onclick point = do + t <- varGet vart+ e <- varGet vare+ g <- varGet varg+ let Halma st = state t+ n = fromgrate $ locate g point + case (e, inside n) of+ (Nothing, True ) -> when (st ! n == Just (player t)) $ varSet vare (Just n) >> repaint p+ (_ , False) -> varSet vare Nothing >> repaint p+ (Just te, True ) -> case lookup (te, n) $ zip (allMoves pr (player t) st) [0..] of+ Nothing -> varSet vare Nothing >> repaint p+ Just i -> varSet vare Nothing >> repaint p >> move' i++ set p [ on click := onclick+ , on unclick := onclick+ , on paint := onpaint+ , on resize ::= repaint+ ]++ return ()++fit :: DC () -> (Int, Int) -> Int -> IO Int+fit dc t m = do+ s <- get dc fontSize+ fit_ dc (s + 6)+ where+ fit_ :: DC () -> Int -> IO Int+ fit_ _dc 1 = border dc t+ fit_ dc' s = do+ set dc' [fontSize := s - 1]+ b <- border dc t+ if b <= m then return b+ else fit_ dc' (s - 1)++drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO ()+drawPiece dc (Rect x y w h) r mp = circle dc (pt (x + w) (y + h `div` 2)) r [brushColor := col mp]++drawBrightPiece :: DC () -> Rect -> Int -> IO ()+drawBrightPiece dc (Rect x y w h) r = circle dc (pt (x + w) (y + h `div` 2)) r [brushKind := BrushTransparent, penWidth := 3, penColor := yellow]++tograte :: (Int, Int) -> (Int, Int)+tograte (i, j) = (12 + 2 * i - j, 8 + j)++fromgrate :: (Int, Int) -> (Int, Int)+fromgrate (i, j) = (-10 + (i + j) `div` 2, -8 + j)++-- x = ½ (i + j) - 10+-- y = j - 8++col :: Maybe Player -> Color+col p = case p of + Nothing -> white+ Just 0 -> blue+ Just 1 -> red+ Just 2 -> green+ Just 3 -> rgb 160 0 (192 :: Int)+ Just 4 -> rgb 192 128 (0 :: Int)+ Just 5 -> grey+ _ -> black++(+-) :: Num a => (a, a) -> (a, a) -> (a, a)+(a, b) +- (c, d) = (a + c, b + d)++allMoves :: Properties -> Player -> Array (Int, Int) (Maybe Player) -> [HalmaMove]+allMoves pr p st | p == 0 && 20 `elem` (map totaldist [0 .. players pr - 1]) = []+ | otherwise = stepmoves ++ jumpmoves+ where+ mypieces :: Player -> [(Int, Int)]+ mypieces p' = map (\(i, _e) -> i) $ filter (\(_i, e) -> e == Just p') $ assocs st++ stepmoves :: [HalmaMove]+ stepmoves = let potmoves = concatMap (\t -> map (\s -> (t, t +- s)) $ steps pr p) (mypieces p)+ in filter (\(_f, t) -> inside t && st ! t == Nothing) potmoves++ jumpmoves :: [HalmaMove]+ jumpmoves = concatMap (\t -> map (\s -> (t, s)) $ floodfill t []) (mypieces p)++ floodfill :: (Int, Int) -> [(Int, Int)] -> [(Int, Int)]+ floodfill t fs = let news = map (\j -> t +- j +- j)+ $ filter (\j -> let u = t +- j +- j+ in inside u + && st ! (t +- j) /= Nothing+ && st ! u == Nothing+ && not (u `elem` fs)+ )+ $ halfjumps+ in foldr ($) fs $ map (\u -> floodfill u . (u :)) news+ totaldist :: Player -> Int+ totaldist p' = sum $ map (dist pr p') $ mypieces p'++steps :: Properties -> Player -> [(Int, Int)]+steps pr p = steppos (pos pr p)+ where+ steppos 0 = [( 1, 1), ( 1, 0), ( 0, -1), (-1, -1)]+ steppos 1 = [( 0, 1), ( 1, 1), ( 1, 0), ( 0, -1)]+ steppos 2 = [(-1, 0), ( 0, 1), ( 1, 1), ( 1, 0)]+ steppos 3 = [(-1, -1), (-1, 0), ( 0, 1), ( 1, 1)]+ steppos 4 = [( 0, -1), (-1, -1), (-1, 0), ( 0, 1)]+ steppos 5 = [( 1, 0), ( 0, -1), (-1, -1), (-1, 0)]+ steppos _ = error "steps: Unexpected value"++{-+jumps :: [(Int, Int)]+jumps = map (\(x, y) -> (2 * x, 2 * y)) halfjumps+-}++halfjumps :: [(Int, Int)]+halfjumps = [(1, 1), (1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1)]++dist :: Properties -> Player -> (Int, Int) -> Int+dist pr p t = distpos (pos pr p) t+ where+ distpos 0 (x, y) = 8 - x + y + max 0 (-4 + x ) + max 0 (-4 - y )+ distpos 1 (x, y) = 8 - x + max 0 (-4 + x - y) + max 0 (-4 + y )+ distpos 2 (x, y) = 8 - y + max 0 (-4 + x ) + max 0 (-4 + y - x)+ distpos 3 (x, y) = 8 + x - y + max 0 (-4 - x ) + max 0 (-4 + y )+ distpos 4 (x, y) = 8 + x + max 0 (-4 - x + y) + max 0 (-4 - y )+ distpos 5 (x, y) = 8 + y + max 0 (-4 - x ) + max 0 (-4 - y + x)+ distpos _ _ = error "dist: Unexpected value"++move :: Properties -> HalmaMove -> (Player, Halma) -> (Player, Halma)+move pr (f, t) (p, Halma s) = ( (p + 1) `mod` players pr+ , Halma $ s // [(f, Nothing), (t, Just p)]+ )++startpos :: (Eq t, Num t, Num t1, Enum t1) => t -> [(t1, t1)]+startpos 0 = [(x, y) | x <- [-4 .. -1], y <- [x + 5 .. 4]]+startpos 1 = [(x, y) | x <- [-8 .. -5], y <- [ - 4 .. x + 4]]+startpos 2 = [(x, y) | x <- [-4 .. -1], y <- [x - 4 .. - 5]]+startpos 3 = [(x, y) | x <- [ 1 .. 4], y <- [ - 4 .. x - 5]]+startpos 4 = [(x, y) | x <- [ 5 .. 8], y <- [x - 4 .. 4]]+startpos 5 = [(x, y) | x <- [ 1 .. 4], y <- [ 5 .. x + 4]]+startpos _ = error "startpos: Unexpected value"++pos :: Properties -> Player -> Int+pos pr p | players pr == 2 = [0, 3 ] !! p+ | players pr == 3 = [0, 2, 4 ] !! p+ | players pr == 4 = [0, 1, 3, 4] !! p+ | players pr == 6 = p+ | otherwise = error "pos: Unexpected value"++inside :: (Int, Int) -> Bool+inside (x, y) = (x >= -4 && y <= 4 && x <= y + 4)+ || (y >= -4 && x <= 4 && y <= x + 4)++{- the halmaboard internally looks like this:++y/j++-8 ....x............+-7 ....xx...........+-6 ....xxx..........+-5 ....xxxx.........+-4 xxxx*****xxxx....+-3 .xxx******xxx....+-2 ..xx*******xx....+-1 ...x********x....+ 0 ....*********....+ 1 ....x********x...+ 2 ....xx*******xx..+ 3 ....xxx******xxx.+ 4 ....xxxx*****xxxx+ 5 .........xxxx....+ 6 ..........xxx....+ 7 ...........xx....+ 8 ............x....++ 87654321012345678 x/i+ --------+ -}
Hex.hs view
@@ -1,181 +1,181 @@- - -{-{ http://en2.wikipedia.org/wiki/Hex_(game) }-} - - ---------- --- Hex -- ---------- - -module Hex (Hex, hex) where - -import Game -import Array -import Graphics.UI.WX hiding (border, point) -import Graphics.UI.WXCore hiding (point) -import Tools - -data Hex = Hex (Array (Int, Int) (Maybe Player)) deriving (Eq, Show) - -type HexMove = (Int, Int) - -hex :: Hex -hex = undefined - -instance Game Hex where - - name _ = "hex" - - standard _ = Properties { players = 2, boardsize = 11, human = [True, False] } - possible _ = PropertyRange { playersrange = [2], boardsizerange = [5 .. 15] } - - new pr = let bsz = boardsize pr - in Hex $ array ((0, 0), (bsz - 1, bsz - 1)) [((x, y), Nothing) | x <- [0 .. bsz - 1], y <- [0 .. bsz - 1]] - - moves pr p (Hex st) = map (move pr) (allMoves pr p st) - - showmove pr p (Hex s) i = case allMoves pr p s !! i - of (x, y) -> ['a' ..] !! x : show (1 + y) - - value pr _p (Hex st) - | win st (boardsize pr) 0 = [ 1, -1] - | win st (boardsize pr) 1 = [-1, 1] - | otherwise = [ 0, 0] - - - 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 Hex st = state t - bsz = boardsize pr - b <- border dc (bsz, bsz) - let g = grate r b (2 * bsz + 1, 2 * bsz + 2) (Size 7 4) - radius = rectWidth (field g (0, 0)) `div` 3 - lin' :: Rect -> Rect -> Color -> IO () - lin' (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) c = do - line dc (pt (x1 + w1 `div` 2) (y1 + h1)) (pt (x2 + w2 `div` 2) (y2 + h2)) [penWidth := 4, penColor := c] - lin :: (Int, Int) -> (Int, Int) -> Color -> IO () - lin p' q = lin' (field g $ tograte bsz p') (field g $ tograte bsz q) - varSet varg g - tileBitmap dc r marble ---{ drawGrate dc g [penColor := yellow] - for 0 (bsz - 1) (\i -> do - drawTextRect dc [['A' ..] !! i] $ field g (bsz + 2 + i, 2 * bsz + 1 - i) |#| field g (bsz + 2 + i, 2 * bsz + 2 - i) - drawTextRect dc (show (i + 1)) $ field g (bsz - 2 - i, 2 * bsz + 1 - i) |#| field g (bsz - 2 - i, 2 * bsz + 2 - i) - ) - lin (0, -1) (bsz - 1, -1) blue - lin (0, bsz) (bsz - 1, bsz) blue - lin (-1, 0) (-1, bsz - 1) red - lin (bsz, 0) (bsz, bsz - 1) red - for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j -> - drawPiece dc (field g $ tograte bsz (i, j)) radius (st ! (i, j)) - ) ) - - onclick :: Point -> IO () - onclick point = do - t <- varGet vart - g <- varGet varg - let Hex st = state t - bsz = boardsize pr - n = fromgrate bsz $ locate g point - case lookup n $ zip (allMoves pr (player t) st) [0..] of - Nothing -> return () - Just i -> move' i - - set p [ on click := onclick - , on paint := onpaint - , on resize ::= repaint - ] - - return () - -drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO () -drawPiece dc (Rect x y w h) r mp = do - circle dc (pt (x + w `div` 2) (y + h)) (max 1 (r `div` 5)) [brushColor := black] - case mp of Just 0 -> circle dc (pt (x + w `div` 2) (y + h)) r [brushKind := BrushTransparent, penColor := blue, penWidth := 3] - Just 1 -> circle dc (pt (x + w `div` 2) (y + h)) r [brushKind := BrushTransparent, penColor := red , penWidth := 3] - Nothing -> return () - _ -> error "drawPiece: Unexpected value" - -tograte :: Int -> (Int, Int) -> (Int, Int) -tograte bsz (i, j) = (bsz + i - j, 2 * bsz - 1 - i - j) - -fromgrate :: Int -> (Int, Int) -> (Int, Int) -fromgrate bsz (i, j) = ((bsz + i - j) `div` 2, (3 * bsz - i - j) `div` 2) - -{- -i = s - 1 + x - y -j = 2s - 2 - x - y - -i + j = 3s - 3 - 2y -2y = 3s - 3 - i - j -y = (...) / 2 - -i - j = -s + 1 + 2x -2x = s - 1 + i - j --} - -(+-) :: Num a => (a, a) -> (a, a) -> (a, a) -(a, b) +- (c, d) = (a + c, b + d) - -allMoves :: Properties -> Player -> Array (Int, Int) (Maybe Player) -> [HexMove] -allMoves pr p st - | win st (boardsize pr) (1 - p) = [] - | otherwise = map fst $ filter ((== Nothing) . snd) $ assocs st - -move :: Properties -> HexMove -> (Player, Hex) -> (Player, Hex) -move _pr place (p, Hex s) = (1 - p, Hex $ s // [(place, Just p)]) - -win :: Array (Int, Int) (Maybe Player) -> Int -> Player -> Bool -win st bsz 0 = any ((== bsz - 1) . snd) $ floodfill st 0 (zip [0 .. bsz - 1] [-1, -1 ..]) -win st bsz 1 = any ((== bsz - 1) . fst) $ floodfill st 1 (zip [-1, -1 ..] [0 .. bsz - 1]) -win _ _ _ = error "win: Unexpected value" - -floodfill :: Array (Int, Int) (Maybe Player) -> Player -> [(Int, Int)] -> [(Int, Int)] -floodfill st p togo = floodfill_ p togo [] - where - floodfill_ :: Player -> [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)] - floodfill_ _ [] known = known - floodfill_ p' (f : togo') known = let new' = filter (not . flip elem known) $ map (f +-) steps - good = filter (\f' -> st ! f' == Just p') $ filter (inRange (bounds st)) new' - in floodfill_ p' (togo' ++ good) (known ++ good) - -steps :: [(Int, Int)] -steps = [(1, 1), (1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1)] - -{- -jumps :: [((Int, Int), [(Int, Int)])] -jumps = [ (( 2, 1), [( 1, 0), ( 1, 1)]) - , (( 1, 2), [( 0, 1), ( 1, 1)]) - , ((-1, 1), [( 0, 1), (-1, 0)]) - , ((-2, -1), [(-1, 0), (-1, -1)]) - , ((-1, -2), [( 0, -1), (-1, -1)]) - , (( 1, -1), [( 1, 0), ( 0, -1)]) - ] --} - -{- the hexboard internally look like this: - - - * - * * - * * * - * * * * - * * * * * - * * * * * * -* * * * * * * - * * * * * * - j * * * i - * * * * - 2 * 2 - 1 1 - 0 - +++{-{ http://en2.wikipedia.org/wiki/Hex_(game) }-}+++---------+-- Hex --+---------++module Hex (Hex, hex) where++import Game+import Data.Array+import Graphics.UI.WX hiding (border, point)+import Graphics.UI.WXCore hiding (point)+import Tools++data Hex = Hex (Array (Int, Int) (Maybe Player)) deriving (Eq, Show)++type HexMove = (Int, Int)++hex :: Hex+hex = undefined++instance Game Hex where++ name _ = "hex"++ standard _ = Properties { players = 2, boardsize = 11, human = [True, False] }+ possible _ = PropertyRange { playersrange = [2], boardsizerange = [5 .. 15] }++ new pr = let bsz = boardsize pr+ in Hex $ array ((0, 0), (bsz - 1, bsz - 1)) [((x, y), Nothing) | x <- [0 .. bsz - 1], y <- [0 .. bsz - 1]]+ + moves pr p (Hex st) = map (move pr) (allMoves pr p st)++ showmove pr p (Hex s) i = case allMoves pr p s !! i+ of (x, y) -> ['a' ..] !! x : show (1 + y)++ value pr _p (Hex st) + | win st (boardsize pr) 0 = [ 1, -1]+ | win st (boardsize pr) 1 = [-1, 1]+ | otherwise = [ 0, 0]+++ 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 Hex st = state t+ bsz = boardsize pr+ b <- border dc (bsz, bsz)+ let g = grate r b (2 * bsz + 1, 2 * bsz + 2) (Size 7 4)+ radius = rectWidth (field g (0, 0)) `div` 3+ lin' :: Rect -> Rect -> Color -> IO ()+ lin' (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) c = do+ line dc (pt (x1 + w1 `div` 2) (y1 + h1)) (pt (x2 + w2 `div` 2) (y2 + h2)) [penWidth := 4, penColor := c]+ lin :: (Int, Int) -> (Int, Int) -> Color -> IO ()+ lin p' q = lin' (field g $ tograte bsz p') (field g $ tograte bsz q)+ varSet varg g+ tileBitmap dc r marble+--{ drawGrate dc g [penColor := yellow]+ for 0 (bsz - 1) (\i -> do+ drawTextRect dc [['A' ..] !! i] $ field g (bsz + 2 + i, 2 * bsz + 1 - i) |#| field g (bsz + 2 + i, 2 * bsz + 2 - i)+ drawTextRect dc (show (i + 1)) $ field g (bsz - 2 - i, 2 * bsz + 1 - i) |#| field g (bsz - 2 - i, 2 * bsz + 2 - i)+ )+ lin (0, -1) (bsz - 1, -1) blue+ lin (0, bsz) (bsz - 1, bsz) blue+ lin (-1, 0) (-1, bsz - 1) red+ lin (bsz, 0) (bsz, bsz - 1) red+ for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->+ drawPiece dc (field g $ tograte bsz (i, j)) radius (st ! (i, j))+ ) )++ onclick :: Point -> IO ()+ onclick point = do + t <- varGet vart+ g <- varGet varg+ let Hex st = state t+ bsz = boardsize pr+ n = fromgrate bsz $ locate g point + case lookup n $ zip (allMoves pr (player t) st) [0..] of+ Nothing -> return ()+ Just i -> move' i++ set p [ on click := onclick+ , on paint := onpaint+ , on resize ::= repaint+ ]++ return ()++drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO ()+drawPiece dc (Rect x y w h) r mp = do+ circle dc (pt (x + w `div` 2) (y + h)) (max 1 (r `div` 5)) [brushColor := black]+ case mp of Just 0 -> circle dc (pt (x + w `div` 2) (y + h)) r [brushKind := BrushTransparent, penColor := blue, penWidth := 3]+ Just 1 -> circle dc (pt (x + w `div` 2) (y + h)) r [brushKind := BrushTransparent, penColor := red , penWidth := 3]+ Nothing -> return ()+ _ -> error "drawPiece: Unexpected value"++tograte :: Int -> (Int, Int) -> (Int, Int)+tograte bsz (i, j) = (bsz + i - j, 2 * bsz - 1 - i - j)++fromgrate :: Int -> (Int, Int) -> (Int, Int)+fromgrate bsz (i, j) = ((bsz + i - j) `div` 2, (3 * bsz - i - j) `div` 2)++{-+i = s - 1 + x - y+j = 2s - 2 - x - y++i + j = 3s - 3 - 2y+2y = 3s - 3 - i - j+y = (...) / 2++i - j = -s + 1 + 2x+2x = s - 1 + i - j+-}++(+-) :: Num a => (a, a) -> (a, a) -> (a, a)+(a, b) +- (c, d) = (a + c, b + d)++allMoves :: Properties -> Player -> Array (Int, Int) (Maybe Player) -> [HexMove]+allMoves pr p st + | win st (boardsize pr) (1 - p) = []+ | otherwise = map fst $ filter ((== Nothing) . snd) $ assocs st++move :: Properties -> HexMove -> (Player, Hex) -> (Player, Hex)+move _pr place (p, Hex s) = (1 - p, Hex $ s // [(place, Just p)])++win :: Array (Int, Int) (Maybe Player) -> Int -> Player -> Bool+win st bsz 0 = any ((== bsz - 1) . snd) $ floodfill st 0 (zip [0 .. bsz - 1] [-1, -1 ..])+win st bsz 1 = any ((== bsz - 1) . fst) $ floodfill st 1 (zip [-1, -1 ..] [0 .. bsz - 1])+win _ _ _ = error "win: Unexpected value"+ +floodfill :: Array (Int, Int) (Maybe Player) -> Player -> [(Int, Int)] -> [(Int, Int)]+floodfill st p togo = floodfill_ p togo []+ where+ floodfill_ :: Player -> [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]+ floodfill_ _ [] known = known+ floodfill_ p' (f : togo') known = let new' = filter (not . flip elem known) $ map (f +-) steps+ good = filter (\f' -> st ! f' == Just p') $ filter (inRange (bounds st)) new'+ in floodfill_ p' (togo' ++ good) (known ++ good)++steps :: [(Int, Int)]+steps = [(1, 1), (1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1)]++{-+jumps :: [((Int, Int), [(Int, Int)])]+jumps = [ (( 2, 1), [( 1, 0), ( 1, 1)])+ , (( 1, 2), [( 0, 1), ( 1, 1)])+ , ((-1, 1), [( 0, 1), (-1, 0)])+ , ((-2, -1), [(-1, 0), (-1, -1)])+ , ((-1, -2), [( 0, -1), (-1, -1)])+ , (( 1, -1), [( 1, 0), ( 0, -1)])+ ]+-}++{- the hexboard internally look like this:+++ *+ * *+ * * *+ * * * *+ * * * * *+ * * * * * *+* * * * * * *+ * * * * * *+ j * * * i+ * * * *+ 2 * 2+ 1 1+ 0 + -}
Inf.hs view
@@ -1,56 +1,56 @@- ---------- --- Inf -- ---------- - -module Inf - ( Inf - , inf, fin - ) where - -data Inf a - = Finite a - | Infinite Bool - deriving Eq - -instance Show a => Show (Inf a) where - show (Finite x) = show x - show (Infinite True ) = "<+inf>" - show (Infinite False) = "<-inf>" - -instance Ord a => Ord (Inf a) where - compare (Finite x ) (Finite y) = compare x y - compare (Infinite b ) (Infinite c) = compare b c - compare (Infinite True ) _ = GT - compare (Infinite False) _ = LT - compare _ (Infinite True ) = LT - compare _ (Infinite False) = GT - -instance Num a => Num (Inf a) where - Finite x + Finite y = Finite (x + y) - Infinite True + Infinite False = error "<+inf> + <-inf>" - Infinite False + Infinite True = error "<-inf> + <+inf>" - Infinite True + _ = Infinite True - Infinite False + _ = Infinite False - _ + Infinite True = Infinite True - _ + Infinite False = Infinite False - Finite x * Finite y = Finite (x * y) - Infinite b * Infinite c = Infinite (b == c) - Infinite _ * Finite 0 = error "<inf> * 0" - Finite 0 * Infinite _ = error "0 * <inf>" - Infinite b * Finite x = Infinite (b == (signum x == 1)) - Finite x * Infinite b = Infinite ((signum x == 1) == b) - negate (Infinite b ) = Infinite (not b) - negate (Finite x ) = Finite (negate x) - signum (Infinite True ) = 1 - signum (Infinite False) = -1 - signum (Finite x ) = Finite (signum x) - abs (Infinite _ ) = Infinite True - abs (Finite x ) = Finite (abs x) - fromInteger x = Finite (fromInteger x) - -fin :: a -> Inf a -fin = Finite - -inf :: Inf a ++---------+-- Inf --+---------++module Inf+ ( Inf+ , inf, fin+ ) where++data Inf a+ = Finite a+ | Infinite Bool+ deriving Eq++instance Show a => Show (Inf a) where+ show (Finite x) = show x+ show (Infinite True ) = "<+inf>"+ show (Infinite False) = "<-inf>"++instance Ord a => Ord (Inf a) where+ compare (Finite x ) (Finite y) = compare x y+ compare (Infinite b ) (Infinite c) = compare b c+ compare (Infinite True ) _ = GT+ compare (Infinite False) _ = LT+ compare _ (Infinite True ) = LT+ compare _ (Infinite False) = GT++instance (Num a, Eq a) => Num (Inf a) where+ Finite x + Finite y = Finite (x + y)+ Infinite True + Infinite False = error "<+inf> + <-inf>"+ Infinite False + Infinite True = error "<-inf> + <+inf>"+ Infinite True + _ = Infinite True+ Infinite False + _ = Infinite False+ _ + Infinite True = Infinite True+ _ + Infinite False = Infinite False+ Finite x * Finite y = Finite (x * y)+ Infinite b * Infinite c = Infinite (b == c)+ Infinite _ * Finite 0 = error "<inf> * 0"+ Finite 0 * Infinite _ = error "0 * <inf>"+ Infinite b * Finite x = Infinite (b == (signum x == 1))+ Finite x * Infinite b = Infinite ((signum x == 1) == b)+ negate (Infinite b ) = Infinite (not b)+ negate (Finite x ) = Finite (negate x)+ signum (Infinite True ) = 1+ signum (Infinite False) = -1+ signum (Finite x ) = Finite (signum x)+ abs (Infinite _ ) = Infinite True+ abs (Finite x ) = Finite (abs x)+ fromInteger x = Finite (fromInteger x)+ +fin :: a -> Inf a +fin = Finite++inf :: Inf a inf = Infinite True
Kram.hs view
@@ -1,129 +1,129 @@- ----------- --- Kram -- ----------- - -module Kram (Kram, kram) where - -import Game -import Array -import Graphics.UI.WX hiding (border, point) -import Graphics.UI.WXCore hiding (point) -import Tools - -data Kram = Kram (Array (Int, Int) (Either Player Bool)) deriving (Eq, Show) - -kram :: Kram -kram = undefined - -instance Game Kram where - - name _ = "kram" - - standard _ = Properties { players = 2, boardsize = 5, human = [True, False] } - - possible _ = PropertyRange { playersrange = [2], boardsizerange = [4 .. 7] } - - new pr = let s = boardsize pr - in Kram $ array ((0, 0), (s - 1, s - 1)) [((x, y), Right False) | x <- [0 .. s - 1], y <- [0 .. s - 1]] - - moves pr p (Kram s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s) - - showmove pr p (Kram s) i = case allMoves (boardsize pr) p s !! i - of Nothing -> "skip turn" - Just (x, y) -> sm (x, y) ++ ":" ++ case p - of 0 -> sm (x + 1, y) - 1 -> sm (x, y + 1) - _ -> "error" - where - sm :: (Int, Int) -> String - sm (x, y) = "abcdefghij" !! x : show (boardsize pr - y) - - value pr p (Kram s) - | null $ moves pr p (Kram 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]) $ open + count (elems s) - where - open :: Int - open = length (moves pr 0 (Kram s)) - length (moves pr 1 (Kram s)) - count :: [Either Player Bool] -> Int - count [] = 0 - count (Right _ : fs) = count fs - count (Left 0 : fs) = 1 + count fs - count (Left 1 : fs) = -1 + count fs - count _ = error "count: 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 Kram 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 Left p' -> drawPiece p' dc (field g (i, j)) - Right _ -> 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 Kram 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 0 dc (Rect x y w h) = do - set dc [brushColor := rgb 96 16 (255 :: Int) ] - drawRect dc (Rect (x + w `div` 10) (y + h `div` 10) (2 * w - w `div` 5) (h - h `div` 5)) [] -drawPiece 1 dc (Rect x y w h) = do - set dc [brushColor := rgb 192 64 (16 :: Int) ] - drawRect dc (Rect (x + w `div` 10) (y + h `div` 10) (w - w `div` 5) (2 * h - h `div` 5)) [] -drawPiece _ _ _ = error "drawPiece: unexpected value" - -allMoves :: Int -> Player -> Array (Int, Int) (Either Player Bool) -> [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) (Either Player Bool) -> [(Int, Int)] - valid p' s' = filter mag $ indices s' - where - mag :: (Int, Int) -> Bool - mag (x, y) | p' == 0 = x < bsz - 1 && s' ! (x, y) == Right False && s' ! (x + 1, y) == Right False - mag (x, y) | p' == 1 = y < bsz - 1 && s' ! (x, y) == Right False && s' ! (x, y + 1) == Right False - mag _ = error "mag: Unexpected value" - -move :: Int -> Maybe (Int, Int) -> (Player, Kram) -> (Player, Kram) -move _bsz (Just (x, y)) (0, Kram s) = (1, Kram $ s // [((x, y), Left 0), ((x + 1, y), Right True)]) -move _bsz (Just (x, y)) (1, Kram s) = (0, Kram $ s // [((x, y), Left 1), ((x, y + 1), Right True)]) -move _ Nothing (p, ks) = (1 - p, ks) -move _ _ _ = error "move: Unexpected value" ++----------+-- Kram --+----------++module Kram (Kram, kram) where++import Game+import Data.Array+import Graphics.UI.WX hiding (border, point)+import Graphics.UI.WXCore hiding (point)+import Tools++data Kram = Kram (Array (Int, Int) (Either Player Bool)) deriving (Eq, Show)++kram :: Kram+kram = undefined++instance Game Kram where++ name _ = "kram"++ standard _ = Properties { players = 2, boardsize = 5, human = [True, False] }++ possible _ = PropertyRange { playersrange = [2], boardsizerange = [4 .. 7] }+ + new pr = let s = boardsize pr+ in Kram $ array ((0, 0), (s - 1, s - 1)) [((x, y), Right False) | x <- [0 .. s - 1], y <- [0 .. s - 1]]+ + moves pr p (Kram s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s)++ showmove pr p (Kram s) i = case allMoves (boardsize pr) p s !! i+ of Nothing -> "skip turn"+ Just (x, y) -> sm (x, y) ++ ":" ++ case p+ of 0 -> sm (x + 1, y)+ 1 -> sm (x, y + 1)+ _ -> "error"+ where+ sm :: (Int, Int) -> String+ sm (x, y) = "abcdefghij" !! x : show (boardsize pr - y)+ + value pr p (Kram s) + | null $ moves pr p (Kram 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]) $ open + count (elems s)+ where+ open :: Int+ open = length (moves pr 0 (Kram s)) - length (moves pr 1 (Kram s))+ count :: [Either Player Bool] -> Int+ count [] = 0+ count (Right _ : fs) = count fs+ count (Left 0 : fs) = 1 + count fs+ count (Left 1 : fs) = -1 + count fs+ count _ = error "count: 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 Kram 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 Left p' -> drawPiece p' dc (field g (i, j))+ Right _ -> 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 Kram 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 0 dc (Rect x y w h) = do+ set dc [brushColor := rgb 96 16 (255 :: Int) ]+ drawRect dc (Rect (x + w `div` 10) (y + h `div` 10) (2 * w - w `div` 5) (h - h `div` 5)) []+drawPiece 1 dc (Rect x y w h) = do+ set dc [brushColor := rgb 192 64 (16 :: Int) ]+ drawRect dc (Rect (x + w `div` 10) (y + h `div` 10) (w - w `div` 5) (2 * h - h `div` 5)) []+drawPiece _ _ _ = error "drawPiece: unexpected value"++allMoves :: Int -> Player -> Array (Int, Int) (Either Player Bool) -> [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) (Either Player Bool) -> [(Int, Int)]+ valid p' s' = filter mag $ indices s'+ where+ mag :: (Int, Int) -> Bool+ mag (x, y) | p' == 0 = x < bsz - 1 && s' ! (x, y) == Right False && s' ! (x + 1, y) == Right False + mag (x, y) | p' == 1 = y < bsz - 1 && s' ! (x, y) == Right False && s' ! (x, y + 1) == Right False + mag _ = error "mag: Unexpected value"++move :: Int -> Maybe (Int, Int) -> (Player, Kram) -> (Player, Kram)+move _bsz (Just (x, y)) (0, Kram s) = (1, Kram $ s // [((x, y), Left 0), ((x + 1, y), Right True)])+move _bsz (Just (x, y)) (1, Kram s) = (0, Kram $ s // [((x, y), Left 1), ((x, y + 1), Right True)])+move _ Nothing (p, ks) = (1 - p, ks)+move _ _ _ = error "move: Unexpected value"
LICENSE.txt view
@@ -1,24 +1,24 @@-Copyright (c) 2003, 2004 Maarten Löffler -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. The name of the author may not be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +Copyright (c) 2003, 2004 Maarten Löffler+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The name of the author may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Main.hs view
@@ -1,44 +1,44 @@- ----------- --- MAIN -- ----------- - -module Main where - -import Game -import Graphics.UI.WX -import GUI - -import Ataxx -import Bamp -import Halma -import Hex -import Kram -import Nim -import Reversi -import TicTacToe -import Zenix - -import System.Directory (setCurrentDirectory) -import Paths_GeBoP (getDataDir) - -games :: [GeneralGame] -games = [ Game ataxx - , Game bamp - , Game halma - , Game hex - , Game kram - , Game nim - , Game reversi - , Game tictactoe - , Game zenix - ] - -main :: IO () -main = - getDataDir >>= - setCurrentDirectory >> - start (gui games) - -exit :: IO () -exit = putStrLn "When will you learn you have to use :q?" ++----------+-- MAIN --+----------++module Main where++import Game+import Graphics.UI.WX+import GUI++import Ataxx+import Bamp+import Halma+import Hex+import Kram+import Nim+import Reversi+import TicTacToe+import Zenix++import System.Directory (setCurrentDirectory)+import Paths_GeBoP (getDataDir)++games :: [GeneralGame]+games = [ Game ataxx+ , Game bamp+ , Game halma+ , Game hex+ , Game kram+ , Game nim+ , Game reversi+ , Game tictactoe+ , Game zenix+ ]++main :: IO ()+main =+ getDataDir >>=+ setCurrentDirectory >> + start (gui games)++exit :: IO ()+exit = putStrLn "When will you learn you have to use :q?"
Nim.hs view
@@ -1,81 +1,81 @@- ---------- --- NIM -- ---------- - -module Nim (Nim, nim) where - -import Game -import Graphics.UI.WX --- import Graphics.UI.WXCore -import Tools - -data Nim = Nim Int deriving (Show, Eq) - -nim :: Nim -nim = undefined - -instance Game Nim where - - name _ = "nim" - - standard _ = Properties { players = 2, boardsize = 21, human = [True, False, False] } - - possible _ = PropertyRange { playersrange = [2, 3], boardsizerange = [1 .. 100] } - - new pr = Nim $ boardsize pr - - moves pr _ (Nim n) = map (move pr) $ filter (<= n) [1 .. 3] - - showmove _ _ _ i = numberword (i + 1) - - value pr p (Nim n) - | n == 0 = (prev p |> 1) $ replicate (players pr) (negate 1) - | otherwise = replicate (players pr) 0 - where - prev :: Player -> Player - prev p' = (p' - 1) `mod` players pr - - board p _pr vart _ move' = do - - st <- staticText p [ text := "There are currently quite a number of rods.\n" ] - b1 <- button p [] - b2 <- button p [] - b3 <- button p [] - - let - - onpaint _dc _r = do - t <- varGet vart - let Nim n = state t - set st [ text := "There are currently " ++ numberword n ++ " rods.\n" - ++ "How many will you take away?" ] - - set b1 [ text := "one rod" , on command := move' 0 ] - set b2 [ text := "two rods" , on command := move' 1 ] - set b3 [ text := "three rods", on command := move' 2 ] - - set p [ layout := floatCentre $ column 4 [ centre $ widget st - , row 4 [widget b1, widget b2, widget b3] - ] - , on paint := onpaint - ] - - return () - -{- -dist :: Int -> Int -> Int -dist x y = let i = x * x + y * y - f = fromInteger $ toInteger i - s = sqrt f - in floor s - -drawButton :: Int -> DC () -> Rect -> IO () -drawButton n dc (Rect x y w h) = - do circle dc (pt (x + w `div` 2) (y + h `div` 2)) (min w h `div` 2) [brushKind := BrushTransparent] - let t = w `div` (n + 1) - for 1 n (\i -> line dc (pt (x + i * t) (y + h `div` 5)) (pt (x + i * t) (y + h - h `div` 5)) []) --} - -move :: Properties -> Int -> (Player, Nim) -> (Player, Nim) -move pr n (p, Nim m) = ((p + 1) `mod` players pr, Nim (m - n)) ++---------+-- NIM --+---------++module Nim (Nim, nim) where++import Game+import Graphics.UI.WX+-- import Graphics.UI.WXCore+import Tools++data Nim = Nim Int deriving (Show, Eq)++nim :: Nim+nim = undefined++instance Game Nim where++ name _ = "nim"++ standard _ = Properties { players = 2, boardsize = 21, human = [True, False, False] }+ + possible _ = PropertyRange { playersrange = [2, 3], boardsizerange = [1 .. 100] }+ + new pr = Nim $ boardsize pr+ + moves pr _ (Nim n) = map (move pr) $ filter (<= n) [1 .. 3]++ showmove _ _ _ i = numberword (i + 1)++ value pr p (Nim n)+ | n == 0 = (prev p |> 1) $ replicate (players pr) (negate 1)+ | otherwise = replicate (players pr) 0+ where + prev :: Player -> Player+ prev p' = (p' - 1) `mod` players pr++ board p _pr vart _ move' = do++ st <- staticText p [ text := "There are currently quite a number of rods.\n" ]+ b1 <- button p []+ b2 <- button p []+ b3 <- button p []++ let ++ onpaint _dc _r = do+ t <- varGet vart+ let Nim n = state t+ set st [ text := "There are currently " ++ numberword n ++ " rods.\n"+ ++ "How many will you take away?" ]++ set b1 [ text := "one rod" , on command := move' 0 ]+ set b2 [ text := "two rods" , on command := move' 1 ]+ set b3 [ text := "three rods", on command := move' 2 ]++ set p [ layout := floatCentre $ column 4 [ centre $ widget st+ , row 4 [widget b1, widget b2, widget b3] + ]+ , on paint := onpaint+ ]+ + return ()++{-+dist :: Int -> Int -> Int+dist x y = let i = x * x + y * y+ f = fromInteger $ toInteger i+ s = sqrt f+ in floor s++drawButton :: Int -> DC () -> Rect -> IO ()+drawButton n dc (Rect x y w h) =+ do circle dc (pt (x + w `div` 2) (y + h `div` 2)) (min w h `div` 2) [brushKind := BrushTransparent]+ let t = w `div` (n + 1)+ for 1 n (\i -> line dc (pt (x + i * t) (y + h `div` 5)) (pt (x + i * t) (y + h - h `div` 5)) [])+-}++move :: Properties -> Int -> (Player, Nim) -> (Player, Nim)+move pr n (p, Nim m) = ((p + 1) `mod` players pr, Nim (m - n))
Reversi.hs view
@@ -1,147 +1,146 @@- -------------- --- Reversi -- -------------- - -module Reversi (Reversi, reversi) where - -import Game -import Array --- import Graphics.UI.WX -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)
Setup.lhs view
@@ -1,5 +1,5 @@-#!/usr/bin/env runhaskell - -> import Distribution.Simple -> main = defaultMainWithHooks simpleUserHooks - +#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMainWithHooks simpleUserHooks+
TicTacToe.hs view
@@ -1,114 +1,127 @@- ---------------- --- TicTacToe -- ---------------- - -module TicTacToe (TicTacToe, tictactoe) where - -import Game -import Graphics.UI.WX hiding (border, point) -import Graphics.UI.WXCore hiding (point) -import Tools - -data TicTacToe = TicTacToe [Maybe Player] deriving (Eq, Show) - -tictactoe :: TicTacToe -tictactoe = undefined - -instance Game TicTacToe where - - name _ = "tictactoe" -{- -rules _ = "Tictactoe" - ++ "\n" - ++ "\nTictactoe is played on a 3x3 board." - ++ "\nTwo players put their pieces in empty squares in turns." - ++ "\nThe first player to make a row of three pieces wins." - information _ = "Tictactoe is one of the easiest and best known strategic boardgames" - ++ "\nin the world. You will probably find it in every book or program on" - ++ "\ngame theory, and this one is no exception." --} - standard _ = Properties { players = 2, boardsize = 3, human = [True, False] } - - possible _ = PropertyRange { playersrange = [2], boardsizerange = [3] } - - new _p = TicTacToe $ replicate 9 Nothing - - moves _ _ (TicTacToe s) - | any (\p -> any (tttwinning p s) tttrows) [0, 1] = [] - | otherwise = map (move . snd) $ possiblemoves s - - showmove _pr _p (TicTacToe s) i = let j = snd (possiblemoves s !! i) - in ["abc" !! (j `mod` 3), "321" !! (j `div` 3)] - - value _ _ (TicTacToe s) | any (tttwinning 0 s) tttrows = [ 1, -1] - | any (tttwinning 1 s) tttrows = [-1, 1] - | otherwise = [ 0, 0] - - 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 TicTacToe st = state t - b <- border dc (3, 3) - let g = grate r b (3, 3) (Size 1 1) - varSet varg g - tileBitmap dc r marble - for 0 2 (\i -> do - drawTextRect dc ["ABC" !! i] $ edge g (i, -1) - drawTextRect dc ["ABC" !! i] $ edge g (i, 3) - drawTextRect dc (show (3 - i)) $ edge g (-1, i) - drawTextRect dc (show (3 - i)) $ edge g ( 3, i) - ) - drawGrate dc g [brushKind := BrushTransparent] - for 0 2 (\i -> for 0 2 (\j -> - case st !! (i + 3 * j) of Just 0 -> drawCross dc $ field g (i, j) - Just 1 -> drawCircle dc $ field g (i, j) - Nothing -> return () - _ -> error "Unexpected value" - )) - - onclick :: Point -> IO () - onclick point = do - t <- varGet vart - g <- varGet varg - let TicTacToe st = state t - (i, j) = locate g point - n | i < 0 || i >= 3 || j < 0 || j >= 3 = -1 - | otherwise = (i + 3 * j) - case lookup n (zip (map snd $ possiblemoves st) [0..]) of - Nothing -> return () - Just n' -> move' n' - - set p [ on click := onclick - , on paint := onpaint - ] - - return () - -possiblemoves :: [Maybe Player] -> [(Maybe Player, Int)] -possiblemoves st = filter ((== Nothing) . fst) $ zip st [0 .. 8] - -drawCross :: DC () -> Rect -> IO () -drawCross dc (Rect x y w h) = - do line dc (pt (x + w `div` 10) (y + h `div` 10)) (pt (x + w - w `div` 10) (y + h - h `div` 10)) [penColor := blue, penWidth := 2] - line dc (pt (x + w `div` 10) (y + h - h `div` 10)) (pt (x + w - w `div` 10) (y + h `div` 10)) [penColor := blue, penWidth := 2] - -drawCircle :: DC () -> Rect -> IO () -drawCircle dc (Rect x y w h) = - do circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [penColor := red, penWidth := 2, brushKind := BrushTransparent] - -move :: Int -> (Player, TicTacToe) -> (Player, TicTacToe) -move n (p, TicTacToe s) = (1 - p, TicTacToe $ (n |> Just p) s) - -tttrows :: [[Int]] -tttrows = [[0, 1, 2], [3, 4, 5], [6, 7, 8], [0, 3, 6], [1, 4, 7], [2, 5, 8], [0, 4, 8], [2, 4, 6]] - -tttwinning :: Player -> [Maybe Player] -> [Int] -> Bool -tttwinning p s is = all (== Just p) $ map (s !!) is ++---------------+-- TicTacToe --+---------------++module TicTacToe (TicTacToe, tictactoe) where++import Game+import Graphics.UI.WX hiding (border, point)+import Graphics.UI.WXCore hiding (point)+import Tools++data TicTacToe = TicTacToe [Maybe Player] deriving (Eq, Show)++tictactoe :: TicTacToe+tictactoe = undefined++instance Game TicTacToe where++ name _ = "tictactoe"+{-+rules _ = "Tictactoe"+ ++ "\n"+ ++ "\nTictactoe is played on a 3x3 board."+ ++ "\nTwo players put their pieces in empty squares in turns."+ ++ "\nThe first player to make a row of three pieces wins."+ information _ = "Tictactoe is one of the easiest and best known strategic boardgames"+ ++ "\nin the world. You will probably find it in every book or program on"+ ++ "\ngame theory, and this one is no exception."+-}+ standard _ = Properties { players = 2, boardsize = 3, human = [True, False] }++ possible _ = PropertyRange { playersrange = [2], boardsizerange = [3] }+ + new _p = TicTacToe $ replicate 9 Nothing+ + moves _ _ (TicTacToe s)+ | any (\p -> any (tttwinning p s) tttrows) [0, 1] = []+ | otherwise = map (move . snd) $ possiblemoves s++ showmove _pr _p (TicTacToe s) i = let j = snd (possiblemoves s !! i)+ in ["abc" !! (j `mod` 3), "321" !! (j `div` 3)]++ value _ _ (TicTacToe s) | any (tttwinning 0 s) tttrows = [ 1, -1]+ | any (tttwinning 1 s) tttrows = [-1, 1]+ | otherwise = [ 0, 0]++ 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 TicTacToe st = state t+ b <- border dc (3, 3)+ let g = grate r b (3, 3) (Size 1 1)+ varSet varg g+ tileBitmap dc r marble+ for 0 2 (\i -> do+ drawTextRect dc ["ABC" !! i] $ edge g (i, -1)+ drawTextRect dc ["ABC" !! i] $ edge g (i, 3)+ drawTextRect dc (show (3 - i)) $ edge g (-1, i)+ drawTextRect dc (show (3 - i)) $ edge g ( 3, i)+ )+ drawGrate dc g [brushKind := BrushTransparent]+ for 0 2 (\i -> for 0 2 (\j ->+ case st !! (i + 3 * j) of Just 0 -> drawCross dc $ field g (i, j)+ Just 1 -> drawCircle dc $ field g (i, j)+ Nothing -> return ()+ _ -> error "Unexpected value"+ ))+ + onclick :: Point -> IO ()+ onclick point = do + t <- varGet vart+ g <- varGet varg+ let TicTacToe st = state t+ (i, j) = locate g point + n | i < 0 || i >= 3 || j < 0 || j >= 3 = -1+ | otherwise = (i + 3 * j)+ case lookup n (zip (map snd $ possiblemoves st) [0..]) of+ Nothing -> return ()+ Just n' -> move' n'++ set p [ on click := onclick+ , on paint := onpaint+ , on resize := repaint p+ ]+ + return ()++possiblemoves :: [Maybe Player] -> [(Maybe Player, Int)]+possiblemoves st = filter ((== Nothing) . fst) $ zip st [0 .. 8]++drawCross :: DC () -> Rect -> IO ()+drawCross dc (Rect x y w h) =+ do line+ dc+ (pt (x + w `div` 10) (y + h `div` 10))+ (pt (x + w - w `div` 10) (y + h - h `div` 10))+ [penColor := blue, penWidth := 2]+ line+ dc+ (pt (x + w `div` 10) (y + h - h `div` 10))+ (pt (x + w - w `div` 10) (y + h `div` 10))+ [penColor := blue, penWidth := 2]++drawCircle :: DC () -> Rect -> IO ()+drawCircle dc (Rect x y w h) =+ do circle+ dc+ (pt (x + w `div` 2) (y + h `div` 2))+ (2 * (min w h) `div` 5)+ [penColor := red, penWidth := 2, brushKind := BrushTransparent]++move :: Int -> (Player, TicTacToe) -> (Player, TicTacToe)+move n (p, TicTacToe s) = (1 - p, TicTacToe $ (n |> Just p) s)++tttrows :: [[Int]]+tttrows = [[0, 1, 2], [3, 4, 5], [6, 7, 8], [0, 3, 6], [1, 4, 7], [2, 5, 8], [0, 4, 8], [2, 4, 6]]++tttwinning :: Player -> [Maybe Player] -> [Int] -> Bool+tttwinning p s is = all (== Just p) $ map (s !!) is
Tools.hs view
@@ -1,228 +1,228 @@- ------------ --- Tools -- ------------ - -module Tools - ( module HSL - , module Inf - , module Tools - ) where - -import Random -import List - -import Graphics.UI.WX -import Graphics.UI.WXCore - -import HSL -import Inf - --- list functions -- - -maximumWith, minimumWith :: (a -> a -> Ordering) -> [a] -> [a] -maximumWith _ [] = [] -maximumWith p (x : xs) = case maximumWith p xs - of [] -> [x] - (y : ys) -> case p x y - of GT -> x : [] - EQ -> x : y : ys - LT -> y : ys -minimumWith = maximumWith . flip - -(|>) :: Int -> a -> [a] -> [a] -(|>) 0 y (_ : xs) = y : xs -(|>) n y (x : xs) = x : (|>) (n - 1) y xs -(|>) _ _ _ = error "(|>): index out of bounds" - -(!!!) :: Show a => [a] -> Int -> a -es !!! i | i < 0 || i >= length es = error $ show i ++ " !!! " ++ show es - | otherwise = es !! i - -sepWith :: [a] -> [[a]] -> [a] -sepWith _ [] = [] -sepWith _ [as] = as -sepWith s (as : ass) = as ++ s ++ sepWith s ass - -zipWithn :: ([a] -> b) -> [[a]] -> [b] -zipWithn f = map f . transpose - -randomList :: IO [Int] -randomList = do i <- randomIO - let g = mkStdGen i - return $ randoms g - -randomElement :: [a] -> IO a -randomElement [] = error "randomElement: empty list" -randomElement xs = do i <- randomRIO (0, length xs - 1) - return $ xs !! i - --- io functions -- - -for :: Int -> Int -> (Int -> IO ()) -> IO () -for x y f = sequence_ $ map f [x..y] - -ifIO :: (IO Bool) -> IO () -> IO () -ifIO iob io = do b <- iob - if b then io else return () - -varCopy :: Var a -> IO (Var a) -varCopy = flip (>>=) varCreate . varGet - --- other -- - -numberword :: Int -> String -numberword x | x < 0 = "minus " ++ numberword (negate x) -numberword 0 = "zero" -numberword 1 = "one" -numberword 2 = "two" -numberword 3 = "three" -numberword 4 = "four" -numberword 5 = "five" -numberword 6 = "six" -numberword 7 = "seven" -numberword 8 = "eight" -numberword 9 = "nine" -numberword 10 = "ten" -numberword 11 = "eleven" -numberword 12 = "twelve" -numberword 13 = "thirteen" -numberword 15 = "fifteen" -numberword 18 = "eighteen" -numberword x | x < 20 = numberword (x - 10) ++ "teen" -numberword 20 = "twenty" -numberword 30 = "thirty" -numberword 40 = "forty" -numberword 50 = "fifty" -numberword 80 = "eighty" -{- -numberword x | x < 10 ^ 2 = largenumber 1 "ty" "-" x - | x < 10 ^ 3 = largenumber 2 " hundred" " " x - | x < 10 ^ 6 = largenumber 3 " thousand" " " x - | x < 10 ^ 9 = largenumber 6 " million" " " x - | toInteger x < 10 ^ 12 = largenumber 9 " billion" " " x --} -numberword x | smallerExp10 x 2 = largenumber 1 "ty" "-" x - | smallerExp10 x 3 = largenumber 2 " hundred" " " x - | smallerExp10 x 6 = largenumber 3 " thousand" " " x - | smallerExp10 x 9 = largenumber 6 " million" " " x - | smallerExp10 x 12 = largenumber 9 " billion" " " x - where - smallerExp10 :: Int -> Int -> Bool - smallerExp10 y z = y < 10 ^ z - - largenumber :: Int -> String -> String -> Int -> String - largenumber q s t y - | y `mod` (10 ^ q) == 0 = numberword (y `div` (10 ^ q)) ++ s - | otherwise = numberword (y - y `mod` (10 ^ q)) ++ t ++ numberword (y `mod` (10 ^ q)) -numberword _ = "unknown number" - -sqr :: Int -> Int -sqr x = x * x - -average :: [Float] -> Float -average xs = sum xs / (fromInteger . toInteger) (length xs) - --- wx functions -- - -type Wire = Graphics.UI.WX.Timer - -wire :: Window a -> [Prop Wire] -> IO Wire -wire f ps = do w <- timer f ps - timerStop w - return w - -send :: Wire -> IO () -send w = do _ <- timerStart w 1 True - return () - -wait :: Window a -> Int -> IO () -> IO () -wait w n action = do - t <- timer w [] - set t [interval := n, on command := set t [enabled := False] >> action] - - -cut :: Ord a => (a, a) -> a -> a -cut (l, u) x - | x < l = l - | x > u = u - | otherwise = x - - -tileBitmap :: DC () -> Rect -> Bitmap () -> IO () -tileBitmap dc (Rect _x _y w h) bmp = do - bw <- bitmapGetWidth bmp - bh <- bitmapGetHeight bmp - for 0 (w `div` bw) (\i -> - for 0 (h `div` bh) (\j -> - drawBitmap dc bmp (pt (i * bw) (j * bh)) False [])) - --- grates -- - -data Grate = Grate Rect (Int, Int) Int - -grate :: Rect -> Int -> (Int, Int) -> Size -> Grate -grate (Rect x y w h) b (m, n) (Size u v) = - grate_ (Rect (x + b) (y + b) (w - 2 * b) (h - 2 * b)) - where - grate_ :: Rect -> Grate - grate_ (Rect x' y' w' h') = - let t = min (w' * n * v) (h' * m * u) - w_ = t `div` (n * v) - h_ = t `div` (m * u) - x_ = (x' + (w' - w_) `div` 2) - y_ = (y' + (h' - h_) `div` 2) - in Grate (Rect x_ y_ w_ h_) (m, n) b - - -field :: Grate -> (Int, Int) -> Rect -field (Grate (Rect x y w h) (m, n) _) (i, j) = - let fx, fy :: Int -> Int - fx i' = x + i' * w `div` m - fy j' = y + j' * h `div` n - in Rect (fx i) (fy j) (fx (i + 1) - fx i) (fy (j + 1) - fy j) - -locate :: Grate -> Point -> (Int, Int) -locate (Grate (Rect x y w h) (m, n) _) (Point px py) = - ((px - x) * m `div` w, (py - y) * n `div` h) - -drawGrate :: DC () -> Grate -> [Prop (DC ())] -> IO () -drawGrate dc g@(Grate _ (m, n) _) options = - for 0 (m - 1) (\i -> for 0 (n - 1) (\j -> - drawRect dc (field g (i, j)) options - ) ) - -edge :: Grate -> (Int, Int) -> Rect -edge g@(Grate _ (m, n) b) (i, j) = - let Rect x y w h = field g (i, j) - x_ | i == -1 = x + w - b - | otherwise = x - y_ | j == -1 = y + h - b - | otherwise = y - w_ | i < 0 || i >= m = b - | otherwise = w - h_ | j < 0 || j >= n = b - | otherwise = h - in Rect x_ y_ w_ h_ - -drawTextRect :: DC () -> String -> Rect -> IO () -drawTextRect dc s (Rect x y w h) = do - Size u v <- getTextExtent dc s - drawText dc s (pt (x + (w - u) `div` 2) (y + (h - v) `div` 2)) [] - -border :: DC () -> (Int, Int) -> IO Int -border dc (m, n) = do - let ms = map show [1 .. m] - ns = map (:[]) $ take n ['A' ..] - hs <- sequence $ map (getTextExtent dc) ms - ws <- sequence $ map (getTextExtent dc) ns - return $ maximum (map sizeH hs ++ map sizeW ws) - -bounding :: Rect -> Rect -> Rect -bounding (Rect x y w h) (Rect x_ y_ w_ h_) = - let r = x + w; r_ = x_ + w_ - b = y + h; b_ = y_ + h_ - in rectBetween (pt (min x x_) (min y y_)) (pt (max r r_) (max b b_)) - -(|#|) :: Rect -> Rect -> Rect -(|#|) = bounding ++-----------+-- Tools --+-----------++module Tools + ( module HSL+ , module Inf+ , module Tools+ ) where++import System.Random+import Data.List++import Graphics.UI.WX+import Graphics.UI.WXCore++import HSL+import Inf++-- list functions --++maximumWith, minimumWith :: (a -> a -> Ordering) -> [a] -> [a]+maximumWith _ [] = []+maximumWith p (x : xs) = case maximumWith p xs+ of [] -> [x]+ (y : ys) -> case p x y+ of GT -> x : []+ EQ -> x : y : ys+ LT -> y : ys+minimumWith = maximumWith . flip++(|>) :: Int -> a -> [a] -> [a]+(|>) 0 y (_ : xs) = y : xs+(|>) n y (x : xs) = x : (|>) (n - 1) y xs+(|>) _ _ _ = error "(|>): index out of bounds"++(!!!) :: Show a => [a] -> Int -> a+es !!! i | i < 0 || i >= length es = error $ show i ++ " !!! " ++ show es+ | otherwise = es !! i++sepWith :: [a] -> [[a]] -> [a]+sepWith _ [] = []+sepWith _ [as] = as+sepWith s (as : ass) = as ++ s ++ sepWith s ass++zipWithn :: ([a] -> b) -> [[a]] -> [b]+zipWithn f = map f . transpose++randomList :: IO [Int]+randomList = do i <- randomIO+ let g = mkStdGen i+ return $ randoms g++randomElement :: [a] -> IO a+randomElement [] = error "randomElement: empty list"+randomElement xs = do i <- randomRIO (0, length xs - 1)+ return $ xs !! i++-- io functions --++for :: Int -> Int -> (Int -> IO ()) -> IO ()+for x y f = sequence_ $ map f [x..y]++ifIO :: (IO Bool) -> IO () -> IO ()+ifIO iob io = do b <- iob+ if b then io else return ()++varCopy :: Var a -> IO (Var a)+varCopy = flip (>>=) varCreate . varGet++-- other --++numberword :: Int -> String+numberword x | x < 0 = "minus " ++ numberword (negate x)+numberword 0 = "zero"+numberword 1 = "one"+numberword 2 = "two"+numberword 3 = "three"+numberword 4 = "four"+numberword 5 = "five"+numberword 6 = "six"+numberword 7 = "seven"+numberword 8 = "eight"+numberword 9 = "nine"+numberword 10 = "ten"+numberword 11 = "eleven"+numberword 12 = "twelve"+numberword 13 = "thirteen"+numberword 15 = "fifteen"+numberword 18 = "eighteen"+numberword x | x < 20 = numberword (x - 10) ++ "teen"+numberword 20 = "twenty"+numberword 30 = "thirty"+numberword 40 = "forty"+numberword 50 = "fifty"+numberword 80 = "eighty"+{-+numberword x | x < 10 ^ 2 = largenumber 1 "ty" "-" x+ | x < 10 ^ 3 = largenumber 2 " hundred" " " x+ | x < 10 ^ 6 = largenumber 3 " thousand" " " x+ | x < 10 ^ 9 = largenumber 6 " million" " " x+ | toInteger x < 10 ^ 12 = largenumber 9 " billion" " " x+-}+numberword x | smallerExp10 x 2 = largenumber 1 "ty" "-" x+ | smallerExp10 x 3 = largenumber 2 " hundred" " " x+ | smallerExp10 x 6 = largenumber 3 " thousand" " " x+ | smallerExp10 x 9 = largenumber 6 " million" " " x+ | smallerExp10 x 12 = largenumber 9 " billion" " " x+ where+ smallerExp10 :: Int -> Int -> Bool+ smallerExp10 y z = y < 10 ^ z++ largenumber :: Int -> String -> String -> Int -> String+ largenumber q s t y+ | y `mod` (10 ^ q) == 0 = numberword (y `div` (10 ^ q)) ++ s+ | otherwise = numberword (y - y `mod` (10 ^ q)) ++ t ++ numberword (y `mod` (10 ^ q))+numberword _ = "unknown number"++sqr :: Int -> Int+sqr x = x * x++average :: [Float] -> Float+average xs = sum xs / (fromInteger . toInteger) (length xs)++-- wx functions --++type Wire = Graphics.UI.WX.Timer++wire :: Window a -> [Prop Wire] -> IO Wire+wire f ps = do w <- timer f ps+ timerStop w+ return w++send :: Wire -> IO ()+send w = do _ <- timerStart w 1 True+ return ()++wait :: Window a -> Int -> IO () -> IO ()+wait w n action = do+ t <- timer w []+ set t [interval := n, on command := set t [enabled := False] >> action]+ ++cut :: Ord a => (a, a) -> a -> a+cut (l, u) x + | x < l = l+ | x > u = u+ | otherwise = x+++tileBitmap :: DC () -> Rect -> Bitmap () -> IO ()+tileBitmap dc (Rect _x _y w h) bmp = do+ bw <- bitmapGetWidth bmp+ bh <- bitmapGetHeight bmp+ for 0 (w `div` bw) (\i ->+ for 0 (h `div` bh) (\j ->+ drawBitmap dc bmp (pt (i * bw) (j * bh)) False []))++-- grates -- ++data Grate = Grate Rect (Int, Int) Int++grate :: Rect -> Int -> (Int, Int) -> Size -> Grate+grate (Rect x y w h) b (m, n) (Size u v) =+ grate_ (Rect (x + b) (y + b) (w - 2 * b) (h - 2 * b))+ where+ grate_ :: Rect -> Grate+ grate_ (Rect x' y' w' h') =+ let t = min (w' * n * v) (h' * m * u)+ w_ = t `div` (n * v)+ h_ = t `div` (m * u)+ x_ = (x' + (w' - w_) `div` 2)+ y_ = (y' + (h' - h_) `div` 2) + in Grate (Rect x_ y_ w_ h_) (m, n) b+++field :: Grate -> (Int, Int) -> Rect+field (Grate (Rect x y w h) (m, n) _) (i, j) =+ let fx, fy :: Int -> Int+ fx i' = x + i' * w `div` m+ fy j' = y + j' * h `div` n+ in Rect (fx i) (fy j) (fx (i + 1) - fx i) (fy (j + 1) - fy j)++locate :: Grate -> Point -> (Int, Int)+locate (Grate (Rect x y w h) (m, n) _) (Point px py) =+ ((px - x) * m `div` w, (py - y) * n `div` h)++drawGrate :: DC () -> Grate -> [Prop (DC ())] -> IO ()+drawGrate dc g@(Grate _ (m, n) _) options =+ for 0 (m - 1) (\i -> for 0 (n - 1) (\j ->+ drawRect dc (field g (i, j)) options+ ) )+ +edge :: Grate -> (Int, Int) -> Rect+edge g@(Grate _ (m, n) b) (i, j) =+ let Rect x y w h = field g (i, j)+ x_ | i == -1 = x + w - b+ | otherwise = x+ y_ | j == -1 = y + h - b+ | otherwise = y+ w_ | i < 0 || i >= m = b+ | otherwise = w+ h_ | j < 0 || j >= n = b+ | otherwise = h+ in Rect x_ y_ w_ h_+ +drawTextRect :: DC () -> String -> Rect -> IO ()+drawTextRect dc s (Rect x y w h) = do+ Size u v <- getTextExtent dc s+ drawText dc s (pt (x + (w - u) `div` 2) (y + (h - v) `div` 2)) []+ +border :: DC () -> (Int, Int) -> IO Int+border dc (m, n) = do+ let ms = map show [1 .. m]+ ns = map (:[]) $ take n ['A' ..]+ hs <- sequence $ map (getTextExtent dc) ms+ ws <- sequence $ map (getTextExtent dc) ns+ return $ maximum (map sizeH hs ++ map sizeW ws)+ +bounding :: Rect -> Rect -> Rect+bounding (Rect x y w h) (Rect x_ y_ w_ h_) =+ let r = x + w; r_ = x_ + w_+ b = y + h; b_ = y_ + h_+ in rectBetween (pt (min x x_) (min y y_)) (pt (max r r_) (max b b_))++(|#|) :: Rect -> Rect -> Rect+(|#|) = bounding
Zenix.hs view
@@ -1,199 +1,199 @@- - -{-{ http://en2.wikipedia.org/wiki/Zenix_(game) }-} - - ------------ --- Zenix -- ------------ - -module Zenix (Zenix, zenix) where - -import Game -import Array -import Graphics.UI.WX hiding (border, point) -import Graphics.UI.WXCore hiding (point) -import Tools - -data Zenix = Zenix (Array (Int, Int) (Maybe Player)) deriving (Eq, Show) - -type ZenixMove = (Int, Int) - -zenix :: Zenix -zenix = undefined - -instance Game Zenix where - - name _ = "zenix" - - standard _ = Properties { players = 2, boardsize = 8, human = [True, False, False] } - possible _ = PropertyRange { playersrange = [2, 3], boardsizerange = [4 .. 12] } - - new pr = let bsz = boardsize pr - in Zenix $ array ((0, 0), (bsz - 1, bsz - 1)) [((x, y), Nothing) | x <- [0 .. bsz - 1], y <- [0 .. bsz - 1]] - - moves pr p (Zenix st) = map (move pr) (allMoves pr p st) - - showmove pr p (Zenix s) i = case allMoves pr p s !! i - of (x, y) -> ['a' ..] !! x : show (1 + y) - - value pr p (Zenix st) - | null $ allMoves pr p st = let winners = map fst $ filter (\(_i, c) -> c == maximum chains) $ zip [0 ..] chains - in foldr ($) (replicate (players pr) (-1)) $ map (|> 1) winners - | otherwise = map myvalue [0 .. players pr - 1] - where - bsz = boardsize pr - - chains :: [Int] - chains = map (\p' -> scan p' bsz []) [0 .. players pr - 1] - - myvalue :: Player -> Float - myvalue p' = let t = fromInteger . toInteger $ (players pr) * (chains !! p') - sum chains - n = fromInteger . toInteger $ 2 * bsz - in t / n - - scan :: Player -> Int -> [Int] -> Int - scan p' y _ | y >= bsz = scan p' (bsz - 1) [0 .. bsz] - scan _p y [] = bsz - y - scan p' y xs = scan p' (y - 1) $ filter good [0 .. y] - where - good :: Int -> Bool - good x = st ! (x, y) == Just p' - && (x `elem` xs || (x + 1) `elem` xs) - - 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 Zenix st = state t - bsz = boardsize pr - b <- border dc (bsz, bsz) - let g = grate r b (2 * bsz, bsz) (Size 4 7) - radius = rectWidth (field g (0, 0)) -{- - lin' :: Rect -> Rect -> Color -> IO () - lin' (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) c = do - line dc (pt (x1 + w1 `div` 2) (y1 + h1)) (pt (x2 + w2 `div` 2) (y2 + h2)) [penWidth := 4, penColor := c] - lin :: (Int, Int) -> (Int, Int) -> Color -> IO () - lin p q = lin' (field g $ tograte bsz p) (field g $ tograte bsz q) --} - varSet varg g - tileBitmap dc r marble ---{ drawGrate dc g [penColor := yellow] - for 0 (bsz - 1) (\i -> do - drawTextRect dc [['A' ..] !! i] $ edge g (2 * i, bsz) - drawTextRect dc (show (i + 1)) $ field g (i - 1, bsz - i - 1) - ) - for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j -> - when (j - i >= 0) $ drawPiece dc (field g $ tograte bsz (i, j)) radius (st ! (i, j)) - )) - - onclick :: Point -> IO () - onclick point = do - t <- varGet vart - g <- varGet varg - let Zenix st = state t - bsz = boardsize pr - n = fromgrate bsz $ locate g point - case lookup n $ zip (allMoves pr (player t) st) [0..] of - Nothing -> return () - Just i -> move' i - - set p [ on click := onclick - , on paint := onpaint - , on resize ::= repaint - ] - - return () - -drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO () -drawPiece dc (Rect x y _w h) r mp = do - case mp of Just 0 -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushSolid, brushColor := blue ] - Just 1 -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushSolid, brushColor := red ] - Just 2 -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushSolid, brushColor := green] - Nothing -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushTransparent] - _ -> error "drawPiece: Unexpected value" - -{- -(+-) :: Num a => (a, a) -> (a, a) -> (a, a) -(a, b) +- (c, d) = (a + c, b + d) --} - -allMoves :: Properties -> Player -> Array (Int, Int) (Maybe Player) -> [ZenixMove] -allMoves pr _p st - | otherwise = filter free $ indices st - where - bsz = boardsize pr - free :: ZenixMove -> Bool - free (x, y) = y - x >= 0 - && st ! (x, y) == Nothing - && (y == bsz - 1 || (st ! (x, y + 1) /= Nothing && st ! (x + 1, y + 1) /= Nothing)) - -move :: Properties -> ZenixMove -> (Player, Zenix) -> (Player, Zenix) -move pr place (p, Zenix s) = ( (p + 1) `mod` players pr - , Zenix $ s // [(place, Just p)] - ) - -{-{ -win :: Array (Int, Int) (Maybe Player) -> Int -> Player -> Bool -win st bsz 0 = any ((== bsz - 1) . snd) $ floodfill st 0 (zip [0 .. bsz - 1] [-1, -1 ..]) -win st bsz 1 = any ((== bsz - 1) . fst) $ floodfill st 1 (zip [-1, -1 ..] [0 .. bsz - 1]) - -floodfill :: Array (Int, Int) (Maybe Player) -> Player -> [(Int, Int)] -> [(Int, Int)] -floodfill st p togo = floodfill_ p togo [] - where - floodfill_ :: Player -> [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)] - floodfill_ p [] known = known - floodfill_ p (f : togo) known = let new = filter (not . flip elem known) $ map (f +-) steps - good = filter (\f -> st ! f == Just p) $ filter (inRange (bounds st)) new - in floodfill_ p (togo ++ good) (known ++ good) - -steps :: [(Int, Int)] -steps = [(1, 1), (1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1)] - -jumps :: [((Int, Int), [(Int, Int)])] -jumps = [ (( 2, 1), [( 1, 0), ( 1, 1)]) - , (( 1, 2), [( 0, 1), ( 1, 1)]) - , ((-1, 1), [( 0, 1), (-1, 0)]) - , ((-2, -1), [(-1, 0), (-1, -1)]) - , ((-1, -2), [( 0, -1), (-1, -1)]) - , (( 1, -1), [( 1, 0), ( 0, -1)]) - ] -}-} - -tograte :: Int -> (Int, Int) -> (Int, Int) -tograte bsz (i, j) = (bsz + 2 * i - j, j) - -fromgrate :: Int -> (Int, Int) -> (Int, Int) -fromgrate bsz (i, j) = ((i + j - bsz + 1) `div` 2, j) - -{- -i = s - 1 + x - y -j = 2s - 2 - x - y - -i + j = 3s - 3 - 2y -2y = 3s - 3 - i - j -y = (...) / 2 - -i - j = -s + 1 + 2x -2x = s - 1 + i - j --} - - -{- the zenixboard internally look like this: - -0 * -1 * * -2 * * * -3 * * * * -4 * * * * * -5 * * * * * * - 0 1 2 3 4 5 - +++{-{ http://en2.wikipedia.org/wiki/Zenix_(game) }-}+++-----------+-- Zenix --+-----------++module Zenix (Zenix, zenix) where++import Game+import Data.Array+import Graphics.UI.WX hiding (border, point)+import Graphics.UI.WXCore hiding (point)+import Tools++data Zenix = Zenix (Array (Int, Int) (Maybe Player)) deriving (Eq, Show)++type ZenixMove = (Int, Int)++zenix :: Zenix+zenix = undefined++instance Game Zenix where++ name _ = "zenix"++ standard _ = Properties { players = 2, boardsize = 8, human = [True, False, False] }+ possible _ = PropertyRange { playersrange = [2, 3], boardsizerange = [4 .. 12] }++ new pr = let bsz = boardsize pr+ in Zenix $ array ((0, 0), (bsz - 1, bsz - 1)) [((x, y), Nothing) | x <- [0 .. bsz - 1], y <- [0 .. bsz - 1]]+ + moves pr p (Zenix st) = map (move pr) (allMoves pr p st)++ showmove pr p (Zenix s) i = case allMoves pr p s !! i+ of (x, y) -> ['a' ..] !! x : show (1 + y)++ value pr p (Zenix st) + | null $ allMoves pr p st = let winners = map fst $ filter (\(_i, c) -> c == maximum chains) $ zip [0 ..] chains+ in foldr ($) (replicate (players pr) (-1)) $ map (|> 1) winners+ | otherwise = map myvalue [0 .. players pr - 1]+ where+ bsz = boardsize pr++ chains :: [Int]+ chains = map (\p' -> scan p' bsz []) [0 .. players pr - 1]++ myvalue :: Player -> Float+ myvalue p' = let t = fromInteger . toInteger $ (players pr) * (chains !! p') - sum chains+ n = fromInteger . toInteger $ 2 * bsz+ in t / n++ scan :: Player -> Int -> [Int] -> Int+ scan p' y _ | y >= bsz = scan p' (bsz - 1) [0 .. bsz]+ scan _p y [] = bsz - y+ scan p' y xs = scan p' (y - 1) $ filter good [0 .. y]+ where+ good :: Int -> Bool+ good x = st ! (x, y) == Just p'+ && (x `elem` xs || (x + 1) `elem` xs)++ 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 Zenix st = state t+ bsz = boardsize pr+ b <- border dc (bsz, bsz)+ let g = grate r b (2 * bsz, bsz) (Size 4 7)+ radius = rectWidth (field g (0, 0))+{-+ lin' :: Rect -> Rect -> Color -> IO ()+ lin' (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) c = do+ line dc (pt (x1 + w1 `div` 2) (y1 + h1)) (pt (x2 + w2 `div` 2) (y2 + h2)) [penWidth := 4, penColor := c]+ lin :: (Int, Int) -> (Int, Int) -> Color -> IO ()+ lin p q = lin' (field g $ tograte bsz p) (field g $ tograte bsz q)+-}+ varSet varg g+ tileBitmap dc r marble+--{ drawGrate dc g [penColor := yellow]+ for 0 (bsz - 1) (\i -> do+ drawTextRect dc [['A' ..] !! i] $ edge g (2 * i, bsz)+ drawTextRect dc (show (i + 1)) $ field g (i - 1, bsz - i - 1)+ )+ for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->+ when (j - i >= 0) $ drawPiece dc (field g $ tograte bsz (i, j)) radius (st ! (i, j))+ ))++ onclick :: Point -> IO ()+ onclick point = do + t <- varGet vart+ g <- varGet varg+ let Zenix st = state t+ bsz = boardsize pr+ n = fromgrate bsz $ locate g point + case lookup n $ zip (allMoves pr (player t) st) [0..] of+ Nothing -> return ()+ Just i -> move' i++ set p [ on click := onclick+ , on paint := onpaint+ , on resize ::= repaint+ ]++ return ()++drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO ()+drawPiece dc (Rect x y _w h) r mp = do+ case mp of Just 0 -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushSolid, brushColor := blue ]+ Just 1 -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushSolid, brushColor := red ]+ Just 2 -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushSolid, brushColor := green]+ Nothing -> circle dc (pt x (y + h `div` 2)) r [brushKind := BrushTransparent]+ _ -> error "drawPiece: Unexpected value"++{-+(+-) :: Num a => (a, a) -> (a, a) -> (a, a)+(a, b) +- (c, d) = (a + c, b + d)+-}++allMoves :: Properties -> Player -> Array (Int, Int) (Maybe Player) -> [ZenixMove]+allMoves pr _p st + | otherwise = filter free $ indices st+ where+ bsz = boardsize pr+ free :: ZenixMove -> Bool+ free (x, y) = y - x >= 0+ && st ! (x, y) == Nothing+ && (y == bsz - 1 || (st ! (x, y + 1) /= Nothing && st ! (x + 1, y + 1) /= Nothing))++move :: Properties -> ZenixMove -> (Player, Zenix) -> (Player, Zenix)+move pr place (p, Zenix s) = ( (p + 1) `mod` players pr+ , Zenix $ s // [(place, Just p)]+ )++{-{+win :: Array (Int, Int) (Maybe Player) -> Int -> Player -> Bool+win st bsz 0 = any ((== bsz - 1) . snd) $ floodfill st 0 (zip [0 .. bsz - 1] [-1, -1 ..])+win st bsz 1 = any ((== bsz - 1) . fst) $ floodfill st 1 (zip [-1, -1 ..] [0 .. bsz - 1])+ +floodfill :: Array (Int, Int) (Maybe Player) -> Player -> [(Int, Int)] -> [(Int, Int)]+floodfill st p togo = floodfill_ p togo []+ where+ floodfill_ :: Player -> [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]+ floodfill_ p [] known = known+ floodfill_ p (f : togo) known = let new = filter (not . flip elem known) $ map (f +-) steps+ good = filter (\f -> st ! f == Just p) $ filter (inRange (bounds st)) new+ in floodfill_ p (togo ++ good) (known ++ good)++steps :: [(Int, Int)]+steps = [(1, 1), (1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1)]++jumps :: [((Int, Int), [(Int, Int)])]+jumps = [ (( 2, 1), [( 1, 0), ( 1, 1)])+ , (( 1, 2), [( 0, 1), ( 1, 1)])+ , ((-1, 1), [( 0, 1), (-1, 0)])+ , ((-2, -1), [(-1, 0), (-1, -1)])+ , ((-1, -2), [( 0, -1), (-1, -1)])+ , (( 1, -1), [( 1, 0), ( 0, -1)])+ ]+}-}++tograte :: Int -> (Int, Int) -> (Int, Int)+tograte bsz (i, j) = (bsz + 2 * i - j, j)++fromgrate :: Int -> (Int, Int) -> (Int, Int)+fromgrate bsz (i, j) = ((i + j - bsz + 1) `div` 2, j)++{-+i = s - 1 + x - y+j = 2s - 2 - x - y++i + j = 3s - 3 - 2y+2y = 3s - 3 - i - j+y = (...) / 2++i - j = -s + 1 + 2x+2x = s - 1 + i - j+-}+++{- the zenixboard internally look like this:++0 *+1 * *+2 * * *+3 * * * *+4 * * * * *+5 * * * * * *+ 0 1 2 3 4 5+ -}
changelog.txt view
@@ -1,22 +1,33 @@- -2010-10-20 - -Version 1.7.2 - - Increased the maximum version of base to < 5 . - - -2009-11-14 - -Version 1.7.1 - - Added -Wall flag in the CABAL file - - Solved all compiler warnings. - - Increased the maximum version of wx and wxcore to < 0.13 . - - Added the file changelog.txt - - -2009-10-29 - -Version 1.7 - - Adapted to wxWidgets 2.8.9 / wxHaskell 0.11.1.2 - - Cabalized - ++2013-09-20++Version 1.7.3+ - Adapted to Haskell Platform 2013.2.0.0, wxWidgets 2.9.5 and+ wxHaskell 0.90.1.0. Amongst others, hierarchical module system+ introduced. GUI.hs: staticBitmapCreate has now 0x00200000+ (== wxBORDER_NONE) as style, as wxWidgets does not accept -1 as style+ anymore. The clientsize of the ¨move now¨ button is not set anymore,+ so the text fits. TicTacToe now repainted on resize+++2010-10-20++Version 1.7.2+ - Increased the maximum version of base to < 5 .+++2009-11-14 ++Version 1.7.1+ - Added -Wall flag in the CABAL file + - Solved all compiler warnings.+ - Increased the maximum version of wx and wxcore to < 0.13 .+ - Added the file changelog.txt+++2009-10-29 ++Version 1.7+ - Adapted to wxWidgets 2.8.9 / wxHaskell 0.11.1.2 + - Cabalized+
help/brain.html view
@@ -1,33 +1,71 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> The Brain Viewer </H2> - - GeBoP features a brain viewer which enables you to explore the computer's internal game tree. To open the brain viewer, first start a game. Next, select 'Open' in the 'Brain' menu. You can open a seperate brain viewer for each open game. <BR> - - <BR> - - The brain viewer consists of two components. To the left, there is a tree view. To the right, there is a situation panel. In the tree view, you can browse the game tree. The situation panel will show statistics about the currently selected situation in the tree view. <BR> - - <BR> - - At the start, there is only one item in the tree view, called 'current situation'. If you double click this item, a list will expand with all possible moves for the current player. Each item represents a new situation. In turn, you can expand these new items with a list with all possible moves for the next player in this new situation. <BR> - - <BR> - - Each item in the tree view has an icon which tells you which player would make the move in question. The best moves, based on the computer's current information, are displayed with a highlighted icon. Next to the icon is the move. This can be grey, black or bold. If it is grey, it means that it has not yet been seen by the computer. If it is black, it has been seen. If it is bold, it means that this situation has been completely computed, that every possible compination of moves from that point on has been seen. <BR> - - <BR> - - The situation panel on the right side of the brain viewer consists of three parts. The upper part shows an icon for the player who has to move in this situation. Next to it is a bar that shows the value of this situation. The middle part shows the complete depth, the maximum depth and the volume of this situation. The complete depth states how many sublevels of this situation have been completely computed. The maximim depth states the depth of the deepest sublevel that has been computed yet. The volume is the number of computed subsituations. Finally, the lower part consists of a graphical representation of the current situation, the way it looks in the normal game window. You can actually make moves in this part, this will result in selecting another situation in the tree view. <BR> - - <BR> - - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> + <BR>++ <H2> The Brain Viewer </H2>++ GeBoP features a brain viewer which enables you to explore the+ computer's internal game tree. To open the brain viewer, first+ start a game. Next, select 'Open' in the 'Brain' menu. You can+ open a separate brain viewer for each open game.+ <BR>++ <BR>++ The brain viewer consists of two components. To the left, there+ is a tree view. To the right, there is a situation panel. In the+ tree view, you can browse the game tree. The situation panel+ will show statistics about the currently selected situation in+ the tree view.+ <BR>++ <BR>++ At the start, there is only one item in the tree view, called+ 'current situation'. If you double click this item, a list will+ expand with all possible moves for the current player. Each item+ represents a new situation. In turn, you can expand these new+ items with a list with all possible moves for the next player in+ this new situation.+ <BR>++ <BR>++ Each item in the tree view has an icon which tells you which+ player would make the move in question. The best moves, based on+ the computer's current information, are displayed with a+ highlighted icon. Next to the icon is the move. This can be+ grey, black or bold. If it is grey, it means that it has not yet+ been seen by the computer. If it is black, it has been seen. If+ it is bold, it means that this situation has been completely+ computed, that every possible combination of moves from that+ point on has been seen.+ <BR>++ <BR>++ The situation panel on the right side of the brain viewer+ consists of three parts. The upper part shows an icon for the+ player who has to move in this situation. Next to it is a bar+ that shows the value of this situation. The middle part shows+ the complete depth, the maximum depth and the volume of this+ situation. The complete depth states how many sublevels of this+ situation have been completely computed. The maximum depth+ states the depth of the deepest sublevel that has been computed+ yet. The volume is the number of computed subsituations.+ Finally, the lower part consists of a graphical representation+ of the current situation, the way it looks in the normal game+ window. You can actually make moves in this part, this will+ result in selecting another situation in the tree view.+ <BR>++ <BR>++ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/index.html view
@@ -1,39 +1,39 @@-<HTML> - - <BODY> - - <IMG SRC="gebop.bmp"> <BR> - - <H2> Contents </H2> - - Welcome to GeBoP, the General Boardgames Player. GeBoP currently has nine games. - - <H2> Games </H2> - - <B> Ataxx </B> <A HREF="rules_ataxx.html" > Rules </A> <A HREF="info_ataxx.html" > Information </A> - <BR> - <B> Bamp </B> <A HREF="rules_bamp.html" > Rules </A> <A HREF="info_bamp.html" > Information </A> - <BR> - <B> Halma </B> <A HREF="rules_halma.html" > Rules </A> <A HREF="info_halma.html" > Information </A> - <BR> - <B> Hex </B> <A HREF="rules_hex.html" > Rules </A> <A HREF="info_hex.html" > Information </A> - <BR> - <B> Kram </B> <A HREF="rules_kram.html" > Rules </A> <A HREF="info_kram.html" > Information </A> - <BR> - <B> Nim </B> <A HREF="rules_nim.html" > Rules </A> <A HREF="info_nim.html" > Information </A> - <BR> - <B> Reversi </B> <A HREF="rules_reversi.html" > Rules </A> <A HREF="info_reversi.html" > Information </A> - <BR> - <B> Tictactoe </B> <A HREF="rules_tictactoe.html"> Rules </A> <A HREF="info_tictactoe.html"> Information </A> - <BR> - <B> Zenix </B> <A HREF="rules_zenix.html" > Rules </A> <A HREF="info_zenix.html" > Information </A> - - <H2> Components </H2> - - The <A HREF="brain.html"> brain viewer </A> - - - - </BODY> - +<HTML>++ <BODY>++ <IMG SRC="gebop.bmp"> <BR>++ <H2> Contents </H2>++ Welcome to GeBoP, the General Boardgames Player. GeBoP currently has nine games.++ <H2> Games </H2>++ <B> Ataxx </B> <A HREF="rules_ataxx.html" > Rules </A> <A HREF="info_ataxx.html" > Information </A>+ <BR>+ <B> Bamp </B> <A HREF="rules_bamp.html" > Rules </A> <A HREF="info_bamp.html" > Information </A>+ <BR>+ <B> Halma </B> <A HREF="rules_halma.html" > Rules </A> <A HREF="info_halma.html" > Information </A>+ <BR>+ <B> Hex </B> <A HREF="rules_hex.html" > Rules </A> <A HREF="info_hex.html" > Information </A>+ <BR>+ <B> Kram </B> <A HREF="rules_kram.html" > Rules </A> <A HREF="info_kram.html" > Information </A>+ <BR>+ <B> Nim </B> <A HREF="rules_nim.html" > Rules </A> <A HREF="info_nim.html" > Information </A>+ <BR>+ <B> Reversi </B> <A HREF="rules_reversi.html" > Rules </A> <A HREF="info_reversi.html" > Information </A>+ <BR>+ <B> Tictactoe </B> <A HREF="rules_tictactoe.html"> Rules </A> <A HREF="info_tictactoe.html"> Information </A>+ <BR>+ <B> Zenix </B> <A HREF="rules_zenix.html" > Rules </A> <A HREF="info_zenix.html" > Information </A>++ <H2> Components </H2>++ The <A HREF="brain.html"> brain viewer </A>++++ </BODY>+ </HTML>
help/info_ataxx.html view
@@ -1,21 +1,21 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Ataxx Information </H2> - - Ataxx is a game known by many names, including - Hexxagon, Chello, Backstab, and Splat. - - The game is one of the subgames of the 7th guest. - There is also a variant of the game which uses - hexagons instead of squares. - - <H3> <A HREF="rules_ataxx.html"> Ataxx Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Ataxx Information </H2>++ Ataxx is a game known by many names, including+ Hexxagon, Chello, Backstab, and Splat.++ The game is one of the subgames of The 7th guest.+ There is also a variant of the game which uses+ hexagons instead of squares.++ <H3> <A HREF="rules_ataxx.html"> Ataxx Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_bamp.html view
@@ -1,20 +1,25 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Bamp Information </H2> - - This is a game I designed myself. GeBoP supports games where the order in which the players move depends on the moves, and is not fixed a priori. However, I could not find such a game anywhere... <BR> - - <BR> - - The reason might be that it is very difficult to plan a strategy in such a game, since you never know when you will be allowed to move again. Still, it is interesting to study this type of games. - - <H3> <A HREF="rules_bamp.html"> Bamp Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Bamp Information </H2>++ This is a game I designed myself. GeBoP supports games where the+ order in which the players move depends on the moves, and is not+ fixed a priori. However, I could not find such a game anywhere... + <BR>++ <BR>++ The reason might be that it is very difficult to plan a strategy in+ such a game, since you never know when you will be allowed to move+ again. Still, it is interesting to study this type of games.++ <H3> <A HREF="rules_bamp.html"> Bamp Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_halma.html view
@@ -1,20 +1,20 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Halma Information </H2> - - Halma was originally played on a square board, with - two or four players. It was first played on the star - shaped board in Germany. Later it became well known - by the name of Chinese Checkers, which doesn't really - have any connection with China. - - <H3> <A HREF="rules_halma.html"> Halma Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Halma Information </H2>++ Halma was originally played on a square board, with+ two or four players. It was first played on the star+ shaped board in Germany. Later it became well known+ by the name of Chinese Checkers, which doesn't really+ have any connection with China.++ <H3> <A HREF="rules_halma.html"> Halma Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_hex.html view
@@ -1,16 +1,16 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Hex Information </H2> - - Hex was independently invented by Piet Hein and John Nash around 1940. - - <H3> <A HREF="rules_hex.html"> Hex Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Hex Information </H2>++ Hex was independently invented by Piet Hein and John Nash around 1940.++ <H3> <A HREF="rules_hex.html"> Hex Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_kram.html view
@@ -1,16 +1,16 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Kram Information </H2> - - Kram, or Cram, is a simple strategic game that has been invented many times. - - <H3> <A HREF="rules_kram.html"> Kram Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Kram Information </H2>++ Kram, or Cram, is a simple strategic game that has been invented many times.++ <H3> <A HREF="rules_kram.html"> Kram Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_nim.html view
@@ -1,16 +1,19 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Nim Information </H2> - - Nim is very well known as example game for game theory. There is an easy way to win the game if the starting number of rods is right. It becomes more interesting when there are more players, or more piles of rods (which isn't an option here). - - <H3> <A HREF="rules_nim.html"> Nim Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Nim Information </H2>++ Nim is very well known as example game for game theory. There is an+ easy way to win the game if the starting number of rods is right. It+ becomes more interesting when there are more players, or more piles+ of rods (which isn't an option here).++ <H3> <A HREF="rules_nim.html"> Nim Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_reversi.html view
@@ -1,18 +1,18 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Reversi Information </H2> - - Reversi was invented in England in 1888. In 1975 the game - was reïntroduced under the name Othello, with a minor change - of the rules. - - <H3> <A HREF="rules_reversi.html"> Reversi Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Reversi Information </H2>++ Reversi was invented in England in 1888. In 1975 the game+ was reïntroduced under the name Othello, with a minor change+ of the rules.++ <H3> <A HREF="rules_reversi.html"> Reversi Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_tictactoe.html view
@@ -1,18 +1,18 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Tictactoe Information </H2> - - Tictactoe is one of the easiest and best known strategic boardgames - in the world. You will probably find it in every book or program on - game theory, and this one is no exception. - - <H3> <A HREF="rules_tictactoe.html"> Tictactoe Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Tictactoe Information </H2>++ Tictactoe is one of the easiest and best known strategic boardgames+ in the world. You will probably find it in every book or program on+ game theory, and this one is no exception.++ <H3> <A HREF="rules_tictactoe.html"> Tictactoe Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/info_zenix.html view
@@ -1,14 +1,14 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Zenix Information </H2> - - <H3> <A HREF="rules_zenix.html"> Zenix Rules </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Zenix Information </H2>++ <H3> <A HREF="rules_zenix.html"> Zenix Rules </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_ataxx.html view
@@ -1,16 +1,22 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Ataxx Rules </H2> - - The object is to have more pieces in your color than your oponent. To do this you can move your pieces around. You can either move a piece to an adjacent square, it will then create a copy of itself. Alternatively, you can move a piece two squares away. After moving your piece, all pieces adjacent to the destination square will turn your color. When you can't move you have to skip your turn. When you can move you have to move. - - <H3> <A HREF="info_ataxx.html"> Ataxx Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Ataxx Rules </H2>++ The object is to have more pieces in your color than your opponent.+ To do this, you can move your pieces around. You can either move a+ piece to an adjacent square, it will then create a copy of itself.+ Alternatively, you can move a piece two squares away. After moving+ your piece, all pieces adjacent to the destination square will turn+ your color. When you can't move, you have to skip your turn. When+ you can move, you have to move.++ <H3> <A HREF="info_ataxx.html"> Ataxx Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_bamp.html view
@@ -1,20 +1,28 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Bamp Rules </H2> - - In Bamp, there is one ball, and a number of squares in four colors. The board is devided in four quadrants, each belonging to a player. When the ball is in your quadrant, you have to make a move. If you can't, you win. <BR> - - <BR> - - You make a move by selecting one of your square pieces that is in the same row or column as the ball. The piece will move to the position where the ball is, and the ball will move as far as possible in the same direction. If it ends up in another quadrant, another player moves. - - <H3> <A HREF="info_bamp.html"> Bamp Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Bamp Rules </H2>++ In Bamp, there is one ball, and a number of squares in four colors.+ The board is devided in four quadrants, each belonging to a player.+ When the ball is in your quadrant, you have to make a move. If you+ can't, you win. + <BR>++ <BR>++ You make a move by selecting one of your square pieces that is in+ the same row or column as the ball. The piece will move to the+ position where the ball is, and the ball will move as far as+ possible in the same direction. If it ends up in another quadrant,+ another player moves.++ <H3> <A HREF="info_bamp.html"> Bamp Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_halma.html view
@@ -1,20 +1,20 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Halma Rules </H2> - - The object of Halma is to be the first player to bring all your - pieces to the other end of the board. - You can move your pieces forward and sideward, but not backwards. - Instead of just moving, you can also jump over any number of - other pieces. Just point where you want to go. - - <H3> <A HREF="info_halma.html"> Halma Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Halma Rules </H2>++ The object of Halma is to be the first player to bring all your+ pieces to the other end of the board.+ You can move your pieces forward and sideward, but not backwards.+ Instead of just moving, you can also jump over any number of+ other pieces. Just point where you want to go.++ <H3> <A HREF="info_halma.html"> Halma Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_hex.html view
@@ -1,20 +1,20 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Hex Rules </H2> - - The object of Hex is to connect two sides of the board together with - a chain of circles. The blue player should connect the two blue sides, - while the red player must try to connect the two red sides. A chain - consists of adjacent circles of the same color. One of the players must - eventually win, it is not possible to end this game in a draw. - - <H3> <A HREF="info_hex.html"> Hex Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Hex Rules </H2>++ The object of Hex is to connect two sides of the board together with+ a chain of circles. The blue player should connect the two blue sides,+ while the red player must try to connect the two red sides. A chain+ consists of adjacent circles of the same color. One of the players must+ eventually win, it is not possible to end this game in a draw.++ <H3> <A HREF="info_hex.html"> Hex Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_kram.html view
@@ -1,21 +1,21 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Kram Rules </H2> - - In Kram, there are two players who must place rectangular pieces on the - board. One of the players may only place them horizontally, while the - other player must place the pieces vertically. Each piece is the size of - two squares on the board. The object of the game is to place more pieces - than your opponent. To place a piece, click on the square where you want - the left or upper half of your piece to be. - - <H3> <A HREF="info_kram.html"> Kram Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Kram Rules </H2>++ In Kram, there are two players who must place rectangular pieces on the+ board. One of the players may only place them horizontally, while the+ other player must place the pieces vertically. Each piece is the size of+ two squares on the board. The object of the game is to place more pieces+ than your opponent. To place a piece, click on the square where you want+ the left or upper half of your piece to be.++ <H3> <A HREF="info_kram.html"> Kram Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_nim.html view
@@ -1,16 +1,17 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Nim Rules </H2> - - The rules for this game are very easy. Each player takes one, two or three rods. The player who takes the last rod wins. - - <H3> <A HREF="info_nim.html"> Nim Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Nim Rules </H2>++ The rules for this game are very easy. Each player takes one, two or+ three rods. The player who takes the last rod wins.++ <H3> <A HREF="info_nim.html"> Nim Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_reversi.html view
@@ -1,21 +1,21 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Reversi Rules </H2> - - The object of the game is to get more pieces in your color than the opponent. - Every move you put a piece onto the board, such that you surround a line of your opponents pieces. - The line can be horizontal, vertical, or diagonal. - After you put your piece onto the board, all od the surrounded piecs become your color. - If you can make no legal move, you must skip your turn. - If you can make a legal move, you may not skip your turn. - - <H3> <A HREF="info_reversi.html"> Reversi Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Reversi Rules </H2>++ The object of the game is to get more pieces in your color than the opponent.+ Every move you put a piece onto the board, such that you surround a group of your opponents pieces.+ The line can be horizontal, vertical, or diagonal.+ After you put your piece onto the board, all of the surrounded pieces become your color.+ If you can make no legal move, you must skip your turn.+ If you can make a legal move, you may not skip your turn.++ <H3> <A HREF="info_reversi.html"> Reversi Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_tictactoe.html view
@@ -1,18 +1,18 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Tictactoe Rules </H2> - - Tictactoe is played on a 3x3 board. - Two players put their pieces in empty squares in turns. - The first player to make a row of three pieces wins. - - <H3> <A HREF="info_tictactoe.html"> Tictactoe Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Tictactoe Rules </H2>++ Tictactoe is played on a 3x3 board.+ Two players put their pieces in empty squares in turns.+ The first player to make a row of three pieces wins.++ <H3> <A HREF="info_tictactoe.html"> Tictactoe Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
help/rules_zenix.html view
@@ -1,20 +1,25 @@-<HTML> - - <BODY> - - <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR> - - <H2> Zenix Rules </H2> - - In Zenix, you have to make the highest connected chain of pieces in your color. Placing the pieces is subject to gravity, so you can only place a piece at the bottom or on top of two adjacent other pieces. <BR> - - <BR> - - A chain must always start at the bottom row, and go upward. The highest piece of your color that is connected with the bottom row, is the one that determines your score. - - <H3> <A HREF="info_zenix.html"> Zenix Information </A> </H3> - <H3> <A HREF="index.html"> Index </A> </H3> - - </BODY> - +<HTML>++ <BODY>++ <A HREF="index.html"> <IMG SRC="gebop.bmp"> </A> <BR>++ <H2> Zenix Rules </H2>++ In Zenix, you have to make the highest connected chain of pieces in+ your color. Placing the pieces is subject to gravity, so you can only+ place a piece at the bottom or on top of two adjacent other pieces.+ <BR>++ <BR>++ A chain must always start at the bottom row, and go upward. The+ highest piece of your color that is connected with the bottom row,+ is the one that determines your score.++ <H3> <A HREF="info_zenix.html"> Zenix Information </A> </H3>+ <H3> <A HREF="index.html"> Index </A> </H3>++ </BODY>+ </HTML>
readme.txt view
@@ -1,55 +1,55 @@------------------------ --- GeBoP version 1.7 -- ------------------------ - -This is the readme.txt file that comes with the source code of GeBoP, version 1.7. This source consists of the following files: - -* 15 Haskell source code files -* 2 Icon files -* This readme file -* 52 Bitmap images in a directory called 'images' -* 20 HTML files and a bitmap in a directory called 'help' - ------------------------------------- --- meaning of the various modules -- ------------------------------------- - -* Game -GeBoP works with a class Game, which is defined in the module Game. This class describes the general properties a boardgame should have. The Game module also includes the concept of a game tree, and a general algorithm to traverse this tree in order to find sensible moves. - -* Ataxx, Bamp, Halma, Hez, Kram, Nim, Reversi, TicTacToe, and Zenix -These are the implemented games. Each of these modules contains an instance of the Game class. - -* GUI -GUI is the module that contains the GUI itself. - -* Tools -This module is just an unstructured bunch of functions I use in other modules :). - -* HSL -This module implements the HSL color model. - -* Inf -This module defines the set of integers including two extra values <+infinity> and <-infinity> - -* Main -Main just imports the games and starts the GUI. - --------------------------- --- state of the program -- --------------------------- - -Version 1.7 of GeBoP is a nice and complete version. However, I could still do some work on the algorithms for playing the computer uses, and some of the games use rather naïve evaluation functions at the moment. I plan to do this some time in the near or otherwise far future. - -Since you are reading this file, you are probably a Haskell programmer. If you feel like implementing your favorite game for GeBoP, please go ahead and mail it to me when you're done :) - --------- --- me -- --------- - -My name is Maarten Löffler. I am currently a student at Utrecht University. - -I wrote GeBoP in my free time, because I like games and I like Haskell. When wxHaskell came to be, it became even more fun because of the nice graphical effects :) - -website at www.students.cs.uu.nl/people/mloffler +-----------------------+-- GeBoP version 1.7 --+-----------------------++This is the readme.txt file that comes with the source code of GeBoP, version 1.7. This source consists of the following files:++* 15 Haskell source code files+* 2 Icon files+* This readme file+* 52 Bitmap images in a directory called 'images'+* 20 HTML files and a bitmap in a directory called 'help'++------------------------------------+-- meaning of the various modules --+------------------------------------++* Game+GeBoP works with a class Game, which is defined in the module Game. This class describes the general properties a boardgame should have. The Game module also includes the concept of a game tree, and a general algorithm to traverse this tree in order to find sensible moves.++* Ataxx, Bamp, Halma, Hez, Kram, Nim, Reversi, TicTacToe, and Zenix+These are the implemented games. Each of these modules contains an instance of the Game class.++* GUI+GUI is the module that contains the GUI itself. ++* Tools+This module is just an unstructured bunch of functions I use in other modules :).++* HSL+This module implements the HSL color model.++* Inf+This module defines the set of integers including two extra values <+infinity> and <-infinity>++* Main+Main just imports the games and starts the GUI.++--------------------------+-- state of the program --+--------------------------++Version 1.7 of GeBoP is a nice and complete version. However, I could still do some work on the algorithms for playing the computer uses, and some of the games use rather naïve evaluation functions at the moment. I plan to do this some time in the near or otherwise far future.++Since you are reading this file, you are probably a Haskell programmer. If you feel like implementing your favorite game for GeBoP, please go ahead and mail it to me when you're done :)++--------+-- me --+--------++My name is Maarten Löffler. I am currently a student at Utrecht University. ++I wrote GeBoP in my free time, because I like games and I like Haskell. When wxHaskell came to be, it became even more fun because of the nice graphical effects :)++website at www.students.cs.uu.nl/people/mloffler email at mloffler@cs.uu.nl