Require Import Reals Psatz.
From iris.algebra Require Export ofe.
From iris.program_logic Require Export language.
From discprob.basic Require Import base sval order monad bigop_ext nify.
  From discprob.idxval Require Import idist_pidist_pair pival_dist ival pival ival_dist pival_dist ival_pair pidist_singleton irrel_equiv idist_pidist_pair.
From discprob.monad Require Import monad.
From mathcomp Require Import ssreflect bigop seq choice fintype finset ssrbool eqtype.
Set Default Proof Using "Type".
From discprob.prob Require Import prob countable.

Section prob_language_mixin.
  Context {expr val state : Type}.
  Context (of_val : val → expr).
  Context (to_val : expr → option val).
  Context (prim_step : expr → state → expr → state → list expr → Prop).
  Context (prim_step_prob : expr → state → expr → state → list expr → R).

  Record ProbLanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None;
    mixin_prim_step_count e σ:
      Countable.class_of { esf: expr * state * list expr |
                           prim_step e σ (esf.1.1) (esf.1.2) (esf.2) };
    mixin_prim_step_sum1 e σ:
        (∃ e' σ' efs, prim_step e σ e' σ' efs) →
        is_series (countable_sum (λ t : Countable.Pack (mixin_prim_step_count e σ)
                                        { esf: expr * state * list expr |
                                          prim_step e σ (esf.1.1) (esf.1.2) (esf.2) },
                                    prim_step_prob e σ
                                                   (fst (fst (sval t)))
                                                   (snd (fst (sval t)))
                                                   (snd (sval t)))) 1;
    mixin_prim_step_nonneg : ∀ e1 σ1 e2 σ2 efs, (prim_step_prob e1 σ1 e2 σ2 efs >= 0)%R;
    mixin_prim_step_strict_gt :
    ∀ e1 σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs ↔ (prim_step_prob e1 σ1 e2 σ2 efs > 0)%R
  }.
End prob_language_mixin.

Structure probLanguage := ProbLanguage  {
  expr : Type;
  val : Type;
  state : Type;

  of_val : val → expr;
  to_val : expr → option val;
  prim_step : expr → state → expr → state → list expr → Prop;

  prim_step_prob : expr → state → expr → state → list expr → R;

  prob_language_mixin :
    ProbLanguageMixin of_val to_val prim_step prim_step_prob;
}.

Arguments ProbLanguage {_ _ _ _ _ _ _} _.
Arguments of_val {_} _%V.
Arguments to_val {_} _%E.
Arguments prim_step {_} _ _ _ _ _.
Arguments prim_step_prob {_} _ _ _ _ _.

