-- | Chu Shogi 'Move' generator
-- 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 <http://www.gnu.org/licenses/>.

module Generator (
                  -- * Access
                  generate_moves
                 ) where

import Control.Exception (assert)
import Data.List (sortBy)
import Data.Maybe
import Game_state
import Piece
import Board
import Move
import Coordinate
import Lighting

-- | Generate all legal moves from state.
--
-- The best moves (according to some heuristic) should come first
generate_moves :: (Non_interactive_state, Maybe Move) -> [(Non_interactive_state, Maybe Move)]
generate_moves (state, _) =
    let colour = case is_black_to_play state of
                   True -> Black
                   False -> White
        pieces' = all_pieces_of_colour (board state) colour
        unsorted = concatMap (generate_moves_for_piece state) pieces'
        sorted = sortBy best_move unsorted
        moves = mapMaybe new_move sorted
    in {-trace (concat (intersperse "\n" (map (print_move . fromJust . snd) moves)))-} moves
        where new_move mv = 
                  case update_from_move (state, Nothing) mv of
                    Nothing -> Nothing
                    Just (st', Nothing) -> Just (st', Just mv)

-- Implementation

-- | Move most likely to be selected according to heuristic:
--
-- (1) Captures first
--
-- (2) Most valuable capture first
--
-- (3) Least valuable capturing piece first
--
-- (4) Most valuable moving piece first
best_move :: Move -> Move -> Ordering
best_move first second =
    let capturing_1 = capturing first
        capturing_2 = capturing second
        moving_value_1 = moving_value first
        moving_value_2 = moving_value second
    in case (capturing_1, capturing_2) of
         (True, False) -> GT
         (False, True) -> LT
         (True, True) -> 
             let capturing_value_1 = capturing_value first
                 capturing_value_2 = capturing_value second
             in case compare capturing_value_1 capturing_value_2 of
                  c | c == EQ -> case compare moving_value_2 moving_value_1 of
                                   c' | c' == EQ -> compare moving_value_1 moving_value_2
                                   c' | otherwise -> c'
                  c | otherwise -> c
         (False, False) -> compare moving_value_1 moving_value_2
      where moving_piece m = case m of
                               Pass p' _ -> p'
                               Igui p' _ _ _ -> p'
                               Double_move p' _ _ _ _ _ -> p'
                               Capture p' _ _ _ _ _ -> p'
                               Move p' _ _ _ _ -> p'
            capturing m = case m of
                            Pass _ _ -> False
                            Igui _ _ _ _ -> True
                            Double_move _ _ _ p1 _ p2 -> 
                                case p1 of
                                  Just _ -> True
                                  Nothing -> case p2 of
                                               Nothing -> False
                                               Just _ -> True
                            Capture _ _ _ _ _ _ -> True
                            Move _ _ _ _ _ -> False
            capturing_value m  = case m of
                            Igui _ _ p' _ -> piece_value p'
                            Double_move _ _ _ (Just p1) _ (Just p2) -> piece_value p1 + piece_value p2 
                            Double_move _ _ _ Nothing _ (Just p2) -> piece_value p2 
                            Double_move _ _ _ (Just p1) _ Nothing -> piece_value p1
                            Capture _ _ p' _ _ _ -> piece_value p'
            moving_value m  = piece_value (moving_piece m)

-- | All valid* moves for piece (random order)
--
-- *Validity subject to a repetition check
generate_moves_for_piece :: Non_interactive_state 
                           -> (Coordinate, Piece, Promotion_status)
                           -> [Move]
generate_moves_for_piece state (coord, piece, status) =
    let directions = enumFrom North
        capturable_filter = is_capturable Nothing (was_lion state) False piece coord (board state)
        range_targets = concatMap ((blank_or_first_capturable Nothing (was_lion state) piece coord (board state)) . (squares_from (board state) coord (-1) (piece_type piece) (piece_colour piece) [])) directions
        jump_targets = filter capturable_filter
                       (concatMap (jump_from (board state) coord (piece_type piece) (piece_colour piece) []) directions)
        lion_move_targets = lion_from  (board state) coord (piece_type piece) (piece_colour piece) []
        range_moves = concatMap (simple_move state coord piece status) range_targets
        jump_moves = concatMap (simple_move state coord piece status) jump_targets
        lion_moves = assert (all good_lion_targets (map ((filter capturable_filter) . lion_move_targets)  directions))
                     map ((simple_lion_moves state coord piece) . (filter capturable_filter) . lion_move_targets)
                     directions
        lion_power = lion_power_moves piece coord state $ filter capturable_filter (lion_power_from (board state) coord (piece_type piece) (piece_colour piece))
    in range_moves ++ jump_moves ++ (concat lion_moves) ++ lion_power

