kdpub.hs

-- 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