finalmente

cards.ml

@@ -73,11 +73,15 @@ let is_straight _cards =
   if (not (no_double_value _cards && is_only_one_seed _cards)) then
     false
   else
-    let last = List.rev _cards |> hd in
+    let ocards = List.sort value_cmp _cards  in
-    let cards  = List.map (fun c -> c.value) _cards  (* use only values *) in
+    let last = List.rev ocards |> hd in
+    let cards  = List.map (fun c -> c.value) ocards (* use only values *) in
     if last.value = 13 && (hd cards) = 1 then (* circolare *)
       let fst, snd = split cards [] in (_is_straight fst) && (_is_straight snd)
     else
+      (* let res = _is_straight cards in
+       * List.iter (fun c -> Printf.printf "%d:%s - " c.value (card_type_to_string c.seed)) _cards ; Printf.printf "%b\n" res;
+       * res *) (* TODO : remove *)
       _is_straight cards
 
 let is_valid _cards =

main.ml

@@ -36,18 +36,206 @@ let card, _ = draw deck;;
  considerata una carta giocabile in mano, considera le carte "prossime", bruteforce;
 *)
 
+let printer n score table = 
+  Printf.printf "****%d:%d****\n%a\n********\n" n score print_table table;;
+let void_printer n score table =  ();;
 (* TESTS TODO: *)
-let printer table = 
-  Printf.printf "********\n%a\n********\n" print_table table;;
 
