Module TF := TF'.
(* Put the discrete topped order on rhs *)
Inductive le_T : T -> T -> Prop :=
| le_T_refl : forall t1 t2,
t1 == t2 -> le_T t1 t2
| le_T_bot: forall t,
le_T T_bot t.
Fixpoint sinv (n: nat) : { T:Type & Setoid T } :=
match n with
| O => existT (fun T => Setoid T) unit (EqSetoid unit)
| S n => existT (fun T => Setoid T)
(prodT (projT1 (sinv n))
(Mor (ProdSetoid  (Fs (projT2 (sinv n))) otherS) (Ts)))
(ProdSetoid (projT2 (sinv n)) (MorSetoid _ _))
end.
Fixpoint floor (m:nat) (n:nat) (p:projT1 (sinv (m+n))) : projT1 (sinv n) :=
match m as m' return forall (p : projT1 (sinv (m'+n))), projT1 (sinv n) with
| O => fun p => p
| S m' => fun p => floor m' n (fst p)
end p.
Definition knot := { n:nat & F (projT1 (sinv n)) }.
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.

Lemma stratify_mor : forall n, Morphism (equiv ==> (@equiv _ (projT2 (sinv n)))) (stratify0 n).