FCards - Solitaire

20. Making some rules

So far we’ve concentrated on the mechanics of enabling the player interaction.

Saying no

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.

Rule: Stacked Cards

must be the opposite colour to the bottom face-up card
must be the next lower number in sequence

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.

Making life easy for ourselves

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

Exercise: Rules for adding to stacks

Write the functions canAddToStack and canMoveCardsBetweenStacks that takes the inputs as used in the update code above.

See an answer

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

Rule: Ace Cards

must be right suit
must be the next higher number in sequence

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

Exercise: Rules for adding to ace stacks

Write the functions canAddToAceFromStack and canAddToAce that takes the inputs as used in the update code above.

See an answer

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  

Code so far

cards.fs

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

model.fs

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
}

printing.fs

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

actions.fs

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

update.fs

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

Program.fs

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`