module Glue = (struct

exception Repeated_Vertex
exception Logic_error

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 (_, 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

let sl nz l = let (intNba, iZCa) = nz l in
let rec sli l = match l with [] -> []
  | h::t -> t::List.map (fun q -> h::q) (sli t) 
and app sll k = match sll with [] -> []
    | h::t -> (h, (intNba k, iZCa k))::(app t (k+1)) in
app (sli l) 0

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

let cmp (c, _) (d, _) = compare c d

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

let rec elim q tl = match q with
   | a, [] -> a, []
   | [], b -> [], b
   | (a::b as rev), (c::d as obv) -> let w = cmp a c in
     if w < 0 then match elim (b, obv) tl with p, q -> a::p, q
     else if w > 0 then match elim (rev, d) tl with p, q -> p, c::q
     else (match (a, c) with (vl, (intNba, iZCa)), (_, (intNbb, iZCb)) ->
           (try let (tapl, tapr) = List.assoc vl tl in
                 intNba (tapl iZCb); intNbb (tapr iZCa);
            with Not_found -> intNba iZCb; intNbb iZCa); elim (b, d) tl)

let morphgen nz x tl = match (elim (b1 (nz, x)) tl) with (p, q) -> List.append
    (List.map (fun (x, y) -> x, (false, y)) p) (List.map (fun (x, y) -> x, (true, y)) q)

type 'a tap2 = (('a -> 'a) * ('a -> 'a))
end : sig
type 'a tap2 = (('a -> 'a) * ('a -> 'a))
val morphgen :
      (int list -> (int -> 'a -> 'b) * (int -> 'a)) -> int list list ->
      (int list * 'a tap2) list ->
      (int list * (bool * (('a -> 'b) * 'a))) list
end);;