-- ACM Pacific NW Region Programming Contest, 11 November 2000 -- Problem D, Poker Solitarie -- Sergio Antoy -- Wed Nov 14 16:37:08 PST 2001 -- updated: Mon Sep 23 15:22:15 PDT 2002 import SetRBT groups = [[ 0, 1, 2, 3, 4] ,[ 5, 6, 7, 8, 9] ,[10,11,12,13,14] ,[15,16,17,18,19] ,[20,21,22,23,24] ,[ 0, 5,10,15,20] ,[ 1, 6,11,16,21] ,[ 2, 7,12,17,22] ,[ 3, 8,13,18,23] ,[ 4, 9,14,19,24] ,[ 0, 6,12,18,24] ,[ 4, 8,12,16,20] ] combinations = [(straight_flush,50) ,(four,25) ,(full,12) ,(flush,10) ,(straight,7) ,(three,5) ,(two_pairs,3) ,(pair,1) ] rank 'A' = 0 rank 'K' = 1 rank 'Q' = 2 rank 'J' = 3 rank 'T' = 4 rank '9' = 5 rank '8' = 6 rank '7' = 7 rank '6' = 8 rank '5' = 9 rank '4' = 10 rank '3' = 11 rank '2' = 12 pair [[a1,_],[a2,_],[a3,_],[a4,_],[a5,_]] = a1==a2 || a2==a3 || a3==a4 || a4==a5 two_pairs [[a1,_],[a2,_],[a3,_],[a4,_],[a5,_]] = a1==a2 && a3==a4 || a1==a2 && a4==a5 || a2==a3 && a4==a5 three [[a1,_],[a2,_],[a3,_],[a4,_],[a5,_]] = a1==a2 && a2==a3 || a2==a3 && a3==a4 || a3==a4 && a4==a5 four [[a1,_],[a2,_],[a3,_],[a4,_],[a5,_]] = a1==a2 && a2==a3 && a3==a4 || a2==a3 && a3==a4 && a4==a5 straight p = consecutive (map (\[x,_] -> rank x) p) where consecutive [_] = True consecutive (a:b:c) = a+1==b && consecutive (b:c) flush [[_,x1],[_,x2],[_,x3],[_,x4],[_,x5]] = x1==x2 && x2==x3 && x3==x4 && x4==x5 full [[a1,_],[a2,_],[a3,_],[a4,_],[a5,_]] = a1==a2 && a3==a4 && a4==a5 || a1==a2 && a2==a3 && a4==a5 straight_flush p = straight p && flush p indices = [(i,j) | i <- [0..23], j <- [i+1..24]] score p = score1 groups where score1 [] = 0 score1 (g:gs) = score2 combinations + score1 gs where pg = sort (map (\x -> p !! x) (map (\y -> g !! y) [0..4])) sort = sortRBT (\[r,_] [s,_] -> rank r < rank s) score2 [] = 0 score2 ((c,v):cs) = if (c pg) then v else score2 cs maximize (p,sp) n = if f==p then (n,sp) else maximize (f,sf) (n+1) where (f,sf) = best indices (p,sp) best [] (q,sq) = (q,sq) best ((i,j):rest) (q,sq) = best rest if sr > sq then (r,sr) else (q,sq) where sr = score r r = swap () swap () | p =:= x++ki:y++kj:z &> i =:= length x &> j =:= length y+i+1 = x++kj:y++ki:z where x,y,z,ki,kj free doOne p = putStrLn ("Initial score = " ++ show initial) >> putStrLn ("Steps = " ++ show steps) >> putStrLn ("Final score = " ++ show final) >> putStrLn ("") >> return () where initial = score p (steps,final) = maximize (p,initial) 0 doAll t | head (head t) == '0' = return () | otherwise = doOne grid >> doAll rest where (grid,rest) = splitAt 25 t main = do input <- readFile "d.dat" doSolve (input=:=input) doAll (words input) -- end of program