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);;