path: root/judge/morpion_rec.ml

open Core
open Main

let ( |> ) x f = f x

module G = struct
  
  exception Invalid_pos

  type loc1 = int * int
  type loc = loc1 * loc1

  type c =      (* P1 <-> X || P2 <-> O *)
      | Empty
      | X
      | O
      | T

  type 'a r = 'a * 'a * 'a
  type 'a morpion = 'a r * 'a r * 'a r

  type game = game_status * c morpion morpion * loc1 option

  (* all_p1 : loc1 list *)
  let all_p1 = [ 1,1; 1,2; 1,3; 2,1; 2,2; 2,3; 3,1; 3,2; 3,3 ]
  (* all_w_s : loc1 list list *)
  let all_w_p1l = [
      [ 1,1; 1,2; 1,3 ];
      [ 2,1; 2,2; 2,3 ];
      [ 3,1; 3,2; 3,3 ];
      [ 1,1; 2,1; 3,1 ];
      [ 1,2; 2,2; 3,2 ];
      [ 1,3; 2,3; 3,3 ];
      [ 1,1; 2,2; 3,3 ];
      [ 1,3; 2,2; 3,1 ];
    ]

  (* encode : loc -> string *)
  let encode ((xg, yg), (xp, yp)) =
    Format.sprintf "%d %d %d %d" xg yg xp yp
  (* decode : string -> loc *)
  let decode s =
    Scanf.sscanf s "%d %d %d %d"
      (fun xg yg xp yp -> (xg, yg), (xp, yp))

  (* getp0 : ('a, 'a, 'a) -> int -> 'a *)
  let getp0 (a, b, c) x = match x with
    | 1 -> a | 2 -> b | 3 -> c
    | _ -> raise Invalid_pos
  (* getp1 : 'a morpion -> loc1 -> 'a *)
  let getp1 m (px, py) =
    getp0 (getp0 m px) py
  (* getp : 'a morpion morpion -> loc2 -> 'a *)
  let getp m (pg, pp) =
    getp1 (getp1 m pg) pp

  (* setp0 : ('a, 'a, 'a) -> int -> 'a -> ('a, 'a, 'a) *)
  let setp0 (a, b, c) x v = match x with
    | 1 -> (v, b, c)
    | 2 -> (a, v, c)
    | 3 -> (a, b, v)
    | _ -> raise Invalid_pos
  (* setp1 : 'a morpion -> loc1 -> 'a -> 'a morpion *)
  let setp1 m (px, py) v =
    setp0 m px (setp0 (getp0 m px) py v) 
  (* setp2 : 'a morpion morpion -> loc2 -> 'a -> 'a morpion morpion *)
  let setp m (pg, pp) v =
    setp1 m pg (setp1 (getp1 m pg) pp v)

  (* r : 'a -> ('a, 'a, 'a) *)
  let r x = (x, x, x)

  (* *************************** *)
  (* Début du code intéressant ! *)

  let id = "morpion_rec"
  let name = "Morpion récursif!"

  let new_game = 
    TurnOf P1, r (r (r (r Empty))), None

  let full_pm m =
    List.for_all (fun p -> getp1 m p <> Empty) all_p1


  let possibilities (s, m, lg) =
    let pg_poss = match lg with
      | None -> all_p1
      | Some x -> if full_pm (getp1 m x) then all_p1 else [x]
    in
    List.flatten
      (List.map (fun pg ->
          all_p1
          |> List.filter (fun pp -> getp m (pg, pp) = Empty)
          |> List.map (fun pp -> (pg, pp)))
        pg_poss)
    |> List.map encode

  let reduce_m rf m =
    match
      all_w_p1l
      |> List.map (List.map (fun x -> rf (getp1 m x)))
      |> List.map (function
            | l when List.for_all ((=) X) l -> X
            | l when List.for_all ((=) O) l -> O
            | l when List.exists ((=) X) l && List.exists ((=) O) l -> T
            | l when List.exists ((=) T) l -> T
            | _ -> Empty)
    with
    | l when List.exists ((=) X) l -> X
    | l when List.exists ((=) O) l -> O
    | l when List.exists ((=) Empty) l -> Empty
    | _ -> T

  let play (gs, m, pgo) act =
    let (pg, pp) = decode act in
    match gs with
    | TurnOf player when
        (match pgo with
          | None -> true
          | Some x when full_pm (getp1 m x) -> true
          | Some x when pg = x -> true
          | _ -> false)
        && getp m (pg, pp) = Empty 
      ->
        let op = other_player player in
        let new_m = setp m (pg, pp) (match player with P1 -> X | P2 -> O) in
        let new_s = match reduce_m (reduce_m (fun x -> x)) new_m with
          | Empty -> TurnOf op
          | X -> Won P1
          | O -> Won P2
          | T -> Tie
        in
        (new_s, new_m, Some pp)
    | TurnOf x -> (Eliminated x, m, pgo)
    | _ -> raise (Eliminated_ex "not someone's turn!")

  let s (s, _, _) = s


  (* ************************* *)
  (* Visualisation graphique ! *)

  open Graphics
  open Main
  open G_util

  let subpos (x1, y1, x2, y2) (l, c) =
    let dx, dy = (x2 - x1) / 3, (y2 - y1) / 3 in
    x1 + (l-1) * dx, y1 + (c-1) * dy, x1 + l * dx, y1 + c * dy
  let margin (x1, y1, x2, y2) m =
    (x1+m, y1+m, x2-m, y2-m)

  let disp_l lw pos =
    let x1, y1, x2, y2 = pos in
    function
    | X ->
      set_line_width lw;
      set_color p1c;
      draw_segments
        [| x1, y1, x2, y2;
           x1, y2, x2, y1 |];
      set_line_width 1
    | O ->
      set_line_width lw;
      set_color p2c;
      draw_circle ((x1+x2)/2) ((y1+y2)/2) (min (x2-x1) (y2-y1) / 2);
      set_line_width 1
    | _ -> ()

  let disp_r rf sdf box mor =
    let x1, y1, x2, y2 = box in
    let dx, dy = (x2 - x1) / 3, (y2 - y1) / 3 in
    let x12, x23 = x1 + dx, x1 + 2 * dx in
    let y12, y23 = y1 + dy, y1 + 2 * dy in
    set_color black;
    draw_segments
      [| x12, y1, x12, y2;
         x23, y1, x23, y2;
         x1, y12, x2, y12;
         x1, y23, x2, y23 |];
    List.iter (fun p -> sdf (margin (subpos box p) 6) (getp1 mor p)) all_p1;
    disp_l 2 box (rf mor)

  let display_game (s, mor, q) (pn1, pn2) =
    let cx, cy = center() in
    let box = cx - 200, cy - 200, cx + 200, cy + 200 in
    disp_r
      (reduce_m (reduce_m (fun x -> x)))
      (disp_r (reduce_m (fun x -> x)) (disp_l 1))
      box mor;
    begin match q, s with
    | Some p, TurnOf player ->
      let x1, y1, x2, y2 = margin (subpos box p) 3 in
      set_color (pc player);
      draw_rect x1 y1 (x2-x1) (y2-y1)
    | _ -> ()
    end


end