Octopus_Carnival/hosaka/table.ml

123 lines
4.1 KiB
OCaml
Raw Normal View History

2019-08-15 10:24:53 +02:00
(* open List;;
* open Hashtbl;; *)
2019-08-12 19:05:45 +02:00
open Cards;;
open Tcards;;
let sum a b = a + b (* TODO: investigate why list.fold doesn't accept + *)
type table = { cards: tcards list}
let make tcards =
2019-08-14 15:03:00 +02:00
{ cards=(List.sort Tcards.cmp tcards) }
2019-08-12 19:05:45 +02:00
2019-08-13 23:55:50 +02:00
let empty =
{ cards = [] }
2019-08-12 19:05:45 +02:00
let valids table =
2019-08-15 10:24:53 +02:00
List.filter (fun ts -> ts.tag = Valid) table.cards
2019-08-12 19:05:45 +02:00
let invalids table =
2019-08-15 10:24:53 +02:00
List.filter (fun ts -> ts.tag = Invalid) table.cards
2019-08-12 19:05:45 +02:00
let score table =
List.length (valids table) - List.length (invalids table)
let hash table =
List.map (fun ts ->Tcards.hash ts) table.cards |>
2019-08-15 10:24:53 +02:00
List.fold_left sum 0
2019-08-12 19:05:45 +02:00
let size table =
List.map (fun tl -> Tcards.length tl) table.cards |>
2019-08-15 10:24:53 +02:00
List.fold_left sum 0
2019-08-12 19:05:45 +02:00
2019-08-13 23:55:50 +02:00
let flatten table : card list=
2019-08-12 19:05:45 +02:00
List.map (fun (ts:tcards) -> ts.cards) table.cards |>
2019-08-15 10:24:53 +02:00
List.concat |> List.sort Cards.value_cmp
2019-08-12 19:05:45 +02:00
2019-08-13 23:55:50 +02:00
let contains tc table =
List.mem tc table.cards
2019-08-14 15:03:00 +02:00
let neighbors (tcs:tcards) table : card list=
2019-08-13 23:55:50 +02:00
let all = flatten table in
2019-08-14 15:03:00 +02:00
let res =
(match tcs.strategy with
2019-08-13 23:55:50 +02:00
| 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)
2019-08-14 15:03:00 +02:00
)|> 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 )
2019-08-12 19:05:45 +02:00
let constraints start eend =
2019-08-15 10:24:53 +02:00
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
2019-08-12 19:05:45 +02:00
2019-08-14 15:03:00 +02:00
let doesnt_improve n scores =
if List.length scores < n then
2019-08-12 19:05:45 +02:00
false
else
let max = List.fold_left max (-1000) scores in
let min = List.fold_left min 1000 scores in
2019-08-14 15:03:00 +02:00
abs (max - min) < (n/7)
2019-08-12 19:05:45 +02:00
2019-08-14 15:03:00 +02:00
let play table in_play to_move : table =
let rec _play table_cards in_play to_move accum played_already moved_already =
2019-08-12 19:05:45 +02:00
match table_cards with
2019-08-14 15:03:00 +02:00
| [] -> accum (* return a new table *)
| hd::tl -> (* put new combination on the table *)
if not played_already && eq hd in_play 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
2019-08-13 23:55:50 +02:00
match (Tcards.remove to_move hd) with
2019-08-14 15:03:00 +02:00
| None -> _play tl in_play to_move accum played_already true
| Some x -> _play tl in_play to_move (x::accum) played_already true
2019-08-12 19:05:45 +02:00
else
2019-08-14 15:03:00 +02:00
_play tl in_play to_move (hd::accum) played_already moved_already
2019-08-12 19:05:45 +02:00
in
2019-08-13 23:55:50 +02:00
assert (table |> contains in_play) ;
2019-08-14 15:03:00 +02:00
_play table.cards in_play to_move [] false false |> make
2019-08-12 19:05:45 +02:00
2019-08-13 23:55:50 +02:00
let is_best_outcome table =
2019-08-15 10:24:53 +02:00
(invalids table |> List.length) = 0
2019-08-14 15:03:00 +02:00
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 =
2019-08-15 10:24:53 +02:00
let cur_score = score table in
let uscores = scores[@cur_score] in
let cur_hash = hash table in
if !should_exit || Hashtbl.mem set cur_hash then
2019-08-14 15:03:00 +02:00
()
else (
should_exit := is_best_outcome table;
2019-08-15 10:24:53 +02:00
Hashtbl.add set cur_hash ();
dbg n cur_score table ;
if constraints original table && cur_score > !max_score then
(max_score := cur_score ; best := table ) ;
2019-08-14 15:03:00 +02:00
2019-08-15 10:24:53 +02:00
if !should_exit || n > maxiter || doesnt_improve (maxiter/2) uscores then
2019-08-14 15:03:00 +02:00
()
else (
table.cards |>
2019-08-15 10:24:53 +02:00
List.map (fun tcs -> neighbors tcs table |> List.map (fun v -> (tcs,v))) |> (* list of cards:neighbors *)
2019-08-14 15:03:00 +02:00
List.concat |> (* flatten *)
List.map (fun (card, neigh) -> (play table card neigh)) |>
2019-08-15 10:24:53 +02:00
List.iter (fun new_table -> _alg new_table (n+1) uscores maxiter)
2019-08-14 15:03:00 +02:00
)
)
in
let maxiter = match maxiter with None -> 14 | Some x -> x in
_alg original 0 [] maxiter ; !best, !max_score