第10回オフラインリアルタイムどう書くの参考問題
(4/20)役の判定をアクティブパターンに変えた。
(4/21)気に入らない関数名を変えた。
parse関数は前からパースせずに後ろからパースした方が短くなったかも。
poker.fs
type Suit = Spade | Heart | Diamond | Club
type Rank = R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | RJ | RQ | RK | RA
type Card = Rank * Suit
type Hand = Card * Card * Card * Card * Card

let toList (c0,c1,c2,c3,c4) = [c0;c1;c2;c3;c4]

let cardToNums (c:Card) =
  match fst c with
  | R2  -> [2]
  | R3  -> [3]
  | R4  -> [4]
  | R5  -> [5]
  | R6  -> [6]
  | R7  -> [7]
  | R8  -> [8]
  | R9  -> [9]
  | R10 -> [10]
  | RJ  -> [11]
  | RQ  -> [12]
  | RK  -> [13]
  | RA  -> [1;14]

let areSameSuit (xs:Card list) =
  match xs with
  | []    -> false
  | c::cs -> List.forall (fun x -> snd x = snd c) cs

let areSequential (xs:int list) =
  List.sort xs
  |> Seq.pairwise
  |> Seq.forall (fun (x,y) -> x + 1 = y)

let product (xss:'a list list) =
  let folder (xs:'a list) (xss:'a list list)=
    let (>>=) xs f = List.collect f xs
    xs >>= fun y ->
      xss >>= fun ys ->
        [y::ys]
  List.foldBack folder xss [[]]

let areSequentialNum (xs:Card list) =
  List.map cardToNums xs
  |> product
  |> List.exists areSequential

let (|Straight|_|) (h:Hand) =
  if h |> toList |> areSequentialNum then Some Straight else None

let (|Flush|_|) (h:Hand) =
  if h |> toList |> areSameSuit then Some Flush else None

let (|StraightFlush|_|) (h:Hand) =
  let l = toList h
  if areSameSuit l && areSequentialNum l then Some StraightFlush else None

let (|RoyalFlush|_|) (h:Hand) =
  let l = toList h
  let areRoyal = List.map fst >> List.sort >> (=) [R10; RJ; RQ; RK; RA]
  if areSameSuit l && areRoyal l then Some RoyalFlush else None

let removeAt i xs =
  Seq.append (Seq.take i xs) (Seq.skip (i+1) xs)
  |> Seq.toList

let removeOne xs =
  List.map (fun i -> removeAt i xs) [0..(List.length xs - 1)]

let allExceptOne pred  =
  toList >> removeOne >> List.exists pred

let (|FourFlush|_|) (h:Hand) =
  if allExceptOne areSameSuit h then Some FourFlush else None

let (|FourStraight|_|) (h:Hand) =
  if allExceptOne areSequentialNum h then Some FourStraight else None

let (|FourStraightFlush|_|) (h:Hand) =
  let areStraightFlush l = areSameSuit l && areSequentialNum l
  if allExceptOne areStraightFlush h then Some FourStraightFlush else None

let show (h:Hand) =
  match h with
  | RoyalFlush        -> "RF"
  | StraightFlush     -> "SF"
  | Flush             -> "FL"
  | Straight          -> "ST"
  | FourStraightFlush -> "4SF"
  | FourFlush         -> "4F"
  | FourStraight      -> "4S"
  | _                 -> "-"

let parse (s:string) : Hand option =
  let parseSuit r xs =
    match xs with
    | 's' :: ys -> Some ((r,Spade)  ,ys)
    | 'h' :: ys -> Some ((r,Heart)  ,ys)
    | 'd' :: ys -> Some ((r,Diamond),ys)
    | 'c' :: ys -> Some ((r,Club)   ,ys)
    | _         -> None
  let parseCard xs =
    match xs with
    | '2' :: ys        -> parseSuit R2 ys
    | '3' :: ys        -> parseSuit R3 ys
    | '4' :: ys        -> parseSuit R4 ys
    | '5' :: ys        -> parseSuit R5 ys
    | '6' :: ys        -> parseSuit R6 ys
    | '7' :: ys        -> parseSuit R7 ys
    | '8' :: ys        -> parseSuit R8 ys
    | '9' :: ys        -> parseSuit R9 ys
    | '1' :: '0' :: ys -> parseSuit R10 ys
    | 'J' :: ys        -> parseSuit RJ ys
    | 'Q' :: ys        -> parseSuit RQ ys
    | 'K' :: ys        -> parseSuit RK ys
    | 'A' :: ys        -> parseSuit RA ys
    | _ -> None
  let rec parseCards cs xs =
    match xs with
    | [] -> cs
    | _  -> match parseCard xs with
            | Some (c,ys) -> parseCards (c::cs) ys
            | None        -> []

  match parseCards [] (Seq.toList s) with
  | c4::c3::c2::c1::c0::[] -> Some (c0,c1,c2,c3,c4)
  | _                      -> None

(* for test *)

type TestResult = Success | Failure

let test target expected =
  let areSame expected actual =
    if expected = actual then Success else Failure
  let result =
    match parse target with
    | Some h -> show h |> areSame expected
    | None   -> Failure
  printfn "%A" result

[<EntryPoint>]
let main args =
  (*  0 *) test "Qs9s3dJd10h" "4S"
  (*  1 *) test "KdAdJd10dQd" "RF"
  (*  2 *) test "QhJhKhAh10h" "RF"
  (*  3 *) test "10dAdJsQdKd" "ST"
  (*  4 *) test "Kd10dAdJd3d" "FL"
  (*  5 *) test "4d3d2dAd5d" "SF"
  (*  6 *) test "5d5d2d3dAd" "FL"
  (*  7 *) test "4d2sAd5d3d" "ST"
  (*  8 *) test "As10dJdQdKd" "ST"
  (*  9 *) test "10d10dQdAsJd" "4F"
  (* 10 *) test "AcJd10dQdKd" "ST"
  (* 11 *) test "Kd2sJdAdQd" "4SF"
  (* 12 *) test "JdAdQcKd2s" "4S"
  (* 13 *) test "KdAdKdJd2s" "4F"
  (* 14 *) test "As2dKdQdJd" "4F"
  (* 15 *) test "AsKdQd2dJh" "4S"
  (* 16 *) test "QhAd2s3dKd" "-"
  (* 17 *) test "Ad4dKh3s2d" "4S"
  (* 18 *) test "3d2dAh5d4s" "ST"
  (* 19 *) test "QcKdAs2dJd" "4S"
  (* 20 *) test "2dQcJdAs10d" "-"
  (* 21 *) test "4d7d5s3c2d" "4S"
  (* 22 *) test "7d5s4dAd3c" "-"
  (* 23 *) test "3s8s10sQs6s" "FL"
  (* 24 *) test "6hAh3h2h8h" "FL"
  (* 25 *) test "3h4hJh9hQh" "FL"
  (* 26 *) test "3s6s5s2sQs" "FL"
  (* 27 *) test "9d3cKdQc2c" "-"
  (* 28 *) test "5sKs7hQcKh" "-"
  (* 29 *) test "Ad6d7h7c9h" "-"
  (* 30 *) test "10h4cAh6s10c" "-"
  (* 31 *) test "9sKsJcQs10d" "ST"
  (* 32 *) test "5d3c2cAs4c" "ST"
  (* 33 *) test "KcQs9c10sJs" "ST"
  (* 34 *) test "9d8s10hJdQd" "ST"
  (* 35 *) test "6c5s10h7d4c" "4S"
  (* 36 *) test "QhJcKsAh8c" "4S"
  (* 37 *) test "JsQc3h10cKs" "4S"
  (* 38 *) test "10c9h7hAd8d" "4S"
  (* 39 *) test "3d4dKd8d5c" "4F"
  (* 40 *) test "10h3hQh9h2s" "4F"
  (* 41 *) test "Qh5h7h9h6c" "4F"
  (* 42 *) test "6s8s7s3sKc" "4F"
  (* 43 *) test "10h8h9hJhQh" "SF"
  (* 44 *) test "10h9hQhKhJh" "SF"
  (* 45 *) test "6d4d7d5d3d" "SF"
  (* 46 *) test "6h9h7h5h8h" "SF"
  (* 47 *) test "Ac6s4s3s5s" "4SF"
  (* 48 *) test "3c9d2c5c4c" "4SF"
  (* 49 *) test "Kh2sQh10hJh" "4SF"
  (* 50 *) test "4h5h2h3h4s" "4SF"
  (* 51 *) test "Js10sAsQsKs" "RF"
  (* 52 *) test "10dKdQdAdJd" "RF"
           0