ai.ml — Coverage report

open Core
open Game_state

type difficulty = Easy | Medium | Hard
type ai_player = { player_index : int; difficulty : difficulty }

type ai_suggestion = {
  move : Move.t;
  score : int;
  words : string list;
  expected_value : int;
}

let depth_of_difficulty = function Easy -> 1 | Medium -> 2 | Hard -> 3
let alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
let board_size = Board.board_size

(* Finds all possible positions on the board where a word can be played, given a starting position and the word length. *)
let build_span_positions (start_pos : Placed_tile.position)
    (direction : Board.direction) (length : int) :
    Placed_tile.position list option =
  let open Placed_tile in
  let rec loop i acc =
    if i = length then Some (List.rev acc)
    else
      let pos =
        match direction with
        | Horizontal -> { row = start_pos.row; col = start_pos.col + i }
        | Vertical -> { row = start_pos.row + i; col = start_pos.col }
      in
      if Board.is_valid_position pos then loop (i + 1) (pos :: acc) else None
  in
  loop 0 []

(* Helper function to check if a list of positions contains one that touches the starting space.*)
let covers_center (positions : Placed_tile.position list) : bool =
  List.exists ~f:(fun pos -> pos.row = 7 && pos.col = 7) positions

(* Checks if any of the given positions on the board or its immediate neighbors neighbors collide with an existing tile *)
let span_touches_existing_tile (board : Board.t)
    (positions : Placed_tile.position list) : bool =
  let open Placed_tile in
  let touches pos =
    Board.get_tile_at board pos |> Option.is_some
    ||
    let neighbors =
      [
        { row = pos.row - 1; col = pos.col };
        { row = pos.row + 1; col = pos.col };
        { row = pos.row; col = pos.col - 1 };
        { row = pos.row; col = pos.col + 1 };
      ]
    in
    List.exists
      ~f:(fun p ->
        Board.is_valid_position p && Board.get_tile_at board p |> Option.is_some)
      neighbors
  in
  List.exists ~f:touches positions

