4
\$\begingroup\$

I wrote the following two players snake game in OCaml. It is working fine (I did not pay much efforts to the graphical appearance though). As a beginner in OCaml, I would be happy to have some review.

#load "unix.cma";;
#load "graphics.cma";;

let minisleep (sec: float) =
    ignore (Unix.select [] [] [] sec);;

Graphics.open_graph " ";;
Graphics.set_window_title "Test !";;
Graphics.plot 50 50;;


type relief = Top | Bot | Flat;;


type box_config =
{   w:int; h:int; bw:int; mutable r:relief;
    b1_col : Graphics.color;
    b2_col : Graphics.color;
    b_col : Graphics.color} ;;


let draw_rect x0 y0 w h =
    let (a,b) = Graphics.current_point()
        and x1 = x0+w 
        and y1 = y0+h
    in
    Graphics.moveto x0 y0;
    Graphics.lineto x0 y1; Graphics.lineto x1 y1;
    Graphics.lineto x1 y0; Graphics.lineto x0 y0;
    Graphics.moveto a b ;;


let draw_background n_tiles tile_size =
    for i=1 to n_tiles do
        for j=1 to n_tiles do
            draw_rect (i*tile_size) (j*tile_size) tile_size tile_size
        done
    done ;;


let draw_box_outline bcf col x1 y1=
    Graphics.set_color col;
    draw_rect x1 y1 bcf.w bcf.h ;;


let draw_box bcf x1 y1 =
    let x2 = x1+bcf.w and y2 = y1+bcf.h in
    let ix1 = x1+bcf.bw and ix2 = x2-bcf.bw
    and iy1 = y1+bcf.bw and iy2 = y2-bcf.bw in
    let border1 g =
        Graphics.set_color g;
        Graphics.fill_poly
        [| (x1,y1);(ix1,iy1);(ix2,iy1);(ix2,iy2);(x2,y2);(x2,y1) |]
    in
    let border2 g =
        Graphics.set_color g;
        Graphics.fill_poly
        [| (x1,y1);(ix1,iy1);(ix1,iy2);(ix2,iy2);(x2,y2);(x1,y2) |]
    in
    Graphics.set_color bcf.b_col;
    ( match bcf.r with
        Top ->
        Graphics.fill_rect ix1 iy1 (ix2-ix1) (iy2-iy1);
        border1 bcf.b1_col;
        border2 bcf.b2_col
        | Bot ->
        Graphics.fill_rect ix1 iy1 (ix2-ix1) (iy2-iy1);
        border1 bcf.b2_col;
        border2 bcf.b1_col
        | Flat ->
        Graphics.fill_rect x1 y1 bcf.w bcf.h );
        draw_box_outline bcf Graphics.black x1 y1   
    ;;


let tile_size = 3 and n_tiles = 150 and refresh_rate = 0.02;;
let speed = tile_size ;;


type player = {x:int; y:int; s_x:int; s_y:int} ;;

let update_player_position pl = {
    x = pl.x + pl.s_x ;
    y = pl.y + pl.s_y ;
    s_x = pl.s_x ;
    s_y = pl.s_y};;

let box_player_1 = {
    w=tile_size;
    bw=tile_size/2;
    h=tile_size;
    r=Top; 
    b1_col = 657900; 
    b2_col = 657900; 
    b_col=657900};; 

let box_player_2 = {
    w=tile_size;
    bw=tile_size/2;
    h=tile_size;
    r=Top; 
    b1_col = 35700; 
    b2_col = 35700; 
    b_col=35700};;

let player_1 = {x=((n_tiles-1)/2)*tile_size; y=tile_size ;s_y=speed; s_x=0} ;;

let player_2 = {x=((n_tiles-1)/2)*tile_size; y=(n_tiles-1)*tile_size; s_y= (-1)*speed; s_x=0} ;;

draw_background n_tiles tile_size;

let draw_players box_player_1 box_player_2 player_1 player_2 =    
    draw_box box_player_1 player_1.x player_1.y;
    draw_box box_player_2 player_2.x player_2.y;
    in

let key_pressed_player_1 button_pressed player =
    (match button_pressed with
      'q' ->  if player.s_x <> speed then {x = player.x; y = player.y; s_x = (-1)*speed; s_y = 0} else player;
      |'d' -> if player.s_x <> (-1)*speed then {x = player.x; y =player.y; s_x = speed; s_y = 0} else player;
      |'z' -> if player.s_y <> (-1)*speed then  {x = player.x; y =player.y; s_x = 0; s_y = speed} else player;
      |'s' -> if player.s_y <> speed then {x = player.x; y =player.y; s_x = 0; s_y = (-1)*speed} else player;
      |_ ->  player)
    in

