foo-1.0: FooMove.hs
-- ==================================
-- 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