From iris.algebra Require Import gmap.
From iris.algebra Require cofe_solver.
From iris.base_logic Require Export base_logic.
From iris Require Import options.

(** In this file we construct the type [iProp] of propositions of the Iris
logic. This is done by solving the following recursive domain equation:

  iProp ≈ uPred (∀ i : gid, gname -fin-> (Σ i) iProp)

where:

  Σ : gFunctors  := lists of locally constractive functors
  i : gid        := indexes addressing individual functors in [Σ]
  γ : gname      := ghost variable names

The Iris logic is parametrized by a list of locally contractive functors [Σ]
from the category of COFEs to the category of CMRAs. These functors are
instantiated with [iProp], the type of Iris propositions, which allows one to
construct impredicate CMRAs, such as invariants and stored propositions using
the agreement CMRA. *)

(** * Locally contractive functors *)
(** The type [gFunctor] bundles a functor from the category of COFEs to the
category of CMRAs with a proof that it is locally contractive. *)
Structure gFunctor := GFunctor {
  gFunctor_F :> rFunctor;
  gFunctor_map_contractive : rFunctorContractive gFunctor_F;
}.
Arguments GFunctor _ {_}.
Existing Instance gFunctor_map_contractive.
Add Printing Constructor gFunctor.

(** The type [gFunctors] describes the parameters [Σ] of the Iris logic: lists
of [gFunctor]s.

Note that [gFunctors] is isomorphic to [list gFunctor], but defined in an
alternative way to avoid universe inconsistencies with respect to the universe
monomorphic [list] type. *)
Definition gFunctors := { n : nat & fin n → gFunctor }.

Definition gid (Σ : gFunctors) := fin (projT1 Σ).
Definition gFunctors_lookup (Σ : gFunctors) : gid Σ → gFunctor := projT2 Σ.

Definition gname := positive.
Canonical Structure gnameO := leibnizO gname.

(** The resources functor [iResF Σ A := ∀ i : gid, gname -fin-> (Σ i) A]. *)
Definition iResF (Σ : gFunctors) : urFunctor :=
  discrete_funURF (λ i, gmapURF gname (gFunctors_lookup Σ i)).

(** We define functions for the empty list of functors, the singleton list of
functors, and the append operator on lists of functors. These are used to
compose [gFunctors] out of smaller pieces. *)
Module gFunctors.
  Definition nil : gFunctors := existT 0 (fin_0_inv _).

  Definition singleton (F : gFunctor) : gFunctors :=
    existT 1 (fin_S_inv (λ _, gFunctor) F (fin_0_inv _)).

  Definition app (Σ1 Σ2 : gFunctors) : gFunctors :=
    existT (projT1 Σ1 + projT1 Σ2) (fin_plus_inv _ (projT2 Σ1) (projT2 Σ2)).
End gFunctors.

Coercion gFunctors.singleton : gFunctor >-> gFunctors.
Notation "#[ ]" := gFunctors.nil (format "#[ ]").
Notation "#[ Σ1 ; .. ; Σn ]" :=
  (gFunctors.app Σ1 .. (gFunctors.app Σn gFunctors.nil) ..).

(** * Subfunctors *)
(** In order to make proofs in the Iris logic modular, they are not done with
respect to some concrete list of functors [Σ], but are instead parametrized by
an arbitrary list of functors [Σ] that contains at least certain functors. For
example, the lock library is parameterized by a functor [Σ] that should have
the functors corresponding to the heap and the exclusive monoid to manage to
lock invariant.

The contraints to can be expressed using the type class [subG Σ1 Σ2], which
expresses that the functors [Σ1] are contained in [Σ2]. *)
Class subG (Σ1 Σ2 : gFunctors) := in_subG i :
  { j | gFunctors_lookup Σ1 i = gFunctors_lookup Σ2 j }.

(** Avoid trigger happy type class search: this line ensures that type class
search is only triggered if the arguments of [subG] do not contain evars. Since
instance search for [subG] is restrained, instances should persistently have [subG] as
their first parameter to avoid loops. For example, the instances [subG_authΣ]
and [auth_discrete] otherwise create a cycle that pops up arbitrarily. *)
Hint Mode subG ! + : typeclass_instances.

Lemma subG_inv Σ1 Σ2 Σ : subG (gFunctors.app Σ1 Σ2) Σ → subG Σ1 Σ * subG Σ2 Σ.
Proof.
  move=> H; split.
  - move=> i; move: H=> /(_ (Fin.L _ i)) [j] /=. rewrite fin_plus_inv_L; eauto.
  - move=> i; move: H=> /(_ (Fin.R _ i)) [j] /=. rewrite fin_plus_inv_R; eauto.
Qed.

Instance subG_refl Σ : subG Σ Σ.
Proof. move=> i; by exists i. Qed.
Instance subG_app_l Σ Σ1 Σ2 : subG Σ Σ1 → subG Σ (gFunctors.app Σ1 Σ2).
Proof.
  move=> H i; move: H=> /(_ i) [j ?].
  exists (Fin.L _ j). by rewrite /= fin_plus_inv_L.
Qed.
Instance subG_app_r Σ Σ1 Σ2 : subG Σ Σ2 → subG Σ (gFunctors.app Σ1 Σ2).
Proof.
  move=> H i; move: H=> /(_ i) [j ?].
  exists (Fin.R _ j). by rewrite /= fin_plus_inv_R.
Qed.

(** * Solution of the recursive domain equation *)
(** We first declare a module type and then an instance of it so as to seal all of
the construction, this way we are sure we do not use any properties of the
construction, and also avoid Coq from blindly unfolding it. *)
Module Type iProp_solution_sig.
  Parameter iPrePropO : gFunctors → ofeT.
  Global Declare Instance iPreProp_cofe {Σ} : Cofe (iPrePropO Σ).

  Definition iResUR (Σ : gFunctors) : ucmraT :=
    discrete_funUR (λ i,
      gmapUR gname (rFunctor_apply (gFunctors_lookup Σ i) (iPrePropO Σ))).
  Notation iProp Σ := (uPred (iResUR Σ)).
  Notation iPropO Σ := (uPredO (iResUR Σ)).
  Notation iPropI Σ := (uPredI (iResUR Σ)).

  Parameter iProp_unfold: ∀ {Σ}, iPropO Σ -n> iPrePropO Σ.
  Parameter iProp_fold: ∀ {Σ}, iPrePropO Σ -n> iPropO Σ.
  Parameter iProp_fold_unfold: ∀ {Σ} (P : iProp Σ),
    iProp_fold (iProp_unfold P) ≡ P.
  Parameter iProp_unfold_fold: ∀ {Σ} (P : iPrePropO Σ),
    iProp_unfold (iProp_fold P) ≡ P.
End iProp_solution_sig.

Module Export iProp_solution : iProp_solution_sig.
  Import cofe_solver.
  Definition iProp_result (Σ : gFunctors) :
    solution (uPredOF (iResF Σ)) := solver.result _.
  Definition iPrePropO (Σ : gFunctors) : ofeT := iProp_result Σ.
  Global Instance iPreProp_cofe {Σ} : Cofe (iPrePropO Σ) := _.

  Definition iResUR (Σ : gFunctors) : ucmraT :=
    discrete_funUR (λ i,
      gmapUR gname (rFunctor_apply (gFunctors_lookup Σ i) (iPrePropO Σ))).
  Notation iProp Σ := (uPred (iResUR Σ)).
  Notation iPropO Σ := (uPredO (iResUR Σ)).

  Definition iProp_unfold {Σ} : iPropO Σ -n> iPrePropO Σ :=
    ofe_iso_1 (iProp_result Σ).
  Definition iProp_fold {Σ} : iPrePropO Σ -n> iPropO Σ :=
    ofe_iso_2 (iProp_result Σ).
  Lemma iProp_fold_unfold {Σ} (P : iProp Σ) : iProp_fold (iProp_unfold P) ≡ P.
  Proof. apply ofe_iso_21. Qed.
  Lemma iProp_unfold_fold {Σ} (P : iPrePropO Σ) : iProp_unfold (iProp_fold P) ≡ P.
  Proof. apply ofe_iso_12. Qed.
End iProp_solution.

(** * Properties of the solution to the recursive domain equation *)
Lemma iProp_unfold_equivI {Σ} (P Q : iProp Σ) :
  iProp_unfold P ≡ iProp_unfold Q ⊢@{iPropI Σ} P ≡ Q.
Proof.
  rewrite -{2}(iProp_fold_unfold P) -{2}(iProp_fold_unfold Q). apply: f_equivI.
Qed.


Require Export BinNat.
Require Export Coq.Lists.List.
Export ListNotations.

Require Export Bedrock.Word.
Require Export Fiat.Common.EnumType.
Require Export Fiat.Narcissus.Formats.ByteBuffer.
Require Export Fiat.Narcissus.Examples.NetworkStack.IPv4Header.
Require Export Fiat.Narcissus.Examples.NetworkStack.UDP_Packet.
Require Export Fiat.Narcissus.Examples.NetworkStack.TCP_Packet.

Definition bytes := { n: nat & ByteBuffer.t n }.

Definition bytes_of_ByteBuffer {n} (bb: ByteBuffer.t n) : bytes :=
  existT _ n bb.

(* Results describe what the guard may do after processing a rule. *)
Inductive result := ACCEPT | DROP.

Definition ipv4Split {A} (k: forall (w1 w2 w3 w4: word 8), A) (addr: word 32) : A :=
  let w1 := split2 24 8 addr in
  let w2 := split1 8 8 (split2 16 16 addr) in
  let w3 := split1 8 16 (split2 8 24 addr) in
  let w4 := split1 8 24 addr in
  k w1 w2 w3 w4.

Definition ipv4ToList :=
  ipv4Split (fun w1 w2 w3 w4 => [w1; w2; w3; w4]).

Definition ipv4ToByteBuffer :=
  ipv4Split (fun w1 w2 w3 w4 => ByteBuffer.of_list [w1; w2; w3; w4]: ByteBuffer.t 4).

Definition WrapDecoder {A B C} (f: forall n, ByteBuffer.t n -> option (A * B * C)) :=
  fun (bs: bytes) =>
    match f _ (projT2 bs) with
    | Some pkt => Some (fst (fst pkt))
    | None => None
    end.

Definition ipv4_decode (bs: bytes) :=
  WrapDecoder (@IPv4_decoder_impl) bs.

Definition tcp_decode (hdr: IPv4_Packet) :=
  let src := ipv4ToByteBuffer hdr.(SourceAddress) in
  let dst := ipv4ToByteBuffer hdr.(DestAddress) in
  let offset := 20 + 4 * List.length hdr.(IPv4Header.Options) in
  let tcpLen := wordToNat hdr.(TotalLength) - offset in
  fun (bs: bytes) =>
    let bs' := AlignedByteBuffer.bytebuffer_of_bytebuffer_range offset tcpLen (projT2 bs) in
    WrapDecoder (@TCP_decoder_impl src dst (natToWord 16 tcpLen)) bs'.

