ocaml-minigames / mills / sdlmills.ml

module Image = struct
  open Sdlvideo
  open Sdlloader
  
  let background_size = 530
  let stone_size = 36
  
  let dot_coords = [| 87,85; 265,85; 444,84; 149,148; 264,147; 382,148;
    207,207; 264,206; 322,207; 86,264; 148,264; 206,264; 322,265; 382,264;
    442,265; 207,322; 264,322; 322,322; 147,381; 263,380; 381,380; 85,440;
    263,441; 441,440 |]
  
  let dot_rects =
    let rect (x, y) = Sdlvideo.rect (x - stone_size /2) (y - stone_size /2)
        stone_size stone_size
    in
    Array.map rect dot_coords
  
  let screen = ref None
  
  let background = ref None
  let black = ref None
  let white = ref None
  let marker = ref None
  let capture = ref None
  let selectable_stone = ref None
  let selectable_dot = ref None
  let selection = ref None
  
  let load surface =
    screen := Some surface;
    background := Some (load_image "data/mills/background.png");
    white := Some (load_image "data/mills/white.png");
    black := Some (load_image "data/mills/black.png");
    marker := Some (load_image "data/mills/marker.png");
    capture := Some (load_image "data/mills/capture.png");
    selectable_stone := Some (load_image "data/mills/selectable_stone.png");
    selectable_dot := Some (load_image "data/mills/selectable_dot.png");
    selection := Some (load_image "data/mills/selection.png")
  
  let blit dst dst_rect imgref = match !imgref with
    | None -> failwith "image not initialized"
    | Some image ->
        Sdlvideo.blit_surface ~dst_rect: dst_rect ~src: image ~dst: dst ()
  
  let update_rect rect =
    match !screen with
    | None -> failwith "screen not initialized"
    | Some surface -> Sdlvideo.update_rect surface ~rect
  
  let draw_background () =
    match !screen with
    | None -> failwith "screen not initialized"
    | Some surface ->
        blit surface (Sdlvideo.rect 0 0 background_size background_size) background
  
  let draw_stone imgref index =
    let r = dot_rects.(index) in
    match !screen with
    | None -> failwith "screen not initialized"
    | Some surface -> blit surface r imgref
  
  let draw_marker index =
    draw_stone marker index;
    update_rect dot_rects.(index)
  
  let draw_capture index =
    draw_stone capture index;
    update_rect dot_rects.(index)
  
  let draw_selection index =
    draw_stone selection index;
    update_rect dot_rects.(index)
  
  let draw_selectable_stone index =
    draw_stone selectable_stone index;
    update_rect dot_rects.(index)
  
  let draw_selectable_dot index =
    draw_stone selectable_dot index;
    update_rect dot_rects.(index)
  
  let rec draw_selectables_stones = function
    | [] -> ()
    | t:: q -> draw_selectable_stone t; draw_selectables_stones q
  
  let rec draw_selectables_dots = function
    | [] -> ()
    | t:: q -> draw_selectable_dot t; draw_selectables_dots q
  
  let draw_state state =
    draw_background ();
    for i = 0 to 23 do
      match Mill.get state i with
      | Some Mill.Black -> draw_stone black i
      | Some Mill.White -> draw_stone white i
      | None -> ()
    done;
    match !screen with
    | None -> failwith "screen not initialized"
    | Some surface -> Sdlvideo.update_rect surface
end

module Sfx = struct
  open Sdlmixer
  
  let move = ref None
  let capture = ref None
  let win = ref None
  let lose = ref None
  
  let load () =
    move := Some (loadWAV "data/mills/move.wav");
    capture := Some (loadWAV "data/mills/capture.wav");
    win := Some (loadWAV "data/mills/win.wav");
    lose := Some (loadWAV "data/mills/lose.wav")
  
  let play sfxref = match !sfxref with
    | None -> failwith "sound not initialized"
    | Some sound -> Sdlmixer.play_channel ~channel:0 sound
end

