Source

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; 263, 85; 442, 85; 148, 148; 264, 148; 381, 148;
    206, 206;267, 206; 323, 206; 85, 262; 148, 262; 206, 262; 323, 263;
    382, 264; 442, 264; 207, 322; 262, 322; 323, 321; 147, 381; 262, 380;
    381, 379; 86, 440; 261, 440; 440, 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 Human = struct
  open Sdlevent
  open Sdlvideo
  
  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
    | 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 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
        Image.draw_state state';
        Image.draw_marker goal;
        if Mill.in_mill state' goal then begin
          let capture = (!p#capture state') in
          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;
  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 _ =
  Random.self_init ();
  let screen = init_sdl () in
  Image.load screen;
  mainloop Human.player Ai_alphabeta.player;
  Sdltimer.delay 1500;