Definition udp_decode (hdr: IPv4_Packet) :=
  let src := ipv4ToByteBuffer hdr.(SourceAddress) in
  let dst := ipv4ToByteBuffer hdr.(DestAddress) in
  let offset := 20 + 4 * List.length hdr.(IPv4Header.Options) in
  let tcpLen := wordToNat hdr.(TotalLength) - offset in
  fun (bs: bytes) =>
    let bs' := AlignedByteBuffer.bytebuffer_of_bytebuffer_range offset tcpLen (projT2 bs) in
    WrapDecoder (@UDP_decoder_impl src dst (natToWord 16 tcpLen)) bs'.

Definition must {A} (o: option A) : if o then A else unit :=
  match o with
  | Some a => a
  | None => tt
  end.


Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import VST.msl.functors.
Import VST.msl.functors.MixVariantFunctor.
Import VST.msl.functors.MixVariantFunctorLemmas.

Module Type KNOT_INPUT__MIXVARIANT_HERED_T_OTH_REL.
  Parameter F : functor.

  Parameter other : Type.

  Parameter Rel : forall A, F A -> F A -> Prop.

  Parameter Rel_fmap : forall A B (f1: A->B) (f2:B->A) x y,
    Rel A x y ->
    Rel B (fmap F f1 f2 x) (fmap F f1 f2 y).
  Axiom Rel_refl : forall A x, Rel A x x.
  Axiom Rel_trans : forall A x y z,
    Rel A x y -> Rel A y z -> Rel A x z.

  Parameter ORel : other -> other -> Prop.
  Axiom ORel_refl : reflexive other ORel.
  Axiom ORel_trans : transitive other ORel.

  Parameter T:Type.
  Parameter T_bot:T.

  Parameter T_rel : T -> T -> Prop.
  Parameter T_rel_bot : forall x, T_rel T_bot x.
  Parameter T_rel_refl : forall x, T_rel x x.
  Parameter T_rel_trans : transitive T T_rel.

End KNOT_INPUT__MIXVARIANT_HERED_T_OTH_REL.

