GeBoP-1.7.4: Hex.hs
{-{ 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, win)
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
-}