Require Import VST.floyd.base.
Require Import VST.floyd.val_lemmas.
Require Import VST.floyd.typecheck_lemmas.
Require Import compcert.cfrontend.Ctypes.

Definition const_only_isUnOpResultType {CS: compspecs} op (typeof_a:type) valueof_a ty : bool :=
match op with
  | Cop.Onotbool => match typeof_a with
                    | Tint _ _ _
                    | Tlong _ _
                    | Tfloat _ _ => is_int_type ty
                    | Tpointer _ _ =>
                        if Archi.ptr64
                        then match valueof_a with
                             | Vlong v =>
                                andb (negb (eqb_type (typeof_a) int_or_ptr_type))
                                     (andb (is_int_type ty) (Z.eqb 0 (Int64.unsigned v)))
                             | _ => false
                             end
                        else match valueof_a with
                             | Vint v =>
                                andb (negb (eqb_type typeof_a int_or_ptr_type))
                                     (andb (is_int_type ty) (Z.eqb 0 (Int.unsigned v)))
                             | _ => false
                             end
                    | _ => false
                    end
  | Cop.Onotint => match Cop.classify_notint (typeof_a) with
                   | Cop.notint_default => false
                   | Cop.notint_case_i _ => (is_int32_type ty)
                   | Cop.notint_case_l _ => (is_long_type ty)
                   end
  | Cop.Oneg => match Cop.classify_neg (typeof_a) with
                    | Cop.neg_case_i sg =>
                          andb (is_int32_type ty)
                          match (typeof_a) with
                          | Tint _ Signed _ =>
                            match valueof_a with
                            | Vint v => negb (Z.eqb (Int.signed v) Int.min_signed)
                            | _ => false
                            end
                          | Tlong Signed _ =>
                            match valueof_a with
                            | Vlong v => negb (Z.eqb (Int64.signed v) Int64.min_signed)
                            | _ => false
                            end
                          | _ => true
                          end
                    | Cop.neg_case_f => is_float_type ty
                    | Cop.neg_case_s => is_single_type ty
                    | _ => false
                    end
  | Cop.Oabsfloat =>match Cop.classify_neg (typeof_a) with
                    | Cop.neg_case_i sg => is_float_type ty
                    | Cop.neg_case_l _ => is_float_type ty
                    | Cop.neg_case_f => is_float_type ty
                    | Cop.neg_case_s => is_float_type ty
                    | _ => false
                    end
end.

(* TODO: binarithType would better be bool type *)
Definition const_only_isBinOpResultType {CS: compspecs} op typeof_a1 valueof_a1 typeof_a2 valueof_a2 ty : bool :=
  match op with
  | Cop.Oadd =>
      match Cop.classify_add (typeof_a1) (typeof_a2) with
      | Cop.add_case_pi t _ | Cop.add_case_pl t =>
        andb
          (andb
             (andb (match valueof_a1 with Vptr _ _ => true | _ => false end) (complete_type cenv_cs t))
             (negb (eqb_type (typeof_a1) int_or_ptr_type)))
          (is_pointer_type ty)
    | Cop.add_case_ip _ t | Cop.add_case_lp t =>
        andb
          (andb
             (andb (match valueof_a2 with Vptr _ _ => true | _ => false end) (complete_type cenv_cs t))
             (negb (eqb_type (typeof_a2) int_or_ptr_type)))
          (is_pointer_type ty)
    | Cop.add_default => false
      end
  | _ => false (* TODO *)
  end.

Definition const_only_isCastResultType {CS: compspecs} (t1 t2: type) (valueof_a: val)  : bool :=
  is_neutral_cast t1 t2 ||
  match t1, t2 with
  | Tint _ _ _, Tlong _ _ => true
  | _, _ => false
  end.

Fixpoint const_only_eval_expr {cs: compspecs} (e: Clight.expr): option val :=
  match e with
  | Econst_int i (Tint I32 _ _) => Some (Vint i)
  | Econst_int _ _ => None
  | Econst_long i ty => None
  | Econst_float f (Tfloat F64 _) => Some (Vfloat f)
  | Econst_float _ _ => None
  | Econst_single f (Tfloat F32 _) => Some (Vsingle f)
  | Econst_single _ _ => None
  | Etempvar id ty => None
  | Evar _ _ => None
  | Eaddrof a ty => None
  | Eunop op a ty =>
      match const_only_eval_expr a with
      | Some v => if const_only_isUnOpResultType op (typeof a) v ty
                  then Some (eval_unop op (typeof a) v)
                  else None
      | None => None
      end
  | Ebinop op a1 a2 ty =>
      match (const_only_eval_expr a1), (const_only_eval_expr a2) with
      | Some v1, Some v2 =>
          if const_only_isBinOpResultType op (typeof a1) v1 (typeof a2) v2 ty
          then Some (eval_binop op (typeof a1) (typeof a2) v1 v2)
          else None
      | _, _ => None
      end
  | Ecast a ty =>
      match const_only_eval_expr a with
      | Some v => if const_only_isCastResultType (typeof a) ty v
                  then Some (eval_cast (typeof a) ty v)
                  else None
      | None => None
      end
  | Ederef a ty => None
  | Efield a i ty => None
  | Esizeof t t0 =>
    if andb (complete_type cenv_cs t) (eqb_type t0 size_t)
    then Some (Vptrofs (Ptrofs.repr (sizeof t)))
    else None
  | Ealignof t t0 =>
    if andb (complete_type cenv_cs t) (eqb_type t0 size_t)
    then Some (Vptrofs (Ptrofs.repr (alignof t)))
    else None
  end.

Lemma const_only_isUnOpResultType_spec: forall {cs: compspecs} rho u e t P,
  const_only_isUnOpResultType u (typeof e) (eval_expr e rho) t = true ->
  P |-- denote_tc_assert (isUnOpResultType u e t) rho.
Proof.
  intros.
  unfold isUnOpResultType.
  unfold const_only_isUnOpResultType in H.
  destruct u.
  + destruct (typeof e);
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
    rewrite !denote_tc_assert_andp.
    match goal with
    | |- context [denote_tc_assert (tc_test_eq ?a ?b)] =>
      change (denote_tc_assert (tc_test_eq a b)) with (expr2.denote_tc_assert (tc_test_eq a b))
    end.
    rewrite binop_lemmas2.denote_tc_assert_test_eq'.
    simpl expr2.denote_tc_assert.
    unfold_lift. simpl.
    unfold tc_int_or_ptr_type.
    destruct Archi.ptr64 eqn:HH.
    - destruct (eval_expr e rho); try solve [inv H].
      rewrite !andb_true_iff in H.
      destruct H as [? [? ?]].
      rewrite H, H0.
      rewrite Z.eqb_eq in H1.
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      simpl.
      rewrite HH.
      change (P |-- (!! (i = Int64.zero)) && (!! (Int64.zero = Int64.zero)))%logic.
      apply andp_right; apply prop_right; auto.
      rewrite <- (Int64.repr_unsigned i), <- H1.
      auto.
    - destruct (eval_expr e rho); try solve [inv H].
      rewrite !andb_true_iff in H.
      destruct H as [? [? ?]].
      rewrite H, H0.
      rewrite Z.eqb_eq in H1.
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      simpl.
      rewrite HH.
      change (P |-- (!! (i = Int.zero)) && (!! (Int.zero = Int.zero)))%logic.
      apply andp_right; apply prop_right; auto.
      rewrite <- (Int.repr_unsigned i), <- H1.
      auto.
  + destruct (Cop.classify_notint (typeof e));
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
  + destruct (Cop.classify_neg (typeof e));
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
    rewrite !andb_true_iff in H.
    destruct H.
    rewrite H; simpl.
    destruct (typeof e) as [| ? [|] | [|] | | | | | |];
      try solve [exact (@prop_right mpred _ True _ I)].
    - simpl.
      unfold_lift.
      unfold denote_tc_nosignedover.
      destruct (eval_expr e rho); try solve [inv H0].
      rewrite negb_true_iff in H0.
      rewrite Z.eqb_neq in H0.
      apply prop_right.
      change (Int.signed Int.zero) with 0.
      rep_lia.
    - simpl.
      unfold_lift.
      unfold denote_tc_nosignedover.
      destruct (typeof e) as [ | _ [ | ] _ | | | | | | | ];
      destruct (eval_expr e rho); try solve [inv H0];
      rewrite negb_true_iff in H0;
      rewrite Z.eqb_neq in H0;
      apply prop_right;
      change (Int64.signed Int64.zero) with 0;
      rep_lia.
  + destruct (Cop.classify_neg (typeof e)); try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
Qed.

Lemma const_only_isBinOpResultType_spec: forall {cs: compspecs} rho b e1 e2 t P,
  const_only_isBinOpResultType b (typeof e1) (eval_expr e1 rho) (typeof e2) (eval_expr e2 rho) t = true ->
  P |-- denote_tc_assert (isBinOpResultType b e1 e2 t) rho.
Proof.
  intros.
  unfold isBinOpResultType.
  unfold const_only_isBinOpResultType in H.
  destruct b.
  + destruct (Cop.classify_add (typeof e1) (typeof e2)).
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e1 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e1 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e2 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e2 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
Qed.

Lemma const_only_isCastResultType_spec: forall {cs: compspecs} rho e t P,
  const_only_isCastResultType (typeof e) t (eval_expr e rho) = true ->
  P |-- denote_tc_assert (isCastResultType (typeof e) t e) rho.
Proof.
  intros.
  unfold const_only_isCastResultType in H.
  rewrite orb_true_iff in H.
  destruct H.
  apply neutral_isCastResultType; auto.
  destruct (typeof e); inv H.
  destruct t; inv H1.
  simpl. apply TT_right.
Qed.

Lemma const_only_eval_expr_eq: forall {cs: compspecs} rho e v,
  const_only_eval_expr e = Some v ->
  eval_expr e rho = v.
Proof.
  intros.
  revert v H; induction e; try solve [intros; inv H; auto].
  + intros.
    simpl in *.
    destruct t as [| [| | |] | | | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    destruct t as [| | | [|] | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    destruct t as [| | | [|] | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e); inv H.
    destruct (const_only_isUnOpResultType u (typeof e) v0 t); inv H1.
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite IHe; auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e1); inv H.
    destruct (const_only_eval_expr e2); inv H1.
    destruct (const_only_isBinOpResultType b (typeof e1) v0 (typeof e2) v1 t); inv H0.
    specialize (IHe1 _ eq_refl).
    specialize (IHe2 _ eq_refl).
    unfold_lift.
    rewrite IHe1, IHe2; auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e); inv H.
    destruct (const_only_isCastResultType (typeof e) t v0) eqn:?H; inv H1.
    unfold_lift. erewrite IHe by reflexivity. auto.
  + intros.
    simpl in *.
    destruct (complete_type cenv_cs t); inv H.
    destruct (eqb_type t0 size_t); inv H1.
    auto.
  + intros.
    simpl in *.
    destruct (complete_type cenv_cs t); inv H.
    destruct (eqb_type t0 size_t); inv H1.
    auto.
Qed.

Lemma const_only_eval_expr_tc: forall {cs: compspecs} Delta e v P,
  const_only_eval_expr e = Some v ->
  P |-- tc_expr Delta e.
