(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

 *)

Require Export cequiv.
Require Export csubst2.

Definition pv_olift {o} (R : NTrel) (x y : @NTerm o) vs : [univ] :=
  forall sub: Sub,
    prog_sub sub
    -> dom_sub sub = vs
    -> R (lsubst x sub) (lsubst y sub).

Definition sub_find_def {o} (sub : @Sub o) v d : NTerm :=
  match sub_find sub v with
    | Some t => t
    | None => d
  end.

Fixpoint sub_select {o} (sub : @Sub o) (vars : list NVar) (d : NTerm) : Sub :=
  match vars with
    | nil => nil
    | v :: vs => (v,sub_find_def sub v d) :: sub_select sub vs d
  end.

Lemma dom_sub_sub_select {o} :
  forall (s : @Sub o) d vs,
    dom_sub (sub_select s vs d) = vs.
Proof.
  induction vs; introv; allsimpl; tcsp.
  rw IHvs; auto.
Qed.

Definition eq_option {o} (op1 op2 : option (@NTerm o)) :=
  match op1, op2 with
    | Some t1, Some t2 => t1 = t2
    | None, None => True
    | _,_ => False
  end.

Definition ext_eq_subs {o} vs (sub1 sub2 : @Sub o) :=
  forall v,
    LIn v vs
    -> eq_option (sub_find sub1 v) (sub_find sub2 v).

Lemma eq_lsubst_aux_if_ext_eq {o} :
  forall (t : @NTerm o) sub1 sub2,
    ext_eq_subs (free_vars t) sub1 sub2
    -> disjoint (bound_vars t) (sub_free_vars sub1)
    -> disjoint (bound_vars t) (sub_free_vars sub2)
    -> lsubst_aux t sub1 = lsubst_aux t sub2.
Proof.
  nterm_ind1s t as [v|f|op bs ind] Case; introv ext d1 d2; allsimpl; auto.

  - Case "vterm".
    pose proof (ext v) as h.
    remember (sub_find sub1 v) as sf1; symmetry in Heqsf1; destruct sf1;
    remember (sub_find sub2 v) as sf2; symmetry in Heqsf2; destruct sf2;
    allsimpl; tcsp.

  - Case "oterm".
    f_equal.
    apply eq_maps; introv i.
    destruct x as [l t].
    allsimpl.
    f_equal.

    pose proof (ind t t l i) as h; clear ind.
    autodimp h hyp; eauto 3 with slow.
    apply h.

    + introv j.
      allrw @sub_find_sub_filter_eq.
      destruct (in_deq _ deq_nvar v l) as [d|d]; boolvar; tcsp; GC.
      apply ext.
      rw lin_flat_map.
      eexists; dands; eauto.
      simpl.
      rw in_remove_nvars; sp.

    + introv j k.
      pose proof (d1 t0) as q.
      autodimp q hyp.
      { rw lin_flat_map.
        eexists; dands; eauto.
        simpl.
        rw in_app_iff; sp. }
      apply subset_sub_free_vars_sub_filter in k; sp.

    + introv j k.
      pose proof (d2 t0) as q.
      autodimp q hyp.
      { rw lin_flat_map.
        eexists; dands; eauto.
        simpl.
        rw in_app_iff; sp. }
      apply subset_sub_free_vars_sub_filter in k; sp.
Qed.

Lemma cl_eq_lsubst_if_ext_eq {o} :
  forall (t : @NTerm o) sub1 sub2,
    cl_sub sub1
    -> cl_sub sub2
    -> ext_eq_subs (free_vars t) sub1 sub2
    -> lsubst t sub1 = lsubst t sub2.
Proof.
  introv cl1 cl2 ext.
  repeat unflsubst.
  apply eq_lsubst_aux_if_ext_eq; eauto 3 with slow;
  rw @sub_free_vars_if_cl_sub; auto.
Qed.

Lemma implies_closed_sub_find_def {o} :
  forall (s : @Sub o) v d,
    closed d
    -> cl_sub s
    -> closed (sub_find_def s v d).
Proof.
  introv ispd isps.
  unfold sub_find_def.
  remember (sub_find s v) as sf; destruct sf; symmetry in Heqsf; auto.
  apply sub_find_some in Heqsf.
  rw @cl_sub_eq in isps.
  apply in_sub_eta in Heqsf; repnd.
  apply isps in Heqsf; eauto 3 with slow.
Qed.
Hint Resolve implies_closed_sub_find_def : slow.

Lemma prog_sub_sub_keep {o} :
  forall (s : @Sub o) vs, prog_sub s -> prog_sub (sub_keep s vs).
Proof.
  induction s; introv ps; allsimpl; auto.
  destruct a; boolvar; allsimpl; auto;
  allrw @prog_sub_cons; repnd; dands; eauto 3 with slow.
Qed.
Hint Resolve prog_sub_sub_keep : slow.