Module Type KNOT__MIXVARIANT_HERED_T_OTH_REL.
  Declare Module KI: KNOT_INPUT__MIXVARIANT_HERED_T_OTH_REL.
  Import KI.

  Parameter knot:Type.
  Parameter ageable_knot : ageable knot.
  Existing Instance ageable_knot.

  Parameter hered : (knot * other -> T) -> Prop.
  Definition predicate := { p:knot * other -> T | hered p }.

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Parameter approx : nat -> predicate -> predicate.

  Axiom squash_unsquash : forall k:knot, squash (unsquash k) = k.
  Axiom unsquash_squash : forall (n:nat) (f:F predicate),
    unsquash (squash (n,f)) = (n, fmap F (approx n) (approx n) f).

  Axiom approx_spec : forall n p ko,
    proj1_sig (approx n p) ko =
     if (Compare_dec.le_gt_dec n (level (fst ko))) then T_bot else proj1_sig p ko.

  Definition knot_rel (k1 k2:knot) :=
    let (n,f) := unsquash k1 in
    let (n',f') := unsquash k2 in
    n = n' /\ Rel predicate f f'.

  Axiom knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

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

  Axiom hered_spec : forall p,
    hered p =
    (forall k k' k'' o o',
      clos_refl_trans _ age k k' ->
      knot_rel  k' k'' ->
      ORel o o' ->
      T_rel (p (k,o)) (p (k'',o'))).

End KNOT__MIXVARIANT_HERED_T_OTH_REL.

Module Knot_MixVariantHeredTOthRel (KI':KNOT_INPUT__MIXVARIANT_HERED_T_OTH_REL) :
  KNOT__MIXVARIANT_HERED_T_OTH_REL with Module KI:=KI'.
  Module KI := KI'.
  Import KI.

  Definition sinv_prod X := prod X (F X * other -> T).

  Definition guppy_sig := (fun X:Type => X * (F X * other -> T) -> Prop).
  Definition guppy_ty := sigT guppy_sig.

  Definition guppy_step_ty (Z:guppy_ty) : Type :=
    (sig (fun (x:sinv_prod (projT1 Z)) => projT2 Z x)).

  Definition guppy_age (Z:guppy_ty) (x:guppy_step_ty Z) : projT1 Z := fst (proj1_sig x).
  Definition guppy_unage (Z:guppy_ty)
    (H:forall t, projT2 Z (t,fun _ => T_bot))
    (x:projT1 Z) : guppy_step_ty Z :=
    exist (fun z => projT2 Z z) (x, fun _ => T_bot) (H x).

  Definition guppy_step_prop (Z:guppy_ty) (xf:sinv_prod (guppy_step_ty Z)) :=
    (forall (k:F (guppy_step_ty Z)) (o:other) H,
         T_rel (snd xf (k,o))
               (snd (proj1_sig (fst xf)) (fmap F (guppy_age Z) (guppy_unage Z H) k,o))) /\
    (forall (k k':F (guppy_step_ty Z)) (o o':other),
         Rel (guppy_step_ty Z) k k' ->
         ORel o o' ->
         T_rel (snd xf (k,o)) (snd xf (k',o'))).

  Definition guppy_step (Z:guppy_ty) : guppy_ty :=
    existT guppy_sig (guppy_step_ty Z) (guppy_step_prop Z).

  Definition guppy_base : guppy_ty :=
    existT guppy_sig unit
      (fun xf =>
        (forall (k k':F unit) (o o':other),
          Rel unit k k' ->
          ORel o o' ->
          T_rel (snd xf (k,o)) (snd xf (k',o')))).

  Fixpoint guppy (n:nat) : guppy_ty :=
    match n with
    | 0    => guppy_base
    | S n' => guppy_step (guppy n')
    end.

  Definition sinv (n:nat) : Type := projT1 (guppy n).
  Definition sinv_prop (n:nat) : prod (sinv n) (F (sinv n) * other -> T) -> Prop := projT2 (guppy n).

  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 (proj1_sig p))
    end p.

  Definition knot := { n:nat & F (sinv n) }.

  Definition sinv_age n : sinv (S n) -> sinv n := guppy_age (guppy n).
  Program Definition sinv_unage n : sinv n -> sinv (S n) := guppy_unage (guppy n) _.
  Next Obligation.
    revert t; induction n; simpl; auto.
    repeat intro.
    apply T_rel_bot.
    split; simpl in *; repeat intro.
    apply T_rel_bot.
    apply T_rel_bot.
  Qed.

  Definition F_sinv n := F (sinv n).

  Definition age1_def (k:knot) : option knot :=
    match k with
      | existT _ 0 f => None
      | existT _ (S m) f => Some
          (existT F_sinv m (fmap F (sinv_age m) (sinv_unage m) f))
    end.

  Definition age_def x y := age1_def x = Some y.

  Inductive knot_rel_inner : knot -> knot -> Prop :=
    | intro_krel : forall n (f f':F_sinv n),
         Rel _ f f' ->
         knot_rel_inner (existT (F_sinv) n f) (existT (F_sinv) n f').

  Definition hered (p:knot * other -> T) : Prop :=
    forall k k' k'' o o',
      clos_refl_trans _ age_def k k' ->
      knot_rel_inner k' k'' -> ORel o o' ->
      T_rel (p (k,o)) (p (k'',o')).

  Definition predicate := { p:knot * other -> T | hered p }.

  Definition app_sinv (n:nat) (p:sinv (S n)) (x:F_sinv n * other) :=
    snd (proj1_sig p) x.

  Section stratifies.
    Variable Q:knot * other -> T.
    Variable HQ:hered 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_sinv n' k,o)
    end.

    Lemma stratifies_unique : forall n p1 p2,
      stratifies n p1 ->
      stratifies n p2 ->
      p1 = p2.
    Proof.
      induction n; simpl; intuition.
      destruct p1; destruct p2; auto.
      destruct p1; destruct p2.
      simpl in *; fold guppy in *.
      cut (x = x0).
      intros.
      revert p p0 H2 H3.
      rewrite <- H0.
      intros.
      replace p0 with p by (apply proof_irr); auto.
      destruct x; destruct x0; simpl in *.
      apply injective_projections; simpl.
      apply IHn; auto.
      extensionality; intros.
      simpl in *.
      destruct x as [x o].
      destruct (H2 x o); destruct (H3 x o).
      rewrite H2.
      rewrite H3.
      auto.
    Qed.

    Definition stratify (n:nat) : { x:sinv n | stratifies n x }.
    Proof.
      induction n.
      exists tt; simpl; exact I.
      assert (HX:
        projT2 (guppy n)
        (proj1_sig IHn, fun v : F_sinv n * other => Q (existT F_sinv n (fst v),snd v))).
      destruct n.
      simpl; intros.
      eapply HQ.
      apply rt_refl.
      constructor; auto.
      auto.
      simpl; intros.
      destruct IHn; simpl.
      simpl in s; destruct s.
      destruct x; simpl in *; fold guppy in *.
      destruct x; simpl in *.
      split; hnf; simpl; intros.
      rewrite H0.
      eapply HQ.
      apply rt_step.
      hnf; simpl.
      reflexivity.
      constructor; auto.
      unfold sinv_unage.
      replace (sinv_unage_obligation_1 n) with H1.
      unfold sinv_age.
      apply Rel_refl.
      apply proof_irr.
      apply ORel_refl.
      eapply HQ.
      apply rt_refl.
      constructor; auto.
      auto.

      exists ((exist (fun x => projT2 (guppy n) x) ( proj1_sig IHn, fun v:F_sinv n * other => Q (existT (F_sinv) n (fst v),snd v) ) HX)).
      simpl; split; auto.
      destruct IHn; auto.
    Qed.
  End stratifies.

  Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
  Proof.
    intros x y; revert x; induction y; simpl; intros.
    right; auto with arith.
    destruct (IHy x) as [[m H]|H].
    left; exists (S m); lia.
    destruct (Peano_dec.eq_nat_dec x y).
    left; exists O; lia.
    right; lia.
  Qed.

  Definition unstratify (n:nat) (p:sinv n) : knot * other -> T := 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 => T_bot
      end
    end.

  Lemma floor_shuffle:
    forall (m1 n : nat)
      (p1 : sinv (m1 + S n)) (H1 : (m1 + S n) = (S m1 + n)),
      floor (S m1) n (eq_rect (m1 + S n) sinv p1 (S m1 + n) H1) = fst (proj1_sig (floor m1 (S n) p1)).
  Proof.
    intros.
    remember (fst (proj1_sig (floor m1 (S n) p1))) as p.
    fold guppy in *.
    revert n p1 H1 p Heqp.
    induction m1; simpl; intros.
    replace H1 with (refl_equal (S n)) by (apply proof_irr); simpl; auto.
    assert (m1 + S n = S m1 + n) by lia.
    destruct p1 as [[p1 f'] Hp1]; simpl in *; fold guppy in *.
    generalize (IHm1 n p1 H p Heqp).
    clear.
    revert Hp1 H1; generalize H.
    revert p1 f'.
    rewrite H.
    simpl; intros.
    replace H1 with (refl_equal (S (S (m1 + n)))) by (apply proof_irr).
    simpl.
    replace H0 with (refl_equal (S (m1+n))) in H2 by (apply proof_irr).
    simpl in H2.
    trivial.
  Qed.

  Lemma unstratify_hered : forall n p,
    hered (unstratify n p).
  Proof.
    intros.
    hnf; intros.
    apply T_rel_trans with (unstratify n p (k',o)).
    clear o' H0 H1.
    induction H.
    hnf in H; simpl in H.
    destruct x as [x f]; simpl in H.
    destruct x; try discriminate.
    assert (y =
      (existT (F_sinv) x (fmap F (sinv_age x) (sinv_unage x) f))).
    inversion H; auto.
    subst y.
    unfold unstratify.
    case_eq (decompose_nat (S x) n); intros.
    destruct s.
    case_eq (decompose_nat x n); intros.
    destruct s.
    destruct n.
    elimtype False; lia.
    assert (S x0 = x1) by lia; subst x1.
    revert H1.
    generalize e e0; revert p; rewrite e; intros.
    rewrite floor_shuffle.
    replace e1 with (refl_equal (x0 + S (S x)));
      simpl eq_rect.
    2: apply proof_irr.
    revert H1.
    generalize (floor x0 (S (S x)) p).
    intros [[s' fs] Hs] H1; simpl in *; fold guppy in *.
    destruct Hs.
    simpl in H2.
    eapply H2; auto.
    elimtype False.
    lia.
    apply T_rel_bot.
    apply T_rel_refl.
    eapply T_rel_trans; eauto.

    clear H.
    inv H0.
    simpl.
    destruct (decompose_nat n0 n); [ | apply T_rel_bot ].
    destruct s; simpl.
    destruct (floor x (S n0) (eq_rect n sinv p (x +S n0) e)); simpl.
    destruct n0; simpl in x0; destruct x0; simpl.
    apply p0; auto.
    apply p0; auto.
  Qed.

  Lemma unstratify_Q : forall n (p:sinv n) Q,
    stratifies Q n p ->
    forall (k:knot) (o:other),
      projT1 k < n ->
      (unstratify n p (k,o) = Q (k,o)).
  Proof.
    intros.
    unfold unstratify.
    destruct k.
    destruct (decompose_nat x n).
    destruct s.
    simpl in H0.
    2: simpl in *; elimtype False; lia.
    clear H0.
    revert p H.
    generalize e.
    rewrite e.
    intros.
    replace e0 with (refl_equal (x0 + S x)) by apply proof_irr.
    simpl.
    clear e e0.
    revert p H.
    induction x0; simpl; intros.
    destruct H.
    auto.
    destruct H.
    apply IHx0.
    auto.
  Qed.

  Lemma stratifies_unstratify_more :
    forall (n m1 m2:nat) (p1:sinv (m1+n)) (p2:sinv (m2+n)),
      floor m1 n p1 = floor m2 n p2 ->
      (stratifies (unstratify (m1+n) p1) n (floor m1 n p1) ->
       stratifies (unstratify (m2+n) p2) n (floor m2 n p2)).
  Proof.
    induction n; intuition.
    split.
    assert (m2 + S n = S m2 + n) by lia.
    erewrite <- floor_shuffle.
    instantiate (1:=H1).
    replace (unstratify (m2 + S n) p2)
      with (unstratify (S m2 + n) (eq_rect (m2 + S n) sinv p2 (S m2 + n) H1)).
    assert (m1 + S n = S m1 + n) by lia.
    eapply (IHn (S m1) (S m2)
      (eq_rect (m1 + S n) sinv p1 (S m1 + n) H2)).
    rewrite floor_shuffle.
    rewrite floor_shuffle.
    rewrite H; auto.
    clear - H0.
    rewrite floor_shuffle.
    simpl in H0.
    destruct H0.
    clear H0.
    revert p1 H.
    generalize H2.
    rewrite <- H2.
    intros.
    replace H0 with (refl_equal (m1 + S n)) by apply proof_irr; auto.
    clear.
    revert p2.
    generalize H1.
    rewrite H1.
    intros.
    replace H0 with (refl_equal (S m2 + n)) by apply proof_irr; auto.

    intros.
    simpl.
    destruct (decompose_nat n (m2 + S n)).
    destruct s.
    assert (m2 = x).
    lia.
    subst x.
    replace e with (refl_equal (m2 + S n)).
    simpl; tauto.
    apply proof_irr.
    elimtype False; lia.
  Qed.

  Lemma stratify_unstratify : forall n p H,
    proj1_sig (stratify (unstratify n p) H n) = p.
  Proof.
    intros.
    apply stratifies_unique with (unstratify n p).
    destruct (stratify _ H n).
    simpl; auto.
    clear H.
    revert p; induction n.
    simpl; intros; auto.
    intros.
    simpl; split.

    assert (stratifies (unstratify n (fst (proj1_sig p))) n (fst (proj1_sig p))).
    apply IHn.
    apply (stratifies_unstratify_more n 0 1 (fst (proj1_sig p)) p).
    simpl; auto.
    auto.

    intros.
    destruct (decompose_nat n (S n)).
    destruct s.
    assert (x = 0) by lia.
    subst x.
    simpl.
    simpl in e.
    replace e with (refl_equal (S n)) by apply proof_irr.
    simpl.
    split; auto.
    elimtype False; lia.
  Qed.

  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) : knot :=
    match x with (n,f) => existT (F_sinv) n (fmap F (strat n) (unstrat n) f) end.

  Definition unsquash (k:knot) : nat * F predicate :=
    match k with existT _ n f => (n, fmap F (unstrat n) (strat 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 (Compare_dec.le_gt_dec n (knot_level_def (fst w))) then T_bot else proj1_sig p w.
  Next Obligation.
    hnf; simpl; intros.
    destruct (Compare_dec.le_gt_dec n (knot_level_def k)).
    apply T_rel_bot.
    destruct (Compare_dec.le_gt_dec n (knot_level_def k'')).
    elimtype False.
    cut (knot_level_def k'' <= knot_level_def k).
    lia.
    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.le_trans; eauto.
    inv H0.
    unfold knot_level_def; simpl; auto.

    destruct p as [p Hp]; simpl.
    eapply Hp; eauto.
  Qed.

  Lemma strat_unstrat : forall n,
    strat n oo unstrat n = id (sinv n).
  Proof.
    intros; extensionality p.
    unfold compose, id.
    unfold strat, unstrat.
    simpl.
    rewrite stratify_unstratify.
    auto.
  Qed.

  Lemma predicate_eq : forall (p1 p2:predicate),
    proj1_sig p1 = proj1_sig p2 ->
    p1 = p2.
  Proof.
    intros; destruct p1; destruct p2; simpl in H.
    subst x0.
    replace h0 with h by apply proof_irr.
    auto.
  Qed.

  Lemma unstrat_strat : forall n,
    unstrat n oo strat n = approx n.
  Proof.
    intros.
    extensionality.
    unfold compose.
    unfold unstrat, strat.
    unfold approx.
    apply predicate_eq.
    simpl.
    extensionality k.
    destruct (Compare_dec.le_gt_dec n (knot_level_def (fst k))).
    unfold unstratify.
    destruct k.
    destruct k.
    unfold knot_level_def in l.
    simpl in *.
    destruct (decompose_nat x0 n); simpl.
    destruct s; simpl; elimtype False; lia.
    auto.
    destruct x as [x Hx]; simpl.
    destruct (stratify x Hx n); simpl.
    destruct k.
    rewrite unstratify_Q with (Q:=x); auto.
    unfold level in *.
    destruct k; simpl in *; auto.
  Qed.

  Lemma squash_unsquash : forall k, squash (unsquash k) = k.
  Proof.
    intros.
    destruct k as [n f]; simpl.
    f_equal.
    change ((fmap F (strat n) (unstrat n) oo (fmap F (unstrat n) (strat n))) f = f).
    rewrite fmap_comp.
    rewrite strat_unstrat.
    rewrite fmap_id.
    auto.
  Qed.

  Lemma unsquash_squash : forall n f,
    unsquash (squash (n,f)) = (n, fmap F (approx n) (approx n) f).
  Proof.
    intros.
    unfold unsquash, squash.
    f_equal.
    change ((fmap F (unstrat n) (strat n) oo (fmap F (strat n) (unstrat n))) f = fmap F (approx n) (approx n) f).
    rewrite fmap_comp.
    rewrite unstrat_strat.
    auto.
  Qed.

  Lemma strat_Sx_unstrat : forall x,
    sinv_unage x = strat (S x) oo unstrat x.
  Proof.
    intros.
    extensionality k.
    unfold sinv_unage.
    generalize (sinv_unage_obligation_1); intro P.
    unfold guppy_unage.
    unfold compose, strat, unstrat.
    simpl.
    apply stratifies_unique with (unstratify x k).
    revert k.
    induction x; simpl; intuition.
    destruct (decompose_nat 0 0); auto.
    destruct s; elimtype False; lia.
    eapply (stratifies_unstratify_more x 0 1).
    simpl; reflexivity.
    simpl.
    simpl in *.
    destruct (IHx (fst (proj1_sig k))); auto.
    destruct (decompose_nat x (S x)).
    destruct s.
    assert (x0 = 0) by lia; subst x0.
    simpl in *.
    replace e with (refl_equal (S x)) by apply proof_irr; auto.
    elimtype False; lia.
    destruct (decompose_nat x (S x)).
    destruct s.
    assert (x0 = 0) by lia; subst x0.
    simpl in *.
    destruct (decompose_nat (S x) (S x)).
    destruct s; elimtype False; lia.
    auto.
    destruct (decompose_nat (S x) (S x)).
    destruct s; elimtype False; lia.
    auto.

    destruct (stratify (unstratify x k) (unstratify_hered x k) (S x)).
    simpl stratifies in s; case s; intros.
    simpl stratifies; split; auto.
  Qed.

  Lemma strat_unstrat_Sx : forall x,
    sinv_age x = strat x oo unstrat (S x).
  Proof.
    intros.
    extensionality k.
    unfold sinv_age, guppy_age.
    unfold compose.
    unfold strat, unstrat.
    simpl.
    apply stratifies_unique with (unstratify x (fst (proj1_sig k))).
    revert k; induction x; simpl; auto.
    intros.
    split.
    eapply (stratifies_unstratify_more x 0 1 ).
    simpl; reflexivity.
    simpl.
    apply IHx.
    intros.
    destruct (decompose_nat x (S x)).
    destruct s.
    assert (x0 = 0) by lia; subst x0.
    simpl in *.
    replace e with (refl_equal (S x)) by apply proof_irr; simpl.
    tauto.
    elimtype False; lia.
    destruct (stratify (unstratify (S x) k)
      (unstratify_hered (S x) k) x).
    simpl; auto.
    cut (x0 = (fst (proj1_sig k))); intros.
    subst x0.
    eapply (stratifies_unstratify_more x 1 0).
    simpl; reflexivity.
    simpl; auto.
    eapply stratifies_unique.
    apply s.
    eapply (stratifies_unstratify_more x 0 1).
    simpl; reflexivity.
    simpl.
    generalize (fst (proj1_sig k) : sinv x).
    clear.
    induction x; simpl; intuition.
    eapply (stratifies_unstratify_more x 0 1).
    simpl; reflexivity.
    simpl.
    apply IHx.
    destruct (decompose_nat x (S x)).
    destruct s0.
    assert (x0 = 0) by lia; subst.
    simpl in *.
    replace e with (refl_equal (S x)); simpl; auto.
    apply proof_irr.
    elimtype False; lia.
  Qed.

  Lemma age1_eq : forall k,
    age1_def k = knot_age1_def k.
  Proof.
    intros.
    unfold knot_age1_def.
    case_eq (unsquash k); intros.
    case_eq k; intros.
    simpl.
    assert (n = x).
    subst k.
    inv H; auto.
    subst x.
    destruct n; auto.
    f_equal.
    f_equal.

    rewrite strat_Sx_unstrat.
    rewrite strat_unstrat_Sx.
    rewrite <- fmap_comp.
    unfold compose.
    f_equal.
    subst k.
    inv H; auto.
  Qed.

  Lemma unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Proof.
    intros.
    rewrite <- (squash_unsquash k1).
    rewrite <- (squash_unsquash k2).
    rewrite H.
    trivial.
  Qed.
  Arguments unsquash_inj [k1 k2] _.

  Lemma pred_ext : forall (p1 p2:predicate),
    (forall x, proj1_sig p1 x = proj1_sig p2 x) ->
    p1 = p2.
  Proof.
    intros.
    destruct p1 as [p1 Hp1]; destruct p2 as [p2 Hp2].
    simpl in *.
    assert (p1 = p2).
    extensionality x; auto.
    subst p2.
    replace Hp2 with Hp1; auto.
    apply proof_irr.
  Qed.

  Lemma approx_spec : forall n p ko,
    proj1_sig (approx n p) ko =
     if (Compare_dec.le_gt_dec n (knot_level_def (fst ko))) then T_bot else proj1_sig p ko.
  Proof.
    intros; simpl; auto.
  Qed.

  Lemma ag_knot_facts : ageable_facts knot knot_level_def knot_age1_def.
  Proof.
    constructor.

    unfold knot_age1_def; unfold knot_level_def; simpl; intros x'.
    destruct (unsquash x') as [n f] eqn:?H; intros.
    destruct x' as [x f0].
    exists (squash (S x, fmap F (unstrat x) (strat x) f0)).
    rewrite unsquash_squash.
    f_equal. f_equal.
    clear.
    transitivity ((fmap F (strat x) (unstrat x) oo fmap F (approx (S x)) (approx (S x)) oo fmap F (unstrat x) (strat x)) f0); auto.
    do 2 rewrite fmap_comp.
    rewrite compose_assoc.
    replace (strat x oo approx (S x) oo unstrat x) with (@id (sinv x)).
    rewrite fmap_id. auto.
    rewrite <- (strat_unstrat x).
    f_equal.
    extensionality a.
    unfold compose, approx.
    case_eq (unstrat x a); intros.
    match goal with
      [ |- _ = exist _ ?X _ ] =>
      assert (x0 = X)
    end.
   2:{
    generalize (approx_obligation_1 (S x)
      (exist (fun p => hered p) x0 h)).
    rewrite <- H0.
    intros. f_equal.
    }
    extensionality.
    destruct x1.
    unfold unstrat in H.
    inv H.
    destruct k.
    unfold unstratify.
    unfold knot_level_def.
    simpl fst.
    destruct (decompose_nat x0 x).
    destruct s.
    destruct (Compare_dec.le_gt_dec (S x) x0).
    elimtype False; lia.
    simpl.
    destruct (decompose_nat x0 x).
    destruct s.
    assert (x1 = x2) by lia.
    subst x2.
    replace e0 with e by apply proof_irr.
    auto.
    elimtype False; lia.
    destruct (Compare_dec.le_gt_dec (S x) x0); auto.
    simpl.
    destruct (decompose_nat x0 x); auto.
    destruct s. elimtype False. lia.

    intro.
    unfold knot_age1_def, knot_level_def.
    case_eq (unsquash x); intros.
    destruct n; simpl; intuition;
      discriminate.

    intros.
    unfold knot_age1_def, knot_level_def in *.
    case_eq (unsquash x); intros; rewrite H0 in H.
    destruct n; try discriminate; simpl.
    inv H; simpl; auto.
  Qed.

  Definition ageable_knot : ageable knot :=
    mkAgeable knot knot_level_def knot_age1_def ag_knot_facts.
  Existing Instance ageable_knot.

  Definition knot_rel (k1 k2:knot) :=
    let (n,f) := unsquash k1 in
    let (n',f') := unsquash k2 in
    n = n' /\ Rel predicate f f'.

  Lemma hered_spec : forall p,
    hered p =
    (forall k k' k'' o o',
      clos_refl_trans _ age k k' ->
      knot_rel  k' k'' ->
      ORel o o' ->
      T_rel (p (k,o)) (p (k'',o'))).
  Proof.
    intros.
    apply prop_ext.
    intuition.
    eapply H.
    instantiate (1:=k').
    clear -H0; induction H0; auto.
    apply rt_step.
    unfold age_def.
    rewrite age1_eq.
    auto.
    eapply rt_trans; eauto.
    destruct k' as [x f], k'' as [x0 f0].
    unfold knot_rel, unsquash in H1.
    destruct H1; subst.
    constructor.
    apply (Rel_fmap _ _ (strat x0) (unstrat x0)) in H3.
    change f with (id _ f).
    change f0 with (id _ f0).
    rewrite <- fmap_id.
    rewrite <- (strat_unstrat x0).
    rewrite <- fmap_comp.
    auto.
    assumption.

    hnf; intros.
    apply (H k k' k''); auto.
    clear -H0; induction H0; auto.
    apply rt_step.
    hnf.
    rewrite <- age1_eq; auto.
    eapply rt_trans; eauto.

    destruct k'; destruct k''.
    inv H1.
    simpl.
    hnf; split; auto.
    apply Eqdep_dec.inj_pair2_eq_dec in H5; auto.
    apply Eqdep_dec.inj_pair2_eq_dec in H7; auto.
    subst.
    apply Rel_fmap; auto.
    exact Peano_dec.eq_nat_dec.
    exact Peano_dec.eq_nat_dec.
  Qed.

  Lemma knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.
  Proof.
    intros; reflexivity.
  Qed.

  Lemma knot_level : forall k:knot,
    level k = fst (unsquash k).
  Proof.
    intros; reflexivity.
  Qed.

End Knot_MixVariantHeredTOthRel.

Module KnotLemmas1.

Class Input: Type := {
  knot: Type;
  Fpred: Type;
  squash: nat * Fpred -> knot;
  unsquash: knot -> nat * Fpred;
  approxF: nat -> Fpred -> Fpred;
  squash_unsquash : forall k:knot, squash (unsquash k) = k;
  unsquash_squash : forall (n:nat) (f:Fpred),
    unsquash (squash (n,f)) = (n, approxF n f)
}.

Class Output (input: Input): Prop := {
  unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2;
  squash_surj : forall k, exists n, exists Fp,
    squash (n, Fp) = k;
  unsquash_approx : forall k n Fp,
    unsquash k = (n, Fp) ->
    Fp = approxF n Fp
}.

Lemma Proof (kli: Input): Output kli.
Proof.
  constructor.
  + intros.
    rewrite <- (squash_unsquash k1).
    rewrite <- (squash_unsquash k2).
    rewrite H.
    trivial.
  + intros.
    remember (unsquash k).
    destruct p as [n f].
    exists n.
    exists f.
    rewrite Heqp.
    rewrite squash_unsquash.
    trivial.
  + intros.
    generalize H; intro.
    rewrite <- (squash_unsquash k) in H.
    rewrite H0 in H.
    rewrite unsquash_squash in H.
    inversion H.
    rewrite H2.
    symmetry.
    trivial.
Qed.

End KnotLemmas1.

Module KnotLemmas2.

Class Input: Type := {
  knot: Type;
  other: Type;
  T: Type;
  t0: T;
  ageable_knot : ageable knot;
  predicate: Type;
  p2p: predicate -> (knot * other -> T);
  approx : nat -> predicate -> predicate;
  pred_ext : forall (p1 p2:predicate),
    (forall x, p2p p1 x = p2p p2 x) ->
    p1 = p2;
  approx_spec : forall n p ko,
    p2p (approx n p) ko =
     if (Compare_dec.le_gt_dec n (level (fst ko))) then t0 else p2p p ko
}.

Class Output (input: Input): Prop := {
  approx_approx1 : forall m n,
    approx n = approx n oo approx (m+n);
  approx_approx2 : forall m n,
    approx n = approx (m+n) oo approx n
}.

Lemma Proof (kli: Input): Output kli.
Proof.
  constructor.
  + intros.
    extensionality p.
    apply pred_ext.
    intros [k o].
    unfold compose.
    repeat rewrite approx_spec.
    simpl.
    destruct (Compare_dec.le_gt_dec n (level k)); auto.
    destruct (Compare_dec.le_gt_dec (m+n) (level k)); auto.
    elimtype False; lia.
  + intros.
    extensionality p.
    apply pred_ext.
    intros [k o].
    unfold compose.
    repeat rewrite approx_spec.
    simpl.
    destruct (Compare_dec.le_gt_dec (m+n) (level k)); auto.
    destruct (Compare_dec.le_gt_dec n (level k)); auto.
    elimtype False; lia.
Qed.

End KnotLemmas2.

Module KnotLemmas_MixVariantHeredTOthRel (K : KNOT__MIXVARIANT_HERED_T_OTH_REL).
  Import K.KI.
  Import K.

  Lemma unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Proof.
    apply
     (@KnotLemmas1.unsquash_inj
       (KnotLemmas1.Build_Input _ _ _ _ _ squash_unsquash unsquash_squash)),
     (KnotLemmas1.Proof).
  Qed.
  Arguments unsquash_inj [k1 k2] _.

  Lemma squash_surj : forall k, exists n, exists Fp,
    squash (n, Fp) = k.
  Proof.
    apply
     (@KnotLemmas1.squash_surj
       (KnotLemmas1.Build_Input _ _ _ _ _ squash_unsquash unsquash_squash)),
     (KnotLemmas1.Proof).
  Qed.

  Lemma unsquash_approx : forall k n Fp,
    unsquash k = (n, Fp) ->
    Fp = fmap F (approx n) (approx n) Fp.
  Proof.
    apply
     (@KnotLemmas1.unsquash_approx
       (KnotLemmas1.Build_Input _ _ _ _ _ squash_unsquash unsquash_squash)),
     (KnotLemmas1.Proof).
  Qed.
  Arguments unsquash_approx [k n Fp] _.

  Lemma pred_ext : forall (p1 p2:predicate),
    (forall x, proj1_sig p1 x = proj1_sig p2 x) ->
    p1 = p2.
  Proof.
    intros.
    destruct p1 as [p1 Hp1]; destruct p2 as [p2 Hp2].
    simpl in *.
    assert (p1 = p2).
    extensionality x; auto.
    subst p2.
    replace Hp2 with Hp1; auto.
    apply proof_irr.
  Qed.

  Lemma approx_approx1 : forall m n,
    approx n = approx n oo approx (m+n).
  Proof.
    apply
     (@KnotLemmas2.approx_approx1
       (KnotLemmas2.Build_Input _ _ _ _ _ _ _ _ pred_ext approx_spec)),
     (KnotLemmas2.Proof).
  Qed.

  Lemma approx_approx2 : forall m n,
    approx n = approx (m+n) oo approx n.
  Proof.
    apply
     (@KnotLemmas2.approx_approx2
       (KnotLemmas2.Build_Input _ _ _ _ _ _ _ _ pred_ext approx_spec)),
     (KnotLemmas2.Proof).
  Qed.

End KnotLemmas_MixVariantHeredTOthRel.

Module Type KNOT_FULL_OUTPUT.
  Declare Module KI: KNOT_INPUT__MIXVARIANT_HERED_T_OTH_REL.
  Declare Module K0: KNOT__MIXVARIANT_HERED_T_OTH_REL with Module KI := KI.
  Import K0.
  Parameter predicate: Type.
  Parameter pkp: bijection predicate K0.predicate.
End KNOT_FULL_OUTPUT.

Module Type KNOT_FULL.
  Declare Module KI: KNOT_INPUT__MIXVARIANT_HERED_T_OTH_REL.
  Declare Module KO: KNOT_FULL_OUTPUT with Module KI := KI.
  Import KI.
  Import KO.

  Definition knot : Type := KO.K0.knot.
  Definition ageable_knot : ageable knot := KO.K0.ageable_knot.
  Existing Instance ageable_knot.
  Definition predicate: Type := KO.predicate.

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Parameter approx : nat -> predicate -> predicate.

  Axiom squash_unsquash : forall k:knot, squash (unsquash k) = k.
  Axiom unsquash_squash : forall (n:nat) (f:F predicate),
    unsquash (squash (n,f)) = (n, fmap F (approx n) (approx n) f).

  Axiom approx_spec : forall n p ko,
    proj1_sig (bij_f _ _ KO.pkp (approx n p)) ko =
     if (Compare_dec.le_gt_dec n (level (fst ko)))
     then KI.T_bot
     else proj1_sig (bij_f _ _ KO.pkp p) ko.

  Axiom knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

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

  Definition knot_rel (k1 k2:knot) :=
    let (n,f) := unsquash k1 in
    let (n',f') := unsquash k2 in
    n = n' /\ KI.Rel predicate f f'.

  Axiom knot_rel_spec: forall k1 k2: knot,
    knot_rel k1 k2 = KO.K0.knot_rel k1 k2.

End KNOT_FULL.

Module Type KNOT_FULL_LEMMAS.
  Declare Module K: KNOT_FULL.
  Import K.

  Axiom unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Arguments unsquash_inj [k1 k2] _.

  Axiom squash_surj : forall k, exists n, exists Fp,
    squash (n, Fp) = k.

  Axiom unsquash_approx : forall k n Fp,
    unsquash k = (n, Fp) ->
    Fp = fmap KI.F (approx n) (approx n) Fp.
  Arguments unsquash_approx [k n Fp] _.

  Axiom approx_approx1 : forall m n,
    approx n = approx n oo approx (m+n).

  Axiom approx_approx2 : forall m n,
    approx n = approx (m+n) oo approx n.

End KNOT_FULL_LEMMAS.

Module KnotFull
  (KI': KNOT_INPUT__MIXVARIANT_HERED_T_OTH_REL)
  (KO': KNOT_FULL_OUTPUT with Module KI := KI'):
  KNOT_FULL with Module KI := KI' with Module KO:=KO'.

  Import MixVariantFunctor.
  Module KI:=KI'.
  Module KO:=KO'.

  Definition knot: Type := KO.K0.knot.
  Definition ageable_knot : ageable knot := KO.K0.ageable_knot.
  Existing Instance ageable_knot.
  Definition predicate: Type := KO.predicate.

  Definition squash : (nat * KI.F predicate) -> knot :=
    fun k => KO.K0.squash
     (fst k, fmap KI.F (bij_f _ _ KO.pkp) (bij_g _ _ KO.pkp) (snd k)).

  Definition unsquash : knot -> (nat * KI.F predicate) :=
    fun k => let (n, f) := KO.K0.unsquash k in
      (n, fmap KI.F (bij_g _ _ KO.pkp) (bij_f _ _ KO.pkp) f).

  Definition approx : nat -> predicate -> predicate :=
    fun n => (bij_g _ _ KO.pkp) oo KO.K0.approx n oo (bij_f _ _ KO.pkp).

  Lemma squash_unsquash : forall k:knot, squash (unsquash k) = k.
  Proof.
    intros; unfold squash, unsquash.
    destruct (KO.K0.unsquash k) as [n f] eqn:?H; simpl.
    rewrite fmap_app, bij_fg_id, fmap_id.
    unfold id.
    rewrite <- H; apply KO.K0.squash_unsquash.
  Qed.

  Lemma unsquash_squash : forall (n:nat) (f:KI.F predicate),
    unsquash (squash (n,f)) = (n, fmap KI.F (approx n) (approx n) f).
  Proof.
    intros; unfold squash, unsquash, approx; simpl.
    rewrite KO.K0.unsquash_squash, !fmap_app, compose_assoc.
    auto.
  Qed.

  Lemma approx_spec : forall n p ko,
    proj1_sig (bij_f _ _ KO.pkp (approx n p)) ko =
     if (Compare_dec.le_gt_dec n (level (fst ko)))
     then KI.T_bot
     else proj1_sig (bij_f _ _ KO.pkp p) ko.
  Proof.
    intros.
    rewrite <- KO.K0.approx_spec.
    unfold approx.
    pattern (KO.K0.approx n) at 2.
    rewrite <- (id_unit2 _ _ (KO.K0.approx n)), <- (bij_fg_id KO.pkp).
    reflexivity.
  Qed.

  Lemma knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.
  Proof.
    intros.
    unfold squash, unsquash.
    rewrite KO.K0.knot_age1.
    destruct (KO.K0.unsquash k) as [n f] eqn:?H.
    destruct n; auto.
    f_equal; simpl.
    rewrite fmap_app, bij_fg_id, fmap_id.
    auto.
  Qed.

  Lemma knot_level: forall k:knot, level k = fst (unsquash k).
  Proof.
    intros.
    unfold unsquash.
    rewrite KO.K0.knot_level.
    destruct (KO.K0.unsquash k) as [n f]; auto.
  Qed.

  Definition knot_rel (k1 k2:knot) :=
    let (n,f) := unsquash k1 in
    let (n',f') := unsquash k2 in
    n = n' /\ KI.Rel predicate f f'.

  Lemma knot_rel_spec: forall k1 k2: knot,
    knot_rel k1 k2 = KO.K0.knot_rel k1 k2.
  Proof.
    intros.
    unfold knot_rel, KO.K0.knot_rel, unsquash.
    destruct (KO.K0.unsquash k1) as [n1 f1].
    destruct (KO.K0.unsquash k2) as [n2 f2].
    f_equal.
    apply prop_ext.
    split; intros.
    + pose proof KI.Rel_fmap _ _ (bij_f _ _ KO.pkp) (bij_g _ _ KO.pkp) _ _ H.
      rewrite !fmap_app, bij_fg_id, fmap_id in H0.
      auto.
    + pose proof KI.Rel_fmap _ _ (bij_g _ _ KO.pkp) (bij_f _ _ KO.pkp) _ _ H.
      auto.
  Qed.

End KnotFull.

Module KnotFullLemmas (K: KNOT_FULL).
  Import K.KI.
  Import K.

  Lemma unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Proof.
    apply
     (@KnotLemmas1.unsquash_inj
       (KnotLemmas1.Build_Input _ _ _ _ _ squash_unsquash unsquash_squash)),
     (KnotLemmas1.Proof).
  Qed.
  Arguments unsquash_inj [k1 k2] _.

  Lemma squash_surj : forall k, exists n, exists Fp,
    squash (n, Fp) = k.
  Proof.
    apply
     (@KnotLemmas1.squash_surj
       (KnotLemmas1.Build_Input _ _ _ _ _ squash_unsquash unsquash_squash)),
     (KnotLemmas1.Proof).
  Qed.

  Lemma unsquash_approx : forall k n Fp,
    unsquash k = (n, Fp) ->
    Fp = fmap F (approx n) (approx n) Fp.
  Proof.
    apply
     (@KnotLemmas1.unsquash_approx
       (KnotLemmas1.Build_Input _ _ _ _ _ squash_unsquash unsquash_squash)),
     (KnotLemmas1.Proof).
  Qed.
  Arguments unsquash_approx [k n Fp] _.

  Lemma pred_ext : forall (p1 p2:predicate),
    (forall x, proj1_sig (bij_f _ _ KO.pkp p1) x =
               proj1_sig (bij_f _ _ KO.pkp p2) x) ->
    p1 = p2.
  Proof.
    intros.
    change (p1 = p2) with (id K.KO.predicate p1 = id K.KO.predicate p2).
    rewrite <- (bij_gf_id KO.pkp); unfold compose.
    destruct (bij_f _ _ KO.pkp p1) as [pp1 Hp1];
    destruct (bij_f _ _ KO.pkp p2) as [pp2 Hp2].
    simpl in *.
    assert (pp1 = pp2).
    extensionality x; auto.
    subst pp2.
    replace Hp2 with Hp1; auto.
    apply proof_irr.
  Qed.

  Lemma approx_approx1 : forall m n,
    approx n = approx n oo approx (m+n).
  Proof.
    apply
     (@KnotLemmas2.approx_approx1
       (KnotLemmas2.Build_Input _ _ _ _ _ _
         (@proj1_sig _ _ oo bij_f _ _ K.KO.pkp) _ pred_ext approx_spec)),
     (KnotLemmas2.Proof).
  Qed.

  Lemma approx_approx2 : forall m n,
    approx n = approx (m+n) oo approx n.
  Proof.
    apply
     (@KnotLemmas2.approx_approx2
       (KnotLemmas2.Build_Input _ _ _ _ _ _
         (@proj1_sig _ _ oo bij_f _ _ K.KO.pkp) _ pred_ext approx_spec)),
     (KnotLemmas2.Proof).
  Qed.

End KnotFullLemmas.

(*
Module Type KNOT_FULL_INPUT.
  Parameter F : functor.

  Parameter other : Type.

  Parameter Rel : forall A, F A -> F A -> Prop.

  Parameter Rel_fmap : forall A B (f1: A->B) (f2:B->A) x y,
    Rel A x y ->
    Rel B (fmap F f1 f2 x) (fmap F f1 f2 y).
  Axiom Rel_refl : forall A x, Rel A x x.
  Axiom Rel_trans : forall A x y z,
    Rel A x y -> Rel A y z -> Rel A x z.

  Parameter ORel : other -> other -> Prop.
  Axiom ORel_refl : reflexive other ORel.
  Axiom ORel_trans : transitive other ORel.

  Parameter T:Type.
  Parameter T_bot:T.

  Parameter T_rel : T -> T -> Prop.
  Parameter T_rel_bot : forall x, T_rel T_bot x.
  Parameter T_rel_refl : forall x, T_rel x x.
  Parameter T_rel_trans : transitive T T_rel.

  Parameter Pred: forall K: Type, ageable K -> (K -> K -> Prop) -> Type.

  Parameter Pred2predicate: forall {K agK KRel},
    Pred K agK KRel ->
    { p: K * other -> T |
      (forall k k' k'' o o',
      clos_refl_trans _ age k k' ->
      KRel k' k'' ->
      ORel o o' ->
      T_rel (p (k,o)) (p (k'',o'))) }.

  Parameter predicate2Pred: forall {K agK} {KRel: K -> K -> Prop},
    { p: K * other -> T |
      (forall (k k' k'': K) o o',
      clos_refl_trans _ age k k' ->
      KRel k' k'' ->
      ORel o o' ->
      T_rel (p (k,o)) (p (k'',o'))) } ->
    Pred K agK KRel.

  Axiom P2p2P: forall K agK KRel (P: Pred K agK KRel),
    predicate2Pred (Pred2predicate P) = P.

  Axiom p2P2p: forall K agK KRel p,
    Pred2predicate (@predicate2Pred K agK KRel p) = p.

End KNOT_FULL_INPUT.

Module Type KNOT_FULL.
  Declare Module KI: KNOT_FULL_INPUT.
  Import KI.

  Parameter knot:Type.
  Parameter ageable_knot : ageable knot.
  Existing Instance ageable_knot.
  Parameter knot_rel: knot -> knot -> Prop.

  Definition predicate: Type := Pred knot ageable_knot knot_rel.

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Parameter approx : nat -> predicate -> predicate.

  Axiom squash_unsquash : forall k:knot, squash (unsquash k) = k.
  Axiom unsquash_squash : forall (n:nat) (f:F predicate),
    unsquash (squash (n,f)) = (n, fmap F (approx n) (approx n) f).

  Axiom approx_spec : forall n p ko,
    proj1_sig (Pred2predicate (approx n (predicate2Pred p))) ko =
     if (le_gt_dec n (level (fst ko))) then T_bot else proj1_sig p ko.

  Axiom knot_rel_spec: forall (k1 k2:knot),
     knot_rel k1 k2 =
    let (n,f) := unsquash k1 in
    let (n',f') := unsquash k2 in
    n = n' /\ Rel predicate f f'.

  Axiom knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

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

End KNOT_FULL.

Module KnotFull (KI': KNOT_FULL_INPUT): KNOT_FULL with Module KI:=KI'.

  Import MixVariantFunctor.
  Module KI:=KI'.

  Module Input.
    Definition F: functor := KI.F.
    Definition other: Type := KI.other.
    Definition Rel: forall (A:Type), KI.F A -> KI.F A -> Prop := KI.Rel.

    Definition Rel_fmap : forall A B (f1: A->B) (f2:B->A) x y,
      Rel A x y ->
      Rel B (fmap F f1 f2 x) (fmap F f1 f2 y)
      := KI.Rel_fmap.

    Definition Rel_refl : forall A x, Rel A x x := KI.Rel_refl.

    Definition Rel_trans : forall A x y z,
      Rel A x y -> Rel A y z -> Rel A x z
      := KI.Rel_trans.

    Definition ORel := KI.ORel.
    Definition ORel_refl := KI.ORel_refl.
    Definition ORel_trans := KI.ORel_trans.

    Definition T := KI.T.
    Definition T_bot: T := KI.T_bot.
    Definition T_rel : T -> T -> Prop := KI.T_rel.
    Definition T_rel_bot : forall x, T_rel T_bot x := KI.T_rel_bot.
    Definition T_rel_refl : forall x, T_rel x x := KI.T_rel_refl.
    Definition T_rel_trans : transitive T T_rel := KI.T_rel_trans.
  End Input.

  Module K := Knot_MixVariantHeredTOthRel(Input).
  Module KL := KnotLemmas_MixVariantHeredTOthRel(K).

  Definition knot: Type := K.knot.
  Definition ageable_knot : ageable knot := K.ageable_knot.
  Existing Instance ageable_knot.
  Definition knot_rel: knot -> knot -> Prop := K.knot_rel.
  Definition predicate: Type := KI.Pred knot ageable_knot knot_rel.

  Definition squash : (nat * KI.F predicate) -> knot :=
    fun k => K.squash (fst k, fmap KI.F KI.Pred2predicate KI.predicate2Pred (snd k)).

  Parameter unsquash : knot -> (nat * F predicate).

  Parameter approx : nat -> predicate -> predicate.

  Axiom squash_unsquash : forall k:knot, squash (unsquash k) = k.
  Axiom unsquash_squash : forall (n:nat) (f:F predicate),
    unsquash (squash (n,f)) = (n, fmap F (approx n) (approx n) f).

  Axiom approx_spec : forall n p ko,
    proj1_sig (Pred2predicate (approx n (predicate2Pred p))) ko =
     if (le_gt_dec n (level (fst ko))) then T_bot else proj1_sig p ko.

  Axiom knot_rel_spec: forall (k1 k2:knot),
     knot_rel k1 k2 =
    let (n,f) := unsquash k1 in
    let (n',f') := unsquash k2 in
    n = n' /\ Rel predicate f f'.

  Axiom knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

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

*)


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Print eq.

Inductive eqs (A : Set) (x : A) : forall a:A, Set :=  eq_refls : eqs A x x.

Definition eqsRMatch
(A A₂ : Set) (A_R : A -> A₂ -> Set) (x : A) (x₂ : A₂)
                 (x_R : A_R x x₂) (a1 : A) (a2 : A₂) (ar : A_R a1 a2)
                 (eqs1 : eqs A x a1) (eqs2 : eqs A₂ x₂ a2) : Set :=

   let reT a1 a2 := forall (ar : A_R a1 a2), Set in
   (match eqs1 in eqs _ _ a1 return reT a1 a2 with
   | eq_refls _ _ => match eqs2 with
                     | eq_refls _ _ => fun ar => x_R = ar
                     end
   end) ar.

Definition eqs_recs :=
fun (A : Set) (x : A) (P : forall a:A, Set) (f : P x) (y : A) (e : eqs A x y) =>
match e as esss in (eqs _ _ yy)  return (P yy) with
| eq_refls _ _ => f
end.

Arguments sigT : clear implicits.

Check eqs.

Definition eqrecs_RR :
forall (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (x₁ : A₁) (x₂ : A₂)
         (x_R : A_R x₁ x₂) (P₁ : A₁ -> Set) (P₂ : A₂ -> Set)
         (P_R : forall (a₁ : A₁) (a₂ : A₂), A_R a₁ a₂ -> P₁ a₁ -> P₂ a₂ -> Set)
         (f₁ : P₁ x₁) (f₂ : P₂ x₂),
       P_R x₁ x₂ x_R f₁ f₂ ->
       forall (y₁ : A₁) (y₂ : A₂) (y_R : A_R y₁ y₂) (e₁ : eqs A₁ x₁ y₁) (e₂ : eqs A₂ x₂ y₂),
       eqsRMatch A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂ ->
       P_R y₁ y₂ y_R (eqs_recs A₁ x₁ P₁ f₁ y₁ e₁) (eqs_recs A₂ x₂ P₂ f₂ y₂ e₂).
Proof.
intros.
unfold eqs_recs.
rename H0 into eqsr.
revert eqsr.
revert e₂.
destruct e₁.
simpl.
intro.
destruct e₂.
intros Heq. subst. assumption.
Qed.

(*
Parametricity Recursive eqs_recs.
Print eqs_R.
*)

Inductive eqsRInd (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Set) (x₁ : A₁) (x₂ : A₂)
(x_R : A_R x₁ x₂)
  : forall (a₁ : A₁) (a₂ : A₂), A_R a₁ a₂ -> eqs A₁ x₁ a₁ -> eqs A₂ x₂ a₂ -> Set :=
eq_refls_Rind : eqsRInd A₁ A₂ A_R x₁ x₂ x_R x₁ x₂ x_R (eq_refls A₁ x₁) (eq_refls A₂ x₂).

Locate UIP_on.
Require Import Coq.Logic.EqdepFacts.

Section usp.
Require Import ReflParam.common.
Require Import ReflParam.Contractible.
Context (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Set) (x₁ : A₁) (x₂ : A₂) (x_R : A_R x₁ x₂)
  (peq : UIP_ (A_R x₁ x₂)).

Lemma cc_rr: forall
  y₁ y₂ y_R (e₁ : eqs A₁ x₁ y₁) (e₂ : eqs A₂ x₂ y₂),
       Contractible (eqsRMatch A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂).
Proof using peq.
  intros ? ? ? ?.
  induction e₁.
  destruct e₂.
  simpl.
  intros ? ?. apply peq.
Qed.

Require Import Coq.Logic.JMeq.
Require Import Coq.Program.Equality.

Lemma cc_r: forall
  y₁ y₂ y_R (e₁ : eqs A₁ x₁ y₁) (e₂ : eqs A₂ x₂ y₂),
       Contractible (eqsRInd A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂).
Proof using peq.
  intros ? ? ? ? ? ?.
  induction a.
  intros b.
  dependent destruction b.
  reflexivity.
Qed.

End usp.

Section tofrom.
Context {A₁ A₂ : Set} {A_R : A₁ -> A₂ -> Set} {x₁ : A₁} {x₂ : A₂} {x_R : A_R x₁ x₂}
  {y₁: A₁} {y₂: A₂} {y_R : A_R y₁ y₂}
  {e₁ : eqs A₁ x₁ y₁} {e₂ : eqs A₂ x₂ y₂}.

Definition fromRMatch (p: eqsRMatch A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂):
  eqsRInd A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂.
Proof using.
  induction e₁.
  destruct e₂.
  simpl in p. subst.
  constructor.
Defined.

Definition toRMatch (p: eqsRInd A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂):
  eqsRMatch A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂.
Proof using.
  induction p. simpl. reflexivity.
Defined.

End tofrom.

Section iso.
Context {A₁ A₂ : Set} {A_R : A₁ -> A₂ -> Set} {x₁ : A₁} {x₂ : A₂} (x_R : A_R x₁ x₂).

Lemma toFromMatch_id : forall {y₁: A₁} {y₂: A₂} {y_R : A_R y₁ y₂}
  {e₁ : eqs A₁ x₁ y₁} {e₂ : eqs A₂ x₂ y₂}
   (p: eqsRMatch A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂),
  toRMatch (fromRMatch p) = p.
Proof using.
  intros.
  induction e₁.
  destruct e₂.
  simpl in p. subst.
  reflexivity.
Qed.

Lemma fromToMatch_id : forall {y₁: A₁} {y₂: A₂} {y_R : A_R y₁ y₂}
  {e₁ : eqs A₁ x₁ y₁} {e₂ : eqs A₂ x₂ y₂}
   (p: eqsRInd A₁ A₂ A_R x₁ x₂ x_R y₁ y₂ y_R e₁ e₂),
  fromRMatch (toRMatch p) = p.
Proof using.
  intros.
  induction p.
  simpl.
  compute.
  reflexivity.
Qed.


(***************************************************************************
* Safety for STLC with Datatypes - Proofs                                  *
* Extented from "Type Safety for STLC" by                                  *
* Arthur Charguéraud, July 2007, Coq v8.1                                  *
***************************************************************************)

Set Implicit Arguments.
Require Import List Metatheory
  STLC_Data_Definitions
  STLC_Data_Infrastructure.

(* ********************************************************************** *)
(** * Proofs *)

(** Typing is preserved by weakening. *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. gen_eq (E & G) as H. gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs. intros y Fr.
   do_rew* concat_assoc (apply* H0).
  apply_fresh* typing_fix. intros y f Fr2.
   do_rew_2* concat_assoc (apply* H0).
  apply_fresh* (@typing_match T Us). intros xs Fr.
    do_rew* concat_assoc (apply* H1).
  auto*.
  auto*.
  auto*.
  auto*.
  auto*.
Qed.

(** Typing is preserved by substitution. *)

Lemma typing_subst : forall F U E t T z u,
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Typt Typu. gen_eq (E & z ~ U & F) as G. gen F.
  induction Typt; introv Equ; subst; simpl subst.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs. intros y Fr.
   rewrite* subst_open_vars.
   do_rew concat_assoc (apply* H0).
  apply_fresh typing_fix. intros y f Fr.
   rewrite* subst_open_vars.
   do_rew_2 concat_assoc (apply* H0).
  apply_fresh* (@typing_match T Us). intros xs Fr.
   rewrite* subst_open_vars.
   do_rew* concat_assoc (apply* H1).
  auto*.
  auto*.
  auto*.
  auto*.
  auto*.
Qed.

(** Typing is preserved by iterated substitution. *)

Lemma typing_substs : forall Us E xs ts t T,
   length xs = length ts ->
   typings E ts Us ->
   E & (iter_push xs Us) |= t ~: T ->
   E |= substs xs ts t ~: T.
Proof.
  intros Us E xs. gen Us E.
  induction xs; simpl; introv Le Typts Typt. auto.
  destruct ts; simpls; inversions Le. inversions Typts.
  rewrite iter_push_cons in Typt.
  rewrite <- concat_assoc in Typt.
  apply* (@IHxs Us0).
  apply* typing_subst.
Qed.

(** Typing the result of pattern matching. *)

Lemma typing_pattern_match : forall p t T E ts Us,
  Some ts = pat_match p t ->
  E |= t ~: T ->
  Us \= p ~: T ->
  typings E ts Us.
Proof.
  induction p; introv EQ Typt Typp; destruct t;
   inversion Typp; inversion EQ; auto; subst; inversions Typt; auto*.
  remember (pat_match p1 t1) as K1.
   remember (pat_match p2 t2) as K2.
   destruct K1 as [ts1|]; destruct K2 as [ts2|]; try discriminate.
   inversions H6. apply* typings_concat.
Qed.

(** Preservation (typing is preserved by reduction). *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen t'.
  induction Typ; introv Red; inversions Red.
  pick_freshes (pat_arity p) xs.
   forward~ (@pat_match_terms p t1 ts) as K.
   rewrite (fresh_length _ _ _ Fr) in K.
   rewrite* (@substs_intro xs).
   apply~ (@typing_substs Us). unfolds terms. auto.
   apply~ (@typing_pattern_match p t1 T).
  auto*.
  auto*.
  inversions Typ1. pick_fresh x.
    rewrite* (@substs_intro (x::nil)). unfolds substs.
    apply_empty* typing_subst.
  inversions Typ1. pick_fresh f. pick_fresh x.
    rewrite* (@substs_intro (x::f::nil)). unfolds substs.
    apply_empty* typing_subst.
    apply_empty* typing_subst.
    apply_empty* typing_weaken.
  auto*.
  auto*.
  auto*.
  auto*.
  auto*.
  auto*.
Qed.

(** Progress (a well-typed term is either a value or it can
  take a step of reduction). *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq (empty : env) as E. poses Typ' Typ.
  induction Typ; intros; subst.
  contradictions.
  left*.
  left*.
  right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    remember (pat_match p t1) as r. symmetry in Heqr. destruct r as [ts|].
      exists* (e ^^ ts).
      exists* t2.
    exists* (trm_match t1' p e t2).
  right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      inversions Typ1; inversions Val1.
        exists* (t0 ^^ (t2::nil)).
        exists* (t0 ^^ (t2::(trm_fix t0)::nil)).
      exists* (trm_app t1 t2').
    exists* (trm_app t1' t2).
  left*.
  destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
     right. exists* (trm_pair t1 t2').
     right. exists* (trm_pair t1' t2).
  destruct~ IHTyp as [Val1 | [t1' Red1]].
    right. exists* (trm_inj1 t1').
  destruct~ IHTyp as [Val1 | [t1' Red1]].
    right. exists* (trm_inj2 t1').
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export angles_droites.
Require Export metrique_triangle.
Set Implicit Arguments.
Unset Strict Implicit.

Definition mediatrice (A B M : PO) := distance M A = distance M B :>R.

Lemma mediatrice_permute :
 forall A B M : PO, mediatrice A B M -> mediatrice B A M.
unfold mediatrice in |- *; intros.
rewrite H; auto.
Qed.
#[export] Hint Immediate mediatrice_permute: geo.

Lemma milieu_mediatrice :
 forall A B M : PO, M = milieu A B :>PO -> mediatrice A B M.
red in |- *; intros.
cut (vec A M = vec M B); intros; auto with geo.
Qed.

Lemma alignes_mediatrice_milieu :
 forall A B M : PO,
 A <> B -> alignes A B M -> mediatrice A B M -> M = milieu A B :>PO.
unfold mediatrice in |- *; intros.
halignes H0 k.
cut (k = / 2); intros.
rewrite H3 in H2.
apply vecteur_milieu; auto.
cut (vec M B = mult_PP (1 + - k) (vec A B)); intros.
cut (scalaire (vec A M) (vec A M) = scalaire (vec M B) (vec M B)); intros.
rewrite H2 in H4.
rewrite H3 in H4.
cut (k * k = (1 + - k) * (1 + - k)); intros; auto with real.
apply
 resolution2
  with
    (x := scalaire (vec A B) (vec A B))
    (y := scalaire (vec A B) (vec A B)); auto with geo.
replace (scalaire (vec A B) (vec A B) * (k * k)) with
 (scalaire (mult_PP k (vec A B)) (mult_PP k (vec A B))).
rewrite H4.
Simplscal.
ring_simplify.
Simplscal.
replace (scalaire (vec A M) (vec A M)) with (scalaire (vec M A) (vec M A)).
repeat rewrite carre_scalaire_distance; rewrite H1; auto.
replace (vec M A) with (mult_PP (-1) (vec A M)).
Simplscal.
Ringvec.
replace (vec M B) with (add_PP (vec A B) (mult_PP (-1) (vec A M))).
rewrite H2.
Ringvec.
Ringvec.
Qed.

Lemma mediatrice_projete_orthogonal :
 forall A B M H : PO,
 A <> B :>PO ->
 H = projete_orthogonal A B M :>PO ->
 mediatrice A B M -> distance H A = distance H B :>R.
unfold mediatrice in |- *; intros.
generalize (Pythagore_projete_orthogonal (A:=A) (B:=B) (C:=M) (H:=H)); intros.
elim H3; [ try clear H3; intros | auto | auto ].
apply distance_carre.
replace (Rsqr (distance H A)) with
 (Rsqr (distance A M) + - Rsqr (distance H M)).
replace (Rsqr (distance H M)) with
 (Rsqr (distance B M) + - Rsqr (distance H B)).
rewrite (distance_sym A M); auto.
rewrite (distance_sym B M); auto.
rewrite H2; ring.
rewrite H4; ring.
rewrite H3; ring.
Qed.

Lemma mediatrice_projete_milieu :
 forall A B M H : PO,
 A <> B :>PO ->
 H = projete_orthogonal A B M :>PO -> mediatrice A B M -> H = milieu A B :>PO.
intros.
generalize (def_projete_orthogonal2 (A:=A) (B:=B) (C:=M) (H:=H)); intros.
elim H3; [ intros; clear H3 | auto | auto ].
apply alignes_mediatrice_milieu; auto.
red in |- *.
apply mediatrice_projete_orthogonal with M; auto.
Qed.

Lemma mediatrice_orthogonale_segment_milieu :
 forall A B M N : PO,
 A <> B :>PO ->
 M <> N :>PO ->
 M = milieu A B :>PO -> mediatrice A B N -> orthogonal (vec A B) (vec M N).
intros A B M N H3 H0 H1 H2; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := N);
 [ intros H H4; try clear existence_projete_orthogonal; auto | auto ].
generalize (mediatrice_projete_milieu (A:=A) (B:=B) (M:=N) (H:=H)); intros H7.
rewrite H1; rewrite <- H7; auto.
generalize (def_projete_orthogonal2 (A:=A) (B:=B) (C:=N) (H:=H)); intros.
elim H5; [ intros; auto | auto | auto ].
Qed.

Lemma mediatrice_orthogonale_segment :
 forall A B M N : PO,
 A <> B :>PO ->
 mediatrice A B M -> mediatrice A B N -> orthogonal (vec M N) (vec A B).
intros.
discrimine M N.
VReplace (vec N N) zero.
auto with geo.
elim (classic (milieu A B = M)); intros.
rewrite <- H3; rewrite <- H3 in H0.
apply ortho_sym.
apply mediatrice_orthogonale_segment_milieu; auto.
rewrite H3; auto.
elim (classic (milieu A B = N)); intros.
rewrite <- H4; rewrite <- H4 in H2.
replace (vec M (milieu A B)) with
 (add_PP (mult_PP 0 (vec (milieu A B) M)) (mult_PP (-1) (vec (milieu A B) M))).
apply ortho_combinaison_lineaire; auto.
apply ortho_sym; apply mediatrice_orthogonale_segment_milieu; auto.
apply ortho_sym; apply mediatrice_orthogonale_segment_milieu; auto.
Ringvec.
cut (orthogonal (vec (milieu A B) N) (vec A B)); intros.
cut (orthogonal (vec (milieu A B) M) (vec A B)); intros.
replace (vec M N) with
 (add_PP (mult_PP 1 (vec (milieu A B) N)) (mult_PP (-1) (vec (milieu A B) M))).
apply ortho_combinaison_lineaire; auto with geo.
Ringvec.
apply ortho_sym; apply mediatrice_orthogonale_segment_milieu; auto with geo.
apply ortho_sym; apply mediatrice_orthogonale_segment_milieu; auto with geo.
Qed.

Lemma orthogonale_segment_milieu_mediatrice :
 forall A B M N : PO,
 A <> B :>PO ->
 M = milieu A B :>PO -> orthogonal (vec A B) (vec M N) -> mediatrice A B N.
unfold mediatrice in |- *; intros.
apply carre_egalite_distance.
repeat rewrite <- carre_scalaire_distance.
generalize (rectangle_Pythagore M N A); unfold iff in |- *; intros.
generalize (rectangle_Pythagore M N B); unfold iff in |- *; intros.
elim H2; [ intros H4 H7; try clear H2 ].
elim H3; [ intros H5 H6; try clear H3 ].
cut (orthogonal (vec M N) (vec M A)); intros.
rewrite H4; auto.
rewrite H5.
replace (scalaire (vec M A) (vec M A)) with (scalaire (vec A M) (vec A M)).
rewrite (milieu_vecteur H0); auto.
replace (vec M A) with (mult_PP (-1) (vec A M)).
Simplscal.
Ringvec.
rewrite <- (milieu_vecteur H0); auto.
auto with geo.
apply ortho_sym.
replace (vec M A) with (mult_PP (- / 2) (vec A B)).
auto with geo.
replace (vec M A) with (mult_PP (-1) (mult_PP (/ 2) (vec A B))).
cut (2 <> 0); intros; auto with real.
Fieldvec 2.
rewrite <- (milieu_vecteur2 H0); auto.
Ringvec.
Qed.

Lemma mediatrice_distinct_extremite :
 forall A B M : PO, A <> B -> mediatrice A B M -> M <> A /\ M <> B.
unfold mediatrice in |- *; intros.
cut (~ (M = A \/ M = B)); intros.
intuition.
unfold not in |- *; intros; apply H.
elim H1;
 [ intros H2; try clear H1; rewrite <- H2; rewrite <- H2 in H0
 | intros H2; try clear H1; rewrite <- H2; rewrite <- H2 in H0 ].
apply distance_nulle; auto.
rewrite carre_scalaire_distance; rewrite <- H0;
 rewrite <- carre_scalaire_distance.
replace (vec M M) with (mult_PP 0 (vec A B)).
Simplscal.
Ringvec.
apply distance_nulle.
replace (vec A M) with (mult_PP (-1) (vec M A)).
Simplscal.
rewrite carre_scalaire_distance; rewrite H0;
 rewrite <- carre_scalaire_distance.
replace (vec M M) with (mult_PP 0 (vec A B)).
Simplscal.
Ringvec.
Ringvec.
Qed.

Lemma existence_mediatrice :
 forall A B : PO,
 A <> B :>PO -> ex (fun J : PO => milieu A B <> J :>PO /\ mediatrice A B J).
intros.
soit_milieu A B M.
soit_orthogonal M A J.
exists J.
split; [ try assumption | idtac ].
apply orthogonale_segment_milieu_mediatrice with M; auto.
apply orthogonal_milieu with M; auto.
Qed.
Comments " " "soit_mediatrice" "pose" "IJ" "mediatrice" "de" "[AB]" "avec"
  "I" "milieu" "de" "AB" "et" "echoue" "si" "A=B" "et" "ajoute" "des"
  "hypotheses".

Ltac soit_mediatrice A B I J :=
  soit_milieu A B I;
   match goal with
   | h:(I = milieu A B) |- _ =>
       elim (existence_mediatrice (A:=A) (B:=B));
        [ intros J; intros HME; rewrite <- h in HME; elim HME; clear HME;
           intros; generalize h; intros; clear h;
           lapply (mediatrice_distinct_extremite (A:=A) (B:=B) (M:=J));
           try assumption; intros toto; elim toto;
           try assumption; clear toto; intros
        | auto ]
   end.

Lemma mediatrice_milieu_angles :
 forall A B M N : PO,
 A <> B ->
 M <> N ->
 M = milieu A B ->
 mediatrice A B N ->
 cons_AV (vec N A) (vec N M) = cons_AV (vec N M) (vec N B) :>AV.
intros.
elim mediatrice_distinct_extremite with (A := A) (B := B) (M := N);
 (auto; intros).
cut (M <> A); intros.
cut (M <> B); intros.
elim
 cas_egalite_triangle_indirect
  with (A := M) (B := N) (C := A) (A' := M) (B' := N) (C' := B);
 (auto with geo; intros).
elim H8; intros H9 H10; try clear H8; try exact H9.
symmetry  in |- *.
generalize (milieu_angles_orthogonaux (A:=A) (B:=B) (M:=M) (N:=N)); intros.
mesure M A M N.
rewrite <- (mes_oppx (A:=M) (B:=A) (C:=M) (D:=N) (x:=x)); auto.
rewrite <- (mes_oppx (A:=M) (B:=N) (C:=M) (D:=B) (x:=x)); auto.
rewrite H8; rewrite H7; auto.
apply mediatrice_orthogonale_segment_milieu; auto.
lapply (milieu_distinct2 (A:=A) (B:=B)); auto; intros.
rewrite H1; auto.
lapply (milieu_distinct (A:=A) (B:=B)); auto; intros.
rewrite H1; auto.
Qed.
Require Export Droite_espace.

Lemma mediatrices_triangle_concours :
 forall A B C I J K L : PO,
 triangle A B C ->
 I = milieu A B :>PO ->
 J = milieu B C :>PO ->
 I <> K :>PO ->
 J <> L :>PO ->
 mediatrice A B K -> mediatrice B C L -> concours (droite I K) (droite J L).
intros.
deroule_triangle A B C.
lapply (position_relative_droites_coplanaires (A:=I) (B:=K) (C:=J) (D:=L));
 auto with geo; intros.
elim H10; auto with geo; intros.
absurd (paralleles (droite J L) (droite I K)); auto with geo.
cut
 (double_AV (cons_AV (vec I K) (vec J L)) =
  double_AV (cons_AV (vec B A) (vec B C))); intros.
apply angle_non_paralleles; auto.
rewrite H12.
red in |- *; intros.
apply H6; auto with geo.
apply angles_droites_orthogonales; auto.
cut (orthogonal (vec I K) (vec A B)); intros; auto with geo.
apply mediatrice_orthogonale_segment; auto.
apply milieu_mediatrice; auto.
apply ortho_sym; auto.
apply mediatrice_orthogonale_segment; auto.
apply milieu_mediatrice; auto.
Qed.

Lemma mediatrice_droite :
 forall A B I J K : PO,
 A <> B :>PO ->
 I = milieu A B :>PO -> mediatrice A B J -> mediatrice A B K -> alignes I J K.
intros.
discrimine I J.
discrimine J K.
discrimine I K.
lapply (milieu_mediatrice (A:=A) (B:=B) (M:=I)); auto; intros.
lapply (mediatrice_orthogonale_segment (A:=A) (B:=B) (M:=I) (N:=J)); auto;
 intros.
lapply (mediatrice_orthogonale_segment (A:=A) (B:=B) (M:=I) (N:=K)); auto;
 intros.
elim (orthogonal_paralleles (A:=I) (B:=B) (C:=J) (E:=I) (F:=K)); auto; intros.
apply colineaire_alignes with x; auto.
lapply (milieu_distinct2 (A:=A) (B:=B)); auto.
rewrite <- H0; auto.
lapply (orthogonal_segment_milieu (A:=A) (B:=B) (C:=I) (D:=J) (I:=I)); auto;
 intros.
elim H9; auto with geo; intros.
apply ortho_sym.
lapply (orthogonal_segment_milieu (A:=A) (B:=B) (C:=I) (D:=K) (I:=I)); auto;
 intros.
elim H9; auto with geo; intros.
Qed.


Require Import Coq.Program.Program.

Set Implicit Arguments.

Notation idmap := (fun x => x).

Class MonadOps (M : Type -> Type)
  := { bind : forall {A B}, M A -> (A -> M B) -> M B;
       ret : forall {A}, A -> M A }.

Global Arguments bind {M _ A B} _ _.
Global Arguments ret {M _ A} _.

Notation "x <- y ; f" := (bind y (fun x => f)) (at level 65, right associativity).

Class MonadLaws M `{MonadOps M}
  := { bind_bind : forall {A B C} (f : A -> M B) (g : B -> M C) x,
                     bind (bind x f) g = bind x (fun u => bind (f u) g);
       bind_unit : forall {A B} (f : A -> M B) x, bind (ret x) f = f x;
       unit_bind : forall {A} (x : M A), bind x ret = x;
       bind_ext : forall {A B} {f g : A -> M B},
                    (forall x, f x = g x)
                    -> forall x, bind x f = bind x g }.

Arguments MonadLaws M {_}.

Class MonadTransformerOps (T : (Type -> Type) -> (Type -> Type))
  := { Tops :> forall M `{MonadOps M}, MonadOps (T M);
       lift : forall {M} `{MonadOps M} {A}, M A -> T M A }.

Class MonadTransformerLaws T `{MonadTransformerOps T}
  := { Tlaws :> forall {M} `{MonadLaws M}, MonadLaws (T M);
       lift_ret : forall {M} `{MonadLaws M} {A} (x : A), lift (ret x) = ret x;
       lift_bind : forall {M} `{MonadLaws M} {A B} (f : A -> M B) x,
                     lift (bind x f) = bind (lift x) (fun u => lift (f u)) }.
Arguments MonadTransformerLaws T {_}.

Create HintDb monad discriminated.
Create HintDb monad' discriminated.
Hint Rewrite @bind_bind @bind_unit @unit_bind @lift_ret @lift_bind : monad.
Hint Rewrite @bind_unit @unit_bind @lift_ret @lift_bind : monad'.
Hint Rewrite <- @bind_bind : monad'.

Instance idM : MonadOps idmap
  := { bind A B x f := f x;
       ret A x := x }.
Instance idML : MonadLaws idmap.
Proof.
  constructor; trivial.
Defined.

Instance idT : MonadTransformerOps idmap
  := { Tops M H := H;
       lift M H A x := x }.
Instance idTL : MonadTransformerLaws idmap.
Proof.
  constructor; trivial.
Defined.

Instance monad_of_transformer T `{MonadTransformerOps T}
: MonadOps (T idmap) | 1000
  := _.
Coercion monad_of_transformer : MonadTransformerOps >-> MonadOps.

Instance monad_laws_of_transformer T `{MonadTransformerLaws T}
: MonadLaws (T idmap)
  := _.
Coercion monad_laws_of_transformer : MonadTransformerLaws >-> MonadLaws.

Instance optionT : MonadTransformerOps (fun M => M ∘ option) | 2
  := { Tops M H := {| ret A x := ret (Some x);
                      bind A B x f := _ |};
       lift M H A x := bind x (fun a => ret (Some a)) }.
Proof.
  { exact (bind x (fun a => match a with
                              | None => ret None
                              | Some a' => f a'
                            end)). }
Defined.

Local Ltac t_option :=
  repeat match goal with
           | _ => intro
           | _ => reflexivity
           | _ => assumption
           | _ => solve [ trivial ]
           | [ H : option _ |- _ ] => destruct H
           | [ |- appcontext[match ?a with None => _ end] ] => case_eq a
           | [ |- @bind ?M ?H ?A ?B ?x _ = bind ?x _ ] => let lem := constr:(@bind_ext M H _ A B) in apply lem
           | [ |- @bind ?M ?H ?A ?B ?x _ = ?x ] => etransitivity; [ | solve [ apply (@unit_bind M H _) ] ]
           | _ => progress autorewrite with monad; try assumption; []
         end.

Instance optionTLaws : MonadTransformerLaws (fun M => M ∘ option) | 2
  := { Tlaws M H L := _ }.
Proof.
  { constructor; simpl; t_option. }
  { simpl; t_option. }
  { simpl; t_option. }
Defined.

Instance optionM : MonadOps option | 2 := optionT.
Instance optionLaws : MonadLaws option | 2 := optionTLaws.

Definition liftA {T} `{MonadTransformerOps T} {M} `{MonadOps M} {A B}
           (f : M A -> M B)
: T M A -> T M B
  := fun x => y <- x; lift (f (ret y)).