Domain-driven design, F# types and War

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

Video: Scott Wlaschin: Domain Driven Design, F# and Types

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

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

Blog: Mr. Mathiesen