Definition strat (n:nat) (p:predicate) : sinv n :=
proj1_sig (stratify (proj1_sig p) (proj2_sig p) n).
Definition unstrat (n:nat) (p:sinv n) : predicate :=
exist hered (unstratify n p) (unstratify_hered n p).
Definition squash (x:nat * F predicate predicate) : knot :=
match x with (n,f) => existT (F_sinv) n (bimap (unstrat n) (strat n) f) end.
Definition unsquash (k:knot) : nat * F predicate predicate :=
match k with existT _ n f => (n, bimap (strat n) (unstrat n) f) end.
Definition knot_level_def (k:knot) : nat :=
fst (unsquash k).
Definition knot_age1_def (k:knot) : option knot :=
match unsquash k with
| (O,_) => None
| (S n,x) => Some (squash (n,x))
end.
Definition knot_unage_def (k:knot) :=
let (n,k) := unsquash k in squash (S n,k).
Program Definition approx (n:nat) (p:predicate) : predicate :=
fun w => if (le_gt_dec n (knot_level_def (fst w))) then T_bot else proj1_sig p w.
Next Obligation.
hnf; simpl; intros.
destruct (le_gt_dec n (knot_level_def k)).
apply T_rel_bot.
destruct (le_gt_dec n (knot_level_def k'')).
elimtype False.
cut (knot_level_def k'' <= knot_level_def k).
omega.
replace (knot_level_def k'') with (knot_level_def k').
clear -H; induction H.
hnf in H.
unfold age1_def in H.
destruct x; destruct y; simpl.
destruct x; try discriminate.
inv H.
simpl.
unfold knot_level_def; simpl; auto.
auto.
eapply le_trans; eauto.
inv H0.
unfold knot_level_def; simpl; auto.
destruct p as [p Hp]; simpl.
eapply Hp; eauto.
Qed.

(* Specifications: *)
Lemma strat_unstrat : forall n,
strat n oo unstrat n = id (sinv n).
Lemma predicate_eq : forall (p1 p2:predicate),
proj1_sig p1 = proj1_sig p2 ->
p1 = p2.
Lemma unstrat_strat : forall n,
unstrat n oo strat n = approx n.
Lemma squash_unsquash : forall k, squash (unsquash k) = k.
Lemma unsquash_squash : forall n f,
unsquash (squash (n,f)) = (n, bimap (approx n) (approx n) f).
Lemma bimap_bimap : forall A B C X Y Z (s:X->Y) (t:Y->Z) (f:B->C) (g:A->B) x,
bimap s f (bimap t g x) = bimap (t oo s) (f oo g) x.
Lemma strat_Sx_unstrat : forall x,
sinv_unage x = strat (S x) oo unstrat x.
Lemma strat_unstrat_Sx : forall x,
sinv_age x = strat x oo unstrat (S x).
Lemma age1_eq : forall k,
age1_def k = knot_age1_def k.
Lemma unsquash_inj : forall k1 k2,
unsquash k1 = unsquash k2 ->
k1 = k2.