import GameController
import Game 
import Data.Maybe (fromJust)
import Data.Map (Map)
import Data.List (elem, elemIndex, sort)
import qualified Data.Map as Map
import Control.Parallel.Strategies (parMap, rpar)

{-

solver.hs
by Joe Huang

4995 Final Project

Descriptions:
The solver implements the Heineman’s Staged Deepening Heusirtic (HSDH) to
find a solution for a freecell game. HSDH first find all the states k steps 
away from the current one and rank them based on the heusirtic. The 
heusirtic checks the foundation's current cards and finds all the card that 
are supposed to be placed next. For those next cards, calculate how many 
cards are on top of them. The heusirtic mulplies that score by two if 
all freecell are used or any foundation cell is 0. Then, the best state are 
used for the next iteration until a solution is found.

References: 
FreeCell Solitaire Optimization: http://people.uncw.edu/tagliarinig/Courses/380/S2015%20papers%20and%20presentations/Freecell%20Opt-Beasley%20Brown/FreeCell_csc380.pdf

-}

boundedSearch :: GameStatus -> Int -> Map GameStatus Int ->[GameStatus]
boundedSearch (GameStatus game moves states) bound seenGS
    | bound == 0 = newGS
    | otherwise = concat $ (parMap rpar) (\x-> boundedSearch x (bound -1) newSeenGS) newGS
    where newGS = (parMap rpar) (\(_, status) -> status) $
                   filter (\(_, status)-> Map.notMember status seenGS) $ 
                   (parMap rpar) (\x -> makeMove (GameStatus game moves states) x) moves
          newSeenGS = Map.union seenGS $ Map.fromList ((parMap rpar) (\x->(x,1)) newGS)

-- Heineman’s Staged Deepening Heusirtic (HSDH), get the foundation score and multiple 
-- if no available freecell or empty 
hSDH :: [GameStatus] -> GameStatus
hSDH [] = error "Empty GameStatus List"
hSDH gss = snd 
           $ head
           $ sort 
           $ map (\(GameStatus (Game ccs fc fd) moves gs) ->
                   ((calculateAllFounScore fd ccs) * (penaltyScore fc fd), 
                    (GameStatus (Game ccs fc fd) moves gs))) 
             gss

-- given a freecell and a foundation, calculate the penalty score
penaltyScore :: Freecell -> Foundation -> Int 
penaltyScore (Freecell fc) (Foundation fd) =
    if (length fc >= 4 || elem 0 fd) then 2 else 1 

-- gievn a game, calculate the sum of all four foundation next card score
-- ex: calculateAllFounScore (Foundation [0,0,0,0]) (Cascades [Cascade [Card Ace Spade, Card Two Diamond], Cascade [Card Ace Diamond], Cascade [Card Ace Club], Cascade [Card Ace Heart]]) 
calculateAllFounScore :: Foundation -> Cascades -> Int 
calculateAllFounScore (Foundation fd) (Cascades ccs) = 
    sum $ map (\(Card r s) -> if (r == King) then 0 
                              else calculateFounScore (Card r s) (Cascades ccs))
          nextCards
    where nextCards = getFoundationNextCards (Foundation fd)

-- given a foundation and a cascades, find the cascade that holds the card and return 
-- the number of card on top of it
-- ex: calculateFounScore (Card Three Spade) (Cascades [Cascade [Card Ace Spade, Card Three Spade]])
calculateFounScore :: Card -> Cascades -> Int 
calculateFounScore _ (Cascades []) = error "Shouldn't happen given a valid game"
calculateFounScore card (Cascades ((Cascade cc):ccs)) = 
    if (elem card cc) then (length cc - fromJust (elemIndex card cc) - 1)
    else calculateFounScore card (Cascades ccs)
    
-- given a foundation, return a list of card one higher than the current one 
getFoundationNextCards :: Foundation -> [Card]
getFoundationNextCards (Foundation fd) = 
    joinCards suits ranks
    where suits = [minBound..maxBound::Suit]
          ranks = map (\x-> if x >= 13 then ([minBound..maxBound::Rank]) !! 12 
                            else ([minBound..maxBound::Rank]) !! x) fd

-- join a list of suits and ranks together as a list of cards 
joinCards :: [Suit] -> [Rank] -> [Card]
joinCards [] [] = []
joinCards [] (_:_) = error "joinCards: length not equal"
joinCards (_:_) [] = error "joinCards: length not equal"
joinCards (s:suits) (r:ranks) = (Card r s):(joinCards suits ranks)
                                         
-- the main funciton to run the solver
main :: IO ()
main = do putStrLn "Please enter a game number: "
          input <- getLine
          let gameNum = (read input :: Int)
          let game = start gameNum
          let (GameStatus _ _ states) = loop game
          print $ reverse states

-- the loop to keep running the solver until it is solved
loop :: GameStatus -> GameStatus 
loop (GameStatus oldGame oldMove oldState) = 
    if game == oldGame then error "Didn't improve...Something is wrong"
    else 
        if (isFinished game) then (GameStatus game move state) else loop (GameStatus game move state)
    where (GameStatus game move state) = hSDH $ boundedSearch (GameStatus oldGame oldMove oldState) 5 (Map.empty)