Source

ocaml-minigames / mills / mill.ml

(*
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 connections =
  let find_connections i =
    let rec find src accu = match src with
      | [] -> accu
      | (a, b, c) :: lst -> 
        if a = i then find lst (b :: accu)
        else if b = i then find lst (a :: c :: accu)   
        else if c = i then find lst (b :: accu)
        else find lst accu   
    in 
    find mills []
  in    
  Array.init 24 find_connections
                         
let connected a b = List.mem b connections.(a)    

let find_dots state dot = 
  let rec loop i accu = 
    if i = 24 then accu
    else if state.dots.(i) = dot then loop (succ i) (i :: accu)
    else loop (succ i) accu  
  in loop 0 []
      
let free_dots state = find_dots state None

let colored_dots state color = find_dots state (Some color)

let neighbors i = connections.(i)

let get_color turn = if turn mod 2 = 0 then White else Black    

let get_turn state = state.turn

let free_neighbors state i =
  let free i = state.dots.(i) = None in
  List.filter (free) (neighbors i)

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 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 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 unroll_turn state = state.turn <- pred 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