{-# contract simple_move :: Ok -> Ok -> Ok -> Ok -> 
  {(_, l) | l `elem` [Step_capture, Step_lighting, Jump_capture, Jump_lighting]} -> Ok #-}    
-- | Generated range or jump moves
simple_move :: Non_interactive_state         -- ^ Initial state
            -> Coordinate                    -- ^ Origin
            -> Piece                         -- ^ Piece to move
            -> Promotion_status              -- ^ Initial status
            -> (Coordinate, Lighting_colour) -- ^ Target and move type
            -> [Move]
simple_move state coord piece status (target, lighting') =
    let (eligible, forced) = is_eligible_to_promote piece status coord target capturing
        pr_decl = case eligible of
               False -> [(False, False)]
               True -> case forced of
                         True -> [(True, False)]
                         False -> [(True, False), (False, True)]
        capturing = lighting' == Step_capture 
        mover = case capturing of
           True -> assert (rank target >= 0 && rank target <= 11 && file target >= 0 && file target <= 11) (Capture piece coord (fst (fromJust $ piece_at (board state) (rank target) (file target))) target)
           False -> Move piece coord target
    in [mover x y | (x, y) <- pr_decl]

-- | Lion moves by non-Lion pieces
--
-- Need to generate:
--
-- (1) Direct jump to B square
--
-- (2) Simple move to A Square
--
-- (3) Igui capture
--
-- (4) Double move
--
-- No pass is generated, since it is easily proved that these cannot affect
-- the outcome of mating problems, and it is postulated that these are never good
-- in real positions (certainly I have never encountered a situation).
--
-- It may be that it is possible to construct an endgame position where pass
-- is a good defence, but such positions do not come up in real games
-- of Chu Shogi, and so can safely be ignored.
{-# contract simple_lion_move :: Ok -> Ok -> Ok -> 
  {targets | good_lion_targets targets} -> Ok #-}    
simple_lion_moves :: Non_interactive_state           -- ^ Initial state
                  -> Coordinate                      -- ^ Origin
                  -> Piece                           -- ^ Piece to move
                  -> [(Coordinate, Lighting_colour)] -- ^ Targets with move types
                  -> [Move]
simple_lion_moves state coord piece targets = 
    let jump_move = case lion_b_specifier targets of
                      Just (target, l) -> move_or_capture target l
                      _ -> []
        simple_move' = case lion_a_specifier targets of
                       Just (target, l) -> move_or_capture target l
                       _ -> []
        igui = case lion_a_specifier targets of
                 Just (target, Lion_a_capture) -> assert (rank target >= 0 && rank target <= 11 && file target >= 0 && file target <= 11)
                     [Igui piece coord (fst . fromJust $ piece_at (board state) (rank target) (file target)) target]
                 _ -> []
        double_move = case length targets == 2 of
                        True -> double_lion_move state coord piece
                                (fromJust . lion_a_specifier $ targets)  (fromJust . lion_b_specifier $ targets)
                        False -> []
    in jump_move ++ simple_move' ++ igui ++ double_move
        where
          move_or_capture target l =
              case l == Lion_b_capture || l == Lion_a_capture of
                True -> let t_piece = assert (rank target >= 0 && rank target <= 11 && file target >= 0 && file target <= 11) fst . fromJust $ piece_at (board state) (rank target) (file target)
                        in [Capture piece coord t_piece target False False]
                False -> [Move piece coord target False False]


-- | Moves by lions
--
-- Need to generate:
--
-- (1) Direct jumps to B squares
--
-- (2) Simple moves to A Squares
--
-- (3) Igui captures
--
-- (4) Double moves
--
-- No pass is generated, since it is easily proved that these cannot affect
-- the outcome of mating problems, and it is postulated that these are never good
-- in real positions (certainly I have never encountered a situation).
--
-- It may be that it is possible to construct an endgame position where pass
-- is a good defence, but such positions do not come up in real games
-- of Chu Shogi, and so can safely be ignored.
lion_power_moves :: Piece       -- ^ Moving Lion
                 -> Coordinate -- ^ Initial location of moving Lion
                 -> Non_interactive_state
                 -> [(Coordinate, Lighting_colour)] -> [Move]
lion_power_moves piece coord state targets =
    let b_targets = filter is_lion_b_pair targets
        a_targets = filter is_lion_a_pair targets
        direct_jumps = map move_or_capture b_targets 
        a_moves = map move_or_capture a_targets 
        iguis = map igui_move $ filter is_lion_a_capture a_targets
        double_moves = [double_lion_move state coord piece a b | a <- a_targets, b <- b_targets, distance_from (fst a) (fst b) == 1]
    in direct_jumps ++ a_moves ++ iguis ++ (concat double_moves)
        where
          t_piece target = assert (rank target >= 0 && rank target <= 11 && file target >= 0 && file target <= 11) fst . fromJust $ piece_at (board state) (rank target) (file target)
          is_lion_a_capture (_, l) = l == Lion_a_capture
          igui_move (target, _) = Igui piece coord (t_piece target) target
          move_or_capture (target, l) =
              case l == Lion_b_capture || l == Lion_a_capture of
                True -> Capture piece coord (t_piece target) target False False
                False -> Move piece coord target False False
    
-- | Singleton or empty list of double-moves
--
-- An empty list might be returned, as we do not generate moves of the form X lc - md - ne
-- or X lc - md x ne
-- as a direct jump is just as good
{-# contract double_lion_move :: Ok -> Ok -> Ok -> {t1 | True} -> {t2 | good_lion_targets [t1, t2]} -> 
  {r | length r < 2} #-}    
double_lion_move :: Non_interactive_state
                 -> Coordinate
                 -> Piece
                 -> (Coordinate, Lighting_colour)
                 -> (Coordinate, Lighting_colour)
                 -> [Move]
double_lion_move state coord piece (a_target, a_colour) (b_target, b_colour) =
    case (a_colour, b_colour) of
      (Lion_a_lighting, _) -> []
      (Lion_a_capture, _) ->
          let b = board state
              a_piece = assert (rank a_target >= 0 && rank a_target <= 11 && file a_target >= 0 && file a_target <= 11) fst . fromJust $ (piece_at b (rank a_target) (file a_target))
              b_piece = 
                  case assert (rank b_target >= 0 && rank b_target <= 11 && file b_target >= 0 && file b_target <= 11) piece_at b (rank b_target) (file b_target) of
                    Nothing -> Nothing
                    Just (p, _) -> Just p
          in [Double_move piece coord a_target (Just a_piece) b_target b_piece]

{-# contract lion_a_specifier :: {targets | good_lion_targets targets} -> Ok #-}    
-- | Lion A move specifier, if any
lion_a_specifier :: [(Coordinate, Lighting_colour)] -> Maybe (Coordinate, Lighting_colour)
lion_a_specifier targets =
    case null targets of
      True -> Nothing
      False ->
          case head targets of
            (c, l) | l == Lion_a_lighting || l ==Lion_a_capture -> Just (c, l)
                   | otherwise -> Nothing

{-# contract lion_a_specifier :: {targets | good_lion_targets targets} -> Ok #-}    
-- | Lion B move specifier, if any
lion_b_specifier :: [(Coordinate, Lighting_colour)] -> Maybe (Coordinate, Lighting_colour)
lion_b_specifier targets =
    case null targets of
      True -> Nothing
      False ->
          case length targets == 2 of
            False ->
                case head targets of
                  (c, l) | l == Lion_b_lighting || l == Lion_b_capture -> Just (c, l)
                         | otherwise -> Nothing
            True -> Just . head . tail $ targets

-- Contract support

-- | Good values for targets of Lion moves for non-Lions
--
-- List may be
--
-- (1) empty
--
-- (2) a single entry consisting of either an A move or a B move
--
-- (3) two entries consisting of an A move followed by a B move
good_lion_targets :: [(Coordinate, Lighting_colour)] -> Bool
good_lion_targets targets =
    let lion_b = [Lion_b_capture, Lion_b_lighting]
        lion_a = [Lion_a_capture, Lion_a_lighting]
    in case length targets of
      0 -> True
      1 -> let (_, l) = head targets
           in elem l (lion_a ++ lion_b)
      2 -> let (_, l1) = head targets
               (_, l2) = head . tail $ targets
           in (elem l1 lion_a) && (elem l2 lion_b)
      _ -> False