Section prob_language.
  Context {Λ : probLanguage}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.
  Implicit Types σ : state Λ.

  Definition prob_lang_mixin : LanguageMixin (@of_val Λ) to_val prim_step.
  Proof.
    split.
    - apply prob_language_mixin.
    - apply prob_language_mixin.
    - apply prob_language_mixin.
  Qed.

  Canonical Structure prob_lang : language := Language prob_lang_mixin.

  Class ProbLanguageCtx (K : expr Λ → expr Λ) := {
    pfill_LanguageCtx : LanguageCtx K;
    pfill_prob e1 σ1 e2 σ2 efs :
      to_val e1 = None →
      prim_step_prob e1 σ1 e2 σ2 efs =
      prim_step_prob (K e1) σ1 (K e2) σ2 efs
  }.

  Inductive prim_step_result :=
  | prim_res_step : expr Λ → state Λ → list (expr Λ) → prim_step_result
  | prim_res_irred.

  Definition ival_prim_step e1 σ1 : ival (prim_step_result).
    destruct (ClassicalEpsilon.excluded_middle_informative (reducible e1 σ1)); last first.
    - unshelve (eexists).
      * apply [countType of unit].
      * intros; apply 1%R.
      * intros. apply (prim_res_irred).
      * intros [] => //=; auto with *.
    - set (ty := Countable.Pack (mixin_prim_step_count _ _ _ _ (prob_language_mixin Λ) e1 σ1)
                                { esf: expr Λ * state Λ * list (expr Λ) |
                                  prim_step e1 σ1 (esf.1.1) (esf.1.2) (esf.2) }).
        unshelve (eexists).
      * apply ty.
      * intros [esf Hpf].
        exact (prim_step_prob e1 σ1 (esf.1.1) (esf.1.2) (esf.2)).
      * intros [esf Hpf].
        exact (prim_res_step (esf.1.1) (esf.1.2) (esf.2)).
      * abstract (intros [[[e2 σ2] efs] Hpf];
          apply (mixin_prim_step_nonneg _ _ _ _ (prob_language_mixin Λ))).
  Defined.

  Lemma ivdist_prim_step_sum1 e1 σ1:
    is_series (countable_sum (ival.val (ival_prim_step e1 σ1))) 1%R.
  Proof.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|]; last first.
    - rewrite //=.
      apply Series_correct'; last first.
      { eexists. apply finite.SeriesF_is_seriesC. }
      rewrite finite.SeriesC_SeriesF finite.SeriesF_big_op.
      { rewrite /index_enum [@Finite.enum]unlock //= big_cons big_nil //=. nra. }
    - rewrite //=.
      eapply is_seriesC_ext;
        last eapply (mixin_prim_step_sum1 _ _ _ _ (prob_language_mixin Λ) e1 σ1).
      * intros [[[e2 σ2] efs] Hpf] => //=.
      * eauto.
  Qed.

  Definition ivdist_prim_step e1 σ1 : ivdist (prim_step_result) :=
    {| ivd_ival := ival_prim_step e1 σ1; val_sum1 := ivdist_prim_step_sum1 e1 σ1 |}.

  Lemma ival_stuck_irred_nonval e σ :
    In_isupport prim_res_irred (ival_prim_step e σ) →
    irreducible e σ.
  Proof.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    - rewrite /irreducible. intros. apply not_reducible; eauto.
    - intros (x&Hind&?). rewrite //= in Hind.
      destruct x. congruence.
  Qed.

  Lemma ival_red_non_stuck' e σ:
    reducible e σ →
    ¬ (∃ i, ind (ival_prim_step e σ) i = prim_res_irred).
  Proof.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=.
    intros (e2&σ2&efs&Hstep) ([]&?); congruence.
  Qed.

  Lemma ival_red_non_stuck e σ:
    reducible e σ →
    ¬ (In_isupport prim_res_irred (ival_prim_step e σ)).
  Proof.
    intros ? (i&?&?); eapply ival_red_non_stuck'; eauto.
  Qed.

  Lemma ival_non_stuck_red e σ e' σ' efs:
    (reducible e σ ∨ to_val e = None) →
    (In_isupport (prim_res_step e' σ' efs) (ival_prim_step e σ)) →
    prim_step e σ e' σ' efs.
  Proof.
    intros Hred.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    - rewrite //=. intros ([]&Hind&?). rewrite //= in Hind.
    - rewrite //=. intros (m&Hind&?). rewrite //= in Hind.
      destruct m. inversion Hind; subst; eauto.
  Qed.

  Lemma ivdist_non_stuck_red e σ e' σ' efs:
    (In_isupport (prim_res_step e' σ' efs) (ival_prim_step e σ)) →
    (prim_step e σ e' σ' efs).
  Proof.
    specialize (ival_non_stuck_red e σ e' σ' efs).
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => Hpre //=; last first.
    - intros (x&Hind&?). rewrite //= in Hind.
    - rewrite //=. intros. eapply Hpre; eauto.
  Qed.

  Lemma ivdist_step_idx' e1 σ1 e2 σ2 efs:
    prim_step e1 σ1 e2 σ2 efs →
    ∃ i, ind (ivdist_prim_step e1 σ1) i = prim_res_step e2 σ2 efs
         ∧ (ival.val (ivdist_prim_step e1 σ1) i = prim_step_prob e1 σ1 e2 σ2 efs)%R.
  Proof.
    intros Hstep.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    * exfalso. eapply Hnr. do 3 eexists; eauto.
    * unshelve (eexists).
      { exists (e2, σ2, efs) => //=. }
      rewrite //=.
  Qed.

  Lemma ivdist_step_idx e1 σ1 e2 σ2 efs:
    prim_step e1 σ1 e2 σ2 efs →
    ∃ i, ind (ivdist_prim_step e1 σ1) i = prim_res_step e2 σ2 efs
         ∧ (ival.val (ivdist_prim_step e1 σ1) i > 0)%R.
  Proof.
    intros Hstep.
    edestruct ivdist_step_idx' as (i&?&Heq); eauto; exists i; split; auto.
    rewrite Heq. by apply (prob_language_mixin).
  Qed.

  Lemma irred_non_val_stuck_ivdist e1 σ1:
    irreducible e1 σ1 →
    In_isupport prim_res_irred (ivdist_prim_step e1 σ1).
  Proof.
    intros Hirred.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    - exists (); split => //=. nra.
    - exfalso. destruct Hr as (?&?&?&?). eapply Hirred; eauto.
  Qed.

  Definition pidist_prim_step e1 σ1 : pidist (prim_step_result).
    unshelve (eexists).
    - unshelve (eexists).
      * exact (λ x, (ival_prim_step e1 σ1) = x).
      * eexists; eauto.
    - abstract (intros ? <-; apply ivdist_prim_step_sum1).
  Defined.

  Inductive step_result :=
  | res_step : list (expr Λ) → state Λ → step_result
  | res_stuck.

  Fixpoint tpool_step (tl tp: list (expr Λ)) (σ: state Λ) : pidist step_result :=
    match tp with
    | [::] => mret res_stuck
    | e :: tp' =>
      pidist_union
        (r ← pidist_prim_step e σ;
           match r with
           | prim_res_step e' σ' efs => mret (res_step (tl ++ e' :: tp' ++ efs) σ')
           | prim_res_irred => mret res_stuck
           end)
        ((tpool_step (tl ++ [::e]) tp' σ))
    end.

  Fixpoint tpool_stepN (n: nat) (tp: list (expr Λ)) (σ: state Λ): pidist (step_result) :=
    match n with
    | O => mret (res_step tp σ)
    | S n' =>
      r ← (tpool_step [::] tp σ);
        match r with
        | res_stuck => mret (res_stuck)
        | res_step tp' σ' =>
          tpool_stepN n' tp' σ'
        end
    end.

  Definition trace := list (cfg prob_lang).

  Definition scheduler := trace → nat.

  Inductive trace_step (sch: scheduler) (tr1 tr2 : trace) : Prop :=
    | trace_active_step i ρ1 ρ2 tr0:
          sch tr1 = i →
          tr1 = tr0 ++ [::ρ1] →
          tr2 = tr0 ++ (ρ1 :: ρ2 :: nil) →
          istep i ρ1 ρ2 →
          trace_step sch tr1 tr2
    | trace_stutter_step i ρ1 tr0:
        sch tr1 = i →
        (¬ ∃ ρ2, istep i ρ1 ρ2) →
        tr1 = tr0  ++ [::ρ1] →
        tr2 = tr0  ++ [ρ1; ρ1] →
        trace_step sch tr1 tr2.

  Definition ivdist_tpool_stepi i (tp: list (expr Λ)) (σ: state Λ) : ivdist (step_result) :=
    match (tp !! i) with
    | None => mret res_stuck
    | Some e =>
      r ← ivdist_prim_step e σ;
        match r with
        | prim_res_step e' σ' efs =>
          mret (res_step (list.take i tp ++ (e' :: list.drop (S i) tp) ++ efs) σ')
        | prim_res_irred => mret res_stuck
        end
    end.

  Definition ivdist_trace_step (s: scheduler) (tr: trace) (tp: list (expr Λ)) (σ: state Λ)
    : ivdist (list (expr Λ) * state Λ) :=
      r ← (ivdist_tpool_stepi (s (tr ++ [::(tp, σ)])) tp σ);
        match r with
        | res_step tp' σ' => mret (tp', σ')
        | res_stuck => mret (tp, σ)
        end.

  Fixpoint ivdist_trace_stepN_aux s tr tp σ n :=
    match n with
    | O => mret (tp, σ)
    | S n' =>
      r ← ivdist_trace_step s tr tp σ;
      ivdist_trace_stepN_aux s (tr ++ [::(tp, σ)])  (fst r) (snd r) n'
    end.

  Definition ivdist_tpool_stepN s tp σ n :=
    ivdist_trace_stepN_aux s [::] tp σ n.

  Definition terminates s tr n :=
    ∀ tr' cfg n', n ≤ n' → nsteps (trace_step s) n' tr (tr' ++ [::cfg]) →
               ∃ v tp, (fst cfg) = (of_val v :: tp).

  Lemma terminates_S s tr cfg cfg' i n :
    terminates s (tr ++ [::cfg]) (S n) →
    s (tr ++ [::cfg]) = i →
    istep i cfg cfg' →
    terminates s (tr ++ (cfg :: cfg' :: nil)) n.
  Proof.
    intros Hterm Hlookup Hi tr' cfg'' n'' Hle Hsteps.
    eapply (Hterm _ _ (S n'')); first omega.
    econstructor; [ econstructor |]; eauto.
  Qed.

  Lemma istep_idx_length i (cfg: language.cfg prob_lang) cfg':
    istep i cfg cfg' → (i < length (fst cfg))%nat.
  Proof.
    inversion 1; subst. rewrite app_length //=. omega.
  Qed.

  Lemma ivdist_prim_step_val_mret e σ:
    language.to_val e <> None →
    eq_ivd (ivdist_prim_step e σ) (mret (prim_res_irred)).
  Proof.
    intros Hval.
    rewrite /eq_ivd//=.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [r|?].
    { exfalso. destruct r as (?&?&?&?). eapply Hval. eapply language.val_stuck; eauto. }
    rewrite /language.to_val//= in Hval.
    destruct (to_val e); last congruence.
    rewrite //=.
    eapply eq_ival_quasi_refl.
  Qed.

  Lemma terminates_stutter_None s tr cfg i n :
    terminates s (tr ++ [::cfg]) (S n) →
    s (tr ++ [::cfg]) = i →
    (fst cfg !! i = None) →
    terminates s (tr ++ (cfg :: cfg :: nil)) n.
  Proof.
    intros Hterm Hsch Hi tr' cfg'' n'' Hle Hsteps.
    eapply (Hterm _ _ (S n'')); first omega.
    econstructor; last eauto.
    eapply trace_stutter_step; eauto.
    intros (cfg'&Hstep).
    assert (length (fst cfg) <= i)%nat.
    { eapply lookup_ge_None_1; eauto. }
    feed pose proof (istep_idx_length i cfg cfg'); eauto.
    omega.
  Qed.

  Lemma terminates_stutter_value s tr cfg i ei n :
    terminates s (tr ++ [::cfg]) (S n) →
    s (tr ++ [::cfg]) = i →
    (fst cfg !! i = Some ei) →
    (to_val ei <> None) →
    terminates s (tr ++ (cfg :: cfg :: nil)) n.
  Proof.
    intros Hterm Hsch Hi Hval tr' cfg'' n'' Hle Hsteps.
    eapply (Hterm _ _ (S n'')); first omega.
    econstructor; last eauto.
    eapply trace_stutter_step; eauto.
    intros (cfg'&Hstep).
    inversion Hstep.
    exfalso; eapply Hval. eapply language.val_stuck; eauto.
    subst.
    rewrite list_lookup_middle in Hi; eauto.
    inversion Hi; subst; eauto.
  Qed.

  Lemma terminates_mono s tr n n' :
    n ≤ n' →
    terminates s tr n →
    terminates s tr n'.
  Proof.
    intros Hle Hterm.
    intros tr' cfg n'' Hle'' Hnsteps.
    eapply (Hterm _ _ n''); eauto.
    omega.
  Qed.

  Definition terminating s tr := ∃ n, terminates s tr n.

  Lemma ivdist_prim_step_primitive e σ: ival_primitive (ivdist_prim_step e σ).
  Proof.
   rewrite //=/ival_prim_step.
   destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
   - rewrite /ival_primitive => //=. intros [] [] => //=.
   - rewrite /ival_primitive => //=.
     intros (((?&?)&?)&?) (((?&?)&?)&?) Heq.
     apply sval_inj_pi => //=.
     inversion Heq; eauto.
  Qed.

  Global Instance prob_lang_ctx_proj K `{ProbLanguageCtx K} : LanguageCtx K.
  Proof. apply pfill_LanguageCtx. Qed.

  Lemma ivdist_val_step e1 σ1 e2 σ2 efs i1:
    (reducible e1 σ1 ∨ to_val e1 = None) →
    ind (ivdist_prim_step e1 σ1) i1 = prim_res_step e2 σ2 efs →
    ival.val (ivdist_prim_step e1 σ1) i1 = prim_step_prob e1 σ1 e2 σ2 efs.
  Proof.
    intros Hred. revert i1.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; [].
    rewrite //= => i Heq.
    destruct i as (((?&?)&?)&?).
    inversion Heq; subst; eauto.
  Qed.

  Lemma ivdist_stuck_val_1 e σ i:
    ind (ivdist_prim_step e σ) i = prim_res_irred →
    ival.val (ivdist_prim_step e σ) i = 1%R.
  Proof.
    move: i. rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    intros (?&?). congruence.
  Qed.

  Lemma ivdist_bind_eq_post_fill K `{!ProbLanguageCtx K} e1 σ1:
    (reducible e1 σ1 ∨ to_val e1 = None) →
    eq_ivd (ivdist_prim_step (K e1) σ1)
                 (x ← (ivdist_prim_step e1 σ1);
                  mret (match x with
                        | prim_res_step e2 efs σ => prim_res_step (K e2) efs σ
                        | prim_res_irred => prim_res_irred
                        end)).
  Proof.
    intros Hred.
    symmetry. apply eq_ival_primitive_fmap_bij.
    - apply ivdist_prim_step_primitive.
    - apply ivdist_prim_step_primitive.
    - intros v Hin. destruct v.
      * eapply ival_non_stuck_red in Hin; eauto.
        edestruct ivdist_step_idx as (i&?&?); last first.
        { exists i; split; eauto. }
        by apply fill_step.
      * destruct Hred.
        ** exfalso.
           eapply ival_red_non_stuck; eauto.
        ** apply irred_non_val_stuck_ivdist.
           *** apply ival_stuck_irred_nonval in Hin.
               apply irreducible_fill; eauto.
    - intros v1 v1' ??.
      destruct v1, v1' => //=.
      inversion 1; f_equal. apply: (@fill_inj _ K); auto.
    - rewrite /ivdist_prim_step.
      intros v2 Hin.
      destruct v2 as [e σ2 efs |].
      ** efeed pose proof (ival_non_stuck_red); [| eauto |].
         { left. rewrite //= in Hin. apply ivdist_non_stuck_red in Hin.
           do 3 eexists; eauto.
         }
        rewrite //= in Hin.  edestruct (@fill_step_inv) as (e'&?&?); eauto; subst; try apply _.
           *** destruct Hred; auto. by eapply reducible_not_val; eauto.
           *** rewrite //=. exists (prim_res_step e' σ2 efs); split; eauto.
               edestruct ivdist_step_idx as (i&?&?); last first.
               { exists i; split; eauto. }
               eauto.
      ** destruct Hred as [Hred|Hnonval].
         *** exfalso. eapply ival_red_non_stuck; last by eauto.
             edestruct Hred as (e2&σ2&efs&Hstep).
             exists (K e2), σ2, efs.
             apply fill_step; eauto.
         *** exists prim_res_irred; split; auto.
             apply ival_stuck_irred_nonval in Hin as Hirred.
             apply irred_non_val_stuck_ivdist; auto.
             intros e2 σ2 efs Hstep. by apply (Hirred (K e2) σ2 efs), fill_step.
    - intros i1 i2.
      case_eq (ind (ivdist_prim_step e1 σ1) i1).
      * intros e2 σ2 efs Hind1 Hind2.
        erewrite ivdist_val_step; eauto; last first.
        { destruct Hred as [Hred|Hnonval].
          ** left. edestruct Hred as (?&?&?&?); do 3 eexists. by apply fill_step.
          ** right.  by apply fill_not_val.
        }
        erewrite ivdist_val_step; eauto.
        rewrite -pfill_prob //=.
        destruct Hred; auto. eapply reducible_not_val; eauto.
      * intros. destruct Hred.
        ** exfalso. eapply ival_red_non_stuck'; eauto.
        ** by rewrite ?ivdist_stuck_val_1.
  Qed.

  (* TODO: many of these proofs can be simplified, since reducible e1 σ1 implies
     e1 is not a value, so the left part of the disjunction is not necessary; however
     this disjunction was added on after the fact. *)
  Lemma ivdist_bind_coupling {X} K `{!ProbLanguageCtx K} e1 σ1 (I: pidist X) P:
    ∀ (Ic: irrel_couplingP (ivdist_prim_step e1 σ1) I P),
      (reducible e1 σ1 ∨ to_val e1 = None) →
      irrel_couplingP (ivdist_prim_step (K e1) σ1) I
                      (λ x y,
                       (match x with
                        | prim_res_step e2 σ efs =>
                          ∃ e2' pf, e2 = K e2' ∧ prim_step e1 σ1 e2' σ efs ∧
                                    ival.In_isupport (exist _ (prim_res_step e2' σ efs, y) pf) Ic
                       | prim_res_irred => ∃ pf,
                          ival.In_isupport (exist _ (prim_res_irred, y) pf) Ic
                        end)).
  Proof.
    intros.
      eapply irrel_coupling_proper.
      { symmetry. apply: ivdist_bind_eq_post_fill; eauto. }
      { apply pidist_right_id. }
      eapply irrel_coupling_bind.
      { apply (irrel_coupling_support _ _ _ Ic).  }
      intros x' y' HP.
      eapply irrel_coupling_mret.
      rewrite //= in HP.
      destruct HP as (Hpf&Hin1&Hin2&HIn3).
      destruct x' => //=.
      - do 2 eexists; repeat split; eauto.
        eapply ival_non_stuck_red; eauto.
      - eexists; eauto.
  Qed.

  Definition Kinv K `{LanguageCtx prob_lang K} : expr Λ → expr Λ.
    intros e. destruct (ClassicalEpsilon.excluded_middle_informative (∃ e', K e' = e)) as [Heq|Hneq].
    - apply ClassicalEpsilon.constructive_indefinite_description in Heq as (e'&?).
      exact e'.
    - exact e.
  Defined.

  Lemma Kinv_K K `{!LanguageCtx K} e:
    Kinv K (K e) = e.
  Proof.
    rewrite /Kinv.
    destruct ClassicalEpsilon.excluded_middle_informative as [?|Hfalse].
    - destruct ClassicalEpsilon.constructive_indefinite_description.
        by apply fill_inj.
    - exfalso. apply Hfalse. eauto.
  Qed.

  Lemma ivdist_bind_eq_post_fill_inv K `{!ProbLanguageCtx K} e1 σ1:
    (reducible e1 σ1 ∨ to_val e1 = None) →
    eq_ivd (ivdist_prim_step e1 σ1)
           (x ← (ivdist_prim_step (K e1) σ1);
              mret (match x with
                    | prim_res_step e2 efs σ => prim_res_step (Kinv K e2) efs σ
                    | prim_res_irred => prim_res_irred
                    end)).
  Proof.
    intros Hred.
    setoid_rewrite ivdist_bind_eq_post_fill; auto.
    rewrite /eq_ivd.
    setoid_rewrite ival.ival_bind_mret_mret.
    setoid_rewrite <-ival.ival_right_id at 1.
    eapply ival.ival_bind_congr; first by reflexivity.
    intros [|] => //=; rewrite ?Kinv_K; reflexivity.
  Qed.

  Lemma ivdist_bind_inv_coupling {X} K `{!ProbLanguageCtx K} e1 σ1 (I: pidist X) P:
    ∀ (Ic: irrel_couplingP (ivdist_prim_step (K e1) σ1) I P),
      (reducible e1 σ1 ∨ to_val e1 = None) →
      irrel_couplingP (ivdist_prim_step e1 σ1) I
                      (λ x y,
                       (match x with
                        | prim_res_step e2 σ efs =>
                         ∃ pf, prim_step (K e1) σ1 (K e2) σ efs ∧
                               ival.In_isupport (exist _ (prim_res_step (K e2) σ efs, y) pf) Ic
                       | prim_res_irred => ∃ pf,
                          ival.In_isupport (exist _ (prim_res_irred, y) pf) Ic
                        end)).
  Proof.
    intros Ic Hred.
      eapply irrel_coupling_proper.
      { symmetry. apply: ivdist_bind_eq_post_fill_inv; eauto. }
      { apply pidist_right_id. }
      eapply irrel_coupling_bind.
      { apply (irrel_coupling_support _ _ _ Ic).  }
      intros x' y' HP.
      eapply irrel_coupling_mret.
      rewrite //= in HP.
      destruct HP as (Hpf&Hin1&Hin2&HIn3).
      destruct x' as [e s l|] => //=.
    - assert (reducible (K e1) σ1 ∨ to_val (K e1) = None).
      { destruct Hred as [Hred|Hnonval].
        * left. edestruct Hred as (?&?&?&?). do 3 eexists.
          apply: fill_step; eauto.
        * right. by apply fill_not_val.
      }
        assert (prim_step (K e1) σ1 e s l) as Hstep1.
        { eapply ival_non_stuck_red; eauto. }

        assert (K (Kinv K e) = e) as Hrewrite.
        { eapply fill_step_inv in Hstep1 as (e0&?&?); last first.
          { destruct Hred; auto; eauto; (eapply reducible_not_val); eauto. }

          subst. rewrite Kinv_K. done.
        }

        rewrite Hrewrite.
        do 2 eexists; repeat split; eauto.
    - exists Hpf. auto.
  Qed.

End prob_language.

Arguments prob_lang : clear implicits.
Coercion prob_lang : probLanguage >-> language.

(* See the explanation in ectxLanguage *)

Definition LanguageOfProb (Λ : probLanguage) : language :=
  let '@ProbLanguage E V St of_val to_val prim_step prim_step_prob mix := Λ in
  @Language E V St of_val to_val _
    (@prob_lang_mixin (@ProbLanguage E V St of_val to_val prim_step prim_step_prob mix)).


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import Clocks.
From Coq Require Import PArith.
From Coq Require Import Omega.
From Coq Require Import Sorting.Permutation.

From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

(** * The NLustre dataflow language *)

Module Type NLSYNTAX
       (Import Ids   : IDS)
       (Import Op    : OPERATORS)
       (Import CESyn : CESYNTAX Op).

  (** ** Equations *)

  Inductive equation : Type :=
  | EqDef : ident -> clock -> cexp -> equation
  | EqApp : list ident -> clock -> ident -> list exp -> option (ident * clock) -> equation
  | EqFby : ident -> clock -> const -> exp -> equation.

  Implicit Type eqn: equation.

  (** ** Node *)

  Definition var_defined (eq: equation) : list ident :=
    match eq with
    | EqDef x _ _ => [x]
    | EqApp x _ _ _ _ => x
    | EqFby x _ _ _ => [x]
    end.

  Definition vars_defined (eqs: list equation) : list ident :=
    flat_map var_defined eqs.

  Definition is_fby (eq: equation) : bool :=
    match eq with
    | EqFby _ _ _ _ => true
    | _ => false
    end.

  Definition is_app (eq: equation) : bool :=
    match eq with
    | EqApp _ _ _ _ _ => true
    | _ => false
    end.

  Definition is_def (eq: equation) : bool :=
    match eq with
    | EqDef _ _ _ => true
    | _ => false
    end.

  Record node : Type :=
    mk_node {
        n_name   : ident;
        n_in     : list (ident * (type * clock));
        n_out    : list (ident * (type * clock));
        n_vars   : list (ident * (type * clock));
        n_eqs    : list equation;

        n_ingt0  : 0 < length n_in;
        n_outgt0 : 0 < length n_out;
        n_defd   : Permutation (vars_defined n_eqs)
                               (map fst (n_vars ++ n_out));
        n_vout   : forall out, In out (map fst n_out) ->
                          ~ In out (vars_defined (filter is_fby n_eqs));
        n_nodup  : NoDupMembers (n_in ++ n_vars ++ n_out);
        n_good   : Forall (AtomOrGensym (PSP.of_list gensym_prefs)) (map fst (n_in ++ n_vars ++ n_out)) /\ atom n_name
      }.

  (** ** Program *)

  Definition global := list node.

  Implicit Type G: global.

  Definition find_node (f : ident) : global -> option node :=
    List.find (fun n=> ident_eqb n.(n_name) f).

  (** Structural properties *)

  Lemma find_node_name:
    forall G f n,
      find_node f G = Some n ->
      n.(n_name) = f.
  Proof.
    unfold find_node.
    induction G as [|m]; intros; try discriminate.
    simpl in H.
    destruct (ident_eqb (n_name m) f) eqn: E; auto.
    apply ident_eqb_eq; inv H; auto.
  Qed.

  Lemma find_node_other:
    forall f node G node',
      node.(n_name) <> f ->
      (find_node f (node::G) = Some node'
       <-> find_node f G = Some node').
  Proof.
    intros f node G node' Hnf.
    apply BinPos.Pos.eqb_neq in Hnf.
    simpl.
    unfold ident_eqb.
    rewrite Hnf.
    reflexivity.
  Qed.

  Lemma find_node_In:
    forall G f n,
      find_node f G = Some n ->
      n.(n_name) = f /\ In n G.
  Proof.
    induction G as [|n G IH]. now inversion 1.
    simpl. intros f n' Fn'.
    destruct (ident_eqb n.(n_name) f) eqn:Efn.
    - inv Fn'. apply ident_eqb_eq in Efn; auto.
    - apply IH in Fn'; tauto.
  Qed.

  Lemma is_filtered_eqs:
    forall eqs,
      Permutation
        (filter is_def eqs ++ filter is_app eqs ++ filter is_fby eqs)
        eqs.
  Proof.
    induction eqs as [|eq eqs]; auto.
    destruct eq; simpl.
    - now apply Permutation_cons.
    - rewrite <-Permutation_cons_app.
      apply Permutation_cons; reflexivity.
      now symmetry.
    - symmetry.
      rewrite <-Permutation_app_assoc.
      apply Permutation_cons_app.
      rewrite Permutation_app_assoc.
      now symmetry.
  Qed.

  Lemma is_filtered_vars_defined:
    forall eqs,
      Permutation
        (vars_defined (filter is_def eqs) ++ vars_defined (filter is_app eqs) ++ vars_defined (filter is_fby eqs))
        (vars_defined eqs).
  Proof.
    simpl.
    induction eqs as [|[] eqs]; simpl; auto.
    - rewrite Permutation_app_comm, 2 Permutation_app_assoc.
      apply Permutation_app_head.
      rewrite <-Permutation_app_assoc, Permutation_app_comm; auto.
    - symmetry.
      rewrite <-Permutation_app_assoc.
      apply Permutation_cons_app.
      symmetry.
      rewrite Permutation_app_assoc; auto.
  Qed.

  Lemma NoDup_var_defined_n_eqs:
    forall n,
      NoDup (vars_defined n.(n_eqs)).
  Proof.
    intro n.
    rewrite n.(n_defd).
    apply fst_NoDupMembers.
    apply (NoDupMembers_app_r _ _ n.(n_nodup)).
  Qed.

  Lemma n_eqsgt0:
    forall n, 0 < length n.(n_eqs).
  Proof.
    intro.
    pose proof (n_defd n) as Defd.
    pose proof (n_outgt0 n) as Out.
    unfold vars_defined in Defd.
    apply Permutation_length in Defd.
    rewrite flat_map_length, map_length, app_length in Defd.
    destruct (n_eqs n); simpl in *; omega.
  Qed.

  Definition gather_mem_eq (eq: equation): list ident :=
    match eq with
    | EqDef _ _ _
    | EqApp _ _ _ _ _ => []
    | EqFby x _ _ _ => [x]
    end.

  Definition gather_inst_eq (eq: equation): list (ident * ident) :=
    match eq with
    | EqDef _ _ _
    | EqFby _ _ _ _ => []
    | EqApp i _ f _ _ =>
      match i with
      | [] => []
      | i :: _ => [(i,f)]
      end
    end.

  Definition gather_app_vars_eq (eq: equation): list ident :=
    match eq with
    | EqDef _ _ _
    | EqFby _ _ _ _ => []
    | EqApp xs _ _ _ _ => tl xs
    end.

  Definition gather_mems := flat_map gather_mem_eq.
  Definition gather_insts := flat_map gather_inst_eq.
  Definition gather_app_vars := flat_map gather_app_vars_eq.

  (** Basic syntactical properties *)

  Lemma In_gather_mems_cons:
    forall eq eqs x,
      In x (gather_mems (eq :: eqs))
      <-> (In x (gather_mem_eq eq) \/ In x (gather_mems eqs)).
  Proof.
    destruct eq; simpl; split; intuition.
  Qed.

  Lemma In_gather_insts_cons:
    forall eq eqs x,
      InMembers x (gather_insts (eq :: eqs))
      <-> (InMembers x (gather_inst_eq eq) \/ InMembers x (gather_insts eqs)).
  Proof.
    destruct eq; simpl; try now intuition.
    destruct l.
    - setoid_rewrite app_nil_l. intuition.
    - now setoid_rewrite InMembers_app.
  Qed.

  Lemma In_gather_mems_dec:
    forall x eqs,
      { In x (gather_mems eqs) } + { ~In x (gather_mems eqs) }.
  Proof.
    induction eqs as [|eq eqs IH].
    now right; inversion 1.
    destruct eq; simpl; auto.
    destruct (ident_eq_dec x i).
    now subst; auto.
    destruct IH. auto.
    right. inversion 1; auto.
  Qed.

  Lemma In_gather_insts_dec:
    forall i eqs,
      { InMembers i (gather_insts eqs) } + { ~InMembers i (gather_insts eqs) }.
  Proof.
    induction eqs as [|eq eqs IH].
    now right; inversion 1.
    destruct eq; simpl; auto.
    destruct l as [|i'].
    now destruct IH; auto.
    destruct (ident_eq_dec i' i).
    subst; simpl; auto.
    destruct IH.
    now left; rewrite InMembers_app; auto.
    right; rewrite NotInMembers_app.
    split; auto. inversion 1; auto.
  Qed.

End NLSYNTAX.

Module NLSyntaxFun
       (Ids     : IDS)
       (Op      : OPERATORS)
       (CESyn   : CESYNTAX Op)
       <: NLSYNTAX Ids Op CESyn.
  Include NLSYNTAX Ids Op CESyn.
End NLSyntaxFun.


Tactic Notation "opose" open_constr(foo) := pose foo.
Class Foo := Build_Foo : Set.
Axiom f : forall `{Foo}, Set.
Set Printing Implicit.
Goal forall `{Foo}, True.
Proof.
  intro H.
  pose f.
  opose f.
  Fail let x := (eval hnf in P) in has_evar x.
  let x := (eval hnf in P0) in has_evar x.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Bool List Int63 PArray.
Require Import State SMT_terms.
Local Open Scope array_scope.
Local Open Scope int63_scope.

Section certif.

  Variable t_form : PArray.array Form.form.
  Variable t_atom : PArray.array Atom.atom.

  Local Notation get_atom := (PArray.get t_atom) (only parsing).
  Local Notation get_form := (PArray.get t_form) (only parsing).

  Definition get_eq (x:var) (f : int -> int -> C.t) :=
    match get_form x with
    | Form.Fatom xa =>
      match get_atom xa with
      | Atom.Abop (Atom.BO_eq _) a b => f a b
      | _ => C._true
      end
    | _ => C._true
    end.
  (* Register get_eq as PrimInline. *)

  Fixpoint check_trans_aux (t1 t2:int)
      (eqs:list _lit) (res:_lit) (clause:C.t) : C.t :=
    match eqs with
    | nil =>
      let xres := Lit.blit res in
      get_eq xres (fun t1' t2' =>
         if ((t1 == t1') && (t2 == t2')) ||
            ((t1 == t2') && (t2 == t1')) then
            Lit.lit xres :: clause
         else C._true)
    | leq::eqs =>
      let xeq := Lit.blit leq in
      get_eq xeq (fun t t' =>
          if t2 == t' then
            check_trans_aux t1 t eqs res (Lit.nlit xeq :: clause)
          else
            if t2 == t then
              check_trans_aux t1 t' eqs res (Lit.nlit xeq :: clause)
            else
              if t1 == t' then
                check_trans_aux t t2 eqs res (Lit.nlit xeq :: clause)
              else
                if t1 == t then
                  check_trans_aux t' t2 eqs res (Lit.nlit xeq :: clause)
                else C._true)
    end.

  Definition check_trans (res:_lit) (eqs:list _lit) : C.t :=
    match eqs with
    | nil =>
      let xres := Lit.blit res in
        get_eq xres (fun t1 t2 =>
         if t1 == t2 then Lit.lit xres :: nil else C._true)
    | leq :: eqs =>
      let xeq := Lit.blit leq in
      get_eq xeq
        (fun t1 t2 => check_trans_aux t1 t2 eqs res (Lit.nlit xeq :: nil))
    end.

  Fixpoint build_congr (eqs:list (option _lit))
       (l r:list int) (c:C.t) {struct eqs} :=
    match eqs, l, r with
    | nil, nil, nil => c
    | eq::eqs, t1::l, t2::r =>
      match eq with
      | None => if t1 == t2 then build_congr eqs l r c else C._true
      | Some leq =>
        let xeq := Lit.blit leq in
        get_eq xeq (fun t1' t2' =>
          if ((t1 == t1') && (t2 == t2')) ||
             ((t1 == t2') && (t2 == t1')) then
            build_congr eqs l r (Lit.nlit xeq :: c)
          else C._true)
      end
    | _, _, _ => C._true
    end.

  Definition check_congr (leq:_lit) (eqs:list (option _lit)) :=
    let xeq := Lit.blit leq in
    get_eq xeq (fun t1 t2 =>
      match get_atom t1, get_atom t2 with
      | Atom.Abop o1 a1 a2, Atom.Abop o2 b1 b2 =>
        if Atom.bop_eqb o1 o2 then
           build_congr eqs (a1::a2::nil) (b1::b2::nil) (Lit.lit xeq :: nil)
        else C._true
      | Atom.Auop o1 a, Atom.Auop o2 b =>
        if Atom.uop_eqb o1 o2 then
           build_congr eqs (a::nil) (b::nil) (Lit.lit xeq :: nil)
        else C._true
      | Atom.Aapp f1 args1, Atom.Aapp f2 args2 =>
        if f1 == f2 then build_congr eqs args1 args2 (Lit.lit xeq :: nil)
        else C._true
      | _, _ => C._true
      end).

  Definition check_congr_pred (PA:_lit) (PB:_lit) (eqs:list (option _lit)) :=
    let xPA := Lit.blit PA in
    let xPB := Lit.blit PB in
    match get_form xPA, get_form xPB with
    | Form.Fatom pa, Form.Fatom pb =>
      match get_atom pa, get_atom pb with
      | Atom.Abop o1 a1 a2, Atom.Abop o2 b1 b2 =>
         if Atom.bop_eqb o1 o2 then
          build_congr eqs
          (a1::a2::nil) (b1::b2::nil) (Lit.nlit xPA :: Lit.lit xPB :: nil)
        else C._true
      | Atom.Auop o1 a, Atom.Auop o2 b =>
         if Atom.uop_eqb o1 o2 then
          build_congr eqs
          (a::nil) (b::nil) (Lit.nlit xPA :: Lit.lit xPB :: nil)
        else C._true
      | Atom.Aapp p a, Atom.Aapp p' b =>
        if p == p' then
          build_congr eqs a b (Lit.nlit xPA :: Lit.lit xPB :: nil)
        else C._true
      | _, _ => C._true
      end
    | _, _ => C._true
    end.

  Section Proof.

    Variables (t_i : array SMT_classes.typ_compdec)
              (t_func : array (Atom.tval t_i))
              (ch_atom : Atom.check_atom t_atom)
              (ch_form : Form.check_form t_form)
              (wt_t_atom : Atom.wt t_i t_func t_atom).

    Local Notation interp_hatom :=
      (Atom.interp_hatom t_i t_func t_atom).

    Local Notation interp_form_hatom :=
      (Atom.interp_form_hatom t_i t_func t_atom).

    Local Notation interp_form_hatom_bv :=
      (Atom.interp_form_hatom_bv t_i t_func t_atom).

    Local Notation rho :=
      (Form.interp_state_var interp_form_hatom interp_form_hatom_bv t_form).

    Let wf_t_atom : Atom.wf t_atom.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Let def_t_atom : default t_atom = Atom.Acop Atom.CO_xH.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Let def_t_form : default t_form = Form.Ftrue.
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [H _]; destruct H; auto.
    Qed.

    Let wf_t_form : Form.wf t_form.
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [H _]; destruct H; auto.
    Qed.

    Let wf_rho : Valuation.wf rho.
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto.
    Qed.

    Lemma valid_C_true : C.interp rho C._true.
    Proof.
      apply C.interp_true.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form);trivial.
    Qed.
    Hint Resolve valid_C_true.

    Local Notation interp := (Atom.interp t_i t_func t_atom).

    Lemma wf_interp_form : forall x,
       rho x = Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form.[x]).
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form).
      destruct H; intros x;rewrite Form.wf_interp_form;trivial.
    Qed.

    Local Notation get_type :=
        (Atom.get_type t_i t_func t_atom).

    Local Notation check_type :=
        (Atom.check_aux t_i t_func get_type).

    Lemma get_eq_interp :
      forall (l:_lit) (f:Atom.hatom -> Atom.hatom -> C.t),
       (forall xa, t_form.[Lit.blit l] = Form.Fatom xa ->
        forall t a b, t_atom.[xa] = Atom.Abop (Atom.BO_eq t) a b ->
        rho (Lit.blit l) =
          Atom.interp_bool t_i
           (Atom.apply_binop t_i t t Typ.Tbool (Typ.i_eqb t_i t)
              (interp_hatom a) (interp_hatom b)) ->
        Typ.eqb (get_type a) t -> Typ.eqb (get_type b) t ->
        C.interp rho (f a b)) ->
      C.interp rho (get_eq (Lit.blit l) f).
    Proof.
      intros l f Hf;unfold get_eq.
      case_eq (t_form.[Lit.blit l]);trivial;intros.
      case_eq (t_atom.[i]);trivial;intros.
      destruct b;trivial.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H0, def_t_atom;discriminate.
      apply H1 in H2;clear H1;rewrite H0 in H2;simpl in H2.
      rewrite !andb_true_iff in H2;decompose [and] H2;clear H2.
      apply Hf with (2:= H0);trivial.
      rewrite wf_interp_form, H;simpl.
      unfold Atom.interp_form_hatom, Atom.interp_hatom at 1;simpl.
      rewrite Atom.t_interp_wf, H0;simpl;trivial.
    Qed.

    Let tunicity : forall A T U, Typ.eqb A T -> Typ.eqb A U -> T = U.
    Proof. intros A T U; rewrite !Typ.eqb_spec; intros; subst T U; auto. Qed.

    Ltac tunicity :=
      match goal with
      | [ H1 : is_true (Typ.eqb ?a ?t1),
          H2 : is_true (Typ.eqb ?a ?t2) |- _ ] =>
        assert (W:= tunicity _ _ _ H1 H2)
      | _ => idtac
      end.

    Lemma interp_binop_eqb_sym :
      forall u a b,
      Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u) a b =
      Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u) b a.
    Proof.
      unfold Atom.apply_binop;simpl;intros u (ta,va) (tb,vb).
      destruct (Typ.cast ta u);destruct (Typ.cast tb u);trivial.
      apply f_equal; apply eq_true_iff_eq.
      match goal with |- ?x = _ <-> ?y = _ =>
                      change (is_true x <-> is_true y) end.
      split; intro; rewrite Typ.i_eqb_sym in H; auto.
    Qed.

    Lemma interp_binop_eqb_trans:
      forall u a b c,
      Typ.eqb (get_type a) u -> Typ.eqb (get_type b) u -> Typ.eqb (get_type c) u ->
      Atom.interp_bool t_i
        (Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u)
           (interp_hatom a) (interp_hatom b)) ->
      Atom.interp_bool t_i
        (Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u)
           (interp_hatom b) (interp_hatom c)) ->
      Atom.interp_bool t_i
        (Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u)
           (interp_hatom a) (interp_hatom c)).
    Proof.
      intros u a b c Ha Hb Hc.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom c). rewrite Typ.eqb_spec in Ha. rewrite Typ.eqb_spec in Hb. rewrite Typ.eqb_spec in Hc. unfold Atom.get_type in Ha, Hb, Hc. rewrite Ha, Hb, Hc. intros [va HHa] [vb HHb] [vc HHc].
      unfold Atom.interp_hatom.
      rewrite HHa, HHb, HHc;simpl;rewrite Typ.cast_refl.
      unfold Atom.interp_bool;simpl.
      apply Typ.i_eqb_trans.
    Qed.

    Lemma check_trans_aux_correct :
      forall eqs u t1 t2 res c,
       Typ.eqb (get_type t1) u -> Typ.eqb (get_type t2) u ->
       Atom.interp_bool t_i (interp (Atom.Abop (Atom.BO_eq u) t1 t2)) \/
       C.interp rho c ->
       C.interp rho (check_trans_aux t1 t2 eqs res c).
    Proof.
      induction eqs;simpl;intros.
      apply get_eq_interp;intros.
      match goal with |- context [if ?b then _ else _] => case_eq b end;
       intros;trivial.
      simpl;rewrite Lit.interp_lit;unfold Var.interp.
      destruct H1;[ | rewrite H1,orb_true_r;auto].
      rewrite orb_true_iff, !andb_true_iff in H7;destruct H7 as
        [[H7 H8] | [H7 H8]].
      rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst.
      tunicity. subst t. rewrite H4, H1;auto.
      rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst.
      tunicity. subst t;rewrite interp_binop_eqb_sym in H1;rewrite H4, H1;auto.
      apply get_eq_interp;intros.
      destruct (Int63Properties.reflect_eqb t2 b);subst;tunicity; try subst t.
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (4:= H1);trivial.
      rewrite interp_binop_eqb_sym;trivial.
      destruct (Int63Properties.reflect_eqb t2 a0); subst;tunicity; try subst t.
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (4:= H1);trivial.
      destruct (Int63Properties.reflect_eqb t1 b);subst;tunicity; try subst t.
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (5:= H1);trivial.
      destruct (Int63Properties.reflect_eqb t1 a0);[subst;tunicity;try subst t|auto].
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (5:= H1);trivial.
      rewrite interp_binop_eqb_sym;trivial.
    Qed.

    Lemma valid_check_trans :
      forall res eqs,
       C.interp rho (check_trans res eqs).
    Proof.
      unfold check_trans;intros res [ | leq eqs].
      apply get_eq_interp;intros.
      destruct (Int63Properties.reflect_eqb a b).
      unfold C.interp; simpl; rewrite orb_false_r.
      unfold Lit.interp; simpl; rewrite Lit.is_pos_lit.
      unfold Var.interp; simpl; rewrite Lit.blit_lit.
      rewrite H1.
      unfold Atom.interp_bool; simpl.
      rewrite e; simpl.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H3. rewrite H3. intros [vb HHb].
      unfold Atom.interp_hatom.
      rewrite HHb;simpl;rewrite Typ.cast_refl;simpl.
      apply Typ.i_eqb_refl.
      auto.
      apply get_eq_interp;intros.
      apply check_trans_aux_correct with t;trivial.
      simpl;rewrite Lit.interp_nlit;unfold Var.interp. rewrite <- H1.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur t *)
      destruct (rho (Lit.blit leq));auto.
    Qed.

    Inductive Forall2 A B (P:A->B->Prop) : list A -> list B -> Prop :=
    | Forall2_nil : Forall2 A B P nil nil
    | Forall2_cons :
       forall a b la lb, P a b -> Forall2 A B P la lb ->
         Forall2 A B P (a::la) (b::lb).

    Lemma build_congr_correct : forall lp l r c,
      (Forall2 _ _ (fun a b => interp_hatom a = interp_hatom b) l r -> C.interp rho c) ->
      C.interp rho (build_congr lp l r c).
    Proof.
      induction lp;destruct l;destruct r;simpl;trivial;intros.
      apply H;constructor.
      destruct a.
      apply get_eq_interp;intros.
      match goal with |- context [if ?x then _ else _] =>
       case_eq x;intros;auto end.
      apply IHlp;simpl;intros.
      rewrite Lit.interp_nlit;unfold Var.interp.
      case_eq (rho (Lit.blit i1));intros;simpl;[ | auto].
      apply H;constructor;trivial.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H3. rewrite Typ.eqb_spec in H4. unfold Atom.get_type in H3, H4. rewrite H3,H4. intros [va HHa] [vb HHb].
      revert H7;rewrite H2;unfold Atom.apply_binop; simpl.
      unfold Atom.interp_hatom.
      rewrite HHa, HHb;simpl;rewrite Typ.cast_refl;simpl.
      intros W;change (is_true (Typ.i_eqb t_i t va vb)) in W.
      rewrite Typ.i_eqb_spec in W.
      rewrite orb_true_iff, !andb_true_iff in H5;destruct H5 as
        [ [H5 H7] | [H5 H7]].
      rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst.
      rewrite HHa, HHb;trivial.
      rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst.
      rewrite HHa, HHb;trivial.
      destruct (Int63Properties.reflect_eqb i i0);[subst | auto].
      apply IHlp;intros;apply H;constructor;auto.
    Qed.

    Lemma valid_check_congr :
       forall leq eqs,
          C.interp rho (check_congr leq eqs).
    Proof.
      unfold check_congr;intros leq eqs;apply get_eq_interp;intros.
      case_eq (t_atom .[ a]);intros;auto;
      case_eq (t_atom .[ b]);intros;auto.
      (* uop *)
      destruct (Atom.reflect_uop_eqb u u0);[subst | auto].
      apply build_congr_correct;intros.
      simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp.
      rewrite H1.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb].
      unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl.
      rewrite HHb, HHa. simpl.
      rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa.
      rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb.
      rewrite Typ.cast_refl;simpl.
      assert (Atom.Bval t_i t va = Atom.Bval t_i t vb).
       inversion H6;subst.
       unfold Atom.interp_hatom in H10.
       rewrite <- HHa; rewrite <- HHb, H10;trivial.
       inversion H7.
       apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial.
       rewrite H9.
       apply Typ.i_eqb_refl.
      intros x y;destruct (Typ.reflect_eqb x y);auto.
      (* bop *)
      destruct (Atom.reflect_bop_eqb b0 b1);[subst | auto].
      apply build_congr_correct;intros.
      simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp.
      rewrite H1.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb].
      unfold Atom.apply_binop. unfold Atom.interp_hatom;simpl.
      rewrite HHb, HHa;simpl.
      rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa.
      rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb.
      rewrite Typ.cast_refl;simpl.
      assert (Atom.Bval t_i t va = Atom.Bval t_i t vb).
       inversion H6;clear H6;subst.
       inversion H12;clear H12;subst.
       unfold Atom.interp_hatom in H10, H8.
       rewrite <- HHa. rewrite <- HHb, H10, H8;trivial.
      inversion H7.
      apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial.
      rewrite H9.
      apply Typ.i_eqb_refl.
      intros x y;destruct (Typ.reflect_eqb x y);auto.
      (* op *)
      destruct (Int63Properties.reflect_eqb i i0);[subst | auto].
      apply build_congr_correct;intros.
      simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp.
      rewrite H1.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb].
      unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl.
      rewrite HHb, HHa;simpl.
      rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa.
      rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb.
      rewrite Typ.cast_refl;simpl.
      assert (Atom.Bval t_i t va = Atom.Bval t_i t vb).
        rewrite <- HHa;rewrite <- HHb;destruct (t_func.[i0]).
        apply f_equal;clear HHa HHb va vb H5 H4.
        induction H6;simpl;trivial.
        unfold Atom.interp_hatom in H4.
        rewrite IHForall2, H4;trivial.
      inversion H7.
      apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial.
      rewrite H9.
      apply Typ.i_eqb_refl.
      intros x y;destruct (Typ.reflect_eqb x y);auto.
    Qed.

    Lemma valid_check_congr_pred :
       forall lpa lpb eqs,
          C.interp rho (check_congr_pred lpa lpb eqs).
    Proof.
      unfold check_congr_pred;intros.
      case_eq (t_form.[Lit.blit lpa]);auto.
      case_eq (t_form.[Lit.blit lpb]);auto;intros.
      case_eq (t_atom.[i0]);auto; case_eq (t_atom.[i]);auto;intros.
      (* uop *)
      destruct (Atom.reflect_uop_eqb u0 u);[subst | auto].
      apply build_congr_correct;simpl;intros.
      rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp.
      replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)).
       destruct (rho (Lit.blit lpa));reflexivity.
      rewrite !wf_interp_form, H, H0;simpl.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H1, def_t_atom;discriminate.
      assert (i0 < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H2, def_t_atom;discriminate.
      apply H4 in H5;apply H4 in H6;clear H4.
      unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl.
      rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial.
      apply f_equal;apply f_equal.
      inversion H3;clear H3;subst;trivial.

      (* bop *)
      destruct (Atom.reflect_bop_eqb b0 b);[subst | auto].
      apply build_congr_correct;simpl;intros.
      rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp.
      replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)).
       destruct (rho (Lit.blit lpa));reflexivity.
      rewrite !wf_interp_form, H, H0;simpl.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H1, def_t_atom. discriminate.
      assert (i0 < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H2, def_t_atom;discriminate.
      apply H4 in H5;apply H4 in H6;clear H4.
      unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl.
      rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial.
      inversion H3;clear H3;subst.
      inversion H11;clear H11;subst.
      apply f_equal; apply f_equal2;trivial.

      (* op *)
      destruct (Int63Properties.reflect_eqb i2 i1);[subst | auto].
      apply build_congr_correct;simpl;intros.
      rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp.
      replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)).
       destruct (rho (Lit.blit lpa));reflexivity.
      rewrite !wf_interp_form, H, H0;simpl.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H1, def_t_atom;discriminate.
      assert (i0 < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H2, def_t_atom;discriminate.
      apply H4 in H5;apply H4 in H6;clear H4.
      unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl.
      rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial.
      apply f_equal;destruct (t_func.[i1]);apply f_equal.
      clear H H0 H1 H2 H5 H6.
      induction H3;simpl;trivial.
      unfold Atom.interp_hatom in H;rewrite H, IHForall2;trivial.
    Qed.

  End Proof.

End certif.

(*
   Local Variables:
   coq-load-path: ((rec ".." "SMTCoq"))
   End:
*)


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Export OrderedType OrderedTypeEx OrderedTypeAlt.
Require Export DecidableType DecidableTypeEx.
Require Export FMapInterface.
Require Export FMapPositive.
Require Export FMapFacts.
Require Export FMapWeakList.
Require Export FMapList.


From stdpp Require Import base countable gmap.
From iris.heap_lang Require Import lang notation proofmode.
From iris.algebra Require Import namespace_map gmap gset auth.
From iris.base_logic Require Import gen_heap.
From iris_string_ident Require Import ltac2_string_ident.
From mathcomp Require ssrbool order path.
From deriving Require deriving.
From cryptis Require Export mathcomp_compat.

(* TODO: Move to Iris? *)
Instance dom_ne {T : ofe} :
  NonExpansive (dom (gset loc) : gmap loc T -> gset loc).
Proof. by move=> ??? e ?; rewrite !elem_of_dom e. Qed.

Lemma meta_meta_token `{Countable L, !gen_heapG L V Σ, Countable A} l (x : A) N E :
  ↑N ⊆ E →
  meta_token l E -∗
  meta l N x -∗
  False.
Proof.
iIntros (sub) "Htoken #Hmeta1".
pose (X := {[encode x]} : gset positive).
iMod (meta_set _ _ (fresh X) with "Htoken") as "#Hmeta2"=> //.
iAssert (meta l N (encode x)) as "Hmeta1'".
  by rewrite {1 3}/meta seal_eq.
iPoseProof (meta_agree with "Hmeta1' Hmeta2") as "%e"; iPureIntro.
assert (contra : encode x ∈ X). { by apply/elem_of_singleton. }
destruct (is_fresh X); by rewrite -e.
Qed.

(* I've made an MR for this. *)
Lemma gmap_equivI `{!EqDecision K, !Countable K, A : ofe, M : ucmra}
  (m1 m2 : gmap K A) :
  m1 ≡ m2 ⊣⊢@{uPredI M} (∀ i : K, m1 !! i ≡ m2 !! i).
Proof. by uPred.unseal. Qed.

Lemma dom_singleton_eq `{EqDecision K, Countable K} {T} (m : gmap K T) x :
  dom (gset K) m = {[x]} →
  ∃ y, m = {[x := y]}.
Proof.
move=> e.
have {}e: ∀ x' : K, x' ∈ dom (gset K) m ↔ x' ∈ ({[x]} : gset K) by rewrite e.
have: x ∈ ({[x]} : gset K) by rewrite elem_of_singleton.
rewrite -e elem_of_dom; case=> y m_x; exists y.
apply: map_eq=> x'; case: (decide (x' = x))=> [ {x'}->|ne].
  by rewrite lookup_singleton.
rewrite lookup_singleton_ne // -(@not_elem_of_dom _ _ (gset K)).
by rewrite e elem_of_singleton.
Qed.

Lemma option_Forall2E {A B} {R : A → B → Prop} ox oy :
  option_Forall2 R ox oy ↔
  match ox, oy with
  | Some x, Some y => R x y
  | None, None => True
  | _, _ => False
  end.
Proof.
split; first by case.
by case: ox oy=> [x|] [y|] //; constructor.
Qed.

Lemma option_equivE `{Equiv A} (ox oy : option A) :
  ox ≡ oy ↔
  match ox, oy with
  | Some x, Some y => x ≡ y
  | None, None => True
  | _, _ => False
  end.
Proof. apply option_Forall2E. Qed.

Lemma namespace_map_validI Σ (A : cmra) (x : namespace_map A) :
  ✓ x ⊣⊢@{iPropI Σ}
  match namespace_map_token_proj x with
  | CoPset E =>
    ✓ namespace_map_data_proj x
    ∧ ⌜∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E⌝
  | CoPsetBot => False
  end.
Proof. by uPred.unseal; case: x=> [? [?|]]. Qed.

(* Double-check this does not exist *)
Lemma singleton_inj `{!EqDecision T, !Countable T} :
  Inj eq eq (singleton : T -> gset T).
Proof.
move=> x1 x2 e.
have : x1 ∈ ({[x1]} : gset _) by apply elem_of_singleton.
by rewrite e => /elem_of_singleton.
Qed.

Definition perm `{!EqDecision T, !Countable T} (X : gset (T * T)) :=
  forall p1 p2, p1 ∈ X → p2 ∈ X → (p1.1 = p2.1 ↔ p1.2 = p2.2).

Definition flipb {T S} (b : bool) (f : T → T → S) x y :=
  f (if b then x else y) (if b then y else x).

Class Repr A := repr : A -> val.
Arguments repr / .

Instance repr_val : Repr val := λ x, x.
Arguments repr_val / .

Instance repr_Z : Repr Z := λ x, #x.
Arguments repr_Z / .

Instance repr_option `{Repr A} : Repr (option A) := λ x,
  match x with
  | Some x => SOMEV (repr x)
  | None => NONEV
  end.
Arguments repr_option {A} {_} !_.

Definition repr_list_aux `{Repr A} :
  seal (foldr (fun x v => SOMEV (repr x, v)%V) NONEV).
  by eexists.
Qed.
Instance repr_list `{Repr A} : Repr (list A) := unseal repr_list_aux.
Arguments repr_list {A} {_} _ : simpl never.

Lemma repr_list_eq `{Repr A} :
  repr_list = foldr (fun x v => SOMEV (repr x, v)%V) NONEV.
Proof. exact: seal_eq. Qed.

Lemma repr_list_val `{Repr A} (xs : list A) :
  repr_list xs = repr_list (map repr xs).
Proof.
rewrite !repr_list_eq; by elim: xs => //= x xs ->.
Qed.

Definition leq_loc_loop : val := rec: "loop" "l1" "l2" "n" :=
  if: "l1" +ₗ "n" = "l2" then #true
  else if: "l2" +ₗ "n" = "l1" then #false
  else "loop" "l1" "l2" ("n" + #1).

Definition leq_loc : val := λ: "l1" "l2",
  leq_loc_loop "l1" "l2" #0.

Definition get_list : val := rec: "loop" "l" "n" :=
  match: "l" with NONE => NONE
  | SOME "p" =>
    if: "n" = #0 then SOME (Fst "p")
    else "loop" (Snd "p") ("n" - #1)
  end.

Notation "l !! n" := (get_list l n) : expr_scope.

Definition NILV : val := NONEV.
Definition CONSV hd tl : val := SOMEV (hd, tl).
Notation "hd :: tl" := (CONSV hd%V tl%V) : val_scope.
Notation "[ ]" := (NILV) : val_scope.
Notation "[ x ]" := (CONSV x%V NILV) : val_scope.
Notation "[ x ; y ; .. ; z ]" :=
  (CONSV x%V (CONSV y%V .. (CONSV z%V NILV) ..)) : val_scope.

Definition NIL : expr := NONE.
Definition CONS : val := λ: "hd" "tl", SOME ("hd", "tl").
Notation "hd :: tl" := (CONS hd%E tl%E) : expr_scope.
Notation "[ ]" := (NIL) : expr_scope.
Notation "[ x ]" := (CONS x%V NIL) : expr_scope.
Notation "[ x ; y ; .. ; z ]" :=
  (CONS x%E (CONS y%E .. (CONS z%E NIL) ..)) : expr_scope.

Definition eq_list : val := rec: "loop" "eq" "l1" "l2" :=
  match: "l1" with
    SOME "l1" =>
      match: "l2" with
        SOME "l2" =>
          let: "v1" := Fst "l1" in
          let: "l1" := Snd "l1" in
          let: "v2" := Fst "l2" in
          let: "l2" := Snd "l2" in
          "eq" "v1" "v2" && "loop" "eq" "l1" "l2"
      | NONE => #false
      end
   | NONE =>
     match: "l2" with
       SOME <> => #false
     | NONE => #true
     end
  end.

Fixpoint list_match_aux (vars : list string) (l : expr) (k : expr) : expr :=
  match vars with
  | [] =>
    match: l with SOME <> => NONEV | NONE => k #() end
  | var :: vars =>
    let k' := if decide (var ∈ vars) then k else k (Fst var) in
    match: l with
      SOME var => list_match_aux vars (Snd var) k'
    | NONE => NONEV
    end
  end.

Definition insert_sorted : val := rec: "loop" "le" "x" "l" :=
  match: "l" with
    NONE => SOME ("x", NONE)
  | SOME "l" =>
    let: "y" := Fst "l" in
    let: "l" := Snd "l" in
    if: "le" "x" "y" then SOME ("x", SOME ("y", "l"))
    else SOME ("y", "loop" "le" "x" "l")
  end.

Definition leq_list : val := rec: "loop" "eq" "le" "l1" "l2" :=
  match: "l1" with
    NONE => #true
  | SOME "l1" =>
    match: "l2" with
      NONE => #false
    | SOME "l2" =>
      let: "x1" := Fst "l1" in
      let: "x2" := Fst "l2" in
      let: "l1" := Snd "l1" in
      let: "l2" := Snd "l2" in
      if: "eq" "x1" "x2" then "loop" "eq" "le" "l1" "l2"
      else "le" "x1" "x2"
    end
  end.

Ltac substC :=
  repeat match goal with
  | |- context [decide ?P] => destruct (decide P) as [?|?]; simpl
  | H : ?P ∧ ?Q |- _ => destruct H as [?|?]
  end.

Lemma substC x1 x2 v1 v2 e :
  x1 ≠ x2 →
  subst x1 v1 (subst x2 v2 e) = subst x2 v2 (subst x1 v1 e).
Proof. by move=> x12; elim: e => //= *; substC; congruence. Qed.

Lemma subst_list_match_aux var v vars el ek :
  subst var v (list_match_aux vars el ek) =
  list_match_aux vars (subst var v el) (
    if decide (var ∈ vars) then ek else subst var v ek).
Proof.
elim: vars => [|var' vars IH] //= in el ek *.
case: (decide (var = var')) => [<-|ne].
  rewrite decide_False; last by intuition congruence.
  rewrite (@decide_True _ (var ∈ var :: vars)) //; last by set_solver.
rewrite decide_True; last by intuition congruence.
rewrite IH; case: (decide (var ∈ vars)) => [in_vars|nin_vars] /=.
  rewrite (@decide_False _ (var = var')) //.
  rewrite !(@decide_True  _ (var ∈ _)) //; set_solver.
rewrite decide_False // (@decide_False _ (var ∈ _)); last by set_solver.
case: decide => [in_vars'|nin_vars'] //=.
by rewrite decide_False.
Qed.

Fixpoint close_vars (vars : list string) (k : expr) : expr :=
  match vars with
  | [] => λ: <>, k
  | var :: vars =>
    (if decide (var ∈ vars) then close_vars vars k
     else λ: var, close_vars vars k)%E
  end.

Lemma subst_close_vars var v vars k :
  var ∉ vars →
  subst var v (close_vars vars k) = close_vars vars (subst var v k).
Proof.
elim: vars => [|var' vars IH] //= in k *.
case: decide => [in_vars'|nin_vars'] nin_vars /=.
  apply: IH; set_solver.
rewrite decide_True; last by split; eauto; set_solver.
rewrite IH //; set_solver.
Qed.

Fact list_match_key : unit. Proof. exact: tt. Qed.

Definition list_match :=
  locked_with list_match_key (
    λ vars l k,
      list_match_aux vars l (close_vars vars k)
  ).

Canonical list_match_unlockable := [unlockable of list_match].

Notation "'list_match:' vars := e1 'in' e2" :=
  (list_match vars e1 e2)%E
  (at level 200, vars at level 1, e1, e2 at level 200,
  format "'[' 'list_match:'  vars  :=  '[' e1 ']'  'in'  '/' e2 ']'") : expr_scope.

Lemma subst_list_match var v vars el ek :
  subst var v (list_match vars el ek) =
  list_match vars (subst var v el) (
    if decide (var ∈ vars) then ek else subst var v ek).
Proof.
rewrite unlock subst_list_match_aux; case: decide => [//|nin_vars].
congr list_match_aux; elim: vars => [|var' vars IH] //= in {el} ek nin_vars *.
have neq : var ≠ var' by set_solver.
have {}nin_vars : var ∉ vars by set_solver.
case: (decide (var' ∈ vars)) => [in_vars'|nin_vars'] /=.
  by rewrite IH.
rewrite decide_True ?IH //; by intuition congruence.
Qed.

Definition binder_vars x : gset string :=
  match x with
  | BAnon => ∅
  | BNamed x => {[x]}
  end.

Lemma elem_of_binder_vars (x : string) (y : binder) :
  x ∈ binder_vars y ↔ x = y :> binder.
Proof.
case: y => /=; first by split.
by move=> ?; rewrite elem_of_singleton; split; congruence.
Qed.

Fixpoint free_vars e : gset string :=
  match e with
  | Val _ => ∅
  | Var x => {[x]}
  | Rec f x e => free_vars e ∖ binder_vars f ∖ binder_vars x
  | App e1 e2 => free_vars e1 ∪ free_vars e2
  | UnOp _ e => free_vars e
  | BinOp _ e1 e2 => free_vars e1 ∪ free_vars e2
  | If e1 e2 e3 => free_vars e1 ∪ free_vars e2 ∪ free_vars e3
  | Pair e1 e2 => free_vars e1 ∪ free_vars e2
  | Fst e | Snd e => free_vars e
  | InjL e | InjR e => free_vars e
  | Case e1 e2 e3 => free_vars e1 ∪ free_vars e2 ∪ free_vars e3
  | Fork e => free_vars e
  | AllocN e1 e2 => free_vars e1 ∪ free_vars e2
  | Free e => free_vars e
  | Load e => free_vars e
  | Store e1 e2 => free_vars e1 ∪ free_vars e2
  | CmpXchg e1 e2 e3 => free_vars e1 ∪ free_vars e2 ∪ free_vars e3
  | FAA e1 e2 => free_vars e1 ∪ free_vars e2
  | NewProph => ∅
  | Resolve e1 e2 e3 => free_vars e1 ∪ free_vars e2 ∪ free_vars e3
  end.

Ltac subst_free_vars :=
  repeat match goal with
  | |- context [decide ?P] => destruct (decide P) as [?|?]
  | H : context[?x ∈ {[?y]}] |- _ => rewrite elem_of_singleton in H * => *
  | H : context[?x ∈ _ ∪ _] |- _ => rewrite elem_of_union in H * => *
  | H : context[?x ∈ _ ∖ _] |- _ => rewrite elem_of_difference in H * => *
  | H : context[?x ∈ binder_vars _] |- _ => rewrite elem_of_binder_vars in H * => *
  | H : _ ∧ _ |- _ => destruct H as [??]
  | H : ¬ (_ ∨ _) |- _ => apply Decidable.not_or in H
  | HQP : ¬ (?Q ∧ ?P), HP : ?P |- _ =>
    assert (¬ Q); [intros ?; apply HQP; by split|clear HQP]
  | HP : ?P, HPQ : ?P -> ?Q |- _ => specialize (HPQ HP)
  end.

Lemma subst_free_vars x v e : x ∉ free_vars e → subst x v e = e.
Proof.
elim: e => //=; try by intros; subst_free_vars; congruence.
Qed.

Fixpoint nsubst (vars : list string) (vs : list val) (k : expr) : expr :=
  match vars, vs with
  | [], [] => k
  | var :: vars, v :: vs => subst var v (nsubst vars vs k)
  | _, _ => NONEV
  end.

Ltac subst_free_vars_rem :=
  repeat (
    simpl in *;
    match goal with
    | |- context [decide ?P] => destruct (decide P) as [?|?]
    | |- ¬ _ => intros ?
    | H : context[?x ∈ {[?y]}] |- _ => rewrite elem_of_singleton in H * => *
    | H : context[?x ∈ _ ∪ _] |- _ => rewrite elem_of_union in H * => *
    | H : context[?x ∈ _ ∖ _] |- _ => rewrite elem_of_difference in H * => *
    | H : context[?x ∈ binder_vars _] |- _ => rewrite elem_of_binder_vars in H * => *
    | H : _ ∧ _ |- _ => destruct H as [??]
    | H : ¬ (_ ∨ _) |- _ => apply Decidable.not_or in H
    | H : context[_ ∈ ∅] |- _ => rewrite -> elem_of_empty in H
    | HQP : ¬ (?Q ∧ ?P), HP : ?P |- _ =>
      assert (¬ Q); [intros ?; apply HQP; by split|clear HQP]
    | HQP : ¬ (?Q ∧ ?P) |- _ =>
      rewrite -> not_and_l in HQP; destruct HQP
    | H : ¬ ¬ _ |- _ => apply dec_stable in H
    | HP : ?P, HPQ : ?P -> ?Q |- _ => specialize (HPQ HP)
    | HNP : ¬ ?P, HP : ?P |- _ => destruct (HNP HP)
    | H : _ ∨ _ |- _ => destruct H
    | e : ?x = _ |- context[?x] => rewrite e
    end
  ).

Lemma subst_free_vars_rem var v e : var ∉ free_vars (subst var v e).
Proof.
by elim: e => /=; try by intros; subst_free_vars_rem; congruence.
Qed.

Lemma free_vars_subst var v e :
  free_vars (subst var v e) = free_vars e ∖ {[var]}.
Proof.
elim: e => //=; intros; subst_free_vars_rem; subst; set_solver.
Qed.

Lemma subst_nsubst var v vars vs e :
  var ∈ vars →
  subst var v (nsubst vars vs e) = nsubst vars vs e.
Proof.
elim: vars vs=> [|var' vars IH] [|v' vs]; try by rewrite ?elem_of_nil //=.
case: (decide (var = var')) => [<- _|var_var'].
  rewrite subst_free_vars //; exact: subst_free_vars_rem.
rewrite elem_of_cons; case => var_in /=; first congruence.
by rewrite substC // IH.
Qed.

Lemma subst_nsubst_nin var v vars vs e :
  var ∉ vars →
  subst var v (nsubst vars vs e) = nsubst vars vs (subst var v e).
Proof.
elim: vars vs=> [|var' vars IH] [|v' vs]; try by rewrite ?elem_of_nil //=.
rewrite elem_of_cons; case/Decidable.not_or => var_var' var_nin.
by rewrite /= substC // IH.
Qed.

Lemma free_vars_nsubst vars vs e :
  length vars = length vs →
  free_vars (nsubst vars vs e) = free_vars e ∖ ⋃ (singleton <$> vars).
Proof.
elim: vars vs => [|var vars IH] [|v vs] //= in e *.
  move=> _; set_solver.
case=> e_len; rewrite free_vars_subst IH //.
set_solver.
Qed.

Section ListLemmas.

Context `{!Repr A, !heapG Σ}.

Lemma twp_get_list E (l : list A) (n : nat) Ψ :
  Ψ (repr (l !! n)) -∗
  WP repr l !! #n @ E [{ Ψ }].
Proof.
rewrite /= repr_list_eq.
elim: n l Ψ => [|n IH] [|x l] /= Ψ; iIntros "post";
wp_rec; wp_pures; eauto.
rewrite (_ : (S n - 1)%Z = n); try lia.
by iApply IH.
Qed.

Lemma wp_get_list E (l : list A) (n : nat) Ψ :
  Ψ (repr (l !! n)) -∗
  WP repr l !! #n @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_get_list. Qed.

Lemma twp_nil E Ψ :
  Ψ (repr (@nil A)) -∗
  WP []%V @ E [{ Ψ }].
Proof.
by rewrite /NILV /= repr_list_eq; iIntros "?"; wp_pures.
Qed.

Lemma wp_nil E Ψ :
  Ψ (repr (@nil A)) -∗
  WP []%V @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_nil. Qed.

Lemma twp_cons E x xs Ψ :
  Ψ (repr (x :: xs)) -∗
  WP repr x :: repr xs @ E [{ Ψ }].
Proof.
rewrite /= repr_list_eq; iIntros "post"; by rewrite /CONS; wp_pures.
Qed.

Lemma wp_cons E x xs Ψ :
  Ψ (repr (x :: xs)) -∗
  WP repr x :: repr xs @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_cons. Qed.

Definition list_to_expr :=
  foldr (fun (x : A) e => CONS (repr x) e) NILV.

Fixpoint napp (vars : list string) (vs : list val) :=
  match vars, vs with
  | var :: vars, v :: vs =>
    if decide (var ∈ vars) then napp vars vs
    else AppLCtx v :: napp vars vs
  | [], [] => [AppLCtx #()]
  | _, _ => []
  end.

Lemma wp_list_match_aux E (vs : list A) evs vars k Ψ :
  elements (free_vars k) ## vars →
  (∀ Ψ, Ψ (repr_list vs) -∗ WP evs @ E {{ Ψ }}) -∗
  (if decide (length vars = length vs) then
     WP fill (napp vars (map repr vs)) k @ E {{ Ψ }}
   else Ψ NONEV) -∗
  WP list_match_aux vars evs k @ E {{ Ψ }}.
Proof.
rewrite repr_list_eq.
elim: vars vs => [|var vars IH] [|v vs] /= in evs k *; iIntros (dis) "evs pS".
- by wp_pures; wp_bind evs; iApply "evs"; wp_pures.
- by wp_pures; wp_bind evs; iApply "evs"; wp_pures.
- by wp_pures; wp_bind evs; iApply "evs"; wp_pures.
rewrite /=; wp_pures; wp_bind evs; iApply "evs"; wp_pures.
rewrite subst_list_match_aux /=.
rewrite [if decide (var = var) then _ else _]decide_True //=.
assert (fresh_var : var ∉ free_vars k) by set_solver.
assert (dis' : elements (free_vars k) ## vars) by set_solver.
iApply (IH with "[]"); try by iIntros (Ψ') "p'"; wp_pures; eauto.
  case: decide => _ //=.
  rewrite free_vars_subst decide_True //=.
  set_solver.
case: (decide (length vars = length vs)) => [eq_l|neq_l]; last first.
  rewrite decide_False //; congruence.
rewrite eq_l decide_True //.
case: decide => [//|nin_vars] /=.
rewrite decide_True //= subst_free_vars //.
wp_pures; iApply wp_bind; wp_pures; by iApply wp_bind_inv.
Qed.

Lemma wp_close_vars E vars vs k Ψ :
  length vars = length vs →
  WP nsubst vars vs k @ E {{ Ψ }} -∗
  WP fill (napp vars vs) (close_vars vars k) @ E {{ Ψ }}.
Proof.
elim: vars vs => [|var vars IH] [|v vs] //= in k Ψ *.
  by iIntros (?) "p"; wp_pures.
move=> [] e; iIntros "p".
case: decide => [in_vars|nin_vars].
  rewrite subst_free_vars; first by iApply IH.
  rewrite free_vars_nsubst // elem_of_difference.
  case => _; rewrite elem_of_union_list.
  by apply; exists {[var]}; split; try set_solver.
rewrite /=.
iApply wp_bind.
wp_pures.
rewrite subst_nsubst_nin //.
iApply wp_bind_inv.
rewrite subst_close_vars //.
by iApply IH.
Qed.

Lemma wp_list_match E vars (vs : list A) k Ψ :
  (if decide (length vars = length vs) then
     WP nsubst vars (map repr vs) k @ E {{ Ψ }}
   else Ψ NONEV) -∗
  WP list_match vars (repr vs) k @ E {{ Ψ }}.
Proof.
rewrite unlock; iIntros "post".
assert (disj : elements (free_vars (close_vars vars k)) ## vars).
  elim: vars => [|var vars IH] /= in k *; try case: decide => ?; set_solver.
iApply (wp_list_match_aux E vs (repr vs)); eauto.
  by iIntros (?) "?"; iApply wp_value.
case: decide => ? //.
iApply (wp_close_vars with "post").
by rewrite map_length.
Qed.

Lemma twp_eq_list `{EqDecision A} (f : val) (l1 l2 : list A) Φ E :
  (∀ (x1 x2 : A) Ψ,
      x1 ∈ l1 →
      Ψ #(bool_decide (x1 = x2)) -∗
      WP f (repr x1) (repr x2) @ E [{ Ψ }]) →
  Φ #(bool_decide (l1 = l2)) -∗
  WP eq_list f (repr l1) (repr l2) @ E [{ Φ }].
Proof.
rewrite repr_list_eq /=.
elim: l1 l2 Φ => [|x1 l1 IH] [|x2 l2] Φ wp_f /=;
iIntros "post" ; wp_rec; wp_pures; do 1?by iApply "post".
wp_bind (f _ _); iApply (wp_f x1 x2); first by set_solver.
case: (bool_decide_reflect (x1 = x2)) => [->|n_x1x2]; wp_pures; last first.
  rewrite bool_decide_decide decide_False; by [iApply "post"|congruence].
iApply IH; first by move=> *; iApply wp_f; set_solver.
case: (bool_decide_reflect (l1 = l2)) => [->|n_l1l2].
- by rewrite bool_decide_decide decide_True.
- by rewrite bool_decide_decide decide_False //; congruence.
Qed.

End ListLemmas.

Section Loc.

Context `{!heapG Σ}.
Import ssreflect.order deriving.instances.

Lemma twp_leq_loc_loop E (l1 l2 : loc) (n k : nat) Ψ :
  loc_car l2 = (loc_car l1 + (n + k)%nat)%Z ∨
  loc_car l1 = (loc_car l2 + (n + k)%nat)%Z ∧ n + k ≠ 0%nat →
  Ψ #(l1 <= l2)%O -∗
  WP leq_loc_loop #l1 #l2 #n @ E [{ Ψ }].
Proof.
have leq_locE l1' l2' :
    (l1' <= l2')%O = bool_decide (loc_car l1' ≤ loc_car l2')%Z.
  exact/(ssrbool.sameP (Z.leb_spec0 _ _))/bool_decide_reflect.
have eq_locE (l1' l2' : loc) :
    bool_decide (#l1' = #l2') = bool_decide (loc_car l1' = loc_car l2').
  apply: bool_decide_iff; split => [[->] //|].
  by case: l1' l2' => [?] [?] /= ->.
elim: k n => [|k IH] n e_l1l2; iIntros "post"; wp_pures; wp_rec; wp_pures.
- rewrite eq_locE.
  case: bool_decide_reflect => /= [eq|neq]; wp_pures.
    rewrite leq_locE bool_decide_decide decide_True //=.
    lia.
  rewrite eq_locE bool_decide_decide decide_True /=; try lia.
  wp_pures; rewrite leq_locE bool_decide_decide decide_False //.
  move=> H; apply: neq; rewrite /loc_add /= in H; lia.
- rewrite eq_locE bool_decide_decide decide_False; last by move=> /= ?; lia.
  wp_pures.
  rewrite eq_locE bool_decide_decide decide_False; last by move=> /= ?; lia.
  wp_pures.
  rewrite (_ : (n + 1)%Z = S n :> Z); try lia.
  iApply IH => //; lia.
Qed.

Lemma twp_leq_loc E (l1 l2 : loc) Ψ :
  Ψ #(l1 <= l2)%O -∗
  WP leq_loc #l1 #l2 @ E [{ Ψ }].
Proof.
have [off offP] :
    ∃ off : nat, (loc_car l2 = loc_car l1 + off ∨
                  loc_car l1 = loc_car l2 + off ∧ off ≠ 0%nat)%Z.
  exists (Z.to_nat (Z.abs (loc_car l1 - loc_car l2))); lia.
iIntros "post"; rewrite /leq_loc -[0%Z]/(Z.of_nat 0); wp_pures.
by iApply twp_leq_loc_loop => //.
Qed.

End Loc.

Section Ordered.

Import ssrbool seq ssreflect.order path deriving.instances.
Variable (d : unit) (A : orderType d).
Context `{!Repr A, !heapG Σ}.
Import Order Order.POrderTheory Order.TotalTheory.
Implicit Types (x y z : A) (s : seqlexi_with d A).

Lemma twp_insert_sorted (f : val) (x : A) (l : list A) E :
  is_true (sorted le l) →
  (∀ (y z : A),
      [[{ True }]] f (repr y) (repr z) @ E [[{ RET #(le y z); True }]]) →
  [[{ True }]]
    insert_sorted f (repr x) (repr l) @ E
  [[{ RET (repr (sort le (x :: l))); True }]].
Proof.
rewrite repr_list_eq => sorted_l wp_f Φ; iIntros "_ post".
iSpecialize ("post" with "[//]"); iStopProof.
elim: l sorted_l Φ => //= [|y l IH] path_l Φ;
iIntros "post"; wp_rec; wp_pures => //.
move/(_ (path_sorted path_l)) in IH.
wp_bind (f _ _); iApply wp_f => //; iIntros "_".
have [le_xy|le_yx] := boolP (x <= y)%O; wp_pures.
  by rewrite sort_le_id //= ?le_xy.
move: le_yx; rewrite -ltNge => /ltW le_yx.
wp_bind (insert_sorted _ _ _); iApply IH.
suff -> : sort le [:: x, y & l] = y :: sort le (x :: l) by wp_pures.
rewrite -[RHS]sort_le_id /=.
  apply/perm_sort_leP/perm_consP.
  exists 1, (l ++ [:: x])%SEQ.
  by rewrite /= perm_catC perm_sym /= perm_sort; split.
rewrite path_min_sorted ?sort_le_sorted // all_sort /= le_yx /=.
apply: order_path_min => //; apply: le_trans.
Qed.

Lemma twp_leq_list (feq : val) (fle : val) s1 s2 E :
  (∀ x1 x2,
      [[{ True }]]
        feq (repr x1) (repr x2) @ E
      [[{ RET #(eqtype.eq_op x1 x2); True }]]) →
  (∀ x1 x2,
      is_true (x1 \in s1) →
      [[{ True }]]
        fle (repr x1) (repr x2) @ E
      [[{ RET #(le x1 x2); True }]]) →
  [[{ True }]]
    leq_list feq fle (repr s1) (repr s2) @ E
  [[{ RET #(le s1 s2); True }]].
Proof.
move=> feqP fleqP Φ; iIntros "_ post".
iSpecialize ("post" with "[//]"); iStopProof.
move: fleqP; rewrite /= repr_list_eq.
elim: s1 s2 => [|x1 s1 IH] [|x2 s2] fleP; iIntros "HΦ"; wp_rec; wp_pures => //.
rewrite lexi_cons; wp_bind (feq _ _); iApply feqP => //; iIntros "_".
case: (ltgtP x1 x2) => [l_x1x2|l_x2x1|<-] /=; wp_pures.
- by iApply fleP; rewrite ?inE ?eqtype.eqxx // ltW //; iIntros "_".
- by iApply fleP; rewrite ?inE ?eqtype.eqxx // leNgt l_x2x1 //; iIntros "_".
- iApply IH => // x1' ? x1'_in ?; iIntros "_ post".
  by iApply fleP; rewrite // inE x1'_in orbT.
Qed.

End Ordered.

Instance repr_prod `{Repr A, Repr B} : Repr (A * B) :=
  λ p, (repr p.1, repr p.2)%V.
Arguments repr_prod {_ _ _ _} !_.

Fixpoint nforall {A} (n : nat) (P : list A → Prop) :=
  match n with
  | 0 => P []
  | S n => forall x : A, nforall n (λ xs, P (x :: xs))
  end.

Lemma nforallP {A} (n : nat) (P : list A -> Prop) :
  nforall n P ↔ ∀ vs, n = length vs → P vs.
Proof.
elim: n => [|n IH] /= in P *.
  split; [by move=> ? [|//]|by apply].
split.
- move=> H [|x xs] //= [e]; by move/IH: (H x); apply.
- by move=> H x; apply/IH => xs len_xs; apply: H; rewrite len_xs.
Qed.

Definition nforall_eq {A} (n : nat) (vs : list A) (P : list A -> Prop) :=
  nforall n (λ vs', vs = vs' → P vs').

Lemma nforall_eqP {A} (n : nat) (xs : list A) (P : list A -> Prop) :
  nforall_eq n xs P ↔ (n = length xs → P xs).
Proof.
rewrite /nforall_eq nforallP; split.
- by move=> H len_xs; apply: H.
- by move=> H xs' len_xs' e_xs'; rewrite e_xs' in H; apply: H.
Qed.

Arguments nforall_eq {A} /.

Lemma list_len_rect (n : nat) A (P : list A → Prop) :
  (nforall n P) →
  (∀ xs, length xs ≠ n → P xs) →
  ∀ xs, P xs.
Proof.
move=> eq_n neq_n xs.
case: (decide (n = length xs)) => [eq|neq].
- by move: xs eq; apply/nforallP.
- exact: neq_n.
Qed.

Fixpoint prod_of_list_aux_type A B n :=
  match n with
  | 0 => A
  | S n => prod_of_list_aux_type (A * B)%type B n
  end.

Fixpoint prod_of_list_aux {A B} n :
  A → list B → option (prod_of_list_aux_type A B n) :=
  match n with
  | 0 => fun x ys =>
    match ys with
    | [] => Some x
    | _  => None
    end
  | S n => fun x ys =>
    match ys with
    | [] => None
    | y :: ys => prod_of_list_aux n (x, y) ys
    end
  end.

Definition prod_of_list_type A n : Type :=
  match n with
  | 0 => unit
  | S n => prod_of_list_aux_type A A n
  end.

Fact prod_of_list_key : unit. Proof. exact: tt. Qed.

Definition prod_of_list {A} n xs : option (prod_of_list_type A n) :=
  locked_with prod_of_list_key (
    match n return list A → option (prod_of_list_type A n) with
    | 0 => fun xs => match xs with
                     | [] => Some tt
                     | _  => None
                     end
    | S n => fun xs => match xs with
                       | [] => None
                       | x :: xs => prod_of_list_aux n x xs
                       end
    end xs).

Canonical prod_of_list_unlockable A n xs :=
  [unlockable of @prod_of_list A n xs].

Lemma prod_of_list_neq {A} n (xs : list A) :
  length xs ≠ n → prod_of_list n xs = None.
Proof.
rewrite unlock; case: n xs=> [|n] [|x xs] //= ne.
have {}ne : length xs ≠ n by congruence.
suffices : ∀ B (x : B), prod_of_list_aux n x xs = None by apply.
elim: n xs {x} => [|n IH] [|y ys] //= in ne * => B x.
rewrite IH //; congruence.
Qed.

Lemma fmap_binder_delete {A B} (f : A → B) (m : gmap string A) x :
  f <$> binder_delete x m = binder_delete x (f <$> m).
Proof. case: x => [|x] //=; by rewrite fmap_delete. Qed.

Lemma fmap_binder_insert {A B} (f : A → B) (m : gmap string A) i x :
  f <$> binder_insert i x m = binder_insert i (f x) (f <$> m).
Proof. case: i => [|i] //=; by rewrite fmap_insert. Qed.

Lemma insert_same {A} (m1 m2 : gmap string A) (i : string) (x : A) :
  (∀ j, j ≠ i → m1 !! j = m2 !! j) →
  <[i := x]>m1 = <[i := x]>m2.
Proof.
move=> e12; apply map_eq => j.
destruct (decide (j = i)) as [->|ne].
- by rewrite !lookup_insert.
- by rewrite !lookup_insert_ne // e12.
Qed.

Lemma binder_insert_same {A} (m1 m2 : gmap string A) (i : binder) (x : A) :
  (∀ j : string, BNamed j ≠ i → m1 !! j = m2 !! j) →
  binder_insert i x m1 = binder_insert i x m2.
Proof.
case: i => [|i] /= e12.
- by apply: map_eq => i; apply: e12.
- apply: insert_same => ??; apply: e12; congruence.
Qed.

Lemma binder_insert_delete {A} (m : gmap string A) (i : binder) (x : A) :
  binder_insert i x (binder_delete i m) = binder_insert i x m.
Proof. case: i => //= i; exact: insert_delete. Qed.

Lemma binder_insert_delete2 {A} (m : gmap string A) (i j : binder) (x y : A) :
  binder_insert i x (binder_insert j y (binder_delete i (binder_delete j m))) =
  binder_insert i x (binder_insert j y m).
Proof.
rewrite -(binder_insert_delete m j y).
case: i j => [|i] [|j] //=.
- by rewrite insert_delete.
- rewrite delete_commute !insert_delete.
  destruct (decide (i = j)) as [->|i_j].
    by rewrite insert_delete.
  by rewrite insert_commute // insert_delete insert_commute //.
Qed.

Lemma binder_delete_commute {A} (m : gmap string A) i j :
  binder_delete i (binder_delete j m) =
  binder_delete j (binder_delete i m).
Proof. case: i j => [|i] [|j] //=; exact: delete_commute. Qed.