Source

ocaml-minigames / memory / memory.ml

module Image = struct
  open Sdlvideo
  open Sdlloader
  
  let imgsize = 115
  
  let images = Array.make 12 None
  let background = ref None
  
  let load () =
    background := Some (load_image "data/memory/background.png");
    for i = 0 to (Array.length images -1) do
      images.(i) <- Some (load_image ("data/memory/" ^ string_of_int i ^ ".png"))
    done
  
  let blit dst dst_rect img = match img with
    | None -> failwith "image not initialized"
    | Some image ->
        Sdlvideo.blit_surface ~dst_rect: dst_rect ~src: image ~dst: dst ()
  
  let draw_img screen x y img =
    let open Sdlvideo in
    let fullrect = rect x y imgsize imgsize in
    blit screen fullrect img;
    update_rect ~rect: fullrect screen
end

let layout = function
  | 4 -> [2; 2]
  | 6 -> [3; 3]
  | 8 -> [4; 4]
  | 10 -> [3; 4; 3]
  | 12 -> [4; 4; 4]
  | 14 -> [5; 4; 5]
  | 16 -> [4; 4; 4; 4]
  | 18 -> [4; 5; 5; 4]
  | 20 -> [5; 5; 5; 5]
  | 22 -> [5; 6; 6; 5]
  | 24 -> [6; 6; 6; 6]
  | _ -> invalid_arg "wrong card number"

let positions width height cards =
  let open Image in
  let line_height lines =
    let whitespace = height - lines * imgsize in
    (whitespace / (lines +1)) + imgsize
  in
  let col_width cols =
    let whitespace = width - cols * imgsize in
    (whitespace / (cols +1)) + imgsize
  in
  let list = ref [] in
  let line_h = line_height (List.length cards) in
  for line = (List.length cards) - 1 downto 0 do
    let count = List.nth cards line in
    let col_w = col_width count in
    for col = count - 1 downto 0 do
      let x = (col_w - imgsize) + col * col_w
      and y = (line_h - imgsize) + line * line_h in
      list := (x, y) :: !list
    done
  done;
  !list

let make_deck size =
  let max = Array.length Image.images in
  let shuffle lst = List.sort (fun a b -> (Random.int 3) - 1) lst in
  let rec select_pairs acc = function
    | 0 -> acc
    | x ->
        let rnd = Random.int max in
        if List.mem rnd acc then select_pairs acc x
        else select_pairs (rnd :: rnd :: acc) (pred x)
  in
  let cards = select_pairs [] (size /2) in
  shuffle cards

type card = {
  img: int;
  x: int;
  y: int;
}

let get_cards width height count =
  let deck = make_deck count in
  let positions = positions width height (layout count) in
  let make_card img (x, y) = { img = img; x = x; y = y } in
  List.map2 make_card deck positions

module Game = struct
  open Sdlevent
  open Sdlkey
  
  let rec wait_some_click () =
    match wait_event() with
    | QUIT -> raise Exit
    | KEYDOWN { keysym = KEY_ESCAPE } -> raise Exit
    | MOUSEBUTTONDOWN _ -> ()
    | _ -> wait_some_click ()
  
  let rec select_card cards =
    let rec find_card x y = function
      | [] -> None
      | card:: list ->
          if card.x <= x && card.y <= y
          && card.x + Image.imgsize >= x && card.y + Image.imgsize >= y
          then Some card
          else find_card x y list
    in
    match wait_event() with
    | QUIT -> raise Exit
    | KEYDOWN { keysym = KEY_ESCAPE } -> raise Exit
    | MOUSEBUTTONDOWN event ->
        let x, y = event.mbe_x, event.mbe_y in
        begin match find_card x y cards with
          | Some (card) -> card
          | None -> select_card cards
        end
    | _ -> select_card cards
  
  let rec play screen cards =
    let show_backgrounds () =
      let white = Sdlvideo.map_RGB screen Sdlvideo.white in
      Sdlvideo.fill_rect screen white;
      List.iter (fun c -> Image.draw_img screen c.x c.y !Image.background) cards;
      Sdlvideo.flip screen
    and show_card c =
      Image.draw_img screen c.x c.y Image.images.(c.img);
      Sdlvideo.flip screen
    in
    match cards with
    | [] -> () (* victory *)
    | _ ->
        show_backgrounds ();
        let first = select_card cards in
        show_card first;
        let second = select_card cards in
        show_card second;
        let remaining = 
          if first.img <> second.img then cards
          else List.filter (fun c -> c.img <> first.img) cards
        in
        Sdltimer.delay 1500; 
        play screen remaining
end

let _ =
  Random.self_init();
  Sdl.init [`VIDEO; `AUDIO];
  at_exit Sdl.quit;
  Sdlmixer.open_audio ();
  at_exit Sdlmixer.close_audio;
  
  Sdlwm.set_caption "memory minigame" "";
  
  let width, height = 1024, 768 in
  let screen = Sdlvideo.set_video_mode ~w: width ~h: height [`HWSURFACE;`DOUBLEBUF] in
  
  Image.load ();
  let count = 10 in
  let cards = get_cards width height count in
  try
    Game.play screen cards
  with Exit -> ()