hstzaar (empty) → 0.1
raw patch · 11 files changed
+1627/−0 lines, 11 filesdep +basedep +cairodep +containerssetup-changed
Dependencies added: base, cairo, containers, glade, gtk, random
Files
- LICENSE +27/−0
- RELEASE-NOTES +21/−0
- Setup.lhs +8/−0
- data/hstzaar.glade +208/−0
- hstzaar.cabal +41/−0
- src/AI/Lame.hs +24/−0
- src/AI/Minimax.hs +284/−0
- src/AI/Utils.hs +64/−0
- src/Board.hs +311/−0
- src/GUI.hs +629/−0
- src/Main.hs +10/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Pedro Vasconcelo 2010++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. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS OR CONTRIBUTORS 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.
+ RELEASE-NOTES view
@@ -0,0 +1,21 @@+hstzaar 0.1 11/08/2010++- Switched the GUI interface to gtk2hs+cairo+- Added AI strategies using minimax and alpha-beta prunning+- Renamed the package to take up maintenance of this.++Pedro Vasconcelos <pbv@dcc.fc.up.pt>++htzaar 0.0.2 10/09/09++- Added other modules to htzaar.cabal.+- Added strategy helpers to AI.Utils (boardHeuristic, pruneBoardTree).++htzaar 0.0.1 10/07/09++- Fixed first turn caveat.+++htzaar 0.0.0 10/07/09++- Initial release.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#! /usr/bin/env runhaskell++> module Main (main) where+>+> import Distribution.Simple (defaultMain)+>+> main :: IO ()+> main = defaultMain
+ data/hstzaar.glade view
@@ -0,0 +1,208 @@+<?xml version="1.0"?>+<glade-interface>+ <!-- interface-requires gtk+ 2.6 -->+ <!-- interface-naming-policy toplevel-contextual -->+ <widget class="GtkWindow" id="mainwindow">+ <property name="title" translatable="yes">HsTZAAR</property>+ <property name="default_width">600</property>+ <property name="default_height">600</property>+ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <property name="orientation">vertical</property>+ <child>+ <widget class="GtkMenuBar" id="menubar1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkMenuItem" id="menuitem1">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Game</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_new">+ <property name="label">gtk-new</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_open">+ <property name="label">gtk-open</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_save">+ <property name="label">gtk-save</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_save_as">+ <property name="label">gtk-save-as</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkSeparatorMenuItem" id="separatormenuitem1">+ <property name="visible">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_quit">+ <property name="label">gtk-quit</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menuitem2">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Move</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu2">+ <property name="visible">True</property>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_undo">+ <property name="label">gtk-undo</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_redo">+ <property name="label">gtk-redo</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkSeparatorMenuItem" id="menuitem5">+ <property name="visible">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menu_item_pass">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Pass</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menuitem3">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Options</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu4">+ <property name="visible">True</property>+ <child>+ <widget class="GtkCheckMenuItem" id="menu_item_random_start">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Random start position</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkCheckMenuItem" id="menu_item_show_heights">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Show heights</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menuitem4">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_AI</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu_ai">+ <property name="visible">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkFrame" id="frame1">+ <property name="visible">True</property>+ <property name="label_xalign">0</property>+ <property name="label_yalign">0</property>+ <property name="shadow_type">none</property>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ <packing>+ <property name="type">label_item</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox1">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkProgressBar" id="progressbar">+ <property name="visible">True</property>+ <property name="ellipsize">end</property>+ </widget>+ <packing>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkStatusbar" id="statusbar">+ <property name="visible">True</property>+ <property name="spacing">2</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">2</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+</glade-interface>
+ hstzaar.cabal view
@@ -0,0 +1,41 @@+name: hstzaar+version: 0.1++category: Game++synopsis: A two player abstract strategy game.++description:+ HsTZAAR is an implementation of TZAAR ((c) 2007 Kris Brum),+ a two player abstract strategy game played on a hexagonal board.+ TZAAR is the the last game in the GIPF game series.+ This program is based on the (retired) htzaar implementation+ by Tom Hawkins <tomahawkins@gmail.com>.++author: Pedro Vasconcelos <pbv@ncc.up.pt>+maintainer: Pedro Vasconcelos <pbv@ncc.up.pt>++license: BSD3+license-file: LICENSE++homepage: http://www.ncc.up.pt/~pbv/stuff/hstzaar++build-type: Simple+cabal-version: >= 1.6+data-files: data/hstzaar.glade++extra-source-files:+ RELEASE-NOTES++executable hstzaar+ hs-source-dirs: src+ main-is: Main.hs+ other-modules: GUI Board AI.Utils AI.Lame AI.Minimax+ build-depends:+ base >= 4 && < 5,+ containers,+ gtk >=0.11, + cairo >= 0.11, + glade >= 0.11,+ random >= 1.0.0 && < 1.1+
+ src/AI/Lame.hs view
@@ -0,0 +1,24 @@+-- | An example AI player.+module AI.Lame (lame) where++import System.Random++import AI.Utils+import Board++lame :: AI+lame = AI+ { name = "lame"+ , description = "Randomly selects the next valid turn."+ , strategy = winOrPreventLoss lameStrategy+ }++-- | The lame strategy picks a valid turn at random. If a two-move turn is available, it picks one. (wow, pretty smart!)+lameStrategy :: Strategy+lameStrategy (GameTree _ branches) g = (turns !! i, g')+ where+ allTurns = fst $ unzip branches+ goodTurns = [ (m1, Just m2) | (m1, Just m2) <- allTurns ]+ turns = if null goodTurns then allTurns else goodTurns+ (i, g') = randomR (0, length turns - 1) g+
+ src/AI/Minimax.hs view
@@ -0,0 +1,284 @@++module AI.Minimax(greedy, ply2,ply3,ply4, dyn1, dyn2) where++import Data.List (sort, sortBy, maximumBy, minimumBy, nub, nubBy)+import qualified Data.Map as Map+import Data.Map (Map)+import AI.Utils+import Board+import Debug.Trace+++greedy :: AI+greedy = AI { name = "greedy"+ , description = "Maximize the static evaluation function"+ , strategy = (ifPieces (==60) + (firstTurn greedyStrategy)+ (ifPieces (>52)+ (onlyCaptureStack greedyStrategy)+ (narrowDoubleCaptures greedyStrategy)+ )+ )+ }+++ply2 :: AI+ply2 = AI { name = "ply2"+ , description = "Minimax with depth 2"+ , strategy = (ifPieces (==60) + (firstTurn $ minimaxStrategy 2 3)+ (narrowDoubleCaptures $ minimaxStrategy 2 3)+ )+ }++ply3 :: AI+ply3 = AI { name = "ply3"+ , description = "Minimax with depth 3"+ , strategy = (ifPieces (==60) + (firstTurn $ minimaxStrategy 3 3)+ (narrowDoubleCaptures $ minimaxStrategy 3 3)+ )+ }++ply4 :: AI+ply4 = AI { name = "ply4"+ , description = "Minimax with depth 4"+ , strategy = (ifPieces (==60) + (firstTurn $ minimaxStrategy 4 3)+ (narrowDoubleCaptures $ minimaxStrategy 4 3)+ )+ }+++dyn1 :: AI+dyn1 = AI { name = "dyn1"+ , description = "Minimax with dynamic depth 1-4"+ , strategy = (ifPieces (==60)+ (firstTurn greedyStrategy)+ (ifPieces (>52) + (onlyCaptureStack greedyStrategy)+ (narrowDoubleCaptures $ + ifPieces (>30)+ (minimaxStrategy 2 3)+ (ifPieces (>20)+ (minimaxStrategy 3 3)+ (minimaxStrategy 4 5)+ )+ )+ )+ )+ }+++dyn2 :: AI+dyn2 = AI { name = "dyn2"+ , description = "Minimax with dynamic depth 2-6"+ , strategy = (ifPieces (==60)+ (firstTurn greedyStrategy)+ (ifPieces (>52) + (onlyCaptureStack $ minimaxStrategy 2 3)+ (narrowDoubleCaptures $ + ifPieces (>30)+ (minimaxStrategy 3 3)+ (ifPieces (>20)+ (minimaxStrategy 4 3)+ (minimaxStrategy 6 5)+ )+ )+ )+ )+ }+++-- | A greedy strategy: locally maximize the static evaluation function+greedyStrategy :: Strategy+greedyStrategy (GameTree _ branches) rndgen + = trace ("Greedy score: " ++ show bestscore) (bestmove, rndgen)+ where + choices = [(m, eval $ root t) | (m,t)<-branches]+ (bestmove,bestscore)= maximumBy (\x y -> compare (snd x) (snd y)) choices+ root (GameTree x _) = x+++++-- | Minimaxing strategy to ply depth `n'+-- With alpha-beta and depth prunning+minimaxStrategy :: Int -> Int -> Strategy+minimaxStrategy n m g rndgen + = trace ("Minimax score: " ++ show bestscore) (bestmove, rndgen)+ where g' = prunebreadth m $ -- ^ cut to breadth $m$+ highfirst $ -- ^ order moves using static evaluation+ mapTree eval $ -- ^ apply evaluation function+ prunedepth n g -- ^ cut to depth $n$+ (bestmove,bestscore) = minimaxMove_ab (-inf) inf g'+++-- | Naive minimax algorithm+-- nodes should contain the static evaluation scores+minimax :: (Num a, Ord a) => GameTree a m -> a +minimax (GameTree x []) = x+minimax (GameTree _ branches) = - minimum (map (minimax.snd) branches)+++-- auxiliary function that returns the best first move+minimaxMove :: (Num a, Ord a) => GameTree a m -> (m,a)+minimaxMove (GameTree _ branches) = (m, -x)+ where (m,x) = minimumBy (\x y ->compare (snd x) (snd y)) [(m,minimax t) | (m,t)<-branches]+++-- | Minimax with alpha-beta prunning+minimax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a+minimax_ab a b (GameTree x []) = a `max` x `min` b+minimax_ab a b (GameTree _ branches) = cmx a b (map snd branches)+ where cmx a b [] = a+ cmx a b (t:ts) | a'>=b = b+ | otherwise = cmx a' b ts+ where a' = - (minimax_ab (-b) (-a) t)+++-- | This variant also returns the best move+-- should always be called with a non-empty tree+minimaxMove_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> (m,a)+minimaxMove_ab a b (GameTree x []) = (undefined, a`max`x`min`b)+minimaxMove_ab a b (GameTree _ branches@((m,_):_)) = cmx m a b branches+ where cmx m a b [] = (m,a)+ cmx m a b ((m',t):branches) + | a'>=b = (m,b)+ | otherwise = cmx m' a' b branches+ where a' = - (minimax_ab (-b) (-a) t)++ +++-- | Static evaluation function+eval :: (Bool,Board) -> Int+eval (True, b) = value b+eval (False,b) = - value (swapBoard b)++value :: Board -> Int+value b@(you,other)+ | pieces==0 || null captures = -inf+ | pieces'==0 || null captures' = inf+ | otherwise = threats + positional + where pieces = length $ nub $ map fst $ Map.elems you+ pieces'= length $ nub $ map fst $ Map.elems you+ captures = nextCaptureMoves b -- my captures+ captures'= nextCaptureMoves (swapBoard b) -- opponents's captures+ -- the zones of control for each player+ -- the active play has advantage for equal heights+ zoc = zoneOfControl (>=) b+ zoc'= zoneOfControl (>) (swapBoard b)++ -- the three piece types+ ts = [Tzaar, Tzarra, Tott]++ -- immediate threats+ threats = points safe' - points safe ++ -- pieces safe from immediate threat+ safe = minimum [count t you - min 2 (count t zoc') | t <- ts]+ safe'= minimum [count t other - min 2 (count t zoc) | t <- ts]++ points n | n<=0 = inf`div`2+ | n==1 = inf`div`4+ | otherwise = 0++ -- positional score+ -- sum heights multiplied by "relevance" factor + -- inside other player's ZoC+ positional = sum [material t zoc * relevance t other | t<-ts] -+ sum [material t zoc'* relevance t you | t<-ts] ++ -- lower count pieces types are more relevant+ relevance t r = 2^(15-count t r)++++++-- | count pieces of a particular type+count :: Type -> HalfBoard -> Int+count t r = Map.size $ Map.filter (\(t',_)->t'==t) r++-- | material score by piece type+-- sum height for stacks +material :: Type -> HalfBoard -> Int+material t r = Map.fold (\(t',h) s->if t==t' then s+h else s) 0 r+++-- | The "zone of control" of a player +-- | the opponent's pieces that can be captured in a turn++zoneOfControl :: (Int->Int->Bool) -> Board -> HalfBoard+zoneOfControl gt board@(you,other) + = Map.filterWithKey forPiece other+ where+ forPiece :: Position -> Piece -> Bool+ forPiece p (_, i) = or $ map (downLine i) $ sixLines p+ where+ downLine, downLine' :: Int -> [Position] -> Bool++ downLine i [] = False+ downLine i (p:ps) + = case atPosition board p of+ Nothing -> downLine i ps+ Just (True, (_, h)) -> h`gt`i+ Just (False, (_, j)) -> + or $ map (downLine' (max i j)) $ sixLines p++ downLine' i [] = False+ downLine' i (p:ps) + = case atPosition board p of+ Nothing -> downLine' i ps+ Just (True, (_, h)) -> h`gt`i+ Just (False, _) -> False++ ++++-- a higher value than legitimate evaluation scores+inf :: Int+inf = 2^20+++-- | narrow the search space: single capture first move+firstTurn :: Strategy -> Strategy+firstTurn s (GameTree node branches) rndgen + = s (GameTree node branches') rndgen+ where branches' = [((m,Nothing),g) | ((m,Nothing), g)<-branches]++-- | narrow the search space: consider only capture-stacking turns+onlyCaptureStack :: Strategy -> Strategy +onlyCaptureStack s g rndgen = s (narrowTree g) rndgen+ where+ narrowTree :: BoardTree -> BoardTree+ narrowTree (GameTree node@(b, (you,_)) branches)+ | b = GameTree node [ ((m1,Just m2), narrowTree g) + | ((m1,Just m2), g)<-branches,+ snd m2 `Map.member` you+ ]+ | otherwise = GameTree node [ (t, narrowTree g) | (t,g)<-branches ]+++-- | eliminate double-captures that lead to the same board+narrowDoubleCaptures :: Strategy -> Strategy+narrowDoubleCaptures s g rndgen = s (nubTree g) rndgen+ where+ nubTree :: BoardTree -> BoardTree+ nubTree (GameTree node branches) + = GameTree node $ nubBy equiv [(t, nubTree g) | (t,g)<-branches]+ where+ equiv ((m1,Just m2),_) ((m2', Just m1'),_)+ = fst m1/=fst m2 && m1==m1' && m2==m2'+ equiv _ _ = False+ ++-- | use different strategies depedening on the number of pieces left+ifPieces :: (Int -> Bool) -> Strategy -> Strategy -> Strategy+ifPieces cond s1 s2 g@(GameTree (_,(you,other)) branches) rndgen+ | cond n = s1 g rndgen -- use the 1st strategy+ | otherwise = s2 g rndgen -- use the 2nd strategy+ where+ n = Map.size you + Map.size other
+ src/AI/Utils.hs view
@@ -0,0 +1,64 @@+-- | Utilities for AI players.+module AI.Utils+ ( winOrPreventLoss+ , mapTree+ , prunedepth+ , prunebreadth+ , highfirst+ , lowfirst+ ) where++import Board+import Data.List (sortBy, minimumBy)++-- | Searches BoardTree to a depth of 1 looking for a +-- | guaranteed win or a preventable loss.+winOrPreventLoss :: Strategy -> Strategy+winOrPreventLoss s (GameTree a branches) = s $ GameTree a branches2+ where+ winning = [ (t, b) | (t, b@(GameTree _ [])) <- branches ]+ losing = [ t | (t, (GameTree _ branches')) <- branches, + (_, (GameTree _ [])) <- branches' ]+ branches1 = if not $ null winning+ then [head winning]+ else if length branches<100 then [ (t, b) | (t, b) <- branches, notElem t losing ] else branches+ branches2 = if null branches1 then [head branches] else branches1+++-- | some auxiliary functions over game trees+-- apply a function to each node+mapTree :: (a->b) -> GameTree a m -> GameTree b m+mapTree f (GameTree x branches) + = GameTree (f x) [(m,mapTree f t) | (m,t)<-branches]++-- apply a function to each edge+mapTree' :: (a->b) -> GameTree s a -> GameTree s b+mapTree' f (GameTree x branches) + = GameTree x [(f m,mapTree' f t) | (m,t)<-branches]+++-- heuristic to order subtrees with highest values first+highfirst, lowfirst :: + (Ord a) => GameTree a m -> GameTree a m+highfirst (GameTree x branches) + = GameTree x $ sortBy cmp [(m,lowfirst t) | (m,t)<-branches]+ where cmp (_,GameTree x _) (_,GameTree y _) = compare y x++lowfirst (GameTree x branches) + = GameTree x $ sortBy cmp [(m,highfirst t) | (m,t)<-branches]+ where cmp (_,GameTree x _) (_, GameTree y _) = compare x y+++-- prune to a fixed depth+prunedepth :: Int -> GameTree a m -> GameTree a m+prunedepth n (GameTree x branches) + | n>0 = GameTree x [(m,prunedepth (n-1) t) | (m,t)<-branches]+ | otherwise = GameTree x []++-- prune to a fixed breadth+prunebreadth :: Int -> GameTree a m -> GameTree a m+prunebreadth n (GameTree x branches) + = GameTree x [(m, prunebreadth n t) | (m,t)<-take n branches]+++
+ src/Board.hs view
@@ -0,0 +1,311 @@+-- | Board State and AI+module Board+ (+ -- * Types+ Board+ , HalfBoard+ , BoardTree+ , GameTree(..)+ , Type (..)+ , Piece+ , Position (..)+ , Move+ , Turn+ -- , AtPosition+ , Strategy+ , AI (..)+ -- * Utilities+ , boardTree+ , swapBoard+ , swapBoardTree+ , nextCaptureMoves+ , nextStackingMoves+ , nextTurns+ , connectedPositions+ , threeLines+ , sixLines+ , atPosition+ , startingBoard+ , randomBoard+ , showTurn+ , showMove+ , applyMove+ , applyTurn+ ) where++import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import System.Random+import Control.Monad(mplus)++-- | The board state is a pair of two "half-boards" (one per player)+type Board = (HalfBoard, HalfBoard)++-- | A Half-board maps locations to pieces +type HalfBoard = Map Position Piece++-- | A game tree with nodes s and moves m+data GameTree s m = GameTree s [(m, GameTree s m)] deriving Show++-- | A game tree of boards labeled with a boolean +-- the label is True if your turn, False if opponent.+type BoardTree = GameTree (Bool,Board) Turn++-- | The three types of pieces+-- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts.+data Type = Tzaar | Tzarra | Tott deriving (Show, Eq)++-- | the type of a piece, and the level of the stack (starting with 1).+type Piece = (Type, Int)++-- | Board position. Letters left to right, numbers bottom to top.+-- Column E has the hole in the middle.+data Position+ = A1 | A2 | A3 | A4 | A5+ | B1 | B2 | B3 | B4 | B5 | B6+ | C1 | C2 | C3 | C4 | C5 | C6 | C7+ | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8+ | E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8+ | F1 | F2 | F3 | F4 | F5 | F6 | F7 | F8+ | G1 | G2 | G3 | G4 | G5 | G6 | G7+ | H1 | H2 | H3 | H4 | H5 | H6+ | I1 | I2 | I3 | I4 | I5+ deriving (Show, Eq, Ord, Enum, Bounded)++-- | A move is one position to another, for either capturing or stacking.+type Move = (Position, Position)++-- | A complete turn is move, followed by an optional move.+type Turn = (Move, Maybe Move)++-- | An AI strategy calculates the next turn from a board tree.+type Strategy = BoardTree -> StdGen -> (Turn, StdGen)++-- | An AI player.+data AI = AI+ { name :: String -- ^ Name of AI.+ , description :: String -- ^ Brief description of AI.+ , strategy :: Strategy -- ^ The strategy.+ }++-- | The state of a single board position; Right true if you, Left if opponent.+-- type AtPosition = Either Piece Piece++-- | List of all positions (for enumeration purposes)+positions :: [Position]+positions = [minBound .. maxBound]++showTurn :: Turn -> String+showTurn (a, Nothing) = showMove a+showTurn (a, Just b ) = showMove a ++ " " ++ showMove b++showMove :: Move -> String+showMove (a, b) = show a ++ " -> " ++ show b++++-- | Possible next turns.+nextTurns :: Board -> [Turn]+nextTurns board@(you, _)+ | lostOneOfThree = []+ | otherwise = captureCapture ++ captureStack ++ captureNothing+ where+ a = nextCaptureMoves board+ b = map (applyMove board) a+ c = map nextCaptureMoves b+ d = map nextStackingMoves b+ captureCapture = [ (a, Just b) | (a, x) <- zip a c, b <- x ]+ captureStack = [ (a, Just b) | (a, x) <- zip a d, b <- x ]+ captureNothing = zip a $ repeat Nothing+ lostOneOfThree = length (nub [t | (t, _)<-Map.elems you]) /= 3+++nextCaptureMoves :: Board -> [Move]+nextCaptureMoves board@(you, _) = concatMap forPiece (Map.assocs you)+ where+ forPiece :: (Position,Piece) -> [Move]+ forPiece (p, (_, i)) = concatMap downLine $ sixLines p+ where+ downLine :: [Position] -> [Move]+ downLine [] = []+ downLine (a:b) = case atPosition board a of+ Nothing -> downLine b+ Just (True, _) -> []+ Just (False, (_, j)) -> [(p, a) | i>=j]++nextStackingMoves :: Board -> [Move]+nextStackingMoves board@(you, _) = concatMap forPiece (Map.keys you)+ where+ forPiece :: Position -> [Move]+ forPiece p = concatMap downLine $ sixLines p+ where+ downLine :: [Position] -> [Move]+ downLine [] = []+ downLine (a:b) = case atPosition board a of+ Nothing -> downLine b+ Just (False, _) -> []+ Just (True, (Tzaar,_)) | oneTzaarRemaining -> []+ Just (True, (Tzarra,_)) | oneTzarraRemaining -> []+ Just (True, (Tott, _)) | oneTottRemaining -> []+ Just (True, _) -> [(p, a)]+ oneTzaarRemaining = 1 == Map.size (Map.filter (\(t,_)->t==Tzaar) you)+ oneTzarraRemaining = 1 == Map.size (Map.filter (\(t,_)->t==Tzarra) you)+ oneTottRemaining = 1 == Map.size (Map.filter (\(t,_)->t==Tott) you)++++++-- Creates a board tree for you and opponent. Assumes you have the next turn.+boardTree :: Board -> BoardTree+boardTree board = mkTree True board+ where+ mkTree :: Bool -> Board -> BoardTree+ mkTree you b+ = GameTree (you,if you then b else swapBoard b) + [ (t, mkTree (not you) $ swapBoard $ applyTurn b t) + | t<-nextTurns b]+++++-- | Swaps board positions, i.e. white to black, black to white.+swapBoard :: Board -> Board+swapBoard (a, b) = (b, a)++-- | Swaps board trees, i.e. white to black, black to white.+swapBoardTree :: BoardTree -> BoardTree+swapBoardTree (GameTree (you,board) branches) = GameTree (not you,swapBoard board) [ (t, swapBoardTree bt) | (t, bt) <- branches ]+++-- Querying the state of a board position.+atPosition :: Board -> Position -> Maybe (Bool,Piece)+atPosition (you,opp) pos + = do { piece<-Map.lookup pos you+ ; return (True,piece) + } `mplus`+ do { piece<-Map.lookup pos opp+ ; return (False,piece)+ }+++-- | All the lines that form connected positions on the board.+connectedPositions :: [[Position]]+connectedPositions =+ [ [A1, A2, A3, A4, A5]+ , [B1, B2, B3, B4, B5, B6]+ , [C1, C2, C3, C4, C5, C6, C7]+ , [D1, D2, D3, D4, D5, D6, D7, D8]+ , [E1, E2, E3, E4]+ , [E5, E6, E7, E8]+ , [F1, F2, F3, F4, F5, F6, F7, F8]+ , [G1, G2, G3, G4, G5, G6, G7]+ , [H1, H2, H3, H4, H5, H6]+ , [I1, I2, I3, I4, I5]++ , [A1, B1, C1, D1, E1]+ , [A2, B2, C2, D2, E2, F1]+ , [A3, B3, C3, D3, E3, F2, G1]+ , [A4, B4, C4, D4, E4, F3, G2, H1]+ , [A5, B5, C5, D5]+ , [F4, G3, H2, I1]+ , [B6, C6, D6, E5, F5, G4, H3, I2]+ , [C7, D7, E6, F6, G5, H4, I3]+ , [D8, E7, F7, G6, H5, I4]+ , [E8, F8, G7, H6, I5]+ + , [E1, F1, G1, H1, I1]+ , [D1, E2, F2, G2, H2, I2]+ , [C1, D2, E3, F3, G3, H3, I3]+ , [B1, C2, D3, E4, F4, G4, H4, I4]+ , [A1, B2, C3, D4]+ , [F5, G5, H5, I5]+ , [A2, B3, C4, D5, E5, F6, G6, H6]+ , [A3, B4, C5, D6, E6, F7, G7]+ , [A4, B5, C6, D7, E7, F8]+ , [A5, B6, C7, D8, E8]+ ]++-- | The three lines that cross at a single board position.+threeLines :: Position -> [[Position]]+threeLines p = [ line | line <- connectedPositions, elem p line ]+++-- | The six lines traveling radially out from a single board position.+-- | optimization: this function is lazily memoied ++sixLines_memo :: Map Position [[Position]]+sixLines_memo = Map.fromList [(p, radials p) | p<-positions]+ where radials p = [r | l<-threeLines p, r<-divide p l, not (null r)]+ divide a b = [reverse x, y]+ where (x, _:y) = span (/= a) b++sixLines :: Position -> [[Position]]+sixLines p = Map.findWithDefault undefined p sixLines_memo++++++-- | The next board state after a move. Assumes move is valid.+applyMove :: Board -> Move -> Board+applyMove board@(a, b) (x, y) + | fromA = (Map.insert y piece (Map.delete x a'), b')+ | otherwise = (a', Map.insert y piece (Map.delete x b'))+ where+ Just (whoX, (typeX, sizeX)) = atPosition board x+ Just (whoY, (_ , sizeY)) = atPosition board y+ capture = whoX /= whoY+ fromA = Map.member x a+ piece = (typeX, if capture then sizeX else sizeX + sizeY)+ a' = Map.delete y a+ b' = Map.delete y b++-- | The next board state after a complete turn. Assumes turn is valid.+applyTurn :: Board -> Turn -> Board+applyTurn board (a, Just b ) = applyMove (applyMove board a) b+applyTurn board (a, Nothing) = applyMove board a++++-- | The default (non-randomized, non-tournament) starting position.+startingBoard :: Board+startingBoard = (Map.fromList whites, Map.fromList blacks)+ where+ f t p = (p, (t, 1))+ whites = map (f Tzaar) wTzaars ++ map (f Tzarra) wTzarras ++ map (f Tott) wTotts+ blacks = map (f Tzaar) bTzaars ++ map (f Tzarra) bTzarras ++ map (f Tott) bTotts+ wTzaars = [D3, E3, G4, G5, C5, D6]+ wTzarras = [C2, D2, E2, H3, H4, H5, B5, C6, D7]+ wTotts = [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]+ bTzaars = [C3, C4, F3, G3, E6, F6]+ bTzarras = [B2, B3, B4, F2, G2, H2, E7, F7, G6]+ bTotts = [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, G7, H6, D4, E5, F4]+++-- | A randomized starting position+randomBoard :: StdGen -> (Board, StdGen)+randomBoard rnd + = ((Map.fromList whites, Map.fromList blacks), rnd')+ where pieces = replicate 6 (Tzaar,1) +++ replicate 9 (Tzarra,1) +++ replicate 15 (Tott,1)+ (positions',rnd') = shuffle rnd positions+ whites = zip (take 30 positions') pieces+ blacks = zip (drop 30 positions') pieces+++-- an auxilary function to shuffle a list randomly+shuffle :: StdGen -> [a] -> ([a], StdGen)+shuffle g xs = shuffle' g xs (length xs)+ where+ shuffle' :: RandomGen g => g -> [a] -> Int -> ([a], g)+ shuffle' g xs n + | n>0 = let (k, g') = randomR (0,n-1) g+ (xs',x:xs'') = splitAt k xs+ (ys,g'') = shuffle' g' (xs' ++ xs'') (n-1)+ in (x:ys, g'')+ | otherwise = ([],g)++
+ src/GUI.hs view
@@ -0,0 +1,629 @@+++module GUI (gui) where++import Graphics.UI.Gtk hiding (eventSent,on)+import Graphics.UI.Gtk.Gdk.Events+import Graphics.UI.Gtk.Glade+import Graphics.Rendering.Cairo+import Data.Function (on)+import Data.Maybe (fromJust)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.List (minimumBy, sortBy)+import Data.IORef+import Control.Concurrent+import Control.Monad (when)+import System.Random+import Board+import AI+++-- record to hold the game state+data State = State+ { bt :: BoardTree+ , history :: [State]+ , future :: [State]+ , stdGen :: StdGen+ , ai :: AI+ , stage :: Stage+ }++data Stage+ = Start0 -- first turn, single move+ | Start1 Position+ | Wait0 -- subsequent turns, two moves+ | Wait1 Position -- 1st position+ | Wait2 Move -- 1st move+ | Wait3 Move Position -- 1st move, 2nd position+ | Wait4 Turn -- end of turn, waiting for AI+ | Finish -- game end+ deriving Eq+++-- a reference to mutable state+type StateRef = IORef State++-- a state with an empty board (before game start)+emptyState :: StdGen -> State+emptyState rnd = State { bt = boardTree emptyboard,+ history = [],+ future = [],+ stdGen = rnd,+ ai = undefined,+ stage = Finish+ }+ where emptyboard = (Map.empty, Map.empty)++++-- initial state (at game start)+initState :: Bool -> StdGen -> AI -> State+initState randomstart g ai + = State { bt = boardTree board+ , history = []+ , future = []+ , stdGen = g'+ , ai = ai+ , stage = Start0+ }+ where (board, g') | randomstart = randomBoard g+ | otherwise = (startingBoard, g)++++-- a record to hold GUI elements+data GUI = GUI {+ mainwin :: Window,+ canvas :: DrawingArea,+ statusbar:: Statusbar,+ progressbar:: ProgressBar,+ menu_item_new :: MenuItem,+ menu_item_quit :: MenuItem,+ menu_item_undo :: MenuItem,+ menu_item_redo :: MenuItem,+ menu_item_pass :: MenuItem,+ menu_item_show_heights :: CheckMenuItem,+ menu_item_random_start :: CheckMenuItem,+ menu_item_ai_players :: [RadioMenuItem],+ contextid :: ContextId+ }+++gui :: String -> IO ()+gui gladepath = + do initGUI+ gui <- loadGlade gladepath+ rnd <- getStdGen+ stateRef <- newIORef (emptyState rnd)+ connect_events gui stateRef++ -- timer event for running other threads+ timeoutAdd (yield >> return True) 50+ -- timer event for updating the progress bar & gui widgets+ timeoutAdd (updateProgress gui stateRef >> return True) 100+ timeoutAdd (updateWidgets gui stateRef >> return True) 500++ -- start event loop+ mainGUI++++-- load gui elements from XML Glade file+loadGlade gladepath =+ do out <- xmlNew gladepath+ when (out==Nothing) $ error "failed to load glade file"+ let Just xml = out+ mw <- xmlGetWidget xml castToWindow "mainwindow"+ fr <- xmlGetWidget xml castToFrame "frame1"+ sb <- xmlGetWidget xml castToStatusbar "statusbar"+ pb <- xmlGetWidget xml castToProgressBar "progressbar"+ mn <- xmlGetWidget xml castToMenuItem "menu_item_new"+ mq <- xmlGetWidget xml castToMenuItem "menu_item_quit"+ mun<- xmlGetWidget xml castToMenuItem "menu_item_undo"+ mre<- xmlGetWidget xml castToMenuItem "menu_item_redo"+ mpa<- xmlGetWidget xml castToMenuItem "menu_item_pass"+ msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights"+ mrs<- xmlGetWidget xml castToCheckMenuItem "menu_item_random_start"++ -- fill in dynamic parts+ bd <- drawingAreaNew+ containerAdd fr bd+ + m<- xmlGetWidget xml castToMenu "menu_ai"+ r <- radioMenuItemNewWithLabel (name $ head ai_players)+ menuAttach m r 0 1 0 1+ rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name t) + menuAttach m w 0 1 i (i+1)+ return w+ | (t,i)<-zip (tail ai_players) [1..]]+++ cid <- statusbarGetContextId sb "status"+ widgetShowAll mw+ return $ GUI mw bd sb pb mn mq mun mre mpa msh mrs (r:rs) cid++++connect_events gui stateRef + = do onExpose (canvas gui) $ \x -> + do drawCanvas gui stateRef+ return (eventSent x)+ onButtonPress (canvas gui) $ \x ->+ do mp<-getPosition (canvas gui) (eventX x) (eventY x)+ case mp of + Nothing -> return (eventSent x)+ Just p -> do selectPosition gui stateRef p+ return (eventSent x)++ sequence_ [ onActivateLeaf item (set_ai player)+ | (player,item) <- + zip ai_players (menu_item_ai_players gui) ]+ + onDestroy (mainwin gui) mainQuit+ onActivateLeaf (menu_item_quit gui) mainQuit++ onActivateLeaf (menu_item_new gui) $+ do newGame gui stateRef+ redrawCanvas (canvas gui)++ onActivateLeaf (menu_item_undo gui) $ + do modifyIORef stateRef undoHistory+ redrawCanvas (canvas gui)+ onActivateLeaf (menu_item_redo gui) $ + do modifyIORef stateRef redoHistory+ redrawCanvas (canvas gui)++ onActivateLeaf (menu_item_pass gui) (movePass gui stateRef)++ onActivateLeaf (menu_item_show_heights gui) $+ redrawCanvas (canvas gui)+++ where set_ai player = modifyIORef stateRef $ \s->s{ai=player}+++newGame :: GUI -> StateRef -> IO ()+newGame gui stateRef+ = do s <- readIORef stateRef+ ai <- getAI gui+ random <- checkMenuItemGetActive (menu_item_random_start gui)+ writeIORef stateRef $ initState random (stdGen s) ai+ updateWidgets gui stateRef+ gui `pushMsg` "Ready"+++-- get the selected AI player+getAI :: GUI -> IO AI+getAI gui + = do bs <- sequence [checkMenuItemGetActive item + | item<-menu_item_ai_players gui]+ return $ head [ai | (True,ai)<-zip bs ai_players] ++++-- methods to update the status bar+pushMsg :: GUI -> String -> IO ()+pushMsg gui txt + = statusbarPush (statusbar gui) (contextid gui) txt >> return ()++popMsg :: GUI -> IO ()+popMsg gui = statusbarPop (statusbar gui) (contextid gui) >> return ()+++++-- update progress bar if we are waiting for AI+updateProgress :: GUI -> StateRef -> IO ()+updateProgress gui stateRef+ = do s <- readIORef stateRef+ case stage s of+ Wait4 _ -> progressBarPulse (progressbar gui)+ _ -> progressBarSetFraction (progressbar gui) 0+ ++-- update widgets sensitivity +updateWidgets :: GUI -> StateRef -> IO ()+updateWidgets gui stateRef+ = do s<-readIORef stateRef+ -- move undo/redo + case stage s of+ Wait4 _ -> do widgetSetSensitive (menu_item_undo gui) False+ widgetSetSensitive (menu_item_redo gui) False+ _ -> do widgetSetSensitive (menu_item_undo gui) (notNull $ history s)+ widgetSetSensitive (menu_item_redo gui) (notNull $ future s)+ -- move pass+ case stage s of + Wait2 _ -> widgetSetSensitive (menu_item_pass gui) True+ _ -> widgetSetSensitive (menu_item_pass gui) False+ +++notNull :: [a] -> Bool+notNull = not . null+++-- handle undo and redo buttons+undoHistory :: State -> State+undoHistory s + = case history s of+ [] -> s+ (s':ss) -> s' {history=ss, future=r:future s}+ where r = recState s+++redoHistory :: State -> State+redoHistory s + = case future s of+ [] -> s+ (s':ss) -> s' {history=r:history s, future=ss}+ where r = recState s+++-- "recordable state" projection+recState :: State -> State+recState s = s { stage = stage' }+ where stage' = case stage s of+ Start1 _ -> Start0+ Wait1 _ -> Wait0+ Wait3 m _ -> Wait2 m+ _ -> stage s+++-- pass the 2nd move of a turn+movePass :: GUI -> StateRef -> IO ()+movePass gui stateRef + = do s <- readIORef stateRef+ case stage s of+ Wait2 m -> dispatchTurn gui stateRef s (m,Nothing)+ _ -> return ()+++redrawCanvas :: DrawingArea -> IO ()+redrawCanvas canvas+ = do (w,h)<-widgetGetSize canvas+ drawin <- widgetGetDrawWindow canvas+ drawWindowInvalidateRect drawin (Rectangle 0 0 w h) False+++-- redraw the canvas using double-buffering+drawCanvas :: GUI -> StateRef -> IO ()+drawCanvas gui stateRef + = do b <- checkMenuItemGetActive (menu_item_show_heights gui)+ (w,h)<-widgetGetSize (canvas gui)+ drawin <- widgetGetDrawWindow (canvas gui)+ state <- readIORef stateRef+ renderWithDrawable drawin $+ renderWithSimilarSurface ContentColor w h $ + \tmp -> + do renderWith tmp (setTransform w h >> renderBoard b state)+ setSourceSurface tmp 0 0+ paint+++-- render the board and pieces+renderBoard :: Bool -> State -> Render ()+renderBoard heights state+ = do -- paint the background + boardBg >> paint+ -- paint the playing area light gray+ gray 0.9 >> polyLine [A1, A5, E8, I5, I1, E1] >> closePath >> fill+ -- repaint the center with background color+ boardBg >> polyLine [D4, D5, E5, F5, F4, E4]>> closePath >> fill+ -- draw the grid and coordinates+ renderGrid+ -- draw the pieces & highlight selection+ case stage state of+ Start0 -> pieces board >>= renderHeights heights+ Start1 p -> pieces board >>= renderHeights heights >> highlight p+ Wait0 -> pieces board >>= renderHeights heights+ Wait1 p -> pieces board >>= renderHeights heights >> highlight p+ Wait2 m -> pieces (applyMove board m) >>= renderHeights heights+ Wait3 m p -> pieces (applyMove board m) >>= renderHeights heights + >> highlight p+ Wait4 t -> pieces (applyTurn board t) >>= renderHeights heights+ Finish -> pieces board >>= renderHeights heights+ where GameTree (_,board) _ = bt state+++-- draw the hexagonal grid and edge coordinates+renderGrid :: Render ()+renderGrid = do gray 0+ setLineWidth 1+ sequence_ [lineFromTo p1 p2 | (p1,p2)<-lines] + setFontSize 22+ sequence_ [do uncurry moveTo $ tr (-10,60) $ boardPosition p+ showText (show p) + | p<-[A1,B1,C1,D1,E1,F1,G1,H1,I1]]+ sequence_ [do uncurry moveTo $ tr (-10,-50) $ boardPosition p+ showText (show p) + | p<-[A5, B6,C7,D8,E8,F8,G7,H6,I5]]+ where tr (dx,dy) (x,y) = (x+dx,y+dy)+ lineFromTo p1 p2 = do uncurry moveTo $ boardPosition p1+ uncurry lineTo $ boardPosition p2+ stroke+ lines = [(A1,A5), (B1,B6), (C1,C7), (D1,D8), (E1,E4),+ (E5,E8), (F1,F8), (G1,G7), (H1,H6), (I1,I5),+ (A1,E1), (A2,F1),(A3,G1), (A4,H1), + (A5, D5), (F4,I1), (B6,I2), (C7,I3), (D8,I4), (E8,I5),+ (E1,I1), (D1,I2), (C1,I3), (B1,I4), (A1,D4), (F5,I5),+ (A5,E8), (A4,F8), (A3,G7), (A2,H6)]++++-- setup coordinate transform for the board+setTransform :: Int -> Int -> Render ()+setTransform w h + = do translate (fromIntegral w/2) (fromIntegral h/2)+ scale (fromIntegral side/1000) (fromIntegral side/1000) + where side = min w h -- constraint to square aspect ratio++ +++-- board background (pale yellow)+boardBg :: Render ()+boardBg = setSourceRGB 1 0.95 0.6 ++-- shades of gray from 0 (black) to 1 (white)+gray :: Double -> Render ()+gray x = setSourceRGB x x x+ ++-- draw a polygonal line+polyLine :: [Position] -> Render ()+polyLine (p:ps) = do uncurry moveTo $ boardPosition p+ sequence_ [uncurry lineTo $ boardPosition p'|p'<-ps]+++-- highlight a position+highlight :: Position -> Render ()+highlight p = do setSourceRGBA 1 0 0 0.5+ setLineWidth 4+ newPath+ uncurry (ring 1.5) $ boardPosition p+++data PieceColor = White | Black deriving (Eq,Show)++-- render all pieces in the board+-- returns the original board for futher use+pieces :: Board -> Render Board+pieces board@(whites,blacks) + = do setLineWidth 2+ mapM_ piece ps+ return board+ -- sort pieces by reverse position to draw from back to front+ where ps = sortBy cmp $ + zip (repeat White) (Map.assocs whites) +++ zip (repeat Black) (Map.assocs blacks)+ cmp (_, (x,_)) (_, (y,_)) = compare y x+++piece :: (PieceColor,(Position,(Type,Int))) -> Render ()+piece (c,(p,(t,size))) = stack size yc+ where (xc,yc)= boardPosition p+ (chipColor, lineColor, crownColor) + = case c of+ White-> (setSourceRGB 1 1 1, + setSourceRGB 0 0 0, + setSourceRGB 0.25 0.25 0)+ Black-> (setSourceRGB 0 0 0, + setSourceRGB 1 1 1, + setSourceRGB 1 0.8 0)+ stack 0 y = case t of + Tott -> return ()+ Tzarra -> crownColor >> disc 0.4 xc y+ Tzaar -> crownColor >> disc 0.8 xc y >> + chipColor >> disc 0.6 xc y >>+ crownColor >> disc 0.4 xc y+ stack n y + | n>0 = do chipColor >> disc 1 xc y+ lineColor >> ring 1 xc y+ stack (n-1) $ if n>1 then y-8 else y++++disc :: Double -> Double -> Double -> Render ()+disc r x y = arc x y (r*33) 0 (2*pi) >> fill++ring :: Double -> Double -> Double -> Render ()+ring r x y = arc x y (r*33) 0 (2*pi) >> stroke+++-- label each position with the stack height+-- ignore single piece stacks+renderHeights :: Bool -> Board -> Render ()+renderHeights b (whites,blacks)+ = when b $ do setSourceRGB 1 0 0 + setFontSize 32+ mapM_ renderHeight (Map.assocs whites)+ mapM_ renderHeight (Map.assocs blacks)+ where+ renderHeight (p, (_, h)) + | h>1 = do moveTo (x-10) y+ showText (show h)+ | otherwise = return ()+ where (x,y) = boardPosition p+++++-- convert a canvas coordinate to a board position+getPosition :: DrawingArea -> Double -> Double -> IO (Maybe Position)+getPosition canvas x y+ = do (w,h)<-widgetGetSize canvas+ drawin<- widgetGetDrawWindow canvas+ (xu, yu)<- renderWithDrawable drawin (setTransform w h >> + deviceToUser x y)+ let (p, d) = minimumBy (compare `on` snd) + [(p, (xu - x')^2 + (yu - y')^2) + | (p, (x', y')) <- Map.assocs boardPositions ]+ return (if d<900 then Just p else Nothing)++++-- dispatch a button click on a board position+selectPosition :: GUI -> StateRef -> Position -> IO ()+selectPosition gui stateRef p+ = do s<-readIORef stateRef + let GameTree _ branches = bt s+ let turns = fst $ unzip branches+ case stage s of+ Start0 | notNull [p0 | ((p0, _), _)<-turns, p0==p] -> + let s'= s { history = s : history s,+ future = [],+ stage = Start1 p }+ in do writeIORef stateRef s'+ redrawCanvas cv+ Start1 p0 | p0==p -> do writeIORef stateRef $ s {stage=Start0}+ redrawCanvas cv+ Start1 p0 | notNull [m | (m, _)<- turns, m==(p0,p)] -> + dispatchTurn gui stateRef s ((p0,p),Nothing)+ ---+ Wait0 | notNull [p0 | ((p0, _), _)<-turns, p0==p] -> + let s'= s { history = s : history s,+ future = [],+ stage=Wait1 p }+ in do writeIORef stateRef s'+ redrawCanvas cv+ Wait1 p0 | p0==p -> do writeIORef stateRef $ s {stage=Wait0}+ redrawCanvas cv+ Wait1 p0 | notNull [m | (m, _)<- turns, m==(p0,p)] -> + do writeIORef stateRef $ s {stage=Wait2 (p0,p)}+ redrawCanvas cv + Wait2 m | notNull [p0 | (m', Just (p0, _))<-turns, m==m', p0==p] -> + let s'=s { history = s : history s,+ future = [],+ stage = Wait3 m p } + in do writeIORef stateRef s'+ redrawCanvas cv+ Wait3 m p0 | p0==p -> do writeIORef stateRef $ s {stage=Wait2 m}+ redrawCanvas cv+ Wait3 m p0 | t`elem`turns -> dispatchTurn gui stateRef s t+ where t = (m, Just (p0, p))+ _ -> return ()+ where cv = canvas gui++++dispatchTurn :: GUI -> StateRef -> State -> Turn -> IO ()+dispatchTurn gui stateRef s t+ | null branches' -- white wins+ = let s' = s { stage = Finish, + bt = swapBoardTree bt', + stdGen = g }+ in do gui `pushMsg` "White wins"+ writeIORef stateRef s'+ redrawCanvas (canvas gui)+ | otherwise + = do { writeIORef stateRef $ s {stage = Wait4 t}+ ; redrawCanvas (canvas gui)+ ; gui `pushMsg` "Thinking..."+ ; forkIO child+ ; return ()+ }+ + where+ child = if null branches'' then+ let s'= s { stage = Finish, + bt = bt'', + stdGen = g }+ in do writeIORef stateRef s'+ redrawCanvas (canvas gui)+ gui `pushMsg` "Black wins"+ else+ let s' = s { stage = Wait0,+ bt = bt'',+ stdGen = g+ }+ in do writeIORef stateRef s'+ redrawCanvas (canvas gui)+ gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t')+ + GameTree _ branches = bt s+ bt'@(GameTree _ branches') = swapBoardTree $ fromJust $ lookup t branches+ (t', g) = strategy (ai s) bt' (stdGen s)+ bt''@(GameTree _ branches'') + = swapBoardTree $ case lookup t' branches' of+ Nothing -> error $ "Invalid AI Turn: " ++ show t'+ Just a -> a+++++boardPosition :: Position -> (Double,Double)+boardPosition p = Map.findWithDefault undefined p boardPositions++boardPositions :: Map Position (Double,Double)+boardPositions + = Map.fromList + [ (A1, p (-4) (-2))+ , (A2, p (-4) (-1))+ , (A3, p (-4) ( 0))+ , (A4, p (-4) ( 1))+ , (A5, p (-4) ( 2))+ , (B1, p (-3) (-3))+ , (B2, p (-3) (-2))+ , (B3, p (-3) (-1))+ , (B4, p (-3) ( 1))+ , (B5, p (-3) ( 2))+ , (B6, p (-3) ( 3))+ , (C1, p (-2) (-3))+ , (C2, p (-2) (-2))+ , (C3, p (-2) (-1))+ , (C4, p (-2) ( 0))+ , (C5, p (-2) ( 1))+ , (C6, p (-2) ( 2))+ , (C7, p (-2) ( 3))+ , (D1, p (-1) (-4))+ , (D2, p (-1) (-3))+ , (D3, p (-1) (-2))+ , (D4, p (-1) (-1))+ , (D5, p (-1) ( 1))+ , (D6, p (-1) ( 2))+ , (D7, p (-1) ( 3))+ , (D8, p (-1) ( 4))+ , (E1, p ( 0) (-4))+ , (E2, p ( 0) (-3))+ , (E3, p ( 0) (-2))+ , (E4, p ( 0) (-1))+ , (E5, p ( 0) ( 1))+ , (E6, p ( 0) ( 2))+ , (E7, p ( 0) ( 3))+ , (E8, p ( 0) ( 4))+ , (F1, p ( 1) (-4))+ , (F2, p ( 1) (-3))+ , (F3, p ( 1) (-2))+ , (F4, p ( 1) (-1))+ , (F5, p ( 1) ( 1))+ , (F6, p ( 1) ( 2))+ , (F7, p ( 1) ( 3))+ , (F8, p ( 1) ( 4))+ , (G1, p ( 2) (-3))+ , (G2, p ( 2) (-2))+ , (G3, p ( 2) (-1))+ , (G4, p ( 2) ( 0))+ , (G5, p ( 2) ( 1))+ , (G6, p ( 2) ( 2))+ , (G7, p ( 2) ( 3))+ , (H1, p ( 3) (-3))+ , (H2, p ( 3) (-2))+ , (H3, p ( 3) (-1))+ , (H4, p ( 3) ( 1))+ , (H5, p ( 3) ( 2))+ , (H6, p ( 3) ( 3))+ , (I1, p ( 4) (-2))+ , (I2, p ( 4) (-1))+ , (I3, p ( 4) ( 0))+ , (I4, p ( 4) ( 1))+ , (I5, p ( 4) ( 2))+ ]+ where+ p :: Int -> Int -> (Double, Double)+ p x y = (100*x',-100*y')+ where+ x' = fromIntegral x * sin (pi / 3)+ y' | even x = fromIntegral y+ | otherwise = fromIntegral y - (fromIntegral (signum y) * 0.5)+
+ src/Main.hs view
@@ -0,0 +1,10 @@+module Main (main) where++import Paths_hstzaar+import GUI++main :: IO ()+main = do+ gladepath <- getDataFileName "data/hstzaar.glade"+ gui gladepath+