Go Fish/OCaml

From Rosetta Code
Go Fish/OCaml is part of Go Fish. You may find other members of Go Fish at Category:Go Fish.
type pip = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | 
Jack | Queen | King | Ace
let pips = [Two; Three; Four; Five; Six; Seven; Eight; Nine; Ten;
Jack; Queen; King; Ace]
 
type suit = Diamonds | Spades | Hearts | Clubs
let suits = [Diamonds; Spades; Hearts; Clubs]
 
type card = pip * suit
 
let string_of_pip = function
| Two -> "Two"
| Three -> "Three"
| Four -> "Four"
| Five -> "Five"
| Six -> "Six"
| Seven -> "Seven"
| Eight -> "Eight"
| Nine -> "Nine"
| Ten -> "Ten"
| Jack -> "Jack"
| Queen -> "Queen"
| King -> "King"
| Ace -> "Ace"
 
let string_of_suit = function
| Diamonds -> "Diamonds"
| Spades -> "Spades"
| Hearts -> "Hearts"
| Clubs -> "Clubs"
 
let string_of_card (pip, suit) =
(Printf.sprintf "(%s-%s)" (string_of_pip pip) (string_of_suit suit))
 
 
let pip_of_card (pip, _) = (pip)
 
let deck =
List.concat (List.map (fun pip -> List.map (fun suit -> (pip, suit)) suits) pips)
 
 
type rank_state =
| Unknown (* Don't know if the opponent has any cards in that rank. *)
| No_cards (* Opponent has no cards there; I took them away, or I asked yet. *)
| Has_cards (* Opponent has cards there; they tried to get them off me and haven't booked them yet. *)
| Booked (* Someone has booked the rank. *)
 
let state_score = function
| Booked -> 0
| No_cards -> 1
| Unknown -> 2
| Has_cards -> 3
 
let string_of_state = function
| Booked -> "Booked"
| No_cards -> "No_cards"
| Unknown -> "Unknown"
| Has_cards -> "Has_cards"
 
let replace ((rank,_) as state) opp =
let rec aux acc = function
| (_rank,_)::tl when _rank = rank -> List.rev_append acc (state::tl)
| hd::tl -> aux (hd::acc) tl
| [] -> assert(false)
in
aux [] opp ;;
 
 
class virtual abstract_player =
object (s)
val mutable virtual cards : card list
val mutable virtual books : pip list
method virtual ask_rank : unit -> pip
method virtual give_rank : pip -> card list
method virtual notify_booked : pip -> unit
method virtual request_failed : pip -> unit
 
method private cards_given rank =
let matched, rest = List.partition (fun (pip,_) -> pip = rank) cards in
if List.length matched = 4 then begin
cards <- rest;
books <- rank :: books;
s#notify_booked rank;
(Some rank)
end
else (None)
 
method give_card (card : card) =
let rank = pip_of_card card in
cards <- card :: cards;
s#cards_given rank
 
method give_cards (_cards : card list) =
let rank =
match _cards with
| [] -> invalid_arg "empty list"
| hd::tl ->
List.fold_left
(fun rank1 (rank2,_) ->
if rank1 <> rank2
then invalid_arg "!= ranks"
else (rank1)
) (pip_of_card hd) tl
in
cards <- _cards @ cards;
s#cards_given rank
 
method give_rank rank =
let give, _cards = List.partition (fun (pip, _) -> pip = rank) cards in
cards <- _cards;
(give)
 
method books_length =
(List.length books)
 
method empty_hand =
cards = []
 
method private dump_cards() =
print_endline(String.concat ", " (List.map string_of_card cards));
 
end
 
 
 
class human_player =
object (s) inherit abstract_player
 
val mutable cards = []
val mutable books = []
 
method ask_rank() =
let ranks =
List.fold_left (fun acc card ->
let rank = pip_of_card card in
if List.mem rank acc
then (acc)
else (rank::acc)
)
[] cards
in
s#dump_cards();
Printf.printf "Ranks: %s\n%!" (String.concat ", " (List.map string_of_pip ranks));
let n = List.length ranks in
Printf.printf "choose from 1 to %d\n%!" n;
let get_int() =
try read_int()
with Failure "int_of_string" -> raise Exit
in
let rec aux() =
let d = get_int() in
if d <= 0 || d > n then aux() else (pred d)
in
let d = aux() in
(List.nth ranks d)
 
method notify_booked rank =
Printf.printf "Rank [%s] is now booked\n%!" (string_of_pip rank);
 
method request_failed rank = ()
end
 
 
 
class ai_player =
object (s) inherit abstract_player as parent
 
val mutable cards = []
val mutable books = []
val mutable opponent = List.map (fun rank -> (rank, Unknown)) pips
 
method private dump_state() =
let f (pip, state) =
Printf.sprintf "{%s:%s}" (string_of_pip pip) (string_of_state state)
in
print_endline(String.concat ", " (List.map f opponent));
 
method ask_rank() =
let ranks =
List.fold_left (fun acc card ->
let rank = pip_of_card card in
try
let _,n = List.find (fun (_rank,_) -> _rank = rank) acc in
(replace (rank, n+1) acc)
with Not_found ->
((rank,1)::acc)
)
[] cards
in
let f (rank,_) =
(state_score(List.assoc rank opponent))
in
let ranks = List.sort (fun a b -> (f b) - (f a)) ranks in
(* DEBUG
Printf.printf "Ranks: %s\n%!" (String.concat ", " (List.map string_of_pip ranks));
s#dump_state();
s#dump_cards();
*)

opponent <- List.sort (fun _ _ -> Random.int 9 - Random.int 9) opponent;
match ranks with
| [] -> Jack
| (x,_)::_ -> x
 
method give_cards (_cards : card list) =
let rank = pip_of_card(List.hd _cards) in
opponent <- replace (rank, No_cards) opponent;
(parent#give_cards _cards)
 
method give_rank rank =
opponent <- replace (rank, Has_cards) opponent;
(parent#give_rank rank)
 
method notify_booked rank =
opponent <- replace (rank, Booked) opponent
 
method request_failed rank =
opponent <- replace (rank, No_cards) opponent
end
 
 
 
class random_player =
object (s) inherit ai_player
 
method ask_rank() =
let ranks =
List.fold_left (fun acc card ->
let rank = pip_of_card card in
if List.mem rank acc
then (acc)
else (rank::acc)
)
[] cards
in
let n = List.length ranks in
let d = Random.int n in
(List.nth ranks d)
 
end
 
 
 
exception Empty_deck
let card_to_player deck player op =
match deck with
| card::deck ->
begin match player#give_card card with
| None -> ()
| Some rank -> op#notify_booked rank
end;
(deck)
| _ -> raise Empty_deck
 
let n_cards_to_player n deck player op =
let rec aux i deck =
if i >= n then (deck) else
let deck = card_to_player deck player op in
aux (succ i) deck
in
aux 0 deck ;;
 
 
let () =
Random.self_init();
let deck = List.sort (fun _ _ -> Random.int 9 - Random.int 9) deck in
let player_a = new human_player
and player_b = new ai_player in
let deck = n_cards_to_player 9 deck player_a player_b in
let deck = n_cards_to_player 9 deck player_b player_a in
let deck = ref deck in
let empty_hand player1 player2 =
if player1#empty_hand
then deck := card_to_player !deck player1 player2
in
let rec make_turn id1 id2 player1 player2 =
print_newline();
(try
empty_hand player1 player2;
empty_hand player2 player1;
with Empty_deck -> ());
if player1#books_length + player2#books_length <> 13
then begin
let rank = player1#ask_rank() in
Printf.printf "player %s asked for %ss\n%!" id1 (string_of_pip rank);
let cards = player2#give_rank rank in
match cards with
| [] ->
Printf.printf "player %s has no %ss\n%!" id2 (string_of_pip rank);
player1#request_failed rank;
(try
deck := card_to_player !deck player1 player2;
make_turn id2 id1 player2 player1
with Empty_deck -> ())
 
| cards ->
let given = String.concat ", " (List.map string_of_card cards) in
Printf.printf "player %s gives %s\n%!" id2 given;
begin match player1#give_cards cards with
| None -> ()
| Some rank ->
Printf.printf "player %s booked [%s]\n%!" id1 (string_of_pip rank);
player2#notify_booked rank;
end;
make_turn id1 id2 player1 player2
end
in
(try
if Random.bool()
then make_turn "a" "b" player_a player_b
else make_turn "b" "a" player_b player_a;
with Exit -> ());
 
Printf.printf "player a has %d books\n" (player_a#books_length);
Printf.printf "player b has %d books\n" (player_b#books_length);
;;