Initial implementation of Turkish rules.

refs #26.

Author: portnov

python/hcheckers/common.py

@@ -237,7 +237,8 @@ def get_ok_button(self):
         ("brazilian", _("Brazilian draughts")),
         ("canadian", _("Canadian draughts")),
         ("spancirety", _("Spancirety draughts")), 
-        ("diagonal", _("Diagonal draughts"))
+        ("diagonal", _("Diagonal draughts")),
+        ("turkish", _("Turkish draughts"))
     ]
 
 rules_dict = dict(supported_rules)

src/Core/Board.hs

@@ -73,10 +73,16 @@ boardDirection Bottom ForwardLeft = UpLeft
 boardDirection Bottom ForwardRight = UpRight
 boardDirection Bottom BackwardLeft = DownLeft
 boardDirection Bottom BackwardRight = DownRight
+boardDirection Bottom Forward = Up
+boardDirection Bottom Backward = Down
 boardDirection Top ForwardLeft = DownRight
 boardDirection Top ForwardRight = DownLeft
 boardDirection Top BackwardLeft = UpRight
 boardDirection Top BackwardRight = UpLeft
+boardDirection Top Backward = Up
+boardDirection Top Forward = Down
+boardDirection _ PRight = ToRight
+boardDirection _ PLeft = ToLeft
 
 boardSide :: BoardOrientation -> Side -> BoardSide
 boardSide FirstAtBottom First = Bottom
@@ -98,22 +104,36 @@ playerDirection First UpLeft = ForwardLeft
 playerDirection First UpRight = ForwardRight
 playerDirection First DownLeft = BackwardLeft
 playerDirection First DownRight = BackwardRight
+playerDirection First Up = Forward
+playerDirection First Down = Backward
 playerDirection Second UpLeft = BackwardRight
 playerDirection Second UpRight = BackwardLeft
 playerDirection Second DownLeft = ForwardRight
 playerDirection Second DownRight = ForwardLeft
+playerDirection Second Down = Forward
+playerDirection Second Up = Backward
+playerDirection _ ToRight = PRight
+playerDirection _ ToLeft = PLeft
 
 oppositeDirection :: PlayerDirection -> PlayerDirection
 oppositeDirection ForwardLeft = BackwardRight
 oppositeDirection ForwardRight = BackwardLeft
 oppositeDirection BackwardLeft = ForwardRight
 oppositeDirection BackwardRight = ForwardLeft
+oppositeDirection Forward = Backward
+oppositeDirection Backward = Forward
+oppositeDirection PRight = PLeft
+oppositeDirection PLeft = PRight
 
 neighbour :: BoardDirection -> Address -> Maybe Address
 neighbour UpLeft a = aUpLeft a
 neighbour UpRight a = aUpRight a
 neighbour DownLeft a = aDownLeft a
 neighbour DownRight a = aDownRight a
+neighbour Up a = aUp a
+neighbour ToRight a = aRight a
+neighbour Down a = aDown a
+neighbour ToLeft a = aLeft a
 
 myNeighbour :: HasBoardOrientation rules => rules -> Side -> PlayerDirection -> Address -> Maybe Address
 myNeighbour rules side dir a = neighbour (myDirection rules side dir) a
@@ -124,6 +144,10 @@ getNeighbourDirection src dst
   | aUpRight src == Just dst = Just UpRight
   | aDownLeft src == Just dst = Just DownLeft
   | aDownRight src == Just dst = Just DownRight
+  | aUp src == Just dst = Just Up
+  | aRight src == Just dst = Just ToRight
+  | aDown src == Just dst = Just Down
+  | aLeft src == Just dst = Just ToLeft
   | otherwise = Nothing
 
 getNeighbourDirection' :: Board -> Address -> Label -> Maybe BoardDirection
@@ -432,33 +456,6 @@ kingMove side src dir n = Move src $ replicate n (Step dir False False)
 firstMoveDirection :: Move -> PlayerDirection
 firstMoveDirection move = sDirection $ head $ moveSteps move
 
