Bla.

Card.hs

{-# LANGUAGE TemplateHaskell #-}

module Card where

import Test.QuickCheck

import Control.Lens

data Card = Of { _rank :: Rank, _suit :: Suit }
  deriving (Eq, Ord, Show)

data Rank
  = Ace
  | Two 
  | Three 
  | Four 
  | Five 
  | Six 
  | Seven 
  | Eight 
  | Nine
  | Ten
  | Jack
  | Queen
  | King
  deriving (Eq, Ord, Show, Bounded, Enum)

data Suit
  = Hearts
  | Spades
  | Diamons
  | Clubs
  deriving (Eq, Ord, Show, Bounded, Enum)

makeLenses ''Card

instance Enum Card where
    toEnum int = toEnum (int `div` 4) `Of` toEnum (int `mod` 4)

    fromEnum (rank `Of` suit) =
        fromEnum suit + 4 * fromEnum rank

instance Bounded Card where
    minBound = Ace  `Of` Hearts
    maxBound = King `Of` Clubs

every :: (Bounded a, Enum a) => [a]
every = [minBound.. maxBound]

cross suit1 suit2 = odd (fromEnum suit1 - fromEnum suit2)

(topR `Of` topS) `follows` (botR `Of` botS) =
    cross topS botS && fromEnum botR == fromEnum topR + 1

instance Arbitrary Card where
    arbitrary = arbitraryBoundedEnum

cards_test = quickCheck $ \card -> 
    (card :: Card) == toEnum (fromEnum card)

CardChain.hs

{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}

module CardChain where

import Control.Monad.Except

import Control.Lens

import Card

type CardChain
  = [Card] -- backwards
  
layOver card chain
  | null chain
    = return $ [card]
  
  | card `follows` head chain
    = return $ card : chain

  | otherwise
    = throwError "layOver: card doesn't follow"

layOverChain chain1 chain2 = do
    last chain1 `layOver` chain2
    return $ chain1 ++ chain2

Deck.hs

module Deck where

import Card

type Deck = [Card]

Table.hs

{-# LANGUAGE TemplateHaskell, FlexibleContexts, Rank2Types #-}

{-
    This module represents table for solitair card game.
    It contains the model for table and main operations (card movement).
-}

module Table
  ( Table
    -- smart-ctor
  , fromDeck
    -- accessors
  , deck
  , waste
  , foundations
  , piles
  , score
  , hand

    -- part of the main model
  , Pile(Pile)
    -- accessors
  , open
  , hidden

    -- actions
  , turnDeck
  , recycleWaste
  , takeFromDeck
  , takeFromPile
  , putToPile
  , putToFoundation
  )
where

import Card
import CardChain
import Deck
import Utils

import           Data.List
import           Data.Maybe
import qualified Data.Map as Map
import           Data.Map   (Map, (!))
import           Data.Traversable

import Control.Monad.State
import Control.Monad.Except

import Control.Lens

data Table
  = Table
    { _deck        :: Deck           -- main deck to take cards from
    , _waste       :: Deck           -- pool to accumulate cards taken from deck
    , _foundations :: Map Suit Int   -- the ace-started columns to fill
    , _piles       :: Map Int  Pile  -- piles to dig out
    , _score       :: Score
    , _hand        :: CardChain
    }
    deriving Show

-- open cards + hidden cards
data Pile 
  = Pile
    { _open   :: CardChain
    , _hidden :: Deck
    }
    deriving Show

type Score = Int

-- generate accessors
makeLenses ''Table
makeLenses ''Pile

fromDeck :: Deck -> Table
-- construct initial game state from a deck permutation
fromDeck input
  | length input /= 52 || length (nub input) /= 52 =
    error "fromDeck: bad deck - it must contain 52 distinct cards"

  | otherwise =
    evalState ctor input
  where
    ctor :: State [Card] Table
    ctor = do
        heaps <- for [0.. 6] (state . splitAt)
        shown <- state (splitAt 7)
        rest  <- get

        let makePile n top down = (n, Pile [top] down)

        return Table
          { _deck        = rest
          , _waste       = []
          , _foundations = Map.fromList (zip every (repeat (-1)))
          , _piles       = Map.fromList (zipWith3 makePile [1.. 7] shown heaps)
          , _score       = 0
          , _hand        = []
          }

turnDeck :: (MonadState Table m, MonadError String m) => m ()
-- take one card from main deck and put it on top of the "waste"
turnDeck = do
    assert "deck is not empty" deck (not . isEmpty)

    top : rest <- use deck
    
    waste %= cons top
    deck  .= rest

recycleWaste :: (MonadState Table m, MonadError String m) => m ()
-- return "wasted" cards to the game
recycleWaste = do
    assert "deck is empty"     deck         isEmpty
    assert "waste isn't empty" waste (not . isEmpty)

    waste %=  reverse
    deck `exchangeWith` waste

takeFromDeck :: (MonadState Table m, MonadError String m) => m ()
-- actually, take from top of the waste
takeFromDeck = do
    assert "hand is clear"  hand         isEmpty
    assert "waste has smth" waste (not . isEmpty)

    top : rest <- use waste

    waste .=  rest
    hand  .= [top]

takeFromPile :: (MonadState Table m, MonadError String m) => Int -> m ()
takeFromPile pileNumber = do
    assert "hand is clear" hand isEmpty

    assert ("pile#% is not empty" % pileNumber)
        (piles.ix(pileNumber).open) 
        (not . isEmpty)
    
    hand `exchangeWith` piles.ix(pileNumber).open

putToPile :: (MonadState Table m, MonadError String m) => Int -> m ()
putToPile pileNumber = do
    assert "hand holds something" hand (not . isEmpty)

    fromHand <- use   hand
    oldPile  <- use $ piles.ix(pileNumber).open
    
    newPile <- layOverChain fromHand oldPile

    piles.ix(pileNumber).open .= newPile

    hand .= []

putToFoundation :: (MonadState Table m, MonadError String m) => Suit -> m ()
-- put top card from the hand into given "foundation"
putToFoundation foundation = do
    assert "hand holds something" hand (not . isEmpty)
    assert "valid suit"           (hand._head.suit) (== foundation)

    rank <- tryUse $ hand._head.rank

    assert "valid rank" (foundations.ix(foundation)) 
        (\rank1 -> rank1 == fromEnum rank - 1)

    foundations.ix(foundation) += 1
    hand %= tail  -- drop the card

Utils.hs

{-# LANGUAGE FlexibleContexts, Rank2Types #-}

module Utils where

import Control.Lens
import Control.Monad.State
import Control.Monad.Except

import Data.Monoid

assert 
    :: MonadState s m
    => MonadError String m
    => String
    -> Traversal' s a
    -> (a -> Bool)
    -> m ()
-- for a given projection (lens), check if any of its images doeds fulfill the predicate
assert msg lens pred = do
    whole <- get
    let hits = [() | part <- whole^..lens, pred part]
    when (null hits) $ do
        throwError ("assertion failed: " ++ msg)

tryUse
  :: MonadError String m
  => MonadState s m
  => Getting (Data.Monoid.First b) s b 
  -> m b
-- "use" restricts the projection to have exactly 1 image; unacceptable!
tryUse lens = do
    whole <- get

    case whole^? lens of
        Just it ->
            return it
        _ -> 
            throwError "try_use: failed"

isEmpty :: [a] -> Bool
isEmpty = null

(%) :: Show a => String -> a -> String
-- push thing into the string
str % thing =
    let (before, '%' : after) = break (== '%') str
    in before ++ show thing ++ after

(%.) :: String -> String -> String
-- push string into the string
str %. string =
    let (before, '%' : after) = break (== '%') str
    in before ++ string ++ after

infix 1 `exchangeWith`
exchangeWith :: (MonadState s m, MonadError String m) => Traversal' s a -> Traversal' s a -> m ()
-- take thing from one projection and put directly into another
acceptor `exchangeWith` sender = do
    thing1 <- tryUse sender
    thing2 <- tryUse acceptor
    acceptor .= thing1
    sender   .= thing2