module Reversi where

import Array
import Data.List
import Data.Maybe
{- import Debug.Trace -}

{- The type of a piece on the game field. 
The cell might be empty as well, so we have None.
This could have been solved by using Maybe as well, 
but I have chosen this approach. -}
data Piece = Head | Tail deriving Eq

switchPiece :: Piece -> Piece
switchPiece Tail = Head
switchPiece Head = Tail

isJustThis :: (Maybe Piece) -> Piece -> Bool
isJustThis (Just piece) expected  = piece == expected
isJustThis Nothing expected = False

type Pos = (Int, Int)
type GameField = Array Pos (Maybe Piece)

{- Creates game field of given size, with given 
initial pieces (as a tuple: position and a piece type) -}
createGameField :: Int -> Int -> [(Pos,Piece)] -> GameField
createGameField width height pieces = 
	if (width < 3) || (height < 3) then error "Game field must be at least of size 3x3"
  else if (length pieces) < 2 then error "Game field has to have at least two pieces."
	else
		let size = ((0,0),(width-1, height-1)) in
		let fieldData = [Nothing | x<-[1..width], y<-[1..height]] in
		let field = listArray size fieldData in
		foldl (\field (pos,piece) -> push pos piece field) field pieces

width :: GameField -> Int
width gameField = let (width, height) = size gameField in width

height :: GameField -> Int
height gameField = let (width, height) = size gameField in height

size :: GameField -> (Int,Int)
size gameField = let ((_,_), (width, height)) = bounds gameField in (width+1, height+1)

isValidIndex :: Pos -> GameField -> Bool
isValidIndex (x,y) gameField = 
	let (width, height) = size gameField in
	x >= 0 && x < width && y >= 0 && y < height
			
get :: Pos -> GameField -> Maybe Piece
get (x,y) f = f!(x,y)
			
push :: Pos -> Piece -> GameField -> GameField
push (x,y) piece orig = orig // [((x,y),Just piece)]
	
moveInDir :: Pos -> Pos -> Pos
moveInDir (dx,dy) (x,y) = (x+dx, y+dy)

flipLine :: Pos -> Pos -> GameField -> [GameField]
flipLine (startX, startY) (endX, endY) field = 
	let dir = (normalize (endX - startX), normalize (endY - startY)) in
	let movedStart = moveInDir dir (startX,startY) in
	let positions = 
		takeWhile ((endX,endY)/=) $ iterate (moveInDir dir) movedStart in
	scanl pushSwitched field positions
	where 
		pushSwitched f pos = push pos (switchPiece (fromJust $ get pos f)) f
		normalize:: Int -> Int
		normalize 0 = 0
		normalize x = x `div` (abs x)

{- Flips lines that are created by playing at given position.
The second argument should be the result of 
function getPossiblePlaysWithEval. -}
flipLines :: Pos -> [(Pos,Pos,Int)] -> GameField -> [GameField]
flipLines pos allLines field =
	let lines = filter (\(start,end,len) -> end == pos) allLines in
	concat $ scanl (\fields (start,end,len) -> flipLine start end (last fields)) [field] lines
	
pieces :: GameField -> [(Pos, Piece)]
pieces field = 
	[((x,y), fromJust (get (x,y) field)) | 
		x <- [0..(width field)-1], 
		y <- [0..(height field)-1],
		(get (x,y) field) /= Nothing]

getPossibleMoves:: Piece -> GameField -> [Pos]
getPossibleMoves me field = 
	[(x,y) | (start, (x,y), length) <- (getPossibleMovesWithEval me field)]

{- Returns the possible moves together with the start and length of the 
potential line that would be flipped. This information will be useful 
when deciding which move to choose and for the actual flipping -}
getPossibleMovesWithEval :: Piece -> GameField -> [(Pos, Pos, Int)]
getPossibleMovesWithEval me field = 
	let myPiecesPos =  [pos | (pos,piece) <- (pieces field), piece == me] in
	let directions = [(1,0), (1,1), (0,1), (-1,1), (-1,0), (-1,-1), (0,-1), (1,-1)] in
	concatMap getPossibleMovesInDirection 
		[(dir,pos) | pos <- myPiecesPos, dir <- directions]
	where
		getPossibleMovesInDirection (dir,(startX,startY)) = 			
			let startMoved = moveInDir dir (startX,startY) in
			let (resultX, resultY) = 
				until (not.itsHimAndInBounds) (moveInDir dir) startMoved in
			let length = max (abs (startX - resultX)) (abs (startY - resultY)) in
			if (isValidIndex (resultX, resultY) field) && 
				((get (resultX, resultY) field) == Nothing) && 
				(length > 1) then
				[((startX, startY), (resultX, resultY), length-1)]
			else []
			where				
				itsHimAndInBounds (x,y) = 			
					(isValidIndex (x,y) field) && 
					((get (x,y) field) `isJustThis` (switchPiece me))
					
