ocaml-minigames / memory / memory.ml

module Sfx = struct
  open Sdlmixer
  
  let turn = ref None
  let bleep = ref None
  let success = ref None
  
  let load () =
    turn := Some (loadWAV "data/memory/sfx/turn.wav");
    bleep := Some (loadWAV "data/memory/sfx/bleep.wav");
    success := Some (loadWAV "data/memory/sfx/success.wav")
  
  let play sfxref = match !sfxref with
    | None -> failwith "sound not initialized"
    | Some sound -> Sdlmixer.play_channel ~channel:0 sound
end

module Image = struct
  open Sdlvideo
  open Sdlloader
  
  let imgsize = 115
  
  let back = ref None
  let background = ref None
  let images = Array.make 12 None
  
  let load () =
    back := Some (load_image "data/memory/back.png");
    background := Some (load_image "data/memory/background.jpg");
    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
  
  let draw_background screen =
    draw_img screen 0 0 !background
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) -> (Sfx.play Sfx.turn; card)
          | None -> select_card cards
        end
    | _ -> select_card cards
  
  let play screen cards =
    let show_backgrounds cards =
      Image.draw_background screen;
      List.iter (fun c -> Image.draw_img screen c.x c.y !Image.back) cards;
      Sdlvideo.flip screen
    and show_card c =
      Image.draw_img screen c.x c.y Image.images.(c.img);
      Sdlvideo.flip screen
    in
    let rec loop flips cards =
      show_backgrounds cards;
      match cards with
      | [] ->
          Sdltimer.delay 500;
          Sfx.play Sfx.success;
          Sdltimer.delay 1000;
          flips
      | _ ->
          let first = select_card cards in
          show_card first;
          let second = select_card cards in
          show_card second;
          let success = first.img = second.img in
          let remaining =
            if not success then cards
            else List.filter (fun c -> c.img <> first.img) cards
          in
          Sdltimer.delay 1500;
          if success then Sfx.play Sfx.bleep;
          loop (succ flips) remaining
    in loop 0 cards
end

let init_sdl width height =
  Sdl.init [`VIDEO; `AUDIO];
  at_exit Sdl.quit;
  Sdlmixer.open_audio ();
  at_exit Sdlmixer.close_audio;
  
  Sdlwm.set_caption "memory minigame" "";
  Sdlvideo.set_video_mode width height [`HWSURFACE;`DOUBLEBUF]

let rec chain_games screen width height count =
  let level_up = if count = 24 then 24 else count + 2
  and level_down = if count = 4 then 4 else count - 2 in
  let cards = get_cards width height count in
  let flips = Game.play screen cards in
  let ratio = float_of_int flips /. float_of_int count in
  if ratio < 1.2 then chain_games screen width height level_up
  else if ratio > 2. then chain_games screen width height level_down
  else chain_games screen width height count

let _ =
  Random.self_init();
  let width, height = 1024, 768 in
  let screen = init_sdl width height in
  Image.load ();
  Sfx.load ();
  let count = 12 in
  try
    chain_games screen width height count
  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.