From Coq Require Import String Arith ZArith.

From Vyper Require Import Config Map.
From Vyper.L10 Require Import Base.
From Vyper.L50 Require Import Types AST Builtins Expr LocalVars DynError Stmt.

Fixpoint interpret_call {C: VyperConfig}
                        (max_call_depth: nat)
                        (max_loop_iterations: nat)
                        (builtins: string -> option yul_builtin)
                        (funs: string -> option fun_decl)
                        (f: fun_decl)
                        (world: world_state)
                        (arg_values: list dynamic_value)
{struct max_call_depth}
: world_state * option (expr_result (list dynamic_value))
:= let _ := string_map_impl in
   match max_call_depth with
   | O => (world, None)
   | S new_max_call_depth =>
        match bind_vars_to_values (fd_inputs f) arg_values Map.empty with
        | inl err =>
            (* since L10-L40 produce a slightly better error message than "too few values",
               namely "function called with too few arguments", it's better to repeat it here.
             *)
            (world, Some (expr_error
                            match err with
                            | DE_TooFewValues => "function called with too few arguments"
                            | DE_TooManyValues => "function called with too many arguments"
                            | _ => string_of_dynamic_error err
                            end))
        | inr loc_with_args_only =>
            match bind_vars_to_zeros (fd_outputs f) loc_with_args_only with
            | inl err => (world, Some (expr_error (string_of_dynamic_error err)))
            | inr loc =>
                let '(world', loc', result) :=
                        interpret_block max_loop_iterations builtins funs (Some f)
                                        (interpret_call new_max_call_depth max_loop_iterations
                                                        builtins funs)
                                        world loc nop (fd_body f)
                in (world', match result with
                            | None => None
                            | Some StmtSuccess =>
                                match get_vars_by_typenames (fd_outputs f) loc' with
                                | inl err => Some (expr_error (string_of_dynamic_error err))
                                | inr outputs => Some (ExprSuccess outputs)
                                end
                            | Some (StmtAbort AbortBreak)
                            | Some (StmtAbort AbortContinue) =>
                                Some (expr_error (string_of_dynamic_error DE_BreakContinueDisallowed))
                            | Some (StmtAbort a) => Some (ExprAbort a)
                            | Some (StmtReturnFromFunction x) => Some (ExprSuccess x)
                            end)
            end
        end
   end.

Definition interpret {C: VyperConfig}
                     (max_call_depth: nat)
                     (max_loop_iterations: nat)
                     (builtins: string -> option yul_builtin)
                     (funs: string -> option fun_decl)
                     (fun_name: string)
                     (world: world_state)
                     (args: list dynamic_value)
: world_state * option (expr_result (list dynamic_value))
:= match funs fun_name with
   | Some f => interpret_call max_call_depth max_loop_iterations builtins funs f world args
   | None => (world, Some (expr_error "declaration not found"))
   end.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Arith.
Require Import Peano_dec.
Require Import EquivDec.
Require Import Decidable.
Require Import Utils.
Require Import DataSystem.
Require Import cNNRC.
Require Import cNNRCShadow.
Require Import TcNNRC.

