Haskell, Score: 4.98M, 7564 Bytes
{-# LANGUAGE BangPatterns #-}
import Control.Concurrent.Async (race)
import Control.Concurrent.Async.Extra (sequenceConcurrently)
import qualified Data.Vector as V
import qualified Data.List as L
import qualified Data.IntSet as S
type Deck = String -- a line of the input, s.th. like
-- JD 2D 9H JC 5D 7H 7C...
type Card = (Int , Int) -- (Suit, Rank)
type Cascade = [Card] -- bottom up, i.e. head is the accessible card
type Board = V.Vector Cascade -- the whole Board: 16 lots of cascades
-- 0..7:tableau, 8..11:cells, 12..15:foundation
type Move = (Int , Int) -- 'from' and 'to' board index
type Game = (Board, [Move]) -- a Board and the Moves to get there
type Strategy = Int
idxTbl, idxFnd, idxTblR, idxFrom :: [Int]
idxTbl = [ 0.. 7] -- indices of tableau cascades
idxTblR = [7,6..0] -- indices of tableau in reverse order
idxFnd = [12..15] -- indices of foundations
idxFrom = [ 0..11] -- all indices where a card can be moved from
(@@) :: Board -> Int -> Cascade -- return cascade at index i
(@@) = (V.!)
(@!) :: Board -> Int -> Int -- return the rank of the top card at index i
brd @! i = snd $ head $ brd@@i
(//) :: Board -> [(Int, Cascade)] -> Board
(//) = (V.//) -- update from Data.Vector
solved :: Board -> Bool
solved brd = all ((==13).(brd@!)) idxFnd
--
--
--
main :: IO ()
main = print . sum =<< mapM solveDeck . lines =<< getContents
-- applies different strategies and hash functions to a given deck
-- does all the concurreny stuff
solveDeck :: Deck -> IO Int
solveDeck deck = do
putStrLn $ "Playing Deck: " ++ deck
mvs <- sequenceConcurrently -- try fast hash funtions concurrently
[dfs hsh S.empty s startGame | hsh<-[hashCLS, hashCL], s<-[1..4]]
let scores = [(length m, reverse m) | m <- mvs, not $ null m]
if null scores
then do -- unsolvable by fast hash functions, retry with slow hash function
mvs2 <- race' (race' (dfs hashC S.empty 1 startGame)
(dfs hashC S.empty 4 startGame))
(race' (dfs hashC S.empty 2 startGame)
(dfs hashC S.empty 3 startGame))
let score2 = length mvs2
putStrLn $ "Solution: " ++ show (score2, reverse mvs2)
return score2
else do -- at least one slow hash function succeeded, return best result
let winner = minimum scores
putStrLn $ "Solution: " ++ show winner
return $ fst winner
where
!startGame = [(deal deck, [])]
race' one two = race one two >>= either return return
-- depth first search with a given strategy and hash function
dfs :: (Board -> Int) -> S.IntSet -> Strategy -> [Game] -> IO [Move]
dfs _ _ _ [] = return []
dfs hashFn seen strat ((brd,mvs):games)
| S.member hBrd seen = dfs hashFn seen strat games --skip board if seen before
| solved brd = return mvs --solution found
| otherwise = dfs hashFn (S.insert hBrd seen) strat (newGames++games)
--descend the search space
where
hBrd = hashFn brd
newGames = nextGames mvs brd strat
-- one step in search
nextGames :: [Move] -> Board -> Strategy -> [Game]
nextGames moves brd strategy
| mv:_ <- autoMoves = doAuto mv
| otherwise = checkMoves $ allMoves strategy
where
-- all possible from/to combinations except between freecells and only to
-- first empty freecell. Based on strategy.
allMoves 1 = [(f,t) | f<-fList, t<-tList idxTbl, f<8||f>11||t<8||t>11]
allMoves 2 = [(f,t) | f<-fList, t<-tList idxTblR, f<8||f>11||t<8||t>11]
allMoves 3 = [(f,t) | t<-tList idxTbl, f<-fList, f<8||f>11||t<8||t>11]
allMoves 4 = [(f,t) | t<-tList idxTblR, f<-fList, f<8||f>11||t<8||t>11]
allMoves _ = error "allMoves: strategy out of range"
-- "from" indices are always ordered by minimum rank in respective cascade
fList = L.sortOn (minimum.map snd.(brd@@)) $ filter (not.null.(brd@@)) idxFrom
-- order of "to" indices is foundation before freecell before tableau
-- * only tableau is subject to strategy
-- * only first empty freecell (if any)
-- * foundation is "12" for all suits, we'll unravel that later
tList idxs
| null $ brd@@ 8 = 12: 8:idxs
| null $ brd@@ 9 = 12: 9:idxs
| null $ brd@@10 = 12:10:idxs
| null $ brd@@11 = 12:11:idxs
| otherwise = 12: idxs
-- checks which moves from 'allMoves' are actually legal and executes
-- them returning a list of games
checkMoves [] = []
checkMoves (mv@(f,t):mvs)
| t == 12 = if fitsFnd then doFnd else checkRest -- to foundation
| t < 8 = if fitsTbl then doTbl else checkRest -- to tableau
| otherwise = doCell -- to cell (alway empty)
where
!cscdT = brd@@t
!cscdF = brd@@f
!cardF@(suitF,rankF) = head cscdF
(suitT,rankT) = head cscdT
fitsTbl = null cscdT || rankT==rankF+1 && odd (suitF+suitT)
fitsFnd = rankF-1 == brd@!(12+suitF)
doTbl = (brd // [(t, cardF:cscdT), (f, tail cscdF)], mv:moves) : checkRest
doCell = (brd // [(t, [cardF]), (f, tail cscdF)], mv:moves) : checkRest
doFnd = (brd // [(t+suitF, [cardF]),(f, tail cscdF)], (f,t+suitF):moves)
: checkRest
checkRest = checkMoves mvs
-- a list of all greedy automoves
autoMoves =
[(f,12+s) | f <- idxFrom, -- keep all 'from' indices
let cascade = brd@@f,
not $ null cascade, -- if there's a card in the cascade
let (s,r) = head cascade,
r-1 == brd@!(12+s), -- and it fits on its foundation
let (j,k) = if even s then (13,15) else (12,14),
r-4 <= min(brd@!j)(brd@!k) ] -- and it's not too greedy
doAuto mv@(f,t)
| fCrd:fCrds <- brd@@f = [(brd // [(t,[fCrd]),(f,fCrds)], mv:moves)]
| otherwise = error "nextGames: automove from empty cascade"
--
-- parsing and dealing decks
--
deal :: Deck -> Board
deal = foldl putCard emptyBoard . zip (cycle idxTbl) . parse
emptyBoard :: Board -- foundation is initialised with dummy cards
emptyBoard = -- of rank 0, so that aces fit on them nicely
foldl (\b i -> putCard b (i+12, (i,0))) (V.replicate 16 []) [0..3]
putCard :: Board -> (Int,Card) -> Board
putCard brd (i,crd) = brd // [(i, crd : brd@@i)]
parse :: Deck -> [Card]
parse [] = []
parse (' ':cs) = parse cs
parse ('1':'0':s:cs) = (chrToSuit s , 10) : parse cs
parse (r:s:cs) | Just i <- L.elemIndex r " A23456789 JQK"
= (chrToSuit s, i) : parse cs
parse _ = error "parse: invalid deck"
chrToSuit :: Char -> Int -- parity important: reds are even, blacks odd
chrToSuit c | Just i <- L.elemIndex c "DSHC" = i
chrToSuit _ = error "chrToSuit: invalid char"
--
-- hash functions
--
hashCLS, hashCL, hashC :: Board -> Int
hashCLS brd = foldl (\h r -> h*16+r) c $ map (brd@!) idxFnd
where c = foldl (\h l -> h*32+l) 0 $ L.sort $ map (length.(brd@@)) idxTbl
hashCL brd = foldl (\h r -> h*16+r) c $ map (brd@!) idxFnd
where c = foldl (\h l -> h*32+l) 0 $ map (length.(brd@@)) idxTbl
hashC brd = foldl (\h r -> h*16+r) c $ map (brd@!) idxFnd
where c = foldl (\h s->h*26633+s) 0 $ L.sort $ map (hCscd.(brd@@)) idxTbl
hCscd cList = foldl (\v (s,r) -> (v*26633+s)*94291+r) 0 cList
The list of games is read via stdin. For each game the output is a pair of the number of moves and a list of moves as (from,to) pairs, where both 'from' and 'to' are indices of board positions. 0 to 7 are the eight cascades, 8 to 11 the four free cells and 12 to 15 the four foundations. E.g.
Playing Deck: KS 8S 3C 9D QS 4D JD QH 5C 10H 5D 10C 4H 3D 7H AD KC 6S 2S 8D AH 7C QD 6C 7S KH 8C 6H 2C 9C JH KD 4S 5S AC 10S JS 3S 9S 5H AS 4C 8H QC 6D 2H JC 10D 7D 2D 3H 9H
Solution: (85,[(0,8),(0,13),(2,9),(2,10),(2,15),(4,11),(7,6),(2,3),(2,13),(9,0),(4,9),(4,15),(4,14),(5,14),(0,14),(4,14),(5,13),(0,13),(7,14),(5,6),(11,5),(1,11),(5,0),(1,2),(0,5),(1,13),(5,0),(8,3),(7,8),(7,3),(7,12),(11,12),(2,11),(2,3),(2,15),(11,15),(5,11),(5,12),(5,12),(3,12),(0,12),(0,5),(0,2),(0,15),(3,15),(3,12),(11,15),(3,15),(6,15),(1,11),(1,13),(5,13),(3,5),(9,7),(3,9),(6,7),(1,6),(1,13),(3,1),(3,14),(3,12),(3,15),(3,12),(7,12),(6,7),(6,15),(6,13),(1,13),(6,4),(6,3),(6,14),(6,12),(3,12),(8,12),(10,14),(5,14),(7,14),(4,14),(7,13),(4,13),(0,13),(7,14),(9,15),(2,15),(11,14)])
At the end the total number of moves is printed.
How it works: The basic approach is a depth first search. As the quality of the search (both number of moves and search time) heavily depends on the search order, I try several orders concurrently and pick the result that finishes first:
That's four different orders (or strategies as I call them) in combination. Source order is the same for all strategies: sorted by minimum rank of all cards in the respective cascade/freecell. There's also autoplay, i.e. if a card can safely be placed in the foundation it's the only move in this situation. It turns out that a greedy autoplay leads to slightly better results, so I autoplay up to two additional ranks (e.g. autoplay 8s even if 5s of opposite color are still around).
However, all this is not good enough (5 games do not finish within reasonable time; about 14.7M moves for the rest), but I had a lucky find: somehow you have to keep track of the boards visited so far to prevent infinite loops during the search. The above method uses a hash which is calculated by rolling through the cascades and including suit and rank of all the cards along the way. Now we are just hashing the length of each cascade plus the top foundation cards (i.e. two boards result in the same hash if (and only if) the foundations are equal and all cascades in order have pairwise the same length). Yes, we do get a lot of collisions but they restrict the search space at pretty good spots and lead to far fewer moves in far less time. In fact, the search is so fast that we can afford to finish all four strategies and pick the best result. A similar hash function where for collision the matching length of a cascade can be anywhere in the tableau and not necessarily at the same index produces even better results - at least on average. Now we can try 8 variants (2 fast hash function with 4 strategies each) and pick the best result. Note: not all variants can solve every game but just one success is enough to get a result. There are 11 games (including the unsolvable #11982) which none of the variants can solve. In these cases I switch back to the slow hash function and pick the fastest result.
Using 4 cores on my laptop this solves all games in about 1.5h and a total of 4.98M moves.
Remarks
- The total number of moves can vary by a few hundred, because the result of the games with the slow hash function depends on how the OS assigns CPU time to the strategies and in different a run a different strategy might finish first. But that's just for 10 games.
- If I let all 12 variants (3 hash functions with 4 strategies each) race agains each other and pick the fastest result I get 7.25M moves in 250 sec.
- The source code is not golfed at all. Removing unnecessary things like comments, types, type annotations, whitespace, error handling and switching to single letter names easily brings the byte count to a third and then we can still apply the usual golfing tricks.
