Fork me on GitHub

The domain

A couple of days ago, a coworker posted on our Team Funktionel group in Yammer the following link (Yammer is like a Facebook for companies):

One of the slides really caught my attention on how Scott was defining type’s (interface/contract) for his functions, see lines 11 and 12 on the following code:

 1 module CardGame =
 2   type Suit = Club | Diamond | Spade | Heart
 3   type Rank =
 4     | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten
 5     | Jack | Queen | King | Ace
 6   type Card = Suit * Rank
 7   type Hand = Card list
 8   type Deck = Card list
 9   type Player = {Name:string; Hand:Hand}
10   type Game = {Deck:Deck; Players: Player list}
11   type Deal = Deck -> (Deck * Card)
12   type PickupCard = (Hand * Card) -> Hand

My background before using F# was OCaml, where you define your interfaces/contracts (signatures in F#) in a .mli file (.fsi files in F#) as shown in the code below:

val foo : unit -> string

Afterwards the following function must be implemented in the .ml file sharing the same name as the .mli file. The main issue here is that you needed to separate the definition of your functions to several files as the project grow. What I like about Scott’s approach, is that you can still maintain the entire domain in the same file while you still are able to define you explicit fields in your signature files:

// Domain.fs file
type Foo : unit -> string
// Foo.fsi file
val foo : Foo

Once I understood why it was smart to take this approach, I then decided that I wanted to implement my functions as types. As I looked through Scott’s amazing F# for fun and profit, I really didn’t find any example on how to implement this. I therefore sent and e-mail to Scott and he was really humble and helpful and provided me this piece of code:

module CardGameImplementation =
    open CardGame

    exception DeckIsEmptyException

    let deal: Deal = 
       fun deck -> 
          match deck with
          | topCard::rest -> (rest,topCard)
          | [] -> raise DeckIsEmptyException

    let illegalDeal: Deal = 
       fun deck -> 
          let aceHearts = (Heart,Ace) // sneak in a card!
          match deck with
          | _::rest -> (rest,aceHearts)
          | [] -> raise DeckIsEmptyException

So the trick was just to implement your function types as lambdas, which is nice.

With this receipt in mind I decided that I wanted to implement a card-game based on the card domain provided by Scott, I ended up modifying it a bit. The chosen game was: War, probably the easiest game to play and (maybe) therefore also the easiest game to implement,

I searched for war card game on Google and the following website showed up:

The rules are described as: In the basic game there are two players and you use a standard 52 card pack. Cards rank as usual from high to low: A K Q J T 9 8 7 6 5 4 3 2. Suits are ignored in this game.

Deal out all the cards, so that each player has 26. Players do not look at their cards, but keep them in a packet face down. The object of the game is to win all the cards.

Both players now turn their top card face up and put them on the table. Whoever turned the higher card takes both cards and adds them (face down) to the bottom of their packet. Then both players turn up their next card and so on.

If the turned up cards are equal there is a war. The tied cards stay on the table and both players play the next card of their pile face down and then another card face-up. Whoever has the higher of the new face-up cards wins the war and adds all six cards face-down to the bottom of their packet. If the new face-up cards are equal as well, the war continues: each player puts another card face-down and one face-up. The war goes on like this as long as the face-up cards continue to be equal. As soon as they are different the player of the higher card wins all the cards in the war.

The game continues until one player has all the cards and wins. This can take a long time.

 1 module CardGameWarDomain =
 2   type Suit = Club | Diamond | Spade | Heart
 3   type Rank =
 4     | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten
 5     | Jack | Queen | King | Ace
 6   type Card = Suit * Rank
 7   type Deck = Card list
 8   type PlayerName = string
 9   type Player = {Name:PlayerName; Deck:Deck}
10   type Pile = (PlayerName option * Card list) list
11   type Deal = (Deck * Player list) -> Player list
12   type Battle = Player list -> (Player list * Pile)
13   type War = (Player list * Pile) -> (Player list * Pile)
14   type PickPile = (Player * Pile) -> Player
15   type Game = (Deck * Player list) -> Player