+(*
+assert  ([
+    Cards.make Hearts 6;
+    Cards.make Hearts 7;
+    Cards.make Hearts 8;
+    Cards.make Hearts 9;
+    Cards.make Hearts 10;]
+    |> Cards.is_straight) ;;
 
-(* let rec alg table original_table n (scores:int list) best max_score (dbg: table -> unit) = *)
+assert  ([
-open Hashtbl;;
+    Cards.make Hearts 1;
-let table = Table.make [
+    Cards.make Hearts 12;
+    Cards.make Hearts 2;
+    Cards.make Hearts 13;]
+    |> Cards.is_straight) ;;
+  
+let ttable = Table.make [
+  Tcards.make [
+    Cards.make Clovers 7;
+    Cards.make Clovers 8;
+    Cards.make Clovers 9;
+  ];
+  Tcards.make [
+    Cards.make Pikes 7;
+    Cards.make Pikes 8;
+    Cards.make Pikes 9;
+  ];
   Tcards.make [
     Cards.make Hearts 7;
     Cards.make Hearts 8;
     Cards.make Hearts 9;
+    Cards.make Hearts 10;
+  ];
+  Tcards.make [
+    Cards.make Hearts 6;
+  ]
+]
+in
+let neighs = neighbors 
+  (Tcards.make [
+    Cards.make Hearts 7;
+    Cards.make Hearts 8;
+    Cards.make Hearts 9;
+    Cards.make Hearts 10;
+  ]) ttable in
+assert (neighs = [Cards.make Hearts 6]) ;;
+
+let ttable = Table.make [
+  Tcards.make [
+    Cards.make Hearts 1;
+    Cards.make Hearts 2;
+    Cards.make Hearts 13;
+  ];
+  Tcards.make [
+    Cards.make Pikes 1;
+    Cards.make Pikes 2;
+    Cards.make Pikes 3;
+  ];
+  Tcards.make [
+    Cards.make Clovers 2;
+    Cards.make Clovers 3;
+  ];
+  Tcards.make [
+    Cards.make Clovers 1;
+    Cards.make Tiles 1;
+  ];
+  Tcards.make [
+    Cards.make Hearts 12;
+    Cards.make Tiles 12;
+  ];
+]
+in
+let neighs = neighbors 
+  (Tcards.make [
+    Cards.make Hearts 1;
+    Cards.make Hearts 2;
+    Cards.make Hearts 13;
+  ]) ttable in
+assert (neighs = [Cards.make Hearts 12]) ;;
+*)
+
+let table1 = Table.make [
+  Tcards.make [
+    Cards.make Clovers 2;
+    Cards.make Pikes 2;
+    Cards.make Hearts 2;
+  ];
+  Tcards.make [
+    Cards.make Clovers 1;
+    Cards.make Tiles 1;
+    Cards.make Pikes 1;
+    Cards.make Hearts 1;
+  ];
+  Tcards.make [
+    Cards.make Tiles 13;
+  ];
+  Tcards.make [
+    Cards.make Tiles 12;
+  ];
+  Tcards.make [
+    Cards.make Hearts 13;
+  ];
+  Tcards.make [
+    Cards.make Hearts 12;
+  ];
+  Tcards.make [
+    Cards.make Pikes 3;
+  ];
+  Tcards.make [
+    Cards.make Clovers 3;
+  ]
+] in
+let table1x = Table.make [
+  Tcards.make [
+    Cards.make Clovers 2;
+    Cards.make Pikes 2;
+    Cards.make Hearts 2;
+  ];
+  Tcards.make [
+    Cards.make Clovers 1;
+    Cards.make Tiles 1;
+    Cards.make Pikes 1;
+    Cards.make Hearts 1;
+  ];
+  Tcards.make [
+    Cards.make Tiles 13;
+  ];
+  Tcards.make [
+    Cards.make Tiles 12;
+  ];
+  Tcards.make [
+    Cards.make Hearts 13;
+  ];
+  Tcards.make [
+    Cards.make Hearts 12;
+  ];
+  Tcards.make [
+    Cards.make Hearts 12;
+  ];
+  Tcards.make [
+    Cards.make Pikes 3;
+  ];
+  Tcards.make [
+    Cards.make Clovers 3;
+  ]
+] in
+let table2 = Table.make [
+  Tcards.make [
+    Cards.make Clovers 2;
+    Cards.make Tiles 2;
+    Cards.make Pikes 2;
+    Cards.make Hearts 2;
+  ];
+  Tcards.make [
+    Cards.make Clovers 1;
+    Cards.make Tiles 1;
+    Cards.make Pikes 1;
+    Cards.make Hearts 1;
+  ];
+  Tcards.make [
+    Cards.make Pikes 3;
+  ]
+] in
+let table3 = Table.make [
+  Tcards.make [
+    Cards.make Clovers 7;
+    Cards.make Clovers 8;
+    Cards.make Clovers 9;
+  ];
+  Tcards.make [
+    Cards.make Hearts 7;
+    Cards.make Hearts 8;
+    Cards.make Hearts 9;
+    Cards.make Hearts 10;
+  ];
+  Tcards.make [
+    Cards.make Pikes 7;
+    Cards.make Pikes 8;
+    Cards.make Pikes 9;
+  ];
+  Tcards.make [
+    Cards.make Tiles 7;
+  ];
+  Tcards.make [
+    Cards.make Hearts 11;
+  ];
+  Tcards.make [
+    Cards.make Hearts 12;
+  ];
+] in
+let table4 = Table.make [
+  Tcards.make [
+    Cards.make Clovers 7;
+    Cards.make Clovers 8;
+    Cards.make Clovers 9;
   ];
   Tcards.make [
     Cards.make Pikes 7;
@@ -67,7 +255,40 @@ let table = Table.make [
     Cards.make Hearts 8;
   ]
 ] in
-let new_tables = Table.alg table 0 [] in
+let table5 = Table.make [
-(* List.iter ~f:(fun (t,_,_) -> printer t) new_table *)
+  Tcards.make [
+    Cards.make Clovers 7;
+  ];
+  Tcards.make [
+    Cards.make Clovers 6;
+  ];
+  Tcards.make [
+    Cards.make Clovers 8;
+  ];
+] in
+let table5x = Table.make [
+  Tcards.make [
+    Cards.make Clovers 7;
+    Cards.make Clovers 8;
+    Cards.make Clovers 9;
+  ];
+  Tcards.make [
+    Cards.make Clovers 10;
+  ];
+  Tcards.make [
+    Cards.make Clovers 10;
+  ];
+] in
 
-Table.prova table [] [] (-1000)  printer new_tables []
+assert (alg table1 void_printer |> snd = 4);
+assert (alg table2 void_printer |> snd = 3);
+assert (alg table3 void_printer |> snd = 4);
+assert (alg table4 void_printer |> snd = 4);
+assert (alg table5 void_printer |> snd = 1);
+assert (alg table5x void_printer |> snd = 0);
+assert (alg table1x void_printer |> snd = 2);
+assert (alg ~maxiter:21 table1x void_printer |> snd = 3);
+assert (alg ~maxiter:14 table1x void_printer |> snd = 2);
+let table = table1x in
+let res = alg ~maxiter:14 table printer in
+Printf.printf "Best result: %d\n%a\n" (res |> snd) print_table (res |> fst)

table.ml

@@ -1,4 +1,5 @@
 open List;;
+open Hashtbl;;
 
 open Cards;;
 open Tcards;;
@@ -8,7 +9,7 @@ let sum a b = a + b (* TODO: investigate why list.fold doesn't accept + *)
 type table = { cards: tcards list}
 
 let make tcards =
-  { cards=tcards }
+  { cards=(List.sort Tcards.cmp tcards) }
 
 let empty =
   { cards = [] }
@@ -32,95 +33,89 @@ let size table =
 
 let flatten table : card list=
   List.map (fun (ts:tcards) -> ts.cards) table.cards |>
-  List.concat ;;
+  List.concat |> List.sort Cards.value_cmp ;; 
 
 let contains tc table =
   List.mem tc table.cards
 
-let neighbors tcs table : card list=
+let neighbors (tcs:tcards) table : card list=
   let all = flatten table in
-  match tcs.strategy with
+  let res = 
+  (match tcs.strategy with
   | Tris -> List.filter (fun x -> tcs.cards@[x] |> Cards.is_tris) all
   | Straight -> List.filter (fun x -> tcs.cards@[x] |> Cards.is_straight) all
   | Single -> all |>
               List.filter (fun x -> let cs = tcs.cards@[x] in
                             Cards.is_straight cs || Cards.is_tris cs)
-      
+  )|> List.sort_uniq (fun a b -> if a = b then 0 else 1)
+  in (
+  (* List.iter (fun c -> Printf.printf "%d:%s - " c.value (card_type_to_string c.seed)) tcs.cards; *)
+  (* Printf.printf "\n"; *)
+  (* List.iter (fun c -> Printf.printf "%d:%s - " c.value (card_type_to_string c.seed)) res ; Printf.printf "\n" ; *)
+   res )
 
 let constraints start eend =
   let hand = List.filter (fun ts -> ts.strategy == Single) start.cards in
   let res = List.filter (fun (e:tcards) -> e.strategy == Single && not (List.mem e hand)) eend.cards in
   (List.length res) == 0;; (* investigate why not = nstead of == (TODO) *)
 
-let doesnt_improve scores =
+let doesnt_improve n scores =
-  if List.length scores < 7 then
+  if List.length scores < n then
     false
   else
     let max = List.fold_left max (-1000) scores in
     let min = List.fold_left min 1000 scores in
-    abs (max - min) < 2
+    abs (max - min) < (n/7)
 
-let play table in_play to_move =
+let play table in_play to_move : table =
-  let rec _play table_cards in_play to_move accum =
+  let rec _play table_cards in_play to_move accum played_already moved_already =
     match table_cards with
-    (* put new combination on the table *)
+    | [] -> accum (* return a new table *)
-    | hd::tl when hd = in_play -> _play tl in_play to_move ((Tcards.make (to_move::in_play.cards))::accum)
+    | hd::tl -> (* put new combination on the table *)
-    | [] -> accum (* generate a new table *)
+      if not played_already && eq hd in_play then
-    | hd::tl -> if hd |> Tcards.contains to_move then
+        _play tl in_play to_move ((Tcards.make (to_move::in_play.cards))::accum) true moved_already
+      else if not moved_already && hd |> Tcards.contains to_move then
         match (Tcards.remove to_move hd) with
-        | None -> _play tl in_play to_move accum
+        | None -> _play tl in_play to_move accum played_already true
-        | Some x -> _play tl in_play to_move (x::accum)
+        | Some x -> _play tl in_play to_move (x::accum) played_already true
       else
-        _play tl in_play to_move (hd::accum)
+        _play tl in_play to_move (hd::accum) played_already moved_already
+        
   in
   assert (table |> contains in_play) ;
-  _play table.cards in_play to_move [] |> make
+  _play table.cards in_play to_move [] false false |> make
   ;;
 
-let update best max_score original newt score =
-  if score > max_score && (constraints original newt) then
-    score, newt
-  else
-    max_score, best
-
 let is_best_outcome table =
   (invalids table |> List.length) == 0
 
-(* let rec alg table original_table n (scores:int list) best max_score (dbg: table -> unit) =
- *   dbg table ;
- *   let ascore = score table in 
- *   (\* if Hashset.has (hash table) then () *\)
- *   (\* else ( *\)
- *     (\* Hashset.add (hash table) ; *\)
- *     let mmax, bbest = update best max_score original_table table ascore in
- *     if is_best_outcome table || n > 14 || doesnt_improve (scores@[ascore]) then
- *       ()
- *     else
- *       table.cards |>
- *       List.map (fun tcs -> neighbors tcs table |> List.map (fun v -> (tcs,v))) |> (\* lista di carta:vicini *\)
- *       List.concat |> (\* flatten *\)
- *       List.map (fun (card, neigh) -> play table card neigh) |> (\* list of new_tables *\)
- *       List.iter (fun new_table -> alg new_table original_table (n+1) (scores@[ascore]) bbest mmax dbg)
- *   (\* ) *\) *)
 
-let alg table n (scores:int list) : (table * int * int list) list =
+let alg ?maxiter original (dbg: int -> int -> table -> unit) =
+  let set = Hashtbl.create 1024 in
+  let should_exit = ref false in
+  let best = ref original in
+  let max_score = ref (score !best) in
+
+  let rec _alg table n scores maxiter =
+    if !should_exit || Hashtbl.mem set (hash table) then
+      ()
+    else (
+      should_exit := is_best_outcome table;
+      Hashtbl.add set (hash table) ();
+      dbg n (score table) table ;
+      if constraints original table && (score table) > !max_score then
+        (max_score := (score table) ; best := table ) ;
+
+      if !should_exit || n > maxiter || doesnt_improve (maxiter/2) (scores@[score table]) then
+        ()
+      else (
         table.cards |>
         List.map (fun tcs -> neighbors tcs table |> List.map (fun v -> (tcs,v))) |> (* lista di carta:vicini *)
         List.concat |> (* flatten *)
-  List.map (fun (card, neigh) -> (play table card neigh), (n+1), (scores@[score table]) )
+        List.map (fun (card, neigh) -> (play table card neigh)) |>
-
+        List.iter (fun new_table -> _alg new_table (n+1) (scores@[score table]) maxiter)
-let condizioni table n scores set =
+      )
-  if List.mem (hash table) set || doesnt_improve scores ||
+    )
-     is_best_outcome table || n > 14 then
+  in
-    true
+  let maxiter = match maxiter with None -> 14 | Some x -> x in
-  else false
+  _alg original 0 [] maxiter ; !best, !max_score
-  
-let rec prova original_table set best max_score (dbg: table -> unit) (accum: (table*int*int list) list)
-    (sols: (table*int*int list) list) =
-  match accum with
-  | [] -> sols
-  | (table, n, scores)::tl -> dbg table ;
-    if condizioni table n scores set then
-      prova original_table ((hash table)::set) best max_score dbg tl ([table, n, scores]@sols)
-    else
-      prova original_table ((hash table)::set) best max_score dbg ((alg table n scores)@tl) sols

tcards.ml

@@ -28,31 +28,37 @@ type tcards = { cards: card list ; tag: card_tag ; strategy: game_strategy }
 let make cards =
   let strategy = if List.length cards = 1 then Single else
     if Cards.is_tris cards then Tris else Straight in
-  { cards=cards ; tag=if Cards.is_valid cards then Valid else Invalid; strategy=strategy }
+  { cards=cards |> List.sort value_cmp ; tag=if Cards.is_valid cards then Valid else Invalid; strategy=strategy }
 
 let contains needle haystack = List.mem needle haystack.cards
 
-let (=) a b =
+let eq a b =
   if List.length a.cards <> List.length b.cards || a.tag != b.tag || a.strategy != b.strategy then
     false
   else
     a.cards = b.cards
 
 let length ts = List.length ts.cards
-let cmp a b =
-  (* TODO: improve *)
-  if a.strategy == Tris && List.length a.cards == 4 then -1
-  else if b.strategy == Tris && List.length b.cards == 4 then 1
-  else if a.strategy != Single && b.strategy == Single then 1
-  else if a.strategy == Single && b.strategy != Single then -1
-  else if a.tag == Invalid && b.tag == Valid then 1
-  else -1 ;;
 
-(* TODO tests *)
+let cmp (a:tcards) (b:tcards) =
-assert (make [Cards.make Pikes 2] |>
+  let tup = (a.strategy, length a, b.strategy, length b, a.tag, b.tag) in
-        cmp (make [Cards.make Pikes 2 ; Cards.make Clovers 2]) == 1);; (* less than *)
+  match tup with
-assert (make [Cards.make Pikes 2] |>
+  | Straight, al, Straight, bl, _, _ -> if al < bl then 1 else -1
-cmp (make [Cards.make Pikes 2 ; Cards.make Clovers 2 ; Cards.make Tiles 2; Cards.make Hearts 2]) == -1)
+  | Tris, 4, _, _, _, _ -> -1
+  | _,  _, Tris, 4, _, _ -> 1
+  | Tris, 3, _, _, _, _ -> -1
+  | _,  _, Tris, 3, _, _ -> 1
+  | Straight, 3, _, _, _, _ -> -1
+  | _,  _, Straight, 3, _, _ -> 1
+  | Straight, al, _, _, _, _ when al > 3 -> -1
+  | _, _, Straight, bl, _, _ when bl > 3 -> 1
+  | Single, _, Single, _, _, _ -> -1 (* avoid ordering by card value here *)
+  | (Straight|Tris), _, Single, _, _, _ -> 1
+  | Single, _, (Straight|Tris), _, _, _ -> -1
+  | _, _, _, _, Invalid, Valid -> 1
+  | _, _, _, _, Valid, Invalid -> -1
+  | _ -> -1 (* doesn't matter if -1 or 1, just don't discriminate otherwise can't try all possible combinations *);;
+
 
 let hash ts =
   ts.cards |>