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 (hereditary ko_age) (unstratify n p) (unstratify_hered n p).
Definition squash (x:nat * F predicate) : knot :=
match x with (n,f) => existT (F oo sinv) n (fmap F (strat n) f) end.
Definition unsquash (k:knot) : nat * F predicate :=
match k with existT _ n f => (n, fmap F (unstrat n) f) end.
Definition level (x:knot) : nat := fst (unsquash x).
Program Definition approx (n:nat) (p:predicate) : predicate :=
fun w => level (fst w) < n /\ p w.
Next Obligation.
hnf; simpl; intros.
intuition.
unfold level in *.
unfold unsquash in *.
destruct a0; simpl in H.
destruct x; try discriminate.
inv H.
simpl in *; omega.
destruct p; simpl in *.
eapply h; 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, fmap F (approx n) f).
Lemma strat_unstrat_Sx : forall x,
@fst _ _ oo @proj1_sig _ _ = strat x oo unstrat (S x).
Lemma unsquash_inj : forall k k',
unsquash k = unsquash k' -> k = k'.
Lemma knot_age_age1 : forall k k',
k_age1 k = Some k' <->
match unsquash k with
| (O,_) => None
| (S n,x) => Some (squash (n,x))
end = Some k'.