Source

class / war.ml

open Core.Std

module Stats : sig
  val log_war : unit -> unit
  val log_round : unit -> unit
  val to_string : unit -> string
end = struct
  type t = {
    mutable wars: int;
    mutable rounds: int
  }

  let stats = { wars = 0; rounds = 0 }

  let to_string () = sprintf "rounds: %i\nwars: %i" stats.rounds stats.wars
  let log_war () = stats.wars <- stats.wars + 1
  let log_round () = stats.rounds <- stats.rounds + 1
end

module Suit = struct
  type t =
    | Hearts
    | Clubs
    | Diamonds
    | Spades

  let all = [Hearts; Clubs; Diamonds; Spades]

  let of_int i =
    match i with
    | 0 -> Hearts
    | 1 -> Clubs
    | 2 -> Diamonds
    | 3 -> Spades
    | _ -> raise (Invalid_argument "Suit.of_int i must be between 0 and 3 (inclusive)")
  ;;

  let to_string t =
    match t with
    | Hearts   -> "hearts"
    | Clubs    -> "clubs"
    | Diamonds -> "diamonds"
    | Spades   -> "spades"
  ;;
end

module Card : sig
  type t
  
  val create : Suit.t -> int -> t
  val compare : t -> t -> int
  val to_string : t -> string
end = struct
  type t = Suit.t * int

  let compare (_,v1) (_,v2) = compare v1 v2

  let to_string (s,v) =
    let v_string =
      match v with
      | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 -> Int.to_string v
      | 11 -> "jack"
      | 12 -> "queen"
      | 13 -> "king"
      | 14 -> "ace"
      | _  -> assert false
    in
    sprintf "%s of %s" v_string (Suit.to_string s)
  ;;

  let create suit value =
    match value with
    | 1 -> (suit, 14)
    | v -> 
        if 2 <= v && v <= 13 then (suit, value)
        else raise (Invalid_argument "value must be between 1 and 13 (inclusive)")
  ;;
end

module Deck = struct
  Random.self_init ();;

  type t = Card.t list

  let default =
    let values = [1;2;3;4;5;6;7;8;9;10;11;12;13] in
    List.map Suit.all ~f:(fun s -> List.map values ~f:(fun v -> Card.create s v)) 
    |! List.flatten
  ;;

  let shuffle t =
    List.map t ~f:(fun c -> Random.float 1., c)
    |! List.sort ~cmp:(fun (r1,_) (r2,_) -> compare r1 r2)
    |! List.map ~f:snd
  ;;

  let to_string t = String.concat ~sep:"\n" (List.map t ~f:Card.to_string)
end

let rec war pile p1 p2 =
  Stats.log_war ();
  match p1,p2 with
  | p1 :: p2 :: p3 :: w1 :: rest1, p4 :: p5 :: p6 :: w2 :: rest2 ->
      let pile = Deck.shuffle [p1;p2;p3;p4;p5;p6;w1;w2] @ pile in
      begin match Card.compare w1 w2 with
      | -1 -> rest1, rest2 @ pile 
      | 1  -> rest1 @ pile, rest2
      | 0  -> war pile rest1 rest2
      | _  -> assert false
      end
  | _ :: _ :: _ :: _ :: _, _ -> pile @ p1 @ p2, []
  | _, _ :: _ :: _ :: _ :: _ -> [], pile @ p1 @ p2
  | _ -> assert false
;;

let rec play p1 p2 =
  Stats.log_round ();
  match p1,p2 with
  | [],_ -> `Two
  | _,[] -> `One
  | c1 :: rest1, c2 :: rest2 ->
      match Card.compare c1 c2 with
      | -1 -> play rest1 (rest2 @ Deck.shuffle [c1; c2])
      | 1  -> play (rest1 @ Deck.shuffle [c1; c2]) rest2
      | 0  -> 
          let p1,p2 = war [c1;c2] rest1 rest2 in
          play p1 p2
      | _  -> assert false
;;

let main () =
  let deck = Deck.shuffle Deck.default in
  let p1,p2 = 
    List.fold_left deck ~init:([],[]) ~f:(fun (cur,next) c -> (next, c :: cur))
  in
  let result = play p1 p2 in
  printf "%s\n" (Stats.to_string ());
  match result with
  | `One -> printf "player 1 wins!\n%!"
  | `Two -> printf "player 2 wins!\n%!"
;;

let () = main ()