FCards - Solitaire

18. Moving Stacks

We can now make our stacks grow - let’s look at what we’ve achieved and have yet to do:

Moving cards from one stack to another

So far, all of our moves have been a single keystroke command. But when we move cards from one stack to another we need to tell the game a few things:

  1. That we want to move a stack
  2. Which stack to move
  3. How many face-up cards to move
  4. Which stack to move the card into

This complicates our update loop, as now we will expect the input and gameplay to come in multiple command phases. However, we don’t want to muddy up the Game type with user interaction.

We will need to remember which phase the multi-step command is up to, and the values that the player has entered so far.

type Phase = 
  | General
  | SelectingSourceStack       
  | SelectingNumCards of int            // remember the source stack number
  | SelectingTargetStack of (int * int) // remember the source stack and number of cards
                                        //   (Note: this is a tuple of two numbers)

We can then wrap the Game up into a container along with the command phase

type MultiPhaseGame = {
  game: Game
  phase: Phase
}

At each phase we need to accept a different set of command keystrokes, and allow the player to change their mind and back out of the previous choice.

let updateGameGeneral game keystroke = // our old `updateGame`, now one of possible update options
  match keystroke with 
  | 'd'   -> game |> applyUpdate DrawCards
  | 'm'   -> game |> nextPhase SelectingSourceStack
  | Number a when (a >= 1 && a <= 6) 
          -> game |> applyUpdate (TableToStack a)
  | _     -> 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

Exercise: Updating the game in different phases

Implement the movement through the phases by updating the phase value of our game, and then actually doing the movement of the cards from one stack to another.

Don’t forget that if we move the last face-up card in the stack, then we need to flip over the next face-down card (if there is one).

Here a couple of helper functions that may be useful

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}

TIP: Hiding and visibility
We can use the keyword private to say that the function cannot be seen or called from outside the module. Quite often this is used to allow us to break down the code into small chunks, but with the intention that only the main functions for each module should be called.

See an answer for moving through the phases

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' -> game |> nextPhase (SelectingNumCards sourceStack)
  | _      -> game

See an answer for moving the cards

let private 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
  let numFaceUp =
    source 
    |> List.filter (fun a -> a.isFaceUp)
    |> List.length
  // flip next card?
  let sourceFlipped =
    match source.Length, numFaceUp with 
    | 0, _ -> source // no cards to flip
    | n, 0 -> // none face up
      source
      |> List.updateAt 
          (n - 1) 
          {source[n - 1] with isFaceUp=true}
    | _, _ -> source //anything else

  //reconstruct the game
  { game with 
      stacks = 
        game.stacks 
        |> List.updateAt (sourceStack - 1) sourceFlipped 
        |> List.updateAt (targetStack - 1) target 
  }


// The _external_ arguments for "MoveCards"
type MoveArgs = { sourceStack: int; numCards: int; targetStack: int; }

type SolitaireCommands = 
  | DrawCards
  | TableToStack of int
  | MoveCards of MoveArgs

let applyCommand (cmd: SolitaireCommands) (game: Game) =
  match cmd with 
  | DrawCards -> game |> drawCards
  | TableToStack a -> game |> tableToStack (a - 1)
  | MoveCards args -> game |> moveCardsBetweenStacks args.sourceStack args.numCards args.targetStack

We also need to print out the commands that are acceptable for the command phase. Try doing this also using a match on the game’s phase.

See an answer for showing the appropriate commands for the phase

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
  multiGame

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
}

type Phase = 
  | General
  | SelectingSourceStack
  | SelectingNumCards of int
  | SelectingTargetStack of int * int

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  |" clearLine
  [0..19] |> List.iter (fun cardNum ->
    [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)
    |> printfn "%s%s" clearLine
  )
  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
  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 deal shuffledDeck = 
  let emptyGame = {
    deck = shuffledDeck
    table = []
    stacks = []
  }
  [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}) 
        {
          stacks = game.stacks @ [ newStack ]
          deck = game.deck |> List.skip i
          table = []
        }
      
      ) emptyGame

let private 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
  }

// a helper to add a card to a numbered stack
let private addToStack (stackNum:int) (card:Card) (stacks: StackCard list list) =
  let updatedStack = stacks[stackNum] @ [ { isFaceUp=true; card=card} ]
  stacks |> List.updateAt stackNum updatedStack

let private tableToStack stackNum game =
  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 private 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
  let numFaceUp =
    source 
    |> List.filter (fun a -> a.isFaceUp)
    |> List.length
  // flip next card?
  let sourceFlipped =
    match source.Length, numFaceUp with 
    | 0, _ -> source // no cards to flip
    | n, 0 -> // none face up
      source
      |> List.updateAt 
          (n - 1) 
          {source[n - 1] with isFaceUp=true}
    | _, _ -> source //anything else

  //reconstruct the game
  { game with 
      stacks = 
        game.stacks 
        |> List.updateAt (sourceStack - 1) sourceFlipped 
        |> List.updateAt (targetStack - 1) target 
  }

// The _external_ arguments for "MoveCards"
type MoveArgs = { sourceStack: int; numCards: int; targetStack: int; }

type SolitaireCommands = 
  | DrawCards
  | TableToStack of int
  | MoveCards of MoveArgs

let applyCommand (cmd: SolitaireCommands) (game: Game) =
  match cmd with 
  | DrawCards -> game |> drawCards
  | TableToStack a -> game |> tableToStack (a - 1)
  | MoveCards args -> game |> moveCardsBetweenStacks args.sourceStack args.numCards args.targetStack

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
  | 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 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

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`