From 0087090b75b346696fa95e2bd97db4fb766215c9 Mon Sep 17 00:00:00 2001 From: Lucian Mogosanu Date: Sun, 25 Aug 2013 21:24:57 +0300 Subject: [PATCH 1/1] initial commit About 10 hrs of coding. --- Command.hs | 56 +++++++++++++ Game.hs | 33 ++++++++ KlondikeByThrees.hs | 233 +++++++++++++++++++++++++++++++++++++++++++++++++++ PCards.hs | 120 ++++++++++++++++++++++++++ Util.hs | 14 ++++ 5 files changed, 456 insertions(+) create mode 100644 Command.hs create mode 100644 Game.hs create mode 100644 KlondikeByThrees.hs create mode 100644 PCards.hs create mode 100644 Util.hs diff --git a/Command.hs b/Command.hs new file mode 100644 index 0000000..fdc47b2 --- /dev/null +++ b/Command.hs @@ -0,0 +1,56 @@ +module Command (parseCommand, Command(..)) where + +import Text.Parsec + +import PCards +import KlondikeByThrees (Move(..), Location(..)) + +data Command = + HelpCmd + | PrintCmd + | MoveCmd { cmdMove :: Move } + | RestartCmd + | QuitCmd + | BadCmd { cmdError :: String } + deriving Show + +parseCommand :: String -> Command +parseCommand s = case parse cmd "Unknown command" s of + Right c -> c + Left e -> BadCmd $ show e + +cmd = do + result <- help <|> printt <|> quit <|> restart <|> move + eof + return result + +help = (char 'h' <|> char '?') >> return HelpCmd +printt = char 'p' >> return PrintCmd +quit = char 'q' >> return QuitCmd +restart = char 'r' >> return RestartCmd + +move = deal <|> specificMove +deal = char 'd' >> return (MoveCmd Deal) +specificMove = do + char 'm' + spaces + s <- location + spaces + d <- location + return (MoveCmd $ Move s d) + +location = waste <|> foundation <|> tableau <|> fail "Unknown location" +waste = char 'w' >> return WasteHead +foundation = char 'f' >> fmap FPile (sPile <|> hPile <|> dPile <|> cPile) + where + sPile = char 's' >> return Spades + hPile = char 'h' >> return Hearts + dPile = char 'd' >> return Diamonds + cPile = char 'c' >> return Clubs +tableau = do + char 't' <|> char 'p' + i <- fmap read digits + d <- try (char ',' >> digits >>= return . read) <|> return 0 + return $ TPile i d + +digits = digit `sepEndBy1` spaces diff --git a/Game.hs b/Game.hs new file mode 100644 index 0000000..e5ef99b --- /dev/null +++ b/Game.hs @@ -0,0 +1,33 @@ +module Main where + +import System.Exit (exitSuccess) +import Control.Monad.State +import Control.Monad.IO.Class (liftIO) + +import PCards +import KlondikeByThrees +import Command +import Util + +main :: IO () +main = void $ execStateT interactiveGame emptyKbt + +interactiveGame :: CardGameT IO () +interactiveGame = do + restart + forever $ do + s <- liftIO getLine' + case parseCommand s of + HelpCmd -> printIO "Unimplemented" + PrintCmd -> get >>= printIO . show + MoveCmd m -> execValidMove m >> get >>= printIO . show + RestartCmd -> restart + QuitCmd -> quit + BadCmd err -> printIO err + where + restart = do + deck <- liftIO shuffledDeck + put $ fromDeck deck + initGame + get >>= printIO . show + quit = liftIO exitSuccess diff --git a/KlondikeByThrees.hs b/KlondikeByThrees.hs new file mode 100644 index 0000000..123333b --- /dev/null +++ b/KlondikeByThrees.hs @@ -0,0 +1,233 @@ +module KlondikeByThrees where + +import Data.List (intercalate) +import Control.Monad.State + +import PCards +import Util + +data KBT = KBT + { talon :: [Card] + , waste :: [Card] + , foundation :: Foundation + , tableau :: Tableau + } + +data Foundation = Foundation + { fspades :: [Card] + , fhearts :: [Card] + , fdiamonds :: [Card] + , fclubs :: [Card] + } + +data HCard = HCard + { hcard :: Card + , hidden :: Bool + } + +type Tableau = [[HCard]] + +-- the game state is pretty complex, so we need to model card moves +-- from one pile to another +data Location = + TalonHead + | WasteHead + | FPile { fpile :: CardSuit } + | TPile { tpile :: Int, tdepth :: Int } + deriving (Show, Eq) + +data Move = + Deal + | Move + { moveFrom :: Location + , moveTo :: Location + } deriving (Show, Eq) + +type CardGameT m a = StateT KBT m a + +-- show only heads +showHead :: [Card] -> String +showHead p = if null p then "Empty" else (show . head) p + +showWaste :: [Card] -> String +showWaste p = intercalate ", " . map show $ take 3 p + +showTableau :: [HCard] -> String +showTableau p = "[" ++ + (intercalate ", " . map (show . hcard) . takeWhile (not . hidden)) p ++ "]" + +instance Show KBT where + show (KBT tl w f tb) = + "Waste: " ++ showWaste w ++ "\n" ++ + "Foundation: " ++ show f ++ "\n" ++ + "Tableau: " ++ (intercalate ", " . map showTableau) tb + +instance Show Foundation where + show (Foundation fs fh fd fc) = intercalate ", " . map showHead $ + [fs, fh, fd, fc] + +emptyKbt :: KBT +emptyKbt = KBT [] [] emptyFoundation emptyTableau + where + emptyFoundation = Foundation [] [] [] [] + +emptyTableau :: Tableau +emptyTableau = replicate 7 [] + +fromDeck :: Deck -> KBT +fromDeck deck = emptyKbt { talon = deck } + +initGame :: Monad m => CardGameT m () +initGame = do + mapM_ initPile [0..6] + execMove Deal + where + initPile i = do + replicateM_ (i + 1) . execMove $ Move TalonHead $ TPile i 0 + (KBT tl w f tb) <- get + put $ KBT tl w f $ hideT tb + +execValidMove :: (Monad m, MonadIO m) => Move -> CardGameT m () +execValidMove m = do + kbt <- get + if validMove m kbt then execMove m else printIO "Invalid move." + +-- Note: Deal can be implemented as a list of Moves +-- this is mostly for efficiency +execMove :: Monad m => Move -> CardGameT m () +execMove Deal = do + KBT tl w f tb <- get + -- redeal? + if null tl + then put $ KBT (reverse w) [] f tb + else mapM_ execMove $ replicate (min 3 $ length tl) $ Move TalonHead WasteHead +execMove (Move s d) = execFrom s >>= execTo d + +-- CardGame monad utility functions +execFrom :: Monad m => Location -> CardGameT m [Card] +execFrom l = do + s <- get + let (c, s') = takeFrom' l s + put s' + return c + +takeFrom :: Location -> KBT -> Maybe ([Card], KBT) +takeFrom l (KBT tl w f tb) = case l of + TalonHead -> if null tl + then Nothing else Just ([head tl], KBT (tail tl) w f tb) + WasteHead -> if null w + then Nothing else Just ([head w], KBT tl (tail w) f tb) + FPile s -> if nullF s f + then Nothing else Just ([headF s f], KBT tl w (tailF s f) tb) + TPile i d -> if i >= length tb || nullT i tb + then Nothing else Just (headT i d tb, KBT tl w f (tailT i d tb)) + +takeFrom' :: Location -> KBT -> ([Card], KBT) +takeFrom' l kbt = maybe (error "takeFrom': empty pile") id $ takeFrom l kbt + +execTo :: Monad m => Location -> [Card] -> CardGameT m () +execTo l cs = do + s <- get + put $ putTo l cs s + where + putTo l cs (KBT tl w f tb) = case l of + -- Note: we assume length cs == 1 for non-TPiles + TalonHead -> KBT (cs ++ tl) w f tb + WasteHead -> KBT tl (cs ++ w) f tb + FPile s -> KBT tl w (consF s cs f) tb + TPile i _ -> KBT tl w f (consT i cs tb) + +-- validity checks for Moves +validMove :: Move -> KBT -> Bool +validMove Deal _ = True +validMove (Move s d) kbt + | s == TalonHead || d == TalonHead = False + | d == WasteHead = False + | msc == Nothing = False + | otherwise = case d of + FPile _ -> checkFoundation + TPile _ _ -> checkTableau + where + msc = fmap fst $ s `takeFrom` kbt + mdc = fmap fst $ d `takeFrom` kbt + scs = maybe (error "validMove: shouldn't get here[scc]") id msc + dcs = maybe (error "validMove: shouldn't get here[dcc]") id mdc + sc = last scs + dc = head dcs + checkFoundation + | length scs /= 1 = False + | cardSuit sc /= fpile d = False + | mdc == Nothing = cardNumber sc == Ace + | sc `isSucc` dc = True + | otherwise = False + checkTableau + | tpile d < 0 || tpile d > 6 = False + | mdc == Nothing = cardNumber sc == King + | dc `isSucc` sc = dc `isComplement` sc + | otherwise = False + +-- foundation functions +consF :: CardSuit -> [Card] -> Foundation -> Foundation +consF s cs (Foundation fs fh fd fc) = case s of + Spades -> Foundation (cs ++ fs) fh fd fc + Hearts -> Foundation fs (cs ++ fh) fd fc + Diamonds -> Foundation fs fh (cs ++ fd) fc + Clubs -> Foundation fs fh fd (cs ++ fc) + +headF :: CardSuit -> Foundation -> Card +headF s = fst . headTailF s + +tailF :: CardSuit -> Foundation -> Foundation +tailF s = snd . headTailF s + +headTailF :: CardSuit -> Foundation -> (Card, Foundation) +headTailF s (Foundation fs fh fd fc) = case s of + Spades -> (head fs, Foundation (tail fs) fh fd fc) + Hearts -> (head fh, Foundation fs (tail fh) fd fc) + Diamonds -> (head fd, Foundation fs fh (tail fd) fc) + Clubs -> (head fc, Foundation fs fh fd (tail fc)) + +nullF :: CardSuit -> Foundation -> Bool +nullF s (Foundation fs fh fd fc) = case s of + Spades -> null fs + Hearts -> null fh + Diamonds -> null fd + Clubs -> null fc + +-- tableau functions +vHCard :: Card -> HCard +vHCard c = HCard c False + +hideT :: Tableau -> Tableau +hideT = map hidePile + where + hidePile (p : ps) = p : map hideCard ps + hidePile _ = [] + hideCard (HCard c _) = HCard c True + +consT :: Int -> [Card] -> Tableau -> Tableau +consT _ _ [] = error "consT: invalid index" +consT 0 cs (p : ps) = (map vHCard cs ++ p) : ps +consT i cs (p : ps) = p : consT (i - 1) cs ps + +headT :: Int -> Int -> Tableau -> [Card] +headT i d = fst . headTailT i d + +tailT :: Int -> Int -> Tableau -> Tableau +tailT i d = snd . headTailT i d + +headTailT :: Int -> Int -> Tableau -> ([Card], Tableau) +headTailT _ _ [] = error "headTailT: invalid index" +headTailT i d ps = headTailT' [] i d ps + where + headTailT' acc 0 d (p : ps) = + (map hcard . filter (not . hidden) . take (d + 1) $ p, + reverse acc ++ revealHead (drop (d + 1) p) : ps) + headTailT' acc i d (p : ps) = headTailT' (p : acc) (i - 1) d ps + revealHead [] = [] + revealHead ((HCard c h) : ps) = (HCard c False) : ps + +nullT :: Int -> Tableau -> Bool +nullT _ [] = error "nullT: invalid index" +nullT 0 (p : ps) = null p +nullT i (_ : ps) = nullT (i - 1) ps diff --git a/PCards.hs b/PCards.hs new file mode 100644 index 0000000..fad9c93 --- /dev/null +++ b/PCards.hs @@ -0,0 +1,120 @@ +module PCards where + +import System.Random.Shuffle + +data CardNumber = Ace | Two | Three | Four | Five | Six | Seven + | Eight | Nine | Ten | Jack | Queen | King + deriving (Eq, Ord, Enum) + +data CardSuit = Spades | Hearts | Diamonds | Clubs + deriving Eq + +data Card = Card + { cardNumber :: CardNumber + , cardSuit :: CardSuit + } deriving Eq + +type Deck = [Card] + +instance Show Card where + show (Card n s) = show s ++ show n + +instance Show CardNumber where + show Ace = "A" + show Two = "2" + show Three = "3" + show Four = "4" + show Five = "5" + show Six = "6" + show Seven = "7" + show Eight = "8" + show Nine = "9" + show Ten = "10" + show Jack = "J" + show Queen = "Q" + show King = "K" + +instance Show CardSuit where + show Spades = "♠" + show Hearts = "♥" + show Diamonds = "♦" + show Clubs = "♣" + +suits :: [CardSuit] +suits = [Spades, Hearts, Diamonds, Clubs] + +orderedDeck :: Deck +orderedDeck = [ Card n s | n <- [Ace .. King], s <- suits ] + +shuffledDeck :: IO Deck +shuffledDeck = shuffleM orderedDeck + +isSpade :: Card -> Bool +isSpade c + | cardSuit c == Spades = True + | otherwise = False + +isHeart :: Card -> Bool +isHeart c + | cardSuit c == Hearts = True + | otherwise = False + +isDiamond :: Card -> Bool +isDiamond c + | cardSuit c == Diamonds = True + | otherwise = False + +isClub :: Card -> Bool +isClub c + | cardSuit c == Clubs = True + | otherwise = False + +isSucc :: Card -> Card -> Bool +isSucc c1 c2 = maybe False (== cardNumber c1) $ (cnSucc . cardNumber) c2 + +isComplement :: Card -> Card -> Bool +isComplement c1 c2 = col c1 /= col c2 + where + col = toColour . cardSuit + +cnSucc :: CardNumber -> Maybe CardNumber +cnSucc = fromNum . (+ 1) . toNum + +data Colour = Black | Red deriving Eq + +toColour :: CardSuit -> Colour +toColour Spades = Black +toColour Hearts = Red +toColour Diamonds = Red +toColour Clubs = Black + +toNum :: CardNumber -> Int +toNum Ace = 1 +toNum Two = 2 +toNum Three = 3 +toNum Four = 4 +toNum Five = 5 +toNum Six = 6 +toNum Seven = 7 +toNum Eight = 8 +toNum Nine = 9 +toNum Ten = 10 +toNum Jack = 11 +toNum Queen = 12 +toNum King = 13 + +fromNum :: Int -> Maybe CardNumber +fromNum 1 = Just Ace +fromNum 2 = Just Two +fromNum 3 = Just Three +fromNum 4 = Just Four +fromNum 5 = Just Five +fromNum 6 = Just Six +fromNum 7 = Just Seven +fromNum 8 = Just Eight +fromNum 9 = Just Nine +fromNum 10 = Just Ten +fromNum 11 = Just Jack +fromNum 12 = Just Queen +fromNum 13 = Just King +fromNum _ = Nothing diff --git a/Util.hs b/Util.hs new file mode 100644 index 0000000..e872401 --- /dev/null +++ b/Util.hs @@ -0,0 +1,14 @@ +module Util where + +import Data.Char (ord) +import Control.Monad (liftM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans (MonadIO) +import System.Console.Haskeline + +printIO :: MonadIO m => String -> m () +printIO = liftIO . putStrLn + +getLine' :: IO String +getLine' = runInputT defaultSettings get + where get = getInputLine "> " >>= return . maybe "" id -- 1.7.10.4