let key_pressed_player_2 button_pressed player =
    (match button_pressed with
      'j' ->  if player.s_x <> speed then {x = player.x; y = player.y; s_x = (-1)*speed; s_y = 0} else player;
      |'l' -> if player.s_x <> (-1)*speed then {x = player.x; y =player.y; s_x = speed; s_y = 0} else player;
      |'i' -> if player.s_y <> (-1)*speed then  {x = player.x; y =player.y; s_x = 0; s_y = speed} else player;
      |'k' -> if player.s_y <> speed then {x = player.x; y =player.y; s_x = 0; s_y = (-1)*speed} else player;
      |_ ->  player)
    in

let is_out player =
    (player.x > tile_size*n_tiles) || (player.y > tile_size*n_tiles) || (player.x < 0) || (player.y < 0)
    in

let is_on_wall player walls =
    List.mem (player.x,player.y) walls
    in

let has_lost player walls =
    (is_out player) || (is_on_wall player walls)
    in

let  main_loop player_1 player_2 =

    let rec aux player_1 player_2 walls over =
        draw_players box_player_1 box_player_2 player_1 player_2;


        let e = Graphics.wait_next_event [Graphics.Poll] in
        if e.Graphics.keypressed then
            ignore (Graphics.wait_next_event [Graphics.Key_pressed]);

        let player_1_bis = key_pressed_player_1 e.Graphics.key player_1 and
            player_2_bis = key_pressed_player_2 e.Graphics.key player_2 in

        minisleep refresh_rate;

        let player_1_next = update_player_position player_1_bis and
            player_2_next = update_player_position player_2_bis in

        if (has_lost player_1_next walls) then begin
            minisleep 3.0; 
            exit 0 
        end else ();
        if (has_lost player_2_next walls) then begin 
            minisleep 3.0; 
            exit 0; 
        end else ();

        aux player_1_next player_2_next ((player_1_next.x,player_1_next.y)::(player_2_next.x,player_2_next.y)::walls) over ;
    in
    aux player_1 player_2 [] false
in

main_loop player_1 player_2;

Actually, there was this obvious refactoring :

if (has_lost player_1_next walls || has_lost player_2_next walls ) then begin
    minisleep 3.0; 
    exit 0 
end else ();

Instead of the redundant code :

if (has_lost player_1_next walls) then begin
    minisleep 3.0; 
    exit 0 
end else ();
if (has_lost player_2_next walls) then begin 
    minisleep 3.0; 
    exit 0; 
end else ();

Edit. I am particularly interested in refactoring this redundant code :

let key_pressed_player_1 button_pressed player =
    (match button_pressed with
      'q' ->  if player.s_x <> speed then {x = player.x; y = player.y; s_x = (-1)*speed; s_y = 0} else player;
      |'d' -> if player.s_x <> (-1)*speed then {x = player.x; y =player.y; s_x = speed; s_y = 0} else player;
      |'z' -> if player.s_y <> (-1)*speed then  {x = player.x; y =player.y; s_x = 0; s_y = speed} else player;
      |'s' -> if player.s_y <> speed then {x = player.x; y =player.y; s_x = 0; s_y = (-1)*speed} else player;
      |_ ->  player)
    in

let key_pressed_player_2 button_pressed player =
    (match button_pressed with
      'j' ->  if player.s_x <> speed then {x = player.x; y = player.y; s_x = (-1)*speed; s_y = 0} else player;
      |'l' -> if player.s_x <> (-1)*speed then {x = player.x; y =player.y; s_x = speed; s_y = 0} else player;
      |'i' -> if player.s_y <> (-1)*speed then  {x = player.x; y =player.y; s_x = 0; s_y = speed} else player;
      |'k' -> if player.s_y <> speed then {x = player.x; y =player.y; s_x = 0; s_y = (-1)*speed} else player;
      |_ ->  player)
    in
\$\endgroup\$
2
+50
\$\begingroup\$

I tried to run your code on my machine. There is no syntax error, the graphics window opens, and I can see the snakes moving. However when I press a key, the program fails with Exception: Unix.Unix_error (Unix.EINTR, "select", ""). I will not try to figure out whether it's a bug in your program or in my configuration, but I can refactor your code a bit.

