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 =
      | 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
            | _ -> 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

  let display_game (s, m, q) (pn1, pn2) =
    (* TODO *)
    ()


end