Commits

Anonymous committed d28ddb0

mills - nine men morris

Comments (0)

Files changed (5)

mills/ai_montecarlo.ml

+open Mill
+
+let do_turn state player =
+  if can_put state then begin
+    let goal = player#put state in
+    put state goal;
+    try
+      if in_mill state goal then capture state (player#capture state)
+    with _ -> () (* not capturable *)
+  end
+  else if can_fly state then begin
+    let from, goal = player#fly state in
+    fly state from goal;
+    try
+      if in_mill state goal then capture state (player#capture state)
+    with _ -> () (* not capturable *)
+  end
+  else begin
+    let from, goal = player#move state in
+    move state from goal;
+    try
+      if in_mill state goal then capture state (player#capture state)
+    with _ -> () (* not  movable or capturable *)
+  end
+
+let all_moves state = 
+  let color = get_color (get_turn state) in
+  let moves a = List.map (fun b -> (a, b)) (free_neighbors state a) in
+  List.flatten (List.map moves (movables state color))
+
+let all_flies state = 
+  let color = get_color (get_turn state) in
+  let flies a = List.map (fun b -> (a, b)) (free_dots state) in
+  List.flatten (List.map flies (movables state color))
+
+let playout state maxturn =
+  while not (game_ended state) && (get_turn state) < maxturn do
+    do_turn state Ai_random.player;
+    end_of_turn state
+  done;
+  (* too many turns, bonus if we have more pieces on the table *)
+  if get_turn state = maxturn then 
+    if get_count state Black > get_count state White then 1 else -1 
+  (* end of game, bonus if we win *)
+  else
+    let black_wins = (get_turn state) mod 2 = 0 in
+    if black_wins then 1 else -1
+  
+let rec estimate state score nplayouts nturns =
+  if nplayouts = 0 then score
+  else begin 
+    let maxturn = (get_turn state) + nturns in
+    let result = playout (copy state) maxturn in
+    estimate state (score + result) (pred nplayouts) nturns
+  end
+  
+let player =
+  let max_playouts = 10000 in
+  let nturns = 100 in
+  object (self)
+    method put state = 
+      let lst = free_dots state in
+      let nplayouts = max_playouts / List.length lst in
+      let init = List.hd lst in
+      let rec select lst best score = match lst with
+        | []  ->  best
+        | candidate::rest  -> 
+          let s = (copy state) in
+          Printf.printf "estimate put %d %d %d%!" candidate best score;
+          put s candidate;
+          begin 
+            try
+              if in_mill s candidate then capture s (self#capture state);
+            with _ -> () (* no possible capture *)
+          end;
+          end_of_turn s;
+          Printf.printf "...%!";
+          let cscore = (estimate s 0 nplayouts nturns) in
+          Printf.printf " => %d\n%!" cscore;
+          if cscore > score then select rest candidate cscore
+          else select rest best score
+      in
+      select lst init min_int    
+    method move state =
+      let lst = all_moves state in
+      let nplayouts = max_playouts / List.length lst in
+      let init = List.hd lst in
+      let rec select lst best score = match lst with
+        | []  ->  best
+        | (from, goal) :: rest  -> 
+          let s = (copy state) in
+          Printf.printf "estimate move %d -> %d %d%!" from goal score;
+          move s from goal;
+          begin 
+            try
+              if in_mill s goal then capture s (self#capture state);
+            with _ -> () (* no possible capture *)
+          end;
+          end_of_turn s;
+          Printf.printf "...%!";
+          let cscore = (estimate s 0 nplayouts nturns) in
+          Printf.printf " => %d\n%!" cscore;
+          if cscore > score then select rest (from, goal) cscore
+          else select rest best score
+      in
+      select lst init min_int    
+    method fly state =
+      let lst = all_flies state in
+      let nplayouts = max_playouts / List.length lst in
+      let init = List.hd lst in
+      let rec select lst best score = match lst with
+        | []  ->  best
+        | (from, goal) :: rest  -> 
+          let s = (copy state) in
+          Printf.printf "estimate fly %d -> %d %d%!" from goal score;
+          fly s from goal;
+          begin 
+            try
+              if in_mill s goal then capture s (self#capture state);
+            with _ -> () (* no possible capture *)
+          end;
+          end_of_turn s;
+          Printf.printf "...%!";
+          let cscore = (estimate s 0 nplayouts nturns) in
+          Printf.printf " => %d\n%!" cscore;
+          if cscore > score then select rest (from, goal) cscore
+          else select rest best score
+      in
+      select lst init min_int   
+    method capture state =
+      let opponent = get_color ((get_turn state) + 1) in
+      let lst = capturables state opponent in
+      let nplayouts = max_playouts / List.length lst in
+      let init = List.hd lst in
+      let rec select lst best score = match lst with
+        | []  ->  best
+        | candidate::rest  -> 
+          let s = (copy state) in
+          Printf.printf "estimate capture %d %d %d%!" candidate best score;
+          capture s candidate;
+          end_of_turn s;
+          Printf.printf "...%!";
+          let cscore = (estimate s 0 nplayouts nturns) in
+          Printf.printf " => %d\n%!" cscore;
+          if cscore > score then select rest candidate cscore
+          else select rest best score
+      in
+      select lst init min_int    
+  end

mills/ai_random.ml

+open Mill
+
+let player =
+  let select lst =
+    let n = Random.int (List.length lst) in
+    List.nth lst n 
+  in
+  object
+    method put state = 
+      select (free_dots state)    
+    method move state =
+      let color = get_color (get_turn state) in
+      let from = select (movables state color) in
+      let goal = select (free_neighbors state from) in
+      from, goal
+    method fly state =
+      let color = get_color (get_turn state) in
+      let from = select (colored_dots state color) in
+      let goal = select (free_dots state) in
+      from, goal
+    method capture state =
+      let opponent = get_color ((get_turn state) + 1) in
+      select (capturables state opponent)
+  end
+(*
+indexes :
+[ 0]----------[ 1]----------[ 2]
+ |  [ 3]------[ 4]------[ 5] |
+ |   |  [ 6]--[ 7]--[ 8] |   |
+[ 9][10][11]        [12][13][14]
+ |   |  [15]--[16]--[17] |   |
+ |  [18]------[19]------[20] |
+[21]---------[22]----------[23]
+*)
+
+type color = White | Black
+
+type state = {
+  dots: color option array; 
+  mutable turn: int;
+  mutable nwhite: int;
+  mutable nblack: int; 
+}
+
+let make () = {dots=Array.make 24 None; turn=0; nwhite=0; nblack=0} 
+
+let copy state = {state with dots = Array.copy state.dots}
+
+let mills = [
+  0, 1, 2; 
+  3, 4, 5; 
+  6, 7, 8;
+  9, 10, 11;
+  12, 13, 14;
+  15, 16, 17;
+  18, 19, 20;
+  21, 22, 23;
+  0, 9, 21;
+  3, 10, 18;
+  6, 11, 15;
+  1, 4, 7;
+  16, 19, 22;
+  8, 12, 17;
+  5, 13, 20;
+  2, 14, 23]
+  
+let in_mill state index = 
+  let check (x, y, z) = 
+    (index = x || index = y || index = z)
+    && state.dots.(x) = state.dots.(y)
+    && state.dots.(x) = state.dots.(z)
+    && state.dots.(x) <> None
+  in 
+  List.exists check mills   
+
+let all =
+  let rec build i lst =
+    if i = 24 then lst
+    else build (succ i) (i :: lst)
+  in List.rev (build 0 [])
+
+let connected a b =
+  let check (x, y, z) = a = x && b = y
+    || a = y && (b = x || b = z)
+    || a = z && b = y
+  in 
+  List.exists check mills    
+
+let free_dots state =
+  let check i = state.dots.(i) = None in
+  List.filter check all
+
+let colored_dots state color =
+  let check i = state.dots.(i) = Some color in
+  List.filter check all
+
+let neighbors i =
+  List.filter (connected i) all
+
+let free_neighbors state i =
+  List.filter (connected i) (free_dots state)
+
+let capturables state color =
+  let check i = not (in_mill state i) in
+  List.filter check (colored_dots state color)
+
+let movables state color =
+  let check i = (free_neighbors state i) <> [] in
+  List.filter check (colored_dots state color)
+
+
+let get_color turn = if turn mod 2 = 0 then White else Black    
+
+let get_turn state = state.turn
+
+let get_count state color = match color with
+  | White -> state.nwhite
+  | Black -> state.nblack
+
+let get state index = state.dots.(index)
+
+let put_turn_limit = 18 (* 9 pieces each *)
+
+let can_put state = 
+  state.turn < put_turn_limit
+
+let can_fly state = 
+  let color = get_color state.turn in
+  (not (can_put state)) &&
+    (movables state color = [] || 
+    (color = White && state.nwhite = 3) || 
+    (color = Black && state.nblack = 3))
+
+let end_of_turn state = state.turn <- succ state.turn 
+
+let game_ended state = 
+  state.turn > put_turn_limit && (state.nwhite < 3 || state.nblack < 3)
+                                           
+                        
+let put state index = 
+  if not (can_put state) then failwith "all pieces have been placed already";
+  if state.dots.(index) <> None then invalid_arg "put on non-empty dot";  
+  let color = get_color state.turn in
+  state.dots.(index) <- Some (get_color state.turn);
+  if color = White then state.nwhite <- succ state.nwhite
+  else state.nblack <- succ state.nblack
+  
+let move state from goal = 
+  if can_put state then failwith "some pieces haven't been placed yet";
+  if state.dots.(from) <> Some (get_color state.turn) then invalid_arg "move from invalid dot";
+  if state.dots.(goal) <> None  then invalid_arg "move to non-empty dot";
+  if not (connected from goal) then invalid_arg "move between non connected dots";
+  state.dots.(goal) <- state.dots.(from);
+  state.dots.(from) <- None
+
+let fly state from goal = 
+  if not (can_fly state) then failwith "too many pieces left to fly";
+  if state.dots.(from) <> Some (get_color state.turn) then invalid_arg "fly from invalid dot";
+  if state.dots.(goal) <> None  then invalid_arg "fly to non-empty dot";
+  state.dots.(goal) <- state.dots.(from);
+  state.dots.(from) <- None
+
+let capture state index = 
+  let opponent = get_color (state.turn + 1) in
+  if state.dots.(index) <> Some opponent then invalid_arg "capture invalid dot";
+  if in_mill state index then invalid_arg "capture from mill";
+  state.dots.(index) <- None;
+  if opponent = White then state.nwhite <- pred state.nwhite
+  else state.nblack <- pred state.nblack
+
+let dot_to_char = function
+  | None -> ' '
+  | Some Black -> '#'
+  | Some White -> '@'
+
+let to_string state =
+  let d = state.dots in
+  let c = dot_to_char in
+  Printf.sprintf "\
+    [%c]--------[%c]--------[%c]\n \
+     | [%c]-----[%c]-----[%c] |\n \
+     |  | [%c]--[%c]--[%c] |  |\n\
+    [%c][%c][%c]       [%c][%c][%c]\n \
+     |  | [%c]--[%c]--[%c] |  |\n \
+     | [%c]-----[%c]-----[%c] |\n\
+    [%c]--------[%c]--------[%c]\n\
+    turn: %d, #: %d, @: %d\n"
+    (c d.(0)) (c d.(1)) (c d.(2)) (c d.(3)) (c d.(4)) (c d.(5))
+    (c d.(6)) (c d.(7)) (c d.(8)) (c d.(9)) (c d.(10)) (c d.(11))
+    (c d.(12)) (c d.(13)) (c d.(14)) (c d.(15)) (c d.(16)) (c d.(17))
+    (c d.(18)) (c d.(19)) (c d.(20)) (c d.(21)) (c d.(22)) (c d.(23))
+    state.turn state.nblack state.nwhite
+    
+(*
+indexes :
+[ 0]----------[ 1]----------[ 2]
+ |  [ 3]------[ 4]------[ 5] |
+ |   |  [ 6]--[ 7]--[ 8] |   |
+[ 9][10][11]        [12][13][14]
+ |   |  [15]--[16]--[17] |   |
+ |  [18]------[19]------[20] |
+[21]---------[22]----------[23]
+*)
+
+type color = White | Black
+
+type state
+
+val make : unit -> state 
+val copy : state -> state
+  
+val get_turn : state -> int
+val end_of_turn : state -> unit
+ 
+val get_color : int -> color
+val get : state -> int -> color option
+
+val get_count : state -> color -> int
+
+val free_dots : state -> int list 
+val colored_dots : state -> color -> int list
+val neighbors : int -> int list
+val free_neighbors : state -> int -> int list 
+val capturables : state -> color -> int list
+val movables:state -> color -> int list
+
+val can_put : state -> bool
+val can_fly : state -> bool
+
+val put : state -> int -> unit
+val move : state -> int -> int -> unit
+val fly : state -> int -> int -> unit
+val capture : state -> int -> unit
+
+val in_mill : state -> int -> bool
+val connected : int -> int -> bool
+val game_ended : state -> bool
+
+val to_string : state  -> string
+let human = object
+	method put state =
+    Printf.printf "%sput: %!" (Mill.to_string state);    
+    read_int ()
+	method move state = 
+    Printf.printf "%smove from: %!" (Mill.to_string state);    
+    let from = read_int () in
+    Printf.printf "move to: %!";    
+    let goal = read_int () in     
+    from, goal
+	method fly state = 
+    Printf.printf "%sfly from: %!" (Mill.to_string state);
+    let from = read_int () in
+    Printf.printf "fly to: %!";    
+    let goal = read_int () in     
+    from, goal
+	method capture state =
+    Printf.printf "%scapture: %!" (Mill.to_string state);    
+    read_int ()
+end
+
+let do_turn state player = 
+  if Mill.can_put state then begin 
+    let goal = player#put state in
+    Mill.put state goal;
+    if Mill.in_mill state goal then Mill.capture state (player#capture state)
+  end
+  else if Mill.can_fly state then begin
+    let from, goal = player#fly state in
+    Mill.fly state from goal;
+    if Mill.in_mill state goal then Mill.capture state (player#capture state)
+  end
+  else begin
+    let from, goal = player#move state in
+    Mill.move state from goal;
+    if Mill.in_mill state goal then Mill.capture state (player#capture state)
+  end
+
+let engine p1 p2 =
+  let next p = if p = p1 then p2 else p1 in
+  let loop state =
+    let p = ref p1 in
+    let s = ref state in
+    while not (Mill.game_ended !s) do
+      let state' = Mill.copy !s in
+	    begin
+        try 
+          do_turn state' !p;
+          Mill.end_of_turn state';
+          s := state';
+          p := next !p
+	      with ex -> ()
+      end;
+    done;
+    Printf.printf "end\n"
+  in
+  loop (Mill.make ())
+  
+
+let () = engine human Ai_montecarlo.player
+