diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/RELEASE-NOTES b/RELEASE-NOTES new file mode 100644 --- /dev/null +++ b/RELEASE-NOTES @@ -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 + +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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#! /usr/bin/env runhaskell + +> module Main (main) where +> +> import Distribution.Simple (defaultMain) +> +> main :: IO () +> main = defaultMain diff --git a/data/hstzaar.glade b/data/hstzaar.glade new file mode 100644 --- /dev/null +++ b/data/hstzaar.glade @@ -0,0 +1,208 @@ + + + + + + HsTZAAR + 600 + 600 + + + True + vertical + + + True + + + True + _Game + True + + + True + + + gtk-new + True + True + True + + + + + gtk-open + True + True + True + + + + + gtk-save + True + True + True + + + + + gtk-save-as + True + True + True + + + + + True + + + + + gtk-quit + True + True + True + + + + + + + + + True + _Move + True + + + True + + + gtk-undo + True + True + True + + + + + gtk-redo + True + True + True + + + + + True + + + + + True + Pass + True + + + + + + + + + True + _Options + True + + + True + + + True + Random start position + True + + + + + True + Show heights + True + + + + + True + _AI + True + + + True + + + + + + + + + + + False + 0 + + + + + True + 0 + 0 + none + + + + + + + label_item + + + + + 1 + + + + + True + True + + + True + end + + + 0 + + + + + True + 2 + + + 1 + + + + + False + 2 + + + + + + diff --git a/hstzaar.cabal b/hstzaar.cabal new file mode 100644 --- /dev/null +++ b/hstzaar.cabal @@ -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 . + +author: Pedro Vasconcelos +maintainer: Pedro Vasconcelos + +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 + diff --git a/src/AI/Lame.hs b/src/AI/Lame.hs new file mode 100644 --- /dev/null +++ b/src/AI/Lame.hs @@ -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 + diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs new file mode 100644 --- /dev/null +++ b/src/AI/Minimax.hs @@ -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 diff --git a/src/AI/Utils.hs b/src/AI/Utils.hs new file mode 100644 --- /dev/null +++ b/src/AI/Utils.hs @@ -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] + + + diff --git a/src/Board.hs b/src/Board.hs new file mode 100644 --- /dev/null +++ b/src/Board.hs @@ -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) + + diff --git a/src/GUI.hs b/src/GUI.hs new file mode 100644 --- /dev/null +++ b/src/GUI.hs @@ -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) + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,10 @@ +module Main (main) where + +import Paths_hstzaar +import GUI + +main :: IO () +main = do + gladepath <- getDataFileName "data/hstzaar.glade" + gui gladepath +