So far we’ve concentrated on the mechanics of enabling the player interaction.
Now it’s time to actually implement some rules of the game. In order to do this we may have to tell the player (gasp!) NO.
One of the important decisions we need to make is where in the in process do we enforce the rules.
I prefer to leave the functions that actually do the activities (e.g. moveCardsBetweenStacks
, moveToAceFromStack
, etc) to be completely ignorant of higher-level rules. That pushes the rule logic up a level to the various applyCommand
function. This is the function that deals with the intended actions and decide what to do with it. So let’s update this function to be a bit more sophisticated:
let applyCommand (cmd: SolitaireCommands) (game: Game) =
match cmd with
...
| TableToStack a
when (a >= 1 && a <= 6)
&& canAddToStack (game.stacks[a - 1]) (game.table.Head)
-> game |> tableToStack (a - 1)
| MoveCards args
when (args.targetStack >= 1 && args.targetStack <= 6)
&& canMoveCardsBetweenStacks args.sourceStack args.numCards args.targetStack game
-> game |> moveCardsBetweenStacks args.sourceStack args.numCards args.targetStack
...
Note the new functions canAddToAceFromStack
, canAddToAce
, canAddToStack
, and canMoveCardsBetweenStacks
are used as part of the matcher’s when clause.
We can extend the model a bit to help us find out these things
type Card with member this.Number = match this with | Hearts a | Diamonds a | Clubs a | Spades a -> a // can all resolve to these same `a`, because all the DU parts are the same type | Joker -> failwith "Joker?!?!?"
type CardNumber with member this.Ordinal = // i.e. the numerical order match this with | Ace -> 1 | Two -> 2 | Three -> 3 | Four -> 4 | Five -> 5 | Six -> 6 | Seven -> 7 | Eight -> 8 | Nine -> 9 | Ten -> 10 | Jack -> 11 | Queen -> 12 | King -> 13
… and use a couple of active patterns to deal with colours
let (|IsRed|_|) (card:Card) = match card with | Hearts _ | Diamonds _ -> Some card // pass the card on | _ -> None // end of the road let (|IsBlack|_|) (card:Card) = match card with | IsRed _ -> None // end of the road | _ -> Some card // pass the card on
Write the functions canAddToStack
and canMoveCardsBetweenStacks
that takes the inputs as used in the update code above.
let canAddToStack (stack: StackCard list) (card:Card) =
if stack = [] && card.Number = King then // BONUS! we can tick this off too
true
else
let bottomCard = stack |> List.last
match bottomCard.card, card with
| IsRed a, IsBlack b
| IsBlack a, IsRed b
when a.Number.Ordinal = b.Number.Ordinal + 1
-> true
| _, _ -> false
let canMoveCardsBetweenStacks sourceStack numCards targetStack game =
// make things a bit easier to call the above function
// by making the arguments the same as the move...() function
let stack = game.stacks[targetStack - 1]
let card =
game.stacks[sourceStack - 1]
|> List.skip ( game.stacks[sourceStack - 1].Length - numCards )
|> List.head
canAddToStack stack card.card
We can update the update functions for Ace stacks in a similar way
let applyCommand (cmd: SolitaireCommands) (game: Game) =
match cmd with
...
| TableToAce
when canAddToAce game.table game
-> game |> moveToAceFromTable
| StackToAce sourceStack
when (sourceStack >= 1 && sourceStack <= 6)
&& canAddToAceFromStack sourceStack game
-> game |> moveToAceFromStack sourceStack
| _ -> game
Write the functions canAddToAceFromStack
and canAddToAce
that takes the inputs as used in the update code above.
let canAddToAce cards game =
match cards with
| [] -> false
| [card]
| card::_ ->
let stackNum = acesStackNum card
let target = game.aces[stackNum] |> List.rev // (so we can easily see the last card as the "head")
match target, card with
| [], c when c.Number = Ace -> true
| [a], c
| a::_, c
when a.Number.Ordinal = c.Number.Ordinal - 1
-> true
| _ -> false
let canAddToAceFromStack sourceStack game =
// Make it easier to call the above function for stacks
let cards =
game.stacks[sourceStack - 1]
|> List.map (fun a -> a.card)
|> List.rev
canAddToAce cards game
module Cards
open System
//COLOR CODES
let COLOR_DEFAULT = "\x1B[0m"
let COLOR_RED = "\x1B[91m"
let COLOR_BLACK = "\x1B[90m"
let SYMBOL_HEART = "\u2665"
let SYMBOL_DIAMOND = "\u2666"
let SYMBOL_CLUB = "\u2663"
let SYMBOL_SPADE = "\u2660"
type CardNumber =
| Two
| Three
| Four
| Five
| Six
| Seven
| Eight
| Nine
| Ten
| Jack
| Queen
| King
| Ace
with
override this.ToString() =
match this with
| Two -> "2 "
| Three -> "3 "
| Four -> "4 "
| Five -> "5 "
| Six -> "6 "
| Seven -> "7 "
| Eight -> "8 "
| Nine -> "9 "
| Ten -> "10"
| Jack -> "J "
| Queen -> "Q "
| King -> "K "
| Ace -> "A "
type Card =
| Hearts of CardNumber
| Diamonds of CardNumber
| Clubs of CardNumber
| Spades of CardNumber
| Joker
with
override this.ToString() =
match this with
| Hearts x -> $"{COLOR_RED}{SYMBOL_HEART}{x}{COLOR_DEFAULT}"
| Diamonds x -> $"{COLOR_RED}{SYMBOL_DIAMOND}{x}{COLOR_DEFAULT}"
| Clubs x -> $"{COLOR_BLACK}{SYMBOL_CLUB}{x}{COLOR_DEFAULT}"
| Spades x -> $"{COLOR_BLACK}{SYMBOL_SPADE}{x}{COLOR_DEFAULT}"
| Joker -> "Jok"
let printOut (hand: 'a seq) =
"[" + String.Join("] [", hand) + "]"
let newDeck =
let suits = [Hearts; Diamonds; Clubs; Spades]
let numbers = [
Two; Three; Four; Five; Six; Seven; Eight; Nine; Ten;
Jack; Queen; King; Ace
]
List.allPairs suits numbers
|> List.map (fun (suit, number) -> suit number)
let rec shuffle deck =
let random = System.Random()
match deck with
| [] -> []
| [a] -> [a]
| _ ->
let randomPosition = random.Next(deck.Length)
let cardAtPosition = deck[randomPosition]
let rest = deck |> List.removeAt randomPosition
[cardAtPosition] @ (shuffle rest)
//moves the cursor up "n" lines
let moveUpLines n =
printfn "\x1B[%dA" n
let combineUpdate printScreen updater game command =
updater game command
|> printScreen
let loopGame<'G>
(printScreen: 'G -> 'G)
(updater: 'G -> char -> 'G)
(initialGame: 'G) =
printScreen initialGame |> ignore
(fun _ -> Console.ReadKey().KeyChar |> Char.ToLowerInvariant)
|> Seq.initInfinite
|> Seq.takeWhile (fun x -> x <> 'q')
|> Seq.fold (combineUpdate printScreen updater) initialGame
module Solitaire.Model
open System
open Cards
type StackCard = {
card: Card
isFaceUp: bool
} with
override this.ToString() =
if this.isFaceUp then
this.card.ToString()
else
"###"
type Game = {
deck: Card list
table: Card list
stacks: StackCard list list
aces: Card list list
}
type Phase =
| General
| SelectingSourceStack
| SelectingNumCards of int
| SelectingTargetStack of int * int
| SelectingAceSource
type MultiPhaseGame = {
game: Game
phase: Phase
}
module Solitaire.Printing
open System
open Cards
open Solitaire.Model
let clearLine = "\x1B[K"
let printHeader multiGame =
printfn "%s========================== Solitaire ===========================" clearLine
multiGame
let printStacks multiGame =
printfn "%s| 1 | 2 | 3 | 4 | 5 | 6 |===| %s | %s | %s | %s |"
clearLine SYMBOL_HEART SYMBOL_DIAMOND SYMBOL_CLUB SYMBOL_SPADE
[0..19] |> List.iter (fun cardNum ->
let stackline =
[0..5] |> List.map (fun stackNum ->
if multiGame.game.stacks[stackNum].Length > cardNum then
multiGame.game.stacks[stackNum][cardNum]
|> sprintf "[%O]"
else
// the stack is out of cards
" "
)
|> fun strings -> String.Join (" ", strings)
let aceline =
[0..3] |> List.map (fun stackNum ->
if multiGame.game.aces[stackNum].Length > cardNum then
multiGame.game.aces[stackNum][cardNum]
|> sprintf "[%O]"
else
// the ace stack is out of cards
" "
)
|> fun strings -> String.Join (" ", strings)
printfn "%s%s %s" clearLine stackline aceline
)
multiGame //pass it on to the next function
let printTable multiGame =
let tableLine =
match multiGame.game.table with
| [] -> ""
| a ->
String.init a.Length (fun _ -> "[")
+ a.Head.ToString()
+ "]"
printfn "%s" clearLine //spacer
printfn "%sTable: %s" clearLine tableLine
multiGame
let printDeck multiGame =
let deckLine = String.init multiGame.game.deck.Length (fun _ -> "[")
printfn "%sDeck: %s###]" clearLine deckLine
multiGame
let printCommands multiGame =
match multiGame.phase with
| General ->
printfn
"%s<d>raw cards, <1-6> put on stack, <m>ove cards between stacks <q>uit"
clearLine
| SelectingSourceStack ->
printfn
"%sMove cards from stack ___(1-6), <esc> Go back, <q>uit"
clearLine
| SelectingNumCards stack->
let numCardsInStack =
multiGame.game.stacks[stack - 1]
|> List.filter (fun a -> a.isFaceUp )
|> List.length
printfn
"%sMove ___(1-%d, or <a>ll) cards from stack %d, <esc> Go back, <q>uit"
clearLine numCardsInStack stack
| SelectingTargetStack (stack, card) ->
printfn
"%sMove %d cards from stack %d to stack ___, <esc> Go back, <q>uit"
clearLine card stack
| SelectingAceSource ->
printfn
"%sMove to ACE stack from stack ___(1-6) or <t>able, <esc> Go back, <q>uit"
clearLine
multiGame
let printMoveToTop multiGame =
let maxCardInAnyStack =
multiGame.game.stacks
|> List.map (fun stack -> stack.Length )
|> List.max
let n =
1 //header
+ 1 //stack numbers
+ 21 //stacks
+ 1 //table
+ 1 //deck
+ 1 //commands
+ 1 //current line
moveUpLines n
multiGame
let printScreen multiGame =
multiGame
|> printMoveToTop
|> printHeader
|> printStacks
|> printTable
|> printDeck
|> printCommands
module Solitaire.Actions
open System
open Cards
open Solitaire.Model
let (|Number|_|) (ch:Char) =
match Char.GetNumericValue(ch) with
| -1.0 -> None
| a -> a |> int |> Some
let deal shuffledDeck =
let emptyGame = {
deck = shuffledDeck |> List.except [Joker]
table = []
stacks = []
aces = List.init 4 (fun _ -> [])
}
[6..-1..1]
|> List.fold (fun game i ->
let newStack =
game.deck
|> List.take i // flip the last card
|> List.mapi (fun n card -> { isFaceUp = (n = i - 1); card=card})
{game with
stacks = game.stacks @ [ newStack ]
deck = game.deck |> List.skip i
}
) emptyGame
let drawCards game =
let withEnoughCardsToDraw =
match game.deck.Length with
| n when n < 3 ->
{game with
deck = game.deck @ game.table
table = []
}
| _ -> game
// in case there is less than 3 remaining
let cardsToTake = Math.Min(3, withEnoughCardsToDraw.deck.Length)
{withEnoughCardsToDraw with
table =
(withEnoughCardsToDraw.deck |> List.take cardsToTake)
@ withEnoughCardsToDraw.table
deck = withEnoughCardsToDraw.deck |> List.skip cardsToTake
}
type Card with
member this.Number =
match this with
| Hearts a
| Diamonds a
| Clubs a
| Spades a -> a
| Joker -> failwith "Joker?!?!?"
type CardNumber with
member this.Ordinal =
match this with
| Ace -> 1
| Two -> 2
| Three -> 3
| Four -> 4
| Five -> 5
| Six -> 6
| Seven -> 7
| Eight -> 8
| Nine -> 9
| Ten -> 10
| Jack -> 11
| Queen -> 12
| King -> 13
let (|IsRed|_|) (card:Card) =
match card with
| Hearts _
| Diamonds _ -> Some card
| _ -> None
let (|IsBlack|_|) (card:Card) =
match card with
| IsRed _ -> None
| _ -> Some card
let canAddToStack (stack: StackCard list) (card:Card) =
if stack = [] && card.Number = King then
true
else
let bottomCard = stack |> List.last
match bottomCard.card, card with
| IsRed a, IsBlack b
| IsBlack a, IsRed b
when a.Number.Ordinal = b.Number.Ordinal + 1
-> true
| _, _ -> false
let canMoveCardsBetweenStacks sourceStack numCards targetStack game =
// make things a bit easier to call the above function
// by making the arguments the same as the move...() function
let stack = game.stacks[targetStack - 1]
let card =
game.stacks[sourceStack - 1]
|> List.skip ( game.stacks[sourceStack - 1].Length - numCards )
|> List.head
canAddToStack stack card.card
let addToStack (stackNum:int) (card:Card) (stacks: StackCard list list) =
let updatedStack = stacks[stackNum] @ [ { isFaceUp=true; card=card} ]
stacks |> List.updateAt stackNum updatedStack
let tableToStack stackNum game =
let stack = game.stacks[stackNum]
match game.table with
| [] -> game // do nothing
| [a]->
{game with
table = [];
stacks = game.stacks |> addToStack stackNum a
}
| a::rest ->
{game with
table = rest;
stacks = game.stacks |> addToStack stackNum a
}
let flipNext stack =
let numFaceUp =
stack
|> List.filter (fun a -> a.isFaceUp)
|> List.length
match stack.Length, numFaceUp with
| 0, _ -> stack // no cards to flip
| n, 0 -> // none face up
stack
|> List.updateAt
(n - 1)
{stack[n - 1] with isFaceUp=true}
| _, _ -> stack //anything else
let moveCardsBetweenStacks sourceStack numCards targetStack game =
// remember - on screen we start at one, but lists start at zero
let numCardsInStack = game.stacks[sourceStack - 1].Length
// do the move
let moving = game.stacks[sourceStack - 1] |> List.skip ( numCardsInStack - numCards )
let source = game.stacks[sourceStack - 1] |> List.take ( numCardsInStack - numCards )
let target = game.stacks[targetStack - 1] @ moving
// flip next card?
let sourceFlipped = flipNext source
//reconstruct the game
{ game with
stacks =
game.stacks
|> List.updateAt (sourceStack - 1) sourceFlipped
|> List.updateAt (targetStack - 1) target
}
let acesStackNum card =
match card with
| Hearts _ -> 0
| Diamonds _ -> 1
| Clubs _ -> 2
| Spades _ -> 3
| Joker _ -> failwith "AAAAH! A Joker!?!?"
let canAddToAce cards game =
match cards with
| [] -> false
| [card]
| card::_ ->
let stackNum = acesStackNum card
let target = game.aces[stackNum] |> List.rev // (so we can easily see the last card as the "head")
match target, card with
| [], c when c.Number = Ace -> true
| [a], c
| a::_, c
when a.Number.Ordinal = c.Number.Ordinal - 1
-> true
| _ -> false
let canAddToAceFromStack sourceStack game =
// Make it easier to call the above function for stacks
let cards =
game.stacks[sourceStack - 1]
|> List.map (fun a -> a.card)
|> List.rev
canAddToAce cards game
let addToAce card game =
let stackNum = acesStackNum card
let target = game.aces[stackNum] @ [card]
{game with
aces =
game.aces
|> List.updateAt stackNum target
}
let moveToAceFromStack sourceStack game =
match game.stacks[sourceStack - 1] with
| [] -> game
| [a] ->
let addedToAce = addToAce a.card game
{addedToAce with
stacks =
game.stacks
|> List.updateAt (sourceStack - 1) []
}
| a ->
//we need the last card, not the first
let source, moving =
a
|> List.splitAt ( a.Length - 1 )
let sourceFlipped = flipNext source
let addedToAce = addToAce moving.Head.card game
{addedToAce with
stacks =
game.stacks
|> List.updateAt (sourceStack - 1) sourceFlipped
}
let moveToAceFromTable game =
match game.table with
| [] -> game
| [a] ->
let addedToAce = addToAce a game
{addedToAce with table = [] }
| a::rest ->
let addedToAce = addToAce a game
{addedToAce with table = rest }
// The _external_ arguments for "MoveCards"
type MoveArgs = { sourceStack: int; numCards: int; targetStack: int; }
type SolitaireCommands =
| DrawCards
| TableToStack of int
| MoveCards of MoveArgs
| TableToAce
| StackToAce of int
let applyCommand (cmd: SolitaireCommands) (game: Game) =
match cmd with
| DrawCards
-> game |> drawCards
| TableToStack a
when (a >= 1 && a <= 6)
&& canAddToStack (game.stacks[a - 1]) (game.table.Head)
-> game |> tableToStack (a - 1)
| MoveCards args
when (args.targetStack >= 1 && args.targetStack <= 6)
&& canMoveCardsBetweenStacks args.sourceStack args.numCards args.targetStack game
-> game |> moveCardsBetweenStacks args.sourceStack args.numCards args.targetStack
| TableToAce
when canAddToAce game.table game
-> game |> moveToAceFromTable
| StackToAce sourceStack
when (sourceStack >= 1 && sourceStack <= 6)
&& canAddToAceFromStack sourceStack game
-> game |> moveToAceFromStack sourceStack
| _ -> game
module Solitaire.Update
open System
open Cards
open Solitaire.Model
open Solitaire.Actions
let private (|Number|_|) (ch:Char) =
match Char.GetNumericValue(ch) with
| -1.0 -> None
| a -> a |> int |> Some
let private applyUpdate command multiPhaseGame =
{
multiPhaseGame with
game = multiPhaseGame.game|> applyCommand command
phase = General // all updates move the phase back to General
}
let private nextPhase phase game = {game with phase = phase}
let private updateGameGeneral game keystroke =
match keystroke with
| 'd' -> game |> applyUpdate DrawCards
| 'm' -> game |> nextPhase SelectingSourceStack
| 'a' -> game |> nextPhase SelectingAceSource
| Number a when (a >= 1 && a <= 6)
-> game |> applyUpdate (TableToStack a)
| _ -> game
let private updateGameSourceStack game keystroke =
match keystroke with
| Number stack when (stack >= 1 && stack <= 6)
-> game |> nextPhase (SelectingNumCards stack)
| '\x1B' -> game |> nextPhase General
| _ -> game
let private updateGameNumCards sourceStack game keystroke =
let numCardsInStack =
game.game.stacks[sourceStack - 1]
|> List.filter (fun a -> a.isFaceUp )
|> List.length
match keystroke with
| Number card -> game |> nextPhase (SelectingTargetStack (sourceStack, card))
| 'a' -> game |> nextPhase (SelectingTargetStack (sourceStack, numCardsInStack))
| '\x1B' -> game |> nextPhase SelectingSourceStack
| _ -> game
let private updateGameTargetStack sourceStack numCards game keystroke =
match keystroke with
| Number targetStack when (targetStack >= 1 && targetStack <= 6) ->
game
|> applyUpdate (MoveCards {sourceStack=sourceStack; numCards=numCards; targetStack=targetStack})
| '\x1B' -> // [esc] key
game |> nextPhase (SelectingNumCards sourceStack)
| _ -> game
let updateAceSourceStack game keystroke =
match keystroke with
| Number sourceStack when (sourceStack >= 1 && sourceStack <= 6)
-> game |> applyUpdate (StackToAce sourceStack)
| 't' -> game |> applyUpdate TableToAce
| '\x1B' -> game |> nextPhase General
| _ -> game
let updateGame (game: MultiPhaseGame) keystroke : MultiPhaseGame =
match game.phase with
| General ->
updateGameGeneral game keystroke
| SelectingSourceStack ->
updateGameSourceStack game keystroke
| SelectingNumCards sourceStack ->
updateGameNumCards sourceStack game keystroke
| SelectingTargetStack (sourceStack, numCards) ->
updateGameTargetStack sourceStack numCards game keystroke
| SelectingAceSource ->
updateAceSourceStack game keystroke
open Cards
open Solitaire
open Solitaire.Model
newDeck
|> shuffle
|> fun cards -> {game=Actions.deal cards; phase=General}
|> loopGame Printing.printScreen Update.updateGame
|> ignore // a program is expected to return `unit` (i.e. nothing), but the above returns a Game
// `ignore()` takes anything as an input and returns `unit`