-- ==================================
-- Module name: FooMove
-- Project: Foo
-- Copyright (C) 2007  Bartosz Wójcik
-- Created on: 01.10.2007
-- Last update: 07.04.2008
-- Version: %

{-  This program 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.

    This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
-}
-- ==================================
module FooMove
where

import qualified Data.Map as Map
import Data.List
import FooField
import Monad

-- This module constructs space of possible moves for a given field, initial vertex and direction towards one of the goals.
-- Provides bunch of funcions manipulating on moves.



-- One of following has to be active:
-- MoveSimple
-- MoveImproved1    (expected acceleration x5 to x30)
-- MergePlies
   -- MergePlies reduces numer of examined moves by recognizing duplications even if they are split into plies.
   -- Additionally it reduces moves' comparison overhead as it stops only when given number of plies is created.
   -- Comparing function gets at very beginnig final space of moves of given ply.
   -- MergePlies makes AlphaBeta useless, so it's cheaper to switch it off.
   -- Finally MergePlies hasn't resulted in playing machine acceleration and I dropped its further development. By now I'm not sure if this option compiles.

-- #define MoveSimple
#define MoveImproved1
-- #define MergePlies

-- MoveImproved2 is optional for MoveImproved1 switched on.
-- It switches on more efficient way of duplicated moves recognition. It assumes that duplicated move has to have a cycle
-- and doesn't check moves that don't have cycles.
#define MoveImproved2


-- Each move consists of passes. Pass is an existing edge between 2 vetices. Each pass can be either
-- intermedium pass - such one that doesn't finish move;
-- final pass - such one that finishes move.

-- Vertex - vertex
-- Graph - graph
-- l - length of field
-- w - width of field
-- Bool - whether Vertex is active. Inactive vertices lead to LastPass.
-- n - number of pass in the move
-- i - number of depth. The real move is depth 0, move against is depth 1 etc.

data Move = NextPass                                -- intermedate, recently constructed pass. Contains all information required to continue constructin space of passes.
                     [Vertex]                                   -- List of vertices constructing move until this point.
                     Graph                                      -- Graph after pass.
                     Int Int                                    -- Size of field. Lenght and width.
                     Bool                                       -- Active last vertex flag.
                     Int                                        -- Number of passes within the move
                     Int                                        -- Depth of the move. 0-inspected move; 1-ply + 1;...
#ifdef MergePlies
                     [Vertex]                                   -- List of vertices constructing move until end of ply 0.
#else
                     [Move]                                     -- List of moves that can start from this point under current circumstances
#endif
                     (Map.Map Int Bool)                         -- Set of edges of current move ordered by edge mark
                     (Map.Map Vertex Int)                       -- Set of ordered vertices having number of occurences within the move. Used for cycle recognition.
          | Pass [Move]                             -- intermediate pass keeps just pointer to next passes
          | LastPass                                -- Last pass within the move. Doesn't finish the game.
                     [Vertex] Graph Int Int Int Int [Move]      -- See description of NextPass
#ifdef MergePlies
                     Vertex                                   -- Last vertex after move of last examined ply.
#endif

          | Goal [Vertex]                           -- Move finished in the opponent's goal. Keeps list of vertices constructing it.
          | LostGoal [Vertex]                       -- Move finished in the own goal. Keeps list of vertices constructing it.
          | LostHalfGoal [Vertex] Graph             -- Move finished because of no passes available. Keeps list of vertices constructing it.
          | HalfGoal [Vertex] Graph                 -- The same but occured while examining possible opponent's moves.
          | UnfinishedMove [Vertex] Int             -- Too many passes to examine this move further.


instance Show (Move) where
   show (Pass _) = "Pass"
#ifdef MergePlies
   show (LastPass v _ _ _ _ i _ _) = "LastPass " ++ concat (map show v)
#else
   show (LastPass v _ _ _ _ i _) = "LastPass " ++ concat (map show v)
#endif
   show (Goal v) = "Goal " ++ concat (map show v)
   show (LostGoal v) = "LostGoal " ++ concat (map show v)
   show (LostHalfGoal v _) = "LostHalfGoal " ++ concat (map show v)
   show (HalfGoal v _) = "HalfGoal " ++ concat (map show v)
   show (UnfinishedMove v _) = "UnfinishedMove " ++ concat (map show v)

-- Cast move on vertices axe.
vOfMove :: Move -> [Vertex]
vOfMove (Pass _)                 = []
#ifdef MergePlies
vOfMove (LastPass v _ _ _ _ _ _ _) = v
#else
vOfMove (LastPass v _ _ _ _ _ _) = v
#endif
vOfMove (Goal v)                 = v
vOfMove (LostGoal v)             = v
vOfMove (LostHalfGoal v _)       = v
vOfMove (HalfGoal v _)           = v
vOfMove (UnfinishedMove v _)     = v