module Human = struct
  open Sdlvideo
  open Sdlevent
  open Sdlkey
  
  let find_rect selection event =
    let check r =
      r.r_x < event.mbe_x && r.r_x + r.r_w > event.mbe_x
      && r.r_y < event.mbe_y && r.r_y + r.r_h > event.mbe_y
    in
    let rec loop = function
      | [] -> raise Not_found
      | t:: q ->
          if check Image.dot_rects.(t) then t
          else loop q
    in
    loop selection
  
  let rec slurp_events () = match poll() with
    | None -> ()
    | Some event -> slurp_events ()
  
  let rec select_dot dots =
    slurp_events ();
    match wait_event () with
    | QUIT -> raise Exit
    | KEYDOWN { keysym = KEY_ESCAPE } -> raise Exit
    | MOUSEBUTTONUP e ->
        begin
          try
            find_rect dots e
          with Not_found -> select_dot dots
        end
    | _ -> select_dot dots
  
  let player = object
    method put state =
      let selectables = (Mill.free_dots state) in
      Image.draw_selectables_dots selectables;
      select_dot selectables
    method move state =
      let color = Mill.get_color (Mill.get_turn state) in
      let selectables = (Mill.movables state color) in
      Image.draw_selectables_stones selectables;
      let from = select_dot selectables in
      Image.draw_state state;
      Image.draw_selection from;
      let selectables = (Mill.free_neighbors state from) in
      Image.draw_selectables_dots selectables;
      let goal = select_dot selectables in
      from, goal
    method fly state =
      let color = Mill.get_color (Mill.get_turn state) in
      let selectables = (Mill.colored_dots state color) in
      Image.draw_selectables_stones selectables;
      let from = select_dot selectables in
      Image.draw_state state;
      Image.draw_selection from;
      let selectables = (Mill.free_dots state) in
      Image.draw_selectables_dots selectables;
      let goal = select_dot selectables in
      from, goal
    method capture state =
      let opponent = Mill.get_color (succ (Mill.get_turn state)) in
      let selectables = (Mill.capturables state opponent) in
      Image.draw_selectables_stones selectables;
      select_dot selectables
  end
end

let do_turn state player =
  if Mill.can_put state then begin
    let goal = player#put state in
    Mill.put state goal;
    goal
  end
  else if Mill.can_fly state then begin
    let from, goal = player#fly state in
    Mill.fly state from goal;
    goal
  end
  else begin
    let from, goal = player#move state in
    Mill.move state from goal;
    goal
  end

let mainloop p1 p2 =
  let open Sdlevent in
  let open Sdlkey in
  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
        let goal = do_turn state' !p in
        Sfx.play Sfx.move;
        Image.draw_state state';
        Image.draw_marker goal;
        if Mill.in_mill state' goal then begin
          let capture = (!p#capture state') in
          Sfx.play Sfx.capture;
          Mill.capture state' capture;
          Image.draw_state state';
          Image.draw_marker goal;
          Image.draw_capture capture;
        end;
        Mill.end_of_turn state';
        
        s := state';
        p := next !p
      end;
    done;
    print_string (Mill.to_string !s);
    if !p = Human.player then Sfx.play Sfx.lose
    else Sfx.play Sfx.win
  in
  let state = Mill.make () in
  Image.draw_state state;
  loop state

let init_sdl () =
  Sdl.init [`VIDEO; `AUDIO];
  at_exit Sdl.quit;
  Sdlmixer.open_audio ();
  at_exit Sdlmixer.close_audio;
  
  Sdlkey.enable_key_repeat ();
  Sdlwm.set_caption "mills minigame" "";
  Sdlvideo.set_video_mode Image.background_size Image.background_size []

let _ =
  let white = ref Human.player in
  let black = ref Ai_alphabeta.player in
  let players = ["human";"montecarlo";"minimax";"alphabeta";"random"] in
  let get_player = function
    | "human" -> Human.player
    | "montecarlo" -> Ai_montecarlo.player
    | "minimax" -> Ai_minimax.player
    | "alphabeta" -> Ai_alphabeta.player
    | "random" -> Ai_random.player
    | _ -> raise (Arg.Bad "unkown player")
  in
  let set_white s = white := get_player s in
  let set_black s = black := get_player s in
  let args =
    let open Arg in
    ("-white", Symbol (players, set_white), "player who will play white") ::
    ("-black", Symbol (players, set_black), "player who will play white") ::
    []
  in
  Arg.parse args ignore "usage";    
  
  Random.self_init ();
  let screen = init_sdl () in
  Image.load screen;
  Sfx.load ();
  try
    mainloop !white !black;
    Sdltimer.delay 1500;
  with Exit -> ()
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.