The first thing is to make sure that top-level values and functions are defined at the top level. At the beginning, everything is fine, but draw_background is followed by a single semicolon, so the syntax prevents you from defining the next functions at the toplevel.

let player_2 = {x=((n_tiles-1)/2)*tile_size; y=(n_tiles-1)*tile_size; s_y= (-1)*speed; s_x=0} ;;

draw_background n_tiles tile_size;

let draw_players box_player_1 box_player_2 player_1 player_2 =    
    draw_box box_player_1 player_1.x player_1.y;
    draw_box box_player_2 player_2.x player_2.y;
    in

let key_pressed_player_1 button_pressed player =
    (match button_pressed with
      'q' ->  if player.s_x <> speed then {x = player.x; y = player.y; s_x = (-1)*speed; s_y = 0} else player;
      |'d' -> if player.s_x <> (-1)*speed then {x = player.x; y =player.y; s_x = speed; s_y = 0} else player;
      |'z' -> if player.s_y <> (-1)*speed then  {x = player.x; y =player.y; s_x = 0; s_y = speed} else player;
      |'s' -> if player.s_y <> speed then {x = player.x; y =player.y; s_x = 0; s_y = (-1)*speed} else player;
      |_ ->  player)
    in

Can be changed into

let player_2 = {x=((n_tiles-1)/2)*tile_size; y=(n_tiles-1)*tile_size; s_y= (-1)*speed; s_x=0} ;;

let () = draw_background n_tiles tile_size;;

let draw_players box_player_1 box_player_2 player_1 player_2 =    
    draw_box box_player_1 player_1.x player_1.y;
    draw_box box_player_2 player_2.x player_2.y

let key_pressed_player_1 button_pressed player =
    (match button_pressed with
      'q' ->  if player.s_x <> speed then {x = player.x; y = player.y; s_x = (-1)*speed; s_y = 0} else player;
      |'d' -> if player.s_x <> (-1)*speed then {x = player.x; y =player.y; s_x = speed; s_y = 0} else player;
      |'z' -> if player.s_y <> (-1)*speed then  {x = player.x; y =player.y; s_x = 0; s_y = speed} else player;
      |'s' -> if player.s_y <> speed then {x = player.x; y =player.y; s_x = 0; s_y = (-1)*speed} else player;
      |_ ->  player)

Notice that instead of using let f x = foo in let g x = bar in we can keep defining top level bindings: let f x = foo let g x = bar. The intermediate bindings can be adapted this way up until the call to the main loop:

    aux player_1 player_2 [] false
in

main_loop player_1 player_2;

is turned into

    aux player_1 player_2 [] false

let () = main_loop player_1 player_2;;

Now I can separate the function and value definitions from the instructions actually executing the code, which gives the following grouping at the end of the file.

let () =
  Graphics.open_graph " ";
  Graphics.set_window_title "Test !";
  Graphics.plot 50 50;
  draw_background n_tiles tile_size;
  main_loop player_1 player_2;;

I try to improve (my) readability by adjusting the style slightly. For instance, following semicolons with a single space: (x1,y1);(ix1,iy1); becomes (x1,y1); (ix1,iy1);. Also editing the column alignment here and there.

I use the record update notation. This is quite useful when you are creating a new record based on an existing one and only changing a few fields. For instance:

let update_player_position pl = {
    x = pl.x + pl.s_x ;
    y = pl.y + pl.s_y ;
    s_x = pl.s_x ;
    s_y = pl.s_y};;

Becomes

let update_player_position pl = { pl with x = pl.x + pl.s_x ; y = pl.y + pl.s_y };;

The same trick can be used in the key_pressed_player_1 function. It gives

let key_pressed_player_1 button_pressed player =
    (match button_pressed with
      |'q' -> if player.s_x <>        speed then { player with s_x = (-1)*speed; s_y =          0 } else player;
      |'d' -> if player.s_x <> (-1) * speed then { player with s_x =      speed; s_y =          0 } else player;
      |'z' -> if player.s_y <> (-1) * speed then { player with s_x =          0; s_y =      speed } else player;
      |'s' -> if player.s_y <>        speed then { player with s_x =          0; s_y = (-1)*speed } else player;
      |_ ->  player)

