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

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Map.
From IntMap Require Import Allmaps.
Require Import Wf_nat.
Require Import EqNat.
Require Import Peano_dec.
Require Import Ensembles.
Require Import Finite_sets.
Require Import Finite_sets_facts.
Require Import Image.
Require Import List.
Require Import Compare.

Require Import misc.
Require Import bool_fun.
Require Import myMap.
Require Import config.
Require Import alloc.
Require Import make.
Require Import neg.
Require Import or.
Require Import univ.
Require Import op.
Require Import tauto.
Require Import quant.
Require Import gc.
Require Import mu.

Section New.

Variable N : nat.

Definition var_env'_dash (ve : var_env') (n : nat) :=
  if leb N n then ve (n - N) else false.

Definition var_env''_dash (ve : var_env'') :=
  var_env'_to_env'' N (2 * N) (var_env'_dash (var_env''_to_env' ve)).

Fixpoint be_dash (be : bool_expr) : bool_expr :=
  match be with
  | Zero => Zero
  | One => One
  | Var x => Var (N_of_nat (N + nat_of_N x))
  | Neg be' => Neg (be_dash be')
  | Or be1 be2 => Or (be_dash be1) (be_dash be2)
  | ANd be1 be2 => ANd (be_dash be1) (be_dash be2)
  | Impl be1 be2 => Impl (be_dash be1) (be_dash be2)
  | Iff be1 be2 => Iff (be_dash be1) (be_dash be2)
  end.

Fixpoint renamef (f : ad -> ad) (be : bool_expr) {struct be} : bool_expr :=
  match be with
  | Zero => Zero
  | One => One
  | Var x => Var (f x)
  | Neg be' => Neg (renamef f be')
  | Or be1 be2 => Or (renamef f be1) (renamef f be2)
  | ANd be1 be2 => ANd (renamef f be1) (renamef f be2)
  | Impl be1 be2 => Impl (renamef f be1) (renamef f be2)
  | Iff be1 be2 => Iff (renamef f be1) (renamef f be2)
  end.

Definition renfnat (n m : nat) := if leb n m then m else m + N.

Definition renfnad (n : nat) (x : ad) := N_of_nat (renfnat n (nat_of_N x)).

Lemma dash_renf :
 forall be : bool_expr,
 be_ok (var_lu 0 N) be -> be_dash be = renamef (renfnad N) be.
Proof.
  simple induction be.  reflexivity.  reflexivity.  unfold renamef in |- *.  simpl in |- *.
  unfold renfnad in |- *.  unfold renfnat in |- *.  intros.  elim (var_ok_inv _ _ H).
  cut (var_lu 0 N b = true).  intro.  unfold var_lu in H0.
  elim (andb_prop _ _ H0).  intros.
  replace (leb N (nat_of_N b)) with false.
  rewrite (plus_comm N (nat_of_N b)).  reflexivity.  symmetry  in |- *.
  apply leb_correct_conv.  unfold lt in |- *.  apply leb_complete.  assumption.
  apply var_ok_inv.  assumption.  intros.  simpl in |- *.  rewrite H.  reflexivity.
  apply neg_ok_inv.  assumption.  intros.  simpl in |- *.  rewrite H.  rewrite H0.
  reflexivity.  exact (proj2 (or_ok_inv _ _ _ H1)).
  exact (proj1 (or_ok_inv _ _ _ H1)).  intros.  simpl in |- *.  rewrite H.
  rewrite H0.  reflexivity.  exact (proj2 (and_ok_inv _ _ _ H1)).
  exact (proj1 (and_ok_inv _ _ _ H1)).  intros.  simpl in |- *.  rewrite H.
  rewrite H0.  reflexivity.  exact (proj2 (impl_ok_inv _ _ _ H1)).
  exact (proj1 (impl_ok_inv _ _ _ H1)).  intros.  simpl in |- *.  rewrite H.
  rewrite H0.  reflexivity.  exact (proj2 (iff_ok_inv _ _ _ H1)).
  exact (proj1 (iff_ok_inv _ _ _ H1)).
Qed.

Lemma dash_be_ok :
 forall be : bool_expr,
 be_ok (var_lu 0 N) be -> be_ok (var_lu N (2 * N)) (be_dash be).
Proof.
  simple induction be.  intro.  apply zero_ok.  intro.  apply one_ok.  intros.  simpl in |- *.
  apply var_ok.  inversion H.  unfold var_lu in H1.  elim (andb_prop _ _ H1).
  intros.  unfold var_lu in |- *.  apply andb_true_intro.  split.
  rewrite (nat_of_N_of_nat (N + nat_of_N b)).  apply leb_correct.
  apply le_plus_l.  rewrite (nat_of_N_of_nat (N + nat_of_N b)).
  replace (S (N + nat_of_N b)) with (S N + nat_of_N b).
  rewrite (plus_Snm_nSm N (nat_of_N b)).  apply leb_correct.
  apply plus_le_compat.  apply le_n.  rewrite <- (plus_n_O N).
  apply leb_complete.  assumption.  simpl in |- *.  reflexivity.  simpl in |- *.  intros.
  inversion H0.  apply neg_ok.  apply H.  assumption.  simpl in |- *.  intros.
  inversion H1.  apply or_ok; [ apply H; assumption | apply H0; assumption ].
  simpl in |- *.  intros.  inversion H1.
  apply and_ok; [ apply H; assumption | apply H0; assumption ].  simpl in |- *.  intros.
  inversion H1.  apply impl_ok; [ apply H; assumption | apply H0; assumption ].
  simpl in |- *.  intros.  inversion H1.
  apply iff_ok; [ apply H; assumption | apply H0; assumption ].
Qed.