Proof.
  intros.
  intro rho.
  revert v H; induction e; try solve [intros; inv H].
  + intros.
    inv H.
    destruct t as [| [| | |] | | | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    destruct t as [| | | [|] | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    destruct t as [| | | [|] | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e) eqn:HH; inv H.
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite denote_tc_assert_andp; simpl; apply andp_right; auto.
    apply const_only_isUnOpResultType_spec.
    apply (const_only_eval_expr_eq rho) in HH.
    rewrite HH.
    destruct (const_only_isUnOpResultType u (typeof e) v0 t); inv H1; auto.
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e1) eqn:HH1; inv H.
    destruct (const_only_eval_expr e2) eqn:HH2; inv H1.
    specialize (IHe1 _ eq_refl).
    specialize (IHe2 _ eq_refl).
    unfold_lift.
    rewrite !denote_tc_assert_andp; simpl; repeat apply andp_right; auto.
    apply const_only_isBinOpResultType_spec.
    apply (const_only_eval_expr_eq rho) in HH1.
    apply (const_only_eval_expr_eq rho) in HH2.
    rewrite HH1, HH2.
    destruct (const_only_isBinOpResultType b (typeof e1) v0 (typeof e2) v1 t); inv H0; auto.
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e) eqn:HH; inv H.
    destruct (const_only_isCastResultType (typeof e) t v0) eqn:?H; inv H1.
    rewrite denote_tc_assert_andp.
    simpl.
    apply andp_right; eauto.
    apply const_only_isCastResultType_spec; auto.
  + intros.
    inv H.
    unfold tc_expr.
    simpl typecheck_expr.
    simpl.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t) eqn:HH; inv H1.
    rewrite andb_true_iff in HH.
    unfold tuint in HH; destruct HH.
    rewrite H, H0.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    unfold tc_expr.
    simpl typecheck_expr.
    simpl.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t) eqn:HH; inv H1.
    rewrite andb_true_iff in HH.
    unfold tuint in HH; destruct HH.
    rewrite H, H0.
    exact (@prop_right mpred _ True _ I).
Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Trivial.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Section Lindenbaum_Trivial.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {GammaPD: ProvableDerivable L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {fwSC: FiniteWitnessedSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {andpSC: AndSequentCalculus L GammaD}
        {orpSC: OrSequentCalculus L GammaD}
        {falsepSC: FalseSequentCalculus L GammaD}
        {inegpSC: IntuitionisticNegSequentCalculus L GammaD}
        {iffpSC: IffSequentCalculus L GammaD}
        {truepSC: TrueSequentCalculus L GammaD}
        {cpSC: ClassicalSequentCalculus L GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {andpAX: AndAxiomatization L GammaP}
        {orpAX: OrAxiomatization L GammaP}
        {falsepAX: FalseAxiomatization L GammaP}
        {inegpAX: IntuitionisticNegAxiomatization L GammaP}
        {iffpAX: IffAxiomatization L GammaP}
        {truepAX: TrueAxiomatization L GammaP}.

Lemma Lindenbaum_for_max_consistent: forall P,
  Lindenbaum_ensures P derivable_closed ->
  Lindenbaum_ensures P orp_witnessed ->
  Lindenbaum_ensures P consistent ->
  Lindenbaum_ensures P (maximal consistent).
Proof.
  intros.
  hnf; intros.
  apply DDCS_MCS; auto.
Qed.

Lemma Lindenbaum_cannot_derive_ensures_max_consistent
      {GammaDP: DerivableProvable L GammaP GammaD}:
  forall x, Lindenbaum_ensures (cannot_derive x) (maximal consistent).
Proof.
  intros.
  apply Lindenbaum_for_max_consistent.
  - apply Lindenbaum_cannot_derive_ensures_derivable_closed.
  - apply Lindenbaum_cannot_derive_ensures_orp_witnessed.
  - apply Lindenbaum_cannot_derive_ensures_consistent.
Qed.

End Lindenbaum_Trivial.


Require Import Coq.Init.Wf Coq.Numbers.BinNums.
Require Import Coq.Arith.Arith.
Require Import Coq.FSets.FMapPositive.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.BaseTypes.
Require Export Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Fix.
Require Import Fiat.Common.FMapExtensions.Wf.
Require Import Fiat.Common.
Require Import Fiat.Common.OptionFacts.
Require Import Fiat.Common.SetoidInstances.

Set Implicit Arguments.
Local Open Scope grammar_fixedpoint_scope.

Section grammar_fixedpoint.
  Context {Char : Type}.
  Context {gdata0 gdata1 : grammar_fixedpoint_data}
          (R : grammar_fixedpoint_lattice_data_relation gdata0 gdata1).

  Definition aggregate_state_relation
    : aggregate_state gdata0 -> aggregate_state gdata1 -> Prop
    := PositiveMapExtensions.lift_relation_hetero
         (state_relation R) ⊤ ⊤.

  Lemma related_aggregate_state_max
        initial_nonterminals_data
        (HRbot : R ⊥ ⊥)
    : aggregate_state_relation
        (aggregate_state_max gdata0 initial_nonterminals_data)
        (aggregate_state_max gdata1 initial_nonterminals_data).
  Proof.
    unfold aggregate_state_relation.
    rewrite PositiveMapExtensions.lift_relation_hetero_iff; intro k.
    rewrite !find_aggregate_state_max_exact.
    break_match; trivial.
  Qed.

  Section with_grammar.
    Context (G : pregrammar' Char).

    Let predata := @rdp_list_predata _ G.
    Local Existing Instance predata.

    Global Instance lift_relation_hetero_Proper_aggregate_state_beq_flip_impl
      : Proper (PositiveMapExtensions.lift_eqb state_beq ⊤ ==> PositiveMapExtensions.lift_eqb state_beq ⊤ ==> flip impl)
               (PositiveMapExtensions.lift_relation_hetero R ⊤ ⊤) | 2.
    Proof.
      apply PositiveMapExtensions.lift_relation_hetero_Proper_Proper_lift_brelation_subrelation_flip_impl; try exact _.
      apply top_state_related.
    Qed.

    Global Instance lift_relation_hetero_Proper_aggregate_state_eq_flip_impl
      : Proper (aggregate_state_eq (gdata:=_) ==> aggregate_state_eq (gdata:=_) ==> flip impl)
               (PositiveMapExtensions.lift_relation_hetero R ⊤ ⊤) | 2
      := _.

    Lemma related_pre_Fix_grammar_gen
          (HRtop : R ⊤ ⊤)
          (HRbot : R ⊥ ⊥)
          (HRtopR : forall x y, R x ⊤ -> R (x ⊔ y) ⊤)
          (HRtopL : forall x y, R ⊤ x -> R ⊤ (x ⊔ y))
          (HRstep : forall st st' k,
              aggregate_state_relation st st'
              -> R (lookup_state st k ⊔ step_constraints gdata0 (lookup_state st) k (lookup_state st k))
                   (lookup_state st' k ⊔ step_constraints gdata1 (lookup_state st') k (lookup_state st' k)))
          (R_Proper : Proper (state_beq ==> state_beq ==> iff) R)
      : aggregate_state_relation
          (pre_Fix_grammar gdata0 initial_nonterminals_data)
          (pre_Fix_grammar gdata1 initial_nonterminals_data).
    Proof.
      pose proof (related_aggregate_state_max initial_nonterminals_data HRbot) as H.
      unfold aggregate_state_relation in *.
      rewrite PositiveMapExtensions.lift_relation_hetero_iff in *.
      rewrite <- ?PositiveMapExtensions.lift_relation_hetero_iff in H. (* undo power of econstr *)
      (*pose proof (@find_pre_Fix_grammar _ gdata0 G) as H0.
      pose proof (@find_pre_Fix_grammar _ gdata1 G) as H1.
      pose proof (fun nt => transitivity (symmetry (H0 nt)) (H1 nt)) as H01; clear H0 H1.
      setoid_rewrite find_pre_Fix_grammar_to_lookup_state' in H01.
      progress repeat setoid_rewrite nonterminal_to_positive_to_nonterminal in H01.*)
      intro k.
      rewrite !find_pre_Fix_grammar_to_lookup_state' in *.
      fold predata.
      destruct (@is_valid_nonterminal _ predata (@initial_nonterminals_data _ predata) (positive_to_nonterminal k)) eqn:Hv; [ | exact I ].
      unfold pre_Fix_grammar, pre_Fix_grammar_helper in *.
      fold predata.
      (*fold predata in H01 |- *.*)
      assert (Hfind : forall k, PositiveMap.find k (aggregate_state_max gdata0 initial_nonterminals_data) = None
                                <-> PositiveMap.find k (aggregate_state_max gdata1 initial_nonterminals_data) = None).
      { intro; rewrite !find_aggregate_state_max_exact.
        break_match; split; congruence. }
      generalize dependent (aggregate_state_max gdata0 initial_nonterminals_data).
      generalize dependent (aggregate_state_max gdata1 initial_nonterminals_data).
      intro a; induction (aggregate_state_lt_wf a) as [st' Hacc IH].
      intro st.
      intros H' Hfind; revert H'.
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      set (FIX := Fix) at 1.
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      subst FIX.
      assert (Hfind_all
              : forall k, (PositiveMap.find k st = None <-> PositiveMap.find k (aggregate_step st') = None)
                          /\ (PositiveMap.find k (aggregate_step st) = None <-> PositiveMap.find k st' = None)
                          /\ (PositiveMap.find k (aggregate_step st) = None <-> PositiveMap.find k (aggregate_step st') = None)
                          /\ (PositiveMap.find k (aggregate_step (aggregate_step st)) = None <-> PositiveMap.find k st' = None)
                          /\ (PositiveMap.find k (aggregate_step (aggregate_step st)) = None <-> PositiveMap.find k (aggregate_step st') = None)).
      { let k := fresh in
        intro k; specialize (Hfind k).
        rewrite !find_aggregate_step; unfold option_map; break_match; intuition congruence. }
      assert (forall k, PositiveMap.find k st = None <-> PositiveMap.find k (aggregate_step st') = None) by apply Hfind_all.
      assert (forall k, PositiveMap.find k (aggregate_step st) = None <-> PositiveMap.find k st' = None) by apply Hfind_all.
      assert (forall k, PositiveMap.find k (aggregate_step st) = None <-> PositiveMap.find k (aggregate_step st') = None) by apply Hfind_all.
      assert (forall k, PositiveMap.find k (aggregate_step (aggregate_step st)) = None <-> PositiveMap.find k st' = None) by apply Hfind_all.
      assert (forall k, PositiveMap.find k (aggregate_step (aggregate_step st)) = None <-> PositiveMap.find k (aggregate_step st') = None) by apply Hfind_all.
      do 2 edestruct dec.
      { rewrite PositiveMapExtensions.lift_relation_hetero_iff.
        unfold lookup_state, PositiveMapExtensions.find_default.
        intro Hfind'.
        let k := match goal with |- context[PositiveMap.find ?k _] => k end in
        specialize (Hfind' k).
        do 2 edestruct PositiveMap.find; simpl; assumption. }
      { specialize (fun y Hy => IH y Hy st).
        rewrite Init.Wf.Fix_eq in IH by (intros; edestruct dec; trivial).
        edestruct dec; [ | congruence ].
        intro Hfind'; apply IH; clear IH; auto using step_lt; [].

        unfold aggregate_state_eq in *.
        unfold PositiveMapExtensions.lift_eqb in *.
        match goal with
        | [ H : PositiveMapExtensions.lift_brelation state_beq ⊤ ?x ?y = true |- PositiveMapExtensions.lift_relation_hetero _ _ _ ?x _ ]
          => change (is_true (PositiveMapExtensions.lift_brelation state_beq ⊤ x y)) in H;
               rewrite H
        end.

        rewrite PositiveMapExtensions.lift_relation_hetero_iff.
        unfold lookup_state, PositiveMapExtensions.find_default.
        intro k'; specialize (Hfind k'); rewrite !find_aggregate_step.

        unfold option_map; break_innermost_match; auto;
          try solve [ intuition congruence ]; [].
        repeat match goal with
               | [ |- context[?s ⊔ step_constraints ?data ?lookup ?k ?s] ]
                 => is_var s;
                      replace s with (lookup k)
                      by (unfold lookup_state, PositiveMapExtensions.find_default, option_rect;
                          rewrite positive_to_nonterminal_to_positive; rewrite_hyp; reflexivity)
               end.
        auto. }
      { clear IH Hfind_all Hacc.
        intro Hrel.
        assert (Hrel' : PositiveMapExtensions.lift_relation_hetero R ⊤ ⊤ (aggregate_step st) st').
        { unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb in *.
          match goal with
          | [ H : PositiveMapExtensions.lift_brelation state_beq ⊤ ?x ?y = true |- PositiveMapExtensions.lift_relation_hetero _ _ _ _ ?x ]
            => change (is_true (PositiveMapExtensions.lift_brelation state_beq ⊤ x y)) in H;
                 rewrite H
          end.
          pose proof Hrel as Hrel'.
          rewrite PositiveMapExtensions.lift_relation_hetero_iff in Hrel' |- *.
          unfold lookup_state, PositiveMapExtensions.find_default.
          intro k'; pose proof (Hrel' k'); rewrite !find_aggregate_step.

          unfold option_map; break_innermost_match; auto;
            try solve [ intuition congruence ]; [].
          repeat match goal with
                 | [ |- context[?s ⊔ step_constraints ?data ?lookup ?k ?s] ]
                   => is_var s;
                        replace s with (lookup k)
                        by (unfold lookup_state, PositiveMapExtensions.find_default, option_rect;
                            rewrite positive_to_nonterminal_to_positive; rewrite_hyp; reflexivity)
                 end.
          auto. }

        revert dependent st'.
        generalize dependent (aggregate_step st); intros a _.
        intros; clear dependent st; revert dependent st'.
        induction (aggregate_state_lt_wf a) as [st Hacc IH].
        intro st'.
        intros.
        rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).

        edestruct dec.
        { unfold lookup_state, PositiveMapExtensions.find_default.
          rewrite positive_to_nonterminal_to_positive.
          lazymatch goal with
          | [ H : PositiveMapExtensions.lift_relation_hetero _ _ _ _ _ |- _ ]
            => revert H
          end.
          rewrite PositiveMapExtensions.lift_relation_hetero_iff.
          intro Hrel.
          repeat match goal with
                 | [ H : forall k : PositiveMap.key, _ |- context[PositiveMap.find ?k' _] ]
                   => specialize (H k')
                 end.
          unfold state in *.
          unfold option_map, option_rect; break_match; auto;
            intuition congruence. }
        { specialize (fun y Hy => IH y Hy st').
          specialize (IH (aggregate_step st)).
          apply IH; clear IH; auto using step_lt;
            [ let k := fresh in
              intro k;
              repeat match goal with
                     | [ H : forall k' : PositiveMap.key, _ |- _ ] => specialize (H k)
                     end;
              rewrite !find_aggregate_step; unfold option_map; break_innermost_match;
              intuition congruence..
            | ].
          { unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb, state in *.
            lazymatch goal with
            | [ H : PositiveMapExtensions.lift_brelation state_beq ⊤ ?x ?y = true |- PositiveMapExtensions.lift_relation_hetero _ _ _ _ ?x ]
              => change (is_true (PositiveMapExtensions.lift_brelation state_beq ⊤ x y)) in H;
                   rewrite H
            end.
            lazymatch goal with
            | [ H : PositiveMapExtensions.lift_relation_hetero _ _ _ _ _ |- _ ]
              => generalize H
            end.
            rewrite !PositiveMapExtensions.lift_relation_hetero_iff.
            let k := fresh in intros Hrel k; specialize (Hrel k); revert Hrel.
            rewrite !find_aggregate_step; unfold option_map, state;
              break_innermost_match; auto.
            repeat match goal with
                   | [ |- context[?s ⊔ step_constraints ?data ?lookup ?k ?s] ]
                     => is_var s;
                          replace s with (lookup k)
                          by (unfold lookup_state, PositiveMapExtensions.find_default, option_rect;
                              rewrite positive_to_nonterminal_to_positive; rewrite_hyp; reflexivity)
                   end.
            auto. } } }
      { intro Hfind'; apply IH; clear IH; auto using step_lt; [].
        pose proof Hfind' as Hfind''.
        rewrite PositiveMapExtensions.lift_relation_hetero_iff in Hfind' |- *.
        intro k'; specialize (Hfind' k').
        rewrite !find_aggregate_step.
        unfold option_map; break_innermost_match; auto.
        repeat match goal with
               | [ |- context[?s ⊔ step_constraints ?data ?lookup ?k ?s] ]
                 => is_var s;
                      replace s with (lookup k)
                      by (unfold lookup_state, PositiveMapExtensions.find_default, option_rect;
                          rewrite positive_to_nonterminal_to_positive; rewrite_hyp; reflexivity)
               end.
        auto. }
    Qed.

    Lemma related_pre_Fix_grammar
          (HRtop : R ⊤ ⊤)
          (HRbot : R ⊥ ⊥)
          (HRtopR : forall x y, R x ⊤ -> R (x ⊔ y) ⊤)
          (HRtopL : forall x y, R ⊤ x -> R ⊤ (x ⊔ y))
          (HRlub : forall x y, R x y -> forall x' y', R x' y' -> R (x ⊔ x') (y ⊔ y'))
          (step_constraints_Proper
           : forall f g,
              (forall k, R (f k) (g k))
              -> forall k st st',
                R st st'
                -> R (step_constraints gdata0 f k st) (step_constraints gdata1 g k st'))
          (R_Proper : Proper (state_beq ==> state_beq ==> iff) R)
      : aggregate_state_relation
          (pre_Fix_grammar gdata0 initial_nonterminals_data)
          (pre_Fix_grammar gdata1 initial_nonterminals_data).
    Proof.
      apply related_pre_Fix_grammar_gen; try assumption.
      { intros ?? k H.
        unfold aggregate_state_relation, lookup_state, PositiveMapExtensions.find_default in *.
        rewrite PositiveMapExtensions.lift_relation_hetero_iff in H.
        unfold option_rect, state in *; simpl in *.
        apply HRlub; [ | apply step_constraints_Proper ];
          repeat match goal with
                 | _ => intro
                 | [ H : forall k : PositiveMap.key, _ |- context[PositiveMap.find ?k _] ]
                   => specialize (H k)
                 | _ => assumption
                 | _ => progress break_innermost_match
                 end. }
    Qed.
(*

  Local Notation default_value := ⊤ (only parsing).

  Definition lookup_state (st : aggregate_state) (nt : default_nonterminal_carrierT)
    : state gdata
    := PositiveMapExtensions.find_default default_value (nonterminal_to_positive nt) st.

  Notation from_aggregate_state := lookup_state (only parsing).

  Definition aggregate_state_le : aggregate_state -> aggregate_state -> bool
    := PositiveMapExtensions.lift_leb state_le default_value.
  Definition aggregate_state_eq : aggregate_state -> aggregate_state -> bool
    := PositiveMapExtensions.lift_eqb state_beq default_value.
  Definition aggregate_state_lt (v1 v2 : aggregate_state) : bool
    := PositiveMapExtensions.lift_ltb state_beq state_le default_value v1 v2.

  Lemma PositiveMap_elements_iff {A m k v}
    : @PositiveMap.find A k m = Some v <-> In (k, v) (PositiveMap.elements m).
  Proof.
    rewrite PositiveMapExtensions.elements_iff_find.
    rewrite InA_alt; unfold PositiveMap.eq_key_elt, PositiveMap.E.eq; simpl.
    split; [ intros [[? ?] [[? ?] ?]] | intro H; exists (k, v) ];
      subst; repeat split; assumption.
  Qed.

  Lemma PositiveMap_elements_iff' {A m kv}
    : @PositiveMap.find A (fst kv) m = Some (snd kv) <-> In kv (PositiveMap.elements m).
  Proof.
    destruct kv; apply PositiveMap_elements_iff.
  Qed.

  Create HintDb aggregate_step_db discriminated.
  Hint Rewrite PositiveMap.fold_1 PositiveMap.gmapi nonterminal_to_positive_to_nonterminal positive_to_nonterminal_to_positive PositiveMap.gempty PositiveMapAdditionalFacts.gsspec (@state_beq_refl _ gdata) orb_true_iff orb_true_r orb_false_iff (@state_le_bottom_eq_bottom _ gdata) (@no_state_lt_bottom _ gdata) (@state_le_bottom_eq_bottom _ gdata) (@state_ge_top_eq_top _ gdata) (@bottom_lub_r _ gdata) (@bottom_lub_l _ gdata) (@top_lub_r _ gdata) (@top_lub_l _ gdata) (fun a b => @least_upper_bound_correct_l _ gdata a b : _ = true) (fun a b => @least_upper_bound_correct_r _ gdata a b : _ = true) (fun s => @bottom_bottom _ gdata s : _ = true) (fun s => @top_top _ gdata s : _ = true) beq_nat_true_iff @PositiveMapExtensions.lift_brelation_iff : aggregate_step_db.
  Hint Rewrite <- beq_nat_refl : aggregate_step_db.
  Hint Rewrite PositiveMapExtensions.map2_1bis_for_rewrite using reflexivity : aggregate_step_db.
  Hint Rewrite PositiveMapExtensions.fold_andb_true : aggregate_step_db.

  Local Ltac fold_andb_t_step :=
    idtac;
    match goal with
    | _ => progress intros
    | _ => progress subst
    | _ => congruence
    | _ => progress unfold PositiveMap.key in *
    | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
    | [ H : Some ?b <> Some false |- _ ] => destruct b eqn:?; [ clear H | congruence ]
    | [ H : (⊥ =b ?s) = false, H' : (⊥ < ?s) = false |- _ ]
      => let H'' := fresh in
         pose proof (bottom_bottom s) as H''; setoid_rewrite orb_true_iff in H''; destruct H''; congruence
    | [ H : context[PositiveMap.fold _ _ _ = true] |- _ ]
      => setoid_rewrite PositiveMapExtensions.fold_andb_true in H
    | [ |- context[PositiveMap.fold _ _ _ = true] ]
      => setoid_rewrite PositiveMapExtensions.fold_andb_true
    | [ |- true = false ] => symmetry
    | [ H : PositiveMap.fold _ _ _ = false |- false = true ]
      => rewrite <- H; clear H
    | [ H : context[PositiveMap.find _ (PositiveMap.map2 ?f _ _)] |- _ ]
      => setoid_rewrite (@PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ f eq_refl) in H
    | [ |- context[PositiveMap.find _ (PositiveMap.map2 ?f _ _)] ]
      => setoid_rewrite (@PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ f eq_refl)
    | [ H : context[PositiveMapExtensions.lift_brelation] |- _ ]
      => setoid_rewrite PositiveMapExtensions.lift_brelation_iff in H
    | [ |- context[PositiveMapExtensions.lift_brelation] ]
      => setoid_rewrite PositiveMapExtensions.lift_brelation_iff
    | [ H : ?x = _, H' : context[?x] |- _ ] => setoid_rewrite H in H'
    | [ H : ?x = _ |- context[?x] ] => setoid_rewrite H
    | [ H : and _ _ |- _ ] => destruct H
    | [ H : pointwise_relation _ eq ?x ?y, H' : context[step_constraints _ ?x] |- _ ]
      => rewrite H in H'
    | _ => progress autorewrite with aggregate_step_db in *
    | [ H : forall k : positive, _ |- _ ]
      => repeat match goal with
                | [ k' : positive |- _ ]
                  => unique pose proof (H k')
                | [ |- context[PositiveMap.find ?k' _] ]
                  => unique pose proof (H k')
                | [ _ : context[PositiveMap.find ?k' _] |- _ ]
                  => unique pose proof (H k')
                end;
         clear H
    | _ => progress simpl in *
    | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
    | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
    | [ |- _ <> _ ] => intro
    | [ H : or _ _ |- _ ] => destruct H
    | [ |- and _ _ ] => split
    | [ H : (?x < ?y) = true, H' : (?y < ?z) = true |- _ ]
      => unique pose proof (state_lt_Transitive H H' : (x < z) = true)
    | [ H : is_true (?x =b ?y) |- _ ]
      => rewrite H in *; clear x H
    | [ H : is_true (?x =b ?y) |- _ ]
      => rewrite <- H in *; clear x H
    | [ H : ?R ?x ?y |- _ ]
      => is_var x; rewrite H in *; clear x H
    | [ H : ?R ?x ?y |- _ ]
      => is_var y; rewrite <- H in *; clear y H
    end.
  Local Ltac fold_andb_t := repeat fold_andb_t_step.

  Global Instance aggregate_state_eq_Reflexive : Reflexive aggregate_state_eq | 1 := _.
  Global Instance aggregate_state_eq_Symmetric : Symmetric aggregate_state_eq | 1 := _.
  Global Instance aggregate_state_eq_Transitive : Transitive aggregate_state_eq | 1 := _.
  Global Instance aggregate_state_le_Reflexive : Reflexive aggregate_state_le | 1 := _.
  Global Instance aggregate_state_le_Transitive : Transitive aggregate_state_le | 1 := _.
  Global Instance aggregate_state_eq_Proper_Equal
    : Proper (@PositiveMap.Equal _ ==> @PositiveMap.Equal _ ==> eq) aggregate_state_eq | 100
    := _.
  Global Instance aggregate_state_le_Proper_Equal
    : Proper (@PositiveMap.Equal _ ==> @PositiveMap.Equal _ ==> eq) aggregate_state_le | 100
    := _.
  Global Instance aggregate_state_lt_Proper_Equal
    : Proper (@PositiveMap.Equal _ ==> @PositiveMap.Equal _ ==> eq) aggregate_state_lt | 100
    := _.
  Global Instance aggregate_state_le_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq ==> eq) aggregate_state_le | 1
    := _.
  Global Instance aggregate_state_lt_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq ==> eq) aggregate_state_lt | 1
    := _.

  Definition aggregate_state_lub_f : option (state gdata) -> option (state gdata) -> option (state gdata)
      := PositiveMapExtensions.defaulted_f default_value default_value least_upper_bound.

  Definition aggregate_state_lub (v1 v2 : aggregate_state) : aggregate_state
    := PositiveMap.map2 aggregate_state_lub_f v1 v2.

  Definition aggregate_prestep (v : aggregate_state) : aggregate_state
    := let helper := step_constraints gdata (from_aggregate_state v) in
       PositiveMap.mapi (fun nt => helper (positive_to_nonterminal nt)) v.

  Definition aggregate_step (v : aggregate_state) : aggregate_state
    := aggregate_state_lub v (aggregate_prestep v).

  Definition aggregate_state_lub_correct (v1 v2 : aggregate_state)
    : aggregate_state_le v1 (aggregate_state_lub v1 v2)
      /\ aggregate_state_le v2 (aggregate_state_lub v1 v2).
  Proof.
    unfold aggregate_state_le, aggregate_state_lub, aggregate_state_lub_f.
    setoid_rewrite PositiveMapExtensions.lift_brelation_iff.
    unfold PositiveMapExtensions.defaulted_f.
    repeat match goal with
           | [ |- and _ _ ] => split
           | _ => intro
           | _ => progress subst
           | [ H : ?x = _ |- context[?x] ] => setoid_rewrite H
           | [ H : ?x = _, H' : context[?x] |- _ ] => setoid_rewrite H in H'
           | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
           | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
           | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
           | [ |- is_true (?R ?x ?x) ] => reflexivity
           | _ => apply top_top
           | _ => apply least_upper_bound_correct_l
           | _ => apply least_upper_bound_correct_r
           | _ => congruence
           | [ H : _ |- _ ] => setoid_rewrite PositiveMapExtensions.map2_1bis_for_rewrite in H; [ | reflexivity.. ]
           end.
  Qed.

  Lemma find_aggregate_state_lub a b k
    : PositiveMap.find k (aggregate_state_lub a b)
      = aggregate_state_lub_f (PositiveMap.find k a) (PositiveMap.find k b).
  Proof.
    unfold aggregate_state_lub.
    fold_andb_t.
  Qed.

  Lemma nothing_empty_lt v : ~aggregate_state_lt (PositiveMap.empty _) v.
  Proof.
    setoid_rewrite PositiveMapExtensions.empty_ltb_nothing; [ congruence | ].
    setoid_rewrite state_ge_top_eq_top.
    intros; symmetry; assumption.
  Qed.

  Lemma aggregate_state_lt_wf : well_founded (Basics.flip aggregate_state_lt).
  Proof.
    apply PositiveMapExtensions.well_founded_lift_gtb.
    { eapply Wf.well_founded_subrelation; [ | eexact (@state_gt_wf _ gdata) ].
      unfold flip, state_le; intros x y H.
      destruct (y < x); [ reflexivity | simpl in * ].
      destruct (y =b x) eqn:Heqb; simpl in *; assumption. }
    { apply top_top. }
    { exact _. }
    { exact _. }
    { exact _. }
    { exact _. }
  Defined.

  Section wrap_wf.
    Context {A R} (Rwf : @well_founded A R).

    Definition lt_wf_idx_step
               (lt_wf_idx : nat -> well_founded R)
               (n : nat)
      : well_founded R.
    Proof.
      destruct n.
      { clear -Rwf; abstract apply Rwf. }
      { constructor; intros; apply lt_wf_idx; assumption. }
    Defined.

    Fixpoint lt_wf_idx (n : nat) : well_founded R
      := lt_wf_idx_step (@lt_wf_idx) n.
  End wrap_wf.

  Definition aggregate_state_lt_wf_idx (n : nat) : well_founded (Basics.flip aggregate_state_lt)
    := lt_wf_idx aggregate_state_lt_wf n.

  Definition step_lt {st}
    : aggregate_state_eq st (aggregate_step st) = false -> Basics.flip aggregate_state_lt (aggregate_step st) st.
  Proof.
    unfold Basics.flip.
    intros pf.
    destruct (aggregate_state_lt st (aggregate_step st)) eqn:H; [ reflexivity | exfalso ].
    unfold aggregate_step in *.
    pose proof (proj1 (aggregate_state_lub_correct st (aggregate_prestep st))) as H'.
    unfold aggregate_state_lt, PositiveMapExtensions.lift_ltb in *.
    fold aggregate_state_le in *.
    fold aggregate_state_eq in *.
    generalize dependent (aggregate_state_le st (aggregate_state_lub st (aggregate_prestep st))).
    generalize dependent (aggregate_state_eq st (aggregate_state_lub st (aggregate_prestep st))).
    clear.
    abstract (
        intros [] ? []; simpl; intros; congruence
      ).
  Defined.

  Global Instance aggregate_state_lub_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq ==> aggregate_state_eq) aggregate_state_lub | 1.
  Proof.
    unfold aggregate_state_eq, aggregate_state_lub, aggregate_state_lub_f.
    refine PositiveMapExtensions.map2_defaulted_Proper_lift_brelation.
  Qed.

  Global Instance from_aggregate_state_Proper
    : Proper (aggregate_state_eq ==> eq ==> state_beq) from_aggregate_state | 1.
  Proof.
    unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb, from_aggregate_state, PositiveMapExtensions.find_default, option_rect; repeat intro; fold_andb_t.
  Qed.

  Global Instance aggregate_step_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq) aggregate_step | 1.
  Proof.
    intros x y H.
    assert (H' : pointwise_relation _ state_beq (from_aggregate_state x) (from_aggregate_state y)) by (intro; setoid_rewrite H; reflexivity).
    unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb, aggregate_step, aggregate_state_lub, aggregate_prestep in *.
    setoid_rewrite PositiveMapExtensions.lift_brelation_iff in H.
    setoid_rewrite PositiveMapExtensions.lift_brelation_iff.
    repeat setoid_rewrite fold_option_rect_nodep.
    first [ setoid_rewrite (PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ _ eq_refl)
          | setoid_rewrite (PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ _ _); [ | reflexivity.. ] ].
    setoid_rewrite PositiveMap.gmapi.
    unfold option_rect_nodep, option_map.
    intro k; specialize (H k).
    generalize dependent (lookup_state x); generalize dependent (lookup_state y); intros;
      do 2 edestruct PositiveMap.find;
      fold_andb_t.
  Qed.

  Lemma lookup_state_aggregate_state_lub a b nt
    : lookup_state (aggregate_state_lub a b) nt = (lookup_state a nt ⊔ lookup_state b nt).
  Proof.
    unfold lookup_state, PositiveMapExtensions.find_default.
    rewrite find_aggregate_state_lub.
    unfold option_rect, aggregate_state_lub_f.
    fold_andb_t.
  Qed.

  Global Instance lookup_state_Proper
    : Proper (aggregate_state_eq ==> eq ==> state_beq) lookup_state | 1.
  Proof.
    unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb, lookup_state, PositiveMapExtensions.find_default, option_rect; repeat intro; fold_andb_t.
  Qed.

  Lemma find_aggregate_prestep st nt
    : PositiveMap.find nt (aggregate_prestep st)
      = option_map (step_constraints gdata (lookup_state st) (positive_to_nonterminal nt))
                   (PositiveMap.find nt st).
  Proof.
    unfold aggregate_prestep.
    autorewrite with aggregate_step_db.
    unfold from_aggregate_state, option_rect, option_map.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Lemma find_aggregate_step st nt
    : PositiveMap.find nt (aggregate_step st)
      = option_map (fun v => v ⊔ step_constraints gdata (lookup_state st) (positive_to_nonterminal nt) v)
                   (PositiveMap.find nt st).
  Proof.
    unfold aggregate_step.
    rewrite find_aggregate_state_lub, find_aggregate_prestep.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Lemma lookup_state_aggregate_prestep st nt
    : lookup_state (aggregate_prestep st) nt
      = option_rect (fun _ => _)
                    (fun _ => step_constraints gdata (lookup_state st) nt (lookup_state st nt))
                    default_value
                    (PositiveMap.find (nonterminal_to_positive nt) st).
  Proof.
    unfold lookup_state.
    unfold PositiveMapExtensions.find_default.
    rewrite find_aggregate_prestep.
    unfold lookup_state.
    rewrite nonterminal_to_positive_to_nonterminal.
    unfold PositiveMapExtensions.find_default.
    unfold state in *; simpl in *.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Lemma lookup_state_aggregate_step st nt
    : lookup_state (aggregate_step st) nt
      = option_rect (fun _ => _)
                    (fun s => s ⊔ step_constraints gdata (lookup_state st) nt (lookup_state st nt))
                    default_value
                    (PositiveMap.find (nonterminal_to_positive nt) st).
  Proof.
    unfold lookup_state, PositiveMapExtensions.find_default.
    rewrite find_aggregate_step.
    unfold lookup_state, PositiveMapExtensions.find_default.
    rewrite nonterminal_to_positive_to_nonterminal.
    unfold state in *; simpl in *.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Section with_initial.
    Context (initial_nonterminals_data : list default_nonterminal_carrierT).

    Definition aggregate_state_max : aggregate_state
      := List.fold_right
           (fun nt st => PositiveMap.add (nonterminal_to_positive nt) ⊥ st)
           (PositiveMap.empty _)
           initial_nonterminals_data.

    Definition pre_Fix_grammar_helper : aggregate_state -> aggregate_state
      := Fix
           (aggregate_state_lt_wf_idx (10 * List.length initial_nonterminals_data))
           (fun _ => aggregate_state)
           (fun st Fix_grammar_internal
            => match Sumbool.sumbool_of_bool (aggregate_state_eq st (aggregate_step st)) with
               | left pf => st
               | right pf => Fix_grammar_internal (aggregate_step st) (step_lt pf)
               end).

    Definition pre_Fix_grammar : aggregate_state
      := pre_Fix_grammar_helper aggregate_state_max.

    Lemma pre_Fix_grammar_helper_fixed st (H : aggregate_state_eq st (aggregate_step st))
      : aggregate_state_eq st (pre_Fix_grammar_helper st).
    Proof.
      unfold pre_Fix_grammar_helper.
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      edestruct dec; [ | congruence ].
      reflexivity.
    Qed.

    Lemma pre_Fix_grammar_helper_commute v
      : aggregate_state_eq (pre_Fix_grammar_helper (aggregate_step v))
                           (aggregate_step (pre_Fix_grammar_helper v)).
    Proof.
      unfold pre_Fix_grammar_helper.
      induction (aggregate_state_lt_wf v) as [v H IHv].
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial);
        symmetry;
        rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial);
        symmetry.
      do 2 edestruct dec; try reflexivity;
        repeat match goal with
               | [ H : ?x = true |- _ ] => change (is_true x) in H
               end.
      { fold @pre_Fix_grammar_helper in *.
        rewrite <- pre_Fix_grammar_helper_fixed by assumption.
        assumption. }
      { match goal with
        | [ H : is_true (aggregate_state_eq ?x ?y), H' : context[?x] |- _ ]
          => rewrite <- H in H'
        end.
        congruence. }
      { apply IHv.
        apply step_lt; assumption. }
    Qed.

    Global Instance aggregate_state_eq_Proper_eq
      : Proper (eq ==> eq ==> eq) aggregate_state_eq
      := _.
    Global Instance aggregate_step_Proper_eq
      : Proper (eq ==> eq) aggregate_step
      := _.

    Lemma pre_Fix_grammar_fixedpoint
      : aggregate_state_eq pre_Fix_grammar (aggregate_step pre_Fix_grammar).
    Proof.
      unfold pre_Fix_grammar, pre_Fix_grammar_helper.
      generalize aggregate_state_max; intro a.
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      edestruct dec as [pf|pf].
      { rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
        edestruct dec; [ | congruence ].
        assumption. }
      { induction (aggregate_state_lt_wf a) as [?? IH].
        rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
        symmetry;
          rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial);
          symmetry.
        rewrite pf; simpl.
        edestruct dec as [pf'|pf'].
        { rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
          rewrite pf'; simpl.
          assumption. }
        { apply IH; try assumption; []; clear IH.
          unfold Basics.flip, aggregate_state_lt, PositiveMapExtensions.lift_ltb.
          setoid_rewrite pf; simpl; rewrite andb_true_r.
          pose proof (fun x => aggregate_state_lub_correct x (aggregate_prestep x)) as H'.
          unfold aggregate_step in *.
          edestruct H'; eassumption. } }
    Qed.
  End with_initial.

  Section with_grammar.
    Context (G : pregrammar' Char).

    Let predata := @rdp_list_predata _ G.
    Local Existing Instance predata.

    Lemma find_aggregate_state_max_spec k v
      : PositiveMap.find k (aggregate_state_max initial_nonterminals_data) = Some v
        <-> (v = ⊥ /\ is_valid_nonterminal initial_nonterminals_data (positive_to_nonterminal k)).
    Proof.
      unfold aggregate_state_max in *.
      generalize dependent (@initial_nonterminals_data _ _); intros ls.
      induction ls as [|x xs IHxs].
      { simpl in *.
        autorewrite with aggregate_step_db in *.
        intuition (tauto || congruence || eauto). }
      { simpl in *.
        autorewrite with aggregate_step_db in *.
        edestruct PositiveMap.E.eq_dec; subst;
          autorewrite with aggregate_step_db in *;
          auto using eq_refl with nocore.
        { repeat intuition (congruence || subst || eauto). }
        { intuition (congruence || subst || eauto).
          { apply orb_true_iff; intuition. }
          { do 2 match goal with
                 | [ H : is_true (orb _ _) |- _ ] => apply orb_true_iff in H
                 | [ H : _ |- _ ] => setoid_rewrite beq_nat_true_iff in H
                 end.
            repeat intuition (congruence || subst || (autorewrite with aggregate_step_db in * ) || eauto). } } }
    Qed.

    Lemma find_aggregate_state_max k v
      : PositiveMap.find k (aggregate_state_max initial_nonterminals_data) = Some v
        -> PositiveMap.find k (aggregate_state_max initial_nonterminals_data) = Some ⊥.
    Proof.
      setoid_rewrite find_aggregate_state_max_spec.
      tauto.
    Qed.

    Hint Rewrite find_aggregate_state_max_spec : aggregate_step_db.

    Lemma lookup_state_aggregate_state_max nt
      : lookup_state (aggregate_state_max initial_nonterminals_data) nt
        = if is_valid_nonterminal initial_nonterminals_data nt
          then ⊥
          else default_value.
    Proof.
      unfold lookup_state, PositiveMapExtensions.find_default, option_rect.
      destruct (PositiveMap.find (nonterminal_to_positive nt) (aggregate_state_max (@initial_nonterminals_data _ predata))) eqn:H; [ | ];
        setoid_rewrite H.
      { simpl in *.
        apply find_aggregate_state_max_spec in H.
        rewrite nonterminal_to_positive_to_nonterminal in H.
        destruct H as [? H']; subst; simpl in *; rewrite H'; intuition. }
      { match goal with |- context[if ?e then _ else _] => destruct e eqn:H' end;
        [ | reflexivity ].
        pose proof (find_aggregate_state_max_spec (nonterminal_to_positive nt) ⊥) as H''.
        rewrite nonterminal_to_positive_to_nonterminal, H' in H''.
        destruct H'' as [_ H''].
        rewrite H'' in H by intuition.
        congruence. }
    Qed.

    Lemma find_pre_Fix_grammar (nt : default_nonterminal_carrierT)
      : is_valid_nonterminal initial_nonterminals_data nt
        <-> PositiveMap.find (nonterminal_to_positive nt) (pre_Fix_grammar initial_nonterminals_data) <> None.
    Proof.
      unfold pre_Fix_grammar, pre_Fix_grammar_helper.
      assert (H : PositiveMap.find (nonterminal_to_positive nt) (aggregate_state_max initial_nonterminals_data) <> None
                  <-> is_valid_nonterminal initial_nonterminals_data nt).
      { pose proof (find_aggregate_state_max_spec (nonterminal_to_positive nt)) as H.
        rewrite nonterminal_to_positive_to_nonterminal in H.
        edestruct PositiveMap.find.
        { edestruct H as [H0 H1]; clear H.
          intuition congruence. }
        { specialize (H ⊥).
          intuition congruence. } }
      rewrite <- H; clear H.
      generalize dependent (aggregate_state_max initial_nonterminals_data); intro a; intros.
      induction (aggregate_state_lt_wf a) as [?? IH].
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      edestruct dec as [pf|pf]; [ reflexivity | ].
      rewrite <- IH by (apply step_lt; assumption).
      rewrite find_aggregate_step.
      unfold option_map; split; fold_andb_t.
    Qed.

    Lemma find_pre_Fix_grammar_to_lookup_state (nt : default_nonterminal_carrierT)
      : PositiveMap.find (nonterminal_to_positive nt) (pre_Fix_grammar initial_nonterminals_data)
        = if is_valid_nonterminal initial_nonterminals_data nt
          then Some (lookup_state (pre_Fix_grammar initial_nonterminals_data) nt)
          else None.
    Proof.
      let v := match goal with |- context[if ?v then _ else _] => v end in
      destruct v eqn:Hvalid.
      { apply find_pre_Fix_grammar in Hvalid.
        unfold lookup_state, PositiveMapExtensions.find_default, state in *; simpl in *.
        edestruct PositiveMap.find;
          [ reflexivity | congruence ]. }
      { destruct (PositiveMap.find (nonterminal_to_positive nt) (pre_Fix_grammar (@initial_nonterminals_data _ predata))) eqn:H; [ | reflexivity ].
        rewrite (proj2 (find_pre_Fix_grammar _)) in Hvalid; congruence. }
    Qed.

    Lemma lookup_state_invalid_pre_Fix_grammar (nt : default_nonterminal_carrierT)
          (Hinvalid : is_valid_nonterminal initial_nonterminals_data nt = false)
      : lookup_state (pre_Fix_grammar initial_nonterminals_data) nt = default_value.
    Proof.
      unfold lookup_state, PositiveMapExtensions.find_default.
      pose proof (find_pre_Fix_grammar nt).
      rewrite Hinvalid in H; destruct H.
      unfold state in *; simpl in *.
      edestruct PositiveMap.find.
      { intuition congruence. }
      { reflexivity. }
    Qed.*)
  End with_grammar.
End grammar_fixedpoint.


Require Import Rel.Definitions.
Require Import Lang.BindingsFacts.
Require Import Wf_natnat.
Set Implicit Arguments.

Implicit Types EV HV V L : Set.

Section section_HV_map_aux.

Hint Extern 1 => match goal with
| [ x : ?V |- ∃ _ : ?V, _ ] => exists x ; crush
end.

Local Hint Extern 0 => match goal with
| [ |- ?n ⊨ ?X ⇔ ?X ] => apply auto_contr_id
| [ |- ?n ⊨ ?X ≈ᵢ ?X ] => repeat iintro ; apply auto_contr_id
| [ |- Acc lt' (_, _) ] => try lt'_solve
end.

Fixpoint
  HV_map_𝓥_aux
  n EV HV HV'
  (Ξ : XEnv EV HV)
  (f : HV → HV')
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : HV' → hd0) (ρ' : HV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ β : HV, ρ₁ β = ρ₁' (f β))
  (Hρ₂ : ∀ β : HV, ρ₂ β = ρ₂' (f β))
  (Hρ : n ⊨ ∀ᵢ β : HV, ρ β ≈ᵢ ρ' (f β))
  (ξ₁ ξ₂ : list var)
  (v₁ v₂ : val0) (T : ty EV HV ∅)
  (W : Acc lt' (n, size_ty T))
  {struct W} :
  (n ⊨
    𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
    𝓥⟦ (HV_map_XEnv f Ξ) ⊢ HV_map_ty f T ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂)
with
  HV_map_𝓾_aux
  n EV HV HV'
  (Ξ : XEnv EV HV)
  (f : HV → HV')
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : HV' → hd0) (ρ' : HV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ β : HV, ρ₁ β = ρ₁' (f β))
  (Hρ₂ : ∀ β : HV, ρ₂ β = ρ₂' (f β))
  (Hρ : n ⊨ ∀ᵢ β : HV, ρ β ≈ᵢ ρ' (f β))
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (ε : ef EV HV ∅)
  (W : Acc lt' (n, 0))
  {struct W} :
  (n ⊨
    𝓾⟦ Ξ ⊢ ε ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓾⟦ (HV_map_XEnv f Ξ) ⊢ HV_map_ef f ε ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)
with
  HV_map_𝓤_aux
  n EV HV HV'
  (Ξ : XEnv EV HV)
  (f : HV → HV')
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : HV' → hd0) (ρ' : HV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ β : HV, ρ₁ β = ρ₁' (f β))
  (Hρ₂ : ∀ β : HV, ρ₂ β = ρ₂' (f β))
  (Hρ : n ⊨ ∀ᵢ β : HV, ρ β ≈ᵢ ρ' (f β))
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (𝓔 : eff EV HV ∅)
  (W : Acc lt' (n, size_eff 𝓔))
  {struct W} :
  (n ⊨
    𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓤⟦ (HV_map_XEnv f Ξ) ⊢ HV_map_eff f 𝓔 ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)
.

Proof.
{
destruct T eqn:HT.
+ crush.
+ simpl 𝓥_Fun ; auto_contr.
  - apply HV_map_𝓥_aux ; auto.
  - apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
+ simpl 𝓥_Fun ; auto_contr.
  replace (EV_shift_XEnv (HV_map_XEnv f Ξ))
    with (HV_map_XEnv f (EV_shift_XEnv Ξ))
    by (erewrite EV_HV_map_XEnv ; crush).
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
+ simpl 𝓥_Fun ; auto_contr.
  replace (HV_shift_XEnv (HV_map_XEnv f Ξ))
    with (HV_map_XEnv (map_inc f) (HV_shift_XEnv Ξ))
    by (repeat erewrite HV_map_map_XEnv ; crush).
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; [ |auto].
  repeat iintro ; apply HV_map_𝓥_aux ; [auto|auto| |auto].
  iintro β ; destruct β ; simpl ; repeat iintro ; [auto|].
  iespecialize Hρ ; apply Hρ.
}

{
destruct ε as [ α | [ p | [ | X ] ] ] ; simpl.
+ auto.
+ auto_contr.
  - rewrite Hρ₁, Hρ₂ ; reflexivity.
  - rewrite Hρ₁, Hρ₂ ; reflexivity.
  - apply 𝓗_Fun'_nonexpansive ; repeat iintro ; [auto|].
    iespecialize Hρ ; apply Hρ.
+ auto.
+ auto_contr.
  isplit ; iintro' H.
  - idestruct H as T H ; idestruct H as 𝓔 H ; idestruct H as HX H.
    ielim_prop HX ; eapply binds_HV_map in HX.
    repeat ieexists ; repeat isplit ; [ eauto | ].
    later_shift.
    erewrite <- I_iff_elim_M ; [ apply H |].
    apply 𝓗_Fun'_nonexpansive ; repeat iintro ; [auto|].
    apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
    { erewrite <- 𝓥_roll_unroll_iff ; auto. }
    { erewrite <- 𝓤_roll_unroll_iff ; auto. }
  - idestruct H as T' H ; idestruct H as 𝓔' H ; idestruct H as HX H.
    ielim_prop HX ; apply binds_HV_map_inv in HX.
    destruct HX as [ T [ 𝓔 [ HT [ H𝓔 HX ] ] ] ] ; subst.
    repeat ieexists ; repeat isplit ; [ eauto | ].
    later_shift.
    erewrite I_iff_elim_M ; [ apply H | ].
    apply 𝓗_Fun'_nonexpansive ; repeat iintro ; [auto|].
    apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
    { erewrite <- 𝓥_roll_unroll_iff ; auto. }
    { erewrite <- 𝓤_roll_unroll_iff ; auto. }
}

{
destruct 𝓔 ; simpl.
+ auto.
+ auto_contr ; auto.
}

Qed.

End section_HV_map_aux.

Section section_HV_map.
Context (n : nat).
Context (EV HV HV' : Set).
Context (Ξ : XEnv EV HV).
Context (f : HV → HV').
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig).
Context (ρ₁' ρ₂' : HV' → hd0) (ρ' : HV' → IRel 𝓣_Sig).
Context (Hρ₁ : ∀ β : HV, ρ₁ β = ρ₁' (f β)).
Context (Hρ₂ : ∀ β : HV, ρ₂ β = ρ₂' (f β)).
Context (Hρ : n ⊨ ∀ᵢ β : HV, ρ β ≈ᵢ ρ' (f β)).

Hint Resolve lt'_wf.

Lemma HV_map_𝓥 T ξ₁ ξ₂ v₁ v₂ :
n ⊨
  𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
  𝓥⟦ (HV_map_XEnv f Ξ) ⊢ HV_map_ty f T ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂.
Proof.
apply HV_map_𝓥_aux ; auto.
Qed.

Lemma HV_map_𝓤 𝓔 ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ :
n ⊨
  𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ ⇔
  𝓤⟦ (HV_map_XEnv f Ξ) ⊢ HV_map_eff f 𝓔 ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂.
Proof.
apply HV_map_𝓤_aux ; auto.
Qed.

Hint Resolve HV_map_𝓥 HV_map_𝓤.

Lemma HV_map_𝓣 T 𝓔 ξ₁ ξ₂ t₁ t₂ :
n ⊨
  𝓣⟦ Ξ ⊢ T # 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ⇔
  𝓣⟦ (HV_map_XEnv f Ξ) ⊢ (HV_map_ty f T) # (HV_map_eff f 𝓔) ⟧
    δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂.
Proof.
apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
Qed.

End section_HV_map.


Require Import Coq.Arith.Arith Coq.NArith.BinNat Coq.micromega.Lia Coq.Strings.String
        Coq.Lists.List Structures.OrdersEx micromega.Lia.
Require Import Common.Common.
Require Import LambdaBoxLocal.expression.
Require Import LambdaANF.algebra LambdaANF.tactics.

Open Scope alg_scope.

(* Environment semantics values *)
Inductive value :=
| Con_v : dcon -> list value -> value
(* | Prf_v : value *)
| Clos_v : list value -> name -> expression.exp -> value
| ClosFix_v : list value -> efnlst -> N -> value.

Lemma value_ind' (P : value -> Prop) :
  (forall dcon vs, Forall P vs -> P (Con_v dcon vs)) ->
  (forall vs na e, Forall P vs -> P (Clos_v vs na e)) ->
  (forall vs fnl n, Forall P vs -> P (ClosFix_v vs fnl n)) ->
  (forall v,  P v).
Proof.
  intros H1 H2 H3.
  fix IHv 1; intros v. destruct v.
  - eapply H1. induction l.
    constructor.
    constructor. eapply IHv. eassumption.
  - eapply H2. induction l.
    constructor.
    constructor. eapply IHv. eassumption.
  - eapply H3. induction l.
    constructor.
    constructor. eapply IHv. eassumption.
Qed.

(* Definition of env *)
Definition env := list value.

Inductive result :=
| Val : value -> result
| OOT : result.

Fixpoint max_binders_branches (br : branches_e) : nat :=
  match br with
  | brnil_e => 0
  | brcons_e _ (m, _) _ br =>
    max (N.to_nat m) (max_binders_branches br)
  end.

Section LambdaBoxLocal_fuel.

  Class LambdaBoxLocal_resource {A} :=
  { HRes :> @resource exp A; }.

End LambdaBoxLocal_fuel.

Section Util.

  (** Helper functions for going between exps and lists *)

  Definition make_rec_env_rev_order (fnlst : efnlst) (rho : env) : env :=
    let fix make_env_aux l :=
        match l with
        | nil => rho
        | cons n l' =>
          let env' := make_env_aux l' in
          ((ClosFix_v rho fnlst (N.of_nat n)) :: env')
        end
    in
    make_env_aux (list_to_zero (efnlength fnlst)).

  Lemma enthopt_inlist_Forall (P : exp -> Prop) :
    forall efnl n e,
      Forall (fun (p : name * exp) => let (_, e) := p in P e) (efnlst_as_list efnl) ->
      enthopt (N.to_nat n) efnl = Some e ->
      P e.
  Proof.
    intros efnl n.
    generalize (N.to_nat n). induction efnl; intros n' e' Hall Hnth.
    - destruct n'; simpl in Hnth; inv Hnth.
    - destruct  n'. inv Hnth.
      + inv Hall. eassumption.
      + inv Hall. simpl in Hnth. eapply IHefnl.
        eassumption. eassumption.
  Qed.

  Lemma make_rec_env_rev_order_app fns vs :
    exists vs', make_rec_env_rev_order fns vs = vs' ++ vs /\
                List.length vs' = efnlength fns /\
                forall n, (n < efnlength fns)%nat ->
                          nth_error vs' n = Some (ClosFix_v vs fns (N.of_nat (efnlength fns - n - 1))).
  Proof.
    unfold make_rec_env_rev_order. generalize (efnlength fns) as m.
    induction m.
    - simpl. eexists []. split. reflexivity. split.
      compute. reflexivity.
      intros. lia.
    - destructAll.
      eexists (ClosFix_v vs fns (N.of_nat (Datatypes.length x)) :: x). simpl.
      split; [ | split ].
      + rewrite H. reflexivity.
      + reflexivity.
      + intros. destruct n.
        * simpl. rewrite Nat.sub_0_r. reflexivity.
        * simpl. eapply H1. lia.
  Qed.

End Util.

Fixpoint add_list {fuel : Type} {Hf : @LambdaBoxLocal_resource fuel} (l : list fuel) : fuel :=
  match l with
  | nil => <0>
  | cons f fs => f <+> add_list fs
  end.

Section FUEL_SEM.

  Inductive Forall3 {A B C : Type} (R : A -> B -> C -> Prop) : list A -> list B -> list C -> Prop :=
    Forall3_nil : Forall3 R [] [] []
  | Forall3_cons :
      forall (x : A) (y : B) (z : C) (l : list A) (l' : list B) (l'' : list C),
        R x y z -> Forall3 R l l' l'' -> Forall3 R (x :: l) (y :: l') (z :: l'').

  Context {trace : Type} {Hf : @LambdaBoxLocal_resource nat} {Ht : @LambdaBoxLocal_resource trace}.

  (** * {Nat,environment}-based semantics for LambdaBoxLocal *)
  Inductive eval_env_step: env -> exp -> result -> nat -> trace -> Prop :=
  | eval_Con_step:
      forall (es : expression.exps) (vs : list value) (rho: env) (dc: dcon) fs ts,
        eval_fuel_many rho es vs fs ts ->
        eval_env_step rho (Con_e dc es) (Val (Con_v dc vs)) fs ts
  | eval_Con_step_OOT:
      forall (es es1 es2: expression.exps) (e : exp) (vs : list value) (rho: env) (dc: dcon) fs f t ts,
        exps_as_list es = exps_as_list es1 ++ e :: exps_as_list es2 ->
        eval_fuel_many rho es1 vs fs ts ->
        eval_env_fuel rho e OOT f t ->
        eval_env_step rho (Con_e dc es) OOT  (fs <+> f) (ts <+> t)

  | eval_App_step:
      forall (e1 e2 e1': expression.exp) v2 r (na : name) (rho rho': env)
             f1 f2 f3 t1 t2 t3,
        eval_env_fuel rho e1 (Val (Clos_v rho' na e1')) f1 t1 ->
        eval_env_fuel rho e2 (Val v2) f2 t2 ->
        eval_env_fuel (v2::rho') e1' r f3 t3 ->
        eval_env_step rho (App_e e1 e2) r (f1 <+> f2 <+> f3) (t1 <+> t2 <+> t3)
  | eval_App_step_OOT1 :
      forall (e1 e2 : expression.exp) (rho : env) f1 t1,
        eval_env_fuel rho e1 OOT f1 t1 ->
        eval_env_step rho (App_e e1 e2) OOT f1 t1
  | eval_App_step_OOT2 :
      forall (e1 e2 : expression.exp) (v : value) (rho : env) f1 f2 t1 t2,
        eval_env_fuel rho e1 (Val v) f1 t1 ->
        eval_env_fuel rho e2 OOT f2 t2 ->
        eval_env_step rho (App_e e1 e2) OOT (f1 <+> f2) (t1 <+> t2)

  | eval_Let_step:
      forall (e1 e2 : expression.exp) (v1 : value) (r : result) (rho: env) (na: name) f1 f2 t1 t2,
        eval_env_fuel rho e1 (Val v1) f1 t1 ->
        eval_env_fuel (v1::rho) e2 r f2 t2 ->
        eval_env_step rho (Let_e na e1 e2) r (f1 <+> f2) (t1 <+> t2)
  | eval_Let_step_OOT:
      forall (e1 e2 : expression.exp) (rho: env) (na: name) f1 t1,
        eval_env_fuel rho e1 OOT f1 t1 ->
        eval_env_step rho (Let_e na e1 e2) OOT f1 t1

  | eval_FixApp_step:
      forall (e1 e2 e': expression.exp) (rho rho' rho'': env) (n: N) (na : name)
             (fnlst: efnlst) (v2 : value) r f1 f2 f3 t1 t2 t3,
        eval_env_fuel rho e1 (Val (ClosFix_v rho' fnlst n)) f1 t1 ->
        enthopt (N.to_nat n) fnlst = Some (Lam_e na e') ->
        make_rec_env_rev_order fnlst rho' = rho'' ->
        eval_env_fuel rho e2 (Val v2) f2 t2 ->
        eval_env_fuel (v2 :: rho'') e' r f3 t3 ->
        eval_env_step rho (App_e e1 e2) r (f1 <+> f2 <+> f3) (t1 <+> t2 <+> t3)

  | eval_Match_step:
      forall (e1 e': expression.exp) (rho: env) (dc: dcon) (vs: list value)
             (n: N) (brnchs: branches_e) (r: result) f1 f2 t1 t2,
        eval_env_fuel rho e1 (Val (Con_v dc vs)) f1 t1 ->
        find_branch dc (N.of_nat (List.length vs)) brnchs = Some e' ->
        eval_env_fuel ((List.rev vs) ++ rho) e' r f2 t2 ->
        eval_env_step rho (Match_e e1 n brnchs) r (f1 <+> f2) (t1 <+> t2)
  | eval_Match_step_OOT:
      forall (e1 : expression.exp) (rho: env) (n: N) (br: branches_e) f1 t1,
        eval_env_fuel rho e1 OOT f1 t1 ->
        eval_env_step rho (Match_e e1 n br) OOT f1 t1

  with eval_fuel_many: env -> exps -> list value -> nat -> trace -> Prop :=
  | eval_many_enil :
      forall rho,
        eval_fuel_many rho enil [] <0> <0>
  | eval_many_econs :
      forall rho e es v vs f fs t ts,
        eval_env_fuel rho e (Val v) f t ->
        eval_fuel_many rho es vs fs ts ->
        eval_fuel_many rho (econs e es) (v :: vs) (f <+> fs) (t <+> ts)

  with eval_env_fuel: env -> exp -> result -> nat -> trace -> Prop :=
  (* Values *)
  | eval_Var_fuel:
      forall (x: N) (rho: env) (v: value),
        nth_error rho (N.to_nat x) = Some v ->
        eval_env_fuel rho (Var_e x) (Val v) <0> <0>
  | eval_Lam_fuel:
      forall (e: expression.exp) (rho:env) (na: name),
        eval_env_fuel rho (Lam_e na e) (Val (Clos_v rho na e)) <0> (one_i (Lam_e na e))
  | eval_Fix_fuel:
      forall (n: N) (rho: env) (fnlst: efnlst),
        eval_env_fuel rho (Fix_e fnlst n) (Val (ClosFix_v rho fnlst n)) <0> (one_i (Fix_e fnlst n))
  (* OOT *)
  | eval_OOT :
      forall rho (e : exp) f t,
        (f < one_i e)%nat ->
        eval_env_fuel rho e OOT f t
  (* STEP *)
  | eval_step : (* take a step *)
      forall rho e r (f : nat) t,
        eval_env_step rho e r f t ->
        eval_env_fuel rho e r (f <+> (one_i e)) (t <+> (one_i e)).

  Set Printing All.

  Scheme eval_env_step_ind' := Minimality for eval_env_step Sort Prop
    with eval_fuel_many_ind' :=  Minimality for eval_fuel_many Sort Prop
    with eval_env_fuel_ind' := Minimality for eval_env_fuel Sort Prop.

  Section WF.

    Definition well_formed_in_env (e : exp) (rho : list value) :=
      exp_wf (N.of_nat (length rho)) e.

    Inductive well_formed_val : value -> Prop :=
    | Wf_Con :
        forall dc vs,
          Forall well_formed_val vs ->
          well_formed_val (Con_v dc vs)
    | Wf_Clos :
        forall vs n e,
          Forall well_formed_val vs ->
          (forall x, well_formed_in_env e (x :: vs)) ->
          well_formed_val (Clos_v vs n e)
    | Wf_ClosFix :
        forall vs n efns,
          Forall well_formed_val vs ->
          n < efnlst_length efns ->
          Forall (fun (p : name * exp) =>
                    let (n, e) := p in
                    isLambda e /\
                    exp_wf (efnlst_length efns + (N.of_nat (length vs))) e) (efnlst_as_list efns) ->
          well_formed_val (ClosFix_v vs efns n).

    Definition well_formed_exps_in_env (es : exps) (rho : list value) :=
      exps_wf (N.of_nat (length rho)) es.

    Definition well_formed_env (rho : list value) : Prop :=
      Forall well_formed_val rho.

    Lemma well_formed_in_env_Match_branches:
      forall e e' bs rho i dc vs f t,
        eval_env_fuel rho e (Val (Con_v dc vs)) f t ->
        well_formed_in_env (Match_e e i bs) rho ->
        find_branch dc (N.of_nat (Datatypes.length vs)) bs = Some e' ->
        well_formed_in_env e' (rev vs ++ rho).
    Proof.
      intros e e' bs rho i d vs f t Heval Hwf H.
      inv Hwf.
      unfold well_formed_in_env.
      rewrite app_length. rewrite Nnat.Nat2N.inj_add.
      rewrite rev_length. eapply find_branch_preserves_wf; eassumption.
    Qed.

    Lemma well_formed_envmake_rec_env_rev_order fnlst rho rho' :
      make_rec_env_rev_order fnlst rho = rho' ->
      well_formed_env rho ->
      Forall
        (fun p : name * exp =>
           let (_, e) := p in
           isLambda e /\
           exp_wf (efnlst_length fnlst + N.of_nat (Datatypes.length rho)) e)
        (efnlst_as_list fnlst) ->
      well_formed_env rho'.
    Proof.
      unfold make_rec_env_rev_order.
      assert (Hlen : N.of_nat (efnlength fnlst) <= efnlst_length fnlst).
      { rewrite efnlength_efnlst_length. lia. }
      revert Hlen. generalize fnlst at 2 3 5 6. revert rho rho'.
      induction fnlst; intros rho rho' fnlst' Hlen Heq Henv Hall; eauto.
      - simpl in *. subst; eauto.
      - simpl in *. subst.
        constructor; eauto.
        constructor; eauto.

        lia.

        eapply IHfnlst; eauto. lia.
    Qed.

    Lemma efnlst_wf_isLambda :
      forall n es e,
        efnlst_wf n es -> In e (efnlst_as_list es) ->
        isLambda (snd e) /\ exp_wf n (snd e).
    Proof.
      intros n es e H1 H2.
      induction es.
      - inv H2.
      - inv H1. inv H2.
        split; eassumption.
        eapply IHes; try eassumption.
    Qed.

    Lemma eval_env_step_preserves_wf :
      forall vs e r f t,
        eval_env_fuel vs e r f t ->
        forall v, r = Val v ->
                  well_formed_env vs ->
                  well_formed_in_env e vs ->
                  well_formed_val v.
    Proof.
      pose (P := fun (vs : env) (e : exp) (r : result) (f : nat) (t : trace) =>
                   forall v,
                     r = Val v ->
                     well_formed_env vs ->
                     well_formed_in_env e vs ->
                     well_formed_val v).

      pose (P1 := fun (vs : env) (es : exps) (vs' : list value) (f : nat) (t : trace) =>
                    well_formed_env vs ->
                    well_formed_exps_in_env es vs ->
                    Forall well_formed_val vs').

      pose (P2 := fun (vs : env) (e : exp) (r : result) (f : nat) (t : trace) =>
                    forall v,
                      r = Val v ->
                      well_formed_env vs ->
                      well_formed_in_env e vs ->
                      well_formed_val v).

      intros vs e r f t Heval.
      eapply eval_env_fuel_ind' with (P := P) (P0 := P1) (P1 := P2);
      unfold P, P1, P2; intros; try congruence.

      - inv H1. constructor. inv H3. eapply H0; eauto.

      - subst. inv H7.
        specialize (H0 _ ltac:(reflexivity) H6 H10).
        inv H0. eapply H4; eauto.
        constructor; eauto.

      - subst. inv H5.
        eapply H2; eauto. constructor; eauto.
        unfold well_formed_in_env.
        simpl List.length.
        replace (N.of_nat (S (Datatypes.length rho))) with (1 + N.of_nat (Datatypes.length rho)) by lia.
        eassumption.

      - subst. inv H9.
        specialize (H0 _ ltac:(reflexivity) H8 H11). inv H0.

        eapply H6; eauto. constructor; eauto.
        now eapply well_formed_envmake_rec_env_rev_order; eauto.

        eapply enthopt_inlist_Forall in H14; eauto.
        inv H14. inv H2.

        unfold well_formed_in_env. simpl List.length.
        replace (N.of_nat (S (Datatypes.length (make_rec_env_rev_order fnlst rho'))))
          with (1 + N.of_nat (Datatypes.length (make_rec_env_rev_order fnlst rho'))) by lia.

        edestruct make_rec_env_rev_order_app. destructAll. rewrite H2.
        rewrite app_length. rewrite Nnat.Nat2N.inj_add.
        rewrite H7. rewrite efnlength_efnlst_length. eassumption.

      - subst.
        inv H6. specialize (H0 _ ltac:(reflexivity) H5 H9). inv H0.
        eapply H3; eauto.
        eapply Forall_app. split; eauto.
        eapply Forall_rev; eauto.
        eapply well_formed_in_env_Match_branches; eauto.
        constructor; eauto.

      - now constructor.

      - inv H4. constructor; eauto.

      - inv H2. inv H0; eauto.
        eapply Forall_forall in H1. eassumption.
        eapply nth_error_In. eassumption.

      - inv H1. inv H. constructor; eauto.
        intros x. unfold well_formed_in_env.
        simpl List.length.
        replace (N.of_nat (S (Datatypes.length rho))) with (1 + N.of_nat (Datatypes.length rho)) by lia.
        eassumption.

      - inv H. inv H1.
        constructor; eauto.

        eapply Forall_forall. intros. destruct x.
        eapply efnlst_wf_isLambda in H.
        eassumption. eassumption.

      - subst; eauto.

      - eassumption.

        Unshelve. eassumption.
    Qed.

  End WF.

  Lemma exps_as_list_append e1 e2 :
    exps_as_list (exps_append e1 e2) = exps_as_list e1 ++ exps_as_list e2.
  Proof.
    induction e1. reflexivity.
    simpl. rewrite IHe1. reflexivity.
  Qed.

  (*
  Lemma fuel_sem_OOT vs e r f f' :
    eval_env_fuel vs e r f ->
    lt f' f ->
    eval_env_fuel vs e OOT f'.
  Proof.
    pose (P := fun (vs : env) (e : exp) (r : result) (f : nat) =>
                 forall f',
                   lt f' f ->
                   eval_env_step vs e OOT f').

    pose (P1 := fun (vs : env) (e : exp) (r : result) (f : nat) =>
                  forall f',
                    lt f' f ->
                    eval_env_fuel vs e OOT f').

    pose (P2 := fun (vs : env) (es : exps) (vs' : list value) (f : nat) =>
                  forall f',
                    lt f' f ->
                    exists es1 e es2 vs1 fs f'',
                      exps_to_list es = exps_to_list es1 ++ e :: exps_to_list es2 /\
                      f' = (fs <+> f'') /\
                      eval_fuel_many vs es1 vs1 fs /\ eval_env_fuel vs e OOT f'').

    intros Heval. revert f'.
    eapply eval_env_fuel_ind' with (P := P) (P0 := P2) (P1 := P1);
      unfold P, P1, P2; intros; try congruence.

    - edestruct H0. eassumption. destructAll.
      econstructor; eassumption.

    - edestruct (lt_all_dec f' fs).
      + edestruct H1. eassumption. destructAll.
        rewrite H6, <- app_assoc in H. simpl in H.
        econstructor.
        rewrite H. f_equal. f_equal.
        replace (e0 :: exps_to_list es2) with (exps_to_list (econs e0 es2)) by reflexivity.
        rewrite <- exps_to_list_append. reflexivity.
        eassumption.
        eassumption.

      + destructAll. rewrite (plus_comm fs) in H4.
        eapply plus_stable in H4. rewrite plus_comm.
        econstructor. eassumption. eassumption.
        eapply H3; eauto.

    - edestruct (lt_all_dec f' f1).

      + eapply eval_App_step_OOT1; eauto.

      + destructAll.
        rewrite plus_assoc in H5.
        rewrite !(plus_comm f1) in H5.
        eapply plus_stable in H5.

        edestruct (lt_all_dec x f2).

        * rewrite plus_comm. eapply eval_App_step_OOT2; eauto.

        * destructAll.
          rewrite !(plus_comm f2) in H5.
          eapply plus_stable in H5.

          rewrite plus_assoc.
          rewrite (plus_comm f2 f1), (plus_comm x0).

          eapply eval_App_step; eauto.

    - eapply eval_App_step_OOT1; eauto.

    - edestruct (lt_all_dec f' f1).

      + eapply eval_App_step_OOT1; eauto.

      + destructAll. rewrite (plus_comm f1) in H3.
        eapply plus_stable in H3.
        rewrite plus_comm.
        eapply eval_App_step_OOT2; eauto.

    - edestruct (lt_all_dec f' f1).

      + eapply eval_Let_step_OOT; eauto.

      + destructAll. rewrite (plus_comm f1) in H3.
        eapply plus_stable in H3.
        rewrite plus_comm.
        eapply eval_Let_step; eauto.

    - eapply eval_Let_step_OOT; eauto.

    - edestruct (lt_all_dec f' f1).

      + eapply eval_App_step_OOT1; eauto.

      + destructAll.
        rewrite plus_assoc in H7.
        rewrite !(plus_comm f1) in H7.
        eapply plus_stable in H7.

        edestruct (lt_all_dec x f2).

        * rewrite plus_comm. eapply eval_App_step_OOT2; eauto.

        * destructAll.
          rewrite !(plus_comm f2) in H7.
          eapply plus_stable in H7.

          rewrite plus_assoc.
          rewrite (plus_comm f2 f1), (plus_comm x0).

          eapply eval_FixApp_step; eauto.

    - edestruct (lt_all_dec f' f1).

      + eapply eval_Match_step_OOT; eauto.

      + destructAll.
        rewrite !(plus_comm f1) in H4.
        eapply plus_stable in H4.
        rewrite plus_comm. eapply eval_Match_step; eauto.

    - eapply eval_Match_step_OOT; eauto.

    - exfalso. eapply lt_zero; eauto.

    - edestruct (lt_all_dec f' f0).

      + exists enil. do 5 eexists.
        split. simpl. reflexivity.
        split. rewrite plus_zero. reflexivity.
        split. constructor.
        eauto.

      + destructAll.
        rewrite !(plus_comm f0) in H3.
        eapply plus_stable in H3.
        edestruct H2. eassumption. destructAll.

        exists (econs e0 x0). do 5 eexists. split.

        simpl. rewrite H4. reflexivity. split.

        rewrite (plus_comm _ f0), plus_assoc. reflexivity.
        split. econstructor; eauto.  eassumption.

    - exfalso. eapply lt_zero; eauto.

    - exfalso. eapply lt_zero; eauto.

    - exfalso. eapply lt_zero; eauto.

    - eapply lt_one in H. subst.
      exfalso; eapply lt_zero; eauto.

    - edestruct (lt_all_dec f' (one_i e0)).

      + econstructor. eassumption.

      + destructAll.
        eapply plus_stable in H1.
        eapply eval_step. eauto.

    - eassumption.
  Qed.

  Lemma fuel_sem_monotonic vs e f f' :
    eval_env_fuel vs e OOT f ->
    lt f' f ->
    eval_env_fuel vs e OOT f'.
  Proof.
    eapply fuel_sem_OOT.
  Qed.
*)

End FUEL_SEM.


From Coq Require Import Arith ZArith OrderedType.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
From nbits Require Import NBits.
From ssrlib Require Import Types SsrOrder Var Nats ZAriths Tactics.
From BitBlasting Require Import Typ TypEnv State QFBV CNF BBCommon AdhereConform.
From BBCache Require Import CompCache Cache.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Definition init_vm := SSAVM.empty word.
Definition init_gen := (var_tt + 1)%positive.
Definition init_env : env := fun _ => true.
Definition init_ccache : compcache := CompCache.empty.
Definition init_cache : cache := Cache.empty.

Lemma init_newer_than_vm :
  newer_than_vm init_gen init_vm.
Proof.
  done.
Qed.

Lemma init_newer_than_tt :
  newer_than_lit init_gen lit_tt.
Proof.
  done.
Qed.

Lemma init_tt :
  interp_lit init_env lit_tt.
Proof.
  done.
Qed.

Lemma init_consistent :
  forall s, consistent init_vm init_env s.
Proof.
  move=> s x. rewrite /consistent1 /init_vm. rewrite SSAVM.Lemmas.empty_o. done.
Qed.

Lemma init_vm_adhere :
  forall te, AdhereConform.adhere init_vm te .
Proof.
  done.
Qed.

Lemma init_ccache_well_formed :
  CompCache.well_formed init_ccache.
Proof.
  done.
Qed.

Lemma init_newer_than_cache :
  newer_than_cache init_gen init_ccache.
Proof.
  done.
Qed.

Lemma init_interp_cache :
  CompCache.interp_cache init_env init_ccache.
Proof.
  done.
Qed.

Lemma init_correct :
  forall m, correct m init_ccache.
Proof.
  done.
Qed.

Lemma init_bound_cache :
  CompCache.bound init_ccache init_vm.
Proof.
  done.
Qed.

Lemma init_interp_cache_ct :
  forall E, interp_cache_ct E init_ccache.
Proof.
  done.
Qed.

Lemma init_compatible :
  compatible init_cache init_ccache.
Proof.
  done.
Qed.


Add LoadPath "/home/user/0my/GITHUB/VerifiedMathFoundations/library".
Require Import Coq.Structures.Equalities.
Require PredicateCalculus.
Require Terms.

(*UsualDecidableTypeFull)*)
Module nat_is_UDTF .
Definition t :=nat.
Definition SetVars:=nat.
End nat_is_UDTF.

Module SetVars := PeanoNat.Nat.
Module FuncSymb := PeanoNat.Nat.
Module PredSymb := PeanoNat.Nat.
Module eexampl :=
PredicateCalculus.Soundness_mod SetVars FuncSymb PredSymb.
(*Module eexampl :=
PredicateCalculus.Soundness_mod PeanoNat.Nat PeanoNat.Nat PeanoNat.Nat.*)

Module counterexample.
Export eexampl.
(*
Print SetVars.
Print FuncSymb.
Check FSV.
*)
(*Print eexampl.FSV.*)

(*Module example1 : Terms.terms_mod PeanoNat.Nat (*nat_is_UDTF*).*)
(*Definition FuncSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.*)
(*Definition SetVars:=nat.*)
(*Notation  SetVars:=nat.
Check PeanoNat.Nat.t.
Notation SetVars := SetVars.t.
Check example0.t.
(*Notation SetVars := PeanoNat.Nat.t.*)
Unset Elimination Schemes.
Inductive Terms : Type :=
| FVC :> SetVars -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.
Set Elimination Schemes.
*)

(* TODO: add *)

(* OK!
Print Fo.
Check Atom.
Print PSV.
Check Atom (MPSV 0 2).
Print Terms.
Check Atom (MPSV 0 2).
Print Vector.t.
Check Vector.cons _ (FVC 1) _ (Vector.cons _ (FVC 0) _ (Vector.nil _ )).
Check Atom (MPSV 0 2)
(Vector.cons _ (FVC 1) _ (Vector.cons _ (FVC 0) _ (Vector.nil _ ))).
*)

Definition xeqy := Atom (MPSV 0 2)
(Vector.cons _ (FVC 1) _ (Vector.cons _ (FVC 0) _ (Vector.nil _ ))).

Theorem upr : PREPR (xeqy::nil) (Fora 2 xeqy).
Proof.
apply GEN_E.
apply hyp_E.
simpl.
apply inl.
reflexivity.
Defined.
(* COUNTEREXAMPLE*)
(* PR is from provability, but it is better to call it derivability.*)
Section cor.
Context (X:Type).
Context (fsI:forall(q:FSV),(Vector.t X (fsv q))->X).
Context (prI:forall(q:PSV),(Vector.t X (psv q))->Omega).
(*Arguments foI X fsI prI .
Print Implicit foI.
Check foI.*)
Definition foIn := @foI X fsI prI.
Theorem badcorrect (x1 x2 : X) (nequ : ~(x1=x2))
(f:Fo) (l:list Fo) (m : PREPR l f) :
~ (forall(val:SetVars.t->X) (lfi : forall h:Fo, (InL h l)->(foIn val h)), foIn val f).
Proof.
intro H.
assert (val:SetVars.t->X).
 intro n. destruct n eqn:nn. exact x1.
(*          destruct s eqn:ss. exact x2. exact x2.*)
Abort.
End cor.

End counterexample.

(* IT IS NOT POSSIBLE TO PROVE THIS THEOREM:
Fixpoint correct (f:Fo) (l:list Fo) (val:SetVars->X) (m:PR l f)
(lfi : forall h:Fo, (InL h l)->(foI val h)) {struct m}: foI val f.
Proof.
revert val lfi.
induction m (* eqn: meq *); intros val lfi.
+ exact (lfi A i).
+ simpl.
  intros a b.
  exact a.
+ simpl.
  intros a b c.
  exact (a c (b c)).
+ simpl in *|-*.
  destruct (substF t xi ph) eqn: j.
  apply (UnivInst ph val xi t f j).
  simpl. firstorder.
+ simpl in *|-*.
  unfold OImp.
  intros H0 H1 m.
  apply H0.
  rewrite -> (NPthenNCACVF xi ps0 m val H).
  exact H1.
+ simpl in * |- *.
  unfold OImp in IHm2.
apply IHm2.
apply lfi.
apply IHm1.
apply lfi. (*  exact (IHm2 IHm1).*)
+ simpl in * |- *.
  intro m0.
apply IHm.
intros h B.
unfold InL in B.
(*Check correct A l val m lfi.*)
Check NPthenNCACVF xi ps0 m val H.
  destruct (substF t xi ph) eqn: j.
  apply (UnivInst ph val xi t f j).
  simpl. firstorder.

*)

(* old trash
unfold InL in B.
(*Check correct A l val m lfi.*)
Check NPthenNCACVF xi ps0 m val H.
  destruct (substF t xi ph) eqn: j.
  apply (UnivInst ph val xi t f j).
  simpl. firstorder.

  2 : { simpl. trivial. unfold OImp. firstorder. }
  apply (correct _ l).
  2 : {assumption. }
  simpl.
Check fun pi => UnivInst ph pi xi t f j.
(*forall pi : SetVars -> X, foI pi (Impl (Fora xi ph) f)*)
Show Proof.
Check PR.
pose (Z:=(@Ded (Fora xi ph) f l )).
simple refine (Z _ _ ).
Check correct.
apply correct.
2 : {
intros.
Check notGenWith.
simpl.
(*
  pose (W:= lfi f).
  destruct (Nat.eqb r xi).
  simpl in H.
  exact H.
  unfold foI.
  simpl.
*)
Abort. *)

(*TRASH
Module Type exVS (X: Terms.terms_mod).
Check X.FuncSymb.
Print X.FSV.
End exVS.

Module example2 : exVS example1.

Check example1.FuncSymb.
Print Fo.

(*Check newt.PR.*)

End example2.

Module example2_1 : exVS.
Module X := example1.
Import X.
End example2_1.

Module Type newt (v:PredicateCalculus.VS).

*)