-- Returns field after move.
graphAfterPass :: Graph -> Move -> Graph
#ifdef MergePlies
graphAfterPass g afterBestMove@(LastPass _ g' _ _ _ _ _ _) = g'
#else
graphAfterPass g afterBestMove@(LastPass _ g' _ _ _ _ _) = g'
#endif
graphAfterPass g afterBestMove@(LostHalfGoal _ g')       = g'
graphAfterPass g afterBestMove@(HalfGoal _ g')           = g'
graphAfterPass g _                                       = g

-- ====================================
-- Function constructing space of moves
-- ====================================

-- ==========
-- MoveSimple
-- ==========
#ifdef MoveSimple

nextPass :: Bool -> Move -> Move
-- Below 3 lines have to be adjusted on experimental way for the processor power.
nextPass d (NextPass vs g fL fW True 5 2 [] _ _)   | vertices (head vs) g /= []        = UnfinishedMove vs 2
nextPass d (NextPass vs g fL fW True 8 1 [] _ _)   | vertices (head vs) g /= []        = UnfinishedMove vs 1
nextPass d (NextPass vs g fL fW True 13 0 [] _ _)  | vertices (head vs) g /= []        = UnfinishedMove vs 0
nextPass d (NextPass vs g fL fW True n i [] m mV)  | even i && noPass                  = LostHalfGoal vs g
                                                   | noPass                            = HalfGoal vs g
                                                   | otherwise                         = Pass [nextPass d (NextPass (v':vs) (rmEdge v v' g) fL fW (active v' g) (n+1) i [] m mV) |v' <- vertices v g]
                                              where v = head vs
                                                    noPass = vertices v g == []
nextPass d (NextPass vs g fL fW False n i [] _ _) | y == 0 && d || y == fL + 2 && not d      = Goal vs
                                                  | y == 0 && not d || y == fL + 2 && d      = LostGoal vs
                                                  | otherwise                                = LastPass vs g fL fW n i [nextMove d v g fL fW (i+1)]
                                       where y = snd v
                                             v = head vs

-- ==================================================================
-- The main function of this modul that returns full space of moves.
-- ==================================================================
-- Later I'll use lazyness to limit this space to size which I think will be practical. Full space of moves is by now too big for my hardware.
-- d - if plays towards (_,0) goal
-- v - initial vertex
-- g - initial graph
-- fL, fW - field size (length, width)
-- i - depth number - first move has depth 0, answer depth 1, etc...
nextMove :: Bool -> Vertex -> Graph -> Int -> Int -> Int -> Move
nextMove d v g fL fW i = nextPass d (NextPass [v] g fL fW True 0 i [] Map.empty Map.empty)
-- ==================================================================

#endif

-- Returns numer of possible moves for given tree of moves until given depth.
sizeMove :: (Num b) => Int -> Move -> b
sizeMove t (Pass m)                             = foldr ((+).sizeMove t) 0 m
sizeMove t (LastPass _ _ _ _ _ i m) | i == t    = 1
                                    | otherwise = foldr ((+).sizeMove t) 0 m
sizeMove _          _                           = 1

-- Walks through tree of moves folding it using given function f.
foldMove :: (b -> b -> b) -> b -> Move -> b
foldMove f value (Pass m) = foldr (f . foldMove f value) value m
foldMove _ value _        = value

-- Maps given function on all leaves of tree of moves.
mapMove :: (Move -> a) -> Move -> [a]
mapMove f (Pass ms) = concat $ map (mapMove f) ms
mapMove f m         = [f m]

-- ===================================================

-- =============
-- MoveImproved1
-- =============
-- Processes current move one pass further. Move is processed so, that first all next passes for until now recognized moves are
-- processed, then duplicated moves are removed and so on. Kind of "breadth-first search".
#ifdef MoveImproved1
nextPass :: Bool -> Move -> [Move]
nextPass d (NextPass vs g fL fW True n i [] m mV)| even i && noPass      = [LostHalfGoal vs g]
                                                 | noPass                = [HalfGoal vs g]
                                                 | otherwise             = [NextPass (v':vs) (rmEdge v v' g) fL fW (active v' g) (n+1) i [] (Map.insert (markEdge fW v v') True m) (Map.insertWith (+) v' 1 mV) |v' <- vertices v g] 
                                                 where v = head vs
                                                       noPass = vertices v g == []
nextPass d (NextPass vs g fL fW False n i [] _ _) | y == 0 && d || y == fL + 2 && not d  = [Goal vs]
                                                  | y == 0 && not d || y == fL + 2 && d  = [LostGoal vs]
                                                  | otherwise                            = [LastPass vs g fL fW n i [nextMove d v g fL fW (i+1)]]
                                          where y = snd v
                                                v = head vs
-- ==================================================================
-- The main function of this modul that returns full space of moves.
-- ==================================================================
-- Later I'll use lazyness to limit this space to size which I think will be practical. Full space of moves is by now too big for my hardware.
-- d - if plays towards (_,0) goal (direction)
-- v - initial vertex
-- g - initial graph
-- fL, fW - field size (length, width)
-- i - depth number - first move has depth 0, answer depth 1, etc...
nextMove :: Bool -> Vertex -> Graph -> Int -> Int -> Int -> Move
nextMove d v g fL fW i = Pass (nNextMove d [NextPass [v] g fL fW True 1 i [] (Map.empty) (Map.insert v 1 Map.empty)]) 
-- ==================================================================

-- Applies nextPass to all by now recognized moves.
nextAllPasses :: Bool -> [Move] -> [Move]
nextAllPasses d ls = (concat $ map (nextPass d) ls) 


-- Couple of functions that categorize moves.
isNextPass :: Move -> Bool
isNextPass (NextPass _ _ _ _ _ _ _ _ _ _) = True
isNextPass _                              = False

isLastPass :: Move -> Bool
isLastPass (LastPass _ _ _ _ _ _ _) = True
isLastPass _                        = False

finishesMatch :: Move -> Bool
finishesMatch (Goal _ )          = True
finishesMatch (LostGoal _)       = True
finishesMatch (HalfGoal _ _)     = True
finishesMatch (LostHalfGoal _ _) = True
finishesMatch _                  = False

-- Removes duplicated moves from the list using Map of edges, each move caries with it.
-- Use it as follows: pruneMoves (Map.empty) ls [], where ls is list of moves to be pruned.
pruneMoves :: Map.Map (Map.Map Int Bool) Bool -> [Move] -> [Move]
pruneMoves _ []                                                                 = []
pruneMoves t (l@(NextPass vs g fL fW True n i ms m _):ls)  | Map.member m t     = pruneMoves t ls
                                                           | otherwise          = (l:(pruneMoves (Map.insert m True t) ls))
pruneMoves t (l:ls)                                                             = (l:(pruneMoves t ls))

-- For given list of moves it makes next step in BFS.
-- This function already presorts moves in the following way.
--   Moves that finish match are first.
--   Moves that don't finish match are afterwards and they are presoted on their length - longer first, shorter afterwards.
nNextMove :: Bool -> [Move] -> [Move]
nNextMove _ [] = []
nNextMove d ls = newFinishingMatch ++ nNextMove d (((movesNotToPrune.newNotFinishedMoves) newMoves) ++ pruneMoves (Map.empty) ((movesPossiblyToPrune.newNotFinishedMoves) newMoves)) ++ newFinishedMoves
               where newMoves = nextAllPasses d ls
                     newFinishingMatch = [m | m <- newMoves, finishesMatch m]                     
                     newFinishedMoves = [m | m <- newMoves, isLastPass m]
                     newNotFinishedMoves ls = [m | m <- ls, isNextPass m]
#endif


-- =============
-- MoveImproved2
-- =============

#ifndef MergePlies
#ifdef MoveImproved2

movesPossiblyToPrune :: [Move] -> [Move]
movesPossiblyToPrune ls = [m | m <- ls, cycleInLastPass m]

movesNotToPrune :: [Move] -> [Move]
movesNotToPrune ls = [m | m <- ls, not $ cycleInLastPass m]

-- Function recognizes cycle after each BFS step.
-- Cycle exists if the last visited vertex has been already visited within current move before.
cycleInLastPass :: Move -> Bool
cycleInLastPass (NextPass vs _ _ _ _ _ _ _ _ mV) = Map.findWithDefault 0 (head vs) mV > 1


-- Very rough and ... order of moves
-- Argumets: Direction towards (_,0) goal and list of moves.
lessThan :: Bool -> Move -> Move -> Bool
lessThan _ (LostGoal _) _ = True
lessThan _ (LostHalfGoal _ _) _ = True
lessThan True  (LastPass ((x,y):vs) _ _ _ _ _ _) (LastPass ((x',y'):vs') _ _ _ _ _ _) = y > y'
lessThan False (LastPass ((x,y):vs) _ _ _ _ _ _) (LastPass ((x',y'):vs') _ _ _ _ _ _) = y < y'
lessThan _ (LastPass _ _ _ _ _ _ _) _ = True
lessThan _ (HalfGoal _ _) _ = True
lessThan _ _ _ = False

#else

movesPossiblyToPrune :: [Move] -> [Move]
movesPossiblyToPrune ls = ls

movesNotToPrune :: [Move] -> [Move]
movesNotToPrune ls = []

#endif
#endif


-- ===================================================
-- ==========
-- MergePlies
-- ==========
#ifdef MergePlies
nextPass :: Bool -> Int -> Move -> [Move]
nextPass d ply (NextPass vs g fL fW True n i [] m mV vs0)| even i && noPass      = [LostHalfGoal vs g]
                                                         | noPass                = [HalfGoal vs g]
                                                         | i > 0                 = [NextPass (v':vs) (rmEdge v v' g) fL fW (active v' g) (n+1) i [] (Map.insert (markEdge fW v v') True m) (Map.insertWith (+) v' 1 mV) vs0 |v' <- vertices v g]
                                                         | otherwise             = [NextPass (v':vs) (rmEdge v v' g) fL fW (active v' g) (n+1) i [] (Map.insert (markEdge fW v v') True m) (Map.insertWith (+) v' 1 mV) (v':vs) |v' <- vertices v g]
                                                 where v = head vs
                                                       noPass = vertices v g == []
nextPass d ply (NextPass vs g fL fW False n i [] _ _ vs0) | y == 0 && d || y == fL + 2 && not d  = [Goal vs]
                                                          | y == 0 && not d || y == fL + 2 && d  = [LostGoal vs]
                                                          | ply > i                              = [NextPass (v':vs) (rmEdge v v' g) fL fW (active v' g) (n+1) (i+1) [] (Map.insert (markEdge fW v v') True m) (Map.insertWith (+) v' 1 mV) vs0 |v' <- vertices v g]
                                                          | otherwise                            = [LastPass vs0 g fL fW n i [] (head vs) ]
                                          where y = snd v
                                                v = head vs
-- ==================================================================
-- The main function of this modul that returns full space of moves.
-- ==================================================================
-- d - if plays towards (_,0) goal
-- v - initial vertex
-- g - initial graph
-- fL, fW - field size (length, width)
-- i - depth number - first move has depth 0, answer depth 1, etc...
-- ply - number of plies function has to explore. It finished when i > ply
nextMove :: Bool -> Vertex -> Graph -> Int -> Int -> Int -> Int -> Move
nextMove d v g fL fW i ply = Pass (nNextMove d ply [NextPass [v] g fL fW True 1 i [] (Map.empty) (Map.insert v 1 Map.empty) [v] ])
-- ==================================================================

nextAllPasses :: Bool -> Int -> [Move] -> [Move]
nextAllPasses d ply ls = (concat $ map (nextPass d ply) ls)

isNextPass :: Move -> Bool
isNextPass (NextPass _ _ _ _ _ _ _ _ _ _ _) = True
isNextPass _                                = False

-- Removes duplicated moves from the list using Map of edges, each move caries with it.
-- Use it as follows: pruneMoves (Map.empty) ls [], where ls is list of moves to be pruned.
-- This function is not beautiful. It validates each move against Map of moves and updates this Map concurently.
-- pruneMoves :: Map.Map (Map.Map Int Int) Bool -> [Move] -> [Move] -> [Move]
-- pruneMoves _ []                                          os                      = os
-- pruneMoves t (l@(NextPass vs g fL fW True n i ms m):ls)  os | Map.member m t     = pruneMoves t ls os
--                                                            | otherwise          = pruneMoves (Map.insert m True t) ls (l:os)
-- pruneMoves t (l:ls)                                      os                      = pruneMoves t ls (l:os)
pruneMoves :: Map.Map (Map.Map Int Bool) Bool -> [Move] -> [Move]
pruneMoves _ []                                                                   = []
pruneMoves t (l@(NextPass vs g fL fW True n i ms m _ _):ls)  | Map.member m t     = pruneMoves t ls
                                                             | otherwise          = (l:(pruneMoves (Map.insert m True t) ls))
pruneMoves t (l:ls)                                                               = (l:(pruneMoves t ls))

nNextMove :: Bool -> Int -> [Move] -> [Move]
nNextMove _ _ [] = []
nNextMove d ply ls = newFinishedMoves ++ nNextMove d ply (((movesNotToPrune.newNotFinishedMoves) newMoves) ++ pruneMoves (Map.empty) ((movesPossiblyToPrune.newNotFinishedMoves) newMoves))
               where newMoves = nextAllPasses d ply ls
                     newFinishedMoves = [m | m <- newMoves, not $ isNextPass m]
                     newNotFinishedMoves ls = [m | m <- ls, isNextPass m]

movesPossiblyToPrune :: [Move] -> [Move]
movesPossiblyToPrune ls = [m | m <- ls, cycleInLastPass m]

movesNotToPrune :: [Move] -> [Move]
movesNotToPrune ls = [m | m <- ls, not $ cycleInLastPass m]

cycleInLastPass :: Move -> Bool
cycleInLastPass (NextPass vs _ _ _ _ _ _ _ _ mV _) = Map.findWithDefault 0 (head vs) mV > 1

#endif