13
\$\begingroup\$

I'm a F# newbie, and would like to share my implementation of the Poker Hands Kata problem to get some feedback.

module PokerHands

open System.Text.RegularExpressions

type Figure = 
    | Two  | Three | Four  | Five 
    | Six  | Seven | Eight | Nine 
    | Ten  | Jack  | Queen | King | Ace

type Suit = Diamonds | Spades | Hearts | Clubs

type Card = Figure * Suit

type Rank =
  | HighCard        of Figure * Rank option
  | Pair            of Figure * Rank
  | TwoPair         of Figure * Figure * Rank
  | ThreeOfKind     of Figure
  | Straight        of Figure
  | Flush           of Rank
  | FullHouse       of Figure
  | FourOfKind      of Figure
  | StraightFlush   of Rank

type Player = {
    Name: string;
    Cards: Card list;
    Hand: Rank;
}

let SortDesc sequence = sequence |> Seq.toList |> List.sortWith (fun x y -> compare y x)
let SortDescBy f sequence = sequence |> List.sortWith (fun x y -> compare (f y) (f x))

let rec BuildHighCard (figures : Figure list) =
    match SortDesc figures with
    | [h] -> HighCard(h, None)
    | h :: t -> HighCard(h, Some(BuildHighCard(t)))
    | _ -> failwith "empty"

let isFlush (cards : Card list) =
    cards |> Seq.distinctBy snd |> Seq.length = 1

let isStraight (cards : Card list) =
    let figs = cards |> List.map fst |> List.sort
    let flag = ref true
    for i in {1 .. List.length figs - 1} do
        if (compare figs.[i-1] figs.[i]) <> -1 then flag.Value <- false
    flag.Value 

let (|IsStraightFlush|_|) cards = 
    if isFlush cards && isStraight cards then Some(StraightFlush(BuildHighCard(cards |> List.map fst))) else None

let (|IsFlush|_|) cards = 
    if isFlush cards then Some(Flush(BuildHighCard(cards |> List.map fst))) else None

let (|IsStraight|_|) cards = 
    if isStraight cards then Some(Straight(cards |> List.minBy fst |> fst)) else None

let (|IsGrouped|_|) (counts : int list) cards  =
    let groups = cards |> Seq.countBy fst |> Seq.toList |> SortDescBy snd
    if groups |> List.map snd = counts then Some(groups |> List.map fst) else None

let DetermineRank (cards : Card list) = 
    match cards with
    | IsStraightFlush straightFlush -> straightFlush
    | IsGrouped [4;1] [f;_]         -> FourOfKind(f)
    | IsGrouped [3;2] [f;_]         -> FullHouse(f)
    | IsFlush flush                 -> flush
    | IsStraight straight           -> straight
    | IsGrouped [3;1;1] [f;_;_]     -> ThreeOfKind(f)
    | IsGrouped [2;2;1] [f1;f2;rest]-> TwoPair(List.max [f1;f2], List.min [f1;f2], BuildHighCard([rest]))
    | IsGrouped [2;1;1;1] (h :: t)  -> Pair(h, BuildHighCard(t))
    | _                             -> BuildHighCard(cards |> List.map fst)

let ParsePlayers input = 
    let r = Regex("(\w+):( [2-9,T,J,Q,K,A][H,C,D,S]){5}")
    let matches = input |> r.Matches

    let parseCard (capture : Capture) =
        let literal = capture.Value.Trim()
        let figure = 
            match literal.[0] with
            | '2' -> Two
            | '3' -> Three
            | '4' -> Four
            | '5' -> Five
            | '6' -> Six
            | '7' -> Seven
            | '8' -> Eight
            | '9' -> Nine
            | 'T' -> Ten
            | 'J' -> Jack
            | 'Q' -> Queen
            | 'K' -> King
            | 'A' -> Ace
            | _ -> failwith "unrecognized figure"
        let suit = 
            match literal.[1] with
            | 'D' -> Diamonds
            | 'S' -> Spades
            | 'H' -> Hearts
            | 'C' -> Clubs
            | _ -> failwith "unrecognized suit"
        (figure, suit)

    let parsePlayer (input : Match) =
        let name = input.Groups.[1].Value
        let cards =
            input.Groups.[2].Captures
            |> Seq.cast
            |> Seq.map parseCard
            |> Seq.toList
        {Name = name; Cards = cards; Hand = DetermineRank cards}

    matches
    |> Seq.cast
    |> Seq.map parsePlayer
    |> Seq.toArray

type Score =
    | Win of string * string
    | Tie

let rec Rationale wonHand lostHand =
    let (|RanksEq|_|) (wonHand,lostHand) =
        match wonHand, lostHand with
        | StraightFlush(w), StraightFlush(l)                            -> Some (Rationale w l)
        | Flush(w), Flush(l)                                            -> Some (Rationale w l)
        | TwoPair(w1,w2,r1), TwoPair(l1,l2,r2) when w1 = l1 && w2 = l2  -> Some (Rationale r1 r2)
        | Pair(f1,r1), Pair(f2,r2) when f1 = f2                         -> Some (Rationale r1 r2)
        | HighCard(w,r1), HighCard(l,r2) when w = l                     -> Some (Rationale (Option.get r1) (Option.get r2))
        | _ -> None

    match wonHand, lostHand with
    | RanksEq(res)          -> res
    | StraightFlush(_), _   -> "straight flush"
    | FourOfKind(f), _      -> sprintf "four of kind: %A" f
    | FullHouse(f), _       -> "full house"
    | Flush(_), _           -> "flush"
    | Straight(f), _        -> "straight"
    | ThreeOfKind(f), _     -> sprintf "three of kind: %A" f
    | TwoPair(f1,f2,_), _   -> sprintf "two pairs: %A + %A" f1 f2
    | Pair(f,_), _          -> sprintf "pair of: %A" f
    | HighCard(w,_), _      -> sprintf "high card: %A" w
    | _                     -> failwith "unhandled rationale"