Lemma eval_dash_lemma1 :
 forall (be : bool_expr) (ve : var_env'),
 eval_be' be ve = eval_be' (be_dash be) (var_env'_dash ve).
Proof.
  simple induction be.  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_zero in |- *.  reflexivity.
  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_one in |- *.  reflexivity.  simpl in |- *.
  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_var in |- *.  unfold var_env'_dash in |- *.
  unfold var_env'_to_env in |- *.  intros.
  rewrite (nat_of_N_of_nat (N + nat_of_N b)).
  elim (sumbool_of_bool (leb N (N + nat_of_N b))).  intro y.  rewrite y.
  rewrite (minus_plus N (nat_of_N b)).  reflexivity.
  replace (leb N (N + nat_of_N b)) with true.  intro.  discriminate.
  symmetry  in |- *.  apply leb_correct.  apply le_plus_l.  intros.  simpl in |- *.
  unfold eval_be' in |- *.  unfold eval_be' in H.  simpl in |- *.  unfold bool_fun_neg in |- *.
  rewrite (H ve).  reflexivity.  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_or in |- *.
  intros.  rewrite (H ve).  rewrite (H0 ve).  reflexivity.  unfold eval_be' in |- *.
  simpl in |- *.  unfold bool_fun_and in |- *.  intros.  rewrite (H ve).  rewrite (H0 ve).
  reflexivity.  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_impl in |- *.  intros.
  rewrite (H ve).  rewrite (H0 ve).  reflexivity.  unfold eval_be' in |- *.  simpl in |- *.
  unfold bool_fun_iff in |- *.  intros.  rewrite (H ve).  rewrite (H0 ve).  reflexivity.
Qed.

Definition var_env_or (ve1 ve2 : var_env) (x : ad) := ve1 x || ve2 x.
Definition var_env'_or (ve1 ve2 : var_env') (x : nat) := ve1 x || ve2 x.

Lemma forall_lemma1 :
 forall (be : bool_expr) (ve : var_env) (a : ad),
 bool_fun_of_bool_expr (forall_ a be) ve = true ->
 bool_fun_of_bool_expr be ve = true.
Proof.
  intros.  rewrite (forall_OK a be ve) in H.  unfold bool_fun_forall in H.
  unfold bool_fun_and in H.  elim (andb_prop _ _ H).  intros.
  elim (sumbool_of_bool (ve a)).  intro y.  rewrite <- H0.
  unfold bool_fun_restrict in |- *.  apply (bool_fun_of_be_ext be).  intros.
  unfold augment in |- *.  elim (sumbool_of_bool (Neqb a x)).  intro y0.  rewrite y0.
  rewrite (Neqb_complete _ _ y0) in y.  assumption.  intro y0.  rewrite y0.
  reflexivity.  intro y.  rewrite <- H1.  unfold bool_fun_restrict in |- *.
  apply (bool_fun_of_be_ext be).  intros.  unfold augment in |- *.
  elim (sumbool_of_bool (Neqb a x)).  intro y0.  rewrite y0.
  rewrite (Neqb_complete _ _ y0) in y.  assumption.  intro y0.  rewrite y0.
  reflexivity.
Qed.

Lemma renamef_ext :
 forall (be : bool_expr) (f g : ad -> ad),
 (forall x : ad, f x = g x) -> renamef f be = renamef g be.
Proof.
  simple induction be.  reflexivity.  reflexivity.  simpl in |- *.  intros.  rewrite (H b).
  reflexivity.  intros.  simpl in |- *.  rewrite (H _ _ H0).  reflexivity.  intros.
  simpl in |- *.  rewrite (H _ _ H1).  rewrite (H0 _ _ H1).  reflexivity.  intros.
  simpl in |- *.  rewrite (H _ _ H1).  rewrite (H0 _ _ H1).  reflexivity.  intros.
  simpl in |- *.  rewrite (H _ _ H1).  rewrite (H0 _ _ H1).  reflexivity.  intros.
  simpl in |- *.  rewrite (H _ _ H1).  rewrite (H0 _ _ H1).  reflexivity.
Qed.

Lemma renamef_id : forall be : bool_expr, renamef (fun x => x) be = be.
Proof.
  simple induction be.  reflexivity.  reflexivity.  reflexivity.  intros.  simpl in |- *.
  rewrite H.  reflexivity.  intros.  simpl in |- *.  rewrite H.  rewrite H0.
  reflexivity.  intros.  simpl in |- *.  rewrite H.  rewrite H0.  reflexivity.  intros.
  simpl in |- *.  rewrite H.  rewrite H0.  reflexivity.  intros.  simpl in |- *.  rewrite H.
  rewrite H0.  reflexivity.
Qed.

Lemma renamefS :
 forall (be : bool_expr) (n : nat),
 n < N ->
 renamef (renfnad (S n)) be =
 subst (ap n) (Var (ap' N n)) (renamef (renfnad n) be).
Proof.
  simple induction be.  simpl in |- *.  reflexivity.  reflexivity.  intros.  simpl in |- *.
  unfold renfnad at 2 in |- *.  unfold renfnat in |- *.
  elim (sumbool_of_bool (leb n (nat_of_N b))).  intro y.  rewrite y.
  rewrite (N_of_nat_of_N b).  unfold ap in |- *.
  elim (sumbool_of_bool (Neqb (N_of_nat n) b)).  intro y0.  rewrite y0.
  unfold renfnad, ap' in |- *.  unfold renfnat in |- *.  rewrite <- (Neqb_complete _ _ y0).
  rewrite (nat_of_N_of_nat n).  replace (leb (S n) n) with false.
  rewrite (plus_comm n N).  reflexivity.  symmetry  in |- *.  apply leb_correct_conv.
  auto.  intro y0.  rewrite y0.  unfold renfnad in |- *.  unfold renfnat in |- *.  rewrite y.
  rewrite (N_of_nat_of_N b).  replace (leb (S n) (nat_of_N b)) with true.
  rewrite (N_of_nat_of_N b).  reflexivity.  symmetry  in |- *.
  elim (le_le_S_eq _ _ (leb_complete _ _ y)).  intro.  apply leb_correct.
  assumption.  intro.  rewrite H0 in y0.  rewrite (N_of_nat_of_N b) in y0.
  rewrite (Neqb_correct b) in y0.  discriminate.  intro y.  rewrite y.
  unfold renfnad at 1 in |- *.  unfold renfnat at 1 in |- *.
  replace (leb (S n) (nat_of_N b)) with false.
  replace (Neqb (ap n) (N_of_nat (nat_of_N b + N))) with false.
  unfold renfnad in |- *.  unfold renfnat in |- *.  rewrite y.  reflexivity.  symmetry  in |- *.
  apply not_true_is_false.  unfold not in |- *; intro.  unfold ap in H0.
  rewrite <- (nat_of_N_of_nat n) in H.
  rewrite (Neqb_complete _ _ H0) in H.
  rewrite (nat_of_N_of_nat (nat_of_N b + N)) in H.  apply (lt_irrefl N).
  apply le_lt_trans with (m := nat_of_N b + N).  apply le_plus_r.
  assumption.  symmetry  in |- *.  apply not_true_is_false.  unfold not in |- *; intro.
  cut (leb n (nat_of_N b) = true).  intro.  rewrite H1 in y.  discriminate.
  apply leb_correct.  apply le_trans with (m := S n).  apply le_S.  apply le_n.  apply leb_complete.  assumption.  intros.  simpl in |- *.  rewrite (H n H0).
  reflexivity.  intros.  simpl in |- *.  rewrite (H n H1).  rewrite (H0 n H1).
  reflexivity.  intros.  simpl in |- *.  rewrite (H n H1).  rewrite (H0 n H1).
  reflexivity.  intros.  simpl in |- *.  rewrite (H n H1).  rewrite (H0 n H1).
  reflexivity.  intros.  simpl in |- *.  rewrite (H n H1).  rewrite (H0 n H1).
  reflexivity.
Qed.

Lemma replacel_lemma :
 forall (n : nat) (be : bool_expr),
 n <= N -> replacel be (lx_1 n) (lx'_1 N n) = renamef (renfnad n) be.
Proof.
  simple induction n.  simpl in |- *.  unfold renfnad in |- *.  unfold renfnat in |- *.  intro.  intro.
  replace
   (renamef
      (fun x : ad =>
       N_of_nat
         match leb 0 (nat_of_N x) with
         | true => nat_of_N x
         | false => nat_of_N x + N
         end) be) with (renamef (fun x => x) be).
  symmetry  in |- *.  apply renamef_id.  apply renamef_ext.  intro.
  rewrite (leb_correct 0 (nat_of_N x) (le_O_n _)).  symmetry  in |- *.
  apply N_of_nat_of_N.  simpl in |- *.  intros.  rewrite (H be).  unfold replace in |- *.
  symmetry  in |- *.  unfold replace in |- *.  apply renamefS.  assumption.
  apply le_trans with (m := S n0).  apply le_S.  apply le_n.  assumption.
Qed.

Lemma replacel_lemma2 :
 forall be : bool_expr,
 be_ok (var_lu 0 N) be -> replacel be (lx N) (lx' N) = be_dash be.
Proof.
  intros.  unfold lx, lx' in |- *.  rewrite (replacel_lemma N be (le_n _)).  symmetry  in |- *.
  apply dash_renf.  assumption.
Qed.

Lemma exl_semantics :
 forall (lx : list ad) (be : bool_expr) (ve : var_env'),
 (forall n : nat, ve n = true -> ~ In (N_of_nat n) lx) ->
 no_dup_list _ lx ->
 (eval_be' (exl be lx) ve = true <->
  (exists ve' : var_env',
     (forall n : nat, ve' n = true -> In (N_of_nat n) lx) /\
     eval_be' be (var_env'_or ve ve') = true)).
Proof.
  simple induction lx.  simpl in |- *.  intros be ve H H00.  split.  intro.
  split with (fun n : nat => false).  split.  intros.  discriminate.  unfold var_env'_or in |- *.
  rewrite <- H0.  unfold eval_be' in |- *.  apply (bool_fun_of_be_ext be).
  unfold var_env'_to_env in |- *.  intro.  elim (ve (nat_of_N x)); reflexivity.
  intros.  elim H0; clear H0.  intros ve' H0.  inversion H0.  clear H0.
  rewrite <- H2.  unfold eval_be' in |- *.  apply (bool_fun_of_be_ext be).
  unfold var_env'_to_env in |- *.  unfold var_env'_or in |- *.  intro.
  replace (ve' (nat_of_N x)) with false.  elim (ve (nat_of_N x)); reflexivity.
  symmetry  in |- *.  apply not_true_is_false.  unfold not in |- *; intro.  exact (H1 _ H0).
  intros a l H be ve H0 H00.  split.  intros.  simpl in H1.
  unfold eval_be' in H1.
  rewrite (ex_OK a (exl be l) (var_env'_to_env ve)) in H1.
  unfold bool_fun_ex in H1.  unfold bool_fun_or in H1.
  unfold bool_fun_restrict in H1.  elim (orb_prop _ _ H1); clear H1; intros.
  elim
   (H be
      (fun n : nat =>
       match Neqb (N_of_nat n) a with
       | true => true
       | false => ve n
       end)).
  intros.  clear H3.  elim H2.  intros ve' H3.  inversion H3.  clear H3.
  split
   with
     (fun n : nat =>
      match Neqb (N_of_nat n) a with
      | true => true
      | false => ve' n
      end).
  split.  intros.  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y.
  rewrite <- (Neqb_complete _ _ y).  left.  reflexivity.  intro y.
  rewrite y in H3.  right.  apply H4; assumption.
  replace
   (eval_be' be
      (var_env'_or ve
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve' n
          end))) with
   (eval_be' be
      (var_env'_or
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve n
          end) ve')).
  assumption.  unfold eval_be', var_env'_or in |- *.  apply (bool_fun_of_be_ext be).
  unfold var_env'_to_env in |- *.  intro.  rewrite (N_of_nat_of_N x).
  elim (Neqb x a).  auto with bool.  auto with bool.  unfold eval_be' in |- *.
  replace
   (bool_fun_of_bool_expr (exl be l)
      (var_env'_to_env
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve n
          end))) with
   (bool_fun_of_bool_expr (exl be l) (augment (var_env'_to_env ve) a true)).
  assumption.  apply (bool_fun_of_be_ext (exl be l)).
  unfold augment, var_env'_to_env in |- *.  intro.  rewrite (N_of_nat_of_N x).
  rewrite (Neqb_comm a x).  reflexivity.  intros.
  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y.
  rewrite (Neqb_complete _ _ y).  apply no_dup_cons_no_in.  assumption.  intro y.
  rewrite y in H2.  simpl in H0.  exact (fun x => H0 _ H2 (or_intror _ x)).
  apply no_dup_cons_no_dup with (a := a).  assumption.
  elim
   (H be
      (fun n : nat =>
       match Neqb (N_of_nat n) a with
       | true => false
       | false => ve n
       end)).
  intros.  clear H3 H.  elim H2.  intros ve' H.  inversion H.  clear H.
  clear H2.  split with ve'.  split.  intros.  right.  apply H3.  assumption.
  rewrite <- H4.  unfold eval_be' in |- *.  apply (bool_fun_of_be_ext be).
  unfold var_env'_to_env, var_env'_or in |- *.  intro.  rewrite (N_of_nat_of_N x).
  elim (sumbool_of_bool (Neqb x a)).  intro y.  rewrite y.  simpl in |- *.
  rewrite (Neqb_complete _ _ y).  elim (sumbool_of_bool (ve (nat_of_N a))).
  intro y0.  elim (H0 _ y0).  rewrite (N_of_nat_of_N a).  left.  reflexivity.
  intro y0.  rewrite y0.  reflexivity.  intro y.  rewrite y.  reflexivity.
  rewrite <- H1.  unfold eval_be' in |- *.  apply (bool_fun_of_be_ext (exl be l)).
  unfold var_env'_to_env, augment in |- *.  intro.  rewrite (N_of_nat_of_N x).
  rewrite (Neqb_comm a x).  reflexivity.  intros.
  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y.
  rewrite (Neqb_complete _ _ y).  apply no_dup_cons_no_in.  assumption.  intro y.
  rewrite y in H2.  exact (fun x => H0 _ H2 (or_intror _ x)).
  apply no_dup_cons_no_dup with (a := a).  assumption.  intros.  elim H1; clear H1.
  intros ve' H1.  inversion H1.  clear H1.  simpl in |- *.  unfold eval_be' in |- *.
  rewrite (ex_OK a (exl be l) (var_env'_to_env ve)).  unfold bool_fun_ex in |- *.
  unfold bool_fun_or in |- *.  unfold bool_fun_restrict in |- *.
  elim (sumbool_of_bool (ve' (nat_of_N a))).  intro y.
  elim
   (H be
      (fun n : nat =>
       match Neqb (N_of_nat n) a with
       | true => true
       | false => ve n
       end)).
  intros.  clear H1 H.  apply orb_true_intro.  left.
  replace
   (bool_fun_of_bool_expr (exl be l) (augment (var_env'_to_env ve) a true))
   with
   (eval_be' (exl be l)
      (fun n : nat =>
       match Neqb (N_of_nat n) a with
       | true => true
       | false => ve n
       end)).
  apply H4.  split
   with
     (fun n : nat =>
      match Neqb (N_of_nat n) a with
      | true => false
      | false => ve' n
      end).
  split.  intros.  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y0.
  rewrite y0 in H.  discriminate.  intro y0.  rewrite y0 in H.  elim (H2 _ H).
  intro.  rewrite <- H1 in y0.  rewrite (Neqb_correct a) in y0.  discriminate.
  auto.  replace
   (eval_be' be
      (var_env'_or
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve n
          end)
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => false
          | false => ve' n
          end))) with (eval_be' be (var_env'_or ve ve')).
  assumption.  unfold eval_be' in |- *.  apply (bool_fun_of_be_ext be).  intro x.
  unfold var_env'_to_env, var_env'_or in |- *.  rewrite (N_of_nat_of_N x).
  elim (sumbool_of_bool (Neqb x a)).  intro y0.  rewrite y0.
  rewrite (Neqb_complete _ _ y0).  rewrite y.  auto with bool.  intro y0.
  rewrite y0.  reflexivity.  unfold eval_be' in |- *.
  apply (bool_fun_of_be_ext (exl be l)).  unfold var_env'_to_env, augment in |- *.
  intros.  rewrite (N_of_nat_of_N x).  rewrite (Neqb_comm a x).  reflexivity.
  intros.  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y0.
  rewrite (Neqb_complete _ _ y0).  apply no_dup_cons_no_in.  assumption.
  intro y0.  rewrite y0 in H1.  exact (fun x => H0 _ H1 (or_intror _ x)).
  apply no_dup_cons_no_dup with (a := a).  assumption.  intro y.  elim (H be ve).
  intros.  clear H H1.  apply orb_true_intro.  right.  rewrite <- H4.
  unfold eval_be' in |- *.  apply (bool_fun_of_be_ext (exl be l)).
  unfold augment, var_env'_to_env in |- *.  intro.  elim (sumbool_of_bool (Neqb a x)).
  intro y0.  rewrite y0.  symmetry  in |- *.  rewrite <- (Neqb_complete _ _ y0).
  apply not_true_is_false.  unfold not in |- *; intro.  apply (H0 _ H).  left.
  symmetry  in |- *.  apply N_of_nat_of_N.  intro y0.  rewrite y0.  reflexivity.
  split with ve'.  split.  intros.  elim (H2 _ H).  intro.  rewrite H1 in y.
  rewrite (nat_of_N_of_nat n) in y.  rewrite H in y.  discriminate.  auto.
  assumption.  intros.  exact (fun x => H0 _ H1 (or_intror _ x)).
  apply no_dup_cons_no_dup with (a := a).  assumption.
Qed.

Lemma univl_semantics :
 forall (lx : list ad) (be : bool_expr) (ve : var_env'),
 (forall n : nat, ve n = true -> ~ In (N_of_nat n) lx) ->
 no_dup_list _ lx ->
 (eval_be' (univl be lx) ve = true <->
  (forall ve' : var_env',
   (forall n : nat, ve' n = true -> In (N_of_nat n) lx) ->
   eval_be' be (var_env'_or ve ve') = true)).
Proof.
  simple induction lx.  simpl in |- *.  intros be ve H H00.  intros.  split.  intro.  intros.
  unfold eval_be' in |- *.
  replace (bool_fun_of_bool_expr be (var_env'_to_env (var_env'_or ve ve')))
   with (bool_fun_of_bool_expr be (var_env'_to_env ve)).
  assumption.  apply (bool_fun_of_be_ext be).  intros.  unfold var_env'_or in |- *.
  unfold var_env'_to_env in |- *.  replace (ve' (nat_of_N x)) with false.
  elim (ve (nat_of_N x)); reflexivity.  symmetry  in |- *.  apply not_true_is_false.
  unfold not in |- *; intro.  exact (H1 _ H2).  intros.
  replace (eval_be' be ve) with
   (eval_be' be (var_env'_or ve (fun n => false))).
  apply H0.  intros.  discriminate.  unfold eval_be' in |- *.
  apply (bool_fun_of_be_ext be).  intro.  unfold var_env'_to_env in |- *.
  unfold var_env'_or in |- *.  elim (ve (nat_of_N x)); reflexivity.  simpl in |- *.
  intros a l H be ve H0 H00.  intros.  split.  intros.  unfold eval_be' in H1.
  elim (sumbool_of_bool (ve' (nat_of_N a))).  intro y.
  rewrite (forall_OK a (univl be l) (var_env'_to_env ve)) in H1.
  unfold bool_fun_forall in H1.  unfold bool_fun_and in H1.
  elim (andb_prop _ _ H1).  intros.  clear H1.  clear H4.
  unfold bool_fun_restrict in H3.
  replace (eval_be' be (var_env'_or ve ve')) with
   (eval_be' be
      (var_env'_or
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve n
          end)
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => false
          | false => ve' n
          end))).
  elim
   (H be
      (fun n : nat =>
       match Neqb (N_of_nat n) a with
       | true => true
       | false => ve n
       end)).
  intros.  clear H4.  apply H1.  unfold augment in H3.  unfold eval_be' in |- *.
  replace
   (bool_fun_of_bool_expr (univl be l)
      (var_env'_to_env
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve n
          end))) with
   (bool_fun_of_bool_expr (univl be l)
      (fun y : BDDvar =>
       match Neqb a y with
       | true => true
       | false => var_env'_to_env ve y
       end)).
  assumption.  apply (bool_fun_of_be_ext (univl be l)).  intros.
  unfold var_env'_to_env in |- *.  rewrite (N_of_nat_of_N x).
  rewrite (Neqb_comm a x).  reflexivity.  intros.
  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y0.  rewrite y0 in H4.
  discriminate.  intro y0.  rewrite y0 in H4.  elim (H2 _ H4).  intro.
  rewrite <- H5 in y0.  rewrite (Neqb_correct a) in y0.  discriminate.
  trivial.  intros.  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y0.
  apply no_dup_cons_no_in.  rewrite (Neqb_complete _ _ y0).  assumption.
  intro y0.  rewrite y0 in H1.  unfold not in |- *; intro.  apply (H0 _ H1).  auto.
  apply no_dup_cons_no_dup with (a := a).  assumption.  unfold eval_be' in |- *.
  apply (bool_fun_of_be_ext be).  intros.  unfold var_env'_to_env, var_env'_or in |- *.
  rewrite (N_of_nat_of_N x).  elim (sumbool_of_bool (Neqb x a)).  intro y0.
  rewrite y0.  simpl in |- *.  rewrite (Neqb_complete _ _ y0).  rewrite y.
  auto with bool.  intro y0.  rewrite y0.  reflexivity.  intro y.  elim (H be ve).
  intros.  clear H4.  apply H3.  unfold eval_be' in |- *.
  apply forall_lemma1 with (a := a).  assumption.  intros.  elim (H2 _ H4).  intro.
  rewrite H5 in y.  rewrite (nat_of_N_of_nat n) in y.  rewrite y in H4.
  discriminate.  auto.  intros.  unfold not in |- *; intro.  apply (H0 _ H3).  auto.
  apply no_dup_cons_no_dup with (a := a).  assumption.  intros.  unfold eval_be' in |- *.
  rewrite (forall_OK a (univl be l) (var_env'_to_env ve)).
  unfold bool_fun_forall in |- *.  unfold bool_fun_and in |- *.  apply andb_true_intro.  split.
  unfold bool_fun_restrict in |- *.
  elim
   (H be
      (fun n : nat =>
       match Neqb (N_of_nat n) a with
       | true => true
       | false => ve n
       end)).
  intros.  clear H2.
  replace
   (bool_fun_of_bool_expr (univl be l) (augment (var_env'_to_env ve) a true))
   with
   (eval_be' (univl be l)
      (fun n : nat =>
       match Neqb (N_of_nat n) a with
       | true => true
       | false => ve n
       end)).
  apply H3.  intros.
  replace
   (eval_be' be
      (var_env'_or
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve n
          end) ve')) with
   (eval_be' be
      (var_env'_or ve
         (fun n : nat =>
          match Neqb (N_of_nat n) a with
          | true => true
          | false => ve' n
          end))).
  apply H1.  intros.  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y.
  left.  rewrite (Neqb_complete _ _ y).  reflexivity.  intro y.
  rewrite y in H4.  right.  apply H2.  assumption.  unfold eval_be' in |- *.
  apply (bool_fun_of_be_ext be).  intros.  unfold var_env'_to_env, var_env'_or in |- *.
  rewrite (N_of_nat_of_N x).  elim (sumbool_of_bool (Neqb x a)).  intro y.
  rewrite y.  auto with bool.  intro y.  rewrite y.  reflexivity.
  unfold eval_be' in |- *.  unfold var_env'_to_env in |- *.
  apply (bool_fun_of_be_ext (univl be l)).  intro.  rewrite (N_of_nat_of_N x).
  unfold augment in |- *.  rewrite (Neqb_comm a x).  reflexivity.  intros.
  elim (sumbool_of_bool (Neqb (N_of_nat n) a)).  intro y.
  apply no_dup_cons_no_in.  rewrite (Neqb_complete _ _ y).  assumption.
  intro y.  rewrite y in H2.  exact (fun x => H0 _ H2 (or_intror _ x)).
  apply no_dup_cons_no_dup with (a := a).  assumption.  unfold bool_fun_restrict in |- *.
  elim (H be ve).  intros.  clear H2.
  replace
   (bool_fun_of_bool_expr (univl be l) (augment (var_env'_to_env ve) a false))
   with (eval_be' (univl be l) ve).
  apply H3.  intros.  apply H1.  intros.  auto.  unfold eval_be' in |- *.
  apply (bool_fun_of_be_ext (univl be l)).  intro.
  unfold var_env'_to_env, augment in |- *.  elim (sumbool_of_bool (Neqb a x)).  intro y.
  rewrite y.  rewrite <- (Neqb_complete _ _ y).  apply not_true_is_false.
  unfold not in |- *.  intro.  elim (H0 (nat_of_N a)).  assumption.  left.
  rewrite (N_of_nat_of_N a).  reflexivity.  intro y.  rewrite y.  reflexivity.
  intros.  exact (fun x => H0 _ H2 (or_intror _ x)).
  apply no_dup_cons_no_dup with (a := a).  assumption.
Qed.

Lemma bool_fun_of_be_ext1 :
 forall (be : bool_expr) (ve ve' : var_env'),
 (forall x : ad,
  be_x_free x be = true -> ve (nat_of_N x) = ve' (nat_of_N x)) ->
 eval_be' be ve = eval_be' be ve'.
Proof.
  simple induction be.  reflexivity.  reflexivity.  intros.  simpl in H.
  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_var in |- *.  unfold var_env'_to_env in |- *.
  rewrite (H b).  reflexivity.  apply Neqb_correct.  simpl in |- *.  intros.
  unfold eval_be' in |- *.  simpl in |- *.  unfold eval_be' in H.  unfold bool_fun_neg in |- *.
  rewrite (H ve ve' H0).  reflexivity.  unfold eval_be' in |- *.  simpl in |- *.
  unfold bool_fun_or in |- *.  intros.  rewrite (H ve ve').  rewrite (H0 ve ve').
  reflexivity.  intros.  apply H1.  rewrite H2.  auto with bool.  intros.
  apply H1.  rewrite H2.  auto with bool.  unfold eval_be' in |- *.  simpl in |- *.
  unfold bool_fun_and in |- *.  simpl in |- *.  intros.  rewrite (H ve ve').
  rewrite (H0 ve ve').  reflexivity.  intros.  apply H1.  rewrite H2.
  auto with bool.  intros.  apply H1.  rewrite H2.  auto with bool.
  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_impl in |- *.  intros.  rewrite (H ve ve').
  rewrite (H0 ve ve').  reflexivity.  intros.  apply H1.  rewrite H2.
  auto with bool.  intros.  apply H1.  rewrite H2.  auto with bool.
  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_iff in |- *.  intros.  rewrite (H ve ve').
  rewrite (H0 ve ve').  reflexivity.  intros.  apply H1.  rewrite H2.
  auto with bool.  intros.  apply H1.  rewrite H2.  auto with bool.
Qed.

Lemma no_dup_lx'_1 : forall n : nat, no_dup_list _ (lx'_1 N n).
Proof.
  simple induction n.  simpl in |- *.  apply no_dup_nil.  simpl in |- *.  intros.  apply no_dup_cons.
  unfold not in |- *; intro.  elim (in_lx'_1_conv _ _ _ H0).  intros.
  elim (lt_irrefl _ H2).  assumption.
Qed.

Lemma mu_all_eval_semantics1 :
 forall t be : bool_expr,
 be_ok (var_lu 0 N) be ->
 forall ve : var_env',
 (forall n : nat, ve n = true -> var_lu 0 N (N_of_nat n) = true) ->
 eval_be' (mu_all_eval N t be) ve = true ->
 forall ve' : var_env',
 (forall n : nat, ve' n = true -> var_lu 0 N (N_of_nat n) = true) ->
 eval_be' t (var_env'_or ve (var_env'_dash ve')) = true ->
 eval_be' be ve' = true.
Proof.
  intros.  unfold mu_all_eval in H1.  rewrite (replacel_lemma2 be H) in H1.
  rewrite (eval_dash_lemma1 be ve').
  elim (univl_semantics (lx' N) (Impl t (be_dash be)) ve).  intros.  clear H5.
  cut
   (eval_be' (Impl t (be_dash be)) (var_env'_or ve (var_env'_dash ve')) =
    true).
  intro.  cut (eval_be' (be_dash be) (var_env'_or ve (var_env'_dash ve')) = true).
  intro.  rewrite <- H6.  apply bool_fun_of_be_ext1.  intros.
  unfold var_env'_or in |- *.  replace (ve (nat_of_N x)) with false.  reflexivity.
  symmetry  in |- *.  apply not_true_is_false.  unfold not in |- *; intro.
  cut (var_lu 0 N x = true).  cut (var_lu N (2 * N) x = true).  intros.
  unfold var_lu in H9, H10.  elim (andb_prop _ _ H9).
  elim (andb_prop _ _ H10).  intros.  apply (lt_irrefl N).
  apply le_lt_trans with (m := nat_of_N x).  apply leb_complete; assumption.
  unfold lt in |- *.  apply leb_complete; assumption.
  apply (be_ok_be_x_free (var_lu N (2 * N)) (be_dash be)).
  apply dash_be_ok.  assumption.  assumption.  rewrite <- (N_of_nat_of_N x).
  apply H0.  assumption.  unfold eval_be' in |- *.  unfold eval_be' in H5.  simpl in H5.
  unfold bool_fun_impl in H5.  unfold eval_be' in H3.  rewrite H3 in H5.
  simpl in H5.  assumption.  apply H4.  assumption.  intros.
  unfold var_env'_dash in H5.  elim (sumbool_of_bool (leb N n)).  intro y.
  rewrite y in H5.  apply in_lx'.  apply leb_complete; assumption.
  cut (var_lu 0 N (N_of_nat (n - N)) = true).  unfold var_lu in |- *.  intro.
  elim (andb_prop _ _ H6).  intros.
  rewrite (nat_of_N_of_nat (n - N)) in H8.  simpl in |- *.
  rewrite <- (plus_n_O N).  replace n with (n - N + N).
  replace (S (n - N + N)) with (S (n - N) + N).
  apply plus_le_compat.  apply leb_complete; assumption.  apply le_n.
  reflexivity.  rewrite (plus_comm (n - N) N).  symmetry  in |- *.
  apply le_plus_minus.  apply leb_complete; assumption.  apply H2.
  assumption.  intro y.  rewrite y in H5.  discriminate.  intros.
  unfold not in |- *; intro.  unfold lx' in H5.  elim (in_lx'_1_conv N N n H5).  intro.
  intro.  unfold var_lu in H0.  elim (andb_prop _ _ (H0 n H4)).  intros.
  apply (lt_irrefl N).  apply le_lt_trans with (m := n).  assumption.  unfold lt in |- *.
  rewrite (nat_of_N_of_nat n) in H9.  apply leb_complete; assumption.
  unfold lx' in |- *.  apply no_dup_lx'_1.
Qed.

Lemma mu_ex_eval_semantics1 :
 forall t be : bool_expr,
 be_ok (var_lu 0 N) be ->
 forall ve : var_env',
 (forall n : nat, ve n = true -> var_lu 0 N (N_of_nat n) = true) ->
 eval_be' (mu_ex_eval N t be) ve = true ->
 exists ve' : var_env',
   (forall n : nat, ve' n = true -> var_lu 0 N (N_of_nat n) = true) /\
   eval_be' t (var_env'_or ve (var_env'_dash ve')) = true /\
   eval_be' be ve' = true.
Proof.
  intros.  unfold mu_ex_eval in H1.  rewrite (replacel_lemma2 be H) in H1.
  elim (exl_semantics (lx' N) (ANd t (be_dash be)) ve).  intros.  clear H3.
  elim (H2 H1).  intros ve' H3.  inversion H3.  clear H2 H3.
  split with (fun n : nat => ve' (N + n)).  split.  intros.  unfold var_lu in |- *.
  apply andb_true_intro.  rewrite (nat_of_N_of_nat n).  split.
  apply leb_correct.  apply le_O_n.  elim (in_lx'_1_conv _ _ _ (H4 _ H2)).
  intros.  apply leb_correct.  unfold lt in H6.
  rewrite (Splus_nm N n) in H6.  rewrite (plus_Snm_nSm N n) in H6.
  apply (fun p n m : nat => plus_le_reg_l n m p) with (p := N).  assumption.  unfold eval_be' in H5.
  simpl in H5.  unfold bool_fun_and in H5.  elim (andb_prop _ _ H5).  intros.
  split.  rewrite <- H2.  unfold eval_be' in |- *.  apply (bool_fun_of_be_ext t).
  unfold var_env'_to_env, var_env'_or, var_env'_dash in |- *.  intros.
  elim (sumbool_of_bool (leb N (nat_of_N x))).  intro y.  rewrite y.
  rewrite <- (le_plus_minus N (nat_of_N x)).  reflexivity.
  apply leb_complete; assumption.  intro y.  rewrite y.
  replace (ve' (nat_of_N x)) with false.  reflexivity.  symmetry  in |- *.
  apply not_true_is_false.  unfold not in |- *; intro.  unfold lx' in H4.
  elim (in_lx'_1_conv _ _ _ (H4 _ H6)).  intros.
  rewrite (leb_correct _ _ H7) in y; discriminate.
  rewrite (eval_dash_lemma1 be (fun n : nat => ve' (N + n))).  rewrite <- H3.
  fold (eval_be' (be_dash be) (var_env'_or ve ve')) in |- *.  apply bool_fun_of_be_ext1.
  intros.  unfold var_env'_or in |- *.  unfold var_env'_dash in |- *.
  cut (var_lu N (2 * N) x = true).  unfold var_lu in |- *.  intro.
  elim (andb_prop _ _ H7).  intros.  rewrite H8.
  replace (ve (nat_of_N x)) with false.  simpl in |- *.
  rewrite <- (le_plus_minus N (nat_of_N x)).  reflexivity.
  apply leb_complete.  assumption.  symmetry  in |- *.  apply not_true_is_false.
  unfold not in |- *; intro.  unfold var_lu in H0.  elim (andb_prop _ _ (H0 _ H10)).
  intros.  rewrite (N_of_nat_of_N x) in H12.  apply (lt_irrefl N).
  apply le_lt_trans with (m := nat_of_N x).  apply leb_complete; assumption.    unfold lt in |- *.  apply leb_complete; assumption.
  apply be_ok_be_x_free with (be := be_dash be).  apply dash_be_ok.  assumption.
  assumption.  intros.  unfold lx' in |- *.  unfold not in |- *; intro.
  elim (in_lx'_1_conv _ _ _ H3).  intros.  unfold var_lu in H0.
  elim (andb_prop _ _ (H0 _ H2)).  rewrite (nat_of_N_of_nat n).  intros.
  apply (lt_irrefl N).  apply le_lt_trans with (m := n).  assumption.  unfold lt in |- *.
  apply leb_complete.  assumption.  unfold lx' in |- *.  apply no_dup_lx'_1.
Qed.

Lemma mu_ex_eval_semantics2 :
 forall t be : bool_expr,
 be_ok (var_lu 0 N) be ->
 forall ve : var_env',
 (forall n : nat, ve n = true -> var_lu 0 N (N_of_nat n) = true) ->
 (exists ve' : var_env',
    (forall n : nat, ve' n = true -> var_lu 0 N (N_of_nat n) = true) /\
    eval_be' t (var_env'_or ve (var_env'_dash ve')) = true /\
    eval_be' be ve' = true) -> eval_be' (mu_ex_eval N t be) ve = true.
Proof.
  unfold mu_ex_eval in |- *.  intros.  rewrite (replacel_lemma2 be H).  elim H1.
  clear H1.  intros ve' H1.  inversion H1.  inversion H3.  clear H3 H1.
  elim (exl_semantics (lx' N) (ANd t (be_dash be)) ve).  intros.  clear H1.
  apply H3.  clear H3.  split with (var_env'_dash ve').  split.
  unfold var_env'_dash in |- *.  intros.  elim (sumbool_of_bool (leb N n)).  intros y.
  apply in_lx'.  apply leb_complete.  assumption.  rewrite y in H1.
  unfold var_lu in H2.  elim (andb_prop _ _ (H2 _ H1)).
  rewrite (nat_of_N_of_nat (n - N)).  intros.  simpl in |- *.
  rewrite <- (plus_n_O N).  replace n with (n - N + N).
  replace (S (n - N + N)) with (S (n - N) + N).
  apply plus_le_compat.  apply leb_complete; assumption.  apply le_n.
  reflexivity.  rewrite (plus_comm (n - N) N).  symmetry  in |- *.
  apply le_plus_minus.  apply leb_complete; assumption.  intro y.
  rewrite y in H1.  discriminate.  unfold eval_be' in |- *.  simpl in |- *.
  unfold bool_fun_and in |- *.  apply andb_true_intro.  split.  exact H4.
  fold (eval_be' (be_dash be) (var_env'_or ve (var_env'_dash ve'))) in |- *.
  rewrite (eval_dash_lemma1 be ve') in H5.  rewrite <- H5.
  apply (bool_fun_of_be_ext1 (be_dash be)).  intros.  unfold var_env'_or in |- *.
  replace (ve (nat_of_N x)) with false.  reflexivity.  symmetry  in |- *.
  apply not_true_is_false.  unfold not in |- *; intro.  unfold var_lu in H0.
  elim (andb_prop _ _ (H0 _ H3)).  rewrite (N_of_nat_of_N x).  intros.
  elim (andb_prop _ _ (be_ok_be_x_free _ _ (dash_be_ok _ H) _ H1)).  intros.
  apply (lt_irrefl N).  apply le_lt_trans with (m := nat_of_N x).
  apply leb_complete; assumption.  unfold lt in |- *.
  apply leb_complete; assumption.  unfold not in |- *; intros.  unfold lx' in H3.
  elim (in_lx'_1_conv _ _ _ H3).  intros.  unfold var_lu in H0.
  elim (andb_prop _ _ (H0 _ H1)).  rewrite (nat_of_N_of_nat n).  intros.
  apply (lt_irrefl N).  apply le_lt_trans with (m := n).  assumption.  unfold lt in |- *.
  apply leb_complete.  assumption.  unfold lx' in |- *.  apply no_dup_lx'_1.
Qed.

Lemma mu_all_eval_semantics2 :
 forall t be : bool_expr,
 be_ok (var_lu 0 N) be ->
 forall ve : var_env',
 (forall n : nat, ve n = true -> var_lu 0 N (N_of_nat n) = true) ->
 (forall ve' : var_env',
  (forall n : nat, ve' n = true -> var_lu 0 N (N_of_nat n) = true) ->
  eval_be' t (var_env'_or ve (var_env'_dash ve')) = true ->
  eval_be' be ve' = true) -> eval_be' (mu_all_eval N t be) ve = true.
Proof.
  unfold mu_all_eval in |- *.  intros.  rewrite (replacel_lemma2 be H).
  elim (univl_semantics (lx' N) (Impl t (be_dash be)) ve).  intros.  clear H2.
  apply H3.  intros.  clear H3.  unfold eval_be' in |- *.  simpl in |- *.  unfold bool_fun_impl in |- *.
  elim
   (sumbool_of_bool
      (bool_fun_of_bool_expr t (var_env'_to_env (var_env'_or ve ve')))).
  intro y.  rewrite y.  simpl in |- *.  unfold eval_be' in H1.
  rewrite <- (H1 (fun n : nat => ve' (N + n))).
  fold (eval_be' be (fun n : nat => ve' (N + n))) in |- *.
  rewrite (eval_dash_lemma1 be (fun n : nat => ve' (N + n))).
  fold (eval_be' (be_dash be) (var_env'_or ve ve')) in |- *.  apply bool_fun_of_be_ext1.
  intros.  intros.  unfold var_env'_or in |- *.  unfold var_env'_dash in |- *.
  cut (var_lu N (2 * N) x = true).  unfold var_lu in |- *.  intro.
  elim (andb_prop _ _ H4).  intros.  rewrite H5.
  replace (ve (nat_of_N x)) with false.  simpl in |- *.
  rewrite <- (le_plus_minus N (nat_of_N x)).  reflexivity.
  apply leb_complete.  assumption.  symmetry  in |- *.  apply not_true_is_false.
  unfold not in |- *; intro.  unfold var_lu in H0.  elim (andb_prop _ _ (H0 _ H7)).
  intros.  rewrite (N_of_nat_of_N x) in H9.  apply (lt_irrefl N).
  apply le_lt_trans with (m := nat_of_N x).  apply leb_complete; assumption.
  unfold lt in |- *.  apply leb_complete; assumption.
  apply be_ok_be_x_free with (be := be_dash be).  apply dash_be_ok.  assumption.
  assumption.  intros.  unfold var_lu in |- *.  apply andb_true_intro.  split.
  apply leb_correct.  apply le_O_n.  rewrite (nat_of_N_of_nat n).
  unfold lx' in H2.  elim (in_lx'_1_conv _ _ _ (H2 _ H3)).  intros.
  unfold lt in H5.  rewrite (plus_comm N n) in H5.  rewrite (Splus_nm n N) in H5.
  apply leb_correct.  apply (fun p n m : nat => plus_le_reg_l n m p) with (p := N).
  rewrite (plus_comm N (S n)).  assumption.  rewrite <- y.
  fold
   (eval_be' t (var_env'_or ve (var_env'_dash (fun n : nat => ve' (N + n)))))
   in |- *.
  fold (eval_be' t (var_env'_or ve ve')) in |- *.  apply bool_fun_of_be_ext1.  intros.
  unfold var_env'_or in |- *.
  replace (var_env'_dash (fun n : nat => ve' (N + n)) (nat_of_N x)) with
   (ve' (nat_of_N x)).
  reflexivity.  unfold var_env'_dash in |- *.
  elim (sumbool_of_bool (leb N (nat_of_N x))).  intro y0.  rewrite y0.
  rewrite <- (le_plus_minus N (nat_of_N x)).  reflexivity.
  apply leb_complete; assumption.  intro y0.  rewrite y0.
  apply not_true_is_false.  unfold not in |- *; intro.  unfold lx' in H2.
  elim (in_lx'_1_conv _ _ _ (H2 _ H4)).  intros.
  rewrite (leb_correct _ _ H5) in y0; discriminate.  intro y.  rewrite y.
  reflexivity.  intros.  unfold not in |- *; intro.  unfold lx' in H3.
  elim (in_lx'_1_conv N N n H3).  intro.  intro.  unfold var_lu in H0.
  elim (andb_prop _ _ (H0 n H2)).  intros.  apply (lt_irrefl N).
  apply le_lt_trans with (m := n).  assumption.  unfold lt in |- *.
  rewrite (nat_of_N_of_nat n) in H7.  apply leb_complete; assumption.
  unfold lx' in |- *.  apply no_dup_lx'_1.
Qed.

End New.


Require Import floyd.proofauto.
Require Import mc_reify.funcs.
Require Import mc_reify.types.
Require Import mc_reify.reify.
Require Import MirrorCore.Lambda.ExprCore.

Definition initialized_temp (id : positive) (t : PTree.t (type * bool)) :=
match (t ! id) with
| Some (ty, _) =>
  PTree.set id (ty, true) t
| None => t
end.

Fixpoint update_temp (t : PTree.t (type * bool)) (s : statement) :=
 match s with
 | Sskip | Scontinue | Sbreak => t
 | Sassign e1 e2 => t (*already there?*)
 | Sset id e2 => (initialized_temp id t)
 | Ssequence s1 s2 => let t' := update_temp t s1 in
                      update_temp t' s2
 | Sifthenelse b s1 s2 => join_te (update_temp t s1) (update_temp t s2)
 | Sloop _ _ => t
 | Sswitch e ls => update_temp_labeled t ls
 | Scall (Some id) _ _ => (initialized_temp id t)
 | _ => t  (* et cetera *)
end
with update_temp_labeled (t : PTree.t (type * bool)) (ls : labeled_statements) :=
       match ls with
         | LSnil => t
         | LScons _ s ls' =>
           join_te (update_temp t s) (update_temp_labeled t ls')
       end.

Lemma initialized_temp_eq : forall t v r gt gs i,
initialized i (mk_tycontext t v r gt gs) = mk_tycontext (initialized_temp i t) v r gt gs.
Proof.
intros.
unfold initialized, temp_types, initialized_temp. simpl. destruct (t ! i); auto.
destruct p; auto.
Qed.

Lemma update_temp_eq : forall t v r gt gs s,
update_tycon (mk_tycontext t v r gt gs) s = (mk_tycontext (update_temp t s) v r gt gs)
with
update_temp_labeled_eq : forall t v r gt gs s,
join_tycon_labeled s (mk_tycontext t v r gt gs) = (mk_tycontext (update_temp_labeled t s) v r gt gs).
Proof.
intros.
destruct s; intros;
simpl; try rewrite initialized_temp_eq; try reflexivity.
destruct o; try rewrite initialized_temp_eq; auto.
repeat rewrite update_temp_eq. reflexivity.
unfold join_tycon.
repeat rewrite update_temp_eq. reflexivity.
repeat rewrite update_temp_labeled_eq. reflexivity.

intros.
destruct s; intros; simpl; try reflexivity.
unfold join_tycon. repeat rewrite update_temp_eq.
rewrite update_temp_labeled_eq. reflexivity.
Qed.


From Coq Require Import Program ssreflect ssrbool List.
From MetaCoq.Template Require Import config utils Kernames MCRelations.

From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive
  PCUICReduction
  PCUICReflect PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICCasesContexts
  PCUICWeakeningConv PCUICWeakeningTyp
  PCUICContextConversionTyp
  PCUICTyping PCUICGlobalEnv PCUICInversion PCUICGeneration
  PCUICConfluence PCUICConversion
  PCUICUnivSubstitutionTyp
  PCUICCumulativity PCUICSR PCUICSafeLemmata
  PCUICValidity PCUICPrincipality PCUICElimination
  PCUICOnFreeVars PCUICWellScopedCumulativity PCUICSN PCUICCanonicity.

From MetaCoq Require Import PCUICArities PCUICSpine.
From MetaCoq.PCUIC Require PCUICWcbvEval.

Section firstorder.

  Context {Σ : global_env_ext}.
  Context {Σb : list (kername × bool)}.

  Fixpoint plookup_env {A} (Σ : list (kername × A)) (kn : kername) {struct Σ} : option A :=
  match Σ with
  | [] => None
  | d :: tl => if eq_kername kn d.1 then Some d.2 else plookup_env tl kn
  end.
  (*
  Definition zo_type (t : term) :=
    match (PCUICAstUtils.decompose_app t).1 with
    | tProd _ _ _ => false
    | tSort _ => false
    | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with
                             | Some l => nth i l false | None => false
                             end
    | _ => true
    end. *)

  Definition firstorder_type (n k : nat) (t : term) :=
    match (PCUICAstUtils.decompose_app t).1 with
    | tInd (mkInd nm i) u => match (plookup_env Σb nm) with
                             | Some b => b | None => false
                             end
    | tRel i => (k <=? i) && (i <? n + k)
    | _ => false
    end.
  (*
  Definition firstorder_type (t : term) :=
    match (PCUICAstUtils.decompose_app t).1 with
    | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with
                             | Some l => nth i l false | None => false
                             end
    | _ => false
    end. *)

  Definition firstorder_con mind (c : constructor_body) :=
    let inds := #|mind.(ind_bodies)| in
    alli (fun k '({| decl_body := b ; decl_type := t ; decl_name := n|}) =>
      firstorder_type inds k t) 0
      (List.rev (c.(cstr_args) ++ mind.(ind_params)))%list.

  Definition firstorder_oneind mind (ind : one_inductive_body) :=
    forallb (firstorder_con mind) ind.(ind_ctors) && negb (Universe.is_level (ind_sort ind)).

  Definition firstorder_mutind (mind : mutual_inductive_body) :=
    (* if forallb (fun decl => firstorder_type decl.(decl_type)) mind.(ind_params) then *)
    (mind.(ind_finite) == Finite) &&
    forallb (firstorder_oneind mind) mind.(ind_bodies)
    (* else repeat false (length mind.(ind_bodies)). *).

  Definition firstorder_ind (i : inductive) :=
    match lookup_env Σ.1 (inductive_mind i) with
    | Some (InductiveDecl mind) => firstorder_mutind mind
    | _ => false
    end.

End firstorder.

Fixpoint firstorder_env' (Σ : global_declarations) :=
  match Σ with
  | nil => []
  | (nm, ConstantDecl _) :: Σ' =>
    let Σb := firstorder_env' Σ' in
    ((nm, false) :: Σb)
  | (nm, InductiveDecl mind) :: Σ' =>
    let Σb := firstorder_env' Σ' in
    ((nm, @firstorder_mutind Σb mind) :: Σb)
  end.

Definition firstorder_env (Σ : global_env_ext) :=
  firstorder_env' Σ.1.(declarations).

Section cf.

Context {cf : config.checker_flags}.

Definition isPropositional Σ ind b :=
  match lookup_env Σ (inductive_mind ind) with
  | Some (InductiveDecl mdecl) =>
    match nth_error mdecl.(ind_bodies) (inductive_ind ind) with
    | Some idecl =>
      match destArity [] idecl.(ind_type) with
      | Some (_, s) => is_propositional s = b
      | None => False
      end
    | None => False
    end
  | _ => False
  end.

Inductive firstorder_value Σ Γ : term -> Prop :=
| firstorder_value_C i n ui u args pandi :
   Σ ;;; Γ |- mkApps (tConstruct i n ui) args :
   mkApps (tInd i u) pandi ->
   Forall (firstorder_value Σ Γ) args ->
   isPropositional Σ i false ->
   firstorder_value Σ Γ (mkApps (tConstruct i n ui) args).

Lemma firstorder_value_inds :
 forall (Σ : global_env_ext) (Γ : context) (P : term -> Prop),
(forall (i : inductive) (n : nat) (ui u : Instance.t)
   (args pandi : list term),
 Σ;;; Γ |- mkApps (tConstruct i n ui) args : mkApps (tInd i u) pandi ->
 Forall (firstorder_value Σ Γ) args ->
 Forall P args ->
 isPropositional (PCUICEnvironment.fst_ctx Σ) i false ->
 P (mkApps (tConstruct i n ui) args)) ->
forall t : term, firstorder_value Σ Γ t -> P t.
Proof using Type.
  intros ? ? ? ?. fix rec 2. intros t [ ]. eapply H; eauto.
  clear - H0 rec.
  induction H0; econstructor; eauto.
Qed.

Lemma firstorder_ind_propositional {Σ : global_env_ext} i mind oind :
  squash (wf_ext Σ) ->
  declared_inductive Σ i mind oind ->
  @firstorder_ind Σ (firstorder_env Σ) i ->
  isPropositional Σ i false.
Proof using Type.
  intros Hwf d. pose proof d as [d1 d2]. intros H. red in d1. unfold firstorder_ind in H.
  red. sq.
  unfold PCUICEnvironment.fst_ctx in *. rewrite d1 in H |- *.
  solve_all.
  unfold firstorder_mutind in H.
  rewrite d2. move/andP: H => [ind H0].
  eapply forallb_nth_error in H0; tea.
  erewrite d2 in H0. cbn in H0.
  unfold firstorder_oneind in H0. solve_all.
  destruct (ind_sort oind) eqn:E2; inv H0.
  eapply PCUICInductives.declared_inductive_type in d.
  rewrite d. rewrite E2.
  now rewrite destArity_it_mkProd_or_LetIn.
Qed.

Inductive firstorder_spine Σ (Γ : context) : term -> list term -> term -> Type :=
| firstorder_spine_nil ty ty' :
    isType Σ Γ ty ->
    isType Σ Γ ty' ->
    Σ ;;; Γ ⊢ ty ≤ ty' ->
    firstorder_spine Σ Γ ty [] ty'

| firstorder_spine_cons ty hd tl na i u args B B' mind oind :
    isType Σ Γ ty ->
    isType Σ Γ (tProd na (mkApps (tInd i u) args) B) ->
    Σ ;;; Γ ⊢ ty ≤ tProd na (mkApps (tInd i u) args) B ->
    declared_inductive Σ i mind oind ->
    Σ ;;; Γ |- hd : (mkApps (tInd i u) args) ->
    @firstorder_ind Σ (@firstorder_env Σ) i ->
    firstorder_spine Σ Γ (subst10 hd B) tl B' ->
    firstorder_spine Σ Γ ty (hd :: tl) B'.

Inductive instantiated {Σ} (Γ : context) : term -> Type :=
| instantiated_mkApps i u args : instantiated Γ (mkApps (tInd i u) args)
| instantiated_LetIn na d b ty :
  instantiated Γ (ty {0 := d}) ->
  instantiated Γ (tLetIn na d b ty)
| instantiated_tProd na B i u args :
  @firstorder_ind Σ (@firstorder_env Σ) i ->
    (forall x,
       (* Σ ;;; Γ |- x : mkApps (tInd i u) args ->  *)
      instantiated Γ (subst10 x B)) ->
    instantiated Γ (tProd na (mkApps (tInd i u) args) B).

Import PCUICLiftSubst.
Lemma isType_context_conversion {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ} {T} :
  isType Σ Γ T ->
  Σ ⊢ Γ = Δ ->
  wf_local Σ Δ ->
  isType Σ Δ T.
Proof using Type.
  intros [s Hs]. exists s. eapply context_conversion; tea. now eapply ws_cumul_ctx_pb_forget.
Qed.

Lemma typing_spine_arity_spine {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ args T' i u pars :
  typing_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd i u) pars)) args T' ->
  arity_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd i u) pars)) args T'.
Proof using Type.
  intros H. revert args pars T' H.
  induction Δ using PCUICInduction.ctx_length_rev_ind; intros args pars T' H.
  - cbn. depelim H.
    + econstructor; eauto.
    + eapply invert_cumul_ind_prod in w. eauto.
  - cbn. depelim H.
    + econstructor; eauto.
    + rewrite it_mkProd_or_LetIn_app in w, i0 |- *. cbn. destruct d as [name [body |] type]; cbn in *.
      -- constructor. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps. eapply X. now len.
         econstructor; tea. eapply isType_tLetIn_red in i0.
         rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps Nat.add_0_r in i0. now rewrite Nat.add_0_r. pcuic.
         etransitivity; tea. eapply into_ws_cumul_pb. 2,4:fvs.
         econstructor 3. 2:{ econstructor. }
         rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps //. constructor 1. reflexivity.
         eapply isType_tLetIn_red in i0. 2:pcuic.
         rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps in i0.
         now eapply isType_open.
      -- eapply cumul_Prod_inv in w as []. econstructor.
         ++ eapply type_ws_cumul_pb. 3: eapply PCUICContextConversion.ws_cumul_pb_eq_le; symmetry. all:eauto.
            eapply isType_tProd in i0. eapply i0.
         ++ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. autorewrite with subst.
            cbn. eapply X. len. lia.
            eapply typing_spine_strengthen. eauto.
            2:{ replace (it_mkProd_or_LetIn (subst_context [hd] 0 Γ0)
            (mkApps (tInd i u) (map (subst [hd] (#|Γ0| + 0)) pars))) with ((PCUICAst.subst10 hd (it_mkProd_or_LetIn Γ0 (mkApps (tInd i u) pars)))).
            2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. }
            eapply substitution0_ws_cumul_pb. eauto. eauto.
            }
            replace (it_mkProd_or_LetIn (subst_context [hd] 0 Γ0)
            (mkApps (tInd i u) (map (subst [hd] (#|Γ0| + 0)) pars))) with ((PCUICAst.subst10 hd (it_mkProd_or_LetIn Γ0 (mkApps (tInd i u) pars)))).
            2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. }
            eapply isType_subst. eapply PCUICSubstitution.subslet_ass_tip. eauto.
            eapply isType_tProd in i0 as [_ tprod].
            eapply isType_context_conversion; tea. constructor. eapply ws_cumul_ctx_pb_refl. now eapply typing_wf_local, PCUICClosedTyp.wf_local_closed_context in t.
            constructor; tea. constructor. pcuic. eapply validity in t. now eauto.
Qed.

Lemma leb_spect : forall x y : nat, BoolSpecSet (x <= y) (y < x) (x <=? y).
Proof using Type.
  intros x y. destruct (x <=? y) eqn:E;
  econstructor; destruct (Nat.leb_spec x y); lia.
Qed.

Lemma nth_error_inds {ind u mind n} : n < #|ind_bodies mind| ->
  nth_error (inds ind u mind.(ind_bodies)) n = Some (tInd (mkInd ind (#|mind.(ind_bodies)| - S n)) u).
Proof using Type.
  unfold inds.
  induction #|ind_bodies mind| in n |- *.
  - intros hm. inv hm.
  - intros hn. destruct n => /=. lia_f_equal.
    eapply IHn0. lia.
Qed.

Lemma alli_subst_instance (Γ : context) u p :
  (forall k t, p k t = p k t@[u]) ->
  forall n,
    alli (fun (k : nat) '{| decl_type := t |} => p k t) n Γ =
    alli (fun (k : nat) '{| decl_type := t |} => p k t) n Γ@[u].
Proof using Type.
  intros hp.
  induction Γ; cbn => //.
  move=> n. destruct a; cbn. f_equal. apply hp. apply IHΓ.
Qed.

Arguments firstorder_mutind : clear implicits.

Lemma plookup_env_lookup_env {Σ : global_env_ext} kn b :
  plookup_env (firstorder_env Σ) kn = Some b ->
  ∑ Σ' decl, lookup_env Σ kn = Some decl ×
    extends_decls Σ' Σ ×
    match decl with
    | ConstantDecl _ => b = false
    | InductiveDecl mind =>
      b = firstorder_mutind (firstorder_env' (declarations Σ')) mind
    end.
Proof using.
  destruct Σ as [[univs Σ retro] ext].
  induction Σ; cbn => //.
  destruct a as [kn' d] => //. cbn.
  case: eqb_specT.
  * intros ->.
    destruct d => //; cbn; rewrite eqb_refl => [=] <-;
    exists {| universes := univs; declarations := Σ; retroknowledge := retro |}.
    eexists; split => //. cbn. split => //.
    red. split => //. eexists (_ :: []); cbn; trea.
    eexists; split => //. cbn; split => //.
    red. split => //. eexists (_ :: []); cbn; trea.
  * intros neq h.
    destruct d => //. cbn in h.
    move: h. case: eqb_specT=> // _ h'.
    unfold firstorder_env in IHΣ. cbn in IHΣ.
    specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]].
    exists Σ', decl; split => //. split => //.
    destruct ext' as [equ [Σ'' eq]]. split => //.
    eexists (_ :: Σ''). cbn in *. rewrite eq. trea.
    move: h. cbn. apply neqb in neq. rewrite (negbTE neq).
    intros h'; specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]].
    exists Σ', decl; split => //. split => //.
    destruct ext' as [equ [Σ'' eq]]. split => //.
    eexists (_ :: Σ''). cbn in *. rewrite eq. trea.
Qed.

Lemma firstorder_spine_let {Σ : global_env_ext} {wfΣ : wf Σ} {Γ na a A B args T'} :
  firstorder_spine Σ Γ (B {0 := a}) args T' ->
  isType Σ Γ (tLetIn na a A B) ->
  firstorder_spine Σ Γ (tLetIn na a A B) args T'.
Proof using Type.
  intros H; depind H.
  - constructor; auto.
    etransitivity; tea. eapply cumulSpec_cumulAlgo_curry; tea; fvs.
    eapply cumul_zeta.
  - intros. econstructor. tea.
    2:{ etransitivity; tea.
        eapply cumulSpec_cumulAlgo_curry; tea; fvs.
        eapply cumul_zeta. }
    all:tea.
Qed.

Lemma instantiated_typing_spine_firstorder_spine {Σ : global_env_ext} {wfΣ : wf Σ} Γ T args T' :
  instantiated (Σ := Σ) Γ T ->
  arity_spine Σ Γ T args T' ->
  isType Σ Γ T ->
  firstorder_spine Σ Γ T args T'.
Proof using Type.
  intros hi hsp.
  revert hi; induction hsp; intros hi isty.
  - constructor => //. now eapply isType_ws_cumul_pb_refl.
  - econstructor; eauto.
  - depelim hi. solve_discr. eapply firstorder_spine_let; eauto. eapply IHhsp => //.
    now eapply isType_tLetIn_red in isty; pcuic.
  - depelim hi. solve_discr.
    specialize (i1 hd). specialize (IHhsp i1).
    destruct (validity t) as [s Hs]. eapply inversion_mkApps in Hs as [? [hi _]].
    eapply inversion_Ind in hi as [mdecl [idecl [decli [? ?]]]].
    econstructor; tea. 2:{ eapply IHhsp. eapply isType_apply in isty; tea. }
    now eapply isType_ws_cumul_pb_refl. eauto.
Qed.

Arguments firstorder_type : clear implicits.

(* Lemma firstorder_env'_app x y :
  firstorder_env' (x ++ y) = firstorder_env' x ++ firstorder_env' y.
Proof.
  induction x in y |- *; cbn => //.
  destruct a => //. destruct g => //. cbn. f_equal; eauto.
  cbn; f_equal; eauto.
  f_equal. f_equal. eauto. *)

Import PCUICGlobalMaps.

Lemma fresh_global_app decls decls' kn :
  fresh_global kn (decls ++ decls') ->
  fresh_global kn decls /\ fresh_global kn decls'.
Proof.
  induction decls => /= //.
  - intros f; split => //.
  - intros f; depelim f.
    specialize (IHdecls f) as [].
    split; eauto. constructor => //.
Qed.

Lemma plookup_env_Some_not_fresh g kn b :
  plookup_env (firstorder_env' g) kn = Some b ->
  ~ PCUICGlobalMaps.fresh_global kn g.
Proof.
  induction g; cbn => //.
  destruct a => //. destruct g0 => //.
  - cbn.
    case: eqb_spec.
    + move=> -> [=].
      intros neq hf. depelim hf. now cbn in H.
    + move=> neq hl hf.
      apply IHg => //. now depelim hf.
  - cbn.
    case: eqb_spec.
    + move=> -> [=].
      intros neq hf. depelim hf. now cbn in H.
    + move=> neq hl hf.
      apply IHg => //. now depelim hf.
Qed.

Lemma plookup_env_extends {Σ Σ' : global_env} kn b :
  extends_decls Σ' Σ ->
  wf Σ ->
  plookup_env (firstorder_env' (declarations Σ')) kn = Some b ->
  plookup_env (firstorder_env' (declarations Σ)) kn = Some b.
Proof.
  intros [equ [Σ'' eq] eqr]. rewrite eq.
  clear equ eqr. intros []. clear o.
  rewrite eq in o0. clear eq. move: o0.
  generalize (declarations Σ'). clear Σ'.
  induction Σ''.
  - cbn => //.
  - cbn. destruct a => //. intros gs ong.
    depelim ong. specialize (IHΣ'' _ ong).
    destruct o as [f ? ? ?].
    destruct g => //.
    * intros hl. specialize (IHΣ'' hl).
      eapply plookup_env_Some_not_fresh in hl.
      cbn. case: eqb_spec.
      + intros <-.  apply fresh_global_app in f as [].
        contradiction.
      + now intros neq.
    * intros hl. specialize (IHΣ'' hl).
      eapply plookup_env_Some_not_fresh in hl.
      cbn. case: eqb_spec.
      + intros <-. apply fresh_global_app in f as [].
        contradiction.
      + now intros neq.
Qed.

Lemma firstorder_mutind_ext {Σ Σ' : global_env_ext} m :
  extends_decls Σ' Σ ->
  wf Σ ->
  firstorder_mutind (firstorder_env' (declarations Σ')) m ->
  firstorder_mutind (firstorder_env Σ) m.
Proof.
  intros [equ [Σ'' eq]] wf.
  unfold firstorder_env. rewrite eq.
  unfold firstorder_mutind.
  move/andP => [] -> /=. apply forallb_impl => x _.
  unfold firstorder_oneind.
  move/andP => [] h -> /=; rewrite andb_true_r.
  eapply forallb_impl; tea => c _.
  unfold firstorder_con.
  eapply alli_impl => i [] _ _ ty.
  unfold firstorder_type.
  destruct decompose_app => // /=.
  destruct t => //. destruct ind => //.
  destruct plookup_env eqn:hl => //. destruct b => //.
  eapply (plookup_env_extends (Σ:=Σ)) in hl. 2:split; eauto.
  rewrite eq in hl. rewrite hl //. apply wf.
Qed.

Lemma firstorder_args {Σ : global_env_ext} {wfΣ : wf Σ} { mind cbody i n ui args u pandi oind} :
  declared_constructor Σ (i, n) mind oind cbody ->
  PCUICArities.typing_spine Σ [] (type_of_constructor mind cbody (i, n) ui) args (mkApps (tInd i u) pandi) ->
  @firstorder_ind Σ (@firstorder_env Σ) i ->
  firstorder_spine Σ [] (type_of_constructor mind cbody (i, n) ui) args (mkApps (tInd i u) pandi).
Proof using Type.
  intros Hdecl Hspine Hind. revert Hspine.
  unshelve edestruct @declared_constructor_inv with (Hdecl := Hdecl); eauto. eapply weaken_env_prop_typing.

  (* revert Hspine. *) unfold type_of_constructor.
  erewrite cstr_eq. 2: eapply p.
  rewrite <- it_mkProd_or_LetIn_app.
  rewrite PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn.
  rewrite PCUICSpine.subst0_it_mkProd_or_LetIn. intros Hspine.

  match goal with
   | [ |- firstorder_spine _ _ ?T _ _ ] =>
  assert (@instantiated Σ [] T) as Hi end.
  { clear Hspine. destruct Hdecl as [[d1 d3] d2]. pose proof d3 as Hdecl.
    unfold firstorder_ind in Hind.
    rewrite d1 in Hind. solve_all. clear a.
    move/andP: Hind => [indf H0].
    eapply forallb_nth_error in H0 as H'.
    erewrite d3 in H'.
    unfold firstorder_oneind in H'. cbn in H'.
    rtoProp.
    eapply nth_error_forallb in H. 2: eauto.
    unfold firstorder_con in H.
    revert H. cbn.
    unfold cstr_concl.
    rewrite PCUICUnivSubst.subst_instance_mkApps subst_mkApps.
    rewrite subst_instance_length app_length.
    unfold cstr_concl_head. rewrite PCUICInductives.subst_inds_concl_head. now eapply nth_error_Some_length in Hdecl.
    rewrite -app_length.
    generalize (cstr_args cbody ++ ind_params mind)%list.
    clear -wfΣ d1 indf H1 H0 Hdecl.
    (* generalize conclusion to mkApps tInd args *)
    intros c.
    change (list context_decl) with context in c.
    move: (map (subst (inds _ _ _) _) _).
    intros args.
    rewrite (alli_subst_instance _ ui (fun k t => firstorder_type _ #|ind_bodies mind| k t)).
    { intros k t.
      rewrite /firstorder_type.
      rewrite -PCUICUnivSubstitutionConv.subst_instance_decompose_app /=.
      destruct (decompose_app) => //=. destruct t0 => //. }
    replace (List.rev c)@[ui] with (List.rev c@[ui]).
    2:{ rewrite /subst_instance /subst_instance_context /map_context map_rev //. }
    revert args.
    induction (c@[ui]) using PCUICInduction.ctx_length_rev_ind => args.
    - unfold cstr_concl, cstr_concl_head. cbn.
      autorewrite with substu subst.
      rewrite subst_context_nil. cbn -[subst0].
      econstructor.
    - rewrite rev_app_distr /=. destruct d as [na [b|] t].
      + move=> /andP[] fot foΓ.
        rewrite subst_context_app /=.
        rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=.
        constructor.
        rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=. len.
        rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
        cbn. len. eapply X. now len.
        rewrite -subst_telescope_subst_context. clear -foΓ.
        revert foΓ. move: (lift0 #|ind_bodies mind| _).
        generalize 0.
        induction (List.rev Γ) => //.
        cbn -[subst_telescope]. intros n t.
        destruct a; cbn -[subst_telescope].
        move/andP => [] fo fol.
        rewrite PCUICContextSubst.subst_telescope_cons /=.
        apply/andP; split; eauto.
        clear -fo.
        move: fo.
        unfold firstorder_type; cbn.
        destruct (decompose_app decl_type) eqn:da.
        rewrite (decompose_app_inv da) subst_mkApps /=.
        destruct t0 => //=.
        { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn'].
          destruct (Nat.leb_spec n n0).
          destruct (n0 - n) eqn:E. lia.
          cbn. rewrite nth_error_nil /=.
          rewrite decompose_app_mkApps //=.
          apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia.
          cbn.
          rewrite decompose_app_mkApps //=.
          apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. }
        { destruct ind => //. rewrite decompose_app_mkApps //. }
      + move=> /andP[] fot foΓ.
        rewrite subst_context_app /=.
        rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=.
        unfold firstorder_type in fot.
        destruct ((PCUICAstUtils.decompose_app t)) eqn:E.
        cbn in fot. destruct t0; try solve [inv fot].
        * rewrite (decompose_app_inv E) /= subst_mkApps.
          rewrite Nat.add_0_r in fot. eapply Nat.ltb_lt in fot.
          cbn. rewrite nth_error_inds. lia. cbn.
          econstructor.
          { rewrite /firstorder_ind d1 /= /firstorder_mutind indf H0 //. }
          intros x.
          rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=. len.
          rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
          cbn. len. eapply X. now len.
          rewrite -subst_telescope_subst_context. clear -foΓ.
          revert foΓ. generalize (lift0 #|ind_bodies mind| x).
          generalize 0.
          induction (List.rev Γ) => //.
          cbn -[subst_telescope]. intros n t.
          destruct a; cbn -[subst_telescope].
          move/andP => [] fo fol.
          rewrite PCUICContextSubst.subst_telescope_cons /=.
          apply/andP; split; eauto.
          clear -fo.
          move: fo.
          unfold firstorder_type; cbn.
          destruct (decompose_app decl_type) eqn:da.
          rewrite (decompose_app_inv da) subst_mkApps /=.
          destruct t0 => //=.
          { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn'].
            destruct (Nat.leb_spec n n0).
            destruct (n0 - n) eqn:E. lia.
            cbn. rewrite nth_error_nil /=.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia.
            cbn.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. }
          { destruct ind => //. rewrite decompose_app_mkApps //. }
        * rewrite (decompose_app_inv E) subst_mkApps //=.
          constructor. {
             unfold firstorder_ind. destruct ind. cbn in *.
             destruct plookup_env eqn:hp => //.
             eapply plookup_env_lookup_env in hp as [Σ' [decl [eq [ext he]]]].
             rewrite eq. destruct decl; subst b => //.
             eapply (firstorder_mutind_ext (Σ' := (empty_ext Σ'))); tea. }
          intros x. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=; len.
          rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
          eapply X. now len. len.
          rewrite -subst_telescope_subst_context. clear -foΓ.
          revert foΓ. generalize (lift0 #|ind_bodies mind| x).
          generalize 0.
          induction (List.rev Γ) => //.
          cbn -[subst_telescope]. intros n t.
          destruct a; cbn -[subst_telescope].
          move/andP => [] fo fol.
          rewrite PCUICContextSubst.subst_telescope_cons /=.
          apply/andP; split; eauto.
          clear -fo.
          move: fo.
          unfold firstorder_type; cbn.
          destruct (decompose_app decl_type) eqn:da.
          rewrite (decompose_app_inv da) subst_mkApps /=.
          destruct t0 => //=.
          { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn'].
            destruct (Nat.leb_spec n n0).
            destruct (n0 - n) eqn:E. lia.
            cbn. rewrite nth_error_nil /=.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia.
            cbn.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. }
          { destruct ind => //. rewrite decompose_app_mkApps //. }
  }
  cbn in Hi |- *.
  revert Hi Hspine. cbn.
  unfold cstr_concl, cstr_concl_head.
  autorewrite with substu subst.
  rewrite subst_instance_length app_length.
  rewrite PCUICInductives.subst_inds_concl_head. { cbn. destruct Hdecl as [[d1 d2] d3]. eapply nth_error_Some. rewrite d2. congruence. }
  match goal with [ |- context[mkApps _ ?args]] => generalize args end.
  intros args' Hi Spine.
  eapply instantiated_typing_spine_firstorder_spine; tea.
  now eapply typing_spine_arity_spine in Spine.
  now eapply typing_spine_isType_dom in Spine.
Qed.

Lemma invert_cumul_it_mkProd_or_LetIn_Sort_Ind {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ s i u args} :
  Σ ;;; Γ ⊢ it_mkProd_or_LetIn Δ (tSort s) ≤ mkApps (tInd i u) args -> False.
Proof using Type.
  induction Δ using PCUICInduction.ctx_length_rev_ind; cbn.
  - eapply invert_cumul_sort_ind.
  - rewrite it_mkProd_or_LetIn_app; destruct d as [na [b|] ty]; cbn.
    * intros hl.
      eapply ws_cumul_pb_LetIn_l_inv in hl.
      rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn in hl.
      eapply H, hl. now len.
    * intros hl. now eapply invert_cumul_prod_ind in hl.
Qed.

Lemma firstorder_value_spec Σ t i u args mind :
  wf_ext Σ -> wf_local Σ [] ->
   Σ ;;; [] |- t : mkApps (tInd i u) args ->
  PCUICWcbvEval.value Σ t ->
  lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) ->
  @firstorder_ind Σ (firstorder_env Σ) i ->
  firstorder_value Σ [] t.
Proof using Type.
  intros Hwf Hwfl Hty Hvalue.
  revert mind i u args Hty.

  induction Hvalue as [ t Hvalue | t args' Hhead Hargs IH ] using PCUICWcbvEval.value_values_ind;
   intros mind i u args Hty Hlookup Hfo.
  - destruct t; inversion_clear Hvalue.
    + exfalso. eapply inversion_Sort in Hty as (? & ? & Hcumul); eauto.
      now eapply invert_cumul_sort_ind in Hcumul.
    + exfalso. eapply inversion_Prod in Hty as (? & ? & ? & ? & Hcumul); eauto.
      now eapply invert_cumul_sort_ind in Hcumul.
    + exfalso. eapply inversion_Lambda in Hty as (? & ? & ? & ? & Hcumul); eauto.
      now eapply invert_cumul_prod_ind in Hcumul.
    + exfalso. eapply inversion_Ind in Hty as (? & ? & ? & ? & ? & ?); eauto.
      eapply PCUICInductives.declared_inductive_type in d.
      rewrite d in w.
      destruct (ind_params x ,,, ind_indices x0) as [ | [? [] ?] ? _] using rev_ind.
      * cbn in w. now eapply invert_cumul_sort_ind in w.
      * rewrite it_mkProd_or_LetIn_app in w. cbn in w.
        eapply ws_cumul_pb_LetIn_l_inv in w.
        rewrite /subst1 PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn PCUICLiftSubst.subst_it_mkProd_or_LetIn in w.
        now eapply invert_cumul_it_mkProd_or_LetIn_Sort_Ind in w.
      * rewrite it_mkProd_or_LetIn_app in w. cbn in w.
        now eapply invert_cumul_prod_ind in w.
    + eapply inversion_Construct in Hty as Hty'; eauto.
      destruct Hty' as (? & ? & ? & ? & ? & ? & ?).
      assert (ind = i) as ->. {
         eapply PCUICInductiveInversion.Construct_Ind_ind_eq with (args := []); eauto.
      }
      eapply firstorder_value_C with (args := []); eauto.
      eapply firstorder_ind_propositional; eauto. sq. eauto.
      now eapply (declared_constructor_inductive (ind := (i, _))).
    + exfalso. eapply invert_fix_ind with (args := []) in Hty as [].
      destruct unfold_fix as [ [] | ]; auto. eapply nth_error_nil.
    + exfalso. eapply (typing_cofix_coind (args := [])) in Hty. red in Hty.
      red in Hfo. unfold firstorder_ind in Hfo.
      rewrite Hlookup in Hfo.
      eapply andb_true_iff in Hfo as [Hfo _].
      rewrite /check_recursivity_kind Hlookup in Hty.
      apply eqb_eq in Hfo, Hty. congruence.
    + eapply inversion_Prim in Hty as [prim_ty [cdecl [wf hp hdecl [s []] cum]]]; eauto.
      now eapply invert_cumul_axiom_ind in cum; tea.
  - destruct t; inv Hhead.
    + exfalso. now eapply invert_ind_ind in Hty.
    + apply inversion_mkApps in Hty as Hcon; auto.
      destruct Hcon as (?&typ_ctor& spine).
      apply inversion_Construct in typ_ctor as (?&?&?&?&?&?&?); auto.
      pose proof d as [[d' _] _]. red in d'. cbn in *. unfold PCUICEnvironment.fst_ctx in *.
      eapply @PCUICInductiveInversion.Construct_Ind_ind_eq with (mdecl := x0) in Hty as Hty'; eauto.
      destruct Hty' as (([[[]]] & ?)  & ? & ? & ? & ? & _). subst.
      econstructor; eauto.
      2:{ eapply firstorder_ind_propositional; sq; eauto. eapply declared_constructor_inductive in d. eauto. }
      eapply PCUICSpine.typing_spine_strengthen in spine. 3: eauto.
      2: eapply PCUICInductiveInversion.declared_constructor_valid_ty; eauto.

      eapply firstorder_args in spine; eauto.
      clear c0 c1 e0 w Hty H0 Hargs.
      induction spine.
      * econstructor.
      * destruct d as [d1 d2]. inv IH.
        econstructor. inv X.
        eapply H0. tea. eapply d0. exact i3.
        inv X. eapply IHspine; eauto.
     + exfalso.
       destruct PCUICWcbvEval.cunfold_fix as [[] | ] eqn:E; inversion H.
       eapply invert_fix_ind in Hty. auto.
       unfold unfold_fix. unfold PCUICWcbvEval.cunfold_fix in E.
       destruct (nth_error mfix idx); auto.
       inversion E; subst; clear E.
       eapply nth_error_None. lia.
    + exfalso. eapply (typing_cofix_coind (args := args')) in Hty.
      red in Hfo. unfold firstorder_ind in Hfo.
      rewrite Hlookup in Hfo.
      eapply andb_true_iff in Hfo as [Hfo _].
      rewrite /check_recursivity_kind Hlookup in Hty.
      apply eqb_eq in Hfo, Hty. congruence.
Qed.

End cf.


Require Import Verdi.GhostSimulations.
Require Import VerdiRaft.Raft.

Require Import VerdiRaft.RaftRefinementInterface.

Section RaftMsgRefinementInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition ghost_log : Type := list entry.

  Lemma ghost_log_eq_dec : forall x y : ghost_log, {x = y} + {x <> y}.
  Proof using.
    decide equality.
    apply entry_eq_dec.
  Qed.

  Definition write_ghost_log (h : name) (st : @data raft_refined_base_params) : ghost_log := log (snd st).

  Instance ghost_log_params : MsgGhostMultiParams raft_refined_multi_params :=
    {| ghost_msg := ghost_log ;
       ghost_msg_eq_dec := ghost_log_eq_dec ;
       ghost_msg_default := [] ;
       write_ghost_msg := write_ghost_log
    |}.

  Definition raft_msg_refined_base_params := mgv_refined_base_params.
  Definition raft_msg_refined_multi_params := mgv_refined_multi_params.
  Definition raft_msg_refined_failure_params := mgv_refined_failure_params.

  Hint Extern 3 (@BaseParams) => apply raft_msg_refined_base_params : typeclass_instances.
  Hint Extern 3 (@MultiParams _) => apply raft_msg_refined_multi_params : typeclass_instances.
  Hint Extern 3 (@FailureParams _ _) => apply raft_msg_refined_failure_params : typeclass_instances.

  Inductive msg_refined_raft_intermediate_reachable : network -> Prop :=
  | MRRIR_init : msg_refined_raft_intermediate_reachable step_async_init
  | MRRIR_step_failure :
      forall failed net failed' net' out,
        msg_refined_raft_intermediate_reachable net ->
        step_failure (failed, net) (failed', net') out ->
        msg_refined_raft_intermediate_reachable net'
  | MRRIR_handleInput :
      forall net h inp gd out d l ps' st',
        msg_refined_raft_intermediate_reachable net ->
        handleInput h inp (snd (nwState net h)) = (out, d, l) ->
        update_elections_data_input h inp (nwState net h) = gd ->
        (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d) h') ->
        (forall p', In p' ps' -> In p' (nwPackets net) \/
                           In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st')
  | MRRIR_handleMessage :
      forall p net xs ys st' ps' gd d l,
        msg_refined_raft_intermediate_reachable net ->
        handleMessage (pSrc p) (pDst p) (snd (pBody p)) (snd (nwState net (pDst p))) = (d, l) ->
        update_elections_data_net (pDst p) (pSrc p) (snd (pBody p)) (nwState net (pDst p)) = gd ->
        nwPackets net = xs ++ p :: ys ->
        (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
        (forall p', In p' ps' -> In p' (xs ++ ys) \/
                           In p' (send_packets (pDst p) (@add_ghost_msg _ _ ghost_log_params (pDst p) (gd, d) l))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st')
  | MRRIR_doLeader :
      forall net st' ps' h os gd d d' ms,
        msg_refined_raft_intermediate_reachable net ->
        doLeader d h = (os, d', ms) ->
        nwState net h = (gd, d) ->
        (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
        (forall p, In p ps' -> In p (nwPackets net) \/
                         In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st')
  | MRRIR_doGenericServer :
      forall net st' ps' os gd d d' ms h,
        msg_refined_raft_intermediate_reachable net ->
        doGenericServer h d = (os, d', ms) ->
        nwState net h = (gd, d) ->
        (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
        (forall p, In p ps' -> In p (nwPackets net) \/
                         In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_client_request (P : network -> Prop) :=
    forall h net st' ps' gd out d l client id c,
      handleClientRequest h (snd (nwState net h)) client id c = (out, d, l) ->
      gd = update_elections_data_client_request h (nwState net h) client id c ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                         In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_timeout (P : network -> Prop) :=
    forall net h st' ps' gd out d l,
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      gd = update_elections_data_timeout h (nwState net h) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                               In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t n pli plt es ci,
      handleAppendEntries (pDst p) (snd (nwState net (pDst p))) t n pli plt es ci = (d, m) ->
      gd = update_elections_data_appendEntries (pDst p) (nwState net (pDst p)) t n pli plt es ci ->
      snd (pBody p) = AppendEntries t n pli plt es ci ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries_reply (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t es res,
      handleAppendEntriesReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t es res = (d, m) ->
      gd = (fst (nwState net (pDst p))) ->
      snd (pBody p) = AppendEntriesReply t es res ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         In p' (send_packets (pDst p) (@add_ghost_msg _ _ ghost_log_params (pDst p) (gd, d) m))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t cid lli llt,
      handleRequestVote (pDst p) (snd (nwState net (pDst p))) t (pSrc p) lli llt  = (d, m) ->
      gd = update_elections_data_requestVote (pDst p) (pSrc p) t (pSrc p) lli llt (nwState net (pDst p)) ->
      snd (pBody p) = RequestVote t cid lli llt ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote_reply (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d t v,
      handleRequestVoteReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t v = d ->
      gd = update_elections_data_requestVoteReply (pDst p) (pSrc p) t v (nwState net (pDst p)) ->
      snd (pBody p) = RequestVoteReply t v ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_leader (P : network -> Prop) :=
    forall net st' ps' gd d h os d' ms,
      doLeader d h = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_generic_server (P : network -> Prop) :=
    forall net st' ps' gd d os d' ms h,
      doGenericServer h d = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_state_same_packet_subset (P : network -> Prop) :=
    forall net net',
      (forall h, nwState net h = nwState net' h) ->
      (forall p, In p (nwPackets net') -> In p (nwPackets net)) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      P net'.

  Definition msg_refined_raft_net_invariant_reboot (P : network -> Prop) :=
    forall net net' gd d h d',
      reboot d = d' ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwState net h = (gd, d) ->
      (forall h', nwState net' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
      nwPackets net = nwPackets net' ->
      P net'.

  Definition msg_refined_raft_net_invariant_init (P : network -> Prop) :=
    P step_async_init.

  Definition msg_refined_raft_net_invariant_client_request' (P : network -> Prop) :=
    forall h net st' ps' gd out d l client id c,
      handleClientRequest h (snd (nwState net h)) client id c = (out, d, l) ->
      gd = update_elections_data_client_request h (nwState net h) client id c ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                         In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_timeout' (P : network -> Prop) :=
    forall net h st' ps' gd out d l,
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      gd = update_elections_data_timeout h (nwState net h) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                               In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t n pli plt es ci,
      handleAppendEntries (pDst p) (snd (nwState net (pDst p))) t n pli plt es ci = (d, m) ->
      gd = update_elections_data_appendEntries (pDst p) (nwState net (pDst p)) t n pli plt es ci ->
      snd (pBody p) = AppendEntries t n pli plt es ci ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries_reply' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t es res,
      handleAppendEntriesReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t es res = (d, m) ->
      gd = (fst (nwState net (pDst p))) ->
      snd (pBody p) = AppendEntriesReply t es res ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         In p' (send_packets (pDst p) (@add_ghost_msg _ _ ghost_log_params (pDst p) (gd, d) m))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t cid lli llt,
      handleRequestVote (pDst p) (snd (nwState net (pDst p))) t (pSrc p) lli llt  = (d, m) ->
      gd = update_elections_data_requestVote (pDst p) (pSrc p) t (pSrc p) lli llt (nwState net (pDst p)) ->
      snd (pBody p) = RequestVote t cid lli llt ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote_reply' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d t v,
      handleRequestVoteReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t v = d ->
      gd = update_elections_data_requestVoteReply (pDst p) (pSrc p) t v (nwState net (pDst p)) ->
      snd (pBody p) = RequestVoteReply t v ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_leader' (P : network -> Prop) :=
    forall net st' ps' gd d h os d' ms,
      doLeader d h = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_generic_server' (P : network -> Prop) :=
    forall net st' ps' gd d os d' ms h,
      doGenericServer h d = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_state_same_packet_subset' (P : network -> Prop) :=
    forall net net',
      (forall h, nwState net h = nwState net' h) ->
      (forall p, In p (nwPackets net') -> In p (nwPackets net)) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      P net'.

  Definition msg_refined_raft_net_invariant_reboot' (P : network -> Prop) :=
    forall net net' gd d h d',
      reboot d = d' ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable net' ->
      nwState net h = (gd, d) ->
      (forall h', nwState net' h' = update name_eq_dec (nwState net) h (gd, d') h') ->
      nwPackets net = nwPackets net' ->
      P net'.

  Lemma msg_refined_raft_net_invariant_client_request'_weak :
    forall net,
      msg_refined_raft_net_invariant_client_request net ->
      msg_refined_raft_net_invariant_client_request' net.
  Proof using.
    unfold msg_refined_raft_net_invariant_client_request, msg_refined_raft_net_invariant_client_request'.
    intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_timeout'_weak :
    forall net,
      msg_refined_raft_net_invariant_timeout net ->
      msg_refined_raft_net_invariant_timeout' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_timeout, msg_refined_raft_net_invariant_timeout'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_append_entries'_weak :
    forall net,
      msg_refined_raft_net_invariant_append_entries net ->
      msg_refined_raft_net_invariant_append_entries' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_append_entries, msg_refined_raft_net_invariant_append_entries'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_append_entries_reply'_weak :
    forall net,
      msg_refined_raft_net_invariant_append_entries_reply net ->
      msg_refined_raft_net_invariant_append_entries_reply' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_append_entries_reply, msg_refined_raft_net_invariant_append_entries_reply'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_request_vote'_weak :
    forall net,
      msg_refined_raft_net_invariant_request_vote net ->
      msg_refined_raft_net_invariant_request_vote' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_request_vote, msg_refined_raft_net_invariant_request_vote'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_request_vote_reply'_weak :
    forall net,
      msg_refined_raft_net_invariant_request_vote_reply net ->
      msg_refined_raft_net_invariant_request_vote_reply' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_request_vote_reply, msg_refined_raft_net_invariant_request_vote_reply'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_do_leader'_weak :
    forall net,
      msg_refined_raft_net_invariant_do_leader net ->
      msg_refined_raft_net_invariant_do_leader' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_do_leader, msg_refined_raft_net_invariant_do_leader'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_do_generic_server'_weak :
    forall net,
      msg_refined_raft_net_invariant_do_generic_server net ->
      msg_refined_raft_net_invariant_do_generic_server' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_do_generic_server, msg_refined_raft_net_invariant_do_generic_server'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_reboot'_weak :
    forall net,
      msg_refined_raft_net_invariant_reboot net ->
      msg_refined_raft_net_invariant_reboot' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_reboot, msg_refined_raft_net_invariant_reboot'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_subset'_weak :
    forall net,
      msg_refined_raft_net_invariant_state_same_packet_subset net ->
      msg_refined_raft_net_invariant_state_same_packet_subset' net.
  Proof using.
    unfold msg_refined_raft_net_invariant_state_same_packet_subset, msg_refined_raft_net_invariant_state_same_packet_subset'.
    intuition eauto.
  Qed.

  Class raft_msg_refinement_interface : Prop :=
    {
      msg_refined_raft_net_invariant :
        forall P net,
          msg_refined_raft_net_invariant_init P ->
          msg_refined_raft_net_invariant_client_request P ->
          msg_refined_raft_net_invariant_timeout P ->
          msg_refined_raft_net_invariant_append_entries P ->
          msg_refined_raft_net_invariant_append_entries_reply P ->
          msg_refined_raft_net_invariant_request_vote P ->
          msg_refined_raft_net_invariant_request_vote_reply P ->
          msg_refined_raft_net_invariant_do_leader P ->
          msg_refined_raft_net_invariant_do_generic_server P ->
          msg_refined_raft_net_invariant_state_same_packet_subset P ->
          msg_refined_raft_net_invariant_reboot P ->
          msg_refined_raft_intermediate_reachable net ->
          P net;
      msg_refined_raft_net_invariant' :
        forall P net,
          msg_refined_raft_net_invariant_init P ->
          msg_refined_raft_net_invariant_client_request' P ->
          msg_refined_raft_net_invariant_timeout' P ->
          msg_refined_raft_net_invariant_append_entries' P ->
          msg_refined_raft_net_invariant_append_entries_reply' P ->
          msg_refined_raft_net_invariant_request_vote' P ->
          msg_refined_raft_net_invariant_request_vote_reply' P ->
          msg_refined_raft_net_invariant_do_leader' P ->
          msg_refined_raft_net_invariant_do_generic_server' P ->
          msg_refined_raft_net_invariant_state_same_packet_subset' P ->
          msg_refined_raft_net_invariant_reboot' P ->
          msg_refined_raft_intermediate_reachable net ->
          P net;
      msg_lift_prop :
        forall (P : _ -> Prop),
          (forall net, refined_raft_intermediate_reachable net -> P net) ->
          (forall net, msg_refined_raft_intermediate_reachable net -> P (mgv_deghost net));
      msg_lift_prop_all_the_way :
        forall (P : _ -> Prop),
          (forall net, raft_intermediate_reachable net -> P net) ->
          (forall (net : @network _ raft_msg_refined_multi_params), msg_refined_raft_intermediate_reachable net -> P (deghost (mgv_deghost net)));
      msg_lower_prop :
        forall P : _ -> Prop,
          (forall net, msg_refined_raft_intermediate_reachable net -> P (mgv_deghost net)) ->
          (forall net, refined_raft_intermediate_reachable net -> P net);
      msg_lower_prop_all_the_way :
        forall P : _ -> Prop,
          (forall (net : @network _ raft_msg_refined_multi_params), msg_refined_raft_intermediate_reachable net -> P (deghost (mgv_deghost net))) ->
          (forall net, raft_intermediate_reachable net -> P net);
      msg_deghost_spec :
        forall (net : @network _ raft_msg_refined_multi_params) h,
          nwState (mgv_deghost net) h = nwState net h;
      msg_simulation_1 :
        forall net,
          msg_refined_raft_intermediate_reachable net ->
          refined_raft_intermediate_reachable (mgv_deghost net)
    }.

End RaftMsgRefinementInterface.

#[global]
Hint Extern 3 (@BaseParams) => apply raft_msg_refined_base_params : typeclass_instances.
#[global]
Hint Extern 3 (@MultiParams _) => apply raft_msg_refined_multi_params : typeclass_instances.
#[global]
Hint Extern 3 (@FailureParams _ _) => apply raft_msg_refined_failure_params : typeclass_instances.