From stdpp Require Import coPset namespaces.
From iris.bi Require Export bi updates.
From iris.bi.lib Require Import fixpoint.
From iris.proofmode Require Import coq_tactics proofmode reduction.
From iris.prelude Require Import options.

(** Conveniently split a conjunction on both assumption and conclusion. *)
Local Tactic Notation "iSplitWith" constr(H) :=
  iApply (bi.and_parallel with H); iSplit; iIntros H.

Section definition.
  Context {PROP : bi} `{!BiFUpd PROP} {TA TB : tele}.
  Implicit Types
    (Eo Ei : coPset) (* outer/inner masks *)
    (α : TA → PROP) (* atomic pre-condition *)
    (P : PROP) (* abortion condition *)
    (β : TA → TB → PROP) (* atomic post-condition *)
    (Φ : TA → TB → PROP) (* post-condition *)
  .

  (** atomic_acc as the "introduction form" of atomic updates: An accessor
      that can be aborted back to [P]. *)
  Definition atomic_acc Eo Ei α P β Φ : PROP :=
    |={Eo, Ei}=> ∃.. x, α x ∗
          ((α x ={Ei, Eo}=∗ P) ∧ (∀.. y, β x y ={Ei, Eo}=∗ Φ x y)).

  Lemma atomic_acc_wand Eo Ei α P1 P2 β Φ1 Φ2 :
    ((P1 -∗ P2) ∧ (∀.. x y, Φ1 x y -∗ Φ2 x y)) -∗
    (atomic_acc Eo Ei α P1 β Φ1 -∗ atomic_acc Eo Ei α P2 β Φ2).
  Proof.
    iIntros "HP12 AS". iMod "AS" as (x) "[Hα Hclose]".
    iModIntro. iExists x. iFrame "Hα". iSplit.
    - iIntros "Hα". iDestruct "Hclose" as "[Hclose _]".
      iApply "HP12". iApply "Hclose". done.
    - iIntros (y) "Hβ". iDestruct "Hclose" as "[_ Hclose]".
      iApply "HP12". iApply "Hclose". done.
  Qed.

  Lemma atomic_acc_mask Eo Ed α P β Φ :
    atomic_acc Eo (Eo∖Ed) α P β Φ ⊣⊢ ∀ E, ⌜Eo ⊆ E⌝ → atomic_acc E (E∖Ed) α P β Φ.
  Proof.
    iSplit; last first.
    { iIntros "Hstep". iApply ("Hstep" with "[% //]"). }
    iIntros "Hstep" (E HE).
    iApply (fupd_mask_frame_acc with "Hstep"); first done.
    iIntros "Hstep". iDestruct "Hstep" as (x) "[Hα Hclose]".
    iIntros "!> Hclose'".
    iExists x. iFrame. iSplitWith "Hclose".
    - iIntros "Hα". iApply "Hclose'". iApply "Hclose". done.
    - iIntros (y) "Hβ". iApply "Hclose'". iApply "Hclose". done.
  Qed.

  Lemma atomic_acc_mask_weaken Eo1 Eo2 Ei α P β Φ :
    Eo1 ⊆ Eo2 →
    atomic_acc Eo1 Ei α P β Φ -∗ atomic_acc Eo2 Ei α P β Φ.
  Proof.
    iIntros (HE) "Hstep".
    iMod (fupd_mask_subseteq Eo1) as "Hclose1"; first done.
    iMod "Hstep" as (x) "[Hα Hclose2]". iIntros "!>". iExists x.
    iFrame. iSplitWith "Hclose2".
    - iIntros "Hα". iMod ("Hclose2" with "Hα") as "$". done.
    - iIntros (y) "Hβ". iMod ("Hclose2" with "Hβ") as "$". done.
  Qed.

  (** atomic_update as a fixed-point of the equation
   AU = atomic_acc α AU β Q
  *)
  Context Eo Ei α β Φ.

  Definition atomic_update_pre (Ψ : () → PROP) (_ : ()) : PROP :=
    atomic_acc Eo Ei α (Ψ ()) β Φ.

  Local Instance atomic_update_pre_mono : BiMonoPred atomic_update_pre.
  Proof.
    constructor.
    - iIntros (P1 P2 ??) "#HP12". iIntros ([]) "AU".
      iApply (atomic_acc_wand with "[HP12] AU").
      iSplit; last by eauto. iApply "HP12".
    - intros ??. solve_proper.
  Qed.

  Local Definition atomic_update_def :=
    bi_greatest_fixpoint atomic_update_pre ().

End definition.

(** Seal it *)
Local Definition atomic_update_aux : seal (@atomic_update_def).
Proof. by eexists. Qed.
Definition atomic_update := atomic_update_aux.(unseal).
Global Arguments atomic_update {PROP _ TA TB}.
Local Definition atomic_update_unseal :
  @atomic_update = _ := atomic_update_aux.(seal_eq).

Global Arguments atomic_acc {PROP _ TA TB} Eo Ei _ _ _ _ : simpl never.
Global Arguments atomic_update {PROP _ TA TB} Eo Ei _ _ _ : simpl never.

(** Notation: Atomic updates *)
(* The way to read the [tele_app foo] here is that they convert the n-ary
function [foo] into a unary function taking a telescope as the argument. *)
Notation "'AU' '<<' ∃∃ x1 .. xn , α '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
                 (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                 Eo Ei
                 (tele_app $ λ x1, .. (λ xn, α%I) ..)
                 (tele_app $ λ x1, .. (λ xn,
                         tele_app (λ y1, .. (λ yn, β%I) .. )
                        ) .. )
                 (tele_app $ λ x1, .. (λ xn,
                         tele_app (λ y1, .. (λ yn, Φ%I) .. )
                        ) .. )
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder,
   format "'[hv   ' 'AU'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AU' '<<' ∃∃ x1 .. xn , α '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
                 (TB:=TeleO)
                 Eo Ei
                 (tele_app $ λ x1, .. (λ xn, α%I) ..)
                 (tele_app $ λ x1, .. (λ xn, tele_app β%I) .. )
                 (tele_app $ λ x1, .. (λ xn, tele_app Φ%I) .. )
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200, x1 binder, xn binder,
   format "'[hv   ' 'AU'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AU' '<<' α '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleO)
                 (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                 Eo Ei
                 (tele_app α%I)
                 (tele_app $ tele_app (λ y1, .. (λ yn, β%I) ..))
                 (tele_app $ tele_app (λ y1, .. (λ yn, Φ%I) ..))
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200, y1 binder, yn binder,
   format "'[hv   ' 'AU'  '<<'  '[' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AU' '<<' α '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic_update (TA:=TeleO) (TB:=TeleO)
                 Eo Ei
                 (tele_app α%I)
                 (tele_app $ tele_app β%I)
                 (tele_app $ tele_app Φ%I)
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200,
   format "'[hv   ' 'AU'  '<<'  '[' α  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

(** Notation: Atomic accessors *)
Notation "'AACC' '<<' ∃∃ x1 .. xn , α , 'ABORT' P '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
              (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
              Eo Ei
              (tele_app $ λ x1, .. (λ xn, α%I) ..)
              P%I
              (tele_app $ λ x1, .. (λ xn,
                      tele_app (λ y1, .. (λ yn, β%I) .. )
                     ) .. )
              (tele_app $ λ x1, .. (λ xn,
                      tele_app (λ y1, .. (λ yn, Φ%I) .. )
                     ) .. )
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder,
   format "'[hv     ' 'AACC'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AACC' '<<' ∃∃ x1 .. xn , α , 'ABORT' P '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
              (TB:=TeleO)
              Eo Ei
              (tele_app $ λ x1, .. (λ xn, α%I) ..)
              P%I
              (tele_app $ λ x1, .. (λ xn, tele_app β%I) .. )
              (tele_app $ λ x1, .. (λ xn, tele_app Φ%I) .. )
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200, x1 binder, xn binder,
   format "'[hv     ' 'AACC'  '<<'  '[' ∃∃  x1  ..  xn ,  '/' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AACC' '<<' α , 'ABORT' P '>>' @ Eo , Ei '<<' ∀∀ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleO)
              (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
              Eo Ei
              (tele_app α%I)
              P%I
              (tele_app $ tele_app (λ y1, .. (λ yn, β%I) ..))
              (tele_app $ tele_app (λ y1, .. (λ yn, Φ%I) ..))
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200, y1 binder, yn binder,
   format "'[hv     ' 'AACC'  '<<'  '[' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' ∀∀  y1  ..  yn ,  '/' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

Notation "'AACC' '<<' α , 'ABORT' P '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic_acc (TA:=TeleO)
              (TB:=TeleO)
              Eo Ei
              (tele_app α%I)
              P%I
              (tele_app $ tele_app β%I)
              (tele_app $ tele_app Φ%I)
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200,
   format "'[hv     ' 'AACC'  '<<'  '[' α ,  '/' ABORT  P  ']' '>>'  '/' @  '[' Eo ,  '/' Ei ']'  '/' '<<'  '[' β ,  '/' COMM  Φ  ']' '>>' ']'") : bi_scope.

(** Lemmas about AU *)
Section lemmas.
  Context `{BiFUpd PROP} {TA TB : tele}.
  Implicit Types (α : TA → PROP) (β Φ : TA → TB → PROP) (P : PROP).

  Local Existing Instance atomic_update_pre_mono.

  (* Can't be in the section above as that fixes the parameters *)
  Global Instance atomic_acc_ne Eo Ei n :
    Proper (
        pointwise_relation TA (dist n) ==>
        dist n ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        dist n
    ) (atomic_acc (PROP:=PROP) Eo Ei).
  Proof. solve_proper. Qed.

  Global Instance atomic_update_ne Eo Ei n :
    Proper (
        pointwise_relation TA (dist n) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        dist n
    ) (atomic_update (PROP:=PROP) Eo Ei).
  Proof.
    rewrite atomic_update_unseal /atomic_update_def /atomic_update_pre. solve_proper.
  Qed.

  Lemma atomic_update_mask_weaken Eo1 Eo2 Ei α β Φ :
    Eo1 ⊆ Eo2 →
    atomic_update Eo1 Ei α β Φ -∗ atomic_update Eo2 Ei α β Φ.
  Proof.
    rewrite atomic_update_unseal {2}/atomic_update_def /=.
    iIntros (Heo) "HAU".
    iApply (greatest_fixpoint_coiter _ (λ _, atomic_update_def Eo1 Ei α β Φ)); last done.
    iIntros "!> *". rewrite {1}/atomic_update_def /= greatest_fixpoint_unfold.
    iApply atomic_acc_mask_weaken. done.
  Qed.

  Local Lemma aupd_unfold Eo Ei α β Φ :
    atomic_update Eo Ei α β Φ ⊣⊢
    atomic_acc Eo Ei α (atomic_update Eo Ei α β Φ) β Φ.
  Proof.
    rewrite atomic_update_unseal /atomic_update_def /=. apply: greatest_fixpoint_unfold.
  Qed.

  (** The elimination form: an atomic accessor *)
  Lemma aupd_aacc Eo Ei α β Φ :
    atomic_update Eo Ei α β Φ -∗
    atomic_acc Eo Ei α (atomic_update Eo Ei α β Φ) β Φ.
  Proof using Type*. by rewrite {1}aupd_unfold. Qed.

  (* This lets you eliminate atomic updates with iMod. *)
  Global Instance elim_mod_aupd φ Eo Ei E α β Φ Q Q' :
    (∀ R, ElimModal φ false false (|={E,Ei}=> R) R Q Q') →
    ElimModal (φ ∧ Eo ⊆ E) false false
              (atomic_update Eo Ei α β Φ)
              (∃.. x, α x ∗
                       (α x ={Ei,E}=∗ atomic_update Eo Ei α β Φ) ∧
                       (∀.. y, β x y ={Ei,E}=∗ Φ x y))
              Q Q'.
  Proof.
    intros ?. rewrite /ElimModal /= =>-[??]. iIntros "[AU Hcont]".
    iPoseProof (aupd_aacc with "AU") as "AC".
    iMod (atomic_acc_mask_weaken with "AC"); first done.
    iApply "Hcont". done.
  Qed.

  (** The introduction lemma for atomic_update. This should usually not be used
  directly; use the [iAuIntro] tactic instead. *)
  Local Lemma aupd_intro P Q α β Eo Ei Φ :
    Absorbing P → Persistent P →
    (P ∧ Q -∗ atomic_acc Eo Ei α Q β Φ) →
    P ∧ Q -∗ atomic_update Eo Ei α β Φ.
  Proof.
    rewrite atomic_update_unseal {1}/atomic_update_def /=.
    iIntros (?? HAU) "[#HP HQ]".
    iApply (greatest_fixpoint_coiter _ (λ _, Q)); last done. iIntros "!>" ([]) "HQ".
    iApply HAU. iSplit; by iFrame.
  Qed.

  Lemma aacc_intro Eo Ei α P β Φ :
    Ei ⊆ Eo → ⊢ (∀.. x, α x -∗
    ((α x ={Eo}=∗ P) ∧ (∀.. y, β x y ={Eo}=∗ Φ x y)) -∗
    atomic_acc Eo Ei α P β Φ).
  Proof.
    iIntros (? x) "Hα Hclose".
    iApply fupd_mask_intro; first set_solver. iIntros "Hclose'".
    iExists x. iFrame. iSplitWith "Hclose".
    - iIntros "Hα". iMod "Hclose'" as "_". iApply "Hclose". done.
    - iIntros (y) "Hβ". iMod "Hclose'" as "_". iApply "Hclose". done.
  Qed.

  (* This lets you open invariants etc. when the goal is an atomic accessor. *)
  Global Instance elim_acc_aacc {X} E1 E2 Ei (α' β' : X → PROP) γ' α β Pas Φ :
    ElimAcc (X:=X) True (fupd E1 E2) (fupd E2 E1) α' β' γ'
            (atomic_acc E1 Ei α Pas β Φ)
            (λ x', atomic_acc E2 Ei α (β' x' ∗ (γ' x' -∗? Pas))%I β
                (λ.. x y, β' x' ∗ (γ' x' -∗? Φ x y))
            )%I.
  Proof.
    (* FIXME: Is there any way to prevent maybe_wand from unfolding?
       It gets unfolded by env_cbv in the proofmode, ideally we'd like that
       to happen only if one argument is a constructor. *)
    iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x') "[Hα' Hclose]".
    iMod ("Hinner" with "Hα'") as (x) "[Hα Hclose']".
    iApply fupd_mask_intro; first set_solver. iIntros "Hclose''".
    iExists x. iFrame. iSplitWith "Hclose'".
    - iIntros "Hα". iMod "Hclose''" as "_".
      iMod ("Hclose'" with "Hα") as "[Hβ' HPas]".
      iMod ("Hclose" with "Hβ'") as "Hγ'".
      iModIntro. destruct (γ' x'); iApply "HPas"; done.
    - iIntros (y) "Hβ". iMod "Hclose''" as "_".
      iMod ("Hclose'" with "Hβ") as "Hβ'".
      (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
      rewrite ->!tele_app_bind. iDestruct "Hβ'" as "[Hβ' HΦ]".
      iMod ("Hclose" with "Hβ'") as "Hγ'".
      iModIntro. destruct (γ' x'); iApply "HΦ"; done.
  Qed.

  (* Everything that fancy updates can eliminate without changing, atomic
  accessors can eliminate as well.  This is a forwarding instance needed becuase
  atomic_acc is becoming opaque. *)
  Global Instance elim_modal_acc p q φ P P' Eo Ei α Pas β Φ :
    (∀ Q, ElimModal φ p q P P' (|={Eo,Ei}=> Q) (|={Eo,Ei}=> Q)) →
    ElimModal φ p q P P'
              (atomic_acc Eo Ei α Pas β Φ)
              (atomic_acc Eo Ei α Pas β Φ).
  Proof. intros Helim. apply Helim. Qed.

  (** Lemmas for directly proving one atomic accessor in terms of another (or an
      atomic update).  These are only really useful when the atomic accessor you
      are trying to prove exactly corresponds to an atomic update/accessor you
      have as an assumption -- which is not very common. *)
  Lemma aacc_aacc {TA' TB' : tele} E1 E1' E2 E3
        α P β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_acc E1' E2 α P β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (P ={E1}=∗ P')) β'
            (λ.. x' y', (α x ∗ (P ={E1}=∗ Φ' x' y'))
                    ∨ ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
    atomic_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep".
    iMod (atomic_acc_mask_weaken with "Hupd") as (x) "[Hα Hclose]"; first done.
    iMod ("Hstep" with "Hα") as (x') "[Hα' Hclose']".
    iModIntro. iExists x'. iFrame "Hα'". iSplit.
    - iIntros "Hα'". iDestruct "Hclose'" as "[Hclose' _]".
      iMod ("Hclose'" with "Hα'") as "[Hα Hupd]".
      iDestruct "Hclose" as "[Hclose _]".
      iMod ("Hclose" with "Hα"). iApply "Hupd". auto.
    - iIntros (y') "Hβ'". iDestruct "Hclose'" as "[_ Hclose']".
      iMod ("Hclose'" with "Hβ'") as "Hres".
      (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
      rewrite ->!tele_app_bind. iDestruct "Hres" as "[[Hα HΦ']|Hcont]".
      + (* Abort the step we are eliminating *)
        iDestruct "Hclose" as "[Hclose _]".
        iMod ("Hclose" with "Hα") as "HP".
        iApply "HΦ'". done.
      + (* Complete the step we are eliminating *)
        iDestruct "Hclose" as "[_ Hclose]".
        iDestruct "Hcont" as (y) "[Hβ HΦ']".
        iMod ("Hclose" with "Hβ") as "HΦ".
        iApply "HΦ'". done.
  Qed.

  Lemma aacc_aupd {TA' TB' : tele} E1 E1' E2 E3
        α β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_update E1' E2 α β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ P')) β'
            (λ.. x' y', (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ Φ' x' y'))
                    ∨ ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
    atomic_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc_aacc with "[Hupd] Hstep"); first done.
    iApply aupd_aacc; done.
  Qed.

  Lemma aacc_aupd_commit {TA' TB' : tele} E1 E1' E2 E3
        α β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_update E1' E2 α β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ P')) β'
            (λ.. x' y', ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
    atomic_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc_aupd with "Hupd"); first done.
    iIntros (x) "Hα". iApply atomic_acc_wand; last first.
    { iApply "Hstep". done. }
    (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
    iSplit; first by eauto. iIntros (??) "?". rewrite ->!tele_app_bind. by iRight.
  Qed.

  Lemma aacc_aupd_abort {TA' TB' : tele} E1 E1' E2 E3
        α β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic_update E1' E2 α β Φ -∗
    (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ P')) β'
            (λ.. x' y', α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ Φ' x' y'))) -∗
    atomic_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc_aupd with "Hupd"); first done.
    iIntros (x) "Hα". iApply atomic_acc_wand; last first.
    { iApply "Hstep". done. }
    (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
    iSplit; first by eauto. iIntros (??) "?". rewrite ->!tele_app_bind. by iLeft.
  Qed.

End lemmas.

(** ProofMode support for atomic updates. *)
Section proof_mode.
  Context `{BiFUpd PROP} {TA TB : tele}.
  Implicit Types (α : TA → PROP) (β Φ : TA → TB → PROP) (P : PROP).

  Lemma tac_aupd_intro Γp Γs n α β Eo Ei Φ P :
    P = env_to_prop Γs →
    envs_entails (Envs Γp Γs n) (atomic_acc Eo Ei α P β Φ) →
    envs_entails (Envs Γp Γs n) (atomic_update Eo Ei α β Φ).
  Proof.
    intros ->. rewrite envs_entails_unseal of_envs_eq /atomic_acc /=.
    setoid_rewrite env_to_prop_sound =>HAU.
    rewrite assoc. apply: aupd_intro. by rewrite -assoc.
  Qed.
End proof_mode.

(** * Now the coq-level tactics *)

Tactic Notation "iAuIntro" :=
  match goal with
  | |- envs_entails (Envs ?Γp ?Γs _) (atomic_update _ _ _ _ ?Φ) =>
      notypeclasses refine (tac_aupd_intro Γp Γs _ _ _ _ _ Φ _ _ _); [
        (* P = ...: make the P pretty *) pm_reflexivity
      | (* the new proof mode goal *) ]
  end.

(** Tactic to apply [aacc_intro]. This only really works well when you have
[α ?] already and pass it as [iAaccIntro with "Hα"]. Doing
[rewrite /atomic_acc /=] is an entirely legitimate alternative. *)
Tactic Notation "iAaccIntro" "with" constr(sel) :=
  iStartProof; lazymatch goal with
  | |- envs_entails _ (@atomic_acc ?PROP ?H ?TA ?TB ?Eo ?Ei ?α ?P ?β ?Φ) =>
    iApply (@aacc_intro PROP H TA TB Eo Ei α P β Φ with sel);
    first try solve_ndisj; last iSplit
  | _ => fail "iAAccIntro: Goal is not an atomic accessor"
  end.

(* From here on, prevent TC search from implicitly unfolding these. *)
Typeclasses Opaque atomic_acc atomic_update.


(** Typeclass for decidable propositions *)

Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Lists.List.
Require Import Rewriter.Util.FixCoqMistakes.
Require Import Rewriter.Util.Sigma.
Require Import Rewriter.Util.HProp.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith_dec.
Require Import Coq.NArith.BinNat.

Local Open Scope type_scope.

Class Decidable (P : Prop) := dec : {P} + {~P}.
Arguments dec _%type_scope {_}.
Notation DecidableRel R := (forall x y, Decidable (R x y)).

Global Instance hprop_eq_dec {A} `{DecidableRel (@eq A)} : IsHPropRel (@eq A) | 10.
Proof. repeat intro; apply UIP_dec; trivial with nocore. Qed.

Global Instance eq_dec_hprop {A} {x y : A} {hp : IsHProp A} : Decidable (@eq A x y) | 5.
Proof. left; auto. Qed.

Ltac no_equalities_about x0 y0 :=
  lazymatch goal with
  | [ H' : x0 = y0 |- _ ] => fail
  | [ H' : y0 = x0 |- _ ] => fail
  | [ H' : x0 <> y0 |- _ ] => fail
  | [ H' : y0 <> x0 |- _ ] => fail
  | _ => idtac
  end.

Ltac destruct_decidable_step :=
  match goal with
  | [ H : Decidable _ |- _ ] => destruct H
  | [ H : forall x y : ?A, Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H x0 y0)
  | [ H : forall a0 (x y : _), Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H _ x0 y0)
  end.
Ltac destruct_decidable := repeat destruct_decidable_step.

Ltac pre_decide_destruct_sigma_step :=
  match goal with
  | [ H : sigT _ |- _ ] => destruct H
  | [ H : sig _ |- _ ] => destruct H
  | [ H : ex _ |- _ ] => destruct H
  end.
Ltac pre_decide_destruct_sigma := repeat pre_decide_destruct_sigma_step.

Ltac pre_decide :=
  repeat (intros
          || destruct_decidable
          || split
          || pre_decide_destruct_sigma
          || unfold Decidable in *
          || hnf).

(** Put the [subst] and reasoning about equalities after the [left]
    and [right]; opaque equality proofs should not block decidability
    proofs. *)
Ltac post_decide :=
  repeat (intros
          || subst
          || pre_hprop).

Ltac solve_decidable_transparent_with tac :=
  pre_decide;
  try solve [ left; abstract (post_decide; tac)
            | right; abstract (post_decide; tac)
            | decide equality; eauto with nocore ].

Ltac solve_decidable_transparent := solve_decidable_transparent_with firstorder.

Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances.
Local Hint Extern 1 => progress inversion_sigma : core.

Global Instance dec_True : Decidable True | 10 := left I.
Global Instance dec_False : Decidable False | 10 := right (fun x => x).
Global Instance dec_or {A B} `{Decidable A, Decidable B} : Decidable (A \/ B) | 10. exact _. Defined.
Global Instance dec_and {A B} `{Decidable A, Decidable B} : Decidable (A /\ B) | 10. exact _. Defined.
Global Instance dec_impl {A B} `{Decidable (B \/ ~A)} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_impl_simple {A B} `{Decidable A, Decidable B} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_iff {A B} `{Decidable A, Decidable B} : Decidable (A <-> B) | 10. exact _. Defined.
Lemma dec_not {A} `{Decidable A} : Decidable (~A).
Proof. solve_decidable_transparent. Defined.
(** Disallow infinite loops of dec_not *)
#[global] Hint Extern 0 (Decidable (~?A)) => apply (@dec_not A) : typeclass_instances.
Global Instance dec_eq_unit : DecidableRel (@eq unit) | 10. exact _. Defined.
Global Instance dec_eq_bool : DecidableRel (@eq bool) | 10. exact _. Defined.
Global Instance dec_eq_Empty_set : DecidableRel (@eq Empty_set) | 10. exact _. Defined.
Global Instance dec_eq_prod {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A * B)) | 10. exact _. Defined.
Global Instance dec_eq_option {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (option A)) | 10. exact _. Defined.
Global Instance dec_eq_list {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (list A)) | 10. exact _. Defined.
Global Instance dec_eq_list_nil_r {A} {ls} : Decidable (ls = @nil A) | 10.
Proof. destruct ls; [ left; reflexivity | right; abstract congruence ]. Defined.
Global Instance dec_eq_list_nil_l {A} {ls} : Decidable (@nil A = ls) | 10.
Proof. destruct ls; [ left; reflexivity | right; abstract congruence ]. Defined.
Global Instance dec_eq_sum {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A + B)) | 10. exact _. Defined.
Global Instance dec_eq_sigT_hprop {A P} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sigT A P)) | 10. exact _. Defined.
Global Instance dec_eq_sig_hprop {A} {P : A -> Prop} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sig A P)) | 10. exact _. Defined.
Global Instance dec_eq_comparison : DecidableRel (@eq comparison) | 10. exact _. Defined.

Global Instance dec_eq_nat : DecidableRel (@eq nat) | 10. exact _. Defined.
Global Instance dec_le_nat : DecidableRel le := Compare_dec.le_dec.
Global Instance dec_lt_nat : DecidableRel lt := Compare_dec.lt_dec.
Global Instance dec_ge_nat : DecidableRel ge := Compare_dec.ge_dec.
Global Instance dec_gt_nat : DecidableRel gt := Compare_dec.gt_dec.

Global Instance dec_eq_N : DecidableRel (@eq N) | 10 := N.eq_dec.

Global Instance dec_eq_Z : DecidableRel (@eq Z) | 10 := Z.eq_dec.
Global Instance dec_lt_Z : DecidableRel BinInt.Z.lt := ZArith_dec.Z_lt_dec.
Global Instance dec_le_Z : DecidableRel BinInt.Z.le := ZArith_dec.Z_le_dec.
Global Instance dec_gt_Z : DecidableRel BinInt.Z.gt := ZArith_dec.Z_gt_dec.
Global Instance dec_ge_Z : DecidableRel BinInt.Z.ge := ZArith_dec.Z_ge_dec.

Global Instance dec_Forall {A P} {HD : forall x : A, Decidable (P x)} {ls}
  : Decidable (Forall P ls) | 10.
Proof.
  induction ls as [|x xs IHxs]; [ left | destruct (HD x), IHxs; [ left | right.. ] ];
    [ constructor; assumption | constructor; assumption | intro Hn.. ];
    clear HD;
    try abstract (inversion Hn; subst; tauto).
Defined.
Global Instance dec_Exists {A P} {HD : forall x : A, Decidable (P x)} {ls}
  : Decidable (Exists P ls) | 10.
Proof.
  induction ls as [|x xs IHxs]; [ right | destruct (HD x), IHxs; [ left.. | right ] ];
    [ intro Hn | constructor; assumption.. | intro Hn ];
    clear HD;
    try abstract (inversion Hn; subst; tauto).
Defined.

Global Instance dec_match_pair {A B} {P : A -> B -> Prop} {x : A * B}
       {HD : Decidable (P (fst x) (snd x))}
  : Decidable (let '(a, b) := x in P a b) | 1.
Proof. edestruct (_ : _ * _); assumption. Defined.

Global Instance dec_if_bool {b : bool} {A B} {HA : Decidable A} {HB : Decidable B}
  : Decidable (if b then A else B) | 10
  := if b return Decidable (if b then A else B)
     then HA
     else HB.

Lemma not_not P {d:Decidable P} : not (not P) <-> P.
Proof. destruct (dec P); intuition. Qed.

Global Instance dec_ex_forall_not : forall T (P:T->Prop) {d:Decidable (exists b, P b)}, Decidable (forall b, ~ P b).
Proof.
  intros T P d.
  destruct (dec (~ exists b, P b)) as [Hd|Hd]; [left|right];
    [abstract eauto | let Hd := Hd in abstract (rewrite not_not in Hd by eauto; destruct Hd; eauto) ].
Defined.

Lemma eqsig_eq {T} {U} {Udec:DecidableRel (@eq U)} (f g:T->U) (x x':T) pf pf' :
  (exist (fun x => f x = g x) x pf) = (exist (fun x => f x = g x) x' pf') <-> (x = x').
Proof. apply path_sig_hprop_iff; auto using UIP_dec, Udec. Qed.

Lemma Decidable_respects_iff A B (H : A <-> B) : (Decidable A -> Decidable B) * (Decidable B -> Decidable A).
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_impl A B (H : A <-> B) : Decidable A -> Decidable B.
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_flip_impl A B (H : A <-> B) : Decidable B -> Decidable A.
Proof. solve_decidable_transparent. Defined.

Global Instance dec_eq_positive : DecidableRel (@eq BinNums.positive) | 10 := BinPos.Pos.eq_dec.
Global Instance dec_lt_positive : DecidableRel BinPos.Pos.lt.
Proof. eauto using Decidable_iff_to_impl, Pos.ltb_lt with typeclass_instances. Defined.
Global Instance dec_le_positive : DecidableRel BinPos.Pos.le.
Proof. eauto using Decidable_iff_to_impl, Pos.leb_le with typeclass_instances. Defined.
Global Instance dec_gt_positive : DecidableRel BinPos.Pos.gt.
Proof. eauto using Decidable_iff_to_flip_impl, Pos.gt_lt_iff with typeclass_instances. Defined.
Global Instance dec_ge_positive : DecidableRel BinPos.Pos.ge.
Proof. eauto using Decidable_iff_to_flip_impl, Pos.ge_le_iff with typeclass_instances. Defined.

Lemma dec_of_semidec {P : Prop} (H : option P) (H_complete : H = None -> ~P) : Decidable P.
Proof. destruct H; [ left; assumption | right; apply H_complete, eq_refl ]. Defined.

Lemma dec_rel_of_semidec_rel {A} {R : A -> A -> Prop} (H : forall x y, option (R x y))
      (H_complete : forall x y, H x y = None -> ~R x y) : DecidableRel R.
Proof. eauto using dec_of_semidec. Defined.

Lemma dec_of_bool_dec {P : Prop} (b : bool) (Hbl : b = true -> P) (Hlb : P -> b = true)
  : Decidable P.
Proof. destruct b; [ left; apply Hbl; reflexivity | right; intro p; apply Bool.diff_false_true, Hlb, p ]. Defined.

Definition bool_of_dec (P : Prop) {H : Decidable P} : bool := if H then true else false.
Lemma bp_of_dec (P : Prop) {H : Decidable P} : bool_of_dec P = true -> P.
Proof. cbv [bool_of_dec]; destruct H; [ trivial with nocore | abstract congruence ]. Defined.
Lemma pb_of_dec (P : Prop) {H : Decidable P} : P -> bool_of_dec P = true.
Proof. cbv [bool_of_dec]; destruct H; [ reflexivity | abstract tauto ]. Defined.

Lemma dec_rel_of_bool_dec_rel {A} {R : A -> A -> Prop} (b : A -> A -> bool)
      (Hbl : forall x y, b x y = true -> R x y) (Hlb : forall x y, R x y -> b x y = true)
  : DecidableRel R.
Proof. eauto using dec_of_bool_dec. Defined.

Definition bool_rel_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R} : A -> A -> bool
  := fun x y => if H x y then true else false.
Lemma br_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R}
  : forall x y, bool_rel_of_dec_rel R x y = true -> R x y.
Proof. cbv [bool_rel_of_dec_rel]; intros x y; destruct (H x y); [ trivial with nocore | abstract congruence ]. Defined.
Lemma rb_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R}
  : forall x y, R x y -> bool_rel_of_dec_rel R x y = true.
Proof. cbv [bool_rel_of_dec_rel]; intros x y; destruct (H x y); [ reflexivity | abstract tauto ]. Defined.

Lemma dec_bool : forall {P} {Pdec:Decidable P}, (if dec P then true else false) = true -> P.
Proof. intros. destruct dec; solve [ auto | discriminate ]. Qed.

Ltac vm_decide_no_check := apply dec_bool; vm_cast_no_check (eq_refl true).
Ltac lazy_decide_no_check := apply dec_bool; exact_no_check (eq_refl true).

Ltac vm_decide := abstract vm_decide_no_check.
Ltac lazy_decide := abstract lazy_decide_no_check.

(** For dubious compatibility with [eauto using]. *)
#[global] Hint Extern 2 (Decidable _) => progress unfold Decidable : typeclass_instances core.

Definition cast_if_eq {T} `{DecidableRel (@eq T)} {P} (t t' : T) (v : P t) : option (P t')
  := match dec (t = t'), dec (t' = t') with
     | left pf, left pf' => Some (eq_rect _ P v _ (eq_trans pf (eq_sym pf')))
     | _, right pf' => match pf' eq_refl with end
     | right pf, _ => None
     end.

Lemma cast_if_eq_refl {T H P} t v : @cast_if_eq T H P t t v = Some v.
Proof.
  compute; clear; destruct (H t t) as [ [] |e];
    [ reflexivity | destruct (e eq_refl) ].
Qed.


Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.SymI.

Require Import ExtLib.Core.RelDec.

Require Import Charge.SetoidRewrite.AutoSetoidRewrite.
Require Import Charge.SetoidRewrite.Base.
Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.ILogicFunc.

Require Import Charge.Logics.ILogic.

Section ILSetoidRewrite.
	Context {typ func : Type} {RType_typ : RType typ}.
	Context {HIL : ILogicFunc typ func} {HB : BaseFunc typ func}.
	Context {RelDec_func : RelDec (@eq (expr typ func))}.
	Context {ilogic : forall t : typ, option (ILogicOps (typD t))}.
	Context {HT2 : Typ2 RType_typ Fun}.
	Context {HT0 : Typ0 _ Prop}.
	Context {RSym_func : RSym func}.

    Let tyProp : typ := @typ0 _ _ _ _.

	Let Rbase := expr typ func.

  Definition il_respects (e : Rbase) (_ : list (RG Rbase))
	   (rg : RG Rbase) : m (expr typ func) :=
	   match ilogicS (typ := typ) (func := expr typ func) e with
		 | Some (ilf_and l) =>
		 	 rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
			         (RGrespects (RGinj (fEntails l))
			         (RGrespects (RGinj (fEntails l))
			         (RGinj (fEntails l)))))
				 (fun _ => rg_ret (fAnd l))
		 | Some (ilf_or l) =>
			 rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
			         (RGrespects (RGinj (fEntails l))
			         (RGrespects (RGinj (fEntails l))
			         (RGinj (fEntails l)))))
				 (fun _ => rg_ret (fOr l))
		 | Some (ilf_entails l) =>
			 rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
			                  (RGrespects (RGflip (RGinj (fEntails l)))
			                  (RGrespects (RGinj (fEntails l))
			                  (RGinj (fEntails tyProp)))))
				 (fun _ => rg_ret (fEntails l))
		 | Some (ilf_impl l) =>
			 rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
			                  (RGrespects (RGflip (RGinj (fEntails l)))
			                  (RGrespects (RGinj (fEntails l))
			                  (RGinj (fEntails l)))))
				 (fun _ => rg_ret (fImpl l))
		 | Some (ilf_exists t l) =>
			 rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
			                  (RGrespects (RGrespects (RGinj (fEq t))
				 	 	                              (RGinj (fEntails l)))
						                  (RGinj (fEntails l))))

				 (fun _ => rg_ret (fExists t l))
(*		 | Some (ilf_true l) => rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails l)))
			 	(fun _ => rg_ret (fTrue l))
		 | Some (ilf_false l) => rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails l)))
			 	(fun _ => rg_ret (fFalse l))*)
		 | _ => rg_fail
	 end.

  Definition il_respects_reflexive (e : Rbase) (_ : list (RG Rbase))
	   (rg : RG Rbase) : m (expr typ func) :=
  	match typeof_expr nil nil e with
      | Some t => match ilogic t with
  				    | Some _ =>
  				      rg_plus
  				        (rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails t)))
					      (fun _ => rg_ret e))
  				        (rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGflip (RGinj (fEntails t))))
					      (fun _ => rg_ret e))
  				    | None => rg_fail
  				  end
  	  | None => rg_fail
  	end.
(*
	   rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails l)))
	   	 (fun _ => rg_ret e).

  Definition il_respects_reflexive := fold_right (fun t acc => sr_combine (il_respects_reflexive_aux t) acc)
  	(fun _ _ _ => rg_fail).
*)
Definition eq_respects :=
  fun (e : expr typ func) (_ : list (AutoSetoidRewrite.RG Rbase))
      (rg : AutoSetoidRewrite.RG Rbase) =>
    match baseS e with
      | Some (pEq t) =>
        rg_bind
          (AutoSetoidRewrite.unifyRG
             (RelDec.rel_dec (equ:=@eq (expr typ func))) rg
             (AutoSetoidRewrite.RGrespects
                (AutoSetoidRewrite.RGinj e)
                (AutoSetoidRewrite.RGrespects
                   (AutoSetoidRewrite.RGinj e)
                   (AutoSetoidRewrite.RGinj (fEntails tyProp)))))
          (fun _ : AutoSetoidRewrite.RG (expr typ func) => rg_ret e)
      | _ => rg_fail
    end.

Definition refl :=
  let Rbase := expr typ func in
  fun (e : expr typ func) (_ : list (AutoSetoidRewrite.RG Rbase))
      (rg : AutoSetoidRewrite.RG Rbase) =>
    match typeof_expr nil nil e with
      | Some t =>
        rg_bind
          (AutoSetoidRewrite.unifyRG (RelDec.rel_dec (equ:=@eq (expr typ func))) rg
                                     (AutoSetoidRewrite.RGinj (fEq t)))
          (fun _ : AutoSetoidRewrite.RG (expr typ func) => rg_ret e)
      | None => rg_fail
    end.

Definition il_rewrite_respects :=
    sr_combine il_respects
               (sr_combine il_respects_reflexive (sr_combine eq_respects refl)).

End ILSetoidRewrite.

Implicit Arguments il_rewrite_respects [[HIL] [HB] [RelDec_func] [RType_typ] [HT2] [HT0] [RSym_func]].


Require Export GMu.Zip.
Require Import GMuAnnot.Definitions.
Require Export GMuAnnot.Definitions.
Require Export TLC.LibTactics.
Require Export TLC.LibFset.
Require Export TLC.LibEnv.
Require Import TLC.LibLN.
Require Export Psatz.
Require Import Coq.Init.Nat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.EqNat.
Require Import List.

#[export] Hint Constructors type term wft typing red value.

#[export] Hint Resolve typing_var typing_app typing_tapp.

Lemma value_is_term : forall e, value e -> term e.
  induction e; intro Hv; inversion Hv; eauto.
Qed.

(** Gathering free names already used in the proofs *)
Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : trm => fv_trm x) in
  let E := gather_vars_with (fun x : typ => fv_typ x) in
  let F := gather_vars_with (fun x : ctx => dom x \u fv_env x) in
  let G := gather_vars_with (fun x : list var => from_list x) in
  let H := gather_vars_with (fun x : list typ => fv_typs x) in
  let I := gather_vars_with (fun x : typctx => domΔ x \u fv_delta x) in
  constr:(A \u B \u C \u E \u F \u G \u H \u I).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto_star.

Ltac get_env :=
  match goal with
  | |- wft ?E _ => E
  | |- typing ?E _ _ => E
  end.

Ltac handleforall :=
  let Hforall := fresh "Hforall" in
  match goal with
  | H: List.Forall ?P ?ls |- _ => rename H into Hforall; rewrite List.Forall_forall in Hforall
  end.

Ltac rewritemapmap :=
  let H' := fresh "Hmapmap" in
  match goal with
  | H: List.map ?f ?ls = (List.map ?g (List.map ?h ?ls)) |- _ => rename H into H'; rewrite List.map_map in H'
  end.

Ltac decide_compare i j :=
  let CMP := fresh "CMP" in
  let EQ := fresh "EQ" in
  remember (i ?= j) as CMP eqn: EQ;
  symmetry in EQ;
  destruct CMP;
  match goal with
  | H: (i ?= j) = Eq |- _ => apply nat_compare_eq in H
  | H: (i ?= j) = Lt |- _ => apply nat_compare_lt in H
  | H: (i ?= j) = Gt |- _ => apply nat_compare_gt in H
  end.

Ltac crush_compare :=
  match goal with
  | H: context [(?i ?= ?j)] |- _ => decide_compare i j; (try lia); eauto
  | |- context [(?i ?= ?j)] => decide_compare i j; (try lia); eauto
  end.

Ltac decide_eq i j :=
  let CMP := fresh "CMP" in
  let EQ := fresh "EQ" in
  remember (i =? j) as CMP eqn: EQ;
  symmetry in EQ;
  destruct CMP;
  match goal with
  | H: (i =? j) = true |- _ => apply beq_nat_true in H
  | H: (i =? j) = false |- _ => apply beq_nat_false in H
  end.

Ltac crush_eq :=
  match goal with
  | H: context [(?i =? ?j)] |- _ => decide_eq i j; eauto
  | |- context [(?i =? ?j)] => decide_eq i j; eauto
  end.

(* maybe move strong induction to separate file? *)
Lemma strong_induction (P : nat -> Prop): (forall m, (forall k, k < m -> P k) -> P m) -> forall n, P n.
  apply Wf_nat.induction_ltof1.
Qed.

Lemma strong_induction_on_term_size_helper : forall (P : trm -> Prop),
    (forall n, (forall e, trm_size e < n -> P e) -> forall e, trm_size e = n -> P e) ->
    forall n e, trm_size e = n -> P e.
  introv IH.
  lets K: strong_induction (fun n => forall e, trm_size e = n -> P e).
  apply K.
  introv IHk.
  lets IHm: IH m.
  apply IHm.
  intros.
  eapply IHk; eauto.
Qed.

Lemma strong_induction_on_term_size : forall (P : trm -> Prop),
    (forall n, (forall e, trm_size e < n -> P e) -> forall e, trm_size e = n -> P e) ->
    forall e, P e.
  intros.
  pose (n := trm_size e).
  eapply strong_induction_on_term_size_helper; eauto.
Qed.

(* TODO DRY *)
Lemma strong_induction_on_type_size_helper : forall (P : typ -> Prop),
    (forall n, (forall e, typ_size e < n -> P e) -> forall e, typ_size e = n -> P e) ->
    forall n e, typ_size e = n -> P e.
  introv IH.
  lets K: strong_induction (fun n => forall e, typ_size e = n -> P e).
  apply K.
  introv IHk.
  lets IHm: IH m.
  apply IHm.
  intros.
  eapply IHk; eauto.
Qed.

Lemma strong_induction_on_typ_size : forall (P : typ -> Prop),
    (forall n, (forall T, typ_size T < n -> P T) -> forall T, typ_size T = n -> P T) ->
    forall T, P T.
  intros.
  pose (n := typ_size T).
  eapply strong_induction_on_type_size_helper; eauto.
Qed.

(* (** These tactics help applying a lemma which conclusion mentions *)
(*   an environment (E & F) in the particular case when F is empty *) *)
(* Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) := *)
(*   let E := get_env in rewrite <- (concat_empty E); *)
(*   eapply lemma; try rewrite concat_empty. *)

(* Tactic Notation "apply_empty" constr(F) := *)
(*   apply_empty_bis (get_env) F. *)

(* Tactic Notation "apply_empty" "*" constr(F) := *)
(*   apply_empty F; auto*. *)

Ltac unsimpl_map_bind :=
  match goal with |- context [ ?B (subst_tt ?Z ?P ?U) ] =>
    unsimpl ((subst_tb Z P) (B U)) end.

Tactic Notation "unsimpl_map_bind" "*" :=
  unsimpl_map_bind; auto_star.

(* TODO make better names for map_id and ext_in_map *)
Lemma map_id : forall (A : Type) (f : A -> A) (ls : list A),
    (forall x, List.In x ls -> x = f x) ->
    ls = List.map f ls.
  introv feq.
  induction ls.
  - auto.
  - cbn.
    rewrite <- feq.
    + rewrite <- IHls.
      * auto.
      * intros.
        apply feq.
        apply* List.in_cons.
    + constructor*.
Qed.

(* adapted from a newer version of Coq stdlib:
https://github.com/coq/coq/blob/master/theories/Lists/List.v
*)
Lemma ext_in_map :
  forall (A B : Type)(f g:A->B) l, List.map f l = List.map g l -> forall a, List.In a l -> f a = g a.
Proof. induction l; intros [=] ? []; subst; auto. Qed.

Ltac crush_open :=
  (try unfold open_tt); (try unfold open_tt_rec); crush_compare.

#[export] Hint Immediate subset_refl subset_empty_l subset_union_weak_l subset_union_weak_r subset_union_2 union_comm union_assoc union_same.

Lemma union_distribute : forall T (A B C : fset T),
    (A \u B) \u C = (A \u C) \u (B \u C).
  intros.
  assert (CuC: C \u C = C); try apply union_same.
  rewrite <- CuC at 1.
  rewrite <- union_assoc.
  rewrite union_comm.
  rewrite union_assoc.
  rewrite <- union_assoc.
  rewrite union_comm.
  assert (CuA: C \u A = A \u C); try apply union_comm.
  rewrite* CuA.
Qed.

Lemma union_fold_detach : forall B (ls : list B) (P : B -> fset var) (z : fset var) (z' : fset var),
    List.fold_left (fun (a : fset var) (b : B) => a \u P b) ls (z \u z')
    =
    List.fold_left (fun (a : fset var) (b : B) => a \u P b) ls z \u z'.
  induction ls; introv.
  - cbn. eauto.
  - cbn.
    assert (Horder: ((z \u z') \u P a) = ((z \u P a) \u z')).
    + rewrite union_comm.
      rewrite union_assoc.
      rewrite (union_comm (P a) z).
      eauto.
    + rewrite Horder.
      apply* IHls.
Qed.

Ltac expand_env_empty E :=
  let HE := fresh "HE" in
  assert (HE: E = E & empty); [
    rewrite* concat_empty_r
  | rewrite HE ].

Ltac fold_env_empty :=
  match goal with
  | |- context [?E & empty] =>
    let HE := fresh "HE" in
    assert (HE: E = E & empty); [
      rewrite* concat_empty_r
    | rewrite* <- HE ]
  end.

Ltac fold_env_empty_H :=
  match goal with
  | H: context [?E & empty] |- _ =>
    let HE := fresh "HE" in
    assert (HE: E = E & empty); [
      rewrite* concat_empty_r
    | rewrite* <- HE in H]
  | H: context [empty & ?E] |- _ =>
    let HE := fresh "HE" in
    assert (HE: E = empty & E); [
      rewrite* concat_empty_l
    | rewrite* <- HE in H]
  end.

Ltac copy H :=
  let H' := fresh H in
  let Heq := fresh "EQ" in
  remember H as H' eqn:Heq; clear Heq.

Ltac copyTo H Hto :=
  let H' := fresh Hto in
  let Heq := fresh "EQ" in
  remember H as H' eqn:Heq; clear Heq.

Ltac apply_folding E lemma :=
  expand_env_empty E; apply* lemma; fold_env_empty.

Ltac add_notin x L :=
  let Fr := fresh "Fr" in
  assert (Fr: x \notin L); auto.

Require Import TLC.LibFset TLC.LibList.
(* different Fset impl? taken from repo: *)
Lemma from_list_spec : forall A (x : A) L,
  x \in from_list L -> LibList.mem x L.
Proof using.
  unfold from_list. induction L; rew_listx.
  - rewrite in_empty. auto.
  - rewrite in_union, in_singleton.
    intro HH.
    destruct HH; eauto.
Qed.

Lemma from_list_spec2 : forall A (x : A) L,
    List.In x L -> x \in from_list L.
Proof using.
  unfold from_list. induction L; rew_listx.
  - rewrite in_empty. auto.
  - rewrite in_union, in_singleton.
    intro HH.
    destruct HH; eauto.
Qed.

Lemma exist_alphas : forall L len,
    exists (Alphas : list var),
      List.length Alphas = len /\ DistinctList Alphas /\ forall A, List.In A Alphas -> A \notin L.
  induction len.
  - exists (@List.nil var). splits*.
    + econstructor.
    + intuition.
  - inversion IHlen as [Alphas' [Hlen [Hdis Hnot]]].
    pick_fresh A.
    exists (List.cons A Alphas').
    splits*.
    + cbn.
      eauto.
    + constructor*.
      intro.
      assert (Hnot2: A \notin from_list Alphas'); eauto.
      apply Hnot2.
      apply* from_list_spec2.
    + introv AiA.
      inversions AiA; eauto.
Qed.

Global Transparent fold_right.

Lemma length_equality : forall A (a : list A),
    LibList.length a = Datatypes.length a.
  induction a; cbn; eauto.
  rewrite <- IHa.
  rewrite length_cons.
  lia.
Qed.

(* stdlib lemma but in TLC version *)
Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l,
    map g (map f l) = map (fun x => g (f x)) l.
  induction l; cbn; auto.
  repeat rewrite map_cons.
  f_equal.
  auto.
Qed.

Lemma eq_dec_var (x y : var) : x = y \/ x <> y.
  lets: var_compare_eq x y.
  Require Import TLC.LibReflect.
  destruct (var_compare x y);
  rewrite isTrue_eq_if in H;
  case_if; auto.
Qed.

Lemma JMeq_from_eq : forall T (x y : T),
    x = y -> JMeq.JMeq x y.
  introv EQ.
  rewrite EQ. trivial.
Qed.

Lemma split_notin_subset_union : forall T (x : T) A B C,
    A \c B \u C ->
    x \notin B ->
    x \notin C ->
    x \notin A.
  introv Hsub HB HC.
  intro inA.
  lets Hf: Hsub inA.
  rewrite in_union in Hf.
  destruct Hf; eauto.
Qed.

Lemma in_from_list : forall As (x : var),
    x \in from_list As ->
          exists A, List.In A As /\ x = A.
  induction As; introv xin.
  - cbn in xin. exfalso; apply* in_empty_inv.
  - cbn in *.
    fold (from_list As) in xin.
    rewrite in_union in xin.
    destruct xin as [xin | xin].
    + rewrite in_singleton in xin. subst. eauto.
    + lets [A Ain]: IHAs xin.
      exists A. split*.
Qed.

Lemma env_map_compose : forall A B C (E : env A) (f : A -> B) (g : B -> C) (h : A -> C),
    (forall x, g (f x) = h x) ->
    EnvOps.map g (EnvOps.map f E) = EnvOps.map h E.
  induction E using env_ind; introv Hcomp;
    autorewrite with rew_env_map; trivial.
  - lets IH: IHE f g h.
    rewrite IH; auto.
    rewrite Hcomp. trivial.
Qed.

Ltac clean_empty_Δ :=
  repeat match goal with
         | [ H: context [ emptyΔ |,| ?D ] |- _ ] =>
           rewrite List.app_nil_r in H
         | [ H: context [ ?D |,| emptyΔ ] |- _ ] =>
           rewrite List.app_nil_l in H
         | [ H: context [ []* |,| ?D ] |- _ ] =>
           rewrite List.app_nil_r in H
         | [ H: context [ ?D |,| []* ] |- _ ] =>
           rewrite List.app_nil_l in H
         | [ |- context [ emptyΔ |,| ?D ] ] =>
           rewrite List.app_nil_r
         | [ |- context [ ?D |,| emptyΔ ] ] =>
           rewrite List.app_nil_l
         | [ |- context [ []* |,| ?D ] ] =>
           rewrite List.app_nil_r
         | [ |- context [ ?D |,| []* ] ] =>
           rewrite List.app_nil_l
         end.

Lemma binds_ext : forall A (x : var) (v1 v2 : A) E,
    binds x v1 E ->
    binds x v2 E ->
    v1 = v2.
  induction E using env_ind; introv b1 b2.
  - exfalso. apply* binds_empty_inv.
  - lets* [[? ?] | [? ?]]: binds_push_inv b1;
      lets* [[? ?] | [? ?]]: binds_push_inv b2.
      subst; trivial.
Qed.

Lemma list_fold_map : forall (A B : Type) (ls : list A) (f : B -> A -> B) (g : A -> A) (z : B),
    List.fold_left (fun a b => f a b) (List.map g ls) z
    =
    List.fold_left (fun a b => f a (g b)) ls z.
  induction ls; introv; cbn; eauto.
Qed.

Lemma notin_inverse : forall A (x y : A),
    x \notin \{ y } ->
    y \notin \{ x }.
  intros.
  assert (x <> y).
  - intro. subst. apply H. apply in_singleton_self.
  - apply* notin_singleton.
Qed.

Lemma LibList_map : forall T U (l : list T) (f : T -> U),
    List.map f l = LibList.map f l.
  induction l; intros; cbn in *; auto.
  rewrite IHl.
  rewrite LibList.map_cons. auto.
Qed.

Lemma LibList_mem : forall A (x : A) L,
    LibList.mem x L -> List.In x L.
  induction L; introv Hin; cbn in *; inversion Hin; eauto.
Qed.

Lemma subst_tb_many_split : forall Ah Ats Ph Pts F,
    EnvOps.map (subst_tb_many (Ah :: Ats) (Ph :: Pts)) F
    =
    EnvOps.map (subst_tb_many Ats Pts) (EnvOps.map (subst_tb Ah Ph) F).
  intros.
  rewrite map_def.
  rewrite map_map.
  repeat rewrite <- LibList_map.
  cbn.
  apply List.map_ext_in.
  intros.
  destruct a as [? [?]].
  cbn.
  f_equal.
Qed.

Ltac fresh_intros :=
    let envvars := gather_vars in
    intros;
    repeat match goal with
           (* TODO find only uninstantiated *)
      | [ H: ?x \notin ?L |- _ ] =>
        instantiate (1:=envvars) in H
           end.

Lemma union_distributes : forall T (A B C : fset T),
    (A \u B) \n C = (A \n C) \u (B \n C).
  intros.
  apply fset_extens; intros x H.
  - rewrite in_union.
    rewrite in_inter in H.
    destruct H as [HAB HC].
    rewrite in_union in HAB.
    destruct HAB.
    + left.
      rewrite~ in_inter.
    + right.
      rewrite~ in_inter.
  - rewrite in_union in H.
    destruct H as [H | H]; rewrite in_inter in H; destruct H;
      rewrite in_inter;
      split~; rewrite~ in_union.
Qed.

Lemma union_empty : forall T (A B : fset T),
    A \u B = \{} ->
    A = \{} /\ B = \{}.
  intros.
  split;
    apply fset_extens; intros x Hin;
      solve [
          assert (xAB: x \in A \/ x \in B); auto;
          rewrite <- in_union in xAB;
          rewrite H in xAB; auto
        | false* in_empty_inv].
Qed.

Lemma empty_inter_implies_notin : forall T (x : T) A B,
    A \n B = \{} ->
    x \in A -> x \notin B.
  intros.
  intro HF.
  asserts~ AB: (x \in A /\ x \in B).
  rewrite <- in_inter in AB.
  rewrite H in AB.
  apply* in_empty_inv.
Qed.

Ltac fold_subst_src :=
  repeat match goal with
  | [ H: context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} (List.map fst ?Th)] |- _ ] =>
    fold (from_list (List.map fst Th)) in H;
    fold (substitution_sources Th) in H
  | [ |- context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} (List.map fst ?Th)] ] =>
    fold (from_list (List.map fst Th));
    fold (substitution_sources Th)
  end.

Lemma subset_transitive : forall T (A B C : fset T),
    A \c B ->
    B \c C ->
    A \c C.
  introv AB BC.
  intros x In.
  auto.
Qed.

Lemma lists_map_eq : forall A B (f : A -> B) la lb a b,
    List.map f la = List.map f lb ->
    List.In (a, b) (zip la lb) ->
    f a = f b.
  induction la as [| a' la]; destruct lb as [| b' lb]; introv Map In; try solve [inversion Map | inversion In].
  cbn in *.
  inversions Map.
  destruct In as [In | In].
  - inversions~ In.
  - apply IHla with lb; auto.
Qed.

Lemma equations_from_lists_are_equations : forall D Ts Us,
    D = equations_from_lists Ts Us ->
    (forall eq, List.In eq D -> exists ϵ, eq = tc_eq ϵ).
  induction D; cbn; introv Deq Hin; auto.
  + false.
  + destruct Ts; destruct Us; cbn; try solve [false].
    cbn in Deq.
    inversions Deq.
    destruct Hin; subst; eauto.
Qed.

Open Scope list_scope.

Ltac fold_delta :=
  repeat match goal with
  | [ H: context [List.map tc_var ?As] |- _ ] =>
    fold (tc_vars As) in H
  | [ H: context [ (tc_var ?X) :: ?As] |- _ ] =>
    match As with
    | []* => fail 1
    | _ => fold ([tc_var X]* ++ As) in H
    end
  | [ H: context [ (tc_eq ?eq) :: ?As] |- _ ] =>
    match As with
    | []* => fail 1
    | _ => fold ([tc_eq eq]* ++ As) in H
    end
  | [ |- context [List.map tc_var ?As] ] =>
    fold (tc_vars As)
  | [ |- context [ (tc_var ?X) :: ?As] ] =>
    match As with
    | []* => fail 1
    | _ => fold ([tc_var X]* ++ As)
    end
  | [ |- context [ (tc_eq ?eq) :: ?As] ] =>
    match As with
    | []* => fail 1
    | _ => fold ([tc_eq eq]* ++ As)
    end
  end.

Ltac destruct_in_app :=
  match goal with
  | [ H: List.In ?X (?A ++ ?B) |- _ ] =>
    apply List.in_app_or in H;
    destruct H
  | [ H: is_var_defined (?A ++ ?B) ?X |- _ ] =>
    unfold is_var_defined in H;
    apply List.in_app_or in H;
    destruct H
  end.
Close Scope list_scope.

Lemma Forall2_eq_len : forall A P (l1 l2 : list A),
    List.Forall2 P l1 l2 ->
    List.length l1 = List.length l2.
  induction l1; destruct l2;
    introv H; cbn in *;
      inversions H; auto.
Qed.

Lemma nth_error_map : forall A B (F : A -> B) l n d,
    List.nth_error (List.map F l) n = Some d ->
    exists e, List.nth_error l n = Some e /\ d = F e.
Proof.
  induction l; destruct n; introv EQ; cbn in *; try solve [false*].
  - inversions EQ. eauto.
  - eauto.
Qed.

Lemma inzip_map_clause_trm : forall A F (Defs : list A) Clauses def cl,
    List.In (def, cl)
            (zip Defs (map_clause_trm_trm F Clauses)) ->
    exists (clA : nat) (clT : trm),
      List.In (def, (clause clA clT)) (zip Defs Clauses) /\
      cl = clause clA (F clT).
  introv In.
  lets [n [ND NC]]: Inzip_to_nth_error In.
  unfold map_clause_trm_trm in NC.
  lets [[clA clT] [? ?]]: nth_error_map NC.
  exists clA clT.
  split~.
  apply* Inzip_from_nth_error.
Qed.

(** The value relation is restricted to well-formed objects. *)
Lemma value_regular : forall t,
  value t -> term t.
Proof.
  induction 1; autos*.
Qed.


Require Import Hask.Prelude.
Require Import Hask.Data.List.
Require Import Hask.Control.Applicative.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Class Comonad (w : Type -> Type) := {
  is_functor :> Functor w;

  extract : forall {a : Type}, w a -> a;
  duplicate : forall {a : Type}, w a -> w (w a)
}.

Arguments extract {w _ _} _.
Arguments duplicate {w _ _} _.

Definition extend `{Comonad w} {X Y : Type} (f : (w X -> Y)) : w X -> w Y :=
  fmap f \o duplicate.

Notation "m =>> f" := (extend f m) (at level 25, left associativity).

Module ComonadLaws.

Include ApplicativeLaws.

(* Class ComonadLaws (w : Type -> Type) `{Comonad w} := { *)
(*   has_applicative_laws :> ApplicativeLaws w; *)

(*   duplicate_fmap_duplicate : forall a : Type, *)
(*     duplicate \o fmap (@duplicate w _ a) =1 duplicate \o duplicate; *)
(*   duplicate_fmap_extract : forall a : Type, *)
(*     duplicate \o fmap (extract (a:=a)) =1 id; *)
(*   duplicate_extract      : forall a : Type, duplicate \o extract =1 @id (w a); *)
(*   duplicate_fmap_fmap : forall (a b : Type) (f : a -> b), *)
(*     duplicate \o fmap (fmap f) =1 fmap f \o duplicate *)
(* }. *)

(* Corollary duplicate_fmap_duplicate_x `{ComonadLaws w} : forall a x, *)
(*   duplicate (fmap (duplicate (a:=a)) x) = duplicate (duplicate x). *)
(* Proof. exact: duplicate_fmap_duplicate. Qed. *)

(* Corollary duplicate_fmap_extract_x `{ComonadLaws w} : forall a x, *)
(*   duplicate (fmap (extract (a:=a)) x) = x. *)
(* Proof. exact: duplicate_fmap_extract. Qed. *)

(* Corollary duplicate_extract_x `{ComonadLaws w} : forall a x, *)
(*   duplicate (extract x) = @id (w a) x. *)
(* Proof. exact: duplicate_extract. Qed. *)

(* Corollary duplicate_fmap_fmap_x `{ComonadLaws w} : *)
(*   forall (a b : Type) (f : a -> b) x, *)
(*   duplicate (fmap (fmap f) x) = fmap f (duplicate x). *)
(* Proof. exact: duplicate_fmap_fmap. Qed. *)

End ComonadLaws.


(** * Finite Modular Maps: Generic Trees *)

(** Author: Pierre Letouzey (Université de Paris - INRIA),
    License: LGPL-2.1-only, see file LICENSE. *)

(** This module factorizes common parts in implementations
    of finite maps as AVL trees and as Red-Black trees. The nodes
    of the trees defined here include an generic information
    parameter, that will be the height in AVL trees and the color
    in Red-Black trees. Without more details here about these
    information parameters, trees here are not known to be
    well-balanced, but simply binary-search-trees.

    The operations we could define and prove correct here are the
    ones that do not modify the informations on the nodes :

     - empty is_empty
     - find mem
     - equal compare
     - fold cardinal bindings
     - map mapi
*)

From Coq Require Import Bool PeanoNat BinInt FunInd.
From Coq Require Import Orders OrdersFacts OrdersLists.
From MMaps Require Import Comparisons Interface OrdList.

Local Open Scope list_scope.
Local Open Scope lazy_bool_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(* For nicer extraction, we create induction principles
   only when needed *)
Local Unset Elimination Schemes.

Module PairNotations.
Notation "s #1" := (fst s) (at level 9, format "s '#1'").
Notation "s #2" := (snd s) (at level 9, format "s '#2'").
End PairNotations.

Module Type InfoTyp.
 Parameter t : Set.
End InfoTyp.

(** ** Ops: the pure functions *)

Module Type Ops (K:OrderedType)(Info:InfoTyp).

Definition key := K.t.

Section Elt.

Variable elt : Type.

(** *** Trees *)

Inductive tree  : Type :=
| Leaf : tree
| Node : Info.t -> tree -> K.t -> elt -> tree -> tree.

Definition t := tree.

(** *** The empty map and emptiness test *)

Definition empty := Leaf.

Definition is_empty t :=
 match t with
 | Leaf => true
 | _ => false
 end.

(** *** Membership test *)

(** The [mem] function is deciding membership. It exploits the
    binary search tree invariant to achieve logarithmic complexity. *)

Fixpoint mem x t :=
 match t with
 | Leaf => false
 | Node _ l k _ r =>
   match K.compare x k with
     | Lt => mem x l
     | Eq => true
     | Gt => mem x r
   end
 end.

Fixpoint find x m : option elt :=
  match m with
    |  Leaf => None
    |  Node _ l y v r =>
       match K.compare x y with
         | Eq => Some v
         | Lt => find x l
         | Gt => find x r
       end
   end.

(** *** Minimal, maximal, arbitrary bindings *)

Fixpoint min_binding (t : tree) : option (key * elt) :=
 match t with
 | Leaf => None
 | Node _ Leaf x e r => Some (x,e)
 | Node _ l x e r => min_binding l
 end.

Fixpoint max_binding (t : tree) : option (key * elt) :=
  match t with
  | Leaf => None
  | Node _ l x e Leaf => Some (x,e)
  | Node _ l x e r => max_binding r
  end.

Definition choose := min_binding.

(** *** Iteration on elements *)

Fixpoint fold {A: Type} (f: key -> elt -> A -> A) (t: tree) (base: A) : A :=
  match t with
  | Leaf => base
  | Node _ l x e r => fold f r (f x e (fold f l base))
 end.

Fixpoint bindings_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x e r => bindings_aux ((x,e) :: bindings_aux acc r) l
  end.

Definition bindings := bindings_aux nil.

Fixpoint rev_bindings_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x e r => rev_bindings_aux ((x,e) :: rev_bindings_aux acc l) r
  end.

Definition rev_bindings := rev_bindings_aux nil.

Fixpoint cardinal (s : tree) : nat :=
  match s with
   | Leaf => 0
   | Node _ l _ _ r => S (cardinal l + cardinal r)
  end.

Fixpoint maxdepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ _ r => S (max (maxdepth l) (maxdepth r))
 end.

Fixpoint mindepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ _ r => S (min (mindepth l) (mindepth r))
 end.

(** *** Testing universal or existential properties *)

(** We do not use the standard boolean operators of Coq,
    but lazy ones. *)

Fixpoint for_all (f:key->elt->bool) s := match s with
  | Leaf => true
  | Node _ l x e r => f x e &&& for_all f l &&& for_all f r
end.

Fixpoint exists_ (f:key->elt->bool) s := match s with
  | Leaf => false
  | Node _ l x e r => f x e ||| exists_ f l ||| exists_ f r
end.

(** *** Comparison of trees *)

(** The algorithm here has been suggested by Xavier Leroy,
    and transformed into c.p.s. by Benjamin Grégoire.
    The original ocaml code (with non-structural recursive calls)
    has also been formalized (thanks to Function+measure), see
    [ocaml_compare] in [MSetFullAVL]. The following code with
    continuations computes dramatically faster in Coq, and
    should be almost as efficient after extraction.
*)

(** Enumeration of the elements of a tree. This corresponds
    to the "samefringe" notion in the litterature. *)

Inductive enumeration :=
 | End : enumeration
 | More : key -> elt -> tree -> enumeration -> enumeration.

(** [cons t e] adds the elements of tree [t] on the head of
    enumeration [e]. *)

Fixpoint cons s e : enumeration :=
 match s with
  | Leaf => e
  | Node _ l x v r => cons l (More x v r e)
 end.

(** One step of comparison of elements *)

Variable eqb : elt->elt->bool.

Definition equal_more x1 v1 (cont:enumeration->bool) e2 :=
 match e2 with
 | End => false
 | More x2 v2 r2 e2 =>
     match K.compare x1 x2 with
      | Eq => eqb v1 v2 &&& cont (cons r2 e2)
      | _ => false
     end
 end.

(** Comparison of left tree, middle element, then right tree *)

Fixpoint equal_cont m1 (cont:enumeration->bool) e2 :=
 match m1 with
  | Leaf => cont e2
  | Node _ l1 x1 v1 r1 =>
     equal_cont l1 (equal_more x1 v1 (equal_cont r1 cont)) e2
  end.

(** Initial continuation *)

Definition equal_end e2 := match e2 with End => true | _ => false end.

(** The complete boolean comparison *)

Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End).

(** Ternary comparison *)

Variable cmp : elt -> elt -> comparison.

(** One step of comparison of bindings *)

Definition compare_more x1 d1 (cont:enumeration -> comparison) e2 :=
  match e2 with
  | End => Gt
  | More x2 d2 r2 e2 =>
    lex (K.compare x1 x2) (lex (cmp d1 d2) (cont (cons r2 e2)))
  end.

(** Comparison of left tree, middle element, then right tree *)

Fixpoint compare_cont s1 (cont:enumeration -> comparison) e2 :=
  match s1 with
  | Leaf => cont e2
  | Node _ l1 x1 d1 r1 =>
    compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2
  end.

(** Initial continuation *)

Definition compare_end (e2:enumeration) :=
  match e2 with End => Eq | _ => Lt end.

(** The complete comparison *)

Definition compare m1 m2 :=
  compare_cont m1 compare_end (cons m2 End).

End Elt.

(** *** Map *)

Fixpoint map {elt elt'}(f : elt -> elt')(m : t elt) : t elt' :=
  match m with
   | Leaf _  => Leaf _
   | Node h l x d r => Node h (map f l) x (f d) (map f r)
  end.

(** *** Mapi *)

Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
  match m with
   | Leaf _ => Leaf _
   | Node h l x d r => Node h (mapi f l) x (f x d) (mapi f r)
  end.

End Ops.

(** ** Props: correctness proofs for the generic operations *)

Module Type Props (K:OrderedType)(Info:InfoTyp)(Import M:Ops K Info).

Implicit Types x y k : K.t.

Local Infix "==" := K.eq (at level 70).

(** Overloaded "<" notation *)

Class LessThan (A B : Type) := lessthan : A -> B -> Prop.
Local Infix "<" := lessthan.

#[export] Instance lt_key_key : LessThan K.t K.t := K.lt.

(** *** Occurrence in a tree *)

Module Ind. (* Module allowing a "Definition" of MapsTo below. *)

Inductive MapsTo elt (x : key)(e : elt) : t elt -> Prop :=
| MapsRoot l r h y : x == y -> MapsTo x e (Node h l y e r)
| MapsLeft l r h y e' : MapsTo x e l -> MapsTo x e (Node h l y e' r)
| MapsRight l r h y e' : MapsTo x e r -> MapsTo x e (Node h l y e' r).

End Ind.
Definition MapsTo := Ind.MapsTo.
Import Ind. (* In the proofs below, let's work with Ind.MapsTo. *)

Local Notation "m @ x ↦ e" := (MapsTo x e m)
 (at level 9, format "m '@' x  '↦'  e").

Definition In elt k m := exists e:elt, m@k ↦ e.
Local Infix "∈" := In (at level 70).

Definition Eqdom elt (m m' : t elt) := forall k, k ∈ m <-> k ∈ m'.
Definition Equal elt (m m' : t elt) := forall k, find k m = find k m'.
Definition Equiv elt (R:elt->elt->Prop) m m' :=
 Eqdom m m' /\ (forall k e e', m@k ↦ e -> m'@k ↦ e' -> R e e').
Definition Equivb elt cmp := @Equiv elt (Cmp cmp).

Definition AllKeys elt (P:key->Prop) (m : t elt) :=
 forall x, x ∈ m -> P x.

(** *** Binary search trees *)

(** Strict order between keys and trees:
    [x < m] when [x] is strictly smaller than any key in [m].
    [m < x] when [x] is strictly greater than any key in [m].
    [m < m'] when all keys in [m] are lower than all keys in [m']. *)

#[export] Instance lt_key_map elt : LessThan K.t (t elt) :=
 fun x => AllKeys (lessthan x).
#[export] Instance lt_map_key elt : LessThan (t elt) K.t :=
 fun m x => AllKeys (fun y => y < x) m.
#[export] Instance lt_map_map elt : LessThan (t elt) (t elt) :=
 fun m m' => AllKeys (fun x => x < m') m.

(** [Bst t] : [t] is a binary search tree *)

Inductive Bst elt : t elt -> Prop :=
| BSLeaf : Bst (Leaf _)
| BSNode h x e l r : Bst l -> Bst r -> l < x -> x < r ->
  Bst (Node h l x e r).

(** [Bst] is the (decidable) invariant our trees will have to satisfy. *)

Definition IsOk := Bst.
Class Ok elt (m:t elt) : Prop := ok : Bst m.

Module F := OrderedTypeFacts K.
Module O := KeyOrderedType K.
Module L := MMaps.OrdList.MakeRaw K.

Scheme tree_ind := Induction for tree Sort Prop.

(** *** Automation and dedicated tactics *)

Local Hint Constructors tree MapsTo Bst : map.
Local Hint Unfold Ok In : map.
Local Hint Immediate F.eq_sym : map.
Local Hint Resolve F.eq_refl : map.

Tactic Notation "factornode" ident(s) :=
 try clear s;
 match goal with
   | |- context [Node ?h ?l ?x ?e ?r] =>
       set (s:=Node h l x e r) in *; clearbody s; clear l x e r; try clear h
   | _ : context [Node ?h ?l ?x ?e ?r] |- _ =>
       set (s:=Node h l x e r) in *; clearbody s; clear l x e r; try clear h
 end.

(** A tactic for cleaning hypothesis after use of functional induction. *)

Ltac cleanf :=
 match goal with
  | H : K.compare _ _ = Eq |- _ =>
    rewrite ?H; apply F.compare_eq in H; cleanf
  | H : K.compare _ _ = Lt |- _ =>
    rewrite ?H; apply F.compare_lt_iff in H; cleanf
  | H : K.compare _ _ = Gt |- _ =>
    rewrite ?H; apply F.compare_gt_iff in H; cleanf
  | _ => idtac
 end.

(** A tactic to repeat [inversion_clear] on all hyps of the
    form [(f (Node ...))] *)

Ltac inv f :=
  match goal with
     | H:f (Leaf _) |- _ => inversion_clear H; inv f
     | H:f _ (Leaf _) |- _ => inversion_clear H; inv f
     | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f
     | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f
     | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
     | _ => idtac
  end.

Ltac inv_all :=
  match goal with
     | H:_ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ _ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ _ (Leaf _) |- _ => inversion_clear H; inv_all
     | H:_ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | H:_ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | H:_ _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv_all
     | _ => idtac
  end.

Ltac chok := change Bst with Ok in *.
Ltac autok := chok; auto with typeclass_instances map.
Ltac invok := inv_all; chok.
Ltac autom := auto with map.
Ltac eautom := eauto with map.

Ltac intuition_m := repeat (intuition (auto with map); inv MapsTo).

Ltac redk :=
  match goal with
  | |- context [ O.eqke ?p ?q ] =>
    change (O.eqke p q) with (fst p == fst q /\ snd p = snd q); simpl
  | H : context [ O.eqke ?p ?q] |- _ =>
    change (O.eqke p q) with (fst p == fst q /\ snd p = snd q) in H;
    simpl in H
  end.

Arguments Ok {elt} m.
Arguments Equal {elt} m m'.
Arguments Eqdom {elt} m m'.

#[export] Instance Equal_equiv {elt} : Equivalence (@Equal elt).
Proof. split; congruence. Qed.
#[export] Instance Eqdom_equiv {elt} : Equivalence (@Eqdom elt).
Proof.
 split; try firstorder. intros x y z E E' k. now rewrite (E k), (E' k).
Qed.

(** Facts about [MapsTo] and [In]. *)

Lemma mapsto_in {elt} k (e:elt) m : m@k ↦ e -> k ∈ m.
Proof.
 eauto with map.
Qed.
Local Hint Resolve mapsto_in : map.

Lemma in_mapsto {elt} k m : k ∈ m -> exists e:elt, m@k ↦ e.
Proof.
 auto with map.
Qed.

Lemma mapsto_eq {elt} m x y (e:elt) :
  x == y -> m@x ↦ e -> m@y ↦ e.
Proof.
 induction m; simpl; intuition_m; eauto. constructor. F.order.
Qed.
Local Hint Immediate mapsto_eq : map.

#[export] Instance MapsTo_compat {elt} :
  Proper (K.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt).
Proof.
 split; subst; now apply mapsto_eq.
Qed.

Lemma leaf_mapsto {elt} y e : (Leaf elt)@y ↦ e <-> False.
Proof.
 now split.
Qed.

Lemma node_mapsto {elt} l x (e:elt) r h y v :
 (Node h l x e r)@y ↦ v <->
   l@y ↦ v \/ (y == x /\ v = e) \/ r@y ↦ v.
Proof.
 intuition_m; subst; auto with map.
Qed.

#[export] Instance in_compat {elt} :
  Proper (K.eq==>Logic.eq==>iff) (@In elt).
Proof.
 intros x x' E m m' <-.
 split; intros (e,M); exists e. now rewrite <-E. now rewrite E.
Qed.

Lemma in_leaf {elt} y : y ∈ (@Leaf elt) <-> False.
Proof.
 unfold In. setoid_rewrite leaf_mapsto. firstorder.
Qed.

Lemma in_node {elt} l x (e:elt) r h y :
  y ∈ (Node h l x e r) <-> y ∈ l \/ y == x \/ y ∈ r.
Proof.
 unfold In. setoid_rewrite node_mapsto. firstorder.
 exists e. intuition.
Qed.

Ltac intuition_in :=
 rewrite ?in_node, ?in_leaf;
 intuition (auto with map typeclass_instances).

Lemma in_left {elt} l x (e:elt) r h y : y ∈ l -> y ∈ (Node h l x e r).
Proof.
 intuition_in.
Qed.

Lemma in_right {elt} l x (e:elt) r h y : y ∈ r -> y ∈ (Node h l x e r).
Proof.
 intuition_in.
Qed.
Local Hint Resolve in_left in_right : map.

(** Results about [AllKeys] *)

Lemma allkeys_leaf {elt} P : AllKeys P (@Leaf elt).
Proof.
 intros y (e,M). inversion M.
Qed.

Lemma allkeys_node {elt} P h l x (e:elt) r :
  Proper (K.eq ==> iff) P ->
  AllKeys P (Node h l x e r) <-> AllKeys P l /\ P x /\ AllKeys P r.
Proof.
 unfold AllKeys. setoid_rewrite in_node. firstorder. apply H0; autom.
Qed.

 #[export] Instance allkeys_m {elt} :
 Proper ((K.eq ==> iff) ==> Eqdom ==> iff) (@AllKeys elt).
Proof.
 intros P P' HP m m' Hm. unfold AllKeys.
 split; intros H x IN.
 - rewrite <- (HP x); autom. apply H, Hm; autom.
 - rewrite (HP x); autom. apply H, Hm; autom.
Qed.

(** Results about [<] *)

Lemma above_leaf {elt} x : @Leaf elt < x.
Proof.
 apply allkeys_leaf.
Qed.

Lemma above_node {elt} x h l y (e:elt) r :
 Node h l y e r < x <-> l < x /\ y < x /\ r < x.
Proof.
 apply allkeys_node with (P := fun z => z < x). now intros ? ? ->.
Qed.

#[export] Instance above_m {elt} :
  Proper (@Eqdom elt ==> K.eq ==> iff) lessthan.
Proof.
 intros until 2. apply allkeys_m; auto. split; F.order.
Qed.

Lemma below_leaf {elt} x : x < @Leaf elt.
Proof.
 apply allkeys_leaf.
Qed.

Lemma below_node {elt} x h l y (e:elt) r :
 x < Node h l y e r <-> x < l /\ x < y /\ x < r.
Proof.
 apply allkeys_node. now intros ? ? ->.
Qed.

#[export] Instance below_m {elt} :
  Proper (K.eq ==> @Eqdom elt ==> iff) lessthan.
Proof.
 intros until 2. apply allkeys_m; auto. split; F.order.
Qed.

 #[export] Instance apart_m {elt} :
 Proper (@Eqdom elt ==> @Eqdom elt ==> iff) lessthan.
Proof.
 intros until 2. apply allkeys_m; auto.
 intros until 1. now apply below_m.
Qed.

(** Helper tactic concerning order of keys. *)

Ltac invlt :=
  match goal with
  | H : _ < Node _ _ _ _ _ |- _ => rewrite !below_node in H; invlt
  | H : Node _ _ _ _ _ < _ |- _ => rewrite !above_node in H; invlt
  | _ => idtac
  end.

Ltac ok :=
 invok;
 match goal with
   | |- Ok (Node _ _ _ _ _) => constructor; autok; ok
   | |- _ < Node _ _ _ _ _ => rewrite !below_node; repeat split; ok
   | |- Node _ _ _ _ _ < _ => rewrite !above_node; repeat split; ok
   | _ => eauto with typeclass_instances map
 end.

Ltac order := intros; match goal with
 | IN: _ ∈ ?m, LT: ?m < _ |- _ => specialize (LT _ IN); order
 | IN: _ ∈ ?m, LT: _ < ?m |- _ => specialize (LT _ IN); order
 | M: ?m @ _ ↦ _, LT: ?m < _ |- _ => specialize (LT _ (mapsto_in M)); order
 | M: ?m @ _ ↦ _, LT: _ < ?m |- _ => specialize (LT _ (mapsto_in M)); order
 | _ => simpl in *; F.order
end.

Lemma above_notin {elt} (m:t elt) x : m < x -> ~ x ∈ m.
Proof.
 intros until 2; order.
Qed.

Lemma below_notin {elt} (m:t elt) x : x < m -> ~ x ∈ m.
Proof.
 intros until 2; order.
Qed.

Lemma above_trans {elt} (m:t elt) x y : x < y -> m < x -> m < y.
Proof.
 intros until 3; order.
Qed.

Lemma below_trans {elt} (m:t elt) x y : y < x -> x < m -> y < m.
Proof.
 intros until 3; order.
Qed.

Local Hint Resolve above_notin above_trans below_notin below_trans : map.

Lemma between {elt} (m m':t elt) x :
  m < x -> x < m' -> m < m'.
Proof.
 intros until 4; order.
Qed.

Lemma apart_node_l {elt} h l x v r (m:t elt) :
  (Node h l x v r) < m <-> l < m /\ x < m /\ r < m.
Proof.
 apply allkeys_node. now intros ? ? ->.
Qed.

Lemma apart_node_r {elt} h l x v r (m:t elt) :
  m < (Node h l x v r) <-> m < l /\ m < x /\ m < r.
Proof.
 unfold "<"; unfold lt_map_map, lt_map_key, AllKeys.
 setoid_rewrite below_node. split; [ | intuition].
 intros H; repeat split; intros y IN; now specialize (H y IN).
Qed.

(** Bst is decidable *)

#[export] Instance Bst_Ok {elt} (m : t elt) (B : Bst m) : Ok m := B.

Fixpoint above {elt} x (m : t elt) :=
 match m with
  | Leaf _ => true
  | Node _ l y _ r =>
     match K.compare x y with
      | Gt => above x l && above x r
      | _ => false
     end
 end.

Fixpoint below {elt} x (m : t elt) :=
 match m with
  | Leaf _ => true
  | Node _ l y _ r =>
     match K.compare x y with
      | Lt => below x l && below x r
      | _ => false
     end
 end.

Fixpoint isok {elt} (m : t elt) :=
 match m with
  | Leaf _ => true
  | Node _  l x _ r => isok l && isok r && above x l && below x r
 end.

Lemma above_iff {elt} x (m:t elt) :
  m < x <-> above x m = true.
Proof.
 induction m as [|c l IHl y v r IHr]; simpl.
 - intuition. apply above_leaf.
 - rewrite above_node.
   case K.compare_spec.
   + split; intros; try easy. intuition. order.
   + split; intros; try easy. intuition. order.
   + rewrite andb_true_iff; intuition.
Qed.

Lemma below_iff {elt} x (m:t elt) :
  x < m <-> below x m = true.
Proof.
 induction m as [|c l IHl y v r IHr]; simpl.
 - intuition. apply below_leaf.
 - rewrite below_node.
   case K.compare_spec.
   + split; intros; try easy. intuition. order.
   + rewrite !andb_true_iff. intuition.
   + split; intros; try easy. intuition. order.
Qed.

Lemma isok_iff {elt} (m:t elt) : Ok m <-> isok m = true.
Proof.
 induction m as [|c l IHl y v r IHr]; simpl.
 - intuition (auto with map).
 - rewrite !andb_true_iff, <- IHl, <-IHr, <- below_iff, <- above_iff.
   intuition (auto with map); invok; auto.
Qed.

Lemma isok_spec {elt} (m:t elt) : reflect (Ok m) (isok m).
Proof.
 apply iff_reflect, isok_iff.
Qed.

Lemma isok_Ok {elt} (m:t elt) : isok m = true -> Ok m.
Proof. apply isok_iff. Qed.

Section Elt.
Variable elt:Type.
Implicit Types m r : t elt.

(** *** Membership *)

Lemma find_1 m x e `{!Ok m} : m@x ↦ e -> find x m = Some e.
Proof.
 induction m; simpl; invok.
 - intuition_m.
 - rewrite node_mapsto.
   case K.compare_spec; intuition_m; subst; auto; order.
Qed.

Lemma find_2 m x e : find x m = Some e -> m@x ↦ e.
Proof.
 induction m; simpl; try easy.
 case K.compare_spec; [ intros -> [= ->] | .. ]; intuition_m.
Qed.

Lemma find_spec m x e `{!Ok m} : find x m = Some e <-> m@x ↦ e.
Proof.
 split; auto using find_1, find_2.
Qed.

Lemma find_in m x : find x m <> None -> x ∈ m.
Proof.
 destruct (find x m) eqn:F; intros H.
 - exists e. now apply find_2.
 - now elim H.
Qed.

Lemma in_find m x `{!Ok m} : x ∈ m -> find x m <> None.
Proof.
 intros (e,M). now rewrite (find_1 M).
Qed.

Lemma find_in_iff m x `{!Ok m} :
 find x m <> None <-> x ∈ m.
Proof.
 split; auto using find_in, in_find.
Qed.

Lemma not_find_iff m x `{!Ok m} :
 find x m = None <-> ~ x ∈ m.
Proof.
 rewrite <- find_in_iff; trivial.
 destruct (find x m); split; try easy. now destruct 1.
Qed.

Lemma eq_option_alt (o o':option elt) :
 o=o' <-> (forall e, o=Some e <-> o'=Some e).
Proof.
split; intros.
- now subst.
- destruct o, o'; rewrite ?H; auto. symmetry; now apply H.
Qed.

Lemma find_mapsto_equiv m m' x `{!Ok m, !Ok m'} :
 find x m = find x m' <->
  (forall d, m@x ↦ d <-> m'@x ↦ d).
Proof.
 rewrite eq_option_alt.
 split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec.
Qed.

Lemma find_in_equiv m m' x `{!Ok m, !Ok m'} :
 find x m = find x m' ->
  (x ∈ m <-> x ∈ m').
Proof.
 intros E. split; intros; apply find_in; [ rewrite <- E | rewrite E ];
  apply in_find; auto.
Qed.

Lemma find_compat m x x' `{!Ok m} : x == x' -> find x m = find x' m.
Proof.
 intros E.
 destruct (find x' m) eqn:H.
 - apply find_1; trivial. rewrite E. now apply find_2.
 - rewrite not_find_iff in *; trivial. now rewrite E.
Qed.

Lemma mem_spec m x `{!Ok m} : mem x m = true <-> x ∈ m.
Proof.
 induction m; simpl.
 - now rewrite in_leaf.
 - invok. rewrite in_node. case K.compare_spec; intuition; order.
Qed.

(** *** Empty map *)

 #[export] Instance empty_ok : Ok (empty elt).
Proof.
 constructor.
Qed.

Lemma empty_spec x : find x (empty elt) = None.
Proof.
 reflexivity.
Qed.

(** *** Emptiness test *)

Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None.
Proof.
 destruct m as [|h r x e l]; simpl; split; try easy.
 intros H. specialize (H x). now rewrite F.compare_refl in H.
Qed.

(** *** Elements *)

Definition eq_key : (key*elt) -> (key*elt) -> Prop := @O.eqk elt.
Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @O.eqke elt.
Definition lt_key : (key*elt) -> (key*elt) -> Prop := @O.ltk elt.

Notation eqk := (O.eqk (elt:= elt)).
Notation eqke := (O.eqke (elt:= elt)).
Notation ltk := (O.ltk (elt:= elt)).

Lemma bindings_aux_mapsto m acc x e :
 InA eqke (x,e) (bindings_aux acc m) <-> m@x ↦ e \/ InA eqke (x,e) acc.
Proof.
 revert acc.
 induction m as [ | h l Hl y e' r Hr ]; intros acc; simpl; auto.
 - intuition_m.
 - rewrite Hl, InA_cons, Hr. redk. intuition_m. subst; autom.
Qed.

Lemma bindings_spec1 m x e :
 InA eqke (x,e) (bindings m) <-> m@x ↦ e.
Proof.
 unfold bindings. rewrite bindings_aux_mapsto. rewrite InA_nil. intuition.
Qed.

Lemma bindings_in m x : L.PX.In x (bindings m) <-> x ∈ m.
Proof.
 unfold L.PX.In.
 split; intros (y,H); exists y.
 - now rewrite <- bindings_spec1.
 - unfold L.PX.MapsTo; now rewrite bindings_spec1.
Qed.

Lemma bindings_aux_sort m acc `{!Ok m} :
 sort ltk acc ->
 (forall x e y, InA eqke (x,e) acc -> y ∈ m -> y < x) ->
 sort ltk (bindings_aux acc m).
Proof.
 revert acc.
 induction m as [ | h l Hl y e r Hr ]; intros acc; simpl; intuition.
 invok.
 apply Hl; auto.
 - constructor.
   + apply Hr; eautom.
   + clear Hl Hr.
     apply InA_InfA with (eqA:=eqke); auto with *.
     intros (y',e') Hy'.
     apply bindings_aux_mapsto in Hy'. change (y < y'). intuition; eautom.
 - clear Hl Hr. intros x e' y' Hx Hy'.
   rewrite InA_cons in Hx. redk. destruct Hx as [(Hx,->)|Hx].
   + order.
   + apply bindings_aux_mapsto in Hx. intuition. order. eautom.
Qed.

Lemma bindings_spec2 m `{!Ok m} : sort ltk (bindings m).
Proof.
 unfold bindings; apply bindings_aux_sort; auto. inversion 1.
Qed.
Local Hint Resolve bindings_spec2 : map.

Lemma bindings_spec2w m `{!Ok m} : NoDupA eqk (bindings m).
Proof.
 intros; apply O.Sort_NoDupA; autom.
Qed.

Lemma bindings_aux_cardinal m acc :
 length acc + cardinal m = length (bindings_aux acc m).
Proof.
 revert acc. induction m; simpl; intuition.
 rewrite <- IHm1; simpl.
 rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc.
 f_equal. f_equal. apply Nat.add_comm.
Qed.

Lemma cardinal_spec m : cardinal m = length (bindings m).
Proof.
 exact (bindings_aux_cardinal m nil).
Qed.

Lemma bindings_app :
 forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc.
Proof.
 induction s; simpl; intros; auto.
 rewrite IHs1, IHs2.
 unfold bindings; simpl.
 rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
Qed.

Lemma bindings_node_acc (t1 t2:t elt) x e z acc :
 bindings (Node z t1 x e t2) ++ acc =
 bindings t1 ++ (x,e) :: bindings t2 ++ acc.
Proof.
 unfold bindings; simpl; intros.
 rewrite !bindings_app, !app_nil_r, !app_ass; auto.
Qed.

Lemma bindings_node (t1 t2:t elt) x e z :
 bindings (Node z t1 x e t2) =
 bindings t1 ++ (x,e) :: bindings t2.
Proof.
 rewrite <- (app_nil_r (bindings _)), bindings_node_acc.
 now rewrite app_nil_r.
Qed.

Lemma rev_bindings_aux_rev m acc :
 rev_bindings_aux acc m = rev (bindings m) ++ acc.
Proof.
 revert acc. induction m; simpl; intros; auto.
 rewrite IHm2, IHm1, bindings_node, !rev_app_distr. simpl.
 now rewrite <- !app_assoc.
Qed.

Lemma rev_bindings_rev m : rev_bindings m = rev (bindings m).
Proof.
 unfold rev_bindings. rewrite rev_bindings_aux_rev. apply app_nil_r.
Qed.

Lemma in_bindings k v (m:t elt) : List.In (k,v) (bindings m) -> In k m.
Proof.
 intros IN. exists v. apply bindings_spec1, In_InA; eauto with *.
Qed.

Lemma in_bindings_uniq k k' v v' (m:t elt) `{!Ok m}:
 List.In (k,v) (bindings m) ->
 List.In (k',v') (bindings m) ->
 k == k' -> k = k' /\ v = v'.
Proof.
 induction m as [|c l IHl x e r IHr].
 - now cbn.
 - rewrite !bindings_node, !in_app_iff. simpl. invok.
   intros [INl|[[= <- <-]|INl]] [INr|[[= <- <-]|INr]] E; eauto;
   try apply in_bindings in INl; try apply in_bindings in INr; order.
Qed.

(** *** Fold *)

Definition fold' {A} (f : key -> elt -> A -> A) m :=
  L.fold f (bindings m).

Lemma fold_equiv_aux {A} m (f : key -> elt -> A -> A) (a : A) acc :
 L.fold f (bindings_aux acc m) a = L.fold f acc (fold f m a).
Proof.
 revert a acc.
 induction m; simpl; trivial.
 intros. rewrite IHm1. simpl. apply IHm2.
Qed.

Lemma fold_equiv {A} m (f : key -> elt -> A -> A) (a : A) :
 fold f m a = fold' f m a.
Proof.
 unfold fold', bindings. now rewrite fold_equiv_aux.
Qed.

Lemma fold_spec m {A} (i:A)(f : key -> elt -> A -> A) :
 fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
Proof.
 rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec.
Qed.

(** *** For_all and exists *)

Lemma for_all_spec (f:key->elt->bool) m :
  for_all f m = List.forallb (fun '(k,e) => f k e) (bindings m).
Proof.
induction m; simpl; auto.
rewrite bindings_node, forallb_app; simpl.
rewrite <- !andb_lazy_alt, andb_assoc, (andb_comm (f _ _)).
f_equal; auto. f_equal; auto.
Qed.

Lemma exists_spec (f:key->elt->bool) m :
  exists_ f m = List.existsb (fun '(k,e) => f k e) (bindings m).
Proof.
induction m; simpl; auto.
rewrite bindings_node, existsb_app; simpl.
rewrite <- !orb_lazy_alt, orb_assoc, (orb_comm (f _ _)).
f_equal; auto. f_equal; auto.
Qed.

(** *** Comparison *)

(** [flatten_e e] returns the list of bindings of the enumeration [e]
    i.e. the list of bindings actually compared *)

Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
  | End _ => nil
  | More x e t r => (x,e) :: bindings t ++ flatten_e r
 end.

Lemma flatten_e_bindings :
 forall (l:t elt) r x d z e,
 bindings l ++ flatten_e (More x d r e) =
 bindings (Node z l x d r) ++ flatten_e e.
Proof.
 intros. now rewrite bindings_node, <- app_assoc.
Qed.

Lemma cons_1 : forall (s:t elt) e,
  flatten_e (cons s e) = bindings s ++ flatten_e e.
Proof.
  induction s; auto; intros.
  simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; auto.
Qed.

(** Proof of correction for the comparisons *)

Variable eqb : elt->elt->bool.

Local Notation Leq := (L.equal eqb).

Lemma equal_cont_Leq : forall m1 cont e2 l,
  (forall e, cont e = Leq l (flatten_e e)) ->
  equal_cont eqb m1 cont e2 = Leq (bindings m1 ++ l) (flatten_e e2).
Proof.
 induction m1 as [|h1 l1 Hl1 x1 d1 r1 Hr1]; intros; auto.
 rewrite bindings_node_acc; simpl.
 apply Hl1; auto.
 clear e2; intros [|x2 d2 r2 e2]; simpl; auto.
 case K.compare; auto. rewrite <- andb_lazy_alt. f_equal.
 rewrite <- cons_1; auto.
Qed.

Lemma equal_Leq m1 m2 :
  equal eqb m1 m2 = Leq (bindings m1) (bindings m2).
Proof.
 unfold equal.
 rewrite <- (app_nil_r (bindings m1)).
 replace (bindings m2) with (flatten_e (cons m2 (End _)))
  by (rewrite cons_1; simpl; rewrite app_nil_r; auto).
 apply equal_cont_Leq. now destruct e.
Qed.

Lemma Equivb_bindings m m' :
 Equivb eqb m m' <-> L.Equivb eqb (bindings m) (bindings m').
Proof.
unfold Equivb, L.Equivb; split; split; try red; intros.
do 2 rewrite bindings_in; firstorder.
destruct H.
apply (H2 k); rewrite <- bindings_spec1; auto.
do 2 rewrite <- bindings_in; firstorder.
destruct H.
apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_spec1; auto.
Qed.

Lemma equal_spec (m m':t elt)`{!Ok m, !Ok m'} :
  equal eqb m m' = true <-> Equivb eqb m m'.
Proof.
 rewrite Equivb_bindings, equal_Leq.
 split; [apply L.equal_2 | apply L.equal_1];
   unfold L.Ok; apply bindings_spec2.
Qed.

Variable cmp : elt -> elt -> comparison.

Local Notation Lcmp := (L.compare cmp).

Lemma compare_cont_Lcmp : forall s1 cont e2 l,
  (forall e, cont e = Lcmp l (flatten_e e)) ->
  compare_cont cmp s1 cont e2 =
   Lcmp (bindings s1 ++ l) (flatten_e e2).
Proof.
 induction s1 as [|h1 l1 Hl1 x1 d1 r1 Hr1]; intros; simpl; auto.
 rewrite bindings_node_acc; simpl.
 apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]; simpl; auto.
 case K.compare; auto. case cmp; auto. rewrite <- cons_1; auto.
Qed.

Lemma compare_Lcmp m1 m2 :
 compare cmp m1 m2 = Lcmp (bindings m1) (bindings m2).
Proof.
 unfold compare; simpl.
 rewrite <- (app_nil_r (bindings m1)).
 replace (bindings m2) with (flatten_e (cons m2 (End _))) by
 (rewrite cons_1; simpl; rewrite app_nil_r; auto).
 apply compare_cont_Lcmp. now destruct e.
Qed.

Lemma compare_spec (m m':t elt)`{!Ok m, !Ok m'} :
  compare cmp m m' =
  list_compare (pair_compare K.compare cmp) (bindings m) (bindings m').
Proof. apply compare_Lcmp. Qed.

End Elt.

Section Map.
Variable elt elt' : Type.
Variable f : elt -> elt'.

Lemma map_spec m :
 bindings (map f m) = List.map (fun '(k,e) => (k,f e)) (bindings m).
Proof.
induction m; simpl; auto.
now rewrite !bindings_node, !map_app, IHm1, IHm2.
Qed.

Lemma map_in m x : x ∈ (map f m) <-> x ∈ m.
Proof.
induction m; simpl; intuition_in.
Qed.

 #[export] Instance map_ok m `{!Ok m} : Ok (map f m).
Proof.
induction m; simpl; ok; intro; rewrite map_in; order.
Qed.

End Map.
Section Mapi.
Variable elt elt' : Type.
Variable f : key -> elt -> elt'.

Lemma mapi_spec m :
 bindings (mapi f m) = List.map (fun '(k,e) => (k,f k e)) (bindings m).
Proof.
induction m; simpl; auto.
now rewrite !bindings_node, !map_app, IHm1, IHm2.
Qed.

Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m.
Proof.
induction m; simpl; intuition_in.
Qed.

 #[export] Instance mapi_ok m `{!Ok m} : Ok (mapi f m).
Proof.
induction m; simpl; ok; intro; rewrite mapi_in; order.
Qed.

End Mapi.

Section Elt.
Variable elt : Type.
Implicit Type m : t elt.

(** mindepth / maxdepth (used later in AVLproofs and RBTproofs *)

Local Open Scope nat.

Lemma mindepth_maxdepth m : mindepth m <= maxdepth m.
Proof.
 induction m; simpl; auto.
 rewrite <- Nat.succ_le_mono.
 transitivity (mindepth m1). apply Nat.le_min_l.
 transitivity (maxdepth m1). trivial. apply Nat.le_max_l.
Qed.

Lemma maxdepth_cardinal m : cardinal m < 2^(maxdepth m).
Proof.
 unfold Peano.lt.
 induction m as [|c l IHl x e r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_max_l.
   * apply Nat.le_max_r.
Qed.

Lemma mindepth_cardinal m : 2^(mindepth m) <= S (cardinal m).
Proof.
 unfold Peano.lt.
 induction m as [|c l IHl x e r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_min_l.
   * apply Nat.le_min_r.
Qed.

Lemma maxdepth_log_cardinal m : m <> Leaf _ ->
 Nat.log2 (cardinal m) < maxdepth m.
Proof.
 intros H.
 apply Nat.log2_lt_pow2. destruct m; simpl; intuition (auto with map arith).
 apply maxdepth_cardinal.
Qed.

Lemma mindepth_log_cardinal m : mindepth m <= Nat.log2 (S (cardinal m)).
Proof.
 apply Nat.log2_le_pow2. auto with arith.
 apply mindepth_cardinal.
Qed.

End Elt.

End Props.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.
Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.
Implicit Arguments old.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

(* Why3 assumption *)
Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Set Contextual Implicit.
Implicit Arguments Nil.
Unset Contextual Implicit.
Implicit Arguments Cons.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint infix_plpl (a:Type)(l1:(list a)) (l2:(list a)) {struct l1}: (list
  a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.
Unset Implicit Arguments.

Axiom Append_assoc : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall (a:Type), forall (l:(list a)), ((infix_plpl l
  (Nil :(list a))) = l).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint length (a:Type)(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.
Unset Implicit Arguments.

Axiom Length_nonnegative : forall (a:Type), forall (l:(list a)),
  (0%Z <= (length l))%Z.

Axiom Length_nil : forall (a:Type), forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil :(list a))).

Axiom Append_length : forall (a:Type), forall (l1:(list a)) (l2:(list a)),
  ((length (infix_plpl l1 l2)) = ((length l1) + (length l2))%Z).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint mem (a:Type)(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.
Unset Implicit Arguments.

Axiom mem_append : forall (a:Type), forall (x:a) (l1:(list a)) (l2:(list a)),
  (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x l2)).

Axiom mem_decomp : forall (a:Type), forall (x:a) (l:(list a)), (mem x l) ->
  exists l1:(list a), exists l2:(list a), (l = (infix_plpl l1 (Cons x l2))).

(* Why3 assumption *)
Inductive tree  :=
  | Leaf : tree
  | Node : tree -> tree -> tree .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint depths(d:Z) (t:tree) {struct t}: (list Z) :=
  match t with
  | Leaf => (Cons d (Nil :(list Z)))
  | (Node l r) => (infix_plpl (depths (d + 1%Z)%Z l) (depths (d + 1%Z)%Z r))
  end.
Unset Implicit Arguments.

Axiom depths_head : forall (t:tree) (d:Z), match (depths d
  t) with
  | (Cons x _) => (d <= x)%Z
  | Nil => False
  end.

Axiom depths_unique : forall (t1:tree) (t2:tree) (d:Z) (s1:(list Z))
  (s2:(list Z)), ((infix_plpl (depths d t1) s1) = (infix_plpl (depths d t2)
  s2)) -> ((t1 = t2) /\ (s1 = s2)).

Axiom depths_unique2 : forall (t1:tree) (t2:tree) (d1:Z) (d2:Z), ((depths d1
  t1) = (depths d2 t2)) -> ((d1 = d2) /\ (t1 = t2)).

Axiom depths_prefix : forall (t:tree) (d1:Z) (d2:Z) (s1:(list Z)) (s2:(list
  Z)), ((infix_plpl (depths d1 t) s1) = (infix_plpl (depths d2 t) s2)) ->
  (d1 = d2).

Axiom depths_prefix_simple : forall (t:tree) (d1:Z) (d2:Z), ((depths d1
  t) = (depths d2 t)) -> (d1 = d2).

(* Why3 assumption *)
Definition lt_nat(x:Z) (y:Z): Prop := (0%Z <= y)%Z /\ (x <  y)%Z.

(* Why3 assumption *)
Inductive lex : (Z* Z)%type -> (Z* Z)%type -> Prop :=
  | Lex_1 : forall (x1:Z) (x2:Z) (y1:Z) (y2:Z), (lt_nat x1 x2) -> (lex (x1,
      y1) (x2, y2))
  | Lex_2 : forall (x:Z) (y1:Z) (y2:Z), (lt_nat y1 y2) -> (lex (x, y1) (x,
      y2)).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint reverse (a:Type)(l:(list a)) {struct l}: (list a) :=
  match l with
  | Nil => (Nil :(list a))
  | (Cons x r) => (infix_plpl (reverse r) (Cons x (Nil :(list a))))
  end.
Unset Implicit Arguments.

Axiom reverse_append : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (x:a), ((infix_plpl (reverse (Cons x l1)) l2) = (infix_plpl (reverse l1)
  (Cons x l2))).

Axiom reverse_reverse : forall (a:Type), forall (l:(list a)),
  ((reverse (reverse l)) = l).

Axiom Reverse_length : forall (a:Type), forall (l:(list a)),
  ((length (reverse l)) = (length l)).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint forest_depths(f:(list (Z* tree)%type)) {struct f}: (list Z) :=
  match f with
  | Nil => (Nil :(list Z))
  | (Cons (d, t) r) => (infix_plpl (depths d t) (forest_depths r))
  end.
Unset Implicit Arguments.

Axiom forest_depths_append : forall (f1:(list (Z* tree)%type)) (f2:(list (Z*
  tree)%type)), ((forest_depths (infix_plpl f1
  f2)) = (infix_plpl (forest_depths f1) (forest_depths f2))).

(* Why3 assumption *)
Definition greedy(d1:Z) (t1:tree) (l:(list (Z* tree)%type)): Prop :=
  forall (d:Z), (d <  d1)%Z -> forall (t:tree) (s:(list Z)),
  ~ ((infix_plpl (depths d t) s) = (forest_depths (Cons (d1, t1) l))).

(* Why3 assumption *)
Inductive g : (list (Z* tree)%type) -> Prop :=
  | Gnil : (g (Nil :(list (Z* tree)%type)))
  | Gone : forall (d:Z) (t:tree), (g (Cons (d, t) (Nil :(list (Z*
      tree)%type))))
  | Gtwo : forall (d:Z) (t:tree) (l:(list (Z* tree)%type)), (greedy d t l) ->
      ((g l) -> (g (Cons (d, t) l))).

Axiom g_tail : forall (l:(list (Z* tree)%type)) (d:Z) (t:tree),
  (g (reverse (Cons (d, t) l))) -> (g (reverse l)).

Axiom right_nil : forall (l:(list (Z* tree)%type)), (2%Z <= (length l))%Z ->
  ((g l) -> forall (t:tree), ~ ((forest_depths l) = (depths 0%Z t))).

Axiom main_lemma : forall (l:(list (Z* tree)%type)) (d1:Z) (d2:Z) (t1:tree)
  (t2:tree), (~ (d1 = d2)) -> ((g (reverse (Cons (d1, t1) l))) ->
  (g (reverse (Cons (d2, t2) (Cons (d1, t1) l))))).

Require Import Why3. Ltac z := why3 "z3".

(* Why3 goal *)
Theorem WP_parameter_tc : forall (left1:(list (Z* tree)%type)),
  forall (right1:(list (Z* tree)%type)), ((g (reverse left1)) /\
  match left1 with
  | (Cons (d, t) Nil) => (~ (d = 0%Z)) \/ ~ (right1 = (Nil :(list (Z*
      tree)%type)))
  | _ => True
  end) ->
  match right1 with
  | (Cons x x1) =>
      match x1 with
      | Nil => True
      | _ =>
          match x with
          | (x2, x3) =>
              match left1 with
              | (Cons x4 x5) =>
                  match x4 with
                  | (x6, x7) => (x6 = x2) -> (((g (reverse x5)) /\
                      match x5 with
                      | (Cons (d, t) Nil) => (~ (d = 0%Z)) \/ ~ ((Cons (
                          (x6 - 1%Z)%Z, (Node x7 x3)) x1) = (Nil :(list (Z*
                          tree)%type)))
                      | _ => True
                      end) -> ((forall (result:tree), ((depths 0%Z
                      result) = (forest_depths (infix_plpl (reverse x5)
                      (Cons ((x6 - 1%Z)%Z, (Node x7 x3)) x1)))) ->
                      ((depths 0%Z
                      result) = (forest_depths (infix_plpl (reverse left1)
                      right1)))) -> ((forall (t:tree), ~ ((depths 0%Z
                      t) = (forest_depths (infix_plpl (reverse x5) (Cons (
                      (x6 - 1%Z)%Z, (Node x7 x3)) x1))))) -> forall (t:tree),
                      ~ ((depths 0%Z
                      t) = (forest_depths (infix_plpl (reverse left1)
                      right1))))))
                  end
              | Nil => True
              end
          end
      end
  | Nil => True
  end.
destruct right1; simpl; auto.
destruct left1; simpl; auto.
z.
destruct right1; simpl; auto.
intros.
destruct p as (d1, t1); destruct p0 as (d2, t2).
rewrite forest_depths_append; simpl.
replace (d2-1+1)%Z with d2 by z.
intros; subst.
z.
Qed.