-makeLine :: [Label] -> [Address]
-makeLine labels = map (\l -> Address l Nothing Nothing Nothing Nothing Nothing) labels
-
-line1labels :: [Label]
-line1labels = ["a1", "c1", "e1", "g1"]
-
-line2labels :: [Label]
-line2labels = ["b2", "d2", "f2", "h2"]
-
-line3labels :: [Label]
-line3labels = ["a3", "c3", "e3", "g3"]
-
-line4labels :: [Label]
-line4labels = ["b4", "d4", "f4", "h4"]
-
-line5labels :: [Label]
-line5labels = ["a5", "c5", "e5", "g5"]
-
-line6labels :: [Label]
-line6labels = ["b6", "d6", "f6", "h6"]
-
-line7labels :: [Label]
-line7labels = ["a7", "c7", "e7", "g7"]
-
-line8labels :: [Label]
-line8labels = ["b8", "d8", "f8", "h8"]
-
 calcBoardHash :: Board -> BoardHash
 calcBoardHash board = foldr update 0 (boardAssocs board)
   where
@@ -473,11 +470,24 @@ updateBoardHash :: Board -> Label -> Piece -> BoardHash
 updateBoardHash board label piece =
   updateBoardHash' (randomTable board) (boardHash board) label piece
 
-buildBoard :: RandomTableProvider rnd => rnd -> BoardOrientation -> BoardSize -> Board
-buildBoard rnd orient bsize@(nrows, ncols) =
-  let mkAddress p = Address (label p) (promote p) (upLeft p) (upRight p) (downLeft p) (downRight p)
+buildBoard :: (RandomTableProvider rnd, HasTopology rules) => rnd -> rules -> BoardOrientation -> BoardSize -> Board
+buildBoard rnd rules orient bsize@(nrows, ncols) =
+  let mkAddress p = Address {
+                        aLabel = label p
+                      , aPromotionSide = promote p
+                      , aUpLeft = upLeft p
+                      , aUpRight = upRight p
+                      , aDownLeft = downLeft p
+                      , aDownRight = downRight p
+                      , aUp = up p
+                      , aRight = right p
+                      , aDown = down p
+                      , aLeft = left p
+                    }
       label (r,c) = Label (c-1) (r-1)
 
+      diagonal = boardTopology rules == Diagonal
+
       promote (r,_)
         | r == 1 = Just $ playerSide orient Top
         | r == nrows = Just $ playerSide orient Bottom
@@ -499,11 +509,30 @@ buildBoard rnd orient bsize@(nrows, ncols) =
         | r-1 < 1 || c+1 > ncols = Nothing
         | otherwise = M.lookup (r-1, c+1) addresses
 
+      up (r,c)
+        | r+1 > nrows = Nothing
+        | otherwise = M.lookup (r+1, c) addresses
+
+      down (r,c)
+        | r-1 < 1 = Nothing
+        | otherwise = M.lookup (r-1, c) addresses
+
+      right (r,c)
+        | c+1 > ncols = Nothing
+        | otherwise = M.lookup (r, c+1) addresses
+
+      left (r,c)
+        | c-1 < 1 = Nothing
+        | otherwise = M.lookup (r, c-1) addresses
+
       addresses = M.fromList [(p, mkAddress p) | p <- coordinates]
 
       odds n = [1, 3 .. n]
       evens n = [2, 4 .. n]
-      coordinates = [(r, c) | r <- odds nrows, c <- odds ncols] ++ [(r, c) | r <- evens nrows, c <- evens ncols]
+
+      coordinates
+        | diagonal = [(r, c) | r <- odds nrows, c <- odds ncols] ++ [(r, c) | r <- evens nrows, c <- evens ncols]
+        | otherwise = [(r, c) | r <- [1..nrows], c <- [1..ncols]]
 
       addressByLabel = buildLabelMap nrows ncols [(label p, address) | (p, address) <- M.assocs addresses]
 
