exception Repeated_Vertex;;
exception Logic_error;;
let boundary x =
let sort less lst =
  let rec fp l = match l with
    [] -> []
  | [a] -> [[a]]
  | a::b::c -> (if less a b then [a; b] else [b; a])::(fp c)
in let rec mrg a b = match (a, b) with
    | (c, []) -> a
    | ([], c) -> b
    | (c::d, e::f) -> if less c e then c::(mrg d b) else e::(mrg f a)
in let rec lmrg llst = match llst with
      [] -> []
    | [a] -> [a]
    | a::b::c -> (mrg a b)::(lmrg c)
in let rec rlm lx = match lx with
    | [] -> []
    | [a] -> a
    | a::b::c -> rlm (lmrg lx)
in rlm (fp lst) in

let pe vl = match let rec mpa l th = match l with
       [] -> [], []
     | (a, b)::c -> if th >= b then raise Repeated_Vertex;
     match mpa c b with sl, l -> (b::sl, (ref false, a)::l)
     in mpa (sort
       (fun x y -> match (x, y) with (_, b), (_, d) -> b < d)
       (let rec numr l n = match l with [] -> [] |
          a::b -> (n, a)::(numr b (n + 1)) in numr vl 0))
      (-1) with svl, spl ->
 let ar = Array.of_list spl in
 let rec dp i p = if i < 0 then p else let next = dp (i-1) in
   match ar.(i) with a, n -> if !a then next (not p) else  
    let rec lop v = match ar.(v) with w, x -> 
      if !w then raise Logic_error; w := true;
      if v = i then () else lop x in lop n;          
      next p
 in dp (Array.length ar - 1) false, svl in

let rec sl l = match l with [] -> []
  | h::t -> t::List.map (fun q -> h::q) (sl t) in

let rc b = List.fold_left
    (fun acc fac -> match fac with (o, vl) ->
   (* Do all faces of this zone with face list fac. *)
   (* Yield a pair of face lists assorted by parity. *)
    match (List.fold_left (fun acc1 face ->
      match acc1 with od, (even, odd) ->
   (not od, if o
      then (odd, face::even)
      else (face::odd, even)))
    (false, acc) (sl vl))
    with (o, (l, r)) -> if o then (r, l) else (l, r))
    ([], []) (List.map pe b) in

let b1 q = match (rc q) with a, b ->
   let ob = List.sort compare in (ob a, ob b) in

let rec elim q = match q with
   | [], [] -> [], []
   | a, [] -> a, []
   | [], b -> [], b
   | (a::b as rev), (c::d as obv) -> let w = compare a c in if w < 0 then
        match elim (b, obv) with p, q -> a::p, q else if w > 0 then
        match elim (rev, d) with p, q -> p, c::q else
        elim (b, d) in

let comb a = elim (b1 a) in

let rec turn (p, q) = match q with [] -> p
     | r::s -> turn (((match r with
       | [] -> raise Logic_error
       | _::[] -> raise Logic_error
       | a::b::c -> b::a::c)::p), s)
  in turn (comb x);;