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