Module TF := TF'.
(* Put the discrete pointed order on rhs *)
Inductive leT : T -> T -> Prop :=
| leT_refl : forall t, leT t t
| leT_bot: forall t, leT T_bot t.
Fixpoint sinv (n: nat) : Type :=
match n with
| O => unit
| S n => prodT (sinv n) ((F (sinv n) * other) -> T)
end.
Fixpoint floor (m:nat) (n:nat) (p:sinv (m+n)) : sinv n :=
match m as m' return forall (p : sinv (m'+n)), sinv n with
| O => fun p => p
| S m' => fun p => floor m' n (fst p)
end p.
Definition knot := { n:nat & F (sinv n) }.
Definition predicate := knot * other -> T.
Fixpoint stratify (n:nat) (Q:predicate) {struct n} : sinv n :=
match n as n' return sinv n' with
| O => tt
| S n' => ( stratify n' Q, fun v => Q (existT (F oo sinv) n' (fst v),snd v) )
end.
Definition unstratify (n:nat) (p:sinv n) : predicate := 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 _ p (m + S nw) Hm)) (w', e)
| inright H => T_bot
end
end.
Definition proof_irr_nat := eq_proofs_unicity dec_eq_nat.
Arguments proof_irr_nat [x] [y] _ _.
Definition squash (x:nat * F predicate) : knot :=
match x with (n,y) => existT (F oo sinv) n (fmap F (stratify n) y) end.
Definition unsquash (x:knot) : (nat * F predicate) :=
match x with existT _ n y => (n, fmap F (unstratify n) y) end.
Definition def_knot_level (k:knot) := fst (unsquash k).
Definition def_knot_age1 (k:knot) : option knot :=
match unsquash k with
| (O,_) => None
| (S n,x) => Some (squash (n,x))
end.
Definition def_knot_unage (k:knot) : knot :=
match unsquash k with
| (n,x) => squash (S n,x)
end.
Definition approx (n:nat) (p:predicate) : predicate :=
fun w => if le_gt_dec n (def_knot_level (fst w)) then T_bot else p w.

Lemma unsquash_squash : forall n x', unsquash (squash (n,x')) = (n,fmap F (approx n) x').