Poker en CAML


Dénombrement à l'aide de CAML des mains de Poker. On commence par construire un type "Ensemble" récursif sous forme d'un arbre dégénéré ("un peigne"). Pour tenir compte du côté non ordonné des ensembles, on construit une égalité basée sur les éléments appartenant à l'arbre. Si, comme au Poker, on n'est sûr que les éléments de départ sont tous distincts (on n'est pas dans un western), on gagne du temps de parcours en ne vérifiant pas l'appartenance d'un élément à l'ensemble avant de l'y ajouter.

On commence par les outils utiles pour manipuler les arbres:

OCaml
(*------------------------------------------------------------------------
               Denombrement avec ensembles
 
  Parcourons l'hôtel "Ensemble"...
--------------------------------------------------------------------------*)
type 'a ens =
  | Vide 
  | Ens of ('a * 'a ens);;
 
(* On cherche si Brian est dans une des chambres du couloir de l'hôtel *)
let rec appartient  (brian: 'a) (couloir: 'a ens) : bool =
  match couloir with
    |Vide -> false
    |Ens(pensionnaire,reste_couloir) ->
      if pensionnaire = brian then true
      else appartient brian reste_couloir;;
 
(* On fabrique une chambre pour Brian dans le couloir sans vérifier s'il
   avait déjà une chambre*)
let colle (brian: 'el) (couloir: 'el ens): 'el ens = Ens(brian,couloir);;
  
(* on ne fabrique une chambre pour Brian que si Brian n'en a pas déjà une  *)
let ajoute (brian: 'el) (couloir: 'el ens): 'el ens =
  if appartient brian couloir then couloir
  else Ens(brian,couloir);;
 
(* union avec test d'appartenance : on met les éléments de ens1
   dans ens2 en testant s'ils ne sont pas déjà présents *)
let union_ajoute (ens1: 'el ens) (ens2: 'el ens): 'el ens =
  let rec union_gen = fun set1 accu ->
    match set1 with
      Vide    -> accu
    |Ens(t,q) -> union_gen q (ajoute t accu)
  in union_gen ens1 ens2;;
 
(* on transvase ens1 dans ens2 sans tester la présence d'éventuels doublons *)
let union_colle (ens1: 'el ens) (ens2: 'el ens): 'el ens =
  let rec union_gen = fun set1 accu ->
    match set1 with
      Vide    -> accu
    |Ens(chambre,reste_a_ajouter) -> union_gen reste_a_ajouter (colle chambre accu)
  in union_gen ens1 ens2;;
 
(* On fait deux fonctions en une avec une fonction d'ordre supérieur :
   on fait une seule fonction union avec la méthode de collage en argument *)
let union (methode_de_collage: 'el -> 'el ens -> 'el ens) (ens1: 'el ens) (ens2:'el ens): 'el ens =
  let rec transfert (couloir_a_transferer: 'el ens) (nouveau_couloir: 'el ens): 'el ens =
    match couloir_a_transferer with
    |Vide                           -> nouveau_couloir
    |Ens(chambre, reste_du_couloir) -> transfert reste_du_couloir (methode_de_collage chambre nouveau_couloir)
  in transfert ens1 ens2;;
 
(* on habille chaque occupant des chambres du couloir en parcourant les chambres une par une
   on crée un nouveau couloir avec des occupants en pyjama donc qui ont éventuellement changé
   de type*)
let applique (habille : 'a -> 'b) (couloir : 'a ens) : 'b ens =
  let rec map (reste_a_habiller : 'a ens) (occupants_habilles : 'b ens) : 'b ens =
    match reste_a_habiller with
      Vide                    -> occupants_habilles
    |Ens(locataire, le_reste) -> map le_reste (colle (habille locataire) occupants_habilles)
  in map couloir Vide;;
 
(* le fold_left des listes : on fait sortir les occupants des chambres et on les
   entasse dans l'ascenseur *)
let plie (entasse: 'b -> 'a -> 'b) (tas_initial: 'b) (couloir_a_plier: 'a ens) : 'b =
  let rec fold (reste_a_plier: 'a ens) (le_tas: 'b) : 'b =
    match reste_a_plier with
      Vide                   -> le_tas
    |Ens(locataire,le_reste) -> fold le_reste (entasse le_tas locataire)
  in fold couloir_a_plier tas_initial;;
 
(* je plie en comptant 1 à chaque pliage avec au départ un cardinal nul
   Il faut être sûr qu'il n'y a pas de doublon *)
let cardinal (ensemble: 'el ens): int = 
   plie (fun compteur element -> compteur + 1) 0 ensemble;;
 
(* on enlève les éventuels doublons en utilisant ajoute dans un accumulateur vide
   au départ *)
let reduit = fun ens ->
  let rec aux = fun ens_a_vider ens_sans_doublon ->
    match ens_a_vider with
      Vide     -> ens_sans_doublon
    | Ens(t,q) -> aux q (ajoute t ens_sans_doublon)
  in aux ens Vide;;
 
(* les parties d'un ensemble : c'est l'ensemble de tous ses sous-ensembles
   on utilise le principe récursif : les parties de {a,b,c} sont les parties de
   {a,b} union les parties de {a,b} dans lesquelles on injecte c *)
let parties (ens: 'a ens): 'a ens ens =
  let rec part (set: 'a ens) (acc: 'a ens ens) : 'a ens ens =
    match set with
      Vide    ->  acc 
    |Ens(t,q) ->  part q ( union colle (applique (ajoute t) acc)  acc)
  in part ens (Ens(Vide,Vide));;
 
(* renvoie l'ensemble des parties de longueur n: on adapte "parties" pour ne prendre que des éléments de cardinal n
   en diminuant d'une unité l'argument n à chaque fois qu'on ajoute un élément dans la partie *)
let rec parties_n  (ens: 'a ens) (n: int) : 'a ens ens =
  if n = 0 then
      Ens(Vide,Vide)
  else 
    match ens with
      Vide    ->  Vide 
    |Ens(t,q) ->  union colle (applique (colle t) (parties_n q (n-1)))  (parties_n q n);;
 
(* on crée un 'a ens à partir d'un 'a ens ens : on fait l'union des sous-couloirs
   en abattant les cloisons *)
let applatit (ens : 'a ens ens): 'a ens =
  let rec abat = fun reste_a_explorer open_space ->
    match reste_a_explorer with
      Vide -> open_space
    |Ens(chambre,le_reste) -> abat le_reste (union ajoute chambre open_space)
  in abat ens Vide;;
 
(* filtre les éléments d'un ensemble qui satisfont un prédicat *)
let filtre (passe_test: 'grain -> bool) (sac_a_grains: 'grain ens) : 'grain ens =
  let rec tri = fun reste_a_trier le_bon_grain ->
    match reste_a_trier with
    |Vide    -> le_bon_grain
    |Ens(grain,reste_du_sac) ->
      if passe_test grain then tri reste_du_sac (colle grain le_bon_grain)
      else tri reste_du_sac le_bon_grain
  in tri sac_a_grains Vide;;
 
(* renvoie les liste des éléments d'un ensemble*)
let liste_el (ens: 'a ens): 'a list =
  let rec aux = fun e acc ->
    match e with
      Vide    -> acc
    |Ens(t,q) -> aux q (t::acc)
  in aux ens [];; 
 
(* crée un ensemble à partir d'une liste *)
let ens_of_list (liste: 'a list) : 'a ens =
  let rec aux = fun l acc ->
    match l with
    |[]   -> acc
    |t::q -> aux q (colle t acc)
  in aux liste Vide;;
 
(* teste l'existence d'un élément dans ens vérifiant un prédicat *)
let rec existe (pred: 'a -> bool) (ens: 'a ens) : bool =
  match ens with
    Vide    -> false
  |Ens(t,q) ->
    if pred t then true
    else existe pred q;;
 
(* teste si tous les éléments vérifient le prédicat *)
let rec pour_tout (pred: 'a -> bool) (ens: 'a ens) : bool =
  not (existe (fun x -> not (pred x)) ens);;
 
(* sépare un ensemble entre ceux qui vérifient le prédicat et les autres*)
let partition (pred: 'a -> bool) (ens: 'a ens) : ('a ens * 'a ens) = 
  let rec temp = fun e e1 e2 ->
    match e with
    |Vide -> (e1,e2)
    |Ens(t,q) ->
      if pred t then temp q (Ens(t,e1)) e2
      else temp q e1 (Ens(t,e2))
  in temp ens Vide Vide;;
 
(* inclusion : tout élément de ens1 appartient à ens2 *)
let est_inclus (ens1: 'a ens) (ens2: 'a ens) : bool =
  pour_tout (fun e1 -> appartient e1 ens2) ens1;; 
 
(* égalité comme double inclusion *)
let est_egal (ens1: 'a ens) (ens2: 'a ens) : bool =
  (est_inclus ens1 ens2) && (est_inclus ens2 ens1);; 
 
(* renvoie la liste des couples (élément, nombre d'occurrences de l'élément dans l'ensemble)
   avant réduction *)
let count (ens: 'a ens) : ('a * int) list =
  let rec compte = fun e accu ->
    match e with
      Vide    -> accu
    |Ens(t,q) ->
      let c = partition (fun x -> x = t) e in
      compte (snd c) ((t,cardinal (fst c))::accu)
  in compte ens [];;
 
(*-------------------------------------------------------------------
 
                                    P O K E R
 
  -------------------------------------------------------------------*)
 
type symbole = Trefle | Carreau | Coeur | Pique ;;
 
type valeur =  Sept | Huit | Neuf | Dix | Valet | Dame | Roi | As ;;
 
type carte =  C of valeur*symbole ;;
 
(* fonction qui renvoie la hauteur d'une carte *)
let hauteur (c: carte): valeur =
  match c with C(h,c) -> h;;
 
(* fonction qui renvoie la couleur d'une carte *)
let couleur (c: carte): symbole =
  match c with C(h,c) -> c;;
 
let vals: valeur ens =
  ens_of_list [Sept;Huit;Neuf;Dix;Valet;Dame;Roi;As];;
 
let symbs: symbole ens =
  ens_of_list [Trefle;Carreau;Coeur;Pique];;
 
(* pour chaque couleur et pour chaque hauteur on ajoute le couple (couleur,hauteur)
   à notre ensemble de cartes. Comme on utilise deux fois applique, on obtient
   un carte ens ens : on applatit une fois pour réduire d'un niveau la profondeur *)
let cartes: carte ens =
  applatit (applique (fun coul -> (applique (fun haut -> C(haut,coul)) vals) ) symbs);;
 
(* Une main au poker a 5 cartes : les mains sont tous les
   sous-ensembles de cartes de longueur 5 *)
let mains: carte ens ens =
  parties_n cartes 5;;
 
(* fonction qui renvoie l'ensemble des hauteurs d'une main *)
let hauteurs (main: carte ens) : valeur ens =
  applique (hauteur) main;;
 
(* fonction qui renvoie l'ensemble des couleurs d'une main *)
let couleurs (main: carte ens) : symbole ens =
  applique (couleur) main;;
 
(* il existe une hauteur qui apparaît 4 fois dans une main *)
let est_carre1 (main: carte ens) : bool =
   List.exists (fun couple -> snd couple = 4) (count (hauteurs main));;
 
(* ou bien la liste triée des hauteurs doit être égale à [1;4] *)
let est_carre2 (main: carte ens): bool =
  List.sort compare (snd (List.split (count (hauteurs main)))) = [1;4];;
 
 
(* on filtre les hauteurs qui apparaissent deux fois dans la main
   et on regarde s'il y a effectivement deux paires dans cette main *)
let est_double_paire1 (main: carte ens): bool =
  List.length (List.filter (fun x -> snd x = 2) (count (hauteurs main))) == 2;;
 
(* ou bien la liste triée des hauteurs doit être égale à [1;2;2] *)
let est_double_paire2 (main: carte ens): bool =
  List.sort compare (snd (List.split (count (hauteurs main)))) = [1;2;2];;
 
(* Plus générique : on met la combinaison en argument
   Notre obsession : Don't Repeat Yourself *)
let est_combinaison (combi: int list) (main: carte ens): bool =
    List.sort compare (snd (List.split (count (hauteurs main)))) = combi;;
 
let est_carre (main: carte ens) : bool =
  est_combinaison [1;4];;
 
let est_double_paire (main: carte ens) : bool =
    est_combinaison [1;2;2];;
 
let est_full (main: carte ens) : bool =
  est_combinaison [2;3];;
 
let est_brelan (main: carte ens) : bool =
  est_combinaison [1;1;3];;
 
let est_paire (main: carte ens) : bool =
  est_combinaison [1;1;1;2]
 
 
 
let meme_couleur (main: carte ens): bool =
  cardinal (reduit (couleurs main)) = 1;;
 
(* ou   plie (&&) true (applique (fun c -> couleur c = couleur (tete main)) main)*)
 
(* Ensemble des suites possibles *)
let les_suites: valeur ens ens =
  applique ens_of_list (
    ens_of_list [
      [Sept;Huit;Neuf;Dix;Valet];
      [Huit;Neuf;Dix;Valet;Dame];
      [Neuf;Dix;Valet;Dame;Roi];
      [Dix;Valet;Dame;Roi;As]
    ]
  );;
 
(* Teste si la main est une suite (mais peut être quinte flush) *)
let est_suite (main: carte ens): bool =
  existe (fun suite -> est_egal suite (hauteurs main)) les_suites;;
 
let est_quinte (main: carte ens): bool =
  (est_suite main) && (not (meme_couleur main));;
 
let est_quinte_flush (main: carte ens): bool =
  (est_suite main) && (meme_couleur main);;
 
let est_couleur (main: carte ens): bool =
  (meme_couleur main) && (not (est_suite main));;
 
cardinal mains;;
 
binom 32 5;;
 
count (applique est_couleur mains);;
count (applique est_carre mains);;
count (applique est_brelan mains);;
count (applique est_double_paire mains);;
count (applique est_paire mains);;
count (applique est_quinte mains);;
count (applique est_quinte_flush mains);;
 
(*
        
Quinte flush       16
Carré              224  
Full               1 344        
Couleur            208  
Quinte             4 080        
Brelan             10 752       
Deux paires        24 192       
Paire              107 520           
 
*)

courtesy of webmatter.de