FCards - Solitaire

19. Aces

We can now move cards around - let’s look at what we’ve achieved and have yet to do:

Ace Stacks

This is part of the end game when we peel off cards from the stacks onto a special stack just for a single suit - starting with the Ace.

So interesting things about these stacks are:

one stack per suit
cards count up from Ace, Two, Three, …, up to King
cards can come from the bottom visible card of a stack, or the table

As the cards in an Ace stack are always face-up we can just use a plain Card:

type Game = {
  ...
  aces: Card list list
}

Showing the “Ace” stacks

So we’ll need to see these stacks:

========================== Solitaire ===========================
| 1  |  2  |  3  |  4  |  5  |  6  |===|  ♥  |  ♦  |  ♣  |  ♠  |
[###] [###] [###] [###] [###]                 [♦A ] [♣A ]
[###] [###] [###] [###]                             [♣2 ]
[###] [###] [###] [♠8 ]                             [♣3 ]
[###] [###] [♥5 ]                  
[###] [♣10]                        
[♣Q ]                              

Table: 
Deck:  [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[###]
<d>raw cards, <1-6> put on stack, <m>ove cards between stacks, <a>ce cards, <q>uit

Moving cards onto the Ace stacks

This is again going to have to be a multi-phase operation. The player will need to tell the game:

That we want to put something on an ace stack
That the card is coming from the table, or to select a stack

We can extend the game phase type to include these possibilities:

type Phase = 
  ...
  SelectingAceSource

It doesn’t need to carry any info into a further state, as once we know the stack number/table that the ace is coming from then we can automatically put it in the right stack based on its suit.

Exercise: Showing Ace stacks

Change the code that prints the screen to include the Ace Stacks

See an answer

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   // print stacks then aces on the same line
  )
  multiGame //pass it on to the next function

Exercise: Add to Ace stacks

Add the update function updateGameAceSource to move cards to the Ace stacks.

Also, include a change to the printCommands functions to keep the player informed.

See an answer for printing commands

let printCommands game =
  match game.phase with
  | General -> 
      printfn 
        "%s<d>raw cards, <1-6> put on stack, <m>ove cards between stacks, <a>ce cards, <q>uit" 
        clearLine  
  ...
  | SelectingAceSource ->
      printfn 
        "%sMove to ACE stack from stack ___(1-6) or <t>able, <esc> Go back, <q>uit" 
        clearLine    

See an answer for moving to Ace stacks

let private addToAce card game =
  let acesStackNum =
    match card with 
    | Hearts _ -> 0
    | Diamonds _ -> 1
    | Clubs _ -> 2
    | Spades _ -> 3
    | Joker _ -> failwith "AAAAH! A Joker!?!?"
  let target = game.aces[acesStackNum] @ [card]
  {game with 
    aces =
      game.aces
      |> List.updateAt acesStackNum target
  }

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

let applyCommand (cmd: SolitaireCommands) (game: Game) =
  match cmd with 
  ...
  | TableToAce     -> game |> moveToAceFromTable
  | StackToAce a   -> game |> moveToAceFromStack a

... 

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   

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 deal shuffledDeck = 
  let emptyGame = {
    deck = shuffledDeck
    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 (|Number|_|) (ch:Char) =
  match Char.GetNumericValue(ch) with
  | -1.0 -> None
  | a -> a |> int |> Some

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 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 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
  // 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 private addToAce card game =
  let acesStackNum =
    match card with 
    | Hearts _ -> 0
    | Diamonds _ -> 1
    | Clubs _ -> 2
    | Spades _ -> 3
    | Joker _ -> failwith "AAAAH! A Joker!?!?"
  let target = game.aces[acesStackNum] @ [card]
  {game with 
    aces =
      game.aces
      |> List.updateAt acesStackNum target
  }

let private 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 private 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 -> game |> tableToStack (a - 1)
  | MoveCards args -> game |> moveCardsBetweenStacks args.sourceStack args.numCards args.targetStack
  | TableToAce     -> game |> moveToAceFromTable
  | StackToAce a   -> game |> moveToAceFromStack a

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`