-- | Internal representation of the Chu Shogi board at a given instance in time -- Copyright 2009 Colin Adams -- -- This file is part of chu-shogi. -- -- Chu-shogi is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- Chu-shogi is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- You should have received a copy of the GNU General Public License -- along with chu-shogi. If not, see . module Board ( -- * Types Board, Lighting_colour (..), -- * Access piece_at, first_gold, all_pieces_of_colour, squares_from, jump_from, lion_from, lion_power_from, forsyth, influence_lighting, position_value, -- * Status report is_protected_lion, is_protected_lion_double, is_in_promotion_zone, is_one_gold, -- * Moves remove_from, move_piece_and_promote, move_piece_twice, move_piece, move_from_to, -- * Board layouts initial_board ) where import Control.Exception (assert) import Data.Array.IArray import Data.Maybe import Data.Char import Data.List (transpose) import Piece import Coordinate import Lighting -- | Abstract representation of playing board. type Board = Array Int (Array Int Square) -- | Individual square, possibly containing a piece data Square = Square (Maybe (Piece, Promotion_status)) deriving Show {-# contract piece_at :: Ok -> {rank' | rank' >= 0 && rank' <= 11} -> {file' | file' >= 0 && file' <= 11} -> Ok #-} -- | Piece in a particular square, if any, along with it's promotion status. piece_at :: Board -- ^ The position being queried -> Int -- ^ Rank (0 = rank a in standard Chu Shogi notation) -> Int -- ^ File (0 = file 1 in standard Chu Shogi notation) -> Maybe (Piece, Promotion_status) piece_at board rank' file' = let Square p = assert (rank' >= 0 && rank' <= 11 && file' >= 0 && file' <= 11) ((board ! file') ! rank') in p {-# contract first :: {board | is_one_gold board} -> Ok #-} -- | First and only Gold General in the position. -- Used to determine which side has won by the bare King rule. first_gold :: Board -> Piece first_gold board = let files = elems board squares = concatMap elems files golds = filter is_g squares in case head golds of Square (Just (p, _)) -> p where is_g sq = case sq of Square Nothing -> False Square (Just (p, _)) | piece_type p == Gold_general -> True | otherwise -> False -- | Location, type and status of all pieces of colour all_pieces_of_colour :: Board -> Piece_colour -> [(Coordinate, Piece, Promotion_status)] all_pieces_of_colour board colour = let ranks = [0..11] files = [0..11] coords = [new_coordinate x y | x <- ranks, y <- files] pieces = map (piece_at_coord colour) coords good_pieces = filter is_good pieces in map from_good good_pieces where piece_at_coord c coord = case piece_at board (rank coord) (file coord) of Just (p, s) | piece_colour p == c -> (coord, Just p, Just s) _ -> (coord, Nothing, Nothing) is_good (_, Just _, Just _) = True is_good (_, Nothing, Nothing) = False from_good (c, Just p, Just s) = (c, p, s) {-# contract squares_from :: Ok -> Ok -> {current_range | current_range >= -1 && current_range <= 11} -> Ok -> Ok -> {acc | True} -> Ok -> {r | length r >= length acc} #-} -- | Eligible ranging squares along with lighting conditions in reverse order squares_from :: Board -- ^ The position being queried -> Coordinate -- ^ Origin of hypothetical move -> Int -- ^ How many squares have been looked at so far -> Piece_type -- ^ Hypothetical moving piece -> Piece_colour -- ^ Colour of hypothetical moving piece -> [(Coordinate, Lighting_colour)] -- ^ Accumulated partial results -> Direction -- ^ Direction of move -> [(Coordinate, Lighting_colour)] squares_from board coord current_range p_type colour acc direction = let r = rank coord f = file coord rng = case current_range of -1 -> Piece.range p_type direction _ -> current_range next = case rng of 0 -> Nothing _ -> next_square board r f colour direction in case next of Just (c, l) -> squares_from board c (rng - 1) p_type colour (acc ++ [(c, l)]) direction Nothing -> acc {-# contract jump_from :: Ok -> Ok -> Ok -> Ok -> {acc | True} -> Ok -> {r | length r >= length acc} #-} -- | Eligible jump square along with lighting conditions jump_from :: Board -- ^ The position being queried -> Coordinate -- ^ Origin of hypothetical move -> Piece_type -- ^ Hypothetical moving piece -> Piece_colour -- ^ Colour of hypothetical moving piece -> [(Coordinate, Lighting_colour)] -- ^ Accumulated partial results -> Direction -- ^ Direction of move -> [(Coordinate, Lighting_colour)] jump_from board coord p_type colour acc direction = let r = rank coord f = file coord jumping = jump p_type direction in case jumping of True -> case next_jump board r f colour direction of Just c -> c:acc Nothing -> acc False -> acc {-# contract lion_from :: Ok -> Ok -> Ok -> Ok -> {acc | True} -> Ok -> {r | length r >= length acc} #-} -- | Lion moves for non-Lion pieces lion_from :: Board -- ^ The position being queried -> Coordinate -- ^ Origin of hypothetical move -> Piece_type -- ^ Hypothetical moving piece -> Piece_colour -- ^ Colour of hypothetical moving piece -> [(Coordinate, Lighting_colour)] -- ^ Accumulated partial results -> Direction -- ^ Direction of move -> [(Coordinate, Lighting_colour)] lion_from board coord p_type colour acc direction = let r = rank coord f = file coord lm = has_lion_moves p_type direction in case lm && is_northerly direction of False -> acc True -> lion_moves board r f p_type colour direction False ++ acc -- | Lion moves for Lion pieces lion_power_from :: Board -- ^ The position being queried -> Coordinate -- ^ Origin of hypothetical move -> Piece_type -- ^ Hypothetical moving piece -> Piece_colour -- ^ Colour of hypothetical moving piece -> [(Coordinate, Lighting_colour)] lion_power_from board coord p_type colour = case p_type of p | p == Lion || p == Promoted_kylin -> lion_power_squares board coord colour | otherwise -> [] -- | Modified Forsyth - compressed ASCII description of the position forsyth :: Board -- ^ The position to be described -> Bool -- ^ Should ranks be separated by newline characters? -> Bool -- ^ Should the description be augmented with promotion status information? -> String forsyth board newlines augmented = let files = elems board files_list = map elems files ranks = transpose files_list in concatMap (rank_forsyth newlines augmented) ranks -- | Influence of all pieces on coord influence_lighting :: Board -- ^ The position being queried -> Coordinate -- ^ Target of hypothetical moves -> [(Coordinate, Lighting_colour)] -- ^ Location and effect of each piece exerting influence influence_lighting board coord = catMaybes $ map (influence_lighting_on board coord False) (pieces_on board coord) {-# contract position_value :: Ok -> {r | r <= infinity && r >= (- infinity)} #-} -- | Standard value of position position_value :: Board -> Int position_value board = sum (map file_value (assocs board)) {-# contract is_protected_lion :: Ok -> {board | True} -> {target | piece_at board (rank target) (file target) == Just _} -> Ok #-} -- | Is lion at target protected, with source removed from board? is_protected_lion :: Coordinate -- ^ Square treated as empty -> Board -- ^ Position being queried -> Coordinate -- ^ Location of Lion -> Bool is_protected_lion source board target = let r = rank source f = file source b' = let new_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing)]) in board // [(f, new_file)] in is_protected_lion_double b' target {-# contract is_protected_lion_double :: {board | True} -> {target | piece_at board (rank target) (file target) == Just _} -> Ok #-} -- | Is lion at target protected from a lion double-capture move? is_protected_lion_double :: Board -- ^ Position being queried -> Coordinate -- ^ Location of Lion -> Bool is_protected_lion_double board target = let Just (_, _) = piece_at board (rank target) (file target) in not $ null (protection_lighting board target) -- | Is piece at target in the promotion zone, assuming it is of colour? is_in_promotion_zone :: Coordinate -- ^ Location of piece -> Piece_colour -- ^ Colour of piece -> Bool is_in_promotion_zone target colour = let r = case colour of White -> rank target Black -> 11 - (rank target) in r > 7 -- | Does board hold exactly one Gold General? is_one_gold :: Board -- ^ Position being queried -> Bool is_one_gold board = let files = elems board squares = concatMap elems files golds = filter is_g squares in length golds == 1 where is_g sq = case sq of Square Nothing -> False Square (Just (p, _)) | piece_type p == Gold_general -> True | otherwise -> False -- | Remove piece at coord from board remove_from :: Board -- ^ Position being changed -> Coordinate -- ^ Square being vacated -> Board remove_from board coord = let r = rank coord f = file coord new_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing)]) in board // [(f, new_file)] {-# contract move_piece_and_promote :: {board | True} -> {piece | True} -> {source | piece_at board (rank source) (file source) == Just (piece, _)} -> {target | source /= target} -> {promoting | not promoting || has_promotion (piece_type piece)} -> {declining | not (promoting && declining)} -> {r | piece_at r (rank target) (file target) == Just (piece, _) && piece_at r (rank source) (file source) == Nothing} #-} -- | Move piece from source to target and possibly promote. -- Promotion eligibility has already determined constraints on promoting and declining. (Proof obligation) move_piece_and_promote :: Board -- ^ Position being changed -> Piece -- ^ Piece being moved -> Coordinate -- ^ Origin of move -> Coordinate -- ^ Destination for move -> Bool -- ^ Are we promoting? -> Bool -- ^ Are we declining an opportunity to promote? -> Board move_piece_and_promote board piece source target promoting declining = let Just (p, st) = piece_at board (rank source) (file source) r = rank source f = file source r' = rank target f' = file target same_file = f == f' (p', st') = case (promoting, declining) of (False, False) -> promoted_piece p st False promoting _ -> assert (not promoting || has_promotion (piece_type p)) promoted_piece p st True promoting new_source_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing)]) new_target_file = assert (r' >= 0 && r' <= 11 && f' >= 0 && f' <= 11) ((board ! f') // [(r', Square (Just (p', st')))]) new_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing), (r', Square (Just (p', st')))]) b' = case same_file of False -> board // [(f, new_source_file), (f', new_target_file)] True -> board // [(f, new_file)] in assert (p == piece && piece_at b' (rank source) (file source) == Nothing) b' {-# contract move_piece_twice :: {board | True} -> {piece | True} -> {source | piece_at board (rank source) (file source) == Just (piece, _)} -> {target | source /= target} -> {target2 | source /= target2 && target /= target2} -. {r | piece_at r (rank target2) (file target2) == Just (piece, _) && piece_at r (rank source) (file source) == Nothing && piece_at r (rank target) (file taregt) == Nothing} #-} -- | Move piece from source to target and then again to target2. -- Eligibility for a double move has already been determined. (Proof obligation) move_piece_twice :: Board -- ^ Position being changed -> Piece -- ^ Piece being moved -> Coordinate -- ^ Origin of move -> Coordinate -- ^ Initial destination for move -> Coordinate -- ^ Final destination for move -> Board move_piece_twice board piece source target target2 = let b' = assert (piece == ((fst . fromJust) $ piece_at board (rank source) (file source))) move_piece_and_promote board piece source target False False in move_piece_and_promote b' piece target target2 False False {-# contract move_piece :: {board | True} -> {(piece, promotion_status) | True} -> {source | True} -> {target | target /= source && piece_at board (rank source) (file source) == Just (piece, promotion_status)} -> {eligible | True} -> {promoting | not promoting || eligible} -> {result | piece_at (rank target) file target) == Just (promoted_piece (piece promotion_status promoting (rank source) (file source) (rank target) (file target)) && piece_at result (rank source) (file source) == Nothing} #-} -- | Move piece from source to target, promote it if requested, and adjust it's promotion status. move_piece :: Board -- ^ Position being changed -> (Piece, Promotion_status) -- ^ Piece, along with it's initial promotion status -> Coordinate -- ^ Origin of move -> Coordinate -- ^ Destination of move -> Bool -- ^ Is piece eligible to promote? -> Bool -- ^ Should piece promote? -> (Board, Bool, Bool) -- ^ New position, along with indication of new White or Black Crown Prince move_piece board (piece, promotion_status) source target eligible promoting = let r = rank source f = file source r' = rank target f' = file target pp = promoted_piece piece promotion_status eligible promoting w_king = case promoting of True | piece_colour (fst pp) == White && is_king (fst pp) -> True _ -> False b_king = case promoting of True | piece_colour (fst pp) == Black && is_king (fst pp) -> True _ -> False in case f == f' of True -> let new_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing), (r', Square (Just pp))]) in (board // [(f, new_file)], w_king, b_king) False -> let new_source_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing)]) new_target_file = assert (r' >= 0 && r' <= 11 && f' >= 0 && f' <= 11) ((board ! f') // [(r', Square (Just pp))]) in (board // [(f, new_source_file), (f', new_target_file)], w_king, b_king) {-# contract move_from_to :: {b | True} -> {x | True} -> {y | y /= x && } -> {r | piece_at r (rank y) file y) == piece_at b (rank x) (file x) && piece_at r (rank x) (file x) == Nothing} #-} -- | Move piece from source to target without any promotion status change. move_from_to :: Board -- ^ Position being changed -> Coordinate -- ^ Origin of move -> Coordinate -- ^ Destination of move -> Board move_from_to board source target = let r = rank source f = file source r' = rank target f' = file target Just piece = piece_at board r f in case f == f' of True -> let new_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing), (r', Square (Just piece))]) in board // [(f, new_file)] False -> let new_source_file = assert (r >= 0 && r <= 11 && f >= 0 && f <= 11) ((board ! f) // [(r, Square Nothing)]) new_target_file = assert (r' >= 0 && r' <= 11 && f' >= 0 && f' <= 11) ((board ! f') // [(r', Square (Just piece))]) in board // [(f, new_source_file), (f', new_target_file)] -- | Initial set-up for even games initial_board :: Board initial_board = listArray (0, 11) [ listArray (0, 11) [Square (Just (Piece Lance White, Not_yet_promoted)), Square (Just (Piece Reverse_chariot White, Not_yet_promoted)), Square (Just (Piece Side_mover White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Side_mover Black, Not_yet_promoted)), Square (Just (Piece Reverse_chariot Black, Not_yet_promoted)), Square (Just (Piece Lance Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Ferocious_leopard White, Not_yet_promoted)), Square Nothing, Square (Just (Piece Vertical_mover White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Vertical_mover Black, Not_yet_promoted)), Square Nothing, Square (Just (Piece Ferocious_leopard Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Copper_general White, Not_yet_promoted)), Square (Just (Piece Bishop White, Not_yet_promoted)), Square (Just (Piece Rook White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Rook Black, Not_yet_promoted)), Square (Just (Piece Bishop Black, Not_yet_promoted)), Square (Just (Piece Copper_general Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Silver_general White, Not_yet_promoted)), Square Nothing, Square (Just (Piece Dragon_horse White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square (Just (Piece Go_between White, Not_yet_promoted)), Square Nothing, Square Nothing, Square (Just (Piece Go_between Black, Not_yet_promoted)), Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Dragon_horse Black, Not_yet_promoted)), Square Nothing, Square (Just (Piece Silver_general Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Gold_general White, Not_yet_promoted)), Square (Just (Piece Blind_tiger White, Not_yet_promoted)), Square (Just (Piece Dragon_king White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Dragon_king Black, Not_yet_promoted)), Square (Just (Piece Blind_tiger Black, Not_yet_promoted)), Square (Just (Piece Gold_general Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece King White, No_promotion)), Square (Just (Piece Kylin White, Not_yet_promoted)), Square (Just (Piece Lion White, No_promotion)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Free_king Black, No_promotion)), Square (Just (Piece Phoenix Black, Not_yet_promoted)), Square (Just (Piece Drunk_elephant Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Drunk_elephant White, Not_yet_promoted)), Square (Just (Piece Phoenix White, Not_yet_promoted)), Square (Just (Piece Free_king White, No_promotion)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Lion Black, No_promotion)), Square (Just (Piece Kylin Black, Not_yet_promoted)), Square (Just (Piece King Black, No_promotion)) ], listArray (0, 11) [Square (Just (Piece Gold_general White, Not_yet_promoted)), Square (Just (Piece Blind_tiger White, Not_yet_promoted)), Square (Just (Piece Dragon_king White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Dragon_king Black, Not_yet_promoted)), Square (Just (Piece Blind_tiger Black, Not_yet_promoted)), Square (Just (Piece Gold_general Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Silver_general White, Not_yet_promoted)), Square Nothing, Square (Just (Piece Dragon_horse White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square (Just (Piece Go_between White, Not_yet_promoted)), Square Nothing, Square Nothing, Square (Just (Piece Go_between Black, Not_yet_promoted)), Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Dragon_horse Black, Not_yet_promoted)), Square Nothing, Square (Just (Piece Silver_general Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Copper_general White, Not_yet_promoted)), Square (Just (Piece Bishop White, Not_yet_promoted)), Square (Just (Piece Rook White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Rook Black, Not_yet_promoted)), Square (Just (Piece Bishop Black, Not_yet_promoted)), Square (Just (Piece Copper_general Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Ferocious_leopard White, Not_yet_promoted)), Square Nothing, Square (Just (Piece Vertical_mover White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Vertical_mover Black, Not_yet_promoted)), Square Nothing, Square (Just (Piece Ferocious_leopard Black, Not_yet_promoted)) ], listArray (0, 11) [Square (Just (Piece Lance White, Not_yet_promoted)), Square (Just (Piece Reverse_chariot White, Not_yet_promoted)), Square (Just (Piece Side_mover White, Not_yet_promoted)), Square (Just (Piece Pawn White, Not_yet_promoted)), Square Nothing, Square Nothing, Square Nothing, Square Nothing, Square (Just (Piece Pawn Black, Not_yet_promoted)), Square (Just (Piece Side_mover Black, Not_yet_promoted)), Square (Just (Piece Reverse_chariot Black, Not_yet_promoted)), Square (Just (Piece Lance Black, Not_yet_promoted)) ] ] -- Implementation follows -- | Value of one file of the board file_value :: (Int, Array Int Square) -> Int file_value (file_coord, file') = sum (map (cell_value file_coord) (assocs file')) -- | Value of one square on the board cell_value :: Int -> (Int, Square) -> Int cell_value file' (rank', cell) = case cell of Square Nothing -> 0 Square (Just (piece, _)) -> let rank'' = case piece_colour piece of Black -> 11 - rank' White -> rank' file'' = case piece_colour piece of Black -> 11 - file' White -> file' in positional_piece_value rank'' file'' piece -- | Influence of all pieces of same colour as coord on coord, without ignoring intervening pieces protection_lighting :: Board -> Coordinate -> [(Coordinate, Lighting_colour)] protection_lighting board coord = catMaybes $ map (influence_lighting_on board coord True) (pieces_on_same_colour board coord) rank_forsyth :: Bool -> Bool -> [Square] -> String rank_forsyth newlines augmented rank' = let trailer = case newlines of True -> "/\n" False -> "/" in "/" ++ (cells_forsyth augmented rank') ++ trailer cells_forsyth :: Bool -> [Square] -> String cells_forsyth augmented cells = let (blanks, rest) = break is_non_blank cells leading_blanks = case length blanks of 0 -> "" n -> (show n) ++ case rest of [] -> "" _ -> "," suffix = case rest of [] -> "" c:[] -> (cell_forsyth augmented c) c:cs -> (cell_forsyth augmented c) ++ "," ++ (cells_forsyth augmented cs) in leading_blanks ++ suffix where is_non_blank (Square Nothing) = False is_non_blank (Square (Just _)) = True {-# contract cell_forsyth :: Ok -> {Just c | True} -> {r | length r > 0} #-} cell_forsyth :: Bool -> Square -> String cell_forsyth augmented (Square (Just (piece, status))) = let abbrev = abbreviation (piece_type piece) augmentation = case augmented of False -> "" True -> case status of Not_yet_promoted -> "00" No_promotion -> "" Declined_to_promote -> "10" May_promote -> "11" text = case piece_colour piece of White -> map toUpper abbrev Black -> map toLower abbrev in text ++ augmentation {-# contract influence_lighting_on :: Ok -> Ok -> Ok -> Ok -> Ok #-} influence_lighting_on :: Board -> Coordinate -> Bool -> (Coordinate, Piece) -> Maybe (Coordinate, Lighting_colour) influence_lighting_on board target ignore_friendly source = case source of (origin, p) -> let c = piece_colour p opponent = piece_at board (rank target) (file target) target_colour = case opponent of Nothing -> c Just (p', _) -> piece_colour p' (y, x) = path_to origin target dr = direction_and_range x y c ls = case dr of Nothing -> [] Just (dir, range') -> lightings_for ignore_friendly board p origin dir range' target lp = case is_lion $ piece_type p of False -> [] True -> case distance_from target origin of r | r > 2 -> [] r | r == 2 -> case target_colour == c of True -> [Lion_b_lighting] False -> [Lion_b_capture] _ -> case target_colour == c of True -> [Lion_a_lighting] False -> [Lion_a_capture] all_ls = ls ++ lp in case all_ls of [] -> Nothing _ -> Just (origin, maximum all_ls) {-# contract lightings_for :: Ok -> Ok -> Ok -> Ok -> Ok -> Ok -> Ok -> Ok #-} lightings_for:: Bool -> Board -> Piece -> Coordinate -> Direction -> Int -> Coordinate -> [Lighting_colour] lightings_for ignore_friendly board piece location direction range' target = let rng = Piece.range (piece_type piece) direction col = piece_colour piece opponent = piece_at board (rank target) (file target) target_colour = case opponent of Nothing -> col Just (p, _) -> piece_colour p rs = case rng - range' of r | r >= 0 -> case ignore_friendly of False -> case opponent of Just _ | target_colour /= col -> [Step_capture] _ -> [Step_lighting] True -> case intervening_pieces board location target of True -> [] False -> [Step_lighting] _ | otherwise -> [] js = case range' of 2 -> case jump (piece_type piece) direction of True -> case target_colour == col of True -> [Jump_lighting] False -> [Jump_capture] False -> [] _ -> [] lm = case has_lion_moves (piece_type piece) direction of False -> [] True -> let lms = lion_moves board (rank location) (file location) (piece_type piece) col direction True in map snd lms in rs ++ js ++ lm -- Are there any pieces between source and target exclusively? intervening_pieces :: Board -> Coordinate -> Coordinate -> Bool intervening_pieces board source target = let sqs = squares_between source target [] maybe_pieces = map (piece_at_square board) sqs in any isJust maybe_pieces piece_at_square :: Board -> Coordinate -> Maybe Piece piece_at_square board square = let r = rank square f = file square in case piece_at board r f of Nothing -> Nothing Just (p, _) -> Just p squares_between :: Coordinate -> Coordinate -> [Coordinate] -> [Coordinate] squares_between source target accumulator = let r = rank source f = file source r' = rank target f' = file target r'' = r + signum (r' - r) f'' = f + signum (f' - f) next_sq = new_coordinate r'' f'' in case next_sq == source of True -> accumulator False -> case next_sq == target of True -> accumulator False -> squares_between next_sq target (next_sq:accumulator) {-# contract direction_and_range :: {x | True} -> {y | x /= 0 || y /= 0} -> Ok -> {(d, r) | r > 0} #-} direction_and_range :: Int -> Int -> Piece_colour -> Maybe (Direction, Int) direction_and_range x y c = case x of _ | x == y && x > 0 -> case c of White -> Just (North_east, x) Black -> Just (South_west, x) _ | x == y && x < 0 -> case c of White -> Just (South_west, - x) Black -> Just (North_east, - x) _ | x == 0 && y > 0 -> case c of White -> Just (North, y) Black -> Just (South, y) _ | x == 0 && y < 0 -> case c of White -> Just (South, - y) Black -> Just (North, - y) _ | y == 0 && x > 0 -> case c of White -> Just (East, x) Black -> Just (West, x) _ | y == 0 && x < 0 -> case c of White -> Just (West, - x) Black -> Just (East, - x) _ | x == - y && x > 0 -> case c of White -> Just (South_east, x) Black -> Just (North_west, x) _ | x == - y && x < 0 -> case c of White -> Just (North_west, y) Black -> Just (South_east, y) _ -> Nothing -- All pieces on board except at coord {-# contract pieces_on :: Ok -> Ok -> Ok #-} pieces_on :: Board -> Coordinate -> [(Coordinate, Piece)] pieces_on board coord = let files = assocs board coordinates = files_and_elems files pruned_coordinates = filter (except_coordinate coord) coordinates in mapMaybe (square_to_piece board) pruned_coordinates -- All pieces on board of same_colour as at coord, except piece at coord {-# contract pieces_on :: Ok -> TODO -> Ok #-} pieces_on_same_colour :: Board -> Coordinate -> [(Coordinate, Piece)] pieces_on_same_colour board coord = let Just (p, _) = piece_at board (rank coord) (file coord) colour = piece_colour p files = assocs board coordinates = files_and_elems files pruned_coordinates = filter (except_coordinate coord) coordinates in filter (same_colour_piece colour) (mapMaybe (square_to_piece board) pruned_coordinates) same_colour_piece :: Piece_colour -> (Coordinate, Piece) -> Bool same_colour_piece colour (_, piece) = colour == piece_colour piece except_coordinate :: Coordinate -> (Coordinate, Square) -> Bool except_coordinate coord candidate = case candidate of (c, _) -> c /= coord files_and_elems :: [(Int, Array Int Square)] -> [(Coordinate, Square)] files_and_elems files = concatMap ranks_from_file files ranks_from_file :: (Int, Array Int Square) -> [(Coordinate, Square)] ranks_from_file indexed_ranks = case indexed_ranks of (f, ranks) -> map (rank_to_squares f) (assocs ranks) rank_to_squares :: Int -> (Int, Square) -> (Coordinate, Square) rank_to_squares file' pair = case pair of (r, s) -> (new_coordinate r file', s) square_to_piece :: Board -> (Coordinate, Square) -> Maybe (Coordinate, Piece) square_to_piece board square = case square of (c, _) -> let r = rank c f = file c p = piece_at board r f in case p of Nothing -> Nothing Just (p', _) -> Just (c, p') {-# contract next_square :: ok -> {x | x >= 0 && x <= 11} -> {y | y >= 0 && y <= 11} -> Ok -> Ok -> Ok #-} next_square :: Board -> Int -> Int -> Piece_colour -> Direction -> Maybe (Coordinate, Lighting_colour) next_square board rank' file' colour direction = let rank_increment = case colour of Black -> -1 White -> 1 (r, f) = case direction of North -> (rank' + rank_increment, file') South -> (rank' - rank_increment, file') East -> (rank', file' + 1) West -> (rank', file' - 1) North_east -> (rank' + rank_increment, file' + 1) North_west -> (rank' + rank_increment, file' - 1) South_east -> (rank' - rank_increment, file' + 1) South_west -> (rank' - rank_increment, file' - 1) cell = case r of rr | rr >= 0 && rr <= 11 -> case f of ff | ff >= 0 && ff <= 11 -> Just (rr, ff) _ -> Nothing _ -> Nothing in case cell of Nothing -> Nothing Just (r', f') -> let p = piece_at board r' f' in case p of Nothing -> Just (new_coordinate r' f', Step_lighting) Just (p', _) -> case piece_colour p' of c | c == colour -> Nothing _ -> Just (new_coordinate r' f', Step_capture ) {-# contract next_jump :: Ok -> {x | x >= 0 && x <= 11} -> {y | y >= 0 && y <= 11} -> Ok -> Ok -> Ok #-} next_jump :: Board -> Int -> Int -> Piece_colour -> Direction -> Maybe (Coordinate, Lighting_colour) next_jump board rank' file' colour direction = let rank_increment = case colour of Black -> -2 White -> 2 (r, f) = case direction of North -> (rank' + rank_increment, file') South -> (rank' - rank_increment, file') East -> (rank', file' + 2) West -> (rank', file' - 2) North_east -> (rank' + rank_increment, file' + 2) North_west -> (rank' + rank_increment, file' - 2) South_east -> (rank' - rank_increment, file' + 2) South_west -> (rank' - rank_increment, file' - 2) cell = case r of rr | rr >= 0 && rr <= 11 -> case f of ff | ff >= 0 && ff <= 11 -> Just (rr, ff) _ -> Nothing _ -> Nothing in case cell of Nothing -> Nothing Just (r', f') -> let p = piece_at board r' f' in case p of Nothing -> Just (new_coordinate r' f', Jump_lighting) Just (p', _) -> case piece_colour p' of c | c == colour -> Nothing _ -> Just (new_coordinate r' f', Jump_capture ) {-# contract has_lion_moves :: Ok -> {direction | True} -> {r | not r || is_northerly direction} #-} has_lion_moves :: Piece_type -> Direction -> Bool has_lion_moves piece direction = case piece of Soaring_eagle -> case direction of North_east -> True North_west -> True _ -> False Horned_falcon -> case direction of North -> True _ -> False _ -> False {-# contract lion_moves :: Ok -> {x | x >= 0 && x <= 11} -> {y | y >= 0 && y <= 11} -> {t | True} -> Ok -> {d | is_northerly d && has_lion_moves t d} -> Ok -> Ok #-} lion_moves :: Board -> Int -> Int -> Piece_type -> Piece_colour -> Direction -> Bool -> [(Coordinate, Lighting_colour)] lion_moves board rank' file' _ colour direction ignore_friendly_piece = let rank_increment = case colour of Black -> -1 White -> 1 (r, f) = case direction of North -> (rank' + rank_increment, file') North_east -> (rank' + rank_increment, file' + 1) North_west -> (rank' + rank_increment, file' - 1) (r', f') = case direction of North -> (rank' + 2 * rank_increment, file') North_east -> (rank' + 2 * rank_increment, file' + 2) North_west -> (rank' + 2 * rank_increment, file' - 2) (c, p) = case good_coordinates r f of False -> (Nothing, Nothing) True -> (Just $ new_coordinate r f, piece_at board r f) (c', p') = case good_coordinates r' f' of False -> (Nothing, Nothing) True -> (Just $ new_coordinate r' f', piece_at board r' f') sq = case c of Nothing -> [] Just c'' -> case p of Nothing -> [(c'', Lion_a_lighting)] Just (p'', _) | piece_colour p'' == colour -> case ignore_friendly_piece of True -> [(c'', Lion_a_lighting)] False -> [] _ -> [(c'', Lion_a_capture)] sq' = case c' of Nothing -> [] Just c''' -> case p' of Nothing -> [(c''', Lion_b_lighting)] Just (p'', _) | piece_colour p'' == colour -> case ignore_friendly_piece of True -> [(c''', Lion_b_lighting)] False -> [] _ -> [(c''', Lion_b_capture)] in sq ++ sq' {-# contract lion_power_squares :: Ok -> Ok -> Ok -> Ok #-} lion_power_squares :: Board -> Coordinate -> Piece_colour -> [(Coordinate, Lighting_colour)] lion_power_squares board coord colour = let r = rank coord f = file coord sqs = [(x, y) | x <- [r - 2, r - 1, r, r + 1, r + 2], y <- [f - 2, f - 1, f, f + 1, f + 2], (x, y) /= (r, f), x >= 0, x <= 11, y >= 0, y <= 11] psqs = [(piece_at board x y, new_coordinate x y) | (x, y) <- sqs] elg = filter (not_same_piece_colour colour) psqs in map (lion_colour r f) elg not_same_piece_colour :: Piece_colour -> (Maybe (Piece, promotion_status), Coordinate) -> Bool not_same_piece_colour colour item = case item of (Just (p, _), _) | piece_colour p == colour -> False _ -> True {-# contract lion_colour :: {x | x >= 0 && x <= 11} -> {y | y >= 0 && y <= 11} -> Ok -> Ok #-} lion_colour :: Int -> Int -> (Maybe (Piece, Promotion_status), Coordinate) -> (Coordinate, Lighting_colour) lion_colour r f item = case item of (p, c) -> let r' = rank c f' = file c sq x = x * x d = sq (r - r') + sq (f - f') long = d > 2 in case p of Nothing -> case long of True -> (c, Lion_b_lighting) False -> (c, Lion_a_lighting) Just _ -> case long of True -> (c, Lion_b_capture) False -> (c, Lion_a_capture)