let DetermineScore (players : Player array) =
    let c = compare (players.[0].Hand) (players.[1].Hand)
    if c = 0
        then Tie 
    else
        let winner = players |> Array.maxBy (fun p -> p.Hand)
        let looser = players |> Array.minBy (fun p -> p.Hand)
        Win(winner.Name, Rationale winner.Hand looser.Hand)

let FormatScore score =
    match score with
    | Win(winner, rationale) -> sprintf "%s wins - %s" winner rationale
    | Tie -> "Tie"

let CompareHands input =
    input
    |> ParsePlayers
    |> DetermineScore
    |> FormatScore

At the first glance, what could look strange is the Rank discriminated union. I decided to implement it this way so that I have the comparing of Ranks out of the box.

Another thing that should require explanation is the Rationale function: It resolves a string rationale for the winning rank, and the inner RanksEq active pattern solves cases such as where both ranks are Pairs - here the rationale should return "high card".

Here's a list of my concerns:

  1. isStraight function - how to achieve a pure functional-looking function that would check if all elements in sequence are consecutive (in regards to a discriminated union type)?
  2. IsStraight, IsFlush, IsStraightFlush active patterns, these three feel like they have something in common - could they be somehow merged into one active pattern?
  3. DetermineScore function - I don't like usage of Array.min and max for getting a lower and higher value from a pair of values - is there a one-liner for this? i.e something returning a tuple Player * Player?

Any other comments about the code will be more than welcome.

\$\endgroup\$

3 Answers 3

6
\$\begingroup\$

I like this! Your use of discriminated unions and active patterns is quite elegant, I think. (Although exploiting that compare on discriminated unions does what it does seems a bit of a hack–although I have a hard time justifying that sentiment.)

As to your concerns:

  1. Here is a manual way to do it functionally (replace the let flag ... flag.Value with this):

    let rec check = function 
            | x :: y :: zs -> compare x y <> -1 && check (y :: zs) 
            | [x] -> true
            | _ -> false
    check figs
    

    For more on this style, see here. Alternatively, you could try to use combinators. If you're willing to compare only sequences of five cards, then maybe like this?

    List.toSeq cards |> Seq.distinct |> Seq.toList 
        |> function
           | [x;_;_;_;y] -> compare x y = -4
           | _ -> false
    
  2. I think these are fine. I don't think you should try to factor out the redundant looking BuildHighCard(cards |> List.map fst). I think if you did, you'd clutter your program rather than make it more readable. As it is, it's perfectly clear what's going on, yes?

  3. Yes:

    let winner, loser = Array.max players, Array.min players
    

But maybe already ParsePlayers return a tuple instead of an array?

Minor suggestion: You could implement SortDesc and SortDescBy as:

let SortDescBy f = List.sortWith (fun x y -> compare (f y) (f x))    

In general, when you write x |> f it means just f x. So when you define

let f x = x |> g ...

you can cut out the middle man and just do

let f = g ...
\$\endgroup\$
2
  • 1
    \$\begingroup\$ I think that your recursive check is wrong. It compares first with second and third with fourth, but not second with third. To fix it, you could change the recursive call to check (y :: zs). \$\endgroup\$
    – svick
    Mar 18, 2014 at 20:21
  • \$\begingroup\$ Quite! I updated the answer. \$\endgroup\$ Mar 18, 2014 at 20:50
4
\$\begingroup\$

The way I would implement isStraight in a functional way would be to take all pairs of i-th and (i+1)-th cards using Seq.zip and then ensure that all pairs satisfy the condition using Seq.forall:

let isStraight (cards : Card list) =
    let figs = cards |> Seq.map fst |> Seq.sort
    let pairs = Seq.zip figs (Seq.skip 1 figs)
    Seq.forall (fun pair -> compare (fst pair) (snd pair) = -1) pairs

(I use Seq instead of List, because List.zip behaves slightly differently and because there is no List.skip.)

\$\endgroup\$
1
  • \$\begingroup\$ I like zipping the sequences. You can write the third line with combinators: Seq.forall ((<||) compare >> (=) -1) pairs. In this case, yours is nicer, though. \$\endgroup\$ Mar 18, 2014 at 21:07
0
\$\begingroup\$

Turns out, there is a Seq.pairwise function which in this case will work as Seq.zip figs (Seq.skip 1 figs) does.

So follwing @svick and @soren-debois suggestions and using Seq.pairwise we can write the isStraight function like this:

let isStraight (cards : Card list) =
    cards
    |> Seq.map fst
    |> Seq.sort
    |> Seq.pairwise
    |> Seq.forall ((<||) compare >> (=) -1)
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.