key_pressed_player_2 is similarly adapted, and now I see clearly the similarity between the two. It really begs for refactoring, as you indicated in your post edit. The only difference between the two functions is which key corresponds to which direction. Once the mapping is given, both function behave exactly the same. So I first define a type to capture the concept of direction, and two functions for the mapping from keys to directions.

type direction = Left | Right | Up | Down

let key_to_direction_1 button_pressed = match button_pressed with
  | 'q' -> Some Left
  | 'd' -> Some Right
  | 'z' -> Some Up
  | 's' -> Some Down
  | _   -> None
let key_to_direction_2 button_pressed = match button_pressed with
  | 'j' -> Some Left
  | 'l' -> Some Right
  | 'i' -> Some Up
  | 'k' -> Some Down
  | _   -> None

The next step is to capture how the speed of the player is updated based on the desired direction, if any.

let update_speed direction_option player = match direction_option with
  | Some Left  -> if player.s_x <>        speed then { player with s_x = (-1)*speed; s_y =          0 } else player;
  | Some Right -> if player.s_x <> (-1) * speed then { player with s_x =      speed; s_y =          0 } else player;
  | Some Up    -> if player.s_y <> (-1) * speed then { player with s_x =          0; s_y =      speed } else player;
  | Some Down  -> if player.s_y <>        speed then { player with s_x =          0; s_y = (-1)*speed } else player;
  | None ->  player

Now I can redefine the key_pressed_player functions to glue the key-direction mapping and the speed update.

let key_pressed_player_1 button_pressed player = update_speed (key_to_direction_1 button_pressed) player
let key_pressed_player_2 button_pressed player = update_speed (key_to_direction_2 button_pressed) player

Note how the key_to_direction_1 function matches immediately on its last (and single) argument and never uses the argument name anywhere else. In such a situation we don't even need to name the argument:

let key_to_direction_1 = function
  | 'q' -> Some Left
  | 'd' -> Some Right
  | 'z' -> Some Up
  | 's' -> Some Down
  | _   -> None

The same trick can be used for update_speed provided we switch the order of the arguments. Of course the order of the arguments also needs to be switched in calls to update_speed.

let update_speed player = function
  | Some Left  -> if player.s_x <>      speed then { player with s_x = -1 * speed; s_y =          0 } else player;
  | Some Right -> if player.s_x <> -1 * speed then { player with s_x =      speed; s_y =          0 } else player;
  | Some Up    -> if player.s_y <> -1 * speed then { player with s_x =          0; s_y =      speed } else player;
  | Some Down  -> if player.s_y <>      speed then { player with s_x =          0; s_y = -1 * speed } else player;
  | None ->  player

Minor stylistic update as I go over the code: the disjunction and conjunction boolean operators || and && have low priority, so we can drop the parentheses around expressions surrounding them. For instance

let has_lost player walls =
    (is_out player) || (is_on_wall player walls)

becomes

let has_lost player walls = is_out player || is_on_wall player walls

Similarly,

        if (has_lost player_1_next walls) then begin
            minisleep 3.0; 
            exit 0 
        end else ();

can be turned into

        if has_lost player_1_next walls then
            (minisleep 3.0; 
            exit 0);

I usually prefer using parentheses instead of begin and end to group sequences of expressions, but it doesn't really matter. This way, I never need to use these two keywords.

I see that the graphics related functions are independent of the other ones, so I can group them in a module that I call Draw (in my own project, I would create a file Draw.ml to hold them). When I do this, I do not need the "draw" prefix that you added to avoid future namespace collision.

There is another convenient record syntax. When defining function taking a record as argument, one can deconstruct and bind the relevant fields directly. For instance is_out can be rewritten as

let is_out { x; y; _ } = x > tile_size * n_tiles || y > tile_size * n_tiles || x < 0 || y < 0

It seems that both player's boxes are identical, except for the color. We can share the construction.

let box_player color = {
  w  = tile_size;
  bw = tile_size / 2;
  h  = tile_size;
  r  = Top;
  b1_col = color;
  b2_col = color;
  b_col  = color }
let box_player_1 = box_player 657900
let box_player_2 = box_player  35700

The starting values for player_1 and player_2 are set globally, but are only used to initialize the main_loop. So these values do not need to be global and can be created immediately before the main loop.

let player_1 = {x=((n_tiles-1)/2)*tile_size; y=tile_size ;s_y=speed; s_x=0} ;;

