Created
August 2, 2015 20:15
-
-
Save caldwell/e7445bc9f66c9d7b2ac5 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- Ted Wilson | |
-- August 2015 | |
import Data.Function (on) | |
import Data.List | |
import System.IO | |
import System.Random (randomRIO) | |
type Card = (Int, Char) | |
type Deck = [Card] | |
type Foundations = [Card] | |
type Stack = (Int, [Card]) | |
type Stacks = [Stack] | |
data From = FromStack Int Int | FromDeck | Rotate deriving ( Eq, Show) | |
data To = ToStack Int | ToFoundation Int | Rotate' deriving ( Eq, Show) | |
data Colors = Red | Black deriving (Eq, Show) | |
type Move = (From, To) | |
data Game = Game { | |
moves::[Move], | |
stacks::Stacks, | |
foundations::Foundations, | |
deck::Deck, | |
stats::[String]} | |
---FIND MOVES---------------------------------------------------------------------- | |
allMovesFromStacksToFoundations stacks foundations = | |
concat $ map (\x-> stackToFoundation stacks x foundations) $ range stacks | |
stackToFoundation stacks stack foundations = | |
if null which then [] else [(FromStack stack 0, ToFoundation (head which))] | |
where | |
card = s2C stacks stack 0 | |
which = filter (\x-> | |
fst card == (fst $ foundations!!x)+1 && | |
snd card == (snd $ foundations!!x)) | |
$ range foundations | |
deckToFoundation deck foundations = | |
if null which then [] else [(FromDeck, ToFoundation (head which))] | |
where | |
which = if null deck then [] | |
else filter (\x-> | |
(fst $ head deck) == (fst $ foundations!!x)+1 && | |
(snd $ head deck) == (snd $ foundations!!x)) | |
$ range foundations | |
findAllMoves (Game _ stacks foundations deck _)= | |
concat [ | |
findAllStackMoves stacks, | |
findMovesFromDeck stacks deck, | |
allMovesFromStacksToFoundations stacks foundations, | |
deckToFoundation deck foundations, | |
if not $ null deck then [(Rotate, Rotate')] else [] | |
] | |
findMovesForCard thecard@(FromStack stack position) stacks = | |
map (\x-> (thecard, (ToStack x))) elibibleStacks | |
where | |
elibibleStacks = filter (\x-> x /= stack && | |
canBeStackedOn | |
(s2C stacks stack position) | |
(s2C stacks x 0)) | |
$ range stacks | |
findEmptyStacks stacks = | |
filter (\x-> null $ snd (stacks!!x)) $ range stacks | |
findMovesFromDeck stacks deck = | |
if null deck then [] else | |
if (fst $ head deck) == 12 then [(FromDeck, ToStack to)| to <- findEmptyStacks stacks] | |
else map (\x-> (FromDeck, ToStack x)) eligibleStacks | |
where | |
eligibleStacks = | |
filter (\x-> canBeStackedOn (head deck) (s2C stacks x 0)) | |
$ range stacks | |
getVisiblesInStacks stacks = | |
concat $ map (\x-> getVisiblesInStack x (stacks!!x)) $ range stacks | |
separateKings visibles stacks = | |
foldr (\m@(FromStack stack x) (yes, no) -> if fst (s2C stacks stack x) == 12 | |
then (m:yes, no) else (yes, m:no)) ([],[]) visibles | |
findAllStackMoves stacks = | |
kingMoves ++ nonKingMoves | |
where | |
nonKingMoves = concat $ map (\x-> findMovesForCard x stacks) nonkings | |
kingMoves = [(from, ToStack to) | from<- kings, to<-emptystacks] | |
visibles = getVisiblesInStacks stacks | |
(kings, nonkings) = separateKings visibles stacks | |
emptystacks = findEmptyStacks stacks | |
getVisiblesInStack n stack = | |
map (\(no, card) -> (FromStack n no)) $ | |
zip [0..](take (fst stack) (snd stack)) | |
counterMove (FromStack stk pos, ToStack stk') = (FromStack stk' pos, ToStack stk) | |
canBeStackedOn::Card->Card->Bool | |
canBeStackedOn card1 card2 = | |
if (fst card1) == (fst card2) -1 | |
then card1 `oppositeColor`card2 | |
else False | |
oppositeColor card1 card2 = color card1 /= color card2 | |
color card = case (snd card) of 'D' -> Red; 'H' -> Red; _ -> Black | |
----EXECUTE MOVES------------------------------------------------------------------------- | |
rotateGame game = game {deck = rotateDeck $ deck game, moves = (Rotate, Rotate'):(moves game)} | |
rotateDeck [] = [] | |
rotateDeck [a] = [a] | |
rotateDeck (a:rest) = rest ++ [a] | |
won game = foundations game == [(12, 'H'),(12, 'c'),(12, 'D'),(12, 's')] | |
make1Move (Rotate, Rotate') game = rotateGame game | |
make1Move (from, to) game = | |
let (cards, game') = performFrom from game in | |
performTo cards to game' | |
performTo cards (ToStack no) game = game { stacks=newstcks} | |
where | |
oldstacks = stacks game | |
newstcks = replaceIth oldstacks no | |
(length cards + (fst $ oldstacks!!no), cards ++ (snd $ oldstacks!!no)) | |
performTo cards (ToFoundation no) game = game { foundations = newfoundations} | |
where | |
oldfoundations = foundations game | |
newfoundations = replaceIth oldfoundations no (head cards) | |
performFrom (FromStack no pos) game = (cards, game') | |
where | |
stcks = stacks game | |
game' = game {stacks = newstacks'} | |
cards = take (pos+1) $ snd $ stcks!!no | |
newstacks' = diminishStacks stcks no pos | |
performFrom (FromDeck) game = (newcards, game') | |
where | |
newcards = [head $ deck game] | |
game' = game {deck = tail $ deck game} | |
diminishStacks stacks no pos = | |
if lim < pos+1 then error "diminisherror" | |
else replaceIth stacks no (newlimit, newstack) | |
where | |
(lim, stks) = stacks!!no | |
newstack = drop (pos+1) stks | |
reducedVisibility = lim - (pos+1) | |
newlimit = if reducedVisibility < 1 && (length newstack) > 0 then 1 else reducedVisibility | |
hiddenInStacks stacks = foldr (\x acc -> acc+ (hiddenInStack x)) 0 stacks | |
hiddenInStack (n, stack) = length stack - n | |
addFoundations found = 4 + foldr (\x acc-> (fst x) + acc) 0 found | |
----STRATEGY-------------------------------------------------------------------------- | |
-- use this to govern building down stacks. | |
isUpStreamFrom::Card->Card->Bool | |
isUpStreamFrom a b = | |
(fst a > fst b) && | |
if (oppositeColor a b) then odd $ fst a + fst b else even $ fst a + fst b | |
isANewMove::Move->Game->Bool | |
isANewMove move@(FromStack a b, ToStack _) game = | |
(not $ move `elem` (moves game)) || ((FromStack a b) `elem` (getAllTargetCards game)) | |
isANewMove _ _ = True | |
willPopCards::[Move]->Game->[Move] | |
willPopCards moves game = | |
filter (\(from, to) -> from `elem` alltargetcards) moves | |
where alltargetcards = getAllTargetCards game | |
isDeckCardUpStreamOfATargetCard game = | |
any (isUpStreamFrom dc) targetcards | |
where | |
targetcards = map (\x-> from2Card x (stacks game)) $ getAllTargetCards game | |
dc = head (deck game) | |
allFroms stcks = [(FromStack x y) | x<- range stcks, y<- range $ stcks!!x] | |
allVisibleFroms stcks = [(FromStack x y) | x<- range stcks, y<- range $ stcks!!x] | |
lastVisibleFroms stcks = filter (\(FromStack _ b) -> b>=0) | |
[(FromStack x (fst (stcks!!x)-1)) | x<- range stcks] | |
getAllTargetCards game = filter (isATargetCard game) $ lastVisibleFroms (stacks game) | |
isABottomCard (FromStack a b) game = | |
b+1 == length ( snd ((stacks game)!!a)) | |
isALastVisibleCard (FromStack a b) game = | |
b+1 == (fst ((stacks game)!!a)) | |
isAKing (FromStack a b) game = | |
fst (s2C (stacks game) a b) == 12 | |
isAKingOnBottom card game = | |
isAKing card game && isABottomCard card game | |
isATargetCard game card = (not $ isAKingOnBottom card game) | |
evalmove::Move->Game->[Move]->[Move]->(Int, Move) | |
evalmove move@(FromStack a b, ToFoundation _) game _ targetmoves = | |
if any (isUpStreamFrom (from2Card (FromStack a b) stks)) | |
(map ((\x-> from2Card x stks).fst) targetmoves) then (40, move) else (62, move) | |
where stks = stacks game | |
evalmove move@(fromDeck, ToFoundation _) game _ targetmoves = | |
if any (isUpStreamFrom (head $ deck game)) | |
(map ((\x-> from2Card x stks).fst) targetmoves) then (40, move) else (62, move) | |
where stks = stacks game | |
evalmove move@(FromDeck, _) game _ pres = (evalDeckCardMove game (map fst pres), move) | |
evalmove move game newMoves presentPops = | |
if move == (Rotate, Rotate') then (15, move) else (pres+new+useless, move) | |
where | |
pres = if move `elem` presentPops then 33 else 0 | |
new = if move `elem` newMoves then 12 else -42 | |
useless = if badMove move game then -35 else 0 | |
evalDeckCardMove::Game-> [From]->Int | |
evalDeckCardMove game targetFroms = | |
if any (\x-> canBeStackedOn x dc) targetCards then 29 | |
else | |
if isDeckCardUpStreamOfATargetCard game then | |
25 | |
else | |
if fst dc > 6 then 17 | |
else 0 | |
where | |
targetCards = map (\x-> from2Card x (stacks game)) targetFroms | |
dc = head (deck game) | |
badMove ((FromStack no pos), _) game = | |
(pos+1) >= (length $ snd $ stks!!no) && (fst (s2C stks no pos) == 12) | |
where stks = stacks game | |
badMove _ _ = False | |
evalmoves moves game = | |
reverse$ sortBy (compare `on` fst) $ | |
map (\x-> evalmove x game newMoves presentPops) moves | |
where | |
newMoves = filter (\x-> isANewMove x game) moves | |
presentPops = willPopCards moves game | |
---GENERATE GAME-------------------------------------------------------------------------- | |
play1000 = makeGame1000games 1000 0 | |
makeGame1000games n res= do | |
deckR <- quickshuffle deckUn | |
let game = Game [] thestacks' foundationStart thedeck [] | |
where | |
(thestacks, thedeck) = deal deckR | |
thestacks' = zip (repeat 1) thestacks | |
let outcome = justPlayGame game | |
let inc = if (take 7) outcome == "Looping" then 0 else 1 | |
putStrLn $ (show n) ++ outcome | |
if n>0 then makeGame1000games (n-1) (res+inc) | |
else putStrLn $ show res | |
deckUn = [(n,s) | n<-[0..12], s<-"sHcD"] | |
deal deck = | |
foldr (\x acc -> (take x (snd acc):(fst acc), drop x $ snd acc)) | |
([], deck) [1..7] | |
foundationStart = [(-1, 'H'),(-1, 'c'),(-1, 'D'),(-1, 's')] | |
main = makeGame 0 | |
makeGame all = do | |
deckR <- quickshuffle deckUn | |
let game = Game [] thestacks' foundationStart thedeck [] | |
where | |
(thestacks, thedeck) = deal deckR | |
thestacks' = zip (repeat 1) thestacks | |
if all == 0 then playGame game | |
else playoutGame [game] | |
makeGameToFile filename = do | |
handle <- openFile filename WriteMode | |
deckR <- quickshuffle deckUn | |
let game = Game [] thestacks' foundationStart thedeck [] | |
where | |
(thestacks, thedeck) = deal deckR | |
thestacks' = zip (repeat 1) thestacks | |
playGameToFile game handle | |
hClose handle | |
----PLAY GAME---------------------------------------------------------------------- | |
playoutGame [] = putStrLn "FAILED" | |
playoutGame (game:rest) = | |
if won game then putStrLn "GAME WON" | |
else do | |
putStrLn $ show $ length rest | |
let newstat = diagnostic game | |
let game' = game {stats = newstat:(stats game)} | |
let newmoves = findAllMoves game' | |
let newmoves'' = evalmoves newmoves game' | |
let newmoves' = map snd $ filter (\x-> (fst x) > -30) newmoves'' | |
let gameovermessage = gameOver game newmoves'' | |
if gameovermessage /= "" then do | |
putStrLn gameovermessage | |
playoutGame rest | |
else do | |
let newgames = map (\x->make1Move x (game {moves = x:(moves game)})) | |
newmoves' | |
playoutGame $ (newgames)++rest | |
playGameToFile game handle = do | |
hPutStrLn handle $ printGame' game | |
if (length (moves game)) >(length (deck game) + 10) -- outmoded; replace with gameOver | |
&& all (== (Rotate, Rotate')) (take (length (deck game) + 10) $ moves game) | |
then do | |
hPutStrLn handle $ "Looping: " ++ diagnostic game | |
putStrLn $ "Looping: " ++ diagnostic game | |
else do | |
if won game then do | |
hPutStrLn handle "GAME WON" | |
putStrLn "GAME WON" | |
else do | |
let newstat = diagnostic game | |
let game' = game {stats = newstat:(stats game)} | |
let newmoves = findAllMoves game' | |
let newmoves' = evalmoves newmoves game' | |
--hPutStrLn handle $ show newmoves' | |
hPutStrLn handle $ printListEvaledMoves newmoves' | |
let newmoves'' = map snd newmoves' | |
playGameToFile (make1Move (head newmoves'') $ | |
game' { moves = (head newmoves''):(moves game') }) | |
handle | |
playGameN game n= do | |
printGame game | |
if gameovermessage /= "" then putStrLn gameovermessage | |
else do | |
putStrLn $ printListEvaledMoves newmoves'' | |
playGameN (make1Move (head newmoves') $ | |
game' { moves = (head newmoves'):(moves game') }) (n-1) | |
where | |
gameovermessage = gameOver game newmoves'' | |
newstat = diagnostic game | |
game' = game {stats = newstat:(stats game)} | |
newmoves = findAllMoves game' | |
newmoves'' = evalmoves newmoves game' | |
newmoves' = map snd newmoves'' | |
gameOver game newmoves | |
|(length (moves game)) >(length (deck game) + 10) | |
&& all (== (Rotate, Rotate')) (take (length (deck game) + 10) $ moves game) = | |
"Looping on deck: " ++ diagnostic game | |
|(length (moves game)) > 400 = "Looping 400 moves" ++ diagnostic game | |
|won game = "GAME WON: " ++ diagnostic game | |
|null newmoves = "Looping on empty moves: " ++ diagnostic game | |
|otherwise = "" | |
justPlayGame::Game->String | |
justPlayGame game = | |
if gameovermessage == "" then | |
justPlayGame | |
(make1Move (head newmoves') $ | |
game' { moves = (head newmoves'):(moves game') }) | |
else gameovermessage | |
where | |
gameovermessage = gameOver game newmoves'' | |
newstat = diagnostic game | |
game' = game {stats = newstat:(stats game)} | |
newmoves = findAllMoves game' | |
newmoves'' = filter (\x-> (fst x) > -75) $ evalmoves newmoves game' | |
newmoves' = map snd newmoves'' | |
playGame game = do | |
printGame game | |
let newstat = diagnostic game | |
let game' = game {stats = newstat:(stats game)} | |
let newmoves = findAllMoves game' | |
let newmoves'' = evalmoves newmoves game' | |
let gameovermessage = gameOver game newmoves'' | |
putStrLn $ printListEvaledMoves newmoves'' | |
let newmoves' = map snd newmoves'' | |
if gameovermessage /= "" then putStrLn gameovermessage | |
else playGame (make1Move (head newmoves') $ game' { moves = (head newmoves'):(moves game') }) | |
diagnostic game = "foundation " ++ (show found) ++ " hidden " ++ (show hidden) ++ " deck " ++ | |
decksize ++ " moves " ++ (show $ length $ moves game ) | |
where | |
found= addFoundations $ (foundations game) | |
hidden = hiddenInStacks (stacks game) | |
decksize = (show$length$ deck game) | |
--- INPUT-------------------------------------------------------------------------------------- | |
getGame file play = do | |
content <- readFile file | |
let thelines = map trimit $ filter notempty $ lines content | |
let game = parsegame (take 7 $ thelines) (thelines!!7)(thelines!!8) | |
case play of | |
0-> printGame game | |
_-> playGame game | |
notempty = any (\x -> not $ x `elem` " \t") | |
trimit = dropWhile (\x-> x `elem` " \t") | |
countVisible stck = | |
if cleanfront == "" then 0 | |
else bc 1 cleanfront | |
where | |
cleanfront = clean front | |
(front, back) = splitByBar "" stck | |
clean str = dropWhile (== ' ') $ reverse $ dropWhile (== ' ') $ reverse str | |
splitByBar acc (a:rest) = case a of | |
'|' -> (acc, rest) | |
_ -> splitByBar (acc ++ [a]) rest | |
bc n "" = n | |
bc n (a:rest) = case (a) of | |
' ' -> bc (n+1) $ dropWhile (==' ') rest | |
'|' -> n | |
_ -> bc n $ rest | |
replaceBarWithSpace ""="" | |
replaceBarWithSpace ('|':ys) = (' ':ys) | |
replaceBarWithSpace (x:ys) = x:(replaceBarWithSpace ys) | |
parseStack::String ->(Int, [(Int, Char)]) | |
parseStack stck = (lim, stck') | |
where | |
stacktrimmed = dropWhile (==' ') stck | |
lim = countVisible stacktrimmed | |
stck' = parsit $ replaceBarWithSpace stacktrimmed | |
parseStacks = map parseStack | |
parsit deck = map trans $ split $ dropWhile (==' ') deck | |
where | |
split "" = [] | |
split deck = (takeWhile (/=' ') deck):(split $ dropWhile (== ' ') $ dropWhile (/= ' ') deck) | |
trans ['0', x] = (0, x) | |
trans ['1', x] = (1, x) | |
trans ['2', x] = (2, x) | |
trans ['3', x] = (3, x) | |
trans ['4', x] = (4, x) | |
trans ['5', x] = (5, x) | |
trans ['6', x] = (6, x) | |
trans ['7', x] = (7, x) | |
trans ['8', x] = (8, x) | |
trans ['9', x] = (9, x) | |
trans('1':'0':x) = (10, head x) | |
trans('1':'1':x) = (11, head x) | |
trans('1':'2':x) = (12, head x) | |
trans('-':'1':x) = (-1, head x) | |
parsegameFromStart stcks deck = | |
Game [] stacks' [(-1, 'H'),(-1, 'c'),(-1, 'D'),(-1, 's')] deck' [] | |
where | |
stacks' = parseStacks stcks | |
deck' = parsit deck | |
parsegame stcks found deck= | |
Game [] stacks' found' deck' [] | |
where | |
stacks' = parseStacks stcks | |
deck' = parsit deck | |
found' = parsit found | |
-- Shuffle deck---found on web------------------------------------------------------------------------ | |
quickshuffle :: [a] -> IO [a] | |
quickshuffle [] = return [] | |
quickshuffle [x] = return [x] | |
quickshuffle xs = do | |
(ls, rs) <- partition' xs | |
sls <- quickshuffle ls | |
srs <- quickshuffle rs | |
return (sls ++ srs) | |
partition' :: [a] -> IO ([a], [a]) | |
partition' xs = do | |
let n = length xs | |
k <- randomRIO (1, n-1) | |
split n k ([], []) xs | |
where split n k (ls, rs) [] = return (ls, rs) | |
split n k (ls, rs) (x:xs) = do | |
p <- randomRIO (1, n) | |
if p <= k | |
then split (n - 1) (k - 1) (x:ls, rs) xs | |
else split (n - 1) k (ls, x:rs) xs | |
------OUTPUT------------------------------------------------------------------------------------------ | |
printGameInfo game = putStrLn $ (printrawstack $ foundations game) ++ "\t" ++ | |
(show $ length $ deck game) ++ "\t" ++ (show $ hiddenInStacks $ stacks game) | |
printGame' game = | |
mvs ++ "\n" ++ stcks ++ "\n " ++ found ++ "\n" ++ thedeck ++ "\n" | |
where | |
mvs = show $ length $ moves game | |
stcks = printstacks (stacks game) 0 | |
found = printrawstack $ foundations game | |
thedeck = printrawstack $ deck game | |
printGame game = do | |
putStrLn $ show $ length $ moves game | |
putStrLn $ printstacks (stacks game) 0 | |
putStrLn $ " " ++ (printrawstack $ foundations game) | |
putStrLn $ printrawstack $ deck game | |
putStrLn "" | |
printstacks [] _= "" | |
printstacks (a:rest) n = (show n) ++ " " ++ printstack a ++ "\n" ++ printstacks rest (n+1) | |
printstack(n, stack) = (printrawstack $ take n stack) ++ "|" ++ (printrawstack $ drop n stack) | |
printrawstack [] = "" | |
printrawstack [(n,s)] = ((show n) ++[s]) | |
printrawstack ((n,s):rest) = ((show n)++[s, ' ']) ++ (printrawstack rest) | |
printMove (FromStack a b, ToStack c) = | |
printFrom (FromStack a b) ++ "->" ++ show c | |
printMove (Rotate, Rotate') = "R" | |
printMove (FromDeck, ToStack n) = "D->" ++ show n | |
printMove (FromStack a b, ToFoundation _) = printFrom (FromStack a b) ++ "->F" | |
printMove (FromDeck, ToFoundation _) = "D->F" | |
printFrom (FromStack a b) = (show a) ++ "." ++ (show b) | |
printEvaledMove (n, move) = '<':(show n) ++ "> " ++ (printMove move) | |
printListEvaledMoves lis = foldr (\x acc-> (printEvaledMove x) ++ "\n" ++ acc) "" lis | |
-- Utils-------------------------------------------------------------------------------- | |
s2C stacks no pos = | |
if (length $ snd $ stacks!!no) < pos +1 then (44, 'x') | |
else (snd (stacks!!no))!!pos | |
from2Card (FromStack no pos) stacks = s2C stacks no pos | |
from2Card fr _ = error $ "from2card has been fed a bad arg" ++ (show fr) | |
range x = [0..length x-1] | |
replaceIth lis i new = take i lis ++ new:(drop (i+1) lis) | |
---SAMPLE GAMES------------------------------------------------------------- | |
tdeck = "3s 2h 12c 9d 4s 7s 11h 0d 8c 1d 10c 1c 5c 11c 3c 9s 5s 9c 10s 8h 7h 10d 5h 12h" | |
tst = ["9h|", | |
"0c|4s", | |
"4d|3h 0d", | |
"2d|12h 8s 3s", | |
"6s|5h 1d 1c 12c", | |
"3c|12s 3d 0s 12d 0h", | |
"8c|1h 5d 10h 11d 9d 11h"] | |
tgame = parsegameFromStart tst tdeck | |
stkerr = ["4c 5H 6c|", | |
"12c|", | |
"9H|10D 12s", | |
"3s 4D|0D", | |
"2c|5D 12H 11H", | |
"6D |1D 1H 5c 8c 10c", | |
"8D 9s 10H|7H 9D 11s 2H 3H 8H"] | |
founderr = "-1H -1c -1D 1s" | |
deckerr = "2D 0H 4H 0c 5s 10s 3c 11D 3D 2s 6s 8s 6H 9c 12D 7c 7s 11c 4s 7D 1c" | |
gamerr = parsegame stkerr founderr deckerr | |
popstacks = [ | |
"|", | |
"1c 2D 3c 4D 5s 6D 7c 8D 9c 10D 11s 12H|", | |
"6D|", | |
"1D 2c | 3D 4c 5D 6s 7H 8c 9D 10c 11H 12c", | |
"7s 8H 9s 10H 11c 12D|", | |
"4c 6c 7D 8s 9H 10s 11D 12s|", | |
"4H|0D"] | |
popfound = "2H 0c -1D 4s" | |
popdeck = "4H 6H 3s" | |
popgame = parsegame popstacks popfound popdeck | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment