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.

(* Specifications: *)
Lemma approx_spec : forall n p w, approx n p w ==
if (le_gt_dec n (level (fst w))) then T_bot else p w.
Lemma squash_unsquash : forall x, squash (unsquash x) == x.
Lemma unsquash_squash : forall n x', unsquash (squash (n,x')) == (n,fmap (approx n) x').
Definition knot_age1 (k:knot) : option knot :=
match unsquash k with
| (O,_) => None
| (S n,x) => Some (squash (n,x))
end.