let player_2 = {x=((n_tiles-1)/2)*tile_size; y=(n_tiles-1)*tile_size; s_y= (-1)*speed; s_x=0} ;;

is moved to

let () =
  Graphics.open_graph " ";
  Graphics.set_window_title "Test !";
  Graphics.plot 50 50;
  Draw.background n_tiles tile_size;
  let player_1 = { x = (n_tiles - 1) / 2 * tile_size; y =                 tile_size; s_y =      speed; s_x = 0 }
  and player_2 = { x = (n_tiles - 1) / 2 * tile_size; y = (n_tiles - 1) * tile_size; s_y = -1 * speed; s_x = 0 } in
  main_loop player_1 player_2;;

The updates_speed function can be simplified by moving the magnitude of the speed to the update_player_position function:

let update_player_position pl = { pl with x = pl.x + pl.s_x ; y = pl.y + pl.s_y };;

let update_speed player = function
  | Some Left  -> if player.s_x <>      speed then { player with s_x = -1 * speed; s_y =          0 } else player;
  | Some Right -> if player.s_x <> -1 * speed then { player with s_x =      speed; s_y =          0 } else player;
  | Some Up    -> if player.s_y <> -1 * speed then { player with s_x =          0; s_y =      speed } else player;
  | Some Down  -> if player.s_y <>      speed then { player with s_x =          0; s_y = -1 * speed } else player;
  | None       -> player

is turned into

let update_player_position pl = { pl with x = pl.x + pl.s_x * speed ; y = pl.y + pl.s_y * speed }

let update_speed player = function
  | Some Left  -> if player.s_x <>  1 then { player with s_x = -1; s_y =  0 } else player;
  | Some Right -> if player.s_x <> -1 then { player with s_x =  1; s_y =  0 } else player;
  | Some Up    -> if player.s_y <> -1 then { player with s_x =  0; s_y =  1 } else player;
  | Some Down  -> if player.s_y <>  1 then { player with s_x =  0; s_y = -1 } else player;
  | None       -> player

Don't forget to update the initial player values

  let player_1 = { x = (n_tiles - 1) / 2 * tile_size; y =                 tile_size; s_y =  1; s_x = 0 }
  and player_2 = { x = (n_tiles - 1) / 2 * tile_size; y = (n_tiles - 1) * tile_size; s_y = -1; s_x = 0 }

The update_speed function can be rewritten to use guards, it'll make it slightly simpler to read.

let update_speed player = function
  | Some Left  when player.s_x <>  1 -> { player with s_x = -1; s_y =  0 };
  | Some Right when player.s_x <> -1 -> { player with s_x =  1; s_y =  0 };
  | Some Up    when player.s_y <> -1 -> { player with s_x =  0; s_y =  1 };
  | Some Down  when player.s_y <>  1 -> { player with s_x =  0; s_y = -1 };
  | _ -> player

Keep in mind that this modification makes the function a bit less robust. Now if you ever change the type direction, for instance to add diagonals, the compiler will not complain about a non-exhaustive match, whereas the previous version would get the compiler to remind you to adapt update_speed.

Now, let's say that we do care about robustness and that we want to take advantage of the type system to help us avoid meaningless states. Currently, there are four possible pairs s_x, s_y that are meaningful, [-1, 0; 1, 0; 0, -1; 0, 1], but the type system does not prevent the construction of or update to player records with values like, say, s_x = 0; s_y = 0. In order to get the compiler to rule out such values, we can change the record type for players. We replace the s_x and s_y fields with a current_direction field that can only ever take 4 values.

type player = { x:int; y:int; cur_direction: direction }

We then need to adapt our functions to take this new type into account.

let update_player_position pl = match pl.cur_direction with
  | Left  -> { pl with x = pl.x - speed }
  | Right -> { pl with x = pl.x + speed }
  | Up    -> { pl with y = pl.y + speed }
  | Down  -> { pl with y = pl.y - speed }

It also gives us the opportunity to clarify the guard condition we had in the update_speed function: we only update the speed if the required direction is not opposite to the current one.

let opposite_direction = function
  | Left  -> Right
  | Right -> Left
  | Up    -> Down
  | Down  -> Up
let update_speed player = function
  | Some dir -> if opposite_direction player.cur_direction <> dir then { player with cur_direction = dir } else player
  | None -> player

At this point, I realize that key_pressed_player_1 is simple enough that inlining it will not decrease readability. We can also rename update_player_position into update_position to match the naming of update_speed. The main loop looks like

