Inductive knotEq : knot -> knot -> Prop :=
keq : forall n (f1 f2:F (projT1 (sinv n))),
@equiv _ (Fs (projT2 (sinv n))) f1 f2 ->
knotEq (existT (fun x => F (projT1 (sinv x))) n f1)
(existT (fun x => F (projT1 (sinv x))) n f2).
Program Instance knotS : Setoid knot := { equiv := knotEq }.
Next Obligation.
constructor; hnf; intros.
destruct x; constructor.
reflexivity.
destruct x; destruct y; simpl in *.
inversion H; subst; simpl in *.
constructor.
replace f with f3.
symmetry; auto.
revert H2.
apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
destruct x; destruct y; destruct z.
inversion H; clear H; subst.
inversion H0; clear H0; subst.
simpl.
constructor.
transitivity f5.
replace f with f4; auto.
revert H3.
apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
replace f5 with f0.
replace f0 with f6; auto.
revert H4.
apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
symmetry.
revert H5.
apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
Qed.
Definition koS : Setoid (knot * other) := @ProdSetoid knot knotS other otherS.
Definition predicate := Mor koS Ts.
Definition predS : Setoid predicate := MorSetoid koS Ts.
Definition natFS : Setoid (nat * F predicate) := @ProdSetoid nat (EqSetoid nat) (F predicate) (Fs predS).
Existing Instance koS.
Existing Instance predS.
Existing Instance natFS.
Program Definition wrap (n:nat) : Mor (ProdSetoid (Fs (projT2 (sinv n))) otherS) (ProdSetoid knotS otherS) :=
@Build_Mor _ _ _ _ (fun v => (existT (fun x => F (projT1 (sinv x))) n (fst v), snd v)) _.
Next Obligation.
hnf; simpl; intuition.
destruct y.
constructor.
simpl in *; auto.
Qed.
Fixpoint stratify0 (n:nat) (Q:predicate) {struct n} : projT1 (sinv n) :=
match n as n' return projT1 (sinv n') with
| O => tt
| S n' => ( stratify0 n' Q, Q oo (wrap n'))
end.

(* Specifications: *)
Lemma stratify_mor : forall n, Morphism (equiv ==> (@equiv _ (projT2 (sinv n)))) (stratify0 n).
Definition stratify (n:nat) : Mor predS (projT2 (sinv n)) :=
Build_Mor predS (projT2 (sinv n)) (stratify0 n) (stratify_mor n).
Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
Definition proof_irr_nat := eq_proofs_unicity dec_eq_nat.