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.
Definition stratify (n:nat) : Mor predS (projT2 (sinv n)) :=
Build_Mor predS (projT2 (sinv n)) (stratify0 n) (stratify_mor n).
Definition proof_irr_nat := eq_proofs_unicity dec_eq_nat.
Implicit Arguments proof_irr_nat.
Program Definition unstratify (n:nat) : Mor (projT2 (sinv n)) predS :=
Build_Mor _ _ (fun p =>
Build_Mor _ _ (fun w =>
match w with (existT nw w',e) =>
match decompose_nat nw n with
| inleft (existT m Hm) => snd (floor m (S nw) (eq_rect n (fun x => projT1 (sinv x)) p (m + S nw) Hm)) (w', e)
| inright H => T_bot
end
end) _) _.
Next Obligation.
hnf; simpl; intros.
destruct x; destruct y; simpl.
destruct k; destruct k0; simpl in *.
destruct H.
inversion H; clear H; subst.
assert (f3 = f) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
subst f3.
assert (f4 = f0) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
subst f4.
clear H3 H5.
simpl.
destruct (decompose_nat x0 n); simpl.
destruct s; simpl.
generalize e.
subst n; intro e.
replace e with (refl_equal (x + S x0)) by apply proof_irr_nat; simpl.
generalize (floor_mor x (S x0) p p (setoid_refl _ p)).
intro H.
simpl in H.
destruct H.
apply H1.
simpl; split; auto.
apply setoid_refl.
Qed.
Next Obligation.
repeat (hnf; simpl in *; intros).
destruct a; destruct a'; simpl in *.
destruct k; destruct k0; destruct H0; simpl in *.
inversion H0; clear H0; subst.
assert (f3 = f) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
subst f3.
assert (f4 = f0) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
subst f4.
simpl.
destruct (decompose_nat x1 n); simpl.
destruct s; simpl.
generalize e; subst n.
intro e.
replace e with (refl_equal (x0 + S x1)) by (apply proof_irr_nat; auto); simpl.
generalize (floor_mor x0 (S x1) x y H); simpl.
intros [? ?].
apply H2.
split; auto.
reflexivity.
Qed.
Program Definition squash : Mor natFS knotS :=
Build_Mor _ _
(fun x =>
match x with (n,y) => existT (fun x => F (projT1 (sinv x))) n (fmap (stratify n) y) end) _.
Next Obligation.
hnf; simpl; intros.
destruct x; destruct y; destruct H; simpl in *.
subst n0.
constructor.
apply mor_prf; auto.
Qed.
Program Definition unsquash : Mor knotS natFS :=
Build_Mor _ _
(fun x =>
match x with existT n y => (n, fmap (unstratify n) y) end) _.
Next Obligation.
hnf; simpl; intros.
destruct x; destruct y; inversion H; clear H; subst; simpl.
split; auto.
apply mor_prf.
transitivity f3; auto.
replace f with f3.
reflexivity.
apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto.
Qed.
Definition level : Mor knotS (EqSetoid nat) := fstM oo unsquash.
Definition approx (n:nat) := unstratify n oo stratify n.

Lemma squash_unsquash : forall x, squash (unsquash x) == x.