-- | State (basic, interactive, and history) of one game -- 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 Game_state ( -- * Types Game_state, Non_interactive_state, Move_stack, Lighting_colour (..), -- * Creation new_game_state, -- * Access board, white_kings, black_kings, pieces, lighting, selected_square, selected_piece, selected_target, last_move_japanese, last_move_western, promotion_choices, first_capture, second_destination, -- * Status report is_piece_selected, is_first_square_selected, is_first_target_selected, is_second_target_selected, is_black_to_play, has_piece, is_bare_king, is_white_bare_gold, is_clear_lighting, is_lion_a, is_eligible_to_promote, is_capturable, blank_or_first_capturable, was_lion, correct_colour_to_move, signals, has_moved, is_double_move, same_selected_square, -- * Moves and selection deselect_piece, select_piece_at, clear_lighting, set_lighting, set_lighting_second_move, move_to_first_square, update_from_move, update_interactive_from_move, complete_move, complete_second_move, save_signals, set_signals_for_first_move, set_signals_for_second_move, reset_move, set_second_destination, influence_on, next_move, previous_move ) where import Control.Exception (assert) import Data.IORef import Data.List import Data.Maybe import qualified Data.Edison.Coll.UnbalancedSet as Set import qualified Data.Edison.Seq.MyersStack as Stack import Graphics.UI.Gtk hiding (set) import Piece import Lighting import Coordinate import Board import Move -- | Full state of game, incuding interactivity -- -- Invariant: Move_stack is never empty type Game_state = (Interactive_state, Non_interactive_state, Move_stack ) -- | History of previous and un-done moves -- -- (1) State which previous move was applied to -- -- (2) Previous move -- -- (3)Future moves (those which were taken back, and might be redone) -- -- Invariant: The 'Maybe' 'Move' entry can only be Nothing on the oldest stack entry. type Move_stack = Stack.Seq (Non_interactive_state, Maybe Move, Stack.Seq (Move) ) -- | Core state, used by AI and interactivity alike -- -- (1) Information about current move and position -- -- (2) Board and pieces -- -- (3) No. of kings/crown princes on each side, and total pieces in play type Non_interactive_state = (Move_state, Board, King_count ) -- | Signal handlers for interactive board -- -- (1) Expose events for normal moves -- -- (2) Expose events for second part of double move -- -- (3) Mouse depress events for normal moves -- -- (4) Mouse depress events for second part of double move -- -- (5) Mouse release events for normal moves -- -- (6) Mouse release events for second part of double move type Signal_handlers = ( Maybe (ConnectId DrawingArea), Maybe (ConnectId DrawingArea), Maybe (ConnectId DrawingArea), Maybe (ConnectId DrawingArea), Maybe (ConnectId DrawingArea), Maybe (ConnectId DrawingArea) ) -- | State relating to the GUI -- -- (1) Selected source piece -- -- (2) Coordinate of source square -- -- (3) Coordinate of first target -- -- (4) Coordinate of second target -- -- (5) Capture at first target -- -- (6) State prior to move -- -- (7) (a) Did source piece promote? -- (b) Did source piece decline to promote ? -- -- (8) Colour coding of possible moves/influence -- -- (9) Was previous move a capture of a Lion by a non-Lion? -- -- (10) Kings and pieces counts at end of previous move -- -- (11) Signal handlers newtype Interactive_state = Interactive_state (Maybe (Piece, Promotion_status), Maybe Coordinate, Maybe Coordinate, Maybe Coordinate, Maybe Piece, (Board, Move_state), (Bool, Bool), Lighting, Bool, King_count, Signal_handlers ) -- | -- -- (1) Is Black to play? -- -- (2) How many moves have been played? -- -- (3) Was a Lion captured last by a non-Lion? -- -- (4) Forsyth of seen positions for (White, Black) type Move_state = (Bool, Int, Bool, (Set.Set String, Set.Set String) ) -- | Colour coding of possible moves/influence type Lighting = [(Coordinate, Lighting_colour)] -- | -- -- (1) No. of white kings and crown princes -- -- (2) No. of black kings and crown princes -- -- (3) Total no. of pieces in play type King_count = (Int, Int, Int ) -- | New even game new_game_state :: Game_state new_game_state = let b = initial_board m = (True, 0, False, (Set.empty, Set.empty)) in (no_interactive_move (b, m) False (1, 1, 92) (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing), (m, b, (1, 1, 92)), Stack.singleton ((m, b, (1, 1, 92)), Nothing, Stack.empty)) -- | Current board board :: Non_interactive_state -> Board board game_state = case game_state of (_, b, _) -> b -- | No. White kings and crown princes in play white_kings :: Non_interactive_state -> Int white_kings (_, _, (w, _, _)) = w -- | No. Black kings and crown princes in play black_kings :: Non_interactive_state -> Int black_kings (_, _, (_, b, _)) = b -- | Total number of pieces in play pieces :: Non_interactive_state -> Int pieces (_, _, (_, _, p)) = p -- | Coloured lights for interactive board, showing canidate moves or influence on a selected square lighting :: Game_state -> Lighting lighting game_state = case game_state of (Interactive_state (_, _, _, _, _, _, _, l, _, _, _), _, _) -> l {-# contract selected_piece :: {x | is_first_square_selected x && is_piece_selected x} -> Ok #-} -- | Piece selected to move, along with its promotion status selected_piece :: Game_state -> (Piece, Promotion_status) selected_piece game_state = case game_state of (Interactive_state (Just p, _, _, _, _, _, _, _, _, _, _), _, _) -> p {-# contract selected_square :: {x | is_first_square_selected x} -> Ok #-} -- | Square selected from which to move a piece selected_square :: Game_state -> Coordinate selected_square game_state = case game_state of (Interactive_state (_, Just c, _, _, _, _, _, _, _, _, _), _, _) -> c {-# contract selected_target :: {game_state | is_first_target_selected game_state} -> Ok #-} -- | Selected square as initial target for move selected_target :: Game_state -> Coordinate selected_target gs = case gs of (Interactive_state (_, _, Just t, _, _, _, _, _, _, _, _), _, _) -> t -- | Count of number of completed moves in current game last_move_japanese :: Non_interactive_state -> Int last_move_japanese ((_, n, _, _), _, _) = n -- | Count of number of completed moves by Black (including handicap setup move) in current game last_move_western :: Non_interactive_state -> Int last_move_western ((b2p, n, _, _), _, _) = case b2p of True -> n `div` 2 False -> (n + 1) `div` 2 -- | Has the current interactive player chosen to: -- -- (1) promote or -- -- (2) decline to promote? promotion_choices :: Game_state -> (Bool, Bool) promotion_choices (Interactive_state (_, _, _, _, _, _, p, _, _, _, _), (_, _, _),_) = p -- | Possible piece captured as first phase of interactive move first_capture :: Game_state -> Maybe Piece first_capture (Interactive_state (_, _, _, _, c, _, _, _, _, _, _), _, _) = c {-# contract second_destination :: {game_state | has_moved game_state} -> Ok #-} -- | Final destination selected for double move, if any second_destination :: Game_state -> Maybe Coordinate second_destination (Interactive_state (_, _, _, t2, _, _, _, _, _, _, _), _, _) = t2 -- | Has a piece been selected interactively, but no target for it to move to? is_piece_selected :: Game_state -> Bool is_piece_selected gs = case gs of (Interactive_state (Just _, Just _, Nothing, _, _, _, _, _, _, _, _), _, _) -> True _ -> False -- | Has a piece been selected interactively? is_first_square_selected :: Game_state -> Bool is_first_square_selected game_state = case game_state of (Interactive_state (Just _, Just _, _, _, _, _, _, _, _, _, _), _, _) -> True _ -> False {-# contract is_first_target_selected :: {game_state | True} {r | r == False || is_first_square_selected game_selected} #-} -- | Has a square been selected to move to interactively? is_first_target_selected :: Game_state -> Bool is_first_target_selected game_state = case game_state of (Interactive_state (Just _, Just _, Just _, _, _, _, _, _, _, _, _), _, _) -> True _ -> False {-# contract is_second_target_selected :: {game_state | True} {r | r == False || is_first_target_selected game_state} #-} -- | Has a square been selected for the final destination of an interactive double move? is_second_target_selected :: Game_state -> Bool is_second_target_selected game_state = case game_state of (Interactive_state (Just _, Just _, Just _, Just _, _, _, _, _, _, _,_), _, _) -> True _ -> False -- | Is it Black's turn to play? is_black_to_play :: Non_interactive_state -> Bool is_black_to_play ((b2p, _, _, _), _, _) = b2p -- | Is there a piece at coord? has_piece :: Game_state -> Coordinate -> Bool has_piece game_state coord = case game_state of (_, (_, b, _), _) -> case piece_at b (rank coord) (file coord) of Nothing -> False Just _ -> True -- | Is the game over by the Bare King rule? is_bare_king :: Non_interactive_state -> Bool is_bare_king game_state = case pieces game_state of 3 -> is_one_gold (board game_state) _ -> False {-# contract is_white_bare_gold :: {game_state | is_bare_king game_state} -> Ok #-} -- | Is White the winner of a Bare King game? is_white_bare_gold :: Non_interactive_state -> Bool is_white_bare_gold game_state = let b = board game_state gold = first_gold b in piece_colour gold == White -- | Does coord have no lighting set? is_clear_lighting :: Game_state -> Coordinate -> Bool is_clear_lighting game_state coord = case game_state of (Interactive_state (_, _, _, _, _, _, _, l, _, _, _), _, _) -> case lookup coord l of Nothing -> True _ -> False -- | Does coord have lighting of a one-step Lion move? is_lion_a :: Game_state -> Coordinate -> Bool is_lion_a game_state coord = case game_state of (Interactive_state (_, _, _, _, _, _, _, l, _, _, _), _, _) -> case lookup coord l of Nothing -> False Just c | c == Lion_a_lighting -> True Just c | c == Lion_a_capture -> True _ -> False -- Is the piece at `coord` the correct colour to make a move now? {-# contract correct_colour_to_move :: {(_, _, x, _) | True} -> {y | isJust (piece_at x (rank y) (file y))} -> Ok #-} correct_colour_to_move :: Game_state -> Coordinate -> Bool correct_colour_to_move game_state coord = case game_state of (_, ((black_to_move, _, _, _), board', _), _) -> case piece_at board' (rank coord) (file coord) of Just (p, _) -> case piece_colour p of Black -> black_to_move White -> not black_to_move -- | Signal-handlers currently set on GUI signals :: Game_state -> Signal_handlers signals game_state = case game_state of (Interactive_state (_, _, _, _, _, _, _, _, _, _, s), _, _) -> s -- | Has the interactive player moved (at least partially)? has_moved :: Game_state -> Bool has_moved (Interactive_state (p, s, t, _, _, _, _, _, _, _, _), _, _) = case p >> s >> t of Nothing -> False Just _ -> True {-# contract is_double_move :: {game_state | has_moved game_state} -> Ok #-} -- | Is the current interactive move a double move? is_double_move :: Game_state -> Bool is_double_move game_state = case game_state of (Interactive_state (_, _, _, Nothing, _, _, _, _, _, _, _), _, _) -> False _ -> True -- | Was a lion captured by a non-lion on previous move? was_lion :: Non_interactive_state -> Bool was_lion ((_, _, l, _), _, _) = l {-# contract is_eligible_to_promote :: Ok -> Ok -> Ok -> Ok -> Ok -> {(e, f) | not f || e} #-} -- | Is piece eligible/forced to promote if moving from source to target? is_eligible_to_promote :: Piece -- ^ Moving piece -> Promotion_status -- ^ Status prior to move -> Coordinate -- ^ Origin of move -> Coordinate -- ^ Destination of move -> Bool -- ^ Capturing? -> (Bool, Bool) -- ^ (is_eligible, is_forced) is_eligible_to_promote piece status source target capturing = case status of s | s == No_promotion -> (False, False) s | s == Declined_to_promote -> case is_compulsory_promotion piece target of True -> (True, True) False -> (capturing && not (piece_type piece == Pawn), False) s | otherwise -> case is_compulsory_promotion piece target of True -> (True, True) False -> case s of May_promote -> (True, False) Not_yet_promoted -> (is_in_promotion_zone target (piece_colour piece) || is_in_promotion_zone source (piece_colour piece), False) {-# contract blank_or_first_capturable :: Ok -> Ok -> {source_piece | True} -> {source_square | True} -> {board | piece_at board (rank source_square) (file source_square) == Just (source_piece, _)} -> Ok -> Ok #-} blank_or_first_capturable :: Maybe Piece -- ^ Piece captured as first part of double move -> Bool -- ^ Was a lion captured by a non-Lion on previous move? -> Piece -- ^ Moving piece -> Coordinate -- ^ Origin of candidate move -> Board -- ^ Position in which capture is contemplated -> [(Coordinate, Lighting_colour)] -- ^ Candidate list of range moves -> [(Coordinate, Lighting_colour)] blank_or_first_capturable first_capture' was_lion_captured source_piece source_square board' candidates = let (blanks, candidates') = span is_blank candidates possible_capture = case candidates' of [] -> [] (c:_) -> case is_capturable first_capture' was_lion_captured False source_piece source_square board' c of True -> [c] False -> [] in blanks ++ possible_capture where is_blank (_, l) = l == Step_lighting {-# contract is_capturable :: Ok -> Ok -> Ok -> {source_piece | True} -> {source_square | True} -> {board | piece_at board (rank source_square) (file source_square) == Just (source_piece, _)} -> {(target, lighting) | piece_at board (rank target) (file target) == (Nothing || Just (prisoner, _)) && (opposite_colour $ piece_type prisoner) == piece_colour source_piece} -> Ok #-} -- | Filter out all uncapturable lions is_capturable :: Maybe Piece -- ^ Piece captured as first part of double move -> Bool -- ^ Was a lion captured by a non-Lion on previous move? -> Bool -- ^ Is this the second part of a double move? -> Piece -- ^ Moving piece -> Coordinate -- ^ Origin of candidate move -> Board -- ^ Position in which capture is contemplated -> (Coordinate, Lighting_colour) -- ^ Final target and associated lighting for candidate move -> Bool is_capturable first_capture' was_lion_captured second_move source_piece source_square board' (target, _) = case piece_at board' (rank target) (file target) of Nothing -> True Just (prisoner, _) -> case piece_type prisoner of p | is_lion p -> case piece_type source_piece of s | is_lion s -> case distance_from target source_square of 1 -> case second_move of False -> True True -> case first_capture' of Nothing -> not (is_protected_lion source_square board' target) Just l | piece_type l == Pawn || piece_type l == Go_between -> not (is_protected_lion_double board' target) _ -> True 2 -> not (is_protected_lion source_square board' target) | otherwise -> not was_lion_captured | otherwise -> True {-# contract same_selected_square :: {game_state | True} -> {coord | True} -> {r | r == False || is_first_square_selected game_state && coord == selected_square game_state} #-} -- | Is coord the square of the selected piece? same_selected_square :: Game_state -> Coordinate -> Bool same_selected_square game_state coord = case game_state of (Interactive_state (Just _, Just c, _, _, _, _, _, _, _, _, _), _, _) -> coord == c _ -> False -- | Re-initialize interactive move. deselect_piece :: IORef Game_state -> IO () deselect_piece game_start_ior = do (Interactive_state (_, _, _, _, _, _ib, _pr, _, _lc, _kc, _s), _ni, _moves) <- readIORef game_start_ior writeIORef game_start_ior (Interactive_state (Nothing, Nothing, Nothing, Nothing, Nothing, _ib, _pr, no_lighting, _lc, _kc, _s), _ni, _moves) -- | Select piece at coord for interactive move. -- -- Require has_piece gs coord && correct_colour_to_move gs coord where gs <- readIORef game_state_ior -- -- Ensure is_first_square_selected select_piece_at :: IORef Game_state -> Coordinate -> IO () select_piece_at game_state_ior coord = do ((Interactive_state (_, _, _, _, _, _ib, _pr, _l, _lc, _okc, _s)), (_m, b, _kc), _moves) <- readIORef game_state_ior writeIORef game_state_ior (Interactive_state (piece_at b (rank coord) (file coord), Just coord, Nothing, Nothing, Nothing, _ib, _pr, _l, _lc, _okc, _s), (_m, b, _kc), _moves) -- | Ensure no squares have lighting set. clear_lighting :: IORef Game_state -> IO () clear_lighting game_state_ior = do game_state <- readIORef game_state_ior case game_state of (Interactive_state (_p, _s, _d, _d2, p, _ib, _pr, _, _lc, _kc, _sg), _ni, _moves) -> writeIORef game_state_ior (Interactive_state (_p, _s, _d, _d2, p, _ib, _pr, no_lighting, _lc, _kc, _sg), _ni, _moves) -- | Set lighting to show possible moves for piece at coord. -- -- Require piece_at board coord == Just p set_lighting :: IORef Game_state -- ^ Mutable reference to current game state -> Bool -- ^ Reserved: must be 'True' for now. -> Coordinate -- ^ Location of piece -> IO () set_lighting game_state_ior is_move coord = do (Interactive_state (_p, _s, _d, _d2, p, _ib, _pr, _, _lc, _okc, _sg), (_m@(_, _, c, _), board', _kc), _moves) <- readIORef game_state_ior case is_move of True -> let Just (piece, _) = piece_at board' (rank coord) (file coord) p_type = piece_type piece colour = piece_colour piece rs = concatMap ((blank_or_first_capturable p c piece coord board') . (squares_from board' coord (-1) p_type colour [])) (enumFrom North) js = filter (is_capturable p c False piece coord board') (concat (map (jump_from board' coord p_type colour []) (enumFrom North))) lp = filter (is_capturable p c False piece coord board') (lion_power_from board' coord p_type colour) ls = filter (is_capturable p c False piece coord board') (concat (map (lion_from board' coord p_type colour []) (enumFrom North))) coordinates = sortBy ordered_coordinates (js ++ rs ++ ls ++ lp) grouped_coordinates = groupBy same_coordinates coordinates in writeIORef game_state_ior (Interactive_state (_p, _s, _d, _d2, p, _ib, _pr, map (maximumBy maximum_lighting) grouped_coordinates, _lc, _okc, _sg), (_m, board', _kc), _moves) False -> return () -- TODO -- | Is second leg of double move allowed? -- -- Only allowed when first leg was a capture, or when returning to origin (pass) only_pass :: Bool -- ^ Was first leg of double move a capture -> Coordinate -- ^ Origin of double move -> (Coordinate, Lighting_colour) -- ^ Final target and associated lighting for candidate move -> Bool only_pass was_capture origin (target, _) = case was_capture of True -> True False -> origin == target -- | Set lighting to show possible second moves for piece at coord. -- -- Require piece_at board coord == Just p and then is_lion p or has_lion_moves p {in at least one direction} set_lighting_second_move :: IORef Game_state -- ^ Mutable reference to current game state -> Coordinate -- ^ Location of piece after first move -> IO () set_lighting_second_move game_state_ior coord = do (Interactive_state (_p, s, _d, _d2, t, _ib, _pr, _, _lc, _okc, _sg), (_m@(_, _, c, _), board', _kc), _moves) <- readIORef game_state_ior let Just (piece, _) = piece_at board' (rank coord) (file coord) p_type = piece_type piece colour = piece_colour piece lp = filter (only_pass (isJust t) (fromJust s)) $ filter (is_capturable t c True piece coord board') (lion_power_from board' coord p_type colour) ls = filter (only_pass (isJust t) (fromJust s)) $ filter (is_capturable t c False piece coord board') (concat (map (lion_from board' coord p_type colour []) (enumFrom North))) coordinates = sortBy ordered_coordinates (ls ++ lp) filtered_coordinates = filter is_lion_a_pair coordinates writeIORef game_state_ior (Interactive_state (_p, s, _d, _d2, t, _ib, _pr, filtered_coordinates, _lc, _okc, _sg), (_m, board', _kc), _moves) -- | Move selected piece to coord, capturing if that square is occupied. -- -- Require is_piece_selected and then -- is_first_square_selected and then -- not is_first_target_selected and then -- not is_second_target_selected -- -- Ensure -- is_first_target_selected -- not is_second_target_selected move_to_first_square :: IORef Game_state -- ^ Mutable reference to current game state -> Coordinate -- ^ Destination of move -> IO () move_to_first_square game_state_ior coord = do (Interactive_state (Just p@(source_piece, _), Just c, Nothing, Nothing, Nothing, _ib, _, _l, _, _, _s), ((b2p, n, lc, _sets), bd, kc@(wkc, bkc, pcs)), _moves) <- readIORef game_state_ior let (capturing, captive) = case piece_at bd (rank coord) (file coord) of Nothing -> (False, Nothing) Just cap -> (True, Just cap) (eligible, promoting) <- check_if_promoting p c coord capturing let (board', w_new_king, b_new_king) = move_piece bd p c coord eligible promoting declined = eligible && not promoting captive_piece = case captive of Nothing -> Nothing Just (p', _) -> Just p' m' = case capturing of False -> (b2p, n, False, _sets) True -> case is_lion (piece_type (fromJust captive_piece)) of True -> case is_lion (piece_type source_piece) of True -> (b2p, n, False, _sets) False -> (b2p, n, True, _sets) False -> (b2p, n, False, _sets) wkc' = case captive_piece of Just cp | is_king cp && piece_colour cp == White -> wkc - 1 _ -> case not (is_king source_piece) && w_new_king of True -> wkc + 1 False -> wkc bkc' = case captive_piece of Just cp | is_king cp && piece_colour cp == Black -> bkc - 1 _ -> case not (is_king source_piece) && b_new_king of True -> bkc + 1 False -> bkc pcs' = case capturing of True -> pcs - 1 False -> pcs writeIORef game_state_ior (Interactive_state (Just p, Just c, Just coord, Nothing, captive_piece, _ib, (promoting, declined), _l, lc, kc, _s), (m', board', (wkc', bkc', pcs')), _moves) -- | New interactive game state resulting from move -- -- The Move_stack is optional - it must be present in all cases -- except when called within the AI, when it must be omitted as is pointless to maintain history. -- -- TODO: contract is that 'move' is valid for state update_interactive_from_move :: Move -- ^ Move to be made -> Game_state -- ^ Existing state of game -> Game_state -- ^ Updated state of game update_interactive_from_move move gs@(_, ni_state, moves) = let Just (new_state@(ms, b, kc), Just new_moves) = case move of Pass _ _ -> append_pass move (ni_state, Just moves) Igui _ _ p c -> igui_capture move (ni_state, Just moves) p c Capture p s p2 t pr dec -> assert (p == ((fst . fromJust) $ piece_at (board ni_state) (rank s) (file s))) single_capture move (ni_state, Just moves) p s p2 t pr dec Move p s t pr dec -> single_move move (ni_state, Just moves) p s t pr dec Double_move p s t p2 t2 p3 -> double_move move (ni_state, Just moves) p s t p2 t2 p3 lc = is_lion_capture move new_interact = no_interactive_move (b, ms) lc kc (signals gs) in (new_interact, new_state, new_moves) {-# contract update_from_move :: {(ni_state, moves) | True} -> Ok -> {r | r == Nothing || r == Just (r_state, r_moves) && isJust moves == isJust r_moves) } #-} -- | New game state resulting from move -- -- The Move_stack is optional - it must be present in all cases -- except when called within the AI, when it must be omitted as is pointless to maintain history. -- -- TODO: contract is that 'move' is valid for state (BIG TODO) update_from_move :: (Non_interactive_state, Maybe Move_stack) -- ^ Existing state of game -> Move -- ^ Move to be made -> Maybe (Non_interactive_state, Maybe Move_stack) -- ^ Updated state of game, if not repetition update_from_move (ni_state, moves) move = case move of Pass _ _ -> append_pass move (ni_state, moves) Igui _ _ p c -> igui_capture move (ni_state, moves) p c Capture p s p2 t pr dec -> assert ((p == ((fst . fromJust) $ piece_at (board ni_state) (rank s) (file s))) && (not pr || has_promotion (piece_type p))) single_capture move (ni_state, moves) p s p2 t pr dec Move p s t pr dec -> single_move move (ni_state, moves) p s t pr dec Double_move p s t p2 t2 p3 -> double_move move (ni_state, moves) p s t p2 t2 p3 -- | Complete interactive single move or return False if it would be repetition -- -- Require not (readIORef game_state_ior >>= has_second_move) complete_move :: IORef Game_state -> IO Bool complete_move game_state_ior = do gs@(Interactive_state (_, _, _, _, t, _ib@(ib, _), _, _, lc, kc, s), ((b2p, move, _lc, (w_set, b_set)), b, _kc), moves) <- readIORef game_state_ior let set = case b2p of True -> w_set False -> b_set position = forsyth b False False capturing = case t of Nothing -> False _ -> True if Set.member position set then return False else do let set' = fromJust $ new_positions b2p w_set b_set position capturing m = (not b2p, move + 1, _lc, set') old_state = ((b2p, move, lc, (w_set, b_set)), ib, kc) writeIORef game_state_ior (no_interactive_move (b, m) _lc _kc s, (m, b, _kc), Stack.lcons (old_state, Just (interactive_move gs), Stack.empty) moves) return True -- | Complete interactive double move or return False if it would be repetition -- -- Require readIORef game_state_ior >>= has_second_move complete_second_move :: IORef Game_state -> IO Bool complete_second_move game_state_ior = do gs@(Interactive_state (_, _, Just c, Just c2, t, _ib@(ib, _), _, _, lc, kc, s), ((b2p, move, _lc, (w_set, b_set)), board', _kc), moves) <- readIORef game_state_ior let b' = move_from_to board' c c2 set = case b2p of True -> w_set False -> b_set position = forsyth b' False False capturing = case (t, piece_at board' (rank c2) (file c2)) of (Nothing, Nothing) -> False _ -> True if Set.member position set then return False else do let set' = fromJust $ new_positions b2p w_set b_set position capturing m = (not b2p, move + 1, _lc, set') old_state = ((b2p, move, lc, (w_set, b_set)), ib, kc) writeIORef game_state_ior (no_interactive_move (b', m) _lc _kc s, (m, b', _kc), Stack.lcons (old_state, Just (interactive_move gs), Stack.empty) moves) return True -- | Update interactive state with new signals. save_signals :: Signal_handlers -> Game_state -> Game_state save_signals signals' game_state = case game_state of (Interactive_state (_p, _c1, _c2, _c3, _p2, _ib, _pr, _l, _lc, _kc, _), _ni, _moves) -> (Interactive_state (_p, _c1, _c2, _c3, _p2, _ib, _pr, _l, _lc, _kc, signals'), _ni, _moves) -- | Allow only those signals used for single moves, or first stage of double moves. -- -- Require all signal-ids allocated set_signals_for_first_move :: Game_state -> IO () set_signals_for_first_move game_state = do let (Just cid1, Just cid2, Just cid3, Just cid4, Just cid5, Just cid6) = signals game_state signalBlock cid2 signalBlock cid4 signalBlock cid6 signalUnblock cid1 signalUnblock cid3 signalUnblock cid5 -- | Allow only those signals used for second stage of double moves. -- -- Require all signal-ids allocated set_signals_for_second_move :: Game_state -> IO () set_signals_for_second_move game_state = do let (Just cid1, Just cid2, Just cid3, Just cid4, Just cid5, Just cid6) = signals game_state signalBlock cid1 signalBlock cid3 signalBlock cid5 signalUnblock cid2 signalUnblock cid4 signalUnblock cid6 {-# contract reset_move :: Ok -> {r | not (has_moved r} #-} -- | Change game state so that no interaction has occured. reset_move :: Game_state -> Game_state reset_move (Interactive_state (_, _, _, _, _, is@(ib, m), _, _, _lc, _okc, s), (_, _, _kc), _moves) = (no_interactive_move is _lc _okc s, (m, ib, _kc), _moves) -- | Make coord the final destination for interactive double move. -- -- Require readIORef game_state_ior >>= has_moved set_second_destination :: IORef Game_state -> Coordinate -> IO () set_second_destination game_state_ior coord = modifyIORef game_state_ior (set_second_target coord) -- | Set lighting in game_state to influence on coord influence_on :: Coordinate -> Game_state -> Game_state influence_on coord game_state = case game_state of (Interactive_state (_p, _c1, _c2, _c3, _p2, _ib, _pr, _, _lc, _kc, _sg), (_m, board', _k), _moves) -> let l = influence_lighting board' coord in (Interactive_state (_p, _c1, _c2, _c3, _p2, _ib, _pr, l, _lc, _kc, _sg), (_m, board', _k), _moves) -- | State at next move from redo stack - state unchanged if no next move next_move :: Game_state -> Game_state next_move gs@(_is, ni_state, moves) = case Stack.lhead moves of (old_ni_state, previous_mv, future_stack) -> case Stack.null future_stack of True -> gs False -> let move = Stack.lhead future_stack new_future_stack = Stack.ltail future_stack new_moves = Stack.lcons (old_ni_state, previous_mv, Stack.empty) (Stack.ltail moves) Just (new_state, new_stack') = update_from_move (ni_state, Just new_moves) move (ni', m', _) = Stack.lhead (fromJust new_stack') new_stack = Stack.lcons (ni', m', new_future_stack) (Stack.ltail (fromJust new_stack')) in (_is, new_state, new_stack) -- | State at previous move from undo stack - state unchanged if no previous move previous_move :: Game_state -> Game_state previous_move gs@(_, _, moves) = let (prev_state@(ms@(_, _, lc, _), b, kc), m, fs) = Stack.lhead moves prev_stack = Stack.ltail moves new_stack = case Stack.null prev_stack of True -> prev_stack -- ignored -- from invariant we know m = Just _ -- need to remove head of `prev_stack' and replace it with it's contents, but incremented future stack False -> let (ni_state, m', _) = Stack.lhead prev_stack in Stack.lcons (ni_state, m', Stack.lcons (fromJust m) fs) (Stack.ltail prev_stack) in case Stack.null prev_stack of True -> gs False -> (no_interactive_move (b, ms) lc kc (signals gs), prev_state, new_stack) -- Implementation follows check_if_promoting :: (Piece, Promotion_status) -> Coordinate -> Coordinate -> Bool -> IO (Bool, Bool) check_if_promoting (piece, status) source target capturing = case status of s | s == No_promotion -> return (False, False) s | s == Declined_to_promote -> case is_compulsory_promotion piece target of True -> return (True, True) False -> case capturing && not (piece_type piece == Pawn) of True -> do promoting <- ask_if_promoting return (True, promoting) False -> return (False, False) s | otherwise -> case is_compulsory_promotion piece target of True -> return (True, True) False -> do let eligible = case s of May_promote -> True Not_yet_promoted -> is_in_promotion_zone target (piece_colour piece) || is_in_promotion_zone source (piece_colour piece) case eligible of False -> return (False, False) True -> do promoting <- ask_if_promoting return (True, promoting) ask_if_promoting :: IO Bool ask_if_promoting = do dialog <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo "Do you wish to promote?" response <- dialogRun dialog widgetHide dialog case response of ResponseYes -> return True ResponseNo -> return False -- | Updated positions seen with Black and White to move, or Nothing if a repetition new_positions :: Bool -> Set.Set String -> Set.Set String -> String -> Bool -> Maybe (Set.Set String, Set.Set String) new_positions b2p w_set b_set position capturing = let b_set' = case b2p of True -> Just b_set False -> case capturing of True -> Just (Set.singleton position) False -> case Set.member position b_set of True -> Nothing False -> Just (Set.insert position b_set) w_set' = case b2p of False -> Just w_set True -> case capturing of True -> Just (Set.singleton position) False -> case Set.member position w_set of True -> Nothing False -> Just (Set.insert position w_set) in case (w_set', b_set') of (Just w, Just b) -> Just (w, b) _ -> Nothing {-# contract set_second_target :: Ok -> {game_state | has_moved game_state} -> {r | is_second_target_selected r} #-} set_second_target :: Coordinate -> Game_state -> Game_state set_second_target coord game_state = case game_state of (Interactive_state (_p, _s, _d, _, _t, _ib, _pr,_l, _lc, _kc, _sg), (_m, b, (wkc, bkc, pcs)), _moves) -> let wkc' = case piece_at b (rank coord) (file coord) of Just (cp, _) | is_king cp && piece_colour cp == White -> wkc - 1 _ -> wkc bkc' = case piece_at b (rank coord) (file coord) of Just (cp, _) | is_king cp && piece_colour cp == Black -> bkc - 1 _ -> bkc pcs' = case piece_at b (rank coord) (file coord) of Nothing -> pcs Just _ -> pcs - 1 in (Interactive_state (_p, _s, _d, Just coord, _t, _ib, _pr, _l, _lc, _kc, _sg), (_m, b, (wkc', bkc', pcs')), _moves) ordered_coordinates :: (Coordinate, Lighting_colour) -> (Coordinate, Lighting_colour) -> Ordering ordered_coordinates first second = case first of (c1, _) -> case second of (c2, _) | c1 == c2 -> EQ | c1 > c2 -> GT | otherwise -> LT same_coordinates :: (Coordinate, Lighting_colour) -> (Coordinate, Lighting_colour) -> Bool same_coordinates first second = (ordered_coordinates first second) == EQ maximum_lighting :: (Coordinate, Lighting_colour) -> (Coordinate, Lighting_colour) -> Ordering maximum_lighting first second = case first of (_, l1) -> case second of (_, l2) | l1 == l2 -> EQ (_, l2) | l1 > l2 -> GT | otherwise -> LT no_lighting :: Lighting no_lighting = [] no_interactive_move :: (Board, Move_state) -> Bool -> King_count -> Signal_handlers -> Interactive_state no_interactive_move initial_state lc kc signals' = Interactive_state (Nothing, Nothing, Nothing, Nothing, Nothing, initial_state, (False, False), no_lighting, lc, kc, signals') {-# contract append_pass :: {Pass _ _} -> {(ni_state, move_stack) | True} -> {r | r == Nothing || r == Just (r_state, r_moves) && isJust move_stack == isJust r_moves) } #-} append_pass :: Move -> (Non_interactive_state, Maybe Move_stack) -> Maybe (Non_interactive_state, Maybe Move_stack) append_pass move (ni_state@((b2p, n, _, (w_set, b_set)), b, _kc), move_stack) = let position = forsyth b False False set' = new_positions b2p w_set b_set position False ms = (not b2p, n + 1, False, fromJust set') moves' = case move_stack of Nothing -> Nothing Just ms' -> Just (Stack.lcons (ni_state, Just move, Stack.empty) ms') new_ni_state = (ms, b, _kc) in case isJust set' of False -> Nothing True -> Just (new_ni_state, moves') {-# contract igui_capture :: {Igui _ _ _ _} -> {(ni_state, move_stack) | True} -> {piece2 | True} -> {coord2 | piece_at (board gs) (rank coord2) (file coord2) == Just (piece2, _) -> {r | r == Nothing || r == Just (r_state, r_moves) && isJust move_stack == isJust r_moves) } #-} igui_capture :: Move -> (Non_interactive_state, Maybe Move_stack) -> Piece -> Coordinate -> Maybe (Non_interactive_state, Maybe Move_stack) igui_capture move (ni_state@((b2p, n, _, (w_set, b_set)), b, (wkc, bkc, pcs)), move_stack) piece2 coord2 = let b' = remove_from b coord2 position = forsyth b' False False set' = new_positions b2p w_set b_set position True ms = (not b2p, n + 1, False, fromJust set') wkc' = case piece2 of cp | is_king cp && piece_colour cp == White -> wkc - 1 _ -> wkc bkc' = case piece2 of cp | is_king cp && piece_colour cp == Black -> bkc - 1 _ -> bkc moves' = case move_stack of Nothing -> Nothing Just ms' -> Just (Stack.lcons (ni_state, Just move, Stack.empty) ms') new_ni_state = (ms, b', (wkc', bkc', pcs - 1)) in case isJust set' of False -> Nothing True -> Just (new_ni_state, moves') {-# contract single_capture :: {Capture _ _ _ _ _ _} -> {(ni_state, move_stack) | True} -> {piece | True} -> {source | piece_at (board gs) (rank source) (file source) == Just (piece, _) -> {piece2 | True} -> {target | piece_at (board gs) (rank target) (file target) == Just (piece2, _) -> {promoting | not promoting || has_promotion (piece_type piece)} -> Ok -> {r | r == Nothing | r == Just (r_state, r_moves) && isJust move_stack == isJust r_moves) } #-} single_capture :: Move -> (Non_interactive_state, Maybe Move_stack) -> Piece -> Coordinate -> Piece -> Coordinate -> Bool -> Bool -> Maybe (Non_interactive_state, Maybe Move_stack) single_capture move (ni_state@((b2p, n, _, (w_set, b_set)), b, (wkc, bkc, pcs)), move_stack) piece source piece2 target promoting declining = let b' = assert ((piece == ((fst . fromJust) $ piece_at b (rank source) (file source))) && (not promoting || has_promotion (piece_type piece))) move_piece_and_promote b piece source target promoting declining Just (pp, _) = piece_at b' (rank target) (file target) position = forsyth b' False False set' = new_positions b2p w_set b_set position True lion' = case is_lion (piece_type piece) of True -> False False -> is_lion (piece_type piece2) wkc' = case piece2 of cp | is_king cp && piece_colour cp == White -> wkc - 1 _ -> case not (is_king piece) && is_king pp && piece_colour pp == White of True -> wkc + 1 False -> wkc bkc' = case piece2 of cp | not (is_king piece) && is_king cp && piece_colour cp == Black -> bkc - 1 _ -> case is_king pp && piece_colour pp == Black of True -> bkc + 1 False -> bkc ms = (not b2p, n + 1, lion', fromJust set') moves' = case move_stack of Nothing -> Nothing Just ms' -> Just (Stack.lcons (ni_state, Just move, Stack.empty) ms') new_ni_state = (ms, b', (wkc', bkc', pcs - 1)) in case isJust set' of False -> Nothing True -> Just (new_ni_state, moves') {-# contract single_move :: {Move _ _ _ _ _} -> {(ni_state, move_stack) | True} -> {piece | True} -> {coord | piece_at (board gs) (rank source) (file source) == Just (piece, _) -> {coord2 | piece_at (board gs) (rank target) == Nothing -> Ok -> Ok -> {r | r == Nothing | r == Just (r_state, r_moves) && isJust move_stack == isJust r_moves) } #-} single_move :: Move -> (Non_interactive_state, Maybe Move_stack) -> Piece -> Coordinate -> Coordinate -> Bool -> Bool -> Maybe (Non_interactive_state, Maybe Move_stack) single_move move (ni_state@((b2p, n, _, (w_set, b_set)), b, (wkc, bkc, pcs)), move_stack) piece source target promoting declining = let b' = assert (piece == ((fst . fromJust) $ piece_at b (rank source) (file source))) move_piece_and_promote b piece source target promoting declining Just (pp, _) = piece_at b' (rank target) (file target) position = forsyth b' False False set' = new_positions b2p w_set b_set position True ms = (not b2p, n + 1, False, fromJust set') wkc' = case not (is_king piece) && is_king pp && piece_colour pp == White of True -> wkc + 1 False -> wkc bkc' = case not (is_king piece) && is_king pp && piece_colour pp == Black of True -> bkc + 1 False -> bkc moves' = case move_stack of Nothing -> Nothing Just ms' -> Just (Stack.lcons (ni_state, Just move, Stack.empty) ms') new_ni_state = (ms, b', (wkc', bkc', pcs)) in case isJust set' of False -> Nothing True -> Just (new_ni_state, moves') {-# contract double_move :: {Double_move _ _ _ _} -> {(ni_state, move_stack) | True} -> {piece | True} -> {source | piece_at (board gs) (rank source) (file source) == Just (piece, _) -> Ok -> Ok -> Ok -> Ok -> {r | r == Nothing | r == Just (r_state, r_moves) && isJust move_stack == isJust r_moves) } #-} double_move :: Move -> (Non_interactive_state, Maybe Move_stack) -> Piece -> Coordinate -> Coordinate -> Maybe Piece -> Coordinate -> Maybe Piece -> Maybe (Non_interactive_state, Maybe Move_stack) double_move move (ni_state@((b2p, n, _, (w_set, b_set)), b, (wkc, bkc, pcs)), move_stack) piece source target piece2 target2 piece3 = let b' = assert (piece == ((fst . fromJust) $ piece_at b (rank source) (file source))) move_piece_twice b piece source target target2 position = forsyth b' False False cap' = case piece2 of Nothing -> case piece3 of Nothing -> False Just _ -> True Just _ -> True (f_cap, f_w_k, f_b_k, f_l) = case piece2 of Nothing -> (False, 0, 0, False) Just fp -> let ik = is_king fp bk = case ik && piece_colour fp == Black of True -> 1 False -> 0 wk = case ik && piece_colour fp == White of True -> 1 False -> 0 in (True, bk, wk, is_lion (piece_type fp)) (s_cap, s_w_k, s_b_k, s_l) = case piece3 of Nothing -> (False, 0, 0, False) Just fp -> let ik = is_king fp bk = case ik && piece_colour fp == Black of True -> 1 False -> 0 wk = case ik && piece_colour fp == White of True -> 1 False -> 0 in (True, bk, wk, is_lion (piece_type fp)) lion' = case is_lion (piece_type piece) of True -> False False -> f_l || s_l wkc' = wkc - f_w_k - s_w_k bkc' = bkc - f_b_k - s_b_k pcs' = case (f_cap, s_cap) of (True, True) -> pcs - 2 (False, True) -> pcs - 1 (True, False) -> pcs - 1 (False, False) -> pcs set' = new_positions b2p w_set b_set position cap' ms = (not b2p, n + 1, lion', fromJust set') new_ni_state = (ms, b', (wkc', bkc', pcs')) moves' = case move_stack of Nothing -> Nothing Just ms' -> Just (Stack.lcons (ni_state, Just move, Stack.empty) ms') in case isJust set' of False -> Nothing True -> Just (new_ni_state, moves') {-# contract interactive_move :: {game_state | has_moved game_state} -> Ok #-} -- | Move constructed by interactive player interactive_move :: Game_state -> Move interactive_move game_state@(_,ni_state, _) = let t2 = second_destination game_state c = first_capture game_state (p, _) = selected_piece game_state s = selected_square game_state t = selected_target game_state b = board ni_state (pr, dec) = promotion_choices game_state in case t2 of Nothing -> case c of Nothing -> Move p s t pr dec Just cap -> Capture p s cap t pr dec Just c3 -> case s == c3 of True -> case c of Nothing -> Pass p s Just p' -> Igui p s p' t False -> let snd_cap = case piece_at b (rank c3) (file c3) of Nothing -> Nothing Just (p', _) -> Just p' in Double_move p s t c c3 snd_cap