Lemma in_dom_sub_sub_keep_implies {o} :
  forall (sub : @Sub o) vs v,
    LIn v (dom_sub (sub_keep sub vs))
    <=> (LIn v vs # LIn v (dom_sub sub)).
Proof.
  induction sub; split; introv i; repnd; allsimpl; tcsp.
  - boolvar; allsimpl; repndors; subst; tcsp; apply IHsub in i; sp.
  - boolvar; allsimpl; repndors; subst; tcsp.
    + right; apply IHsub; sp.
    + apply IHsub; sp.
Qed.

Lemma implies_isprog_sub_find_def {o} :
  forall (s : @Sub o) v d,
    isprog d
    -> prog_sub s
    -> isprog (sub_find_def s v d).
Proof.
  introv ispd isps.
  unfold sub_find_def.
  remember (sub_find s v) as sf; destruct sf; symmetry in Heqsf; auto.
  apply sub_find_some in Heqsf.
  rw <- @prog_sub_eq in isps.
  apply in_sub_eta in Heqsf; repnd.
  apply isps in Heqsf; eauto 3 with slow.
Qed.
Hint Resolve implies_isprog_sub_find_def : slow.

Lemma prog_sub_sub_select {o} :
  forall (s : @Sub o) d vs,
    isprog d
    -> prog_sub s
    -> prog_sub (sub_select s vs d).
Proof.
  induction vs; introv pd ps; allsimpl; eauto 3 with slow.
  apply prog_sub_cons; dands; auto.
  destruct a; boolvar; allsimpl; auto;
  allrw @prog_sub_cons; repnd; dands; eauto 3 with slow.
Qed.
Hint Resolve prog_sub_sub_select : slow.

Lemma sub_find_sub_select {o} :
  forall (s : @Sub o) vs d v,
    sub_find (sub_select s vs d) v
    = if memvar v vs
      then Some (sub_find_def s v d)
      else None.
Proof.
  induction vs; introv; simpl; auto.
  allrw memvar_cons; boolvar; tcsp.
  - rw IHvs; boolvar; tcsp.
  - rw IHvs; boolvar; tcsp.
Qed.

Lemma cl_sub_sub_select {o} :
  forall (s : @Sub o) d vs,
    closed d
    -> cl_sub s
    -> cl_sub (sub_select s vs d).
Proof.
  induction vs; introv pd ps; allsimpl; eauto 3 with slow.
  apply cl_sub_cons; dands; auto.
  destruct a; boolvar; allsimpl; auto;
  allrw @cl_sub_cons; repnd; dands; eauto 3 with slow.
Qed.
Hint Resolve cl_sub_sub_select : slow.

Lemma cl_lsubst_trim_select {o} :
  forall t (sub : @Sub o) lv d,
    cl_sub sub
    -> closed d
    -> (forall v, LIn v (free_vars t) -> (LIn v lv <=> LIn v (dom_sub sub)))
    -> lsubst t sub = lsubst t (sub_select sub lv d).
Proof.
  introv cls cld sv.
  apply cl_eq_lsubst_if_ext_eq; eauto 3 with slow.
  introv i.
  applydup sv in i.
  rw @sub_find_sub_select.
  unfold sub_find_def.
  boolvar.
  - applydup i0 in Heqb.
    apply in_dom_sub_exists in Heqb0; exrepnd.
    rw Heqb1; simpl; auto.
  - rw @sub_find_none_if; simpl; auto.
    intro h.
    apply i0 in h; sp.
Qed.

Lemma isvalue_like_lam {o} :
  forall v (t : @NTerm o), isvalue_like (mk_lam v t).
Proof.
  introv.
  unfold isvalue_like; simpl; tcsp.
Qed.
Hint Resolve isvalue_like_lam : slow.

Lemma cl_olift_iff_pv_olift {o} :
  forall R (x y : @NTerm o) vs,
    isprog_vars vs x
    -> isprog_vars vs y
    -> (pv_olift R x y vs <=> cl_olift R x y).
Proof.
  introv ispx ispy.
  unfold pv_olift, cl_olift.
  split; intro h; repnd; dands; eauto 3 with slow.

  - introv ps isp1 isp2.
    applydup @lsubst_program_implies in isp1.
    applydup @lsubst_program_implies in isp2.
    applydup @isprog_vars_eq in ispx; repnd.
    applydup @isprog_vars_eq in ispy; repnd.
    allrw @subvars_eq.

    pose proof (h (sub_select sub vs mk_axiom)) as q; clear h.
    rw @dom_sub_sub_select in q.
    repeat (autodimp q hyp); eauto 2 with slow.

    rw <- @cl_lsubst_trim_select in q; eauto 2 with slow;
    [|introv i;applydup isp0 in i;apply ispx1 in i; sp].

    rw <- @cl_lsubst_trim_select in q; eauto 2 with slow.
    introv i;applydup isp3 in i;apply ispy1 in i; sp.

  - introv ps e.
    apply h; auto.

    + apply isprogram_lsubst_if_isprog_sub; eauto 2 with slow.
      introv i.
      apply isprog_vars_eq in ispx; repnd.
      allrw subvars_eq.
      apply ispx0 in i; subst; sp.

    + apply isprogram_lsubst_if_isprog_sub; eauto 2 with slow.
      introv i.
      apply isprog_vars_eq in ispy; repnd.
      allrw subvars_eq.
      apply ispy0 in i; subst; sp.
Qed.

Lemma implies_approxc_lam {o} :
  forall lib v (t1 t2 : @CVTerm o [v]),
    (forall u : CTerm, cequivc lib (substc u v t1) (substc u v t2))
    -> approxc lib (mkc_lam v t1) (mkc_lam v t2).
Proof.
  introv imp.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  allunfold @approxc; allsimpl.

  constructor.
  unfold close_comput; dands;
  try (apply isprogram_lam);
  eauto 3 with slow.

  + introv comp.
    apply computes_to_value_isvalue_eq in comp;
      try (apply isvalue_mk_lam); eauto 3 with slow.
    unfold mk_lam in comp; ginv; fold_terms.
    exists [bterm [v] x]; fold_terms.
    dands.
    { apply computes_to_value_isvalue_refl;
      try (apply isvalue_mk_lam); eauto 3 with slow. }

    unfold lblift; simpl; dands; auto.
    introv ltn.
    destruct n; try omega; clear ltn.
    unfold selectbt; simpl.
    unfold blift.
    exists [v] x0 x; dands; eauto 3 with slow.
    apply clearbots_olift.
    apply cl_olift_implies_olift; eauto 3 with slow.

    pose proof (cl_olift_iff_pv_olift (approx lib) x0 x [v]) as xx.
    repeat (autodimp xx hyp).
    apply xx; clear xx.
    introv ps e.
    destruct sub as [|p s]; allsimpl; ginv.
    destruct s; ginv.
    destruct p as [z u]; allsimpl.
    allrw @fold_subst.
    allrw @prog_sub_cons; repnd.
    pose proof (imp (mk_cterm u ps0)) as h; clear imp; allsimpl.
    destruct h; sp.

  + introv comp.
    apply can_doesnt_raise_an_exception in comp; sp.

  + introv comp.
    apply reduces_to_if_isvalue_like in comp; ginv; eauto 3 with slow.
Qed.

Lemma cequivc_iff_approxc {o} :
  forall lib (a b : @CTerm o),
    cequivc lib a b <=> (approxc lib a b # approxc lib b a).
Proof.
  introv; destruct_cterms; unfold cequivc, approxc; simpl; sp.
Qed.

Lemma implies_cequivc_lam {o} :
  forall lib v (t1 t2 : @CVTerm o [v]),
    (forall u : CTerm, cequivc lib (substc u v t1) (substc u v t2))
    -> cequivc lib (mkc_lam v t1) (mkc_lam v t2).
Proof.
  introv imp.
  apply cequivc_iff_approxc; dands.
  - apply implies_approxc_lam; auto.
  - apply implies_approxc_lam; auto.
    introv.
    apply cequivc_sym; auto.
Qed.

Lemma implies_approx_lam2 {o} :
  forall lib v1 v2 (t1 t2 : @NTerm o),
    isprog_vars [v1] t1
    -> isprog_vars [v2] t2
    -> (forall u : NTerm, isprog u -> cequiv lib (subst t1 v1 u) (subst t2 v2 u))
    -> approx lib (mk_lam v1 t1) (mk_lam v2 t2).
Proof.
  introv isp1 isp2 imp.

  constructor.
  unfold close_comput; dands;
  try (apply isprogram_lam);
  eauto 3 with slow.

  - introv comp.
    apply computes_to_value_isvalue_eq in comp;
      try (apply isvalue_mk_lam); eauto 3 with slow.
    unfold mk_lam in comp; ginv; fold_terms.
    exists [bterm [v2] t2]; fold_terms.
    dands.
    { apply computes_to_value_isvalue_refl;
      try (apply isvalue_mk_lam); eauto 3 with slow. }

    unfold lblift; simpl; dands; auto.
    introv ltn.
    destruct n; try omega; clear ltn.
    unfold selectbt; simpl.
    unfold blift.
    exists [v1] t1 (subst t2 v2 (mk_var v1)); dands; eauto 3 with slow.

    + apply clearbots_olift.
      apply cl_olift_implies_olift; eauto 3 with slow.

      pose proof (cl_olift_iff_pv_olift (approx lib) t1 (subst t2 v2 (mk_var v1)) [v1]) as xx.
      repeat (autodimp xx hyp).
      { clear imp; allrw @isprog_vars_eq; repnd; dands.
        - eapply subvars_eqvars;
          [|apply eqvars_sym;apply eqvars_free_vars_disjoint].
          simpl.
          rw subvars_app_l; dands.
          + apply subvars_remove_nvars; simpl.
            eapply subvars_trans;eauto.
            rw subvars_prop; simpl; tcsp.
          + boolvar; simpl; eauto 3 with slow.
        - apply nt_wf_subst; eauto 3 with slow. }
      apply xx; clear xx.
      introv ps e.
      destruct sub as [|p s]; allsimpl; ginv.
      destruct s; ginv.
      destruct p as [z u]; allsimpl.
      allrw @fold_subst.
      allrw @prog_sub_cons; repnd.
      pose proof (imp u) as h; clear imp; allsimpl.
      autodimp h hyp; eauto 3 with slow.
      destruct h; sp.
      eapply approx_trans; eauto.

      eapply approx_alpha_rw_r_aux;
        [apply alpha_eq_sym;apply combine_sub_nest|].
      simpl.
      allrw @fold_subst.
      rw @subst_mk_var1.

      destruct (deq_nvar v2 z); subst.

      * pose proof (cl_lsubst_app_sub_filter t2 [(z,u)] [(z,u)]) as h; allsimpl.
        autodimp h hyp; eauto 3 with slow.
        allrw memvar_singleton; boolvar; rw h; eauto 3 with slow.

      * pose proof (lsubst_sub_filter_alpha t2 [(v2, u), (z, u)] [z]) as h.
        allrw disjoint_singleton_r; allsimpl.
        allrw memvar_singleton; boolvar; tcsp.
        autodimp h hyp.
        { allrw @isprog_vars_eq; repnd.
          allrw subvars_eq.
          introv h; apply isp3 in h; allsimpl; tcsp. }

        eapply approx_alpha_rw_r_aux;[exact h|].
        allrw @fold_subst; eauto 3 with slow.

    + pose proof (alpha_eq_bterm_single_change t2 v2) as h.
      allrw subset_singleton_r.
      autodimp h hyp.
      { introv ix.
        clear imp.
        allrw @isprog_vars_eq; repnd.
        allrw subvars_eq.
        apply isp3 in ix; allsimpl; tcsp. }
      apply h.

  - introv comp.
    apply can_doesnt_raise_an_exception in comp; sp.

  - introv comp.
    apply reduces_to_if_isvalue_like in comp; ginv; eauto 3 with slow.
Qed.

Lemma implies_approxc_lam2 {o} :
  forall lib v1 v2 (t1 : @CVTerm o [v1]) t2,
    (forall u : CTerm, cequivc lib (substc u v1 t1) (substc u v2 t2))
    -> approxc lib (mkc_lam v1 t1) (mkc_lam v2 t2).
Proof.
  introv imp.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  allunfold @approxc; allsimpl.

  apply implies_approx_lam2; auto.
  introv isp.
  apply isprogram_eq in isp.
  pose proof (imp (mk_cterm u isp)) as k; allsimpl; auto.
Qed.

Lemma implies_cequivc_lam2 {o} :
  forall lib v1 v2 (t1 : @CVTerm o [v1]) t2,
    (forall u : CTerm, cequivc lib (substc u v1 t1) (substc u v2 t2))
    -> cequivc lib (mkc_lam v1 t1) (mkc_lam v2 t2).
Proof.
  introv imp.
  apply cequivc_iff_approxc; dands.
  - apply implies_approxc_lam2; auto.
  - apply implies_approxc_lam2; auto.
    introv.
    apply cequivc_sym; auto.
Qed.

Lemma nt_wf_lambda_iff {p} :
  forall (bs : list (@BTerm p)),
    nt_wf (oterm (Can NLambda) bs)
    <=> {v : NVar
        $ {b : NTerm
        $ bs = [bterm [v] b]
        # nt_wf b}}.
Proof.
  introv; split; intro k.
  - inversion k as [|?|? ? imp e]; clear k; subst.
    allsimpl.
    repeat (destruct bs; allsimpl; ginv).
    destruct b as [l1 t1].
    allunfold @num_bvars; allsimpl.
    repeat (destruct l1; ginv).
    pose proof (imp (bterm [n] t1)) as h1.
    autodimp h1 hyp.
    clear imp.
    allrw @bt_wf_iff.
    exists n t1; dands; auto.
  - exrepnd; subst.
    repeat constructor.
    introv i; allsimpl; repndors; subst; tcsp.
Qed.


              Require Import List.
From Utils    Require Import Defns.
From CompCert Require Import Coqlib Maps Lattice Kildall Errors.
From PIPE     Require Import TagDomain.
From RTLT     Require Import Language Semantics.
Import ListNotations.

Create HintDb csedomDB.

(* Adapted from CompCert's CSEdomain.v *)

Module Functor (Import Tags  : TagDomain.MiddleEnd)
               (Import Rules : RTLT.Policy.Sig Tags)
               (Import Lang  : RTLT.Language.Sig Tags)
               (Import Sem   : RTLT.Semantics.Sig Tags Rules Lang).

Definition valnum := positive.

Inductive rhs : Type :=
  | Op: bool (* -> bool -> PCTag *) -> operation -> valnum -> valnum -> rhs.

Inductive equation : Type :=
  | Eq (v: valnum) (r: rhs).

Definition eq_valnum: forall (x y: valnum), {x=y}+{x<>y} := peq.

Definition eq_list_valnum: forall (x y: list valnum), {x=y}+{x<>y} := list_eq_dec peq.

Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
Proof.
  assert (forall o1 o2:operation, {o1 = o2} + {o1 <> o2}) by
    (intros [] []; auto; right; inversion 1).
  generalize bool_dec eq_valnum eq_list_valnum (* pt_eq_dec *).
  decide equality.
Defined.

Record numbering : Type := mknumbering {
  num_next: valnum; (**r first unused value number *)
  num_eqs: list equation; (**r valid equations *)
  num_reg: PTree.t valnum; (**r mapping register to valnum *)
  num_val: PMap.t (list reg) (**r reverse mapping valnum to regs containing it *)
}.

Definition empty_numbering :=
  {| num_next := 1%positive;
     num_eqs := nil;
     num_reg := PTree.empty _;
     num_val := PMap.init nil |}.

Definition valnums_rhs (r: rhs): list valnum :=
  match r with
  | Op b op v1 v2 => [v1;v2]
  end.

Definition wf_rhs (next: valnum) (r: rhs) : Prop :=
forall v, In v (valnums_rhs r) -> Plt v next.

Definition wf_equation (next: valnum) (e: equation) : Prop :=
  match e with Eq l r => Plt l next /\ wf_rhs next r end.

Record wf_numbering (n: numbering) : Prop := {
  wf_num_eqs: forall e,
      In e n.(num_eqs) -> wf_equation n.(num_next) e;
  wf_num_reg: forall r v,
      PTree.get r n.(num_reg) = Some v -> Plt v n.(num_next);
  wf_num_val: forall r v,
      In r (PMap.get v n.(num_val)) -> PTree.get r n.(num_reg) = Some v
}.

Hint Resolve wf_num_eqs wf_num_reg wf_num_val: csedomDB.

Definition valuation := valnum -> atom.
(* Definition valuation := valnum -> val. *)

Inductive rhs_eval_to (valu: valuation) : rhs -> atom -> Prop :=
  | op_eval_to: forall b (* pcp wpci *) op v t vn1 vn2 p a t1 t2 p' v1 v2 itag,
      (valu vn1) = (v1,t1) ->
      (valu vn2) = (v2,t2) ->
      IopTR itag p op t1 t2 = ret (p', t) ->
      eval_op op v1 v2 = v ->
      a = (v,t) ->
      rhs_eval_to valu (Op b op vn1 vn2) a.

Inductive equation_holds (valu: valuation) : equation -> Prop :=
  | eq_holds: forall l r,
      rhs_eval_to valu r (valu l) ->
      equation_holds valu (Eq l r).

Record numbering_holds (valu: valuation)
                       (rs: regbank) (n: numbering) : Prop := {
  num_holds_wf:
     wf_numbering n;
  num_holds_eq: forall eq,
     In eq n.(num_eqs) -> equation_holds valu eq;
  num_holds_reg: forall r v,
     n.(num_reg)!r = Some v -> rs#r = valu v
}.

Hint Resolve num_holds_wf num_holds_eq num_holds_reg: csedomDB.

Lemma empty_numbering_holds:
  forall valu rs,
  numbering_holds valu rs empty_numbering.
Proof.
  intros; split; simpl; intros.
  - split; simpl; intros.
    + contradiction.
    + rewrite PTree.gempty in H; discriminate.
    + rewrite PMap.gi in H; contradiction.
  - contradiction.
  - rewrite PTree.gempty in H; discriminate.
Qed.

Module Numbering.
  Definition t := numbering.
  Definition ge (n1 n2: numbering) : Prop :=
    forall valu rs,
    numbering_holds valu rs n2 ->
    numbering_holds valu rs n1.
  Definition top := empty_numbering.
  Lemma top_ge: forall x, ge top x.
Proof.
  intros; red; intros. unfold top.
  apply empty_numbering_holds.
Qed.

Lemma refl_ge: forall x, ge x x.
Proof.
  intros; red; auto.
Qed.
End Numbering.

Module Solver := BBlock_solver(Numbering).

End Functor.


(** * Well-founded relation on [reachable] *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Relations.Relation_Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.All.Reachable.
Require Import Fiat.Parsers.BaseTypes.

Section rel.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}.

  Section size.
    Context {ch : Char} {valid : nonterminals_listT}.
    Definition size_of_reachable_from_item'
               (size_of_reachable_from_productions : forall {pats}, reachable_from_productions G ch valid pats -> nat)
               {it} (p : reachable_from_item G ch valid it) : nat
      := match p with
           | ReachableTerminal _ _ => 0
           | ReachableNonTerminal _ _ p' => S (size_of_reachable_from_productions p')
         end.

    Fixpoint size_of_reachable_from_productions {pats} (p : reachable_from_productions G ch valid pats) : nat
      := match p with
           | ReachableHead _ _ p' => S (size_of_reachable_from_production p')
           | ReachableTail _ _ p' => S (size_of_reachable_from_productions p')
         end
    with size_of_reachable_from_production {pat} (p : reachable_from_production G ch valid pat) : nat
         := match p with
              | ReachableProductionHead _ _ p' => S (size_of_reachable_from_item' (@size_of_reachable_from_productions) p')
              | ReachableProductionTail _ _ p' => S (size_of_reachable_from_production p')
            end.

    Definition size_of_reachable_from_item
               {it} (p : reachable_from_item G ch valid it) : nat
      := @size_of_reachable_from_item' (@size_of_reachable_from_productions) it p.
  End size.
End rel.


Require Import Source.
Require Import Target.

(* _____________________________________
               DEFINITIONS
   _____________________________________ *)

Definition shape : Type :=
  (program_interfaces * list (option component_id)).

Definition get_interfacesS (s:shape) : program_interfaces :=
  match s with
  | (Is, _) => Is
  end.

Definition get_component_idS (s:shape) :
  list (option component_id) :=
  match s with
  | (_, comps_id) => comps_id
  end.

(* _____________________________________
             SOURCE LANGUAGE
   _____________________________________ *)

(* ------- Well-formedness ------- *)
Inductive wellformed_shape : shape -> Prop :=
  | WF_shape : forall s,
    let Is := get_interfacesS s in
    let comps_id := get_component_idS s in
    wellformed_interfaces Is ->
    incl comps_id (dom2partial (dom_interfaces Is)) ->
    wellformed_shape s.

(* ------- Has shape ------- *)
Reserved Notation "'PROGRAM_SHAPE' P ∈• s" (at level 40).
Inductive program_has_shape :
  Source.partial_program -> shape -> Prop :=
  | SH_program : forall P Is comps_id,
    wellformed_partial_program_alt Is P ->
    (compsPartialProgram P = comps_id) ->
    PROGRAM_SHAPE P ∈• (Is, comps_id)
  where "'PROGRAM_SHAPE' P ∈• s" := (program_has_shape P s).

Reserved Notation "'CONTEXT_SHAPE' P ∈∘ s" (at level 40).
Inductive context_has_shape :
  Source.partial_program -> shape -> Prop :=
  | SH_context : forall P Is comps_id,
    let f C x :=
      match C with
      | Some C' =>
        match x with
        | Some x' => C' =? x'
        | None => false
        end
      | None => false
      end
    in
    let not_in_compsId :=
      fun (C:option component_id) =>
        negb (existsb (f C) comps_id)
    in
    wellformed_partial_program_alt Is P ->
    dom_partial_program P =
      (filter not_in_compsId (dom2partial (compsInterface Is))) ->
    CONTEXT_SHAPE P ∈∘ (Is, comps_id)
  where "'CONTEXT_SHAPE' P ∈∘ s" := (context_has_shape P s).

(* ------- Context application ------- *)
Definition unify_option {X:Type} (default:X)
  (K : option X * option X) : X :=
  match K with
  | (Some k1', None) => k1'
  | (None, Some k2') => k2'
  | _ => default
  end.

Definition context_application (A P : Source.partial_program) :
  Source.program :=
  map (unify_option (0,0,[],0,0,[])) (combine A P).

(* _____________________________________
                  PROOFS
   _____________________________________ *)

Theorem context_application_preserves_wellformedness :
  forall A P s,
  (wellformed_shape s) /\
  (CONTEXT_SHAPE A ∈∘ s) /\ (PROGRAM_SHAPE P ∈• s) ->
  wellformed_whole_program (context_application A P).
Proof.
Admitted.

(* _____________________________________
             TARGET LANGUAGE
   _____________________________________ *)

(* ------- Has shape ------- *)

Reserved Notation "'LL_PROGRAM_SHAPE' P ∈• s" (at level 40).
Inductive ll_program_has_shape :
  Target.program -> shape -> Prop :=
  | SH_LLprogram : forall Is_p mem E Is comps_id,
    (forall i, (In (Some i) Is_p) ->
      ((nth (get_name i) Is (0,0,[])) = i)) ->
    (dom_entry_points E = dom_global_memory mem) ->
    (dom_global_memory mem =
      (compsPartialInterface Is_p)) ->
    (compsPartialInterface Is_p) = comps_id ->
    LL_PROGRAM_SHAPE (Is_p, mem, E) ∈• (Is, comps_id)
  where "'LL_PROGRAM_SHAPE' P ∈• s" :=
  (ll_program_has_shape P s).

Reserved Notation "'LL_CONTEXT_SHAPE' A ∈∘ s" (at level 40).
Inductive ll_context_has_shape :
  Target.program -> shape -> Prop :=
  | SH_LLcontext : forall Is_a mem E Is comps_id,
    let f C x :=
      match C with
      | Some C' =>
        match x with
        | Some x' => C' =? x'
        | None => false
        end
      | None => false
      end
    in
    let not_in_compsid :=
      fun (C:option component_id) =>
        negb (existsb (f C) comps_id)
    in
    (forall i, (In (Some i) Is_a) ->
      ((nth (get_name i) Is (0,0,[])) = i)) ->
    (dom_entry_points E = dom_global_memory mem) ->
    (dom_global_memory mem = compsPartialInterface Is_a) ->
    (compsPartialInterface Is_a =
      filter not_in_compsid
      (dom2partial (compsInterface Is))) ->
    LL_CONTEXT_SHAPE (Is_a, mem, E) ∈∘ (Is, comps_id)
  where "'LL_CONTEXT_SHAPE' A ∈∘ s" :=
  (ll_context_has_shape A s).

(* ------- Context application ------- *)

Definition normalize_Is (Is:program_interfaces) :
  partial_program_interfaces := map (fun x => Some x) Is.

Definition normalize_mem (mem:list (list nat)) :
  global_memory := map (fun x => Some x) mem.

Definition normalize_E (E:list (list nat)) :
  global_memory := map (fun x => Some x) E.

Definition LL_context_application (A P:Target.program) :
  Target.program :=
  match A with
  | (Is_a, mem_a, E_a) =>
    match P with
    | (Is_p, mem_p, E_p) =>
      let combineIs := combine Is_a Is_p in
      let combineMem := combine mem_a mem_p in
      let combineE := combine E_a E_p in
      let mapIs := map (unify_option (0,0,[])) combineIs in
      let mapMem := map (unify_option []) combineMem in
      let mapE := map (unify_option []) combineE in
      (normalize_Is mapIs,
       normalize_mem mapMem,
       normalize_E mapE)
    end
  end.

(* _____________________________________
            FULL DEFINEDNESS
   _____________________________________ *)

Inductive program_fully_defined
  (sh:shape) : partial_program -> Prop :=
  | FD_program : forall P (PC:Source.program) C s d K e,
    (PROGRAM_SHAPE P ∈• sh) ->
  ~(exists A, (CONTEXT_SHAPE A ∈∘ sh) ->
    let PC := (context_application A P) in
    (procbodies PC) ⊢ (initial_cfg_of PC) ⇒* (C,s,d,K,e) ->
    undefined_cfg (procbodies PC) (C,s,d,K,e) ->
    In (Some C) (compsPartialProgram P)) ->
    program_fully_defined sh P.

Inductive context_fully_defined
  (sh:shape) : partial_program -> Prop :=
  | FD_context : forall A (PC:Source.program) C s d K e,
    (CONTEXT_SHAPE A ∈∘ sh) ->
  ~(exists P, (PROGRAM_SHAPE P ∈• sh) ->
    let PC := (context_application A P) in
    (procbodies PC) ⊢ (initial_cfg_of PC) ⇒* (C,s,d,K,e) ->
    undefined_cfg (procbodies PC) (C,s,d,K,e) ->
    In (Some C) (compsPartialProgram A)) ->
    context_fully_defined sh A.

(* _____________________________________
             SANITY CHECKING
   _____________________________________ *)

Example sanity_check1 :
  forall s,
  forall P, PROGRAM_SHAPE P ∈• s ->
  forall A, CONTEXT_SHAPE A ∈∘ s ->
  context_fully_defined s A ->
  program_fully_defined s P ->
  program_defined (context_application A P).
Proof.
  intros s P HP A HA H1 H2.
  unfold program_defined. unfold not.
  intro contra.
  inversion contra.
Admitted.


From stdpp Require Import nat_cancel.
From iris.proofmode Require Import modality_instances classes.
From iris.prelude Require Import options.
Import bi.

Section class_instances_internal_eq.
Context `{!BiInternalEq PROP}.
Implicit Types P Q R : PROP.

Global Instance from_pure_internal_eq {A : ofe} (a b : A) :
  @FromPure PROP false (a ≡ b) (a ≡ b).
Proof. by rewrite /FromPure pure_internal_eq. Qed.

Global Instance into_pure_eq {A : ofe} (a b : A) :
  Discrete a → @IntoPure PROP (a ≡ b) (a ≡ b).
Proof. intros. by rewrite /IntoPure discrete_eq. Qed.

Global Instance from_modal_Next {A : ofe} (x y : A) :
  FromModal (PROP1:=PROP) (PROP2:=PROP) True (modality_laterN 1)
    (▷^1 (x ≡ y) : PROP)%I (Next x ≡ Next y) (x ≡ y).
Proof. by rewrite /FromModal /= later_equivI. Qed.

Global Instance into_laterN_Next {A : ofe} only_head n n' (x y : A) :
  NatCancel n 1 n' 0 →
  IntoLaterN (PROP:=PROP) only_head n (Next x ≡ Next y) (x ≡ y) | 2.
Proof.
  rewrite /IntoLaterN /MaybeIntoLaterN /NatCancel Nat.add_0_r.
  move=> <-. rewrite later_equivI. by rewrite Nat.add_comm /= -laterN_intro.
Qed.

Global Instance into_internal_eq_internal_eq {A : ofe} (x y : A) :
  @IntoInternalEq PROP _ A (x ≡ y) x y.
Proof. by rewrite /IntoInternalEq. Qed.
Global Instance into_internal_eq_affinely {A : ofe} (x y : A) P :
  IntoInternalEq P x y → IntoInternalEq (<affine> P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite affinely_elim. Qed.
Global Instance into_internal_eq_intuitionistically {A : ofe} (x y : A) P :
  IntoInternalEq P x y → IntoInternalEq (□ P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite intuitionistically_elim. Qed.
Global Instance into_internal_eq_absorbingly {A : ofe} (x y : A) P :
  IntoInternalEq P x y → IntoInternalEq (<absorb> P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite absorbingly_internal_eq. Qed.
Global Instance into_internal_eq_plainly `{!BiPlainly PROP} {A : ofe} (x y : A) P :
  IntoInternalEq P x y → IntoInternalEq (■ P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite plainly_elim. Qed.
Global Instance into_internal_eq_persistently {A : ofe} (x y : A) P :
  IntoInternalEq P x y → IntoInternalEq (<pers> P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite persistently_elim. Qed.
End class_instances_internal_eq.


(* 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                                                     *)

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Category Theory : Yoneda's Functor                               *)
(*                                                                           *)
(*          Amokrane Saibi May 1994                                          *)
(*                                                                           *)
(*****************************************************************************)

Require Export HomFunctor_NT.
Require Export CatFunct.
Require Export Functor_dup1.

Set Implicit Arguments.
Unset Strict Implicit.

(* Fonctor Y:C^o-->[C==>SET] *)

Section yoneda_functor.

Variable C : Category.

 Section funy_map_def.

 Variable a b : C.

 Lemma FunY_map_law : Map_law0'' (NtH (C:=C) (b:=a) (a:=b)).
 Proof.
 unfold Map_law0'', NtH in |- *; simpl in |- *.
 unfold Equal_NT in |- *; simpl in |- *.
 unfold Ext in |- *; simpl in |- *.
 unfold NtH_arrow in |- *; simpl in |- *.
 unfold FunSET_ob in |- *; intros.
 apply Comp_r; assumption.
 Qed.

 Canonical Structure FunY_map := Build_Map0'' FunY_map_law.

 End funy_map_def.

Lemma FunY_comp_law : Fcomp_law0'' (C:=Dual C) FunY_map.
Proof.
unfold Fcomp_law0'' in |- *; simpl in |- *.
unfold Equal_NT in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *.
unfold NtH_arrow in |- *; simpl in |- *.
unfold FunSET_ob, DHom in |- *.
intros a b c f g d h; apply Sym.
exact (Prf_ass g f h).
Qed.

Lemma FunY_id_law : Fid_law0'' (C:=Dual C) FunY_map.
Proof.
unfold Fid_law0'' in |- *; simpl in |- *.
unfold Equal_NT in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *.
unfold NtH_arrow in |- *; simpl in |- *.
unfold FunSET_ob in |- *.
unfold Id_fun in |- *; simpl in |- *.
intros a b f; unfold Comp in |- *; apply (Prf_idl (c:=C)).
Qed.

Canonical Structure FunY := Build_Functor0'' FunY_comp_law FunY_id_law.

(* lemma : Y is full *)

Lemma Y_full :
 let f := fun (a b : C) (h : NT (FunSET a) (FunSET b)) => h a (Id a) in
 Full_law0'' (F:=FunY) f.
Proof.
unfold Full_law0'' in |- *; simpl in |- *; intros a b h.
unfold Equal_NT in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *.
unfold NtH_arrow in |- *.
unfold FunSET_ob in |- *.
intros c f; simpl in |- *.
(* *) apply Trans with (h c (Id a o f)).
apply Pres1.
apply Sym; unfold Comp in |- *; simpl in |- *; unfold FunSET_ob in |- *;
 apply (Prf_idl (c:=C)).
apply (Prf_NT_law h f (Id a)).
Qed.

(* Y is faithful *)

Lemma Y_faithful : Faithful_law0'' FunY.
Proof.
unfold Faithful_law0'' in |- *; simpl in |- *.
unfold Equal_NT in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; unfold DHom in |- *.
unfold NtH_arrow in |- *.
unfold FunSET_ob in |- *.
intros a b f g H.
(* *) apply Trans with (g o Id a).
(* *) apply Trans with (f o Id a).
apply Idr.
apply H.
apply Idr1.
Qed.

End yoneda_functor.


(* USIG instance *)

Require Export ComponentSM3.
Require Export MinBFTprops2.

Section MinBFTass_mon.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma USIG_sm_mon :
    forall r l s1 s2,
      trusted_run_sm_on_inputs s1 (USIG_comp r) l = s2
      -> usig_counter s1 = usig_counter s2
         \/
         usig_counter s1 < usig_counter s2.
  Proof.
    unfold trusted_run_sm_on_inputs in *.
    induction l; introv run; simpl in *; tcsp; subst; tcsp;[].
    destruct a; repnd; simpl; tcsp.
    unfold update_state in *; simpl in *.
    autorewrite with comp in *.
    match goal with
    | [ |- _ \/ usig_counter ?a < usig_counter ?b ] =>
      pose proof (IHl (increment_USIG s1) b) as IHl
    end; repeat (autodimp IHl hyp); simpl in *; repndors; tcsp; try omega.
  Qed.

  Lemma ASSUMPTION_monotonicity_true :
    forall (eo : EventOrdering), assume_eo eo ASSUMPTION_monotonicity.
  Proof.
    repeat introv; apply assume_eo_ASSUMPTION_monotonicity_iff_monotonicity.
    clear e.
    introv.
    unfold no_trusted_generation, generates_trusted.
    unfold id_before, id_after; simpl.
    unfold trusted_state_before, trusted_state_after; simpl.
    unfold M_byz_state_sys_on_event.
    unfold M_byz_state_sys_before_event.

    assert (ex_node_e e) as exe by (destruct e; auto).

    unfold ex_node_e in exe; simpl in *; exrepnd.
    apply node_cond2 in exe0.
    unfold MinBFTsys; rewrite <- exe0.

    pose proof (M_byz_compose_step_trusted e (MinBFTlocalSys n) (incr_n_proc (USIG_comp n))) as h.
    repeat (autodimp h hyp); eauto 3 with comp minbft;[].
    exrepnd; simpl in *.

    unfold TCN, pre2trusted in *; simpl in *.
    unfold preUSIGname in *; simpl in *.
    rewrite h1, h2.

    pose proof (trusted_run_sm_on_inputs_incr_n_proc preUSIGname s1 (USIG_comp n) l) as z; simpl in z.
    repeat (unfold TCN, USIGname, preUSIGname, MkCN, pre2trusted in *; simpl in *); rewrite z in h0; clear z.

    (* TODO: use something else? *)
    assert (usig_counter s1 = usig_counter s2
            \/
            usig_counter s1 < usig_counter s2) as h.
    { eapply USIG_sm_mon; eauto; try congruence. }
    repndors; exrepnd;
      [left; exists (usig_counter s1); dands; eauto
      |right; exists (usig_counter s1) (usig_counter s2); dands; eauto; rewrite interp_towns; auto].
  Qed.
  Hint Resolve ASSUMPTION_monotonicity_true : minbft.

End MinBFTass_mon.

Hint Resolve ASSUMPTION_monotonicity_true : minbft.


From Coq Require Import ZArith.ZArith.

From CertiGraph Require Import lib.List_ext.

From CertiGC Require Import model.heapgraph.block.block.
From CertiGC Require Import model.heapgraph.block.cell.
From CertiGC Require Import model.heapgraph.generation.generation.
From CertiGC Require Import model.heapgraph.graph.

Definition heapgraph_block_fields
  (g : HeapGraph) (v : Addr) :
  list Field := filter_sum_right (heapgraph_block_cells g v).

Lemma heapgraph_block_is_no_scan__no_fields
  (g : HeapGraph) (v : Addr)
  (Hv : heapgraph_block_is_no_scan g v) :
  heapgraph_block_fields g v = nil.
Proof.
  (apply block_tag__no_scan in Hv).
  (unfold heapgraph_block_fields).
  (destruct (filter_sum_right (heapgraph_block_cells g v)) as [| f ff] eqn:E; try easy).
  (destruct Hv).
  (assert (Hf : In f (filter_sum_right (heapgraph_block_cells g v)))).
  {
    (rewrite E).
    now left.
  }
  (rewrite <- filter_sum_right_In_iff in Hf).
  clear ff E.
  (unfold heapgraph_block_cells in Hf).
  (remember (block_fields (heapgraph_block g v)) as xx eqn:Exx ).
  clear Exx.
  (remember O as n eqn:En ).
  clear En.
  revert n Hf.
  (induction xx as [| x xx IHxx]; simpl; intros n Hf; try easy).
  (destruct x as [x| ]; try destruct x as [x| x]; simpl in Hf; try now left).
  all: (destruct Hf as [Hf| Hf]; try easy).
  all: (right; now apply IHxx with (n + 1)%nat).
Qed.

Lemma heapgraph_block_fields_fst : forall g v e, In e (heapgraph_block_fields g v) -> field_addr e = v.
Proof.
  (intros g v e).
  (unfold heapgraph_block_fields, heapgraph_block_cells).
  (remember (block_fields (heapgraph_block g v))).
  (remember O as n).
  clear Heqn Heql.
  revert n.
  (induction l; intros; simpl in *).
  - (exfalso; assumption).
  - (destruct a; [ destruct s |  ]; simpl in *; [  |  | destruct H; [ subst e; simpl; reflexivity |  ] ];
      apply IHl in H; assumption).
Qed.

Lemma heapgraph_block_fields_In :
  forall g v s,
  In {| field_addr := v; field_index := s |} (heapgraph_block_fields g v) <->
  In s (map field_index (heapgraph_block_fields g v)).
Proof.
  (intros).
  (unfold heapgraph_block_fields, heapgraph_block_cells).
  (remember (block_fields (heapgraph_block g v))).
  (remember O as n).
  clear Heqn Heql.
  revert n.
  (induction l; intros; simpl; try easy).
  (destruct a as [a| ]; try destruct a as [a| a]; simpl).
  all: (rewrite IHl; try easy).
  intuition.
  (inversion H0).
  (left; reflexivity).
Qed.

Lemma ang_heapgraph_block_fields :
  forall g gi v, heapgraph_block_fields g v = heapgraph_block_fields (heapgraph_generations_append g gi) v.
Proof.
  (intros).
  (unfold heapgraph_block_fields, heapgraph_block_cells).
  (simpl).
  reflexivity.
Qed.


(** * Definition of the common part of the interface of the CFG parser *)
Require Import Coq.Lists.List Coq.Arith.Wf_nat Coq.Init.Wf Coq.Strings.String.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.

Set Implicit Arguments.

Local Open Scope string_like_scope.

Local Coercion is_true : bool >-> Sortclass.

Section recursive_descent_parser.
  Context {Char} {HSLM : StringLikeMin Char} {G : grammar Char}.

  Class parser_computational_predataT :=
    { nonterminals_listT : Type;
      nonterminal_carrierT : Type;
      of_nonterminal : String.string -> nonterminal_carrierT;
      to_nonterminal : nonterminal_carrierT -> String.string;
      production_carrierT : Type;
      to_production : production_carrierT -> production Char;
      nonterminal_to_production : nonterminal_carrierT -> list production_carrierT;
      production_tl : production_carrierT -> production_carrierT;
      production_carrier_valid : production_carrierT -> bool;
      initial_nonterminals_data : nonterminals_listT;
      nonterminals_length : nonterminals_listT -> nat;
      is_valid_nonterminal : nonterminals_listT -> nonterminal_carrierT -> bool;
      remove_nonterminal : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT }.

  Class parser_removal_dataT' {predata : parser_computational_predataT} :=
    { nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop
      := ltof _ nonterminals_length;
      nonterminals_length_zero : forall ls,
                                   nonterminals_length ls = 0
                                   -> forall nt, is_valid_nonterminal ls nt = false;
      remove_nonterminal_dec : forall ls nonterminal,
                                 is_valid_nonterminal ls nonterminal
                                 -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls;
      remove_nonterminal_noninc : forall ls nonterminal,
                                    ~nonterminals_listT_R ls (remove_nonterminal ls nonterminal);
      initial_nonterminals_correct : forall nonterminal,
                                       is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) <-> List.In nonterminal (Valid_nonterminals G);
      initial_nonterminals_correct' : forall nonterminal,
                                       is_valid_nonterminal initial_nonterminals_data nonterminal <-> List.In (to_nonterminal nonterminal) (Valid_nonterminals G);
      to_of_nonterminal : forall nonterminal,
                            List.In nonterminal (Valid_nonterminals G)
                            -> to_nonterminal (of_nonterminal nonterminal) = nonterminal;
      of_to_nonterminal : forall nonterminal,
                            is_valid_nonterminal initial_nonterminals_data nonterminal
                            -> of_nonterminal (to_nonterminal nonterminal) = nonterminal;
      production_tl_correct : forall p,
                                to_production (production_tl p) = tl (to_production p);
      nonterminal_to_production_correct
      : forall nt,
          List.In nt (Valid_nonterminals G)
          -> List.map to_production (nonterminal_to_production (of_nonterminal nt))
             = Lookup G nt;
      production_tl_valid
      : forall p,
          production_carrier_valid p -> production_carrier_valid (production_tl p);
      nonterminal_to_production_valid
      : forall nt,
          is_valid_nonterminal initial_nonterminals_data nt
          -> List.Forall production_carrier_valid (nonterminal_to_production nt);
      ntl_wf : well_founded nonterminals_listT_R
      := well_founded_ltof _ _;
      remove_nonterminal_1
      : forall ls ps ps',
          is_valid_nonterminal (remove_nonterminal ls ps) ps'
          -> is_valid_nonterminal ls ps';
      remove_nonterminal_2
      : forall ls ps ps',
          is_valid_nonterminal (remove_nonterminal ls ps) ps' = false
          <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }.

  Definition sub_nonterminals_listT `{parser_computational_predataT} (x y : nonterminals_listT) : Prop
    := forall p, is_valid_nonterminal x p -> is_valid_nonterminal y p.

  Class split_dataT `{parser_computational_predataT} :=
    { split_string_for_production
      : production_carrierT -> String -> nat -> nat -> list nat }.

  Class boolean_parser_dataT :=
    { predata :> parser_computational_predataT;
      split_data :> split_dataT }.

  Global Coercion predata : boolean_parser_dataT >-> parser_computational_predataT.
  Global Coercion split_data : boolean_parser_dataT >-> split_dataT.
End recursive_descent_parser.


(** Congruence closure *)
Require Import Arith.Peano_dec.
Require Import List.
Require Import Cybele.Cybele.
Require Import Cybele.Map.
Require Import Cybele.DataStructures.
Require Import Definitions.

Set Implicit Arguments.
Set Transparent Obligation.
Import Monad ListNotations.

(** The congruence-closure algorithm returning only a proof of [True] *)
Module CongruenceClosureBool (P: Parameters).
  (** Fake [EqProof] to compute the time lost in proof computations *)
  Module EqProof.
    Record t (T: Type) (values: Values.t T) := Make {
      i: Index.t;
      j: Index.t;
      H: True}.

    Arguments Make [T values i j] H.
  End EqProof.

  Definition T: Type := EqProof.t P.Values.

  Definition Sig: Sig.t := Sig.Make nil
    (Index.FMap.t T :: (bool: Type) :: nil).

  Definition Hash := Ref.t Sig (Index.FMap.t T).
  Definition M := M Sig.

  Definition read (hash: Hash) (key: Index.t): M T :=
    let! map := !hash in
    match Index.FMap.find key map with
    | None => error "Hash read: not found"
    | Some v => ret v
    end.

  Definition write (hash: Hash) (key: Index.t) (value: T): M unit :=
    let! map := !hash in
    match Index.FMap.find key map with
    | None => error "Hash write: not found"
    | Some _ => hash :=! Index.FMap.add key value map
    end.

  Definition do (map: Index.FMap.t (M unit)): M (Index.FMap.t unit) :=
    Index.FMap.fold (fun k x map' =>
      let! x := x in
      let! map' := map' in
      ret (Index.FMap.add k x map'))
      map (ret (Index.FMap.empty _)).

  Definition iter (hash: Hash) (f: Index.t -> T -> M unit): M unit :=
    let! map := !hash in
    do! do (Index.FMap.mapi f map) in
    ret tt.

  Definition Find (hash: Hash) (index: Index.t)
    : M {index': Index.t | True}.
    refine (
      dependent_fix (fun i => {j: Index.t | True})
        (fun f i =>
          let! eq_proof := read hash i in
          let (i', j, Hij) := eq_proof in
          match Index.eqb i i' with
            | true => _
            | false => error "Find: i <> i' unexpected"
          end)
        index).
    refine (
      match Index.eqb i j with
        | true => ret (exist _ j _)
        | false =>
          let! r := f j in
          let (k, Hjk) := r in
          do! write hash i (EqProof.Make (i := i) (j := k) _) in
          ret (exist _ k _)
      end); exact I.
  Defined.

  (** Do the union and return [true] if the values were in different sets *)
  Definition Merge (hash: Hash) (Hij: T): M bool.
    refine (
      let (i, j, Hij) := Hij in
      let! Pii' := Find hash i in
      let! Pjj' := Find hash j in
      let (i', Hii') := Pii' in
      let (j', Hjj') := Pjj' in
      match Index.eqb i' j' with
      | true => ret false
      | false =>
        do! write hash i' (EqProof.Make (i := i') (j := j') _) in
        ret true
      end); exact I.
  Defined.

  (** The equality proof of two values if they are equivalent *)
  Definition AreEquiv (hash: Hash) (i j: Index.t)
    : M (option True).
    refine (
      let! Pii' := Find hash i in
      let! Pjj' := Find hash j in
      let (i', Hii') := Pii' in
      let (j', Hjj') := Pjj' in
      match Index.eqb i' j' with
      | true => ret (Some _)
      | false => ret None
      end);
    exact I.
  Defined.

  Fixpoint areCongruentAux (xs ys: list Index.t)
    (f: forall (x y: Index.t), M (option True))
    {struct xs}
    : M (option True).
    destruct xs as [| x xs]; destruct ys as [| y ys];
      [exact (ret (Some I)) | exact (ret None) |
      exact (ret None) | ]; simpl.
    refine (
      let! Pxy := f x y in
      let! Pxsys := areCongruentAux xs ys f in
      match (Pxy, Pxsys) with
      | (Some _, Some _) => ret (Some _)
      | _ => ret None
      end); exact I.
  Defined.

  (** The equality proof of two values if they are congruent *)
  Definition AreCongruent (hash: Hash)
    : forall (ij: Index.t * Index.t),
      M (option True).
    refine (dependent_fix
      (fun xy => option True)
      _); intros f xy.
    destruct xy as [x y].
    refine (
      let! OHxy := AreEquiv hash x y in
      match OHxy with
      | Some _ => ret OHxy
      | None => _
      end); clear OHxy.
    destruct x as [i xs]; destruct y as [j ys]; simpl.
    refine (
      match PeanoNat.Nat.eqb i j with
      | true =>
        let! OHxsys := areCongruentAux xs ys (fun x y => f (x, y)) in
        match OHxsys with
        | None => ret None
        | Some Hxsys => ret (Some _)
        end
      | false => ret None
      end); exact I.
  Defined.

  (** Merge two equal values and merge the new congruent terms *)
  Definition RecurseMerge (hash: Hash) (get_preds: Index.t -> M Index.FSet.t)
    (Pij: T): M bool :=
    fix_ (fun recurse_merge Pij =>
      let! b := Merge hash Pij in
      if b then
        let (i, j, _) := Pij in
        let! ps := get_preds i in
        let! qs := get_preds j in
        do!
          Index.FSet.fold (fun p next =>
            do! next in
            Index.FSet.fold (fun q next =>
              do! next in
              let! P := AreCongruent hash (p, q) in
              match P with
              | Some P =>
                do! recurse_merge (EqProof.Make (i := p) (j := q) P) in
                ret tt
              | None => ret tt
              end)
              qs (ret tt))
            ps (ret tt) in
        ret true
      else
        ret false)
      Pij.

  (** Generate the congruent relation given a list of equalities and
      other involved terms *)
  Definition CongruenceClosure (eq_proofs: list T) (other_indexes: list Index.t)
    : M Hash :=
    let preds :=
      Index.Preds (other_indexes ++ flat_map (fun (P: T) =>
        let (i, j, _) := P in
        i :: j :: nil) eq_proofs) in
    let get_preds (i: Index.t): M Index.FSet.t :=
      match Index.FMap.find i preds with
      | Some s => ret s
      | None => error "Invalid index in preds"
      end in
    let! hash := tmp_ref Sig 0 (Index.FMap.mapi (fun i _ =>
      EqProof.Make (i := i) (j := i) I) preds) in
    do! List.do (List.map (RecurseMerge hash get_preds) eq_proofs) in
    ret hash.

  (** Compute the equality proof of two terms with congruence-closure *)
  Definition ProveEqual (eq_proofs: list T) (i j: Index.t)
    : M True.
    refine (
      let! hash := CongruenceClosure eq_proofs (i :: j :: nil) in
      let! Pii' := Find hash i in
      let! Pjj' := Find hash j in
      let (i', Hii') := Pii' in
      let (j', Hjj') := Pjj' in
      match Index.eqb i' j' with
      | true => ret _
      | false => error "Equality proof not found"
      end); exact I.
  Defined.
End CongruenceClosureBool.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils
  PCUICWeakeningEnv PCUICEquality PCUICReduction PCUICCumulativity PCUICCumulativitySpec
  (* PCUICContextSubst *) (* PCUICUnivSubst *) (* PCUICCases *) (* PCUICTyping *)
  (* PCUICGuardCondition *) (* PCUICGlobalEnv *).
From Equations Require Import Equations.

Require Import ssreflect.

Set Default Goal Selector "!".
Implicit Types (cf : checker_flags).

Lemma compare_term_subset {cf} pb Σ φ φ' t t'
  : ConstraintSet.Subset φ φ'
    -> compare_term pb Σ φ t t' -> compare_term pb Σ φ' t t'.
Proof.
  intro H. apply eq_term_upto_univ_impl; auto.
  all: change eq_universe with (compare_universe Conv).
  all: change leq_universe with (compare_universe Cumul).
  3: destruct pb.
  4: transitivity (compare_universe Cumul φ).
  4: tc.
  all: intros ??; now eapply cmp_universe_subset.
Qed.

Lemma eq_term_subset {cf} Σ φ φ' t t'
  : ConstraintSet.Subset φ φ' -> eq_term Σ φ t t' -> eq_term Σ φ' t t'.
Proof. apply compare_term_subset with (pb := Conv). Qed.

Lemma leq_term_subset {cf:checker_flags} Σ ctrs ctrs' t u
  : ConstraintSet.Subset ctrs ctrs' -> leq_term Σ ctrs t u -> leq_term Σ ctrs' t u.
Proof. apply compare_term_subset with (pb := Cumul). Qed.

Lemma compare_decl_subset {cf} pb Σ φ φ' d d'
  : ConstraintSet.Subset φ φ'
    -> compare_decl pb Σ φ d d' -> compare_decl pb Σ φ' d d'.
Proof.
  intros Hφ []; constructor; eauto using compare_term_subset.
Qed.

Lemma compare_context_subset {cf} pb Σ φ φ' Γ Γ'
  : ConstraintSet.Subset φ φ'
    -> compare_context pb Σ φ Γ Γ' ->  compare_context pb Σ φ' Γ Γ'.
Proof.
  intros Hφ. induction 1; constructor; auto; eapply compare_decl_subset; eassumption.
Qed.

Section ExtendsWf.
  Context {cf : checker_flags}.
  Context {Pcmp: global_env_ext -> context -> conv_pb -> term -> term -> Type}.
  Context {P: global_env_ext -> context -> term -> typ_or_sort -> Type}.

  Let wf := on_global_env Pcmp P.

Lemma global_variance_sigma_mon {Σ Σ' gr napp v} :
  wf Σ' -> extends Σ Σ' ->
  global_variance Σ gr napp = Some v ->
  global_variance Σ' gr napp = Some v.
Proof using P Pcmp cf.
  intros wfΣ' ext.
  rewrite /global_variance_gen /lookup_constructor /lookup_constructor_gen
    /lookup_inductive /lookup_inductive_gen /lookup_minductive /lookup_minductive_gen.
  destruct gr as [|ind|[ind i]|] => /= //.
  - destruct (lookup_env Σ ind) eqn:look => //.
    eapply extends_lookup in look; eauto. rewrite look //.
  - destruct (lookup_env Σ (inductive_mind i)) eqn:look => //.
    eapply extends_lookup in look; eauto. rewrite look //.
Qed.

(** The definition of [R_global_instance] is defined so that it is weakenable. *)
Lemma R_global_instance_weaken_env Σ Σ' Re Re' Rle Rle' gr napp :
  wf Σ' -> extends Σ Σ' ->
  RelationClasses.subrelation Re Re' ->
  RelationClasses.subrelation Rle Rle' ->
  RelationClasses.subrelation Re Rle' ->
  subrelation (R_global_instance Σ Re Rle gr napp) (R_global_instance Σ' Re' Rle' gr napp).
Proof using P Pcmp cf.
  intros wfΣ ext he hle hele t t'.
  rewrite /R_global_instance_gen /R_opt_variance.
  destruct global_variance_gen as [v|] eqn:look.
  - rewrite (global_variance_sigma_mon wfΣ ext look).
    induction t in v, t' |- *; destruct v, t'; simpl; auto.
    intros []; split; auto.
    destruct t0; simpl; auto.
  - destruct (global_variance Σ' gr napp) => //.
    * induction t in l, t' |- *; destruct l,  t'; simpl; intros H; inv H; auto.
      split; auto. destruct t0; simpl; auto.
    * eauto using R_universe_instance_impl'.
Qed.

#[global]
Instance eq_term_upto_univ_weaken_env Σ Σ' Re Re' Rle Rle' napp :
  wf Σ' -> extends Σ Σ' ->
  RelationClasses.subrelation Re Re' ->
  RelationClasses.subrelation Rle Rle' ->
  RelationClasses.subrelation Re Rle' ->
  CRelationClasses.subrelation (eq_term_upto_univ_napp Σ Re Rle napp)
    (eq_term_upto_univ_napp Σ' Re' Rle' napp).
Proof using P Pcmp cf.
  intros wfΣ ext he hele hle t t'.
  induction t in napp, t', Rle, Rle', hle, hele |- * using PCUICInduction.term_forall_list_ind;
    try (inversion 1; subst; constructor;
         eauto using R_universe_instance_impl'; fail).
  - inversion 1; subst; constructor.
    eapply All2_impl'; tea.
    eapply All_impl; eauto.
  - inversion 1; subst; constructor.
    eapply R_global_instance_weaken_env. 6:eauto. all:eauto.
  - inversion 1; subst; constructor.
    eapply R_global_instance_weaken_env. 6:eauto. all:eauto.
  - inversion 1; subst; destruct X as [? [? ?]]; constructor; eauto.
    * destruct X2 as [? [? ?]].
      constructor; intuition auto; solve_all.
      + eauto using R_universe_instance_impl'.
    * eapply All2_impl'; tea.
      eapply All_impl; eauto.
      cbn. intros x [? ?] y [? ?]. split; eauto.
  - inversion 1; subst; constructor.
    eapply All2_impl'; tea.
    eapply All_impl; eauto.
    cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto.
  - inversion 1; subst; constructor.
    eapply All2_impl'; tea.
    eapply All_impl; eauto.
    cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto.
Qed.

Lemma weakening_env_red1 Σ Σ' Γ M N :
  wf Σ' ->
  extends Σ Σ' ->
  red1 Σ Γ M N ->
  red1 Σ' Γ M N.
Proof using P Pcmp cf.
  induction 3 using red1_ind_all;
    try solve [econstructor; eauto with extends; solve_all].
Qed.

Lemma weakening_env_cumul_gen pb Σ Σ' φ Γ M N :
  wf Σ' ->
  extends Σ Σ' ->
  cumulAlgo_gen (Σ, φ)  Γ pb M N ->
  cumulAlgo_gen (Σ', φ) Γ pb M N.
Proof using P Pcmp.
  intros wfΣ ext.
  induction 1; simpl.
  - econstructor. eapply compare_term_subset.
    + now eapply global_ext_constraints_app.
    + simpl in *. eapply eq_term_upto_univ_weaken_env in c; simpl; eauto.
      all:typeclasses eauto.
  - econstructor 2; eauto. eapply weakening_env_red1; eauto.
  - econstructor 3; eauto. eapply weakening_env_red1; eauto.
Qed.

Lemma weakening_env_conv Σ Σ' φ Γ M N :
  wf Σ' ->
  extends Σ Σ' ->
  convAlgo (Σ, φ) Γ M N ->
  convAlgo (Σ', φ) Γ M N.
Proof using P Pcmp. apply weakening_env_cumul_gen with (pb := Conv). Qed.

Lemma weakening_env_cumul Σ Σ' φ Γ M N :
  wf Σ' ->
  extends Σ Σ' ->
  cumulAlgo (Σ, φ) Γ M N ->
  cumulAlgo (Σ', φ) Γ M N.
Proof using P Pcmp. apply weakening_env_cumul_gen with (pb := Cumul). Qed.

Lemma weakening_env_cumulSpec0 Σ Σ' φ Γ pb M N :
  wf Σ' ->
  extends Σ Σ' ->
  cumulSpec0 (Σ, φ) Γ pb M N ->
  cumulSpec0 (Σ', φ) Γ pb M N.
Proof.
  intros HΣ' Hextends Ind.
  pose proof (subrelations_leq_extends _ _  φ Hextends). revert H.
  assert (RelationClasses.subrelation
          (eq_universe (global_ext_constraints (Σ,φ)))
          (leq_universe (global_ext_constraints (Σ',φ)))).
  { typeclasses eauto. } revert H.
  generalize (leq_universe (global_ext_constraints (Σ',φ))); intros Rle Hlee Hle .
  revert pb Γ M N Ind Σ' Rle Hle Hlee HΣ' Hextends.
  apply: (cumulSpec0_ind_all (Σ,φ)).
  all:intros; try solve [econstructor; eauto with extends; intuition auto].
  - eapply cumul_Evar. solve_all.
  - eapply cumul_Case.
    * destruct X as (Hparams & Hinst & Hctx & Hret & IHret). repeat split; tas.
      + solve_all.
      + eapply R_universe_instance_impl'; eauto; apply subrelations_extends; eauto.
      + eapply IHret; eauto.
    * solve_all.
    * solve_all.
  - eapply cumul_Fix; solve_all.
  - eapply cumul_CoFix; solve_all.
  - eapply cumul_Ind; eauto. 2:solve_all.
    eapply @R_global_instance_weaken_env. 1,2,6:eauto. all: tc.
  - eapply cumul_Construct; eauto. 2:solve_all.
    eapply @R_global_instance_weaken_env. 1,2,6:eauto. all: tc.
  - eapply cumul_Sort. eapply subrelations_compare_extends; tea.
  - eapply cumul_Const. eapply R_universe_instance_impl'; eauto; tc.
Defined.

Lemma weakening_env_convSpec Σ Σ' φ Γ M N :
  wf Σ' ->
  extends Σ Σ' ->
  convSpec (Σ, φ) Γ M N ->
  convSpec (Σ', φ) Γ M N.
Proof using P Pcmp. apply weakening_env_cumulSpec0 with (pb := Conv). Qed.

Lemma weakening_env_cumulSpec Σ Σ' φ Γ M N :
  wf Σ' ->
  extends Σ Σ' ->
  cumulSpec (Σ, φ) Γ M N ->
  cumulSpec (Σ', φ) Γ M N.
Proof using P Pcmp. apply weakening_env_cumulSpec0 with (pb := Cumul). Qed.

Lemma weakening_env_conv_decls {Σ φ Σ' Γ Γ'} :
  wf Σ' -> extends Σ Σ' ->
  CRelationClasses.subrelation (conv_decls cumulSpec0 (Σ, φ) Γ Γ') (conv_decls cumulSpec0 (Σ', φ) Γ Γ').
Proof using P Pcmp.
  intros wfΣ' ext d d' Hd; depelim Hd; constructor; tas;
    eapply weakening_env_convSpec; tea.
Qed.

Lemma weakening_env_cumul_decls {Σ φ Σ' Γ Γ'} :
  wf Σ' -> extends Σ Σ' ->
  CRelationClasses.subrelation (cumul_decls cumulSpec0 (Σ, φ) Γ Γ') (cumul_decls cumulSpec0 (Σ', φ) Γ Γ').
Proof using P Pcmp.
  intros wfΣ' ext d d' Hd; depelim Hd; constructor; tas;
    (eapply weakening_env_convSpec || eapply weakening_env_cumulSpec); tea.
Qed.

Lemma weakening_env_conv_ctx {Σ Σ' φ Γ Δ} :
  wf Σ' ->
  extends Σ Σ' ->
  conv_context cumulSpec0 (Σ, φ) Γ Δ ->
  conv_context cumulSpec0 (Σ', φ) Γ Δ.
Proof using P Pcmp.
  intros wfΣ' ext.
  intros; eapply All2_fold_impl; tea => Γ0 Γ' d d'.
  now eapply weakening_env_conv_decls.
Qed.

Lemma weakening_env_cumul_ctx {Σ Σ' φ Γ Δ} :
  wf Σ' ->
  extends Σ Σ' ->
  cumul_context cumulSpec0 (Σ, φ) Γ Δ ->
  cumul_context cumulSpec0 (Σ', φ) Γ Δ.
Proof using P Pcmp.
  intros wfΣ' ext.
  intros; eapply All2_fold_impl; tea => Γ0 Γ' d d'.
  now eapply weakening_env_cumul_decls.
Qed.

End ExtendsWf.

#[global] Hint Resolve weakening_env_conv_ctx : extends.
#[global] Hint Resolve weakening_env_cumul_ctx : extends.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.

Require Import Oqarina.core.identifiers.
Require Import Oqarina.AADL.Kernel.properties.

(*! Type Checking *)

Inductive in_enumR (id : identifier) (t : property_type) : Prop :=
| In_Enum (literals : list identifier) :
    t = PT_Enumeration literals ->
    In id literals -> in_enumR id t.

Definition in_enum (id : identifier) (t : property_type) : bool  :=
  match t with
  | PT_Enumeration literals => existsb (identifier_beq id) literals
  | _ => false
  end.

Lemma in_enum_iff : forall id l,
    in_enum id (PT_Enumeration l) = true <-> in_enumR id (PT_Enumeration l).
Proof.
  unfold in_enum.
  induction l as [|i l'].
  - simpl. split.
    + intros. discriminate.
    + intros. inversion H. inversion H0; subst. inversion H1.
  - simpl. split.
    + destruct (id_beqP id i) as [H1 | H1].
      * intros. subst. econstructor. reflexivity.
        simpl. auto.
      * simpl. intros. apply IHl' in H. econstructor. reflexivity. right.
        destruct H. inversion H; subst. assumption.
    + destruct (id_beqP id i) as [H1 | H1].
      * auto.
      * intros. rewrite IHl'. apply (In_Enum id (PT_Enumeration l') l'). reflexivity.
        inversion H; clear H. inversion H0; subst; clear H0.
        destruct H2. rewrite H in H1. contradiction.
        apply H.
Qed.

Inductive is_unitR (id : identifier) (unit : unit_literal) : Prop :=
| Is_Base :
    unit = BaseUnit id -> is_unitR id unit
| Is_Derived base_id factor :
    unit = DerivedUnit id base_id factor -> is_unitR id unit.

Definition is_unit (id : identifier) (unit : unit_literal) : bool :=
  match unit with
  | BaseUnit uid
  | DerivedUnit uid _ _ => identifier_beq uid id
  end.

Lemma is_unit_iff : forall id unit,
    is_unit id unit = true <-> is_unitR id unit.
Proof.
  intros.
  split; intros H.
  - destruct unit; simpl in H.
    + apply Is_Base.
      destruct (id_beqP name id).
      * rewrite e. auto.
      * discriminate.
    + apply (Is_Derived _ _ base factor).
      destruct (id_beqP name id).
      * rewrite e. auto.
      * discriminate.
  - destruct unit; simpl.
    + inversion H. injection H0. intros.
      destruct (id_beqP name id).
      * reflexivity.
      * contradiction.
      * discriminate.
    + inversion H.
      * discriminate.
      * injection H0. intros.
        destruct (id_beqP name id).
        -- reflexivity.
        -- contradiction.
Qed.

Definition in_unitsR (id : identifier) (t : property_type) : Prop :=
  match t with
  | PT_Units units => Exists (is_unitR id) units
  | PT_Number _ _ None => False
(*  | NumberType _ (Some units) => Exists (Is_Unit_Id id) units *)
  | _ => False
  end.

Definition in_units (id : identifier) (t : property_type) : bool :=
  match t with
  | PT_Units units => existsb (is_unit id) units
  | PT_Number _ _ None => false
(*  | NumberType _ (Some units) => Exists (Is_Unit_Id id) units *)
  | _ => false
  end.

Lemma exP : forall {A} (f : A -> bool)  l,
    existsb f l = true <-> Exists (fun x => f x = true) l.
Proof.
  split.
  - generalize dependent f. induction l.
    + simpl. intros. discriminate.
    + simpl. intros. destruct (f a) eqn:Ef.
      * constructor. apply Ef.
      * simpl in H. apply IHl in H.
        apply Exists_cons_tl. auto.
  - generalize dependent f. induction l.
    + intros. apply Exists_nil in H. contradiction.
    + intros. destruct (f a) eqn:Ef.
      * simpl. rewrite Ef. auto.
      * simpl. rewrite Ef. apply IHl.
        apply Exists_cons in H. rewrite Ef in H. destruct H.
        discriminate. auto.
Qed.

Lemma in_units_iff : forall id t,
    in_units id t = true <-> in_unitsR id t.
Proof.
  split.
  - destruct t; try discriminate.
    + simpl. intros H. rewrite exP in H.
      induction units.
      * inversion H.
      * inversion H; subst.
        -- apply Exists_cons_hd. apply is_unit_iff.
           assumption.
        -- apply Exists_cons_tl. apply IHunits.
           assumption.
    + intro H. destruct units; discriminate.
  - destruct t; simpl; auto.
    + intros H. apply exP.
      induction units.
      * inversion H.
      * inversion H; subst.
        -- apply Exists_cons_hd. apply is_unit_iff.
           assumption.
        -- apply Exists_cons_tl. apply IHunits.
           assumption.
    + destruct units; auto.
Qed.

Definition is_declR (id : identifier) (d' : property_set_declaration) (d : property_set_declaration) : Prop :=
  match d with
  | PropertyTypeDecl id' _
  | PropertyConstantDecl id' _ _
  | PropertyDecl id' _ _ _ => id' = id /\ d' = d
  end.

Definition is_decl (id : identifier) (d : property_set_declaration) : option property_set_declaration :=
  match d with
  | PropertyTypeDecl id' t
  | PropertyConstantDecl id' t _
  | PropertyDecl id' t _ _ => if identifier_beq id' id then Some d else None
  end.

Lemma is_decl_iff: forall d id t,
    is_decl id d = Some t <-> is_declR id t d.
Proof.
  split.
  - intros H. destruct d; simpl in H; try discriminate.
    + simpl. destruct (identifier_beq name id) eqn:D.
      * apply identifier_beq_eq in D. injection H. intros H0. auto.
      * discriminate H.
    + simpl. destruct (identifier_beq name id) eqn:D.
      * apply identifier_beq_eq in D. injection H. intros H0. auto.
      * discriminate H.
    + simpl. destruct (identifier_beq name id) eqn:D.
      * apply identifier_beq_eq in D. injection H. intros H0. auto.
      * discriminate H.
  - intros H. destruct d; simpl in H; try contradiction.
    + simpl. destruct H. apply identifier_beq_eq in H. rewrite H, H0. reflexivity.
    + simpl. destruct H. apply identifier_beq_eq in H. rewrite H, H0. reflexivity.
    + simpl. destruct H. apply identifier_beq_eq in H. rewrite H, H0. reflexivity.
Qed.

Definition in_propertysetR (id : identifier) (d : property_set_declaration) (ps : property_set) : Prop :=
  let 'PropertySet id' decls := ps in
  Exists (is_declR id d) decls.

Definition in_propertyset (id : identifier) (ps : property_set) : option property_set_declaration :=
  let 'PropertySet _ decls := ps in
  fold_left (fun (o : option property_set_declaration) d => if o then o else is_decl id d)
            decls None.

Lemma find_first1 : forall id ds p,
    fold_left
      (fun (o : option property_set_declaration) (d : property_set_declaration) =>
         if o then o else is_decl id d) ds (Some p) = Some p.
Proof.
  induction ds.
  - simpl. reflexivity.
  - intros. simpl. apply IHds.
Qed.

(* Exists could give any of several occurrences, for the function we
   ignore later occurrences. Need to add something about uniqueness
   of names in property sets. *)

Axiom exists_unique : forall id t d ds,
  Exists (is_declR id t) (d :: ds) ->
  Exists (is_declR id t) ds ->
  is_decl id d = None.

Lemma in_propertyset_iff : forall id t ps,
    in_propertyset id ps = Some t <-> in_propertysetR id t ps.
Proof.
  split.
  - destruct ps.
    generalize dependent t.
    induction declarations as [| decl decls' IHd'].
    + simpl. discriminate.
    + intros. simpl.
      destruct (is_decl id decl) eqn:Ed.
      * apply Exists_cons_hd.
        apply is_decl_iff.
        unfold in_propertyset in H.
        simpl in H.
        rewrite Ed in H.
        rewrite find_first1 in H.
        rewrite H in Ed. apply Ed.
      * apply Exists_cons_tl.
        unfold in_propertyset in H. simpl in H.
        rewrite Ed in H.
        apply IHd' in H. apply H.
  - destruct ps.
    generalize dependent t.
    induction declarations as [| decl decls' IHd'].
    + simpl. intros. inversion H.
    + intros. simpl in H |- *.
      inversion H; subst.
      * apply is_decl_iff in H1.
        rewrite H1. apply find_first1.
      * inversion H; subst.
        -- apply is_decl_iff in H2.
           rewrite H2. apply find_first1.
        -- apply (exists_unique id t decl decls') in H.
           rewrite H.
           apply IHd' in H2. apply H2.
           apply H2.
Qed.

Definition is_psR (setid : identifier) (ps : property_set) : Prop :=
  let 'PropertySet id _ := ps in
  id = setid.

Definition is_ps (setid : identifier) (ps : property_set) : bool :=
  let 'PropertySet id _ := ps in
  identifier_beq id setid.

Lemma is_ps_iff : forall id ps,
    is_ps id ps = true <-> is_psR id ps.
Proof.
  split; intros.
  - destruct ps.
    simpl in H |- *.
    apply identifier_beq_eq. assumption.
  - destruct ps.
    simpl in H |- *.
    apply identifier_beq_eq. assumption.
Qed.

Definition in_modelR (setid id : identifier) (d : property_set_declaration) (ps : property_sets) : Prop :=
  Exists (fun p => is_psR setid p /\ in_propertysetR id d p)
         ps.

Definition in_model (ps : property_sets) (setid id: identifier) : option property_set_declaration :=
  fold_left (fun (o : option property_set_declaration) p =>
               if o then o else in_propertyset id p)
            (filter (is_ps setid) ps) None.

(* Check that a type reference is resolved to a type *)
Definition is_resolved_typeR (ps : property_sets) (qname : ps_qname) (t: property_type) : Prop :=
  let 'PSQN setname name := qname in
  exists d, in_modelR (Id setname) (Id name) d ps /\ d = PropertyTypeDecl (Id name) t.

(* Check that a reference to a property or constant is resolved to one of these *)
Definition is_resolved_valueR (ps : property_sets) (qname : ps_qname) (t : property_type) : Prop :=
  let 'PSQN setname name := qname in
  exists decl, in_modelR (Id setname) (Id name) decl ps /\ (
            (exists val, decl = PropertyConstantDecl (Id name) t val) \/
            (exists def app, decl = PropertyDecl (Id name) t def app)
          ).

Definition is_resolved_propertyR (ps : property_sets) (qname : ps_qname) (t : property_type) : Prop :=
  let 'PSQN setname name := qname in
  exists decl, in_modelR (Id setname) (Id name) decl ps /\
          exists def app, decl = PropertyDecl (Id name) t def app.

Fixpoint resolve_type' (fuel : nat) (ps : property_sets) (t : property_type) : option property_type :=
  match fuel with
  | 0%nat => None
  | S n => match t with
          | PT_TypeRef (PSQN setname name) =>
            match in_model ps (Id setname) (Id name) with
            | Some decl => match decl with
                          | PropertyTypeDecl _ r => resolve_type' n ps r
                          | _ => None
                          end
            | _ => None
            end
          | _ => Some t
          end
  end.

Definition resolve_type := resolve_type' 10.

Definition resolve_value (ps : property_sets) (qname : ps_qname) : option property_type :=
  let 'PSQN setname name := qname in
  match in_model ps (Id setname) (Id name) with
  | Some decl => match decl with
                | PropertyConstantDecl _ r _
                | PropertyDecl _ r _ _ => resolve_type ps r
                | _ => None
                end
  | _ => None
  end.

Definition resolve_default_value (ps : property_sets) (qname : ps_qname) : option property_value :=
    let 'PSQN setname name := qname in
    match in_model ps (Id setname) (Id name) with
    | Some decl => match decl with
                  | PropertyConstantDecl _ r _ => None
                  | PropertyDecl _ _ d _ => d
                  | _ => None
                  end
    | _ => None
    end.

Definition resolve_property (ps : property_sets) (qname : ps_qname) : option property_type :=
  let 'PSQN setname name := qname in
  match in_model ps (Id setname) (Id name) with
  | Some decl => match decl with
                | PropertyDecl _ r _ _ => resolve_type ps r
                | _ => None
                end
  | _ => None
  end.

  (** [resolve_property_decl] resolves a [property_set_declaration] in [ps]. *)

  Definition resolve_property_decl (ps : property_sets) (qname : ps_qname) : option property_set_declaration :=
    let 'PSQN setname name := qname in
     in_model ps (Id setname) (Id name).

Reserved Notation "m '|-' t1 '==' t2" (at level 60, t1, t2 at next level).

Inductive same_typeR (ps : property_sets) (t t' : property_type) : Prop :=
| ST_TypeRef0 (qname1 qname2 : ps_qname) :
    t = PT_TypeRef qname1 ->
    t' = PT_TypeRef qname2 ->
    qname1 = qname2 -> ps |- t == t'
| ST_TypeRef1 (qname : ps_qname) (r : property_type) :
    t = PT_TypeRef qname ->
    is_resolved_typeR ps qname r ->
    same_typeR ps r t' -> ps |- t == t'
| ST_TypeRef2 (qname : ps_qname) (r : property_type) :
    t' = PT_TypeRef qname ->
    is_resolved_typeR ps qname r ->
    ps |- t == r -> ps |- t == t'
| ST_Bool :
    t = aadlboolean ->
    t' = aadlboolean -> ps |- t == t'
| ST_String :
    t = aadlstring ->
    t' = aadlstring -> ps |- t == t'
| ST_Int :
    t = aadlinteger ->
    t' = aadlinteger -> ps |- t == t'
| ST_Real :
    t = aadlreal ->
    t' = aadlreal -> ps |- t == t'
where "m '|-' t1 '==' t2" := (same_typeR m t1 t2).

Reserved Notation "m '|-' v '∈' t" (at level 60, v at next level).

Inductive has_typeR (ps : property_sets) (t : property_type) (v : property_value) : Prop :=
| HT_PropertyRef (qname : ps_qname) (r : property_type) :
    v = PV_PropertyRef qname ->
    is_resolved_valueR ps qname r ->
    ps |- t == r -> ps |- v ∈ t
| HT_TypeRef (qname : ps_qname) (r : property_type) :
    t = PT_TypeRef qname ->
    is_resolved_typeR ps qname r ->
    ps |- v ∈ r -> ps |- v ∈ t
| HT_Bool (b : bool) :
    t = aadlboolean ->
    v = PV_Bool b -> ps |- v ∈ t
| HT_String (s : string) :
    t = aadlstring ->
    v = PV_String s -> ps |- v ∈ t
| HT_Enum (i : identifier) :
    v = PV_Enum i ->
    in_enumR i t -> ps |- v ∈ t
| HT_Unit (i : identifier) :
    v = PV_Unit i ->
    in_unitsR i t -> ps |- v ∈ t
| HT_Int (n : INT) :
    t = aadlinteger ->
    v = PV_Int n -> ps |- v ∈ t
| HT_Int' (n : INT) :
    t = PT_Number aadlinteger None None ->
    v = PV_Int n -> ps |- v ∈ t
| HT_Real (r : REAL) :
    t = aadlreal ->
    v = PV_Real r -> ps |- v ∈ t
| HT_Real' (r : REAL) :
    t = PT_Number aadlreal None None ->
    v = PV_Real r -> ps |- v ∈ t
| HT_IntU (n : INT) (rc : option range_constraint) (ut: property_type) (u : property_value) :
    t = PT_Number aadlinteger rc (Some ut) ->
    v = PV_IntU n u ->
    ps |- u ∈ ut -> ps |- v ∈ t
| HT_RealU (r : REAL) (rc : option range_constraint) (ut: property_type) (u : property_value) :
    t = PT_Number aadlreal rc (Some ut) ->
    v = PV_RealU r u ->
    has_typeR ps t u -> has_typeR ps t v
| HT_IntRange (min max : property_value) :
    t = PT_Range aadlinteger ->
    v = PV_IntRange min max ->
    ps |- min ∈ aadlinteger ->
    ps |- max ∈ aadlinteger -> ps |- v ∈ t
| HT_RealRange (min max : property_value) :
    t = PT_Range aadlreal ->
    v = PV_RealRange min max ->
    ps |- min ∈ aadlreal ->
    ps |- max ∈ aadlreal -> ps |- v ∈ t
| HT_IntRangeD (bt : property_type) (min max Δ : property_value) :
    t = PT_Range aadlinteger ->
    v = PV_IntRangeD min max Δ ->
    ps |- min ∈ aadlinteger ->
    ps |- max ∈ aadlinteger ->
    ps |- Δ ∈ aadlinteger -> ps |- v ∈ t
| HT_RealRangeD (bt : property_type) (min max Δ : property_value) :
    t = PT_Range aadlreal ->
    v = PV_RealRangeD min max Δ ->
    ps |- min ∈ aadlreal ->
    ps |- max ∈ aadlreal ->
    ps |- Δ ∈ aadlreal -> ps |- v ∈ t
| HT_Classifier :
    t = PT_Classifier ->
    v = PV_Classifier -> ps |- v ∈ t
| HT_ModelRef (path : list identifier) :
    t = PT_Reference ->
    v = PV_ModelRef path -> ps |- v ∈ t
| HT_Record_nil fdecls:
    t = PT_Record fdecls ->
    v = PV_Record [] -> ps |- v ∈ t
| HT_Record_hd did ft fdecls vid fv fvals:
    t = PT_Record (FieldDecl did ft :: fdecls) ->
    v = PV_Record (FieldVal vid fv :: fvals) ->
    did = vid ->
    ps |- fv ∈ ft ->
    ps |- (PV_Record fvals) ∈ t -> ps |- v ∈ t
| HT_Record_tl did ft fdecls fval fvals:
    t = PT_Record (FieldDecl did ft :: fdecls) ->
    v = PV_Record (fval :: fvals) ->
    ps |- (PV_Record [fval]) ∈ (PT_Record fdecls) ->
    ps |- (PV_Record fvals) ∈ t -> ps |- v ∈ t
| HT_List (et : property_type) (elements : list property_value) :
    t = PT_List et ->
    v = PV_List elements ->
    Forall (fun e => ps |- e ∈ et) elements -> ps |- v ∈ t
| HT_Computed (s : string) :
    v = PV_Computed s -> ps |- v ∈ t
where "m '|-' v '∈' t" := (has_typeR m t v).

Fixpoint same_type' (fuel : nat) (ps : property_sets) (t t' : property_type) : bool :=
  match fuel with
  | 0%nat => false
  | S n =>
    match t, t' with
    | aadlboolean, aadlboolean => true
    | aadlstring, aadlstring => true
    | aadlinteger, aadlinteger => true
    | aadlreal, aadldreal => true
    | PT_TypeRef qname1 as t1, PT_TypeRef qname2 as t2 =>
      if ps_qname_beq qname1 qname2 then true
      else
        match resolve_type ps t1, resolve_type ps t2 with
        | Some t1', Some t2' => same_type' n ps t1' t2'
        | _, _ => false
        end
    | PT_TypeRef _ as t1, t2 =>
      match resolve_type ps t1 with
      | Some t1' => same_type' n ps t1' t2
      | _ => false
      end
    | t1, PT_TypeRef _ as t2 =>
      match resolve_type ps t2 with
      | Some t2' => same_type' n ps t1 t2'
      | _ => false
      end
    | _, _ => false
    end
  end.

Definition same_type := same_type' 10.

Fixpoint has_type' (fuel : nat) (ps : property_sets) (t : property_type) (v : property_value) : bool :=
  match fuel with
  | 0%nat => false
  | S n =>
  match resolve_type ps t with
  | Some t' =>
    match v with
    | PV_PropertyRef qname => match resolve_value ps qname with
                             | Some t'' => same_type ps t' t''
                             | _ => false
                             end
    | PV_Bool b => match t' with aadlboolean => true | _ => false end
    | PV_String s => match t' with aadlstring => true | _ => false end
    | PV_Enum i => in_enum i t'
    | PV_Unit i => in_units i t'
    | PV_Int _ => match t' with aadlinteger | PT_Number aadlinteger _ None => true | _ => false end
    | PV_Real _ => match t' with aadlreal | PT_Number aadlreal _ None => true | _ => false end
    | PV_IntU _ u =>
      match t' with
      | PT_Number aadlinteger _ (Some ut) => has_type' n ps ut u
      | _ => false end
    | PV_RealU _ u =>
      match t' with
      | PT_Number aadlreal _ (Some ut) => has_type' n ps ut u
      | _ => false end
    | PV_IntRange min max =>
      match t' with
      | PT_Range aadlinteger => has_type' n ps aadlinteger min && has_type' n ps aadlinteger max
      | _ => false
      end
    | PV_RealRange min max =>
      match t' with
      | PT_Range aadlreal => has_type' n ps aadlreal min && has_type' n ps aadlreal max
      | _ => false
      end
    | PV_IntRangeD min max Δ =>
      match t' with
      | PT_Range aadlinteger => has_type' n ps aadlinteger min && has_type' n ps aadlinteger max
                               && has_type' n ps aadlinteger Δ
      | _ => false
      end
    | PV_RealRangeD min max Δ =>
      match t' with
      | PT_Range aadlreal => has_type' n ps aadlreal min && has_type' n ps aadlreal max
                            && has_type' n ps aadlreal Δ
      | _ => false
      end
    | PV_Classifier => match t' with PT_Classifier => true | _ => false end
    | PV_ModelRef path => match t' with PT_Reference => true | _ => false end
    | PV_Record [] => match t' with PT_Record _ => true | _ => false end
    | PV_Record ((FieldVal vid fv as fval) :: fvals) =>
      match t' with
      | PT_Record (FieldDecl did ft :: fdecls) =>
        if identifier_beq did vid then
          if has_type' n ps ft fv then
            has_type' n ps t' (PV_Record fvals)
          else
            false
        else
          has_type' n ps (PT_Record fdecls) (PV_Record [fval])
      | _ => false
      end
    | PV_List elements => match t' with
                         | PT_List et => fold_left
                                          (fun acc e => acc && (has_type' n ps et e))
                                          elements true
                         | _ => false
                         end
    | PV_Computed _ => true
    end
  | _ => false
  end
  end.

Definition has_type := has_type' 20.

Notation "m '|=' v '∈' t" := (has_type m t v) (at level 60, v at next level).

Definition typecheck_ps_decl (ps : property_sets) (decl : property_set_declaration) : bool :=
  match decl with
  | PropertyConstantDecl _ t v => ps |= v ∈ t
  | PropertyDecl _ t (Some v) _ => ps |= v ∈ t
  | _ => true
  end.

Definition typecheck_property_set (psl : property_sets) (ps : property_set) : bool :=
  match ps with
  | PropertySet _ decls =>
    fold_left (fun acc decl => acc && typecheck_ps_decl psl decl) decls true
  end.

Definition typecheck_property_sets (ps : property_sets) : bool :=
  fold_left (fun acc mu => acc && typecheck_property_set ps mu) ps true.

Definition check_property_association (ps : property_sets) (pa: property_association) :=
  match resolve_property ps pa.(P) with
  | Some pt => ps |= pa.(PV) ∈ pt
  | _ => false
  end.

(* TODO :
   - check that the references are not cyclic
   - prove termination for resolution and typing fixpoints if there are no cycles
   - use efficient typing environment
   - add mapping from predeclared property name to predeclared property set name
   - how to report errors (cf. scalaz.Validation, cats.Validated)?
 *)


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Subtyping_inversion
        Deterministic
        Type_Safety
        rules_inf2.
Require Import Lia.

Fixpoint erase_anno (e:exp) : dexp :=
  match e with
  | (e_var_b nat) => de_var_b nat
  | (e_var_f x) => de_var_f x
  | e_top => de_top
  | (e_lit i5) => de_lit i5
  | (e_abs A e B) => de_abs (erase_anno e)
  | (e_fixpoint A e) => de_fixpoint (erase_anno e)
  | (e_app e1 e2) => de_app (erase_anno e1) (erase_anno e2)
  | (e_merge e1 e2) => de_merge (erase_anno e1) (erase_anno e2)
  | (e_anno e A) => erase_anno e
  end.

Notation "| e |" := (erase_anno e) (at level 30, e at level 39).

Ltac size_ind_auto :=
  ( eapply_first_lt_hyp ;
    try reflexivity;
    try lia ;
    try eauto ).

Lemma erasure_open_aux : forall i,
    forall e, (size_exp e = i -> forall t n, | open_exp_wrt_exp_rec n t e | = open_dexp_wrt_dexp_rec n (| t |) (| e |)).
Proof.
  intros i. pattern i. apply lt_wf_rec.
    clear i; intros i H;
      apply_mutual_ind exp_mutind;
      default_simp; size_ind_auto.
Qed.

Lemma erasure_open : forall e t,
    | e ^^ t | = open_dexp_wrt_dexp (| e |)  (| t |).
Proof.
  intros e v.
  pose proof (erasure_open_aux (size_exp e)).
  intuition eauto.
Qed.

Lemma erasure_lc_aux : forall i,
   forall e, (size_exp e = i -> lc_exp e -> lc_dexp (| e |) ).
Proof.
  intros i. pattern i. apply lt_wf_rec.
    clear i; intros i H;
      apply_mutual_ind exp_mutind;
      default_simp;
      try solve [ size_ind_auto ];
      try solve [
            constructor;
            size_ind_auto
          ].
  - (* abs *)
    pick fresh x.
    apply (lc_de_abs_exists x).
    assert ( |e_var_f x| = de_var_f x ) by auto.
    rewrite <- H1.
    rewrite <- erasure_open.
    eapply_first_lt_hyp;
    try (apply size_exp_open_exp_wrt_exp_var);
    try lia.
    apply H3.
  - (* fix *)
    pick fresh x.
    apply (lc_de_fixpoint_exists x).
    assert ( |e_var_f x| = de_var_f x ) by auto.
    rewrite <- H1.
    rewrite <- erasure_open.
    eapply_first_lt_hyp;
    try (apply size_exp_open_exp_wrt_exp_var);
    try lia.
    apply H3.
Qed.

Lemma erasure_lc : forall e,
    lc_exp e -> lc_dexp (erase_anno e).
Proof.
  intros e H.
  pose proof erasure_lc_aux (size_exp e).
  intuition eauto.
Qed.

Lemma erasure_val : forall v,
    value v -> DValue (erase_anno v).
Proof.
  intros v H.
  induction H;
    simpl;
    try constructor*.
  forwards*: erasure_lc H.
Qed.

Lemma D_value_lc : forall v,
    DValue v -> lc_dexp v.
Proof.
  intros v H.
  induction H;
    simpl;
    try solve [constructor*].
  auto.
Qed.

Lemma TypedReduce_lc: forall v A v',
    TypedReduce v A v'-> lc_exp v /\ lc_exp v'.
Proof.
  introv Red.
  induction Red;
    try solve [constructor*].
  - (* absv *)
    inverts~ H.
Qed.

#[export]
Hint Resolve erasure_lc TypedReduce_lc : core.

Lemma star_onestep : forall a b,
    DunfieldStep a b -> a ->>*  b.
Proof.
  intros a b H.
  eapply star_trans.
  apply star_refl.
  auto.
Qed.

(* eval ctxt *)
Lemma step_mergel : forall e1 e2 e1',
    e1 ->>* e1' -> lc_dexp e2 -> (de_merge e1 e2) ->>* (de_merge e1' e2).
Proof.
  intros e1 e2 e1' H LC.
  induction H.
  auto.
  eapply star_trans.
  apply star_onestep.
  apply DStep_mergel.
  auto.
  apply H.
  auto.
Qed.

Lemma step_merger : forall v1 e2 e2',
    e2 ->>* e2' -> lc_dexp v1 -> DValue v1 -> (de_merge v1 e2) ->>* (de_merge v1 e2').
Proof.
  intros v1 e2 e2' H LC Val.
  induction~ H.
  applys* star_trans.
Qed.

Lemma step_appl : forall e1 e1' e2,
    e1 ->>* e1' -> lc_dexp e2 -> (de_app e1 e2) ->>* (de_app e1' e2).
Proof.
  intros e1 e1' e2 H LC.
  induction~ H.
  applys* star_trans.
Qed.

Lemma step_appr : forall v1 e2 e2',
    e2 ->>* e2' -> DValue v1 -> (de_app v1 e2) ->>* (de_app v1 e2').
Proof.
  intros v1 e2 e2' H Val.
  induction~ H.
  applys* star_trans.
Qed.

Lemma tred_soundness : forall v A v',
    value v -> TypedReduce v A v' -> (erase_anno v) ->>* (erase_anno v').
Proof.
  intros v A v' Val Red.
  lets Red': Red.
  induction Red;
    lets [Lc Lc']: TypedReduce_lc Red';
    simpl; auto;
      try solve [inverts Val; inverts* Lc].
  - lets : erasure_lc Lc.
    lets : erasure_val Val.
    eapply star_trans.
    apply star_onestep.
    applys* DStep_top.
    apply star_refl.
  - lets : erasure_lc Lc.
    lets : erasure_val Val.
    eapply star_trans.
    apply star_onestep.
    eapply DStep_split.
    auto.
    eapply star_trans.
    apply step_mergel.
    forwards*: IHRed1.
    auto.
    inverts* Lc'.
    forwards*: erasure_lc H3.
    apply~ step_merger.
    apply~ erasure_val.
    forwards*: TypedReduce_prv_value Red1.
Qed.

Theorem reduction_soundness : forall e e',
    step e e' -> (erase_anno e) ->>* (erase_anno e').
Proof.
  intros e e' Red.
  induction Red;
    try solve [
        simpl;
        apply star_refl ].
  - simpl.
    econstructor.
    apply DStep_toparr. lets* : erasure_val H.
    apply star_refl.
  -
    simpl.
    lets : tred_soundness H0 H1.
    lets Lc: erasure_lc H.
    lets Val: erasure_val H0.
    simpl in Lc.
    lets [Lc_v Lc_v']: TypedReduce_lc H1.
    eapply star_trans.
    eapply step_appr.
    apply H2.
    auto. auto.

    apply star_onestep.
    assert (| e ^^ v'| = open_dexp_wrt_dexp (| e |)  (| v' |)) by apply erasure_open.
    simpl.
    rewrite H3.
    apply~ DStep_beta.
    apply~ erasure_val.
    forwards*: TypedReduce_prv_value H1.
  -
    simpl.
    lets* : tred_soundness H.
  -
    simpl.
    apply~ step_appl.
  -
    simpl.
    lets Val: erasure_val H.
    lets Lc: erasure_lc.
    apply~ step_appr.
  -
    simpl.
    apply~ step_mergel.
  -
    simpl.
    lets Val: erasure_val H.
    apply~ step_merger.
  -
    simpl.
    auto.
  -
    apply erasure_lc in H.
    apply star_onestep.
    assert (| e ^^ e_fixpoint A e | = open_dexp_wrt_dexp (| e |)  (| e_fixpoint A e |)) by apply erasure_open.
    simple. rewrite H0.
    apply~ DStep_fix.
Qed.


Require Import Logic List ListSet Arith Peano_dec Omega Ensembles.
Require Import Finite_sets_facts Finite_sets Relation_Definitions.
Require Import Relation_Operators.
Require Import strictorder set_rep_equiv util.
Require Import finite_set_builder strandlib.
Require Import LibTactics.

Require Import strandspace.

Module NSLSpace.

Open Scope list_scope.
Import ListNotations.
Open Scope ss_scope.

(* Names and Nonces *)
Variable A B Na Nb : Text.
  Hypothesis neqANa : A <> Na.
  Hypothesis neqANb : A <> Nb.
  Hypothesis neqBNa : B <> Na.
  Hypothesis neqBNb : B <> Nb.
(* "Public" and "Private" keys *)
Variable Ka Kb Ka' Kb' : Key.
  Hypothesis keyinj : Ka = Kb -> A = B.
  Hypothesis Ka_inv : Inv Ka Ka'.
  Hypothesis Kb_inv : Inv Kb Kb'.

(* Self-communication in this protocol is nonsensical *)
Hypothesis neqAB : A <> B.

Lemma neqKaKb : Ka <> Kb.
Proof.
  intros contra.
  apply keyinj in contra.
  apply neqAB. auto.
Qed.

Definition NSLInitiator : Strand :=
  [(+ {(!Na) * (!A)}^[Kb]) ;
   (- {(!Na) * (!Nb) * (!B)}^[Ka]) ;
   (+ {(!Nb)}^[Kb])].

Definition NSLResponder : Strand :=
  [(- {(!Na) * (!A)}^[Kb]) ;
   (+ {(!Na) * (!Nb) * (!B)}^[Ka]) ;
   (- {(!Nb)}^[Kb])].

Hypothesis NSLProtocol :
  Protocol = [NSLInitiator ; NSLResponder].

End NSLSpace.

Export NSLSpace.