As I mention above, I made a few additions and subtractions to the domain. As Scott’s also says in the video, that this approach is so clear and concise that should be enough to understand what the application will do, so I’m not going to explain the model.

In order to make the implementation easier and more clean I can already think of a couple of functions that could be useful to a card game implementation: random and shuffle for mixing the cards, Cartesian product to create the deck of cards, etc.

 1 module Utils =
 2   open Microsoft.FSharp.Reflection
 3   
 4   let rand = System.Random()
 5   
 6   let unionCases<'a>() =
 7     FSharpType.GetUnionCases(typeof<'a>)
 8     |> Array.map (fun x -> FSharpValue.MakeUnion(x, [||]) :?> 'a)
 9     |> Array.toList
10     
11   let cartProd xs ys =
12     xs |> List.collect (fun x -> ys |> List.map (fun y -> x,y))
13     
14   let swap (a: _[]) x y =
15     let t = a.[x]
16     a.[x] <- a.[y]
17     a.[y] <- t
18     
19   let shuffle xs = // Knuth's shuffle algorithm
20     let xs' = xs |> List.toArray
21     xs' |> Array.iteri(fun i _ -> swap xs' i (rand.Next(i, xs'.Length)))
22     xs' |> Array.toList

The implementation of the domain

And finally to the implementation of the game. As we use to state in the F# Community, code should be easily readable. Please don’t hesitate to leave comments at the bottom of blog post if you don’t understand some parts of the code and I’ll try to explain it as best as possible. Remark: I might have a bad habit of using very small, usually a letter or two, to define my values, please bare with me.

  1 module CardGameWar =
  2   
  3   open System
  4   open CardGameWarDomain
  5   open Utils
  6   
  7   let rec round players cards (pile:Pile) = function
  8     | [] ->
  9       let tags = players |> List.map(fun x -> x.Name |> Some)
 10       let cards' = cards |> List.map(fun x -> [x])
 11       let _,cards'' = pile |> List.unzip
 12       let tagAndCards = (None, cards'' |> List.fold(fun a x -> a @ x) [])
 13       players,tagAndCards::((tags,cards') ||> List.zip)
 14     | p::players' ->
 15       match p.Deck with
 16         | [] -> round players cards pile players'
 17         | c::cards' ->
 18           let p' = {p with Deck = cards'}
 19           round (p'::players) (c::cards) pile players'
 20           
 21   let battle : Battle =
 22     fun (players : Player list) ->
 23       players |> round [] [] []
 24       
 25   let rec war : War = // call round twice to skip first card
 26     fun (players : Player list, pile : Pile) ->
 27       let players', pile' = players |> round [] [] pile 
 28       (pile',players') ||> round [] []
 29       
 30   let pickPile : PickPile =
 31     fun (player: Player, pile: Pile) ->
 32       printfn "player: %A, pile: %A" (player.Name) pile
 33       let _,cs = pile |> List.unzip
 34       {player with Deck = player.Deck @ (cs |> List.reduce(@))}
 35       
 36   let deck () : Deck =
 37     (unionCases<Suit>(), unionCases<Rank>()) ||> cartProd |> shuffle
 38     
 39   let players n : Player list =
 40     let ns = Array.append [|'a' .. 'z'|] [|'A' .. 'Z'|]
 41     
 42     let rec players' acc = function
 43       | 0 -> acc
 44       | i when i <= 4 ->
 45         let p = {Name = string ns.[i-1]; Deck = []}
 46         players' (p::acc) (i-1)
 47       | _ -> failwith "Only max 4 players are allowed"
 48     players' [] n
 49     
 50   let deal : Deal =
 51     fun (deck : Deck, players : Player list) ->
 52       let n = players |> List.length
 53       let rec deal' (ps : Player list) = function
 54         | [] -> ps
 55         | c::cs ->
 56           let p,ps' = ps |> List.head, ps |> List.tail
 57           let p' = {p with Deck = c::p.Deck}
 58           deal' (p'::ps' |> List.permute(fun i -> (i + 1) % n)) cs
 59       deck |> deal' players
 60       
 61   let game : Game =
 62     fun (deck : Deck, players : Player list) ->
 63       let ps = deal(deck, players)
 64       
 65       let rec game' (pile : Pile) = function
 66         | []  -> failwith "No winners" 
 67         | [p] -> p
 68         | ps' ->
 69           let ps'',pile' =
 70             match pile |> List.isEmpty with
 71               | true  ->  ps'       |> battle
 72               | false -> (ps',pile) |> war
 73           // based on win or loose -> check pile for 1 only high card
 74           // then add pile to winner or pass pile and plays to next "war".
 75           let max =
 76             pile'
 77             |> List.filter(fun (x,y) -> x.IsSome)
 78             |> List.maxBy(fun (x,y) -> y |> List.head |> snd)
 79             |> fun (x,ys) -> ys |> List.head |> snd
 80           let winner =
 81             pile'
 82             |> List.filter(fun (x,y) -> x.IsSome)
 83             |> List.filter(fun (x,ys) -> (ys |> List.head |> snd) = max)
 84           let ps''',pile'' =
 85             let n = ps'' |> List.length
 86             
 87             let rec findPlayer tag = function
 88               | x::xs when (x.Name = tag) -> x,xs
 89               | xs -> findPlayer tag (xs |> List.permute(fun i -> (i + 1) % n))
 90               
 91             match winner |> List.length = 1 with
 92               | true ->
 93                 let tag,_ = winner |> List.head
 94                 let tag' = tag |> function | Some v -> v | None -> String.Empty
 95                 let h,t = ps'' |> findPlayer tag'
 96                 ((h,pile') |> pickPile)::t,[]
 97               | false -> ps'',pile'
 98           
 99           game' pile'' ps'''
100           
101       ps |> game' []
102       
103   let simulation n = (deck (),players n) |> game
104 
105 printfn "The winner is: %A" (CardGameWar.simulation 4)

So based on this approach, the whole application can be encapsulated in types which is really, really, really cool !!!

All

In order to watch who wins and collects each pile, I added a print statement in the let pickPile : PickPile function. The output can be seen below:

[ mon@mbai7 tmp ] fsi CardGameWar.fsx
player: "c", pile: [(null, []); (Some "d", [(Heart, Five)]); (Some "c", [(Club, Ace)]);
 (Some "b", [(Heart, Jack)]); (Some "a", [(Club, Five)])]
player: "d", pile: [(null, []); (Some "d", [(Heart, Ace)]); (Some "a", [(Diamond, Six)]);
 (Some "b", [(Club, Three)]); (Some "c", [(Diamond, Three)])]
player: "a", pile: [(null, []); (Some "c", [(Heart, Six)]); (Some "b", [(Diamond, Jack)]);
 (Some "a", [(Spade, Queen)]); (Some "d", [(Diamond, Ten)])]
player: "b", pile: [(null, []); (Some "b", [(Club, King)]); (Some "c", [(Spade, Two)]);
 (Some "d", [(Club, Six)]); (Some "a", [(Spade, Eight)])]
player: "b", pile: [(null, []); (Some "a", [(Spade, Four)]); (Some "d", [(Club, Two)]);
 (Some "c", [(Spade, Six)]); (Some "b", [(Spade, Seven)])]
player: "c", pile: [(null, []); (Some "c", [(Heart, Queen)]); (Some "d", [(Diamond, Seven)]);
 (Some "a", [(Heart, Two)]); (Some "b", [(Heart, Nine)])]
player: "b", pile: [(null, []); (Some "b", [(Diamond, Ace)]); (Some "a", [(Club, Seven)]);
 (Some "d", [(Heart, Four)]); (Some "c", [(Spade, Jack)])]
player: "d", pile: [(null,
  [(Diamond, Nine); (Diamond, King); (Heart, King); (Spade, King);
   (Diamond, Two); (Club, Nine); (Diamond, Eight); (Spade, Three)]);
 (Some "c", [(Club, Eight)]); (Some "d", [(Spade, Ace)]);
 (Some "a", [(Diamond, Four)]); (Some "b", [(Spade, Nine)])]
player: "d", pile: [(null, []); (Some "c", [(Heart, Three)]); (Some "b", [(Heart, Ten)]);
 (Some "a", [(Spade, Five)]); (Some "d", [(Club, Queen)])]
player: "d", pile: [(null, []); (Some "a", [(Diamond, Five)]); (Some "b", [(Heart, Seven)]);
 (Some "c", [(Heart, Eight)]); (Some "d", [(Club, Ten)])]
player: "c", pile: [(null, []); (Some "c", [(Diamond, Queen)]); (Some "b", [(Club, Four)]);
 (Some "a", [(Club, Jack)]); (Some "d", [(Spade, Ten)])]
player: "d", pile: [(null, []); (Some "d", [(Heart, Ace)]); (Some "a", [(Heart, Six)]);
 (Some "b", [(Club, King)]); (Some "c", [(Heart, Five)])]
player: "c", pile: [(null, []); (Some "c", [(Club, Ace)]); (Some "b", [(Spade, Two)]);
 (Some "a", [(Diamond, Jack)]); (Some "d", [(Diamond, Six)])]
player: "a", pile: [(null, []); (Some "d", [(Club, Three)]); (Some "a", [(Spade, Queen)]);
 (Some "b", [(Club, Six)]); (Some "c", [(Heart, Jack)])]
player: "a", pile: [(null, []); (Some "d", [(Diamond, Three)]); (Some "c", [(Club, Five)]);
 (Some "b", [(Spade, Eight)]); (Some "a", [(Diamond, Ten)])]
player: "c", pile: [(null, []); (Some "b", [(Spade, Four)]); (Some "c", [(Heart, Queen)]);
 (Some "d", [(Diamond, Nine)]); (Some "a", [(Club, Three)])]
player: "d", pile: [(null, []); (Some "b", [(Club, Two)]); (Some "a", [(Spade, Queen)]);
 (Some "d", [(Diamond, King)]); (Some "c", [(Diamond, Seven)])]
player: "d", pile: [(null, []); (Some "a", [(Club, Six)]); (Some "b", [(Spade, Six)]);
 (Some "c", [(Heart, Two)]); (Some "d", [(Heart, King)])]
player: "d", pile: [(null, []); (Some "c", [(Heart, Nine)]); (Some "b", [(Spade, Seven)]);
 (Some "a", [(Heart, Jack)]); (Some "d", [(Spade, King)])]
player: "b", pile: [(null, []); (Some "a", [(Diamond, Three)]); (Some "b", [(Diamond, Ace)]);
 (Some "c", [(Diamond, Queen)]); (Some "d", [(Diamond, Two)])]
player: "d", pile: [(null, []); (Some "a", [(Club, Five)]); (Some "d", [(Club, Nine)]);
 (Some "c", [(Club, Four)]); (Some "b", [(Club, Seven)])]
player: "c", pile: [(null, []); (Some "a", [(Spade, Eight)]); (Some "b", [(Heart, Four)]);
 (Some "c", [(Club, Jack)]); (Some "d", [(Diamond, Eight)])]
player: "b", pile: [(null, []); (Some "b", [(Spade, Jack)]); (Some "a", [(Diamond, Ten)]);
 (Some "d", [(Spade, Three)]); (Some "c", [(Spade, Ten)])]
player: "c", pile: [(null, []); (Some "c", [(Club, Ace)]); (Some "d", [(Club, Eight)]);
 (Some "b", [(Diamond, Three)])]
player: "d", pile: [(null,
  [(Diamond, Ace); (Spade, Ace); (Spade, Two); (Diamond, Jack); (Diamond, Four);
   (Diamond, Queen)]); (Some "b", [(Diamond, Two)]); (Some "d", [(Spade, Nine)]);
 (Some "c", [(Diamond, Six)])]
player: "b", pile: [(null, []); (Some "b", [(Spade, Jack)]); (Some "c", [(Spade, Four)]);
 (Some "d", [(Heart, Three)])]
player: "c", pile: [(null, []); (Some "d", [(Heart, Ten)]); (Some "c", [(Heart, Queen)]);
 (Some "b", [(Diamond, Ten)])]
player: "c", pile: [(null, []); (Some "d", [(Spade, Five)]); (Some "b", [(Spade, Three)]);
 (Some "c", [(Diamond, Nine)])]
player: "d", pile: [(null, []); (Some "b", [(Spade, Ten)]); (Some "d", [(Club, Queen)]);
 (Some "c", [(Club, Three)])]
player: "b", pile: [(null, []); (Some "b", [(Spade, Jack)]); (Some "c", [(Spade, Eight)]);
 (Some "d", [(Diamond, Five)])]
player: "d", pile: [(null, []); (Some "d", [(Heart, Seven)]); (Some "c", [(Heart, Four)]);
 (Some "b", [(Spade, Four)])]
player: "c", pile: [(null, []); (Some "b", [(Heart, Three)]); (Some "c", [(Club, Jack)]);
 (Some "d", [(Heart, Eight)])]
player: "b", pile: [(null, []); (Some "b", [(Spade, Jack)]); (Some "d", [(Club, Ten)]);
 (Some "c", [(Diamond, Eight)])]
player: "d", pile: [(null,
  [(Club, Ace); (Heart, Ace); (Spade, Eight); (Diamond, Five); (Heart, Six);
   (Club, Eight)]); (Some "c", [(Diamond, Three)]); (Some "d", [(Club, King)]);
 (Some "b", [(Spade, Jack)])]
player: "d", pile: [(null,
  [(Heart, Ten); (Club, Ten); (Heart, Five); (Club, Two); (Diamond, Eight);
   (Heart, Queen)]); (Some "c", [(Diamond, Ten)]); (Some "d", [(Spade, Queen)])]
player: "d", pile: [(null, []); (Some "c", [(Spade, Five)]); (Some "d", [(Diamond, King)])]
player: "d", pile: [(null, []); (Some "c", [(Spade, Three)]); (Some "d", [(Diamond, Seven)])]
player: "c", pile: [(null, []); (Some "c", [(Diamond, Nine)]); (Some "d", [(Club, Six)])]
player: "d", pile: [(null, []); (Some "d", [(Spade, Six)]); (Some "c", [(Heart, Three)])]
player: "c", pile: [(null, []); (Some "c", [(Club, Jack)]); (Some "d", [(Heart, Two)])]
player: "d", pile: [(null, []); (Some "d", [(Heart, King)]); (Some "c", [(Heart, Eight)])]
player: "d", pile: [(null,
  [(Diamond, Nine); (Heart, Nine); (Spade, Seven); (Club, Six); (Club, Jack);
   (Heart, Jack); (Spade, King); (Heart, Two)]); (Some "d", [(Club, Five)])]

The last part out-putted by the game is the winner, in this case “d”, who ends up with all the 52 cards in his deck.

The winner is: {Name = "d";
 Deck =
  [(Club, Nine); (Club, Four); (Club, Seven); (Diamond, Ace); (Spade, Ace);
   (Spade, Two); (Diamond, Jack); (Diamond, Four); (Diamond, Queen);
   (Diamond, Two); (Spade, Nine); (Diamond, Six); (Spade, Ten); (Club, Queen);
   (Club, Three); (Heart, Seven); (Heart, Four); (Spade, Four); (Club, Ace);
   (Heart, Ace); (Spade, Eight); (Diamond, Five); (Heart, Six); (Club, Eight);
   (Diamond, Three); (Club, King); (Spade, Jack); (Heart, Ten); (Club, Ten);
   (Heart, Five); (Club, Two); (Diamond, Eight); (Heart, Queen); (Diamond, Ten);
   (Spade, Queen); (Spade, Five); (Diamond, King); (Spade, Three);
   (Diamond, Seven); (Spade, Six); (Heart, Three); (Heart, King); (Heart, Eight);
   (Diamond, Nine); (Heart, Nine); (Spade, Seven); (Club, Six); (Club, Jack);
   (Heart, Jack); (Spade, King); (Heart, Two); (Club, Five)];}

War by Edwin Starr (1969)

Finally but not least, we need to remember what war is really good for: “War, huh, yeah What is it good for Absolutely nothing Uh-huh War, huh, yeah What is it good for Absolutely nothing Say it again, y’all”.

comments powered by Disqus