initial commit

About 10 hrs of coding.

diff --git a/Command.hs b/Command.hs
new file mode 100644 (file)
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 (file)
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 (file)
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 (file)
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 (file)
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