Section TcNNRCShadow.
  Hint Constructors nnrc_core_type : qcert.

  Context {m:basic_model}.

  Lemma nnrc_core_type_remove_duplicate_env {τcenv} l v x l' x' l'' e τ:
    nnrc_core_type τcenv (l ++ (v,x)::l' ++ (v,x')::l'') e τ <->
    nnrc_core_type τcenv (l ++ (v,x)::l' ++ l'') e τ.
  Proof.
    apply nnrc_core_type_lookup_equiv_prop; trivial.
    apply lookup_remove_duplicate.
  Qed.

  Lemma nnrc_core_type_remove_free_env {τcenv} l v x l' e τ :
    ~ In v (nnrc_free_vars e) ->
    (nnrc_core_type τcenv (l ++ (v,x)::l') e τ <-> nnrc_core_type τcenv (l ++ l') e τ).
  Proof.
    split; revert l v x l' τ H;
      induction e; simpl; inversion 2; subst; intuition; eauto 3 with qcert.
    - constructor. erewrite <- lookup_remove_nin; eauto.
    - apply nin_app_or in H. intuition. qeauto.
    - apply nin_app_or in H. intuition.
      econstructor; eauto.
      destruct (equiv_dec v v0); unfold Equivalence.equiv in *; subst.
      + apply (nnrc_core_type_remove_duplicate_env nil v0 τ₁ l) in H7; eauto.
      + eapply (IHe2 ((v, τ₁) :: l)); eauto.
        intro; elim H2; apply remove_in_neq; eauto.
    - apply nin_app_or in H. intuition.
      econstructor; eauto.
      destruct (equiv_dec v v0); unfold Equivalence.equiv in *; subst.
      + apply (nnrc_core_type_remove_duplicate_env nil v0 τ₁ l) in H7; eauto.
      + eapply (IHe2 ((v, τ₁) :: l)); eauto.
        intro; elim H2; apply remove_in_neq; eauto.
    - apply nin_app_or in H; destruct H as [? HH]; apply nin_app_or in HH.
      intuition. qeauto.
    - apply nin_app_or in H. destruct H as [neq1 neq2].
      apply nin_app_or in neq2. destruct neq2 as [neq2 neq3].
      econstructor; eauto.
      + destruct (equiv_dec v v1); unfold Equivalence.equiv in *; subst.
        * apply (nnrc_core_type_remove_duplicate_env nil v1 τl l) in H9; eauto.
        * eapply (IHe2 ((v, τl) :: l)); eauto.
          rewrite <- remove_in_neq in neq2; intuition.
      + destruct (equiv_dec v0 v1); unfold Equivalence.equiv in *; subst.
        * apply (nnrc_core_type_remove_duplicate_env nil v1 τr l) in H10; eauto.
        * eapply (IHe3 ((v0, τr) :: l)); eauto.
          rewrite <- remove_in_neq in neq3; intuition.
    - constructor. erewrite lookup_remove_nin; eauto.
    - apply nin_app_or in H. intuition. qeauto.
    - apply nin_app_or in H. intuition.
      econstructor; eauto.
      destruct (equiv_dec v v0); unfold Equivalence.equiv in *; subst.
      + apply (nnrc_core_type_remove_duplicate_env nil v0 τ₁ l); eauto.
      + eapply (IHe2 ((v, τ₁) :: l)); eauto.
        intro; elim H2; apply remove_in_neq; eauto.
    - apply nin_app_or in H. intuition.
      econstructor; eauto.
      destruct (equiv_dec v v0); unfold Equivalence.equiv in *; subst.
      + apply (nnrc_core_type_remove_duplicate_env nil v0 τ₁ l); eauto.
      + eapply (IHe2 ((v, τ₁) :: l)); eauto.
        intro; elim H2; apply remove_in_neq; eauto.
    - apply nin_app_or in H; destruct H as [? HH]; apply nin_app_or in HH.
      intuition.
    - apply nin_app_or in H. destruct H as [neq1 neq2].
      apply nin_app_or in neq2; destruct neq2  as [neq2 neq3].
      econstructor; eauto.
      + destruct (equiv_dec v v1); unfold Equivalence.equiv in *; subst.
        * apply (nnrc_core_type_remove_duplicate_env nil v1 τl l); simpl; trivial.
        * eapply (IHe2 ((v, τl) :: l)); eauto.
          rewrite <- remove_in_neq in neq2; intuition.
      + destruct (equiv_dec v0 v1); unfold Equivalence.equiv in *; subst.
        * apply (nnrc_core_type_remove_duplicate_env nil v1 τr l); simpl; trivial.
        * eapply (IHe3 ((v0, τr) :: l)); eauto.
          rewrite <- remove_in_neq in neq3; intuition.
  Qed.

  Lemma nnrc_core_type_remove_disjoint_env {τcenv} l1 l2 l3 e τ :
    disjoint (domain l2) (nnrc_free_vars e) ->
    (nnrc_core_type τcenv (l1 ++ l2 ++ l3) e τ <-> nnrc_core_type τcenv (l1 ++ l3) e τ).
  Proof.
    revert l1 l3.
    induction l2; intros l1 l3 disj; simpl.
    - tauto.
    - simpl in disj.
      apply disjoint_cons_inv1 in disj.
      destruct disj as [disj nin].
      destruct a; simpl in *.
      rewrite nnrc_core_type_remove_free_env; trivial.
      eauto.
  Qed.

  Lemma nnrc_core_type_remove_almost_free_env {τcenv} l v x l' e τ :
    (In v (nnrc_free_vars e) -> In v (domain l)) ->
    (nnrc_core_type τcenv (l ++ (v,x)::l') e τ <-> nnrc_core_type τcenv (l ++ l') e τ).
  Proof.
    intros Hinn.
    destruct (in_dec string_dec v (nnrc_free_vars e)) as [inn|inn].
    - apply Hinn in inn.
      apply in_domain_in in inn.
      destruct inn as [? inn].
      destruct (in_split _ _ inn) as [? [? ?]]; subst.
      repeat rewrite app_ass; simpl.
      apply nnrc_core_type_remove_duplicate_env.
    - apply nnrc_core_type_remove_free_env; trivial.
  Qed.

  Lemma nnrc_core_type_remove_almost_disjoint_env {τcenv} l1 l2 l3 e τ :
    (forall x,
        In x (domain l2) ->
        In x (nnrc_free_vars e) -> In x (domain l1)) ->
    (nnrc_core_type τcenv (l1 ++ l2 ++ l3) e τ <-> nnrc_core_type τcenv (l1 ++ l3) e τ).
  Proof.
    revert l1 l3.
    induction l2; intros l1 l3 disj; simpl.
    - tauto.
    - simpl in disj.
      destruct a; simpl in *.
      rewrite nnrc_core_type_remove_almost_free_env; trivial.
      + eauto.
      + intuition.
  Qed.

  Lemma nnrc_core_type_swap_neq {τcenv} l1 v1 x1 v2 x2 l2 e τ :
    v1 <> v2 ->
    (nnrc_core_type τcenv (l1++(v1,x1)::(v2,x2)::l2) e τ <->
     nnrc_core_type τcenv (l1++(v2,x2)::(v1,x1)::l2) e τ).
  Proof.
    intros.
    apply nnrc_core_type_lookup_equiv_prop; trivial.
    apply lookup_swap_neq; trivial.
  Qed.

  Lemma nnrc_core_type_cons_subst {τcenv} e Γ v τ₀ v' τ :
    ~ (In v' (nnrc_free_vars e)) ->
    ~ (In v' (nnrc_bound_vars e)) ->
    (nnrc_core_type τcenv ((v',τ₀)::Γ) (nnrc_subst e v (NNRCVar v')) τ <->
     nnrc_core_type τcenv ((v,τ₀)::Γ) e τ).
  Proof.
    split; revert Γ v τ₀ v' τ H H0;
      induction e; simpl in *; unfold equiv_dec, string_eqdec;
        trivial; intros Γ v₀ τ₀ v' τ nfree nbound.
    - intuition.
      constructor.
      destruct (string_dec v v₀); simpl; subst; intuition; inversion H; subst; simpl in *; repeat dest_eqdec; intuition.
    - intuition.
      constructor.
      destruct (string_dec v v₀); simpl; subst; intuition; inversion H; subst; simpl in *; repeat dest_eqdec; intuition.
    - inversion 1; subst. qeauto.
    - inversion 1; subst.
      rewrite nin_app_or in nfree, nbound.
      intuition; qeauto.
    - inversion 1; subst. qeauto.
    - inversion 1; subst.
      rewrite nin_app_or in nfree. intuition.
      apply nin_app_or in H3. intuition.
      match_destr_in H; subst.
      + econstructor; eauto.
        apply (nnrc_core_type_remove_duplicate_env nil v₀ τ₁ nil); simpl.
        generalize (@nnrc_core_type_remove_free_env τcenv ((v₀,τ₁)::nil)); simpl; intros HH.
        apply HH in H6; eauto.
        intro; elim H1. apply remove_in_neq; eauto.
      + econstructor; eauto.
        apply (nnrc_core_type_swap_neq nil); eauto; simpl.
        eapply IHe2; eauto.
        * intro; elim H1.
          apply remove_in_neq; eauto.
        * apply (nnrc_core_type_swap_neq nil); eauto; simpl.
    - inversion 1; subst.
      rewrite nin_app_or in nfree. intuition.
      apply nin_app_or in H3. intuition.
      match_destr_in H6; subst.
      + econstructor; eauto.
        apply (nnrc_core_type_remove_duplicate_env nil v₀ τ₁ nil); simpl.
        generalize (@nnrc_core_type_remove_free_env τcenv ((v₀,τ₁)::nil)); simpl; intros HH.
        apply HH in H6; eauto.
        intro; elim H1. apply remove_in_neq; eauto.
      + econstructor; eauto.
        apply (nnrc_core_type_swap_neq nil); eauto; simpl.
        eapply IHe2; eauto.
        * intro; elim H1.
          apply remove_in_neq; eauto.
        * apply (nnrc_core_type_swap_neq nil); eauto; simpl.
    - inversion 1; subst.
      apply nin_app_or in nfree; destruct nfree as [? HH]; apply nin_app_or in HH.
      apply nin_app_or in nbound; destruct nbound as [? HHH]; apply nin_app_or in HHH.
      intuition; qeauto.
    - intro HH; inversion HH; subst; clear HH.
      apply not_or in nbound; destruct nbound as [nb1 nb2].
      apply not_or in nb2; destruct nb2 as [nb2 nb3].
      repeat rewrite nin_app_or in nb3, nfree.
      rewrite <- (remove_in_neq _ _ v) in nfree by congruence.
      rewrite <- (remove_in_neq _ _ v0) in nfree by congruence.
      econstructor.
      + eapply IHe1; eauto 2; intuition.
      + match_destr_in H7; subst.
        * generalize (@nnrc_core_type_remove_free_env τcenv ((v₀,τl)::nil)); simpl;
            intros re1; rewrite re1 in H7 by intuition.
          generalize (@nnrc_core_type_remove_duplicate_env τcenv nil v₀ τl nil); simpl;
            intros re2; rewrite re2 by intuition.
          trivial.
        * apply (nnrc_core_type_swap_neq nil); eauto 2; simpl.
          apply (nnrc_core_type_swap_neq nil) in H7; eauto 2; simpl in *.
          eapply IHe2; eauto 2; intuition.
      + match_destr_in H8; subst.
        * generalize (@nnrc_core_type_remove_free_env τcenv ((v₀,τr)::nil)); simpl;
            intros re1; rewrite re1 in H8 by intuition.
          generalize (@nnrc_core_type_remove_duplicate_env τcenv nil v₀ τr nil); simpl;
            intros re2; rewrite re2 by intuition.
          trivial.
        * apply (nnrc_core_type_swap_neq nil); eauto 2; simpl.
          apply (nnrc_core_type_swap_neq nil) in H8; eauto 2; simpl in *.
          eapply IHe3; eauto 2; intuition.
    - (* GroupBy Case: always fails for core? *)
      intros.
      inversion H.
    - intuition.
      destruct (string_dec v v₀); simpl; subst; intuition;
        inversion H; subst; simpl in *; repeat dest_eqdec; intuition;
          inversion H4; subst; constructor; simpl;
            repeat dest_eqdec; intuition.
    - intuition.
      destruct (string_dec v v₀); simpl; subst; intuition;
        inversion H; subst; simpl in *; repeat dest_eqdec; intuition;
          inversion H4; subst; constructor; simpl;
            repeat dest_eqdec; intuition.
    - inversion 1; subst. qeauto.
    - inversion 1; subst.
      rewrite nin_app_or in nfree, nbound.
      intuition; qeauto.
    - inversion 1; subst. qeauto.
    - inversion 1; subst.
      rewrite nin_app_or in nfree. intuition.
      apply nin_app_or in H3. intuition.
      match_destr; subst.
      + econstructor; eauto.
        apply (nnrc_core_type_remove_duplicate_env nil v₀ τ₁ nil) in H6;
          simpl in H6.
        generalize (@nnrc_core_type_remove_free_env τcenv ((v₀,τ₁)::nil)); simpl; intros HH.
        apply HH; eauto.
        intro; elim H1. apply remove_in_neq; eauto.
      + econstructor; eauto.
        apply (nnrc_core_type_swap_neq nil); eauto; simpl.
        eapply IHe2; eauto.
        * intro; elim H1.
          apply remove_in_neq; eauto.
        * apply (nnrc_core_type_swap_neq nil); eauto; simpl.
    - inversion 1; subst.
      rewrite nin_app_or in nfree. intuition.
      apply nin_app_or in H3. intuition.
      match_destr; subst.
      + econstructor; eauto.
        apply (nnrc_core_type_remove_duplicate_env nil v₀ τ₁ nil) in H6;
          simpl in H6.
        generalize (@nnrc_core_type_remove_free_env τcenv ((v₀,τ₁)::nil)); simpl; intros HH.
        apply HH; eauto.
        intro; elim H1. apply remove_in_neq; eauto.
      + econstructor; eauto.
        apply (nnrc_core_type_swap_neq nil); eauto; simpl.
        eapply IHe2; eauto.
        * intro; elim H1.
          apply remove_in_neq; eauto.
        * apply (nnrc_core_type_swap_neq nil); eauto; simpl.
    - inversion 1; subst.
      apply nin_app_or in nfree; destruct nfree as [? HH]; apply nin_app_or in HH.
      apply nin_app_or in nbound; destruct nbound as [? HHH]; apply nin_app_or in HHH.
      intuition; eauto.
    - apply not_or in nbound; destruct nbound as [nb1 nb2].
      apply not_or in nb2; destruct nb2 as [nb2 nb3].
      repeat rewrite nin_app_or in nb3, nfree.
      rewrite <- (remove_in_neq _ _ v) in nfree by congruence.
      rewrite <- (remove_in_neq _ _ v0) in nfree by congruence.
      intro HH; inversion HH; clear HH; subst.
      econstructor.
      + apply IHe1; eauto 2; intuition.
      + match_destr; subst.
        * generalize (@nnrc_core_type_remove_duplicate_env τcenv nil v₀ τl nil); simpl;
            intros re1; rewrite re1 in H7.
          apply (nnrc_core_type_remove_free_env ((v₀,τl)::nil)); intuition.
        * apply (nnrc_core_type_swap_neq nil); eauto; simpl.
          apply IHe2; eauto 2; intuition.
          apply (nnrc_core_type_swap_neq nil); eauto; simpl.
      + match_destr; subst.
        * generalize (@nnrc_core_type_remove_duplicate_env τcenv nil v₀ τr nil); simpl;
            intros re1; rewrite re1 in H8.
          apply (nnrc_core_type_remove_free_env ((v₀,τr)::nil)); intuition.
        * apply (nnrc_core_type_swap_neq nil); eauto; simpl.
          apply IHe3; eauto 2; intuition.
          apply (nnrc_core_type_swap_neq nil); eauto; simpl.
    - (* GroupBy Case: always fails for core? *)
      intros.
      inversion H.
  Qed.

  Lemma nnrc_core_type_cons_subst_disjoint {τcenv} e e' Γ v τ₀ τ :
    disjoint (nnrc_bound_vars e) (nnrc_free_vars e') ->
    nnrc_core_type τcenv Γ e' τ₀ ->
    nnrc_core_type τcenv ((v,τ₀)::Γ) e τ ->
    nnrc_core_type τcenv Γ (nnrc_subst e v e') τ.
  Proof.
    intros disj typ'.
    revert Γ e' v τ₀ τ disj typ'.
    nnrc_cases (induction e) Case; simpl in *;
      trivial; intros Γ v₀ τ₀ v' τ nfree nbound; simpl;
        intros typ; inversion typ; clear typ; subst;
          unfold equiv_dec in *; simpl in * .
    - Case "NNRCGetConstant"%string.
      qeauto.
    - Case "NNRCVar"%string.
      match_destr.
      + congruence.
      + qauto.
    - Case "NNRCConst"%string.
      econstructor; trivial.
    - Case "NNRCBinop"%string.
      apply disjoint_app_l in nfree.
      destruct nfree.
      econstructor; eauto 2.
    - Case "NNRCUnop"%string.
      econstructor; eauto.
    - Case "NNRCLet"%string.
      apply disjoint_cons_inv1 in nfree.
      destruct nfree as [disj nin].
      apply disjoint_app_l in disj.
      destruct disj as [disj1 disj2].
      econstructor; eauto 2.
      match_destr.
      + red in e; subst.
        generalize (@nnrc_core_type_remove_duplicate_env τcenv nil τ₀ τ₁ nil v' Γ);
          simpl; intros re1; apply re1; eauto.
      + eapply IHe2; eauto 2.
        * generalize (@nnrc_core_type_remove_free_env τcenv nil v τ₁ Γ v₀);
            simpl; intros re1; apply re1; eauto.
        * generalize (@nnrc_core_type_swap_neq τcenv nil τ₀ v' v τ₁ Γ e2 τ);
            simpl; intros re1; apply re1; eauto.
    - Case "NNRCFor"%string.
      apply disjoint_cons_inv1 in nfree.
      destruct nfree as [disj nin].
      apply disjoint_app_l in disj.
      destruct disj as [disj1 disj2].
      econstructor; eauto 2.
      match_destr.
      + red in e; subst.
        generalize (@nnrc_core_type_remove_duplicate_env τcenv nil τ₀ τ₁ nil v' Γ);
          simpl; intros re1; apply re1; eauto.
      + eapply IHe2; eauto 2.
        * generalize (@nnrc_core_type_remove_free_env τcenv nil v τ₁ Γ v₀);
            simpl; intros re1; apply re1; eauto.
        * generalize (@nnrc_core_type_swap_neq τcenv nil τ₀ v' v τ₁ Γ e2 τ₂);
            simpl; intros re1; apply re1; eauto.
    - Case "NNRCIf"%string.
      apply disjoint_app_l in nfree.
      destruct nfree as [disj1 disj2].
      apply disjoint_app_l in disj2.
      destruct disj2 as [disj2 disj3].
      econstructor; eauto 2.
    - Case "NNRCEither"%string.
      apply disjoint_cons_inv1 in nfree.
      destruct nfree as [disj nin].
      apply disjoint_cons_inv1 in disj.
      destruct disj as [disj nin2].
      apply disjoint_app_l in disj.
      destruct disj as [disj1 disj2].
      apply disjoint_app_l in disj2.
      destruct disj2 as [disj2 disj3].
      econstructor; eauto 2.
      + {
          match_destr.
          + red in e; subst.
            generalize (@nnrc_core_type_remove_duplicate_env τcenv nil τ₀ τl nil v' Γ);
              simpl; intros re1; apply re1; eauto.
          + eapply IHe2; eauto 2.
            * generalize (@nnrc_core_type_remove_free_env τcenv nil v τl Γ v₀);
                simpl; intros re1; apply re1; eauto.
            * generalize (@nnrc_core_type_swap_neq τcenv nil τ₀ v' v τl Γ e2 τ);
                simpl; intros re1; apply re1; eauto.
        }
      + {
          match_destr.
          + red in e; subst.
            generalize (@nnrc_core_type_remove_duplicate_env τcenv nil τ₀ τr nil v' Γ);
              simpl; intros re1; apply re1; eauto.
          + eapply IHe3; eauto 2.
            * generalize (@nnrc_core_type_remove_free_env τcenv nil v0 τr Γ v₀);
                simpl; intros re1; apply re1; eauto.
            * generalize (@nnrc_core_type_swap_neq τcenv nil τ₀ v' v0 τr Γ e3 τ);
                simpl; intros re1; apply re1; eauto.
        }
  Qed.

  Lemma nnrc_core_type_rename_pick_subst {τcenv} sep renamer avoid e Γ v τ₀ τ :
    (nnrc_core_type τcenv
                    ((nnrc_pick_name sep renamer avoid v e,τ₀)::Γ)
                    (nnrc_rename_lazy e v (nnrc_pick_name sep renamer avoid v e)) τ
     <->
     nnrc_core_type τcenv ((v,τ₀)::Γ) e τ).
  Proof.
    unfold nnrc_rename_lazy.
    match_destr.
    - rewrite <- e0.
      tauto.
    - rewrite nnrc_core_type_cons_subst; trivial.
      + tauto.
      + apply nnrc_pick_name_neq_nfree; trivial.
      + apply nnrc_pick_name_bound.
  Qed.

  Theorem nnrc_core_unshadow_type {τcenv} sep renamer avoid Γ n τ :
    nnrc_core_type τcenv Γ n τ <-> nnrc_core_type τcenv Γ (unshadow sep renamer avoid n) τ.
  Proof.
    Hint Resolve really_fresh_from_free  really_fresh_from_bound : qcert.
    split; revert Γ τ; induction n; simpl in *; inversion 1; subst; qeauto; simpl.
    - econstructor; [eauto|..].
      apply nnrc_core_type_rename_pick_subst.
      eauto.
    - econstructor; [eauto|..].
      apply nnrc_core_type_rename_pick_subst.
      eauto.
    - econstructor; [eauto|..].
      apply nnrc_core_type_rename_pick_subst.
      + eauto.
      + apply nnrc_core_type_rename_pick_subst.
        eauto.
    - econstructor; [eauto|..].
      apply nnrc_core_type_rename_pick_subst in H6.
      eauto.
    - econstructor; [eauto|..].
      apply nnrc_core_type_rename_pick_subst in H6.
      eauto.
    - econstructor; [eauto|..].
      + apply nnrc_core_type_rename_pick_subst in H8.
        eauto.
      + apply nnrc_core_type_rename_pick_subst in H9.
        eauto.
  Qed.

End TcNNRCShadow.


Require Import VST.sepcomp.semantics.

Require Import VST.veric.juicy_base.

Require Import VST.veric.juicy_mem.
Require Import VST.sepcomp.extspec.
Require Import VST.veric.ghost_PCM.
Require Import VST.veric.juicy_extspec.

Require Import VST.veric.res_predicates.
Require Import VST.veric.mpred.
Require Import VST.veric.seplog.

(*Require Import VST.veric.initial_world.
Require Import VST.veric.SeparationLogic.
 *)

(*********copied from initial_world***********)
Fixpoint find_id (id: ident) (G: funspecs) : option funspec  :=
 match G with
 | (id', f)::G' => if eq_dec id id' then Some f else find_id id G'
 | nil => None
 end.

Definition cond_approx_eq n A P1 P2 :=
  (forall ts,
      fmap (dependent_type_functor_rec ts (AssertTT A)) (approx n) (approx n) (P1 ts) =
      fmap (dependent_type_functor_rec ts (AssertTT A)) (approx n) (approx n) (P2 ts)).

Definition func_at'' fsig cc A P Q :=
  pureat (SomeP (SpecTT A) (packPQ P Q)) (FUN fsig cc).
(*also copy lemmas on these from initial_world? or isolate in general file?*)

(**********************************************)

Module Type GENERAL_SEPARATION_LOGIC_SOUNDNESS.

(*Declare Module ExtSpec: EXTERNAL_SPEC. *)
(*Declare Module CSL: CLIGHT_SEPARATION_LOGIC.
Import CSL. for semax_prog*)

Parameter F T: Type. (*Clight instantiates := fundef V:=type*)
(*Record genv : Type := Build_genv { genv_genv : @Genv.t F T;  genv_cenv : composite_env }.

Parameter genv:Type.
*)
Definition genv:Type := Genv.t F T.

(*duplicated from tycontext to prevent specialization to Clight*)
Definition filter_genv (ge: genv) : genviron := Genv.find_symbol ge.
Definition empty_environ (ge: genv) := mkEnviron (filter_genv ge) (Map.empty _) (Map.empty _).

Parameter C: Type.
Parameter Sem: genv -> CoreSemantics C Memory.mem.

(*Definition genv_symb_injective {F V} (ge: Genv.t F V) : extspec.injective_PTree block.
Proof.
exists (Genv.genv_symb ge).
hnf; intros.
eapply Genv.genv_vars_inj; eauto.
Defined.*)
(*Parameter genv_symb_injective: forall {F V:Type} (ge: Genv.t F V), extspec.injective_PTree block.*)
Parameter genv_symb_injective: genv -> extspec.injective_PTree block.

Definition jsafeN {Z} (Hspec : juicy_ext_spec Z) (ge: genv) :=
  @jsafeN_ genv _ _ genv_symb_injective (*(genv_symb := fun ge: genv => Genv.genv_symb ge)*)
           (Sem ge) Hspec ge.

Definition matchfunspecs (ge : genv) (G : funspecs) (Phi : rmap) :=
forall (b : block) (fsig : compcert_rmaps.funsig)
  (cc : calling_convention) (A : TypeTree)
  (P
   Q : forall ts : list Type,
       (dependent_type_functor_rec ts (AssertTT A)) (pred rmap)),
(func_at'' fsig cc A P Q (b, 0)) Phi ->
exists
  (id : ident) (P'
                Q' : forall ts : list Type,
                     (dependent_type_functor_rec ts (AssertTT A)) mpred)
(P'_ne : super_non_expansive P') (Q'_ne : super_non_expansive Q'),
  Genv.find_symbol ge id = Some b /\
  find_id id G = Some (mk_funspec fsig cc A P' Q' P'_ne Q'_ne) /\
  cond_approx_eq (level Phi) A P P' /\ cond_approx_eq (level Phi) A Q Q'.

Definition EPoint_sound {Espec: OracleKind} FS m (h:nat) (entryPT:ident) (g:genv) :=
     { b : block & { q : C &
       (Genv.find_symbol g entryPT = Some b) *
       (forall jm, m_dry jm = m -> exists jm', semantics.initial_core (juicy_core_sem (Sem g)) h
                    jm q jm' (Vptr b Ptrofs.zero) nil) *
       forall n z,
         { jm |
           m_dry jm = m /\ level jm = n /\
           nth_error (ghost_of (m_phi jm)) 0 = Some (Some (ext_ghost z, NoneP)) /\
           jsafeN (@OK_spec Espec) g n z q jm /\
           res_predicates.no_locks (m_phi jm) /\
           matchfunspecs g FS (m_phi jm) /\
           app_pred (funspecs_assert (make_tycontext_s FS) (empty_environ g))  (m_phi jm) } } }%type.

(*maybe generalize from single EP ("main") to multiple entry points?
Axiom module_sound: forall Espec G m h entryPT g,
      @EPoint_sound Espec G m h entryPT g.

Definition prog_sound {Espec: OracleKind} CS prog :=
     @semax_prog Espec CS prog V G ->
     forall h m,
     @Genv.init_mem F T prog = Some m ->
     @EPoint_sound Espec G m h (prog_main prog)  (globalenv prog).
                                    *)

End GENERAL_SEPARATION_LOGIC_SOUNDNESS.


From mathcomp Require Import all_ssreflect.
From Michocoq Require Import semantics util macros.
Import syntax comparable error.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module ccgen(C : ContractContext).
Module semantics := Semantics C. Import semantics.
Require Import String.
Open Scope string_scope.

Definition reconstr_op {self_type A B}
           (op: @opcode self_type A B) : @opcode None A B :=
  match op with
  | APPLY _ _ _ _ b => @APPLY _ _ _ _ _ b
  | DUP _ _ => DUP
  | SWAP _ _ _ => SWAP
  | UNIT _ => UNIT
  | EQ _ => EQ
  | NEQ _ => NEQ
  | LT _ => LT
  | GT _ => GT
  | LE _ => LE
  | GE _ => GE
  | OR _ s _ => @OR _ _ s _
  | AND _ _ s _ => @AND _ _ _ s _
  | XOR _ s _ => @XOR _ _ s _
  | NOT _ s _ => @NOT _ _ s _
  | NEG _ s _ => @NEG _ _ s _
  | ABS _ => ABS
  | ISNAT _ => ISNAT
  | INT _ => INT
  | ADD _ _ _ _ => ADD
  | SUB _ _ _ _ => SUB
  | MUL _ _ _ _ => MUL
  | EDIV _ _ _ _ => EDIV
  | LSL _ => LSL
  | LSR _ => LSR
  | COMPARE _ _ => COMPARE
  | CONCAT _ i _ => @CONCAT _ _ i _
  | CONCAT_list _ i _ => @CONCAT_list _ _ i _
  | SIZE _ i _ => @SIZE _ _ i _
  | SLICE _ i _ => @SLICE _ _ i _
  | PAIR _ _ _ => PAIR
  | CAR _ _ _ => CAR
  | CDR _ _ _ => CDR
  | EMPTY_SET elt _ => EMPTY_SET elt
  | MEM _ _ i _ => @MEM _ _ _ i _
  | UPDATE _ _ _ i _ => @UPDATE _ _ _ _ i _
  | EMPTY_MAP x y _ => EMPTY_MAP x y
  | EMPTY_BIG_MAP x y _ => EMPTY_BIG_MAP x y
  | GET _ i _ _ => @GET _ _ i _ _
  | SOME _ _ => SOME
  | NONE a _ => NONE a
  | LEFT _ b _ => LEFT b
  | RIGHT a _ _ => RIGHT a
  | CONS _ _ => CONS
  | NIL a _ => NIL a
  | TRANSFER_TOKENS _ _ => TRANSFER_TOKENS
  | SET_DELEGATE _ => SET_DELEGATE
  | BALANCE _ => BALANCE
  | ADDRESS _ _ => ADDRESS
  | CONTRACT _ annot_opt p => CONTRACT annot_opt p
  | SOURCE _ => SOURCE
  | SENDER _ => SENDER
  | AMOUNT _ => AMOUNT
  | IMPLICIT_ACCOUNT _ => IMPLICIT_ACCOUNT
  | NOW _ => NOW
  | PACK _ _ => PACK
  | UNPACK a _ => UNPACK a
  | HASH_KEY _ => HASH_KEY
  | BLAKE2B _ => BLAKE2B
  | SHA256 _ => SHA256
  | SHA512 _ => SHA512
  | CHECK_SIGNATURE _ => CHECK_SIGNATURE
  | DIG n _ _ _ Sn => DIG n Sn
  | DUG n _ _ _ Sn => DUG n Sn
  | DROP n _ _ An => DROP n An
  | CHAIN_ID _ => CHAIN_ID
  end.

Fixpoint reconstr {self_type a b tff} (ins: instruction_seq self_type tff a b) :
  Datatypes.option (instruction_seq None tff a b) :=
  match ins with
  | NOOP _ _ => Some NOOP
  | Tail_fail _ _ _ x => omap Tail_fail (reconstr1 x)
  | SEQ _ _ _ _ _ x y =>
    obind (fun a => omap a (reconstr y)) (omap SEQ (reconstr1 x))
  end
with reconstr1 {self_type a b tff} (ins: instruction self_type tff a b) :
  Datatypes.option (instruction None tff a b) :=
  match ins with
  | Instruction_seq _ _ _ _ x =>
    omap Instruction_seq (reconstr x)
  | FAILWITH _ _ _ _ => Some FAILWITH
  | IF_ _ _ _ _ _ _ _ _ i x y =>
    obind (fun a => omap a (reconstr y)) (omap (IF_ i) (reconstr x))
  | LOOP_ _ _ _ _ _ _ i x => omap (LOOP_ i) (reconstr x)
  | PUSH t x _ _ => Some (PUSH t x)
  | LAMBDA x y _ _ _ z => omap (LAMBDA x y) (reconstr z)
  | ITER _ _ _ _ _ x => omap ITER (reconstr x)
  | MAP _ _ _ _ _ x => omap MAP (reconstr x)
  | CREATE_CONTRACT _ _ _ g p an x => Some (CREATE_CONTRACT g p an x)
  | SELF _ _ _ annot_opt H => None
  | EXEC _ _ _ _ => Some EXEC
  | DIP n _ _ _ _ An x => omap (DIP n An) (reconstr x)
  | Instruction_opcode _ _ _ op => Some (Instruction_opcode (reconstr_op op))
  end.

Open Scope michelson_scope.

Definition genprog {parameter_ty storage_ty}
           (prog: full_contract false parameter_ty None storage_ty)
           (validation_snippet: instruction_seq None false
                                                (pair bytes mutez ::: [::])
                                                (pair bytes mutez ::: [::]))
  : Datatypes.option (instruction_seq None false (pair bytes mutez ::: [::])
    (list (pair (pair syntax_type.string (lambda (pair bytes bytes)
    (pair (list operation) bytes))) (pair bytes mutez)) ::: [::])) :=
  match reconstr prog with
  | Some prog0 =>
    Some (validation_snippet;;;
         {DIP1 {NIL _};
         LAMBDA _ _
                {
                  UNPAIR; UNPACK parameter_ty;
                  IF_NONE {PUSH _ (Comparable_constant syntax_type.string "unpack param"); FAILWITH}
                          {
                            SWAP; UNPACK storage_ty;
                            IF_NONE {PUSH _ (Comparable_constant syntax_type.string "unpack storage"); FAILWITH}
                                    (SWAP;; PAIR;; prog0;;;
                                     {UNPAIR; DIP1 {PACK}; PAIR})
                          }
                };
         PUSH _ (Comparable_constant syntax_type.string "main"); PAIR; PAIR; CONS})
  | None => None
  end.

Definition initprog :
  instruction_seq None false (pair bytes mutez ::: [::])
    (lambda (map syntax_type.string address)
       (list (pair syntax_type.string bytes)) ::: [::]) :=
  {DROP1; LAMBDA _ _ {DROP1; NIL (pair _ bytes)}}.
End ccgen.