@@ -612,9 +641,33 @@ setManyPieces addresses piece board = foldr (\a b -> setPiece a piece b) board a
 setManyPieces' :: [Label] -> Piece -> Board -> Board
 setManyPieces' labels piece board = foldr (\l b -> setPiece' l piece b) board labels
 
-board8 :: RandomTableProvider rnd => rnd -> Board
-board8 rnd =
-  let board = buildBoard rnd FirstAtBottom (8, 8)
+line1labels :: [Label]
+line1labels = ["a1", "c1", "e1", "g1"]
+
+line2labels :: [Label]
+line2labels = ["b2", "d2", "f2", "h2"]
+
+line3labels :: [Label]
+line3labels = ["a3", "c3", "e3", "g3"]
+
+line4labels :: [Label]
+line4labels = ["b4", "d4", "f4", "h4"]
+
+line5labels :: [Label]
+line5labels = ["a5", "c5", "e5", "g5"]
+
+line6labels :: [Label]
+line6labels = ["b6", "d6", "f6", "h6"]
+
+line7labels :: [Label]
+line7labels = ["a7", "c7", "e7", "g7"]
+
+line8labels :: [Label]
+line8labels = ["b8", "d8", "f8", "h8"]
+
+board8 :: (RandomTableProvider rnd, HasTopology rules) => rnd -> rules -> Board
+board8 rnd rules =
+  let board = buildBoard rnd rules FirstAtBottom (8, 8)
       labels1 = line1labels ++ line2labels ++ line3labels
       labels2 = line8labels ++ line7labels ++ line6labels
   in  setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board
@@ -660,7 +713,7 @@ boardRep :: Board -> BoardRep
 boardRep board = BoardRep $ boardAssocs board
 
 parseBoardRep :: (GameRules rules, RandomTableProvider rnd) => rnd -> rules -> BoardRep -> Board
-parseBoardRep rnd rules (BoardRep list) = foldr set (buildBoard rnd orient bsize) list
+parseBoardRep rnd rules (BoardRep list) = foldr set (buildBoard rnd rules orient bsize) list
   where
     set (label, piece) board = setPiece' label piece board
     bsize = boardSize rules

src/Core/Supervisor.hs

@@ -51,6 +51,7 @@ import Rules.Brazilian
 import Rules.Canadian
 import Rules.Spancirety
 import Rules.Diagonal
+import Rules.Turkish
 
 -- | Request for new game creation
 data NewGameRq = NewGameRq {
@@ -115,7 +116,8 @@ supportedRules =
    ("brazilian", SomeRules brazilian),
    ("canadian", SomeRules canadian),
    ("spancirety", SomeRules spancirety),
-   ("diagonal", SomeRules diagonal)]
+   ("diagonal", SomeRules diagonal),
+   ("turkish",  SomeRules turkish) ]
 
 -- | Select rules by client request.
 selectRules :: NewGameRq -> Maybe SomeRules

src/Core/Types.hs

@@ -139,7 +139,11 @@ data Address = Address {
     aUpLeft :: Maybe Address,
     aUpRight :: Maybe Address,
     aDownLeft :: Maybe Address,
-    aDownRight :: Maybe Address
+    aDownRight :: Maybe Address,
+    aUp :: Maybe Address,
+    aRight :: Maybe Address,
+    aDown :: Maybe Address,
+    aLeft :: Maybe Address
   }
   deriving (Typeable)
 
@@ -239,27 +243,37 @@ type TBoardMap a = SM.Map BoardHash a
 data BoardDirection =
     UpLeft | UpRight 
   | DownLeft | DownRight
+  | Up | ToRight | Down | ToLeft
   deriving (Eq, Generic, Typeable)
 
 instance Show BoardDirection where
   show UpLeft = "UL"
   show UpRight = "UR"
   show DownLeft = "DL"
   show DownRight = "DR"
