GeBoP 1.7 → 1.7.1
raw patch · 15 files changed
+359/−277 lines, 15 filesdep ~wxdep ~wxcore
Dependency ranges changed: wx, wxcore
Files
- Ataxx.hs +26/−20
- Bamp.hs +25/−18
- GUI.hs +110/−110
- Game.hs +3/−2
- GeBoP.cabal +5/−3
- HSL.hs +15/−4
- Halma.hs +40/−28
- Hex.hs +20/−16
- Kram.hs +19/−15
- Nim.hs +8/−6
- Reversi.hs +19/−18
- TicTacToe.hs +10/−9
- Tools.hs +22/−12
- Zenix.hs +24/−16
- changelog.txt +13/−0
Ataxx.hs view
@@ -8,8 +8,8 @@ import Game import Array -- import Graphics.UI.WX -import Graphics.UI.WX hiding (border) -import Graphics.UI.WXCore +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) @@ -52,8 +52,9 @@ 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 + board p pr vart ia move' = do marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero @@ -79,7 +80,7 @@ ) 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) + case st ! (i, j) of Just p' -> drawPiece p' dc $ field g (i, j) Nothing -> return () )) case e of @@ -88,21 +89,21 @@ 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 + move' 0 else return () onclick :: Point -> IO () - onclick pt = do + onclick point = do t <- varGet vart g <- varGet varg let Ataxx st = state t - n = locate g pt + 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 pt = do + onunclick point = do t <- varGet vart g <- varGet varg e <- varGet vare @@ -110,12 +111,12 @@ Nothing -> return () Just m -> do let Ataxx st = state t - n = locate g pt + 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 + Just i -> move' i set p [ on click := onclick , on unclick := onunclick @@ -124,37 +125,42 @@ ] allMoves :: Int -> Player -> Array (Int, Int) (Maybe Player) -> [AtaxxMove] -allMoves bsz p s +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 + 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 p [] = True + 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)) +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 + check m f' | not $ inRange (bounds s) m = False + | otherwise = s ! m == f' move _ Nothing (p, rs) = (1 - p, rs) grows :: [(Int, Int)] @@ -168,8 +174,8 @@ 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] - 1 -> set dc [brushColor := rgb 192 96 32] + 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) []
Bamp.hs view
@@ -7,8 +7,8 @@ import Game import Array -import Graphics.UI.WX hiding (border) -import Graphics.UI.WXCore +import Graphics.UI.WX hiding (border, point) +import Graphics.UI.WXCore hiding (point) import Tools data BampField @@ -22,9 +22,11 @@ isPortal (Portal _) = True isPortal _ = False +{- isPiece :: BampField -> Bool isPiece (Piece _) = True isPiece _ = False +-} data Bamp = Bamp (Array (Int, Int) BampField) deriving (Eq, Show) @@ -74,7 +76,7 @@ }-} | otherwise = [0, 0, 0, 0] - board p pr vart ia move = do + board p pr vart _ia move' = do marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero @@ -105,14 +107,14 @@ )) onclick :: Point -> IO () - onclick pt = do + onclick point = do t <- varGet vart g <- varGet varg let Bamp st = state t - n = locate g pt + n = locate g point case lookup n $ zip (allMoves (boardsize pr) (player t) st) [0..] of Nothing -> return () - Just i -> move i + Just i -> move' i set p [ on click := onclick , on paint := onpaint @@ -125,44 +127,49 @@ | 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 dc (Rect x y w h) Empty = return () +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] +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 +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 + && 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)]) + 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) + 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
GUI.hs view
@@ -6,17 +6,15 @@ module GUI (gui, version) where -import Game --- import Graphics.UI.WX -import Graphics.UI.WX hiding (bitmap) +import Game -- hiding (name) +import Graphics.UI.WX hiding (bitmap, children, click, selections, stop) import Graphics.UI.WXCore -import Random import Char -import Tools +import Tools hiding (field) import List version :: String -version = "1.7" +version = "1.7.1" gui :: [GeneralGame] -> IO () gui games = do @@ -193,8 +191,8 @@ 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 + ss <- sequence $ map (\p' -> hslider p' False 0 10 []) ps + bs <- sequence $ map (\p' -> singleListBox p' []) ps --{ field <- statusField [] @@ -225,9 +223,10 @@ logo 3 = logopurple logo 4 = logobrown logo 5 = logogrey + logo _ = error "logo: Unexpected value" onpaintplayer :: Int -> DC () -> Rect -> IO () - onpaintplayer i dc r@(Rect x y w h) = do + 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 @@ -243,16 +242,16 @@ t <- getTree when (player t == i) $ send clock - playerpanel i p sli box = do - but <- button p [] - stt <- staticText p [] + playerpanel i p' sli box = do + but <- button p' [] + stt <- staticText p' [] itemAppend box $ "" set sli [ clientSize := Size 60 20 , color := setLum 0.25 $ colorplayer i , bgcolor := setLum 0.95 $ colorplayer i , on command := do v <- sliderGetValue sli - set stt [text := show (2 ^ v) ++ " sec"] + set stt [text := show ((2 :: Int) ^ v) ++ " sec"] , visible := not (human pr !!! i) , selection := 3 ] @@ -276,33 +275,33 @@ 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 - ] - ] + 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 + boxInsert p' s = do + let b = (bs !!! p') i <- get b itemCount - set b [item (i - 1) := s] - mapM_ (\b -> set b [selection := i - 1]) bs + 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 + win i' = do t <- getTree - return $ (movesnr t == 0) && (val t !!! i == 1) + return $ (movesnr t == 0) && (val t !!! i' == 1) gamename = (\(c : cs) -> toUpper c : cs) $ name g @@ -343,14 +342,14 @@ think :: IO () think = do t <- getTree js <- randomList - let p = path followcombination js t + let p' = path followcombination js t --{ let p = path followbest js t - updateTree $ step p + updateTree $ step p' u <- getTree when (val t /= val u) $ sequence_ $ map repaint ps b <- varGet varb - bUpdatePath b p + bUpdatePath b p' return () @@ -469,7 +468,7 @@ bPlayer <- staticBitmapCreate pRight (-1) (logos !!! 0) rectNull (-1) - tPlayer <- staticText pRight [] + -- tPlayer <- staticText pRight [] tMind <- staticText pInfo [] tMaxd <- staticText pInfo [] tVolume <- staticText pInfo [] @@ -487,8 +486,8 @@ gamename = (\(c : cs) -> toUpper c : cs) $ name g getData :: TreeItem -> IO [Int] - getData item = do - mmovs <- unsafeTreeCtrlGetItemClientData tc item + getData treeItem = do + mmovs <- unsafeTreeCtrlGetItemClientData tc treeItem case mmovs of Just movs -> return movs Nothing -> return [] @@ -529,63 +528,63 @@ line dc (pt x 20) (pt (x + w) 20) [] onTreeEvent :: EventTree -> IO () - onTreeEvent (TreeItemExpanding item veto) | treeItemIsOk item = do + onTreeEvent (TreeItemExpanding treeItem _veto) | treeItemIsOk treeItem = do wxcBeginBusyCursor - children <- treeCtrlGetChildren tc item - mapM_ visualise children + children' <- treeCtrlGetChildren tc treeItem + mapM_ visualise children' wxcEndBusyCursor propagateEvent - onTreeEvent (TreeSelChanged item olditem) | treeItemIsOk item = do + onTreeEvent (TreeSelChanged treeItem _olditem) | treeItemIsOk treeItem = do wxcBeginBusyCursor - selectRight item + selectRight treeItem wxcEndBusyCursor propagateEvent onTreeEvent _ = propagateEvent visualise :: TreeItem -> IO () - visualise item = do - c <- treeCtrlItemHasChildren tc item - when (c == 0) $ giveBirth item - updateThickness item - updateImages item + visualise treeItem = do + c <- treeCtrlItemHasChildren tc treeItem + when (c == 0) $ giveBirth treeItem + updateThickness treeItem + updateImages treeItem selectRight :: TreeItem -> IO () - selectRight item = do - updateRight item + 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 item = do - t <- gametree item + 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 + bClose' :: IO () + bClose' = close f - bUpdatePath :: [Int] -> IO () - bUpdatePath path = do + bUpdatePath' :: [Int] -> IO () + bUpdatePath' path' = do root <- treeCtrlGetRootItem tc - updatePath root path + updatePath root path' where updatePath :: TreeItem -> [Int] -> IO () - updatePath item path = do - updateThickness item - updateImages item - ifIO (treeCtrlIsSelected tc item) $ updateRight item - ifIO (treeCtrlIsExpanded tc item) $ case path of - (i:is) -> do cs <- treeCtrlGetChildren tc item + updatePath 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 + bRefresh' :: IO () + bRefresh' = do treeCtrlDeleteAllItems tc --{ root <- treeCtrlAddRoot tc "current situation" 5 (-1) objectNull root <- treeCtrlAddRoot tc "current situation" 12 12 objectNull @@ -597,32 +596,32 @@ selectRight root giveBirth :: TreeItem -> IO () - giveBirth item = do - movs <- getData item - t <- gametree item + giveBirth treeItem = do + movs <- getData treeItem + t <- gametree treeItem for 0 (movesnr t - 1) (\i -> do - let u = shear i t + let -- u = shear i t m = showmove pr (player t) (state t) i ---{ jtem <- treeCtrlAppendItem tc item (show i ++ " (" ++ m ++ ")") (player t) (-1) objectNull - jtem <- treeCtrlAppendItem tc item (show i ++ " (" ++ m ++ ")") (-1) (-1) objectNull +--{ 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 item (movesnr t > 0) + treeCtrlSetItemHasChildren tc treeItem (movesnr t > 0) updateThickness :: TreeItem -> IO () - updateThickness item = do - t <- gametree item + updateThickness treeItem = do + t <- gametree treeItem let itemcolor | filled t = black | otherwise = grey - treeCtrlSetItemTextColour tc item itemcolor - treeCtrlSetItemBold tc item (closed t) + treeCtrlSetItemTextColour tc treeItem itemcolor + treeCtrlSetItemBold tc treeItem (closed t) updateImages :: TreeItem -> IO () - updateImages item = do - t <- gametree item - c <- treeCtrlItemHasChildren tc item - cs <- treeCtrlGetChildren tc item + 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 @@ -630,18 +629,18 @@ ) setImage :: TreeItem -> Int -> IO () - setImage item i = do - j <- treeCtrlGetItemImage tc item 0 --{ wxTreeItemIcon_Normal + setImage treeItem i = do + j <- treeCtrlGetItemImage tc treeItem 0 --{ wxTreeItemIcon_Normal when (i /= j) $ do - treeCtrlSetItemImage tc item i 0 --{ wxTreeItemIcon_Normal - treeCtrlSetItemImage tc item i 1 --{ wxTreeItemIcon_Selected ---{ treeCtrlSetItemImage tc item i 2 --{ wxTreeItemIcon_Expanded ---{ treeCtrlSetItemImage tc item i 3 --{ wxTreeItemIcon_SelectedExpanded + 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 item = do + gametree treeItem = do t <- varGet vart - movs <- getData item + movs <- getData treeItem return $ gametree_ movs t where -- gametree_ :: [Int] -> Tree g -> Tree g @@ -652,23 +651,23 @@ playerinput :: Int -> IO () playerinput i = do info $ "brain moverequest: " ++ show i - item <- treeCtrlGetSelection tc - t <- gametree item - cs <- treeCtrlGetChildren tc item + treeItem <- treeCtrlGetSelection tc + t <- gametree treeItem + cs <- treeCtrlGetChildren tc treeItem when (0 <= i && i < movesnr t) $ do - treeCtrlExpand tc item + treeCtrlExpand tc treeItem treeCtrlSelectItem tc (cs !! i) {--== MODIFICATION PHASE ==--} board pBoard pr varu False playerinput - bRefresh + bRefresh' -- setImages True setImages False - varSet varb $ Brain bClose bUpdatePath bRefresh + 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 ] @@ -744,11 +743,12 @@ 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] + 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" @@ -758,25 +758,25 @@ ++ "\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 +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 +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 +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
@@ -123,7 +123,7 @@ -- 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 +update _i t = computeVal $ t { closed = and $ map closed $ elems $ children t , mind = case filter (not . closed) $ elems $ children t of [] -> inf @@ -137,6 +137,7 @@ 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 @@ -152,7 +153,7 @@ 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 + | 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
GeBoP.cabal view
@@ -3,7 +3,7 @@ Description: The games: Ataxx, Bamp, Halma, Hez, Kram, Nim, Reversi, TicTacToe, and Zenix Homepage: http://www.haskell.org/haskellwiki/GeBoP -Version: 1.7 +Version: 1.7.1 License: BSD3 License-file: LICENSE.txt Author: Maarten Löffler @@ -14,6 +14,7 @@ Category: Game Tested-with: GHC == 6.10.4 Extra-Source-Files: + changelog.txt readme.txt, Ataxx.hs, Bamp.hs, @@ -110,11 +111,12 @@ Executable gebop Build-Depends: base < 3.1, - wxcore >= 0.11 && < 0.12, - wx >= 0.11 && < 0.12, + 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)
HSL.hs view
@@ -22,13 +22,17 @@ 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 = round $ 255 * l + | 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 @@ -43,9 +47,12 @@ in v colorHSL c = - let var_r = (fromInteger . toInteger $ colorRed c) / 255 - var_g = (fromInteger . toInteger $ colorGreen c) / 255 - var_b = (fromInteger . toInteger $ colorBlue c) / 255 + 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 @@ -60,8 +67,12 @@ | 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
Halma.hs view
@@ -8,8 +8,8 @@ import Game import Array -- import Graphics.UI.WX -import Graphics.UI.WX hiding (border) -import Graphics.UI.WXCore +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) @@ -40,18 +40,20 @@ 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 + 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)) + 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 + 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)) + varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero + vare <- varCreate (Nothing :: Maybe (Int, Int)) let @@ -69,18 +71,18 @@ 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) + 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 ..] + 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 + 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) + 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) @@ -100,22 +102,22 @@ 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 + case e of Just p' -> drawBrightPiece dc (field g $ tograte p') radius Nothing -> return () onclick :: Point -> IO () - onclick pt = do + onclick point = do t <- varGet vart e <- varGet vare g <- varGet varg let Halma st = state t - n = fromgrate $ locate g pt + 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 + Just i -> varSet vare Nothing >> repaint p >> move' i set p [ on click := onclick , on unclick := onclick @@ -131,12 +133,12 @@ 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] + 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) + 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] @@ -159,8 +161,8 @@ Just 0 -> blue Just 1 -> red Just 2 -> green - Just 3 -> rgb 160 0 192 - Just 4 -> rgb 192 128 0 + Just 3 -> rgb 160 0 (192 :: Int) + Just 4 -> rgb 192 128 (0 :: Int) Just 5 -> grey _ -> black @@ -172,12 +174,15 @@ | otherwise = stepmoves ++ jumpmoves where mypieces :: Player -> [(Int, Int)] - mypieces p = map (\(i, e) -> i) $ filter (\(i, e) -> e == Just p) $ assocs st + 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 + 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 @@ -189,7 +194,7 @@ $ halfjumps in foldr ($) fs $ map (\u -> floodfill u . (u :)) news totaldist :: Player -> Int - totaldist p = sum $ map (dist pr p) $ mypieces p + totaldist p' = sum $ map (dist pr p') $ mypieces p' steps :: Properties -> Player -> [(Int, Int)] steps pr p = steppos (pos pr p) @@ -200,9 +205,12 @@ 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)] @@ -216,30 +224,34 @@ 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 look like this: +{- the halmaboard internally looks like this: y/j
Hex.hs view
@@ -11,8 +11,8 @@ import Game import Array -import Graphics.UI.WX hiding (border) -import Graphics.UI.WXCore +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) @@ -37,13 +37,14 @@ 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) + 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 + board p pr vart _ia move' = do + marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero @@ -61,7 +62,7 @@ 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) + 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] @@ -78,15 +79,15 @@ ) ) onclick :: Point -> IO () - onclick pt = do + onclick point = do t <- varGet vart g <- varGet varg let Hex st = state t bsz = boardsize pr - n = fromgrate bsz $ locate g pt + n = fromgrate bsz $ locate g point case lookup n $ zip (allMoves pr (player t) st) [0..] of Nothing -> return () - Just i -> move i + Just i -> move' i set p [ on click := onclick , on paint := onpaint @@ -98,9 +99,10 @@ 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] + 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) @@ -129,24 +131,26 @@ | 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)]) +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_ 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) + 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)]) @@ -155,7 +159,7 @@ , ((-1, -2), [( 0, -1), (-1, -1)]) , (( 1, -1), [( 1, 0), ( 0, -1)]) ] - +-} {- the hexboard internally look like this:
Kram.hs view
@@ -7,8 +7,8 @@ import Game import Array -import Graphics.UI.WX hiding (border) -import Graphics.UI.WXCore +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) @@ -50,8 +50,9 @@ 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 + board p pr vart ia move' = do marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero @@ -75,24 +76,24 @@ ) 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)) + 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 + move' 0 else return () onclick :: Point -> IO () - onclick pt = do + onclick point = do t <- varGet vart g <- varGet varg let Kram st = state t - n = Just $ locate g pt + n = Just $ locate g point case lookup n $ zip (allMoves (boardsize pr) (player t) st) [0..] of Nothing -> return () - Just i -> move i + Just i -> move' i set p [ on click := onclick , on paint := onpaint @@ -101,11 +102,12 @@ drawPiece :: Player -> DC () -> Rect -> IO () drawPiece 0 dc (Rect x y w h) = do - set dc [brushColor := rgb 96 16 255 ] + 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 ] + 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 @@ -113,13 +115,15 @@ | otherwise = map Just $ valid p s where valid :: Player -> Array (Int, Int) (Either Player Bool) -> [(Int, Int)] - valid p s = filter mag $ indices s + 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 (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 _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"
Nim.hs view
@@ -34,9 +34,9 @@ | otherwise = replicate (players pr) 0 where prev :: Player -> Player - prev p = (p - 1) `mod` players pr + prev p' = (p' - 1) `mod` players pr - board p pr vart _ move = do + board p _pr vart _ move' = do st <- staticText p [ text := "There are currently quite a number of rods.\n" ] b1 <- button p [] @@ -45,15 +45,15 @@ let - onpaint dc r = do + 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 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] @@ -63,6 +63,7 @@ return () +{- dist :: Int -> Int -> Int dist x y = let i = x * x + y * y f = fromInteger $ toInteger i @@ -74,6 +75,7 @@ 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
@@ -50,8 +50,9 @@ 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 + board p pr vart ia move' = do marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero @@ -75,24 +76,24 @@ ) 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) + 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 + move' 0 else return () onclick :: Point -> IO () - onclick pt = do + onclick point' = do t <- varGet vart g <- varGet varg let Reversi st = state t - n = Just $ locate g pt + n = Just $ locate g point' case lookup n $ zip (allMoves (boardsize pr) (player t) st) [0..] of Nothing -> return () - Just i -> move i + Just i -> move' i set p [ on click := onclick , on paint := onpaint @@ -101,8 +102,8 @@ 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 ] - 1 -> set dc [brushColor := rgb 192 64 16 ] + 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) [] @@ -110,26 +111,26 @@ (a, b) +- (c, d) = (a + c, b + d) allMoves :: Int -> Player -> Array (Int, Int) (Maybe Player) -> [Maybe (Int, Int)] -allMoves bsz p s +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 + 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 + 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) + 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 + 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)) +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]] @@ -141,6 +142,6 @@ | 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 + check m' f | not $ inRange (bounds s) m' = False + | otherwise = s ! m' == f move _ Nothing (p, rs) = (1 - p, rs)
TicTacToe.hs view
@@ -6,8 +6,8 @@ module TicTacToe (TicTacToe, tictactoe) where import Game -import Graphics.UI.WX hiding (border) -import Graphics.UI.WXCore +import Graphics.UI.WX hiding (border, point) +import Graphics.UI.WXCore hiding (point) import Tools data TicTacToe = TicTacToe [Maybe Player] deriving (Eq, Show) @@ -32,20 +32,20 @@ possible _ = PropertyRange { playersrange = [2], boardsizerange = [3] } - new p = TicTacToe $ replicate 9 Nothing + 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)] + 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 + board p _pr vart _ia move' = do marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero @@ -71,19 +71,20 @@ 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 pt = do + onclick point = do t <- varGet vart g <- varGet varg let TicTacToe st = state t - (i, j) = locate g pt + (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 + Just n' -> move' n' set p [ on click := onclick , on paint := onpaint
Tools.hs view
@@ -21,7 +21,7 @@ -- list functions -- maximumWith, minimumWith :: (a -> a -> Ordering) -> [a] -> [a] -maximumWith p [] = [] +maximumWith _ [] = [] maximumWith p (x : xs) = case maximumWith p xs of [] -> [x] (y : ys) -> case p x y @@ -31,7 +31,7 @@ minimumWith = maximumWith . flip (|>) :: Int -> a -> [a] -> [a] -(|>) 0 y (x : xs) = y : xs +(|>) 0 y (_ : xs) = y : xs (|>) n y (x : xs) = x : (|>) (n - 1) y xs (|>) _ _ _ = error "(|>): index out of bounds" @@ -95,16 +95,26 @@ 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 x - | x `mod` (10 ^ q) == 0 = numberword (x `div` (10 ^ q)) ++ s - | otherwise = numberword (x - x `mod` (10 ^ q)) ++ t ++ numberword (x `mod` (10 ^ q)) + 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 @@ -140,7 +150,7 @@ tileBitmap :: DC () -> Rect -> Bitmap () -> IO () -tileBitmap dc (Rect x y w h) bmp = do +tileBitmap dc (Rect _x _y w h) bmp = do bw <- bitmapGetWidth bmp bh <- bitmapGetHeight bmp for 0 (w `div` bw) (\i -> @@ -156,20 +166,20 @@ 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) + 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) + 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 + 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)
Zenix.hs view
@@ -11,8 +11,8 @@ import Game import Array -import Graphics.UI.WX hiding (border) -import Graphics.UI.WXCore +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) @@ -38,27 +38,30 @@ 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 + | 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] + 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 + 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] + 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 + good x = st ! (x, y) == Just p' && (x `elem` xs || (x + 1) `elem` xs) - board p pr vart ia move = do + board p pr vart _ia move' = do marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero @@ -73,11 +76,13 @@ 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] @@ -90,15 +95,15 @@ )) onclick :: Point -> IO () - onclick pt = do + onclick point = do t <- varGet vart g <- varGet varg let Zenix st = state t bsz = boardsize pr - n = fromgrate bsz $ locate g pt + n = fromgrate bsz $ locate g point case lookup n $ zip (allMoves pr (player t) st) [0..] of Nothing -> return () - Just i -> move i + Just i -> move' i set p [ on click := onclick , on paint := onpaint @@ -108,17 +113,20 @@ return () drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO () -drawPiece dc (Rect x y w h) r mp = do +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 +allMoves pr _p st | otherwise = filter free $ indices st where bsz = boardsize pr
+ changelog.txt view
@@ -0,0 +1,13 @@+ +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 +