Section stratifies.
Variable Q:knot * other -> Prop.
Variable HQ:hereditary ko_age Q.
Fixpoint stratifies (n:nat) : sinv n -> Prop :=
match n as n' return sinv n' -> Prop with
| 0 => fun _ => True
| S n' => fun (p:sinv (S n')) =>
stratifies n' (fst (proj1_sig p)) /\
forall (k:F (sinv n')) (o:other), snd (proj1_sig p) (k,o) <-> Q (existT (F oo sinv) n' k,o)
end.
Definition stratify (n:nat) : { x:sinv n | stratifies n x }.
End stratifies.
Definition unstratify (n:nat) (p:sinv n) : knot * other -> Prop := fun w =>
match w with (existT _ nw w',o) =>
match decompose_nat nw n with
| inleft (existT _ m Hm) => snd (proj1_sig (floor m (S nw) (eq_rect  n _ p (m + S nw) Hm))) (w',o)
| inright H => False
end
end.
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.
Program Instance ag_knot : ageable knot :=
{ age1 := k_age1
; level := level
}.
Next Obligation.
econstructor.
(* unage *)
intros.
destruct (unsquash x') as [n f] eqn:?H; intros.
exists (squash (S n, f)).
rewrite knot_age_age1.
rewrite unsquash_squash.
f_equal.
apply unsquash_inj.
rewrite unsquash_squash.
rewrite H.
f_equal.
cut (f = fmap F (approx n) f).
intros.
rewrite fmap_app.
pattern f at 2. rewrite H0.
f_equal.
extensionality p.
apply predicate_eq.
extensionality w.
simpl. apply prop_ext.
intuition.
generalize H; intro.
rewrite <- (squash_unsquash x') in H.
rewrite H0 in H.
rewrite unsquash_squash in H.
congruence.
(* level 0 *)
intro x. destruct x; simpl.
destruct x; intuition; discriminate.
(* level S *)
intros. destruct x; simpl in *.
destruct x. discriminate.
inv H. simpl. auto.
Qed.
Existing Instance ag_prod.

Lemma knot_level : forall k:knot, level k = fst (unsquash k).