let main_loop player_1 player_2 =
  let rec aux player_1 player_2 walls over =
    Draw.players player_1 player_2;

    let e = Graphics.wait_next_event [Graphics.Poll] in
    if e.Graphics.keypressed then ignore (Graphics.wait_next_event [Graphics.Key_pressed]);

    let player_1_bis = update_speed player_1 (key_to_direction_1 e.Graphics.key)
    and player_2_bis = update_speed player_2 (key_to_direction_2 e.Graphics.key) in

    minisleep refresh_rate;

    let player_1_next = update_position player_1_bis
    and player_2_next = update_position player_2_bis in

    if has_lost player_1_next walls then (minisleep 3.0; exit 0);
    if has_lost player_2_next walls then (minisleep 3.0; exit 0);

    aux player_1_next player_2_next ((player_1_next.x, player_1_next.y) :: (player_2_next.x, player_2_next.y) :: walls) over in
  aux player_1 player_2 [] false

We notice that as soon as player_i_bis is defined, we don't need to access player_i anymore and that as soon as player_i_next is defined, we don't need to access player_i_bis anymore. So we can use the same name player_i all over and shadow the previous values. On the other hand, the only use of player_i made by main_loop is to feed aux, so if we change the ordering of the arguments of aux we can define this function in main once and for all (instead of redefining aux for each instance of the arguments player_i. Also, the over argument of aux is never used, so we can drop it.

When a player loses, we can get out of aux naturally instead of calling exit 0, by simply not performing a recursive call.

Back to the drawing. The box_player_1 and box_player_2 values are defined globally but they are only used to feed the Draw.players function. This can be inlined.

By the way, I'm not exactly sure what you're doing with the relief type. Only the Top value seem to be used. Maybe it's there for future versions. If you don't care about Flat and Bot, then the code for Draw.box can be simplified.

I see that Graphics.plot 50 50; has hard-coded the value 50, but it corresponds to n_tiles / tile_size. Also, the Graphics instructions corresponding to the setup can be moved to the Draw module by creating an appropriate initialization function.

  let init n_tiles tile_size =
    Graphics.open_graph " ";
    Graphics.set_window_title "Test !";
    Graphics.plot (n_tiles / tile_size) (n_tiles / tile_size);
    background n_tiles tile_size

After all these modifications, my refactored version of your program would be

#load "unix.cma";;
#load "graphics.cma";;

let minisleep (sec: float) = ignore (Unix.select [] [] [] sec)

type relief = Top | Bot | Flat

type box_config =
  { w:int; h:int; bw:int;
    mutable r:relief;
    b1_col : Graphics.color;
    b2_col : Graphics.color;
    b_col  : Graphics.color }

let tile_size = 3
and n_tiles = 150
and refresh_rate = 0.02
let speed = tile_size

type direction = Left | Right | Up | Down

type player = { x : int; y : int; cur_direction : direction }

module Draw =
struct

  let rect x0 y0 w h =
    let (a, b) = Graphics.current_point ()
    and x1 = x0 + w
    and y1 = y0 + h in
    Graphics.moveto x0 y0;
    Graphics.lineto x0 y1; Graphics.lineto x1 y1;
    Graphics.lineto x1 y0; Graphics.lineto x0 y0;
    Graphics.moveto a b

  let background n_tiles tile_size =
    for i = 1 to n_tiles do
      for j = 1 to n_tiles do
        rect (i * tile_size) (j * tile_size) tile_size tile_size
      done
    done

  let box_outline bcf col x1 y1=
    Graphics.set_color col;
    rect x1 y1 bcf.w bcf.h

  let box bcf x1 y1 =
    let x2  = x1 + bcf.w  and y2  = y1 + bcf.h in
    let ix1 = x1 + bcf.bw and ix2 = x2 - bcf.bw
    and iy1 = y1 + bcf.bw and iy2 = y2 - bcf.bw in
    let border1 g =
      Graphics.set_color g;
      Graphics.fill_poly [| (x1, y1); (ix1, iy1); (ix2, iy1); (ix2, iy2); (x2, y2); (x2, y1) |] in
    let border2 g =
      Graphics.set_color g;
      Graphics.fill_poly [| (x1, y1); (ix1, iy1); (ix1, iy2); (ix2, iy2); (x2, y2); (x1, y2) |] in
    Graphics.set_color bcf.b_col;
    (match bcf.r with
    | Top ->
       Graphics.fill_rect ix1 iy1 (ix2 - ix1) (iy2 - iy1);
       border1 bcf.b1_col;
       border2 bcf.b2_col
    | Bot ->
       Graphics.fill_rect ix1 iy1 (ix2 - ix1) (iy2 - iy1);
       border1 bcf.b2_col;
       border2 bcf.b1_col
    | Flat ->
       Graphics.fill_rect x1 y1 bcf.w bcf.h);
    box_outline bcf Graphics.black x1 y1

  let box_player color = {
    w  = tile_size;
    bw = tile_size / 2;
    h  = tile_size;
    r  = Top;
    b1_col = color;
    b2_col = color;
    b_col  = color }
  let box_player_1 = box_player 657900
  let box_player_2 = box_player  35700

  let init n_tiles tile_size =
    Graphics.open_graph " ";
    Graphics.set_window_title "Test !";
    Graphics.plot (n_tiles / tile_size) (n_tiles / tile_size);
    background n_tiles tile_size

  let players player_1 player_2 =
    box box_player_1 player_1.x player_1.y;
    box box_player_2 player_2.x player_2.y
end


let key_to_direction_1 = function
  | 'q' -> Some Left  | 'd' -> Some Right  | 'z' -> Some Up  | 's' -> Some Down
  | _   -> None
let key_to_direction_2 = function
  | 'j' -> Some Left  | 'l' -> Some Right  | 'i' -> Some Up  | 'k' -> Some Down
  | _   -> None

let update_position pl = match pl.cur_direction with
  | Left  -> { pl with x = pl.x - speed }
  | Right -> { pl with x = pl.x + speed }
  | Up    -> { pl with y = pl.y + speed }
  | Down  -> { pl with y = pl.y - speed }

let opposite_direction = function
  | Left  -> Right
  | Right -> Left
  | Up    -> Down
  | Down  -> Up
let update_speed player = function
  | Some dir -> if opposite_direction player.cur_direction <> dir then { player with cur_direction = dir } else player
  | None -> player

let is_out { x; y; _ } = x > tile_size * n_tiles || y > tile_size * n_tiles || x < 0 || y < 0
let is_on_wall player walls = List.mem (player.x, player.y) walls
let has_lost player walls = is_out player || is_on_wall player walls

let main_loop =
  let rec aux walls player_1 player_2 =
    Draw.players player_1 player_2;

    let e = Graphics.wait_next_event [Graphics.Poll] in
    if e.Graphics.keypressed then ignore (Graphics.wait_next_event [Graphics.Key_pressed]);

    let player_1 = update_speed player_1 (key_to_direction_1 e.Graphics.key)
    and player_2 = update_speed player_2 (key_to_direction_2 e.Graphics.key) in

    minisleep refresh_rate;

    let player_1 = update_position player_1
    and player_2 = update_position player_2 in

    if has_lost player_1 walls || has_lost player_2 walls then minisleep 3.0
    else aux ((player_1.x, player_1.y) :: (player_2.x, player_2.y) :: walls) player_1 player_2 in
  aux []

let () =
  Draw.init n_tiles tile_size;
  let player_1 = { x = (n_tiles - 1) / 2 * tile_size; y =                 tile_size; cur_direction =   Up }
  and player_2 = { x = (n_tiles - 1) / 2 * tile_size; y = (n_tiles - 1) * tile_size; cur_direction = Down } in
  main_loop player_1 player_2;;

Deeper modifications are possible too. For instance, you could be concerned with the latency introduced by checking for wall collision. Currently, you store walls in a list and checking for membership is O(n). You can replace the list with a two-dimensional array, or with a hash-table and get O(1). If you would like to prefer keeping the code purely functional, then a Set from the standard library would give you access in O(log n), or maybe you could go for a Patricia tree using Jean-Christophe Filliâtre's library.

| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ Regarding the keyboard interaction bugs, I did not have them in my windows environment but it seems that Unix environments don't support it... \$\endgroup\$ – RUser4512 Mar 20 '16 at 20:52
3
\$\begingroup\$

I saw the same problem Abdallah found: Unix.Unix_error (Unix.EINTR, "select", "")

This can be fixed by using Unix.sleepf (OCaml version >= 4.03.0):

let minisleep (sec: float) = Unix.sleepf sec
| improve this answer | |
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.