minimax :: GameField -> Piece -> Int -> (Pos,Int)
minimax initialField initialPlayer allocatedTime = 
	let (pos,score) = minimax' initialField initialPlayer True 1000000 allocatedTime [] in 
	(pos,score)
	where
		minimax' :: GameField -> Piece -> Bool -> Int -> Int -> [Pos] -> (Pos,Int)
		minimax' field _ _ _ 0 plays = 
			{- trace (show (plays)) $ -}
			((-1,-1), eval field)
		minimax' field player seekMax previousBestOpponentResult allocatedTime plays = 
			let moves = getPossibleMovesWithEval player field in
			let opponent = switchPiece player in	
			if (length moves) == 0 then 
				if (length $ getPossibleMoves opponent field) == 0 then
					((-1,-1), (eval field) * 10000)
				else 
					minimax' field opponent (not seekMax) bestPossibleOpponentResult allocatedTime plays
			else 
				let moveAllocatedTime = allocatedTime `div` (length moves) in
				let heuristics =					
					sortBy (\group1 group2 -> flip compare (snd group1) (snd group2)) $
					map sumUpLengths $
					groupBy (\(_,end1,_) (_,end2,_) -> end1 == end2) moves in
				let minimaxEvaluated = 
					scanl (\(bestPos,bestScore) (pos,_) -> (
							let (hisPos, score) = 
								minimax' (updateField pos moves) opponent (not seekMax) bestScore moveAllocatedTime (pos:plays) in
							if (score `myCmpFunction` bestScore == GT) then (pos, score)
							else (bestPos,bestScore)
						)) ((-1,-1),bestPossibleOpponentResult) heuristics in
				let alphaBetaPrunned = 
					takeWhilePlusOne (\(pos,score) -> 
							score `myCmpFunction` previousBestOpponentResult == LT) 
							minimaxEvaluated in
							-- in the seekMax case:
							-- 	take until my best score is lower than his best score in 
							--  the previous recursion level, because then it's still change 
							--  that the result in the recursion level will be chosen as 
							--  a minimum in the previous recursion level.
				last alphaBetaPrunned
			where
				bestPossibleOpponentResult :: Int
				bestPossibleOpponentResult = if seekMax then -100000 else 100000

				myCmpFunction :: (Int -> Int -> Ordering)
				myCmpFunction = if seekMax then compare else (flip compare)
				
				sumUpLengths :: [(Pos,Pos,Int)] -> (Pos,Int)
				sumUpLengths group = 
						let (_,end,_) = (head group) in
						(end, sum [len | (_,_,len) <- group])		

				updateField :: Pos -> [(Pos,Pos,Int)] -> GameField		
				updateField pos moves = 
					last $ flipLines pos moves $
					push pos player field						

				takeWhilePlusOne :: (a -> Bool) -> [a] -> [a]
				takeWhilePlusOne func [] = []
				takeWhilePlusOne func (x:xs) = 
					if func x then (x:takeWhilePlusOne func xs)
					else [x]
		
		eval :: GameField -> Int
		eval field = 
			let him = switchPiece initialPlayer in
			let hisPiecesCount = sum $ map scorePos $
				filter ((him==).snd) (pieces field) in
			let myPiecesCount = sum $ map scorePos $ 
				filter ((initialPlayer==).snd) (pieces field) in
			let myMovesCount = length $ getPossibleMoves initialPlayer field in
			let hisMovesCount = length $ getPossibleMoves him field in
			if (hisMovesCount == 0) && (myMovesCount == 0) then ((myPiecesCount - hisPiecesCount) * 100000)
			else (myPiecesCount - hisPiecesCount) + (myMovesCount - hisMovesCount)
			where
				scorePos ((x,y),_) = (sideMultiplicator x (width field)) * (sideMultiplicator y (height field))
				sideMultiplicator coord size = 
					if (coord == 0) || (coord == size) then 2 else 1