+  show Up = "U"
+  show ToRight = "R"
+  show Down = "D"
+  show ToLeft = "L"
 
 -- | Direction from a point of view of a player.
 -- For example, for white, B2 is at ForwardRight of A1;
 -- for black, B2 is at BackwardLeft of A1.
 data PlayerDirection =
     ForwardLeft | ForwardRight
   | BackwardLeft | BackwardRight
+  | Forward | PRight | Backward | PLeft
   deriving (Eq, Ord, Generic, Typeable)
 
 instance Show PlayerDirection where
   show ForwardLeft = "FL"
   show ForwardRight = "FR"
   show BackwardLeft = "BL"
   show BackwardRight = "BR"
+  show Forward = "F"
+  show PRight = "R"
+  show Backward = "B"
+  show PLeft = "L"
 
 -- | One step of the move is a movement of piece
 -- from one field to it's neighbour. At that moment
@@ -395,8 +409,17 @@ class HasBoardOrientation a where
   boardOrientation :: a -> BoardOrientation
   boardOrientation _ = FirstAtBottom
 
+data BoardTopology =
+    Diagonal
+  | Orthogonal
+  | DiagonalAndOrthogonal
+  deriving (Eq, Show, Typeable)
+
+class HasTopology a where
+  boardTopology :: a -> BoardTopology
+
 -- | Interface of game rules
-class (Typeable g, Show g, HasBoardOrientation g) => GameRules g where
+class (Typeable g, Show g, HasBoardOrientation g, HasTopology g) => GameRules g where
   -- | Initial board with initial pieces position
   initBoard :: SupervisorState -> g -> Board
   -- | Size of board used

src/Main.hs

@@ -59,7 +59,7 @@ special cmd args =
       withCheckers cmd $ do
         sh <- asks csSupervisor
         st <- liftIO $ atomically $ readTVar sh
-        let b = movePiece' "c3" "e5" $ board8 st
+        let b = movePiece' "c3" "e5" $ board8 st russian
             b' = flipBoard b
             b'' = flipBoard b'
         liftIO $ do

src/Rules/Brazilian.hs

@@ -15,6 +15,9 @@ import Rules.Russian
 newtype Brazilian = Brazilian GenericRules
   deriving (Typeable, HasBoardOrientation)
 
+instance HasTopology Brazilian where
+  boardTopology _ = Diagonal
+
 instance Show Brazilian where
   show = rulesName
 

src/Rules/Canadian.hs

@@ -17,11 +17,14 @@ newtype Canadian = Canadian GenericRules
 instance Show Canadian where
   show = rulesName
 
+instance HasTopology Canadian where
+  boardTopology _ = Diagonal
+
 instance GameRules Canadian where
   boardSize _ = (12, 12)
 
   initBoard rnd r =