let generate_tile_permutations (rack : Rack.t) (length : int) ~(limit : int) :
    'a list list =
  let used_orig = List.init (Rack.length rack) ~f:(fun _ -> false) in
  let rec backtrack (acc : 'a list) (results : 'a list list) (used : bool list)
      : 'a list list =
    if List.length results >= limit then results
    else if List.length acc = length then backtrack [] (acc :: results) used
    else
      let rec iterate (i : int) (results : 'a list list) : 'a list list =
        if i = Rack.length rack then results
        else if not (List.nth_exn used i) then
          iterate (i + 1)
            (backtrack
               (Rack.nth_exn rack i :: acc)
               results
               (List.mapi ~f:(fun k el -> if k = i then true else el) used))
        else iterate (i + 1) results
      in
      iterate 0 results
  in
  backtrack [] [] used_orig |> List.map ~f:List.rev

let expand_blank_placements (placed_tiles : Placed_tile.t list) ~(limit : int) :
    Placed_tile.t list list =
  let alphabet_chars =
    List.init (String.length alphabet) ~f:(String.get alphabet)
  in
  let rec aux partial remaining acc =
    if List.length acc >= limit then acc
    else
      match remaining with
      | [] -> partial :: acc
      | (pt : Placed_tile.t) :: rest -> (
          match Tile.is_blank_without_letter pt.tile with
          | true ->
              let rec add_letters letters accum =
                match letters with
                | [] -> accum
                | c :: cs ->
                    if List.length accum >= limit then accum
                    else
                      let tile = Tile.make ~blank_with_letter:true (Some c) 0 in
                      let accum =
                        aux ({ pt with tile } :: partial) rest accum
                      in
                      add_letters cs accum
              in
              add_letters alphabet_chars acc
          | false -> aux (pt :: partial) rest acc)
  in
  aux [] placed_tiles [] |> List.map ~f:List.rev

let take (n : int) (ls : 'a list) : 'a list =
  let rec loop i acc = function
    | [] -> List.rev acc
    | _ when i = 0 -> List.rev acc
    | x :: xs -> loop (i - 1) (x :: acc) xs
  in
  loop n [] ls

let validate_and_score_move game_state board placement =
  (* check whether move is valid *)
  let valid, _, _ = Validation.validate_move game_state placement in
  if not valid then None
  else
    let temp_board =
      List.fold placement ~init:board ~f:(fun b { tile; pos } ->
          Board.place_tile_on_board b pos tile)
    in
    let words = Word_extraction.extract_words temp_board placement in
    if List.is_empty words then None
    else
      let score = Scoring.calculate_move_score words placement in
      Some
        {
          move = Place placement;
          score;
          words = List.map words ~f:(fun w -> w.word);
          expected_value = 0;
        }
(* return valid AI move *)

let try_word_placement game_state rack start_pos direction word_length =
  match build_span_positions start_pos direction word_length with
  | None -> [] (* invalid position or out bounds *)
  | Some positions ->
      let board = game_state.board in
      let board_empty = Board.is_board_empty board in

      if board_empty && not (covers_center positions) then []
        (* ensure word placement is valid *)
      else if
        (not board_empty) && not (span_touches_existing_tile board positions)
      then []
      else (* get empty board squares *)
        let empty_positions =
          List.filter positions ~f:(fun pos ->
              Option.is_none (Board.get_tile_at board pos))
        in
        if List.is_empty empty_positions then []
        else if
          List.length empty_positions > Rack.length rack
          || List.length empty_positions > 7
        then []
        else
          let permutations =
            (* generate possible tile permutations *)
            generate_tile_permutations rack
              (List.length empty_positions)
              ~limit:200
          in
          permutations
          (* generate all possible blank tile expansions, validate them, and keep only valid scored moves *)
          |> List.concat_map ~f:(fun tiles ->
                 let placed_tiles =
                   List.map2_exn empty_positions tiles ~f:(fun pos tile ->
                       Placed_tile.{ tile; pos })
                 in
                 expand_blank_placements placed_tiles ~limit:5000)
          |> List.filter_map ~f:(validate_and_score_move game_state board)

let generate_possible_moves game_state player =
  let rack = Player.get_rack player in
  if Rack.is_empty rack then [] (* no possible moves *)
  else (* makes list of possible moves *)
    let all_moves =
      List.init board_size ~f:Fn.id (* iterate over every row *)
      |> List.concat_map ~f:(fun row ->
             List.init board_size ~f:Fn.id (* iterate over every column *)
             |> List.concat_map ~f:(fun col ->
                    let pos : Placed_tile.position = { row; col } in
                    Board.[ Horizontal; Vertical ]
                    |> List.concat_map ~f:(fun direction ->
                           List.init board_size ~f:(fun i -> i + 1)
                           |> List.concat_map ~f:(fun word_length ->
                                  try_word_placement game_state rack pos
                                    direction word_length))))
    in
    all_moves
    |> List.sort ~compare:(fun (a : ai_suggestion) (b : ai_suggestion) ->
           match Int.compare b.score a.score with
           | 0 ->
               let len_a = String.length (String.concat a.words)
               and len_b = String.length (String.concat b.words) in
               Int.compare len_b len_a
           | cmp -> cmp)
    |> take 20 (* keep top 20 best moves *)

let rec minimax game_state depth is_maximizing ai_player_index =
  let players = game_state.players in
  let ai_score =
    match List.find ~f:(fun p -> Player.get_id p = ai_player_index) players with
    (* access id field of players to find ai player *)
    | Some p -> Player.get_score p (* return ai player score*)
    | None -> 0
  in
  let opponent_best =
    players
    |> List.filter ~f:(fun p -> Player.get_id p <> ai_player_index)
       (* filters out AI player to get opponent's scores *)
    |> List.fold ~init:0 ~f:(fun acc (p : Player.t) ->
           Int.max acc (Player.get_score p))
    (* fold over list of players to find max score *)
  in

  if depth = 0 || Game_state.is_game_over game_state then
    (None, ai_score - opponent_best)
  else
    let current_player = Game_state.get_current_player game_state in
    (* whose turn is it *)
    let is_ai_turn = Player.get_id current_player = ai_player_index in
    let possible_moves = generate_possible_moves game_state current_player in
    (* get possible moves from function and evaluate them *) 
    let eval_moves moves init_val is_maximizing next_phase =
      List.fold moves ~init:(None, init_val) ~f:(fun (best_move, best_value) move ->
        let success, _, new_state, _, _ = Move.apply game_state move.move in
        match (success, new_state) with
        | true, Some state -> let _, value = minimax state (depth - 1) next_phase ai_player_index in
          let better = if is_maximizing then value > best_value else value < best_value in
          if better then (Some move, value) else (best_move, best_value)
        | _ -> (best_move, best_value)) in

    let handle_no_move next_phase = (* no available move *)
      let success, _, new_state, _, _ = Move.apply game_state Pass in
      match (success, new_state) with
      | true, Some state -> minimax state (depth - 1) next_phase ai_player_index
      | _ -> (None, ai_score - opponent_best) in

    if is_maximizing && is_ai_turn then (* in maximizing phase *)
      let best_move, best_value = eval_moves possible_moves Int.min_value true false in
      (match best_move with
      | Some _ -> (best_move, best_value)
      | None -> handle_no_move false)
    else (* in minimizing phase *)
      let worst_move, worst_value = eval_moves possible_moves Int.max_value false true in
      (match worst_move with
      | Some _ -> (worst_move, worst_value)
      | None -> handle_no_move true)

let find_best_move game_state ai_player =
  if Game_state.is_game_over game_state then None
  else
    let depth = depth_of_difficulty ai_player.difficulty in
    let move, value = minimax game_state depth true ai_player.player_index in
    match move with
    | Some m ->
        Some
          {
            move = m.move;
            score = m.score;
            words = m.words;
            expected_value = value;
          }
    | None -> None

let create_ai_player player_index difficulty = { player_index; difficulty }

let is_ai_player player ai_players =
  List.exists ai_players ~f:(fun ai -> ai.player_index = Player.get_id player)
src/lib/ai.ml

95.36%
