needs "../formal_lp/hypermap/tests/Tri2.ml";;
needs "../formal_lp/hypermap/tests/Quad2.ml";;
needs "../formal_lp/hypermap/tests/Pent2.ml";;
needs "../formal_lp/hypermap/tests/Hex2.ml";;

(* 18762 *)
length pent + length hex + length tri + length quad;;



open List;;

(* undup *)
let rec undup s =
  match s with
      [] -> []
    | h :: t -> if mem h t then undup t else h :: undup t;;


(* uniq *)
let rec uniq_test s =
  match s with
      [] -> true
    | h :: t -> if mem h t then false else uniq_test t;;


(* list_of_elements *)
let list_of_elements hyp = undup (flatten hyp);;


(* list_pairs *)
let list_pairs s =
  let head = hd s in
  let rec list_pairs_head s =
    match s with
	[] -> failwith "list_pairs"
      | [h] -> [h,head]
      | h1 :: h2 :: t -> (h1,h2) :: list_pairs_head (h2 :: t) in
    list_pairs_head s;;


(* list_of_faces *)
let list_of_faces hyp =
  map list_pairs hyp;;


(* list_of_darts *)
let list_of_darts hyp = flatten (list_of_faces hyp);;


(* find_pair_list *)
let rec find_pair_list hyp d =
  match hyp with
      [] -> []
    | f :: t -> if mem d (list_pairs f) then f else find_pair_list t d;;


(* find_face *)
let find_face hyp d = list_pairs (find_pair_list hyp d);;


(* next_el *)
let next_el s d =
  let head = hd s in
  let rec next s =
    match s with
	[] -> failwith "next_el"
      | [h] -> if Pervasives.compare h d = 0 then head else next []
      | h1 :: h2 :: t -> if Pervasives.compare h1 d = 0 then h2 else next (h2 :: t) in
    next s;;


(* prev_el *)
let prev_el s d =
  let rec prev_rec prev s =
    match s with
	[] -> failwith "prev_el"
      | h :: t -> if Pervasives.compare h d = 0 then prev else prev_rec h t in
    prev_rec (last s) s;;


(* e_list *)
let e_list (d1,d2) = d2,d1;;


(* f_list *)
let f_list hyp d = next_el (find_face hyp d) d;;


(* n_list *)
let n_list hyp d = e_list (prev_el (find_face hyp d) d);;


(* orbit *)
let orbit f d =
  let rec orbit_acc acc x =
    let next = f x in
      if mem next acc then acc else orbit_acc (next :: acc) next in
    rev (orbit_acc [d] d);;


(* orbits *)
let orbits f set =
  let rec orbits_rec set =
    match set with
	[] -> []
      | h :: t ->
	  let x = orbit f h in
	    x :: orbits_rec (subtract set x) in
    orbits_rec set;;


(* good_list *)
let good_list hyp =
  let darts = list_of_darts hyp in
  let c1 = uniq_test darts in
  let c2 = for_all (fun l -> l <> []) hyp in
  let c3 = for_all (fun (d1,d2) -> mem (d2,d1) darts) darts in
    c1 & c2 & c3;;


(* good_list_nodes *)
let good_list_nodes hyp =
  let darts = list_of_darts hyp in
  let n0 = length (list_of_elements hyp) in
  let n1 = length (orbits (n_list hyp) darts) in
    n0 = n1;;



let tm = hd hex;;
good_list tm;;
good_list_nodes tm;;

let good_test = fold_left (fun l h -> l & good_list h) true;;
let good_nodes_test = fold_left (fun l h -> l & good_list_nodes h) true;;

let tri_test = good_test tri;;
let quad_test = good_test quad;;
let pent_test = good_test pent;;
let hex_test = good_test hex;;


let tri_test2 = good_nodes_test tri;;
let quad_test2 = good_nodes_test quad;;
let pent_test2 = good_nodes_test pent;;
let hex_test2 = good_nodes_test hex;;