-    let board = buildBoard rnd (boardOrientation r) (12, 12)
+    let board = buildBoard rnd r (boardOrientation r) (12, 12)
         labels1 = ["a1", "c1", "e1", "g1", "i1", "k1",
                    "b2", "d2", "f2", "h2", "j2", "l2",
                    "a3", "c3", "e3", "g3", "i3", "k3",

src/Rules/Diagonal.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Rules.Diagonal (Diagonal, diagonal) where
+module Rules.Diagonal (DiagonalRussian, diagonal) where
 
 import Data.Typeable
 
@@ -11,15 +11,18 @@ import Core.Evaluator
 import Rules.Russian
 import Rules.Generic
 
-newtype Diagonal = Diagonal GenericRules
+newtype DiagonalRussian = DiagonalRussian GenericRules
   deriving (Typeable, HasBoardOrientation)
 
-instance Show Diagonal where
+instance Show DiagonalRussian where
   show = rulesName
 
-instance GameRules Diagonal where
+instance HasTopology DiagonalRussian where
+  boardTopology _ = Core.Types.Diagonal
+
+instance GameRules DiagonalRussian where
   initBoard rnd r =
-    let board = buildBoard rnd (boardOrientation r) (8, 8)
+    let board = buildBoard rnd r (boardOrientation r) (8, 8)
         labels1 = ["c1", "e1", "g1",
                    "d2", "f2", "h2",
                    "e3", "g3",
@@ -53,8 +56,8 @@ instance GameRules Diagonal where
 
   pdnId _ = "42"
 
-diagonal :: Diagonal
-diagonal = Diagonal $
+diagonal :: DiagonalRussian
+diagonal = DiagonalRussian $
   let rules = russianBase rules
   in  rules
 

src/Rules/English.hs

@@ -19,11 +19,14 @@ newtype English = English GenericRules
 instance Show English where
   show = rulesName
 
+instance HasTopology English where
+  boardTopology _ = Diagonal
+
 instance GameRules English where
   boardSize _ = boardSize Russian.russian
 
   initBoard rnd r = 
-    let board = buildBoard rnd (boardOrientation r) (boardSize r)
+    let board = buildBoard rnd r (boardOrientation r) (boardSize r)
         labels1 = line1labels ++ line2labels ++ line3labels
         labels2 = line8labels ++ line7labels ++ line6labels
     in  setManyPieces' labels1 (Piece Man Second) $ setManyPieces' labels2 (Piece Man First) board

src/Rules/International.hs

@@ -20,11 +20,14 @@ newtype International = International GenericRules
 instance Show International where
   show = rulesName
 
+instance HasTopology International where
+  boardTopology _ = Diagonal
+
 instance GameRules International where
   boardSize _ = (10, 10)
 
   initBoard rnd r =
-    let board = buildBoard rnd (boardOrientation r) (10, 10)
+    let board = buildBoard rnd r (boardOrientation r) (10, 10)
         labels1 = ["a1", "c1", "e1", "g1", "i1",
                    "b2", "d2", "f2", "h2", "j2",
                    "a3", "c3", "e3", "g3", "i3",

src/Rules/Russian.hs

@@ -20,8 +20,11 @@ newtype Russian = Russian GenericRules
 instance Show Russian where
   show = rulesName
 
+instance HasTopology Russian where
+  boardTopology _ = Diagonal
+
 instance GameRules Russian where
-  initBoard rnd _ = board8 rnd
+  initBoard rnd r = board8 rnd r
 
   boardSize _ = (8, 8)
 

src/Rules/Simple.hs

@@ -18,6 +18,9 @@ newtype Simple = Simple GenericRules
 instance Show Simple where
   show = rulesName
 
+instance HasTopology Simple where
+  boardTopology _ = Diagonal
+
 instance GameRules Simple where
   initBoard rnd _ = initBoard rnd Russian.russian
   boardSize _ = boardSize Russian.russian

src/Rules/Spancirety.hs

@@ -17,9 +17,12 @@ newtype Spancirety = Spancirety GenericRules
 instance Show Spancirety where
   show = rulesName
 
+instance HasTopology Spancirety where
+  boardTopology _ = Diagonal
+
 instance GameRules Spancirety where
   initBoard rnd r =
-    let board = buildBoard rnd (boardOrientation r) (8, 10)
+    let board = buildBoard rnd r (boardOrientation r) (8, 10)
         labels1 = ["a1", "c1", "e1", "g1", "i1",
                    "b2", "d2", "f2", "h2", "j2",
                    "a3", "c3", "e3", "g3", "i3"]

src/Rules/Turkish.hs

@@ -0,0 +1,126 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Rules.Turkish (
+    Turkish, turkish, turkishBase
+  ) where
+
+import Data.Typeable
+
+import Core.Types
+import Core.Board
+import Core.BoardMap
+import Core.Evaluator
+import Rules.Generic
+
+newtype Turkish = Turkish GenericRules
+  deriving (Typeable, HasBoardOrientation)
+
+instance Show Turkish where
+  show = rulesName
+
+instance HasTopology Turkish where
+  boardTopology _ = Orthogonal
+
+instance GameRules Turkish where
+  initBoard rnd r =
+    let board = buildBoard rnd r (boardOrientation r) (8, 8)
+        labels1 = ["a2", "b2", "c2", "d2", "e2", "f2", "g2", "h2",
+                   "a3", "b3", "c3", "d3", "e3", "f3", "g3", "h3"]
+        labels2 = ["a7", "b7", "c7", "d7", "e7", "f7", "g7", "h7",
+                   "a6", "b6", "c6", "d6", "e6", "f6", "g6", "h6"]
+    in  setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board
+
+  boardSize _ = (8, 8)
+
+  dfltEvaluator r = SomeEval $ defaultEvaluator r
+
+  boardNotation _ = chessNotation
+
+  parseNotation _ = parseChessNotation
+
+  rulesName _ = "turkish"
+
+  possibleMoves (Turkish rules) side board = gPossibleMoves rules side board
+
+  updateRules r _ = r
+
+  getGameResult = genericGameResult
+
+  pdnId _ = "43"
+
+turkishBase :: GenericRules -> GenericRules
+turkishBase =
+  let rules this = (abstractRules this) {
+                        gManSimpleMoveDirections = [PLeft, Forward, PRight]
+                      , gManCaptureDirections =  [PLeft, Forward, PRight]
+                      , gKingCaptureDirections = [Backward, PLeft, Forward, PRight]
+                      , gManCaptures = manCaptures this
+                      , gManCaptures1 = manCaptures1 this
+                      , gCaptureMax = True
+                    }
+  in  rules
+
+turkish :: Turkish
+turkish = Turkish $
+  let rules = turkishBase rules
+  in  rules
+
+manCaptures :: GenericRules -> CaptureState -> [PossibleMove]
+manCaptures rules ct@(CaptureState {..}) =
+  let side = pieceSide ctPiece
+      captures = manCaptures1 rules ct
+      -- when last horizontal reached, pass non-promoted piece to
+      -- next moves check; man can capture backward, so it will
+      -- continue capture as a man if it can.
+      nextMoves pm = genericNextMoves rules ct False pm
+  in concat $ flip map captures $ \capture ->
+       let [move1] = translateCapture ctPiece capture
+           moves2 = nextMoves move1
+       in  if null moves2
+             then [move1]
+             else [catPMoves move1 move2 | move2 <- moves2]
+
+manCaptures1 :: GenericRules -> CaptureState -> [Capture]
+manCaptures1 rules ct@(CaptureState {..}) =
+    concatMap (check ctCurrent) $ filter allowedDir (gManCaptureDirections rules)
+  where
+    side = pieceSide ctPiece
+
+    allowedDir dir =
+      case ctPrevDirection of
+        Nothing -> True
+        Just prevDir -> oppositeDirection prevDir /= dir
+
+    check a dir =
+      case myNeighbour rules side dir a of
+        Just victimAddr {- | not (aLabel victimAddr `labelSetMember` ctCaptured) -} ->
+          case getPiece victimAddr ctBoard of
+            Nothing -> []
+            Just victim ->
+              if isMyPiece side victim
+                then []
+                else case myNeighbour rules side dir victimAddr of
+                       Nothing -> []
+                       Just freeAddr ->
+                        if isFree freeAddr ctBoard
+                          then let captured' = insertLabelSet (aLabel victimAddr) ctCaptured
+                                   next = ct {
+                                            ctPrevDirection = Just dir,
+                                            ctCaptured = captured',
+                                            ctCurrent = freeAddr
+                                          }
+                               in [Capture {
+                                  cSrc = a,
+                                  cDirection = dir,
+                                  cInitSteps = 0,
+                                  cFreeSteps = 1,
+                                  cVictim = victimAddr,
+                                  cDst = freeAddr,
+                                  cPromote = isLastHorizontal side freeAddr &&
+                                             not (gCanCaptureFrom rules next)
+                                }]
+                          else []
+        _ -> []
+