coins.hs

-- Two players. Six coins. Start with the coins arranged in a line on the
-- table, alternately heads-up and tails-up, so HTHTHT. One player is heads,
-- one tails. Players alternate moves. Your move is: take any consecutive 1,
-- 2, or 3 coins, and flip them over. So player 1 could decide to flip over
-- coins 2,3 and 4, leaving the line as HHTHHT. You may not flip exactly the
-- same set of coins as the previous player (and so you can't just reverse
-- their move). The goal is to have all the coins showing your side, so if the
-- coins show HHHHHH then the "heads" player wins.

import Control.Arrow ((&&&))
import Control.Monad ((<=<))
import Data.List (findIndices, group)
import Data.Maybe (catMaybes, isJust)
import qualified Data.Set as Set
import System.Environment (getArgs)

data Coin = Heads | Tails deriving (Show, Eq, Ord)

data Position = Position { coins :: [Coin], currentPlayer :: Coin, moveList :: [Int], seen :: Set.Set [Coin] } deriving (Show, Eq)


initialPosition :: Position
initialPosition = Position { coins = [Heads, Tails, Heads, Tails, Heads, Tails], currentPlayer = Heads, moveList = [], seen = Set.empty }

switchCoin :: Coin -> Coin
switchCoin Heads = Tails
switchCoin Tails = Heads


winner :: Position -> Maybe Coin
winner (Position { coins = x:xs }) = if all (x==) xs then Just x else Nothing
winner (Position { coins = _ }) = Nothing


winning :: Position -> Bool
winning = isJust . winner


groupRuns = map head . group

-- Doesn't check that integer is in range

flipCoins :: Int -> [Coin] -> [Coin]
flipCoins n cs = let (same, rest) = splitAt n cs
                     x:xs = rest
                     (toFlip, dontFlip) = span (x==) rest
                 in groupRuns $ same ++ (switchCoin (head toFlip)):dontFlip


forceTurn :: Position -> Int -> Position
-- This seems like quite verbose syntax (repeating position all the time)
forceTurn position n = Position { coins = flipCoins n (coins position),
                                  currentPlayer = switchCoin (currentPlayer position),
                                  moveList = n:(moveList position),
                                  seen = Set.insert (coins position) (seen position)
                                }


willRepeat Position { moveList = [] } _   = False
willRepeat Position { moveList = x:xs, seen = seen, coins = coins} n = n == x || Set.member (flipCoins n coins) seen


takeTurn :: Position -> Int -> Maybe Position
takeTurn position n =
    if willRepeat position n
    then Nothing
    else Just $ forceTurn position n


possibleMoves :: Position -> [Int]
possibleMoves p = findIndices (currentPlayer p /=) (coins p)

possibleNextTurns :: Position -> [Position]
possibleNextTurns p = catMaybes $ map (takeTurn p) $ possibleMoves p


afterTurns :: Position -> Int -> [Position]
afterTurns start n = return start >>= foldr (<=<) return (replicate n possibleNextTurns)

victories xs = [(w, reverse $ moveList position) | (Just w, position) <- zip (map winner xs) xs]


main :: IO ()
main = do
  args <- getArgs
  let maxMoves = read (head args) :: Int
  mapM_ (putStrLn . show) $ concatMap (victories . afterTurns initialPosition) [1..maxMoves]