(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*                   Proof of functional correctness                   *)
(*          for the C functions implemented in the MPTBit layer        *)
(*                                                                     *)
(*                        Xiongnan (Newman) Wu                         *)
(*                                                                     *)
(*                          Yale University                            *)
(*                                                                     *)
(* *********************************************************************)
Require Import TacticsForTesting.
Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryX.
Require Import EventsX.
Require Import Globalenvs.
Require Import Locations.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import MPTInit.
Require Import ZArith.Zwf.
Require Import RealParams.
Require Import LoopProof.
Require Import VCGen.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import CompatClightSem.
Require Import PrimSemantics.
Require Import PTNewGenSpec.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import XOmega.
Require Import AbstractDataType.
Require Import MPTInitCSource.

Module MPTINITCODE.

  Section WithPrimitives.

    Context `{real_params: RealParams}.
    Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
    Context `{Hmwd: UseMemWithData memb}.

    Let mem := mwd (cdata RData).

    Context `{Hstencil: Stencil}.
    Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
    Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

    Section PTRESV2.

      Let L: compatlayer (cdata RData) := container_alloc ↦ gensem alloc_spec
           ⊕ pt_insert ↦ gensem ptInsert0_spec.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section PTResv2Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches sc ge).

        (** container_alloc *)

        Variable balloc: block.

        Hypothesis halloc1 : Genv.find_symbol ge container_alloc = Some balloc.

        Hypothesis halloc2 : Genv.find_funct_ptr ge balloc = Some (External (EF_external container_alloc (signature_of_type (Tcons tint Tnil) tint cc_default)) (Tcons tint Tnil) tint cc_default).

        (** pt_insert2 *)

        Variable bptinsert: block.

        Hypothesis hpt_insert1 : Genv.find_symbol ge pt_insert = Some bptinsert.

        Hypothesis hpt_insert2 : Genv.find_funct_ptr ge bptinsert = Some (External (EF_external pt_insert (signature_of_type (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))) tint cc_default)) (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))) tint cc_default).

        Lemma pt_resv2_body_correct: forall m d d' env le proc_index vaddr perm proc_index2 vaddr2 perm2 v,
                                      env = PTree.empty _ ->
                                      PTree.get tproc_index le = Some (Vint proc_index) ->
                                      PTree.get tvaddr le = Some (Vint vaddr) ->
                                      PTree.get tperm le = Some (Vint perm) ->
                                      PTree.get tproc_index2 le = Some (Vint proc_index2) ->
                                      PTree.get tvaddr2 le = Some (Vint vaddr2) ->
                                      PTree.get tperm2 le = Some (Vint perm2) ->
                                      ptResv2_spec (Int.unsigned proc_index) (Int.unsigned vaddr) (Int.unsigned perm) (Int.unsigned proc_index2) (Int.unsigned vaddr2) (Int.unsigned perm2) d = Some (d', Int.unsigned v) ->
                                      high_level_invariant d ->
                                      exists le',
                                        exec_stmt ge env le ((m, d): mem) pt_resv2_body E0 le' (m, d') (Out_return (Some (Vint v, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          subst.
          unfold pt_resv2_body.
          inversion H7.
          functional inversion H6; subst.
          {
            rewrite <- Int.unsigned_repr with 1048577 in H8; try omega.
            apply unsigned_inj in H8.
            rewrite <- H8.
            functional inversion H9; subst.
            {
              destruct _x.
              omega.
            }
            {
              change 0 with (Int.unsigned Int.zero) in H9.
              esplit.
              repeat vcgen.
            }
          }
          {
            rewrite <- Int.unsigned_repr with 1048577 in H8; try omega.
            apply unsigned_inj in H8.
            rewrite <- H8.
            functional inversion H9;subst.
            {
              destruct _x0.
              destruct a0.
              generalize (valid_nps H17); intro npsrange.
              esplit.
              repeat vcgen.
            }
            {
              omega.
            }
          }
          {
            functional inversion H8; subst.
            {
              destruct _x1.
              destruct a0.
              generalize (valid_nps H17); intro npsrange.
              functional inversion H10; functional inversion H28; subst; esplit; repeat vcgen.
              destruct _x2.
              destruct a1.
              simpl in a0.
              instantiate (1:= v0).
              repeat vcgen.
              discharge_cmp.
              omega.
              destruct _x2.
              destruct a1.
              simpl in a0.
              omega.
              repeat vcgen.
              repeat vcgen.
            }
            {
              omega.
            }
          }
          Grab Existential Variables.
          apply le.
          apply le.
          apply le.
        Qed.

      End PTResv2Body.

      Theorem pt_resv2_code_correct:
        spec_le (pt_resv2 ↦ ptResv2_spec_low) (〚pt_resv2 ↦ f_pt_resv2 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (pt_resv2_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_pt_resv2)
                                                               (Vint n::Vint vadr::Vint p0::Vint n'::Vint vadr'::Vint p'::nil)
                                                               (create_undef_temps (fn_temps f_pt_resv2)))) H0.
      Qed.

    End PTRESV2.

    Section PTNEW.

      Let L: compatlayer (cdata RData) := container_split ↦ gensem container_split_spec.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section PTNewBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches sc ge).

        (* parameters *)
        Variables (id quota: int).

        (** container_split *)

        Variable bsplit: block.

        Hypothesis hsplit1 : Genv.find_symbol ge container_split = Some bsplit.

        Hypothesis hsplit2 :
          Genv.find_funct_ptr ge bsplit = Some (External
            (EF_external container_split (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default))
            (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma pt_new_body_correct:
          forall m d d' env le n,
            env = PTree.empty _ ->
            pt_new_spec (Int.unsigned id) (Int.unsigned quota) d = Some (d', Int.unsigned n) ->
            le ! tid = Some (Vint id) -> le ! tquota = Some (Vint quota) ->
            exists le',
              exec_stmt ge env le ((m, d): mem) pt_new_body E0 le' (m, d') (Out_return (Some (Vint n, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          unfold pt_new_body.
          functional inversion H0.
          unfold update_cusage, update_cchildren in *; rewrite ZMap.gss in *; simpl in *.
          exists (PTree.set tchild (Vint n) le).
          repeat vcgen.
          subst; apply PTree.gempty.
          unfold container_split_spec, update_cusage, update_cchildren; subst child c i.
          repeat (match goal with
                  | [ H : ?a = _ |- context [if ?a then _ else _] ] => rewrite H
                  | [ |- context [if ?a then _ else _] ] => destruct a; try omega
                  end).
          rewrite ZMap.gss; subst.
          apply f_equal with (f:= Int.repr) in H4; rewrite Int.repr_unsigned in H4; subst.
          repeat vcgen.
        Qed.

      End PTNewBody.

      Theorem pt_new_code_correct:
        spec_le (pt_new ↦ pt_new_spec_low) (〚pt_new ↦ f_pt_new 〛L).
      Proof.
        fbigstep_pre L.
        fbigstep (pt_new_body_correct s (Genv.globalenv p) makeglobalenv id q b0 Hb0fs Hb0fp
                                      m'0 labd labd' (PTree.empty _)
                                      (bind_parameter_temps' (fn_params f_pt_new)
                                         (Vint id :: Vint q :: nil)
                                         (create_undef_temps (fn_temps f_pt_new)))) H0.
      Qed.

    End PTNEW.

    Section PTRESV.

      Let L: compatlayer (cdata RData) := container_alloc ↦ gensem alloc_spec
           ⊕ pt_insert ↦ gensem ptInsert0_spec.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section PTResvBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches sc ge).

        (** container_alloc *)

        Variable balloc: block.

        Hypothesis halloc1 : Genv.find_symbol ge container_alloc = Some balloc.

        Hypothesis halloc2 : Genv.find_funct_ptr ge balloc = Some (External (EF_external container_alloc (signature_of_type (Tcons tint Tnil) tint cc_default)) (Tcons tint Tnil) tint cc_default).

        (** pt_insert2 *)

        Variable bptinsert: block.

        Hypothesis hpt_insert1 : Genv.find_symbol ge pt_insert = Some bptinsert.

        Hypothesis hpt_insert2 : Genv.find_funct_ptr ge bptinsert = Some (External (EF_external pt_insert (signature_of_type (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))) tint cc_default)) (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))) tint cc_default).

        Lemma pt_resv_body_correct: forall m d d' env le proc_index vaddr perm v,
                                      env = PTree.empty _ ->
                                      PTree.get tproc_index le = Some (Vint proc_index) ->
                                      PTree.get tvaddr le = Some (Vint vaddr) ->
                                      PTree.get tperm le = Some (Vint perm) ->
                                      ptResv_spec (Int.unsigned proc_index)
                                                    (Int.unsigned vaddr) (Int.unsigned perm) d = Some (d', Int.unsigned v) ->
                                      high_level_invariant d ->
                                      exists le',
                                        exec_stmt ge env le ((m, d): mem) pt_resv_body E0 le' (m, d') (Out_return (Some (Vint v, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          subst.
          unfold pt_resv_body.
          inversion H4.
          functional inversion H3; subst.
          {
            rewrite <- Int.unsigned_repr with 1048577 in H5; try omega.
            apply unsigned_inj in H5.
            rewrite <- H5.
            functional inversion H6;subst.
            {
              destruct _x.
              destruct a0.
              generalize (valid_nps H12); intro npsrange.
              esplit.
              repeat vcgen.
            }
            {
              change 0 with (Int.unsigned Int.zero) in H6.
              esplit.
              repeat vcgen.
            }
          }
          {
            functional inversion H5; subst.
            {
              destruct _x0.
              destruct a0.
              generalize (valid_nps H12); intro npsrange.
              esplit.
              repeat vcgen.
            }
            {
              change 0 with (Int.unsigned Int.zero) in H5.
              esplit.
              repeat vcgen.
            }
          }
          Grab Existential Variables.
          apply le.
          apply le.
        Qed.

      End PTResvBody.

      Theorem pt_resv_code_correct:
        spec_le (pt_resv ↦ ptResv_spec_low) (〚pt_resv ↦ f_pt_resv 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (pt_resv_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_pt_resv)
                                                               (Vint n::Vint vadr::Vint p0::nil)
                                                               (create_undef_temps (fn_temps f_pt_resv)))) H0.
      Qed.

    End PTRESV.

    Section PMAPINIT.

      Let L: compatlayer (cdata RData) := pt_init ↦ gensem pt_init_spec.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Local Open Scope Z_scope.

      Section PMapInitBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches sc ge).

        (** pt_init *)

        Variable bptinit: block.

        Hypothesis hpt_init1 : Genv.find_symbol ge pt_init = Some bptinit.

        Hypothesis hpt_init2 : Genv.find_funct_ptr ge bptinit = Some (External (EF_external pt_init (signature_of_type (Tcons tint Tnil) Tvoid cc_default)) (Tcons tint Tnil) Tvoid cc_default).

        Lemma pmap_init_body_correct:
          forall m d d' env le mbi_adr,
            env = PTree.empty _ ->
            PTree.get tmbi_adr le = Some (Vint mbi_adr) ->
            pmap_init_spec (Int.unsigned mbi_adr) d = Some d' ->
            exec_stmt ge env le ((m, d): mem) pmap_init_body E0 le (m, d') Out_normal.
        Proof.
          intros; unfold pmap_init_body.
          functional inversion H1.
          change le with (set_opttemp None Vundef le); repeat vcgen.
          subst; apply PTree.gempty.
          unfold pt_init_spec.
          repeat (match goal with
                  | [ H : ?a = _ |- context[if ?a then _ else _] ] => rewrite H
                  end); auto.
        Qed.

      End PMapInitBody.

      Theorem pmap_init_code_correct:
        spec_le (pmap_init ↦ pmap_init_spec_low) (〚pmap_init ↦ f_pmap_init 〛L).
      Proof.
        fbigstep_pre L.
        fbigstep (pmap_init_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp
                                         m'0 labd labd' (PTree.empty _)
                                         (bind_parameter_temps' (fn_params f_pmap_init)
                                                                (Vint mbi_adr::nil)
                                                                (create_undef_temps (fn_temps f_pmap_init)))) H0.
      Qed.

    End PMAPINIT.

(*
    Section PTFREE.

      Let L: compatlayer (cdata RData) := set_bit ↦ gensem (fun a b d => set_pt_bit_spec d a b)
           ⊕ pt_rmv ↦ gensem (fun a b d => ptRmv_spec d a b).

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section PTFreeBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches sc ge).

        (** set_bit *)

        Variable bsetbit: block.

        Hypothesis hset_bit1 : Genv.find_symbol ge set_bit = Some bsetbit.

        Hypothesis hset_bit2 : Genv.find_funct_ptr ge bsetbit = Some (External (EF_external set_bit (signature_of_type (Tcons tint (Tcons tint Tnil)) Tvoid cc_default)) (Tcons tint (Tcons tint Tnil)) Tvoid cc_default).

        (** pt_rmv *)

        Variable bptrmv: block.

        Hypothesis hpt_rmv1 : Genv.find_symbol ge pt_rmv = Some bptrmv.

        Hypothesis hpt_rmv2 : Genv.find_funct_ptr ge bptrmv = Some (External (EF_external pt_rmv (signature_of_type (Tcons tint (Tcons tint Tnil)) Tvoid cc_default)) (Tcons tint (Tcons tint Tnil)) Tvoid cc_default).

        Definition pt_free_mk_rdata adt (i: Z) (proc_index: Z) := (mkRData (HP adt) (ti adt) (pe adt) (ikern adt) (ihost adt) (AT adt) (nps adt) (PT adt) (ZMap.set proc_index (Calculate_free_pt (Z.to_nat ((i - (kern_low * PgSize)) / PgSize)) (ZMap.get proc_index (ptpool adt))) (ptpool adt)) (ipt adt) (pb adt)).

        Section pt_free_loop_proof.

          Variable minit: memb.
          Variable proc_index: int.
          Variable adt: RData.
          Hypothesis pe : pe adt = true.
          Hypothesis ipt : ipt adt = true.
          Hypothesis ikern: ikern adt = true.
          Hypothesis ihost: ihost adt = true.
          Hypothesis indexrange: 0 < Int.unsigned proc_index < num_proc.
          Hypothesis hinv: high_level_invariant adt.

          Lemma valid_PT_kern: forall m: mem, ipt adt = true -> pe adt = true -> PT adt = 0.
          Proof.
            intros.
            remember adt as ad.
            destruct ad.
            destruct hinv.
            rewrite Heqad in *.
            apply valid_PT_kern; auto.
          Qed.

          Definition pt_free_loop_body_P (le: temp_env) (m: mem): Prop :=
            PTree.get ti le = Some (Vint (Int.repr adr_low)) /\
            PTree.get tproc_index le = Some (Vint proc_index) /\
            (forall i, adr_low <= Int.unsigned i < adr_high ->
                       exists pdt, ZMap.get (PDX (Int.unsigned i))
                                            (ZMap.get (Int.unsigned proc_index)
                                                      (ptpool adt)) = PDTValid pdt) /\
            m = (minit, adt).

          Definition pt_free_loop_body_Q (le : temp_env) (m: mem): Prop :=
            m = (minit, pt_free_mk_rdata adt (adr_high - PgSize) (Int.unsigned proc_index)).

          Lemma pt_free_loop_correct_aux : LoopProofSimpleWhile.t pt_free_while_condition pt_free_while_body ge (PTree.empty _) (pt_free_loop_body_P) (pt_free_loop_body_Q).
          Proof.
            generalize max_unsigned_val; intro muval.
            generalize adr_low_val; intro adrlowval.
            generalize adr_high_val; intro adrhighval.
            apply LoopProofSimpleWhile.make with
            (W := Z)
              (lt := fun z1 z2 => (0 <= z2 /\ z1 < z2)%Z)
              (I := fun le (m: mem) w => exists i,
                                           PTree.get ti le = Some (Vint i) /\
                                           PTree.get tproc_index le = Some (Vint proc_index) /\
                                           ipt adt = true /\
                                           pe adt = true /\
                                           ihost adt = true /\
                                           (forall i, adr_low <= Int.unsigned i < adr_high ->
                                                      exists pdt, ZMap.get (PDX (Int.unsigned i))
                                                                           (ZMap.get (Int.unsigned proc_index)
                                                                                (ptpool adt)) = PDTValid pdt) /\
                                           (Int.unsigned i = adr_low /\ m = (minit, adt) \/ Int.unsigned i > adr_low /\ m = (minit, pt_free_mk_rdata adt (Int.unsigned i - PgSize) (Int.unsigned proc_index))) /\
                                           adr_low <= Int.unsigned i <= adr_high /\
                                           (PgSize | Int.unsigned i) /\
                                           w = adr_high - Int.unsigned i
              )
            .
            apply Zwf_well_founded.
            intros.
            unfold pt_free_loop_body_P in H.
            destruct H as [tile tmpH].
            destruct tmpH as [tprocindexle tmpH].
            destruct tmpH as [pdtvalid msubst].
            subst.
            esplit. esplit.
            repeat vcgen.
            unfold Z.divide.
            exists 262144.
            omega.
            intros.
            destruct H as [i tmpH].
            destruct tmpH as [tile tmpH].
            destruct tmpH as [tprocindexle tmpH].
            destruct tmpH as [nipt tmpH].
            destruct tmpH as [npe tmpH].
            destruct tmpH as [nihost tmpH].
            destruct tmpH as [pdtvalid tmpH].
            destruct tmpH as [mcase tmpH].
            destruct tmpH as [irange tmpH].
            destruct tmpH as [idiv nval].
            subst.
            unfold pt_free_while_condition.
            unfold pt_free_while_body.
            destruct irange as [ilow ihigh].
            apply Zle_lt_or_eq in ihigh.
            destruct m.
            Caseeq ihigh.

            (* i < adr_high *)
            intro ihigh.

            assert(icrange: adr_low <= Int.unsigned i < adr_high) by omega.
            generalize (pdtvalid i icrange); intro pdtvalidi.
            destruct pdtvalidi as [pdt pdtvalidi].
            generalize (valid_PT_kern (m, adt) nipt npe); intro pt.

            Caseeq mcase.

            (* i = adr_low *)
            intro tmpH.
            destruct tmpH as [jval msubst].
            rewrite jval.
            injection msubst; intros; subst.

            esplit. esplit.
            repeat vcgen.
            esplit. esplit.
            repeat vcgen.
            unfold ptRmv_spec.
            rewrite ikern, pe, ihost, ipt, pdtvalidi.
            unfold ptRmv_Arg.
            repeat zdestruct.
            exists (adr_high - adr_low - PgSize).
            repeat vcgen.
            esplit.
            Opaque Z.sub PTree.set "!".
            simpl.
            Transparent Z.sub.
            repeat vcgen.
            right.
            split.
            omega.
            assert(1073741824 <= Int.unsigned i + 4096 - 4096 < 4026531840) by omega.
            f_equal.
            unfold pt_free_mk_rdata.
            rewrite jval in *.
            simpl.
            unfold Calculate_free_pt_at_i.
            rewrite pdtvalidi.
            rewrite ipt, ihost, ikern, pe.
            reflexivity.
            unfold Z.divide in *.
            destruct idiv as [z idiv].
            exists (z + 1).
            omega.

            (* i > adr_low *)
            intro tmpH.
            destruct tmpH as [igt tmpH].
            injection tmpH; intros; subst.

            assert (exists pdt, ZMap.get (PDX (Int.unsigned i))
                                         (Calculate_free_pt
                                            (Z.to_nat ((Int.unsigned i - 4096 - 1073741824) / 4096))
                                            (ZMap.get (Int.unsigned proc_index) (ptpool adt))) = PDTValid pdt).
              set (ni:= Z.to_nat ((Int.unsigned i - 4096 - 1073741824) / 4096)).
              induction ni.
              (* ni = 0 *)
              simpl.
              unfold Calculate_free_pt_at_i.
              assert(exists pdt : PTE,
               ZMap.get (PDX 1073741824)
                 (ZMap.get (Int.unsigned proc_index) (ptpool adt)) =
               PDTValid pdt).
                rewrite <- Int.unsigned_repr with (1073741824); try omega.
                apply pdtvalid; auto.
                rewrite Int.unsigned_repr with (1073741824); try omega.
              destruct H.
              rewrite H.
              assert(icase: PDX (Int.unsigned i) = PDX 1073741824 \/ PDX (Int.unsigned i) <> PDX 1073741824) by omega.
              Caseeq icase.
              (* PDX i0 = PDX i *)
              intro ieqi.
              rewrite ieqi.
              rewrite ZMap.gss.
              esplit.
              reflexivity.
              (* PDX i0 <> PDX i *)
              intro ineqi.
              rewrite ZMap.gso.
              apply pdtvalid.
              assumption.
              assumption.
              (* ni = S ni' *)
              Opaque Z.of_nat.
              simpl.
              unfold Calculate_free_pt_at_i.
              destruct (ZMap.get (PDX (Z.of_nat (S ni) * 4096 + 1073741824))
           (Calculate_free_pt ni
              (ZMap.get (Int.unsigned proc_index) (ptpool adt)))).
              assert(icase: PDX (Int.unsigned i) = PDX (Z.of_nat (S ni) * 4096 + 1073741824) \/ PDX (Int.unsigned i) <> PDX (Z.of_nat (S ni) * 4096 + 1073741824)) by omega.
              Caseeq icase.
              (* PDX i0 = PDX i *)
              intro ieqi.
              rewrite ieqi.
              rewrite ZMap.gss.
              esplit.
              reflexivity.
              (* PDX i0 <> PDX i *)
              intro ineqi.
              rewrite ZMap.gso.
              assumption.
              assumption.
              assumption.
            destruct H.

            esplit. esplit.
            split.
            repeat vcgen.
            split.
            repeat vcgen.
            split.
            intro contra; discriminate contra.
            intro.
            esplit. esplit.
            repeat vcgen.
            unfold ptRmv_spec.
            simpl.
            rewrite ZMap.gss.
            rewrite ikern, pe, ihost, ipt.
            unfold ptRmv_Arg.
            repeat zdestruct.
            rewrite H.
            reflexivity.

            exists (adr_high - Int.unsigned i - PgSize).
            repeat vcgen.
            esplit.
            repeat vcgen.
            right.
            split.
            omega.
            assert (irangenew: adr_low <= Int.unsigned i + 4096 - 4096 < adr_high) by omega.
            f_equal.
            unfold pt_free_mk_rdata.
            rewrite ZMap.set2.
            simpl.
            assert(tmp: ((Int.unsigned i + 4096 - 4096 - 1073741824) / 4096) = (Int.unsigned i - 4096 - 1073741824) / 4096 + 1).
            rewrite <- Z_div_plus_full.
            assert (tmp1: Int.unsigned i + 4096 - 4096 - 1073741824 = Int.unsigned i - 1073741824) by omega.
            assert (tmp2: Int.unsigned i - 4096 - 1073741824 + 1 * 4096 = Int.unsigned i - 1073741824) by omega.
            rewrite tmp1, tmp2.
            trivial.
            omega.
            rewrite tmp.
            change ((Int.unsigned i - 4096 - 1073741824) / 4096 + 1) with (Z.succ ((Int.unsigned i - 4096 - 1073741824) / 4096)).
            rewrite Z2Nat.inj_succ.
            Opaque Z.of_nat.
            simpl.
            rewrite Nat2Z.inj_succ.
            rewrite Z2Nat.id.
            unfold Z.succ.
            unfold Calculate_free_pt_at_i.
            assert(tmp2: (((Int.unsigned i - 4096 - 1073741824) / 4096 + 1) *
                          4096 + 1073741824) = Int.unsigned i).
            rewrite <- Z_div_plus_full.
            replace (Int.unsigned i - 4096 - 1073741824 + 1 * 4096) with (Int.unsigned i - 1073741824) by omega.
            destruct idiv as [z idiv].
            rewrite idiv.
            replace 1073741824 with (262144 * 4096) by omega.
            rewrite <- Z.mul_sub_distr_r.
            rewrite Z_div_mult_full.
            rewrite <- Z.mul_add_distr_r.
            replace (z - 262144 + 262144) with z by omega.
            trivial.
            omega.
            omega.
            rewrite tmp2.
            simpl in H.
            rewrite H.
            rewrite pe, ikern, ihost, ipt.
            reflexivity.
            repeat discharge_unsigned_range.
            repeat discharge_unsigned_range.
            repeat discharge_unsigned_range.
            apply Z_div_pos; try omega.
            destruct idiv as [z idiv].
            rewrite idiv in *.
            omega.
            apply Z_div_pos; try omega.
            destruct idiv as [z idiv].
            rewrite idiv in *.
            omega.
            destruct idiv as [z idiv].
            rewrite idiv in *.
            omega.
            destruct idiv as [z idiv].
            rewrite idiv.
            unfold Z.divide.
            exists (z + 1).
            omega.

            (* j = adr_high *)
            intro jeqadrhigh.
            esplit. esplit.
            repeat vcgen.
            unfold pt_free_loop_body_Q.
            Caseeq mcase.
            intro tmpH.
            destruct tmpH.
            omega.
            intro tmpH.
            rewrite jeqadrhigh in tmpH.
            destruct tmpH as [ihigh' tmpH].
            assumption.
          Qed.

        End pt_free_loop_proof.

          Lemma pt_free_loop_correct: forall m d d' le proc_index,
                                        pe d = true ->
                                        ipt d = true ->
                                        ikern d = true ->
                                        ihost d = true ->
                                        0 < Int.unsigned proc_index < num_proc ->
                                        high_level_invariant d ->
                                        PTree.get ti le = Some (Vint (Int.repr adr_low)) ->
                                        PTree.get tproc_index le = Some (Vint proc_index) ->
                                        (forall i, adr_low <= Int.unsigned i < adr_high ->
                                                   exists pdt, ZMap.get (PDX (Int.unsigned i))
                                                                        (ZMap.get (Int.unsigned proc_index)
                                                                                (ptpool d)) = PDTValid pdt) ->
                                        d' = pt_free_mk_rdata d (adr_high - PgSize) (Int.unsigned proc_index) ->
                                        exists le', exec_stmt ge (PTree.empty _) le ((m, d): mem) (Swhile pt_free_while_condition pt_free_while_body) E0 le' (m, d') Out_normal.
          Proof.
            intros m d d' le proc_index pe ipt ikern ihost indexrange hinv tile tindexle pdtvalid d'val.
            generalize (pt_free_loop_correct_aux m proc_index d pe ipt ikern ihost indexrange hinv).
            intro LP.
            refine (_ (LoopProofSimpleWhile.termination _ _ _ _ _ _ LP le (m, d) _)).
            intro pre.
            destruct pre as [le'' pre].
            destruct pre as [m'' pre].
            destruct pre as [pre1 pre2].
            unfold pt_free_loop_body_Q in pre2.
            subst.
            esplit.
            eassumption.
            unfold pt_free_loop_body_P.
            eauto.
          Qed.

        Lemma pt_free_body_correct: forall m d d' env le proc_index,
                                      env = PTree.empty _ ->
                                      PTree.get tproc_index le = Some (Vint proc_index) ->
                                      pt_free_spec d (Int.unsigned proc_index) = Some d' ->
                                      high_level_invariant d ->
                                      exists le',
                                        exec_stmt ge env le ((m, d): mem) pt_free_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          subst.
          unfold pt_free_body.
          functional inversion H1.
          subst.

          set (di:= {|
                     HP := HP d;
                     ti := ti d;
                     pe := pe d;
                     ikern := ikern d;
                     ihost := ihost d;
                     AT := AT d;
                     nps := nps d;
                     PT := PT d;
                     ptpool := ptpool d;
                     ipt := ipt d;
                     pb := ZMap.set (Int.unsigned proc_index) PTFalse (pb d) |}).
          exploit (pt_free_loop_correct m di (pt_free_mk_rdata di (4026531840 - 4096) (Int.unsigned proc_index)) (PTree.set ti (Vint (Int.repr adr_low)) (set_opttemp None Vundef le)) proc_index); repeat vcgen.
          generalize set_bit_inv; intro.
          inversion H.
          eapply semprops_high_level_invariant; auto.
          instantiate  (2:= d).
          repeat econstructor.
          instantiate (2:= proc_index).
          instantiate (1:= (Int.repr 0)).
          unfold set_pt_bit_spec.
          unfold di.
          rewrite H3, H4, H5.
          unfold ZtoPTBit.
          repeat zdestruct.
          assumption.
          unfold di; simpl.
          destruct H2.
          rewrite H6 in valid_PT_common.
          exploit (valid_PT_common refl_equal (Int.unsigned proc_index)).
          omega.
          intro.
          destruct H2.
          unfold PDT_usr in H10.
          unfold PDT_valid in H10.
          unfold PDX in *.
          generalize (H10 (Int.unsigned i / 4096)); intro.
          rewrite <- Zdiv_Zdiv in H11; try omega.
          rewrite <- Zdiv_Zdiv; try omega.
          rewrite Z_div_mult_full in H11; try omega.
          apply H11.
          generalize H; clear; intro.
          xomega.
          destruct H as [le' stmt].

          esplit.
          repeat vcgen.
          unfold set_pt_bit_spec, di.
          rewrite H3, H4, H5.
          unfold ZtoPTBit.
          repeat zdestruct.
        Qed.

      End PTFreeBody.

      Theorem pt_free_code_correct:
        spec_le (pt_free ↦ pt_free_spec_low) (〚pt_free ↦ f_pt_free 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (pt_free_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_pt_free)
                                                               (Vint n::nil)
                                                               (create_undef_temps (fn_temps f_pt_free)))) H0.
      Qed.

    End PTFREE.

*)

  End WithPrimitives.

End MPTINITCODE.


From Coq Require Import Logic.FinFun.
From Coq Require Import Lists.List.
From Coq Require Import micromega.Lia.
From Coq Require Import ZArith.ZArith.

From VST Require Import floyd.proofauto.

From CertiGraph Require Import graph.graph_gen.
From CertiGraph Require Import graph.graph_model.
From CertiGraph Require Import lib.EquivDec_ext.
From CertiGraph Require Import lib.List_ext.

From CertiGC Require Import model.compatible.compatible.
From CertiGC Require Import model.constants.
From CertiGC Require Import model.heap.heap.
From CertiGC Require Import model.heapgraph.block.block.
From CertiGC Require Import model.heapgraph.block.ptr.
From CertiGC Require Import model.heapgraph.block.cell.
From CertiGC Require Import model.heapgraph.block.field.
From CertiGC Require Import model.heapgraph.field_pairs.
From CertiGC Require Import model.heapgraph.generation.generation.
From CertiGC Require Import model.heapgraph.graph.
From CertiGC Require Import model.heapgraph.has_block.
From CertiGC Require Import model.heapgraph.has_field.
From CertiGC Require Import model.heapgraph.mark.
From CertiGC Require Import model.heapgraph.predicates.
From CertiGC Require Import model.heapgraph.remset.remset.
From CertiGC Require Import model.heapgraph.roots.
From CertiGC Require Import model.op.do_generation.
From CertiGC Require Import model.op.forward.
From CertiGC Require Import model.op.reset.
From CertiGC Require Import model.op.scan.
From CertiGC Require Import model.thread_info.thread_info.
From CertiGC Require Import model.util.

Definition new_gen_relation (gen: nat) (g1 g2: HeapGraph):
    Prop
 := if heapgraph_has_gen_dec g1 gen
    then g1 = g2
    else exists gen_i: Generation, generation_block_count gen_i = O /\ g2 = heapgraph_generations_append g1 gen_i
.

Inductive garbage_collect_loop (f_info : fun_info)
  : list nat -> roots_t -> HeapGraph -> roots_t -> HeapGraph -> Prop :=
  gcl_nil: forall g roots, garbage_collect_loop f_info nil roots g roots g
| gcl_cons: forall (g1 g2 g3 g4: HeapGraph) (i: nat) (il: list nat)
                   (roots1 roots2 roots3: roots_t),
    new_gen_relation (S i) g1 g2 ->
    do_generation_relation i (S i) f_info roots1 roots2 g2 g3 ->
    garbage_collect_loop f_info il roots2 g3 roots3 g4 ->
    garbage_collect_loop f_info (i :: il) roots1 g1 roots3 g4.

Definition garbage_collect_relation (f_info: fun_info)
           (roots1 roots2: roots_t) (g1 g2: HeapGraph): Prop :=
  exists n, garbage_collect_loop f_info (nat_inc_list (S n)) roots1 g1 roots2 g2 /\
            heapgraph_generation_can_copy g2 n (S n).

Definition garbage_collect_condition (g: HeapGraph) (t_info : thread_info)
           (roots : roots_t) (f_info : fun_info) : Prop :=
  graph_unmarked g /\ no_backward_edge g /\ no_dangling_dst g /\
  roots_fi_compatible roots f_info /\ ti_size_spec t_info.

Local Open Scope Z_scope.

Lemma gcc_add: forall g ti gi sp i (Hs: 0 <= i < MAX_SPACES) roots fi,
    generation_block_count gi = O -> space_capacity sp = generation_size (Z.to_nat i) ->
    garbage_collect_condition g ti roots fi ->
    garbage_collect_condition (heapgraph_generations_append g gi)
                              (ti_add_new_space ti sp i Hs) roots fi.
Proof.
  intros. destruct H1 as [? [? [? [? ?]]]]. split; [|split; [|split; [|split]]].
  - apply graph_unmarked_add; assumption.
  - apply no_backward_edge_add; assumption.
  - apply no_dangling_dst_add; assumption.
  - assumption.
  - apply ti_size_spec_add; assumption.
Qed.

Lemma gc_cond_implies_do_gen_cons: forall g t_info roots f_info i,
    heapgraph_can_copy_except g i ->
    heapgraph_has_gen g (S i) ->
    graph_thread_info_compatible g t_info ->
    garbage_collect_condition g t_info roots f_info ->
    do_generation_condition g t_info roots f_info i (S i).
Proof.
  intros.
  destruct H2 as [? [? [? [? ?]]]].
  assert (heapgraph_has_gen g i) by (unfold heapgraph_has_gen in H0 |-*; lia).
  split; [|split; [|split; [|split; [|split; [|split; [|split]]]]]]; auto.
  - unfold heapgraph_can_copy_except, heapgraph_generation_can_copy in H.
    red.
    unfold rest_gen_size.
    specialize (H (S i) ltac:(lia) ltac:(lia) H0) ; simpl in H.
    pose proof (generation__space__compatible__remembered (gt_gs_compatible _ _ H1 _ H0)) as HSi_remembered.
    pose proof (generation__space__compatible__allocated (gt_gs_compatible _ _ H1 _ H0)) as HSi_allocated.
    pose proof (generation__space__compatible__allocated (gt_gs_compatible _ _ H1 _ H7)) as Hallocated.
    simpl in HSi_remembered, HSi_allocated, Hallocated.
    fold (gen_size t_info (S i)).
    pose proof (proj2 (space__order (nth_space t_info i))) as Horder.
    fold (gen_size t_info i) in Horder.
    unfold heapgraph_generation_size.
    rewrite Hallocated. clear Hallocated.
    transitivity (gen_size t_info i).
    {
      pose proof (space_remembered__lower_bound (nth_space t_info i)).
      lia.
    }
    rewrite (ti_size_gen _ _ _ H1 H7 H6), (ti_size_gen _ _ _ H1 H0 H6).
    unfold heapgraph_generation_size in H.
    rewrite HSi_allocated in H ; clear HSi_allocated.
    unfold heapgraph_remember_size in H.
    rewrite HSi_remembered in H ; clear HSi_remembered.
    assumption.
  - now apply graph_unmarked_copy_compatible.
  - unfold heapgraph_can_copy_except, heapgraph_generation_can_copy in H.
    specialize (H (S i) ltac:(lia) ltac:(lia) ltac:(easy)).
    replace
      (Init.Nat.pred (S i))
      with i
      in H
      by lia.
    pose proof (ngs_0_lt i) as H8.
    pose proof (ngs_0_lt (S i)) as H9.
    rewrite (ti_size_gen _ _ _ H1 H0 H6).
    replace
      (heapgraph_generation_size g (S i))
      with (space_allocated (nth_space t_info (S i)))
      in H.
    2: {
      pose proof (gt_gs_compatible _ _ H1 _ H0) as H10.
      apply generation__space__compatible__allocated in H10.
      now simpl in H10.
    }
    replace
      (heapgraph_remember_size g (S i))
      with (space_remembered (nth_space t_info (S i)))
      in H.
    2: {
      pose proof (gt_gs_compatible _ _ H1 _ H0) as H10.
      apply generation__space__compatible__remembered in H10.
      now simpl in H10.
    }
    pose proof (space_allocated__order (nth_space t_info (S i))) as H10.
    lia.
  - rewrite graph_heapgraph_generation_is_unmarked_iff in H2.
    apply H2.
Qed.

Lemma do_gen_gcc: forall g1 t_info1 roots1 g2 t_info2 roots2 f_info i out,
    super_compatible (g1, t_info1, roots1) f_info out ->
    firstn_gen_clear g1 i -> heapgraph_has_gen g1 (S i) ->
    thread_info_relation t_info1 t_info2 ->
    garbage_collect_condition g1 t_info1 roots1 f_info ->
    do_generation_relation i (S i) f_info roots1 roots2 g1 g2 ->
    garbage_collect_condition g2 t_info2 roots2 f_info.
Proof.
  intros. destruct H3 as [? [? [? [? ?]]]].
  assert (heapgraph_generation_is_unmarked g1 (S i)) by (rewrite graph_heapgraph_generation_is_unmarked_iff in H3; apply H3).
  assert (no_dangling_dst g2). {
    eapply do_gen_no_dangling_dst; eauto.
    - apply graph_unmarked_copy_compatible; assumption.
    - apply (proj1 H7).
    - destruct H as [_ [_ [[_ ?] _]]]. assumption. }
  split; [|split; [|split; [|split]]]; auto.
  - eapply do_gen_graph_unmarked; eauto.
  - eapply do_gen_no_backward_edge; eauto.
  - destruct H4 as [g3 [g4 [? _]]]. eapply frr_roots_fi_compatible; eauto.
  - eapply ti_relation_size_spec; eauto.
Qed.

Lemma do_gen_stcte: forall g1 roots1 g2 roots2 f_info i,
    heapgraph_can_copy_except g1 i -> heapgraph_has_gen g1 (S i) ->
    do_generation_relation i (S i) f_info roots1 roots2 g1 g2 ->
    heapgraph_can_copy_except g2 (S i).
Proof.
  intros. unfold heapgraph_can_copy_except in *. intros.
  destruct H1 as [g3 [g4 [? [? ?]]]]. destruct (Nat.eq_dec n i).
  - subst. red. unfold heapgraph_generation_size, heapgraph_generation. simpl.
    rewrite reset_heapgraph_generation_info_same. simpl. unfold heapgraph_block_size_prev.
    simpl. destruct i. 1: contradiction. simpl. rewrite Z.sub_0_r.
    pose proof (generation_size_le_S i).
    now rewrite reset_graph_remember_size_zero.
  - subst g2. apply reset_stct; auto. destruct H5 as [m [? ?]].
    rewrite graph_has_gen_reset in H4.
    assert (heapgraph_has_gen g3 (S i)) by (erewrite <- frr_graph_has_gen; eauto).
    assert (heapgraph_has_gen g3 n) by (erewrite svwl_graph_has_gen; eauto).
    eapply (svwl_stcg i (S i) _ g3); eauto.
    assert (heapgraph_has_gen g1 n) by (erewrite frr_graph_has_gen; eauto).
    eapply (frr_stcg i (S i) _ _ g1); eauto.
Qed.

Lemma gcl_add_tail: forall l g1 roots1 g2 roots2 g3 roots3 g4 f_info i,
    garbage_collect_loop f_info l roots1 g1 roots2 g2 ->
    new_gen_relation (S i) g2 g3 ->
    do_generation_relation i (S i) f_info roots2 roots3 g3 g4 ->
    garbage_collect_loop f_info (l +:: i) roots1 g1 roots3 g4.
Proof.
  induction l; intros.
  - simpl. inversion H. subst. eapply gcl_cons; eauto. constructor.
  - inversion H. subst. clear H. simpl app. eapply gcl_cons; eauto.
Qed.


Require Import Omega.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import Loc.

Require Import Time.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import FulfillStep.
Require Import MemoryReorder.
Require Import MemorySplit.
Require Import MemoryMerge.

Set Implicit Arguments.

Definition VIEW_CMP := forall (loc:Loc.t) (ts:Time.t) (lhs rhs:option View.t), Prop.

Definition loctmeq: VIEW_CMP := fun _ _ (r1 r2: option View.t) => r1 = r2.
Hint Unfold loctmeq.

Definition mem_sub (cmp: VIEW_CMP) (m1 m2: Memory.t) : Prop :=
  forall loc ts from val rel1
    (IN: Memory.get loc ts m1 = Some (from, Message.mk val rel1)),
  exists rel2,
  <<IN: Memory.get loc ts m2 = Some (from, Message.mk val rel2)>> /\
  <<CMP: cmp loc ts rel1 rel2>>.

Definition mem_eqrel (cmp: VIEW_CMP) (m1 m2: Memory.t) : Prop :=
  <<LR: mem_sub cmp m1 m2>> /\
  <<RL: mem_sub (fun l t x y => cmp l t y x) m2 m1>>.
Hint Unfold mem_eqrel.

Definition mem_eqlerel (m1 m2: Memory.t) : Prop :=
  mem_eqrel (fun _ _ => View.opt_le) m1 m2.
Hint Unfold mem_eqlerel.

Program Instance mem_eqlerel_PreOrder: PreOrder mem_eqlerel.
Next Obligation.
  ii. econs; ii; esplits; eauto; refl.
Qed.
Next Obligation.
  ii. inv H. inv H0. des. econs; ii.
  - exploit H1; eauto. i. des.
    exploit H; eauto. i. des.
    esplits; eauto. etrans; eauto.
  - exploit H3; eauto. i. des.
    exploit H2; eauto. i. des.
    esplits; eauto. etrans; eauto.
Qed.

Lemma mem_eqlerel_get
      m1 m2
      l f t v r2
      (LE: mem_eqlerel m1 m2)
      (GET2: Memory.get l t m2 = Some (f, Message.mk v r2)):
  exists r1,
    <<GET1: Memory.get l t m1 = Some (f, Message.mk v r1)>> /\
    <<REL: View.opt_le r1 r2>>.
Proof. inv LE. des. exploit H0; eauto. Qed.

Lemma mem_eqrel_closed_timemap
      cmp tm m1 m2
      (EQMEM: mem_eqrel cmp m1 m2)
      (CLOSED: Memory.closed_timemap tm m1):
  Memory.closed_timemap tm m2.
Proof.
  ii. specialize (CLOSED loc). des.
  apply EQMEM in CLOSED. des.
  esplits; eauto.
Qed.

Lemma mem_eqrel_closed_view
      cmp cap m1 m2
      (EQMEM: mem_eqrel cmp m1 m2)
      (CLOSED: Memory.closed_view cap m1):
  Memory.closed_view cap m2.
Proof.
  inv CLOSED. econs; eapply mem_eqrel_closed_timemap; eauto.
Qed.

Lemma mem_eqrel_closed_opt_view
      cmp cap m1 m2
      (EQMEM: mem_eqrel cmp m1 m2)
      (CLOSED: Memory.closed_opt_view cap m1):
  Memory.closed_opt_view cap m2.
Proof.
  inv CLOSED; econs. eapply mem_eqrel_closed_view; eauto.
Qed.

Lemma mem_eqrel_closed_tview
      cmp tview m1 m2
      (EQMEM: mem_eqrel cmp m1 m2)
      (CLOSED: TView.closed tview m1):
  TView.closed tview m2.
Proof.
  inv CLOSED. econs; i; eapply mem_eqrel_closed_view; eauto.
Qed.

Lemma lower_mem_eqlerel
      m1 loc from to val r1 r2 m2
      (LOWER: Memory.lower m1 loc from to val r1 r2 m2):
  mem_eqlerel m2 m1.
Proof.
  econs; ii.
  - revert IN. erewrite Memory.lower_o; eauto. condtac; ss.
    + i. des. inv IN. exploit Memory.lower_get0; eauto. i. esplits; eauto.
      inv LOWER. inv LOWER0. auto.
    + i. esplits; eauto. refl.
  - erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst. revert IN. erewrite Memory.lower_get0; eauto. i. inv IN.
      esplits; eauto. inv LOWER. inv LOWER0. auto.
    + esplits; eauto. refl.
Qed.

Lemma mem_eqrel_memory_op
      m1 m2 m1' m2' released1 released2 kind1 kind2
      cmp
      loc from to val
      (EQMEM: mem_eqrel cmp m1 m2)
      (OP1: Memory.op m1 loc from to val released1 m1' kind1)
      (OP2: Memory.op m2 loc from to val released2 m2' kind2):
  Memory.op_kind_match kind1 kind2.
Proof.
  inv OP1; inv OP2; try by econs.
  - exploit Memory.split_get0; eauto. i. des.
    apply EQMEM in GET3. des.
    inv ADD. inv ADD0. exfalso. eapply DISJOINT; eauto.
    + apply Interval.mem_ub. auto.
    + inv SPLIT. inv SPLIT0. econs; auto. left. auto.
  - exploit Memory.lower_get0; eauto. i.
    apply EQMEM in x0. des.
    erewrite Memory.add_get0 in IN; eauto. congr.
  - exploit Memory.split_get0; eauto. i. des.
    apply EQMEM in GET3. des.
    inv ADD. inv ADD0. exfalso. eapply DISJOINT; eauto.
    + apply Interval.mem_ub. auto.
    + inv SPLIT. inv SPLIT0. econs; auto. left. auto.
  - exploit Memory.split_get0; try exact SPLIT; eauto. i. des.
    apply EQMEM in GET3. des.
    exploit Memory.split_get0; eauto. i. des.
    exploit MemoryFacts.get_same_from; [exact IN|exact GET3|..].
    { ii. subst. inv SPLIT. inv SPLIT1. inv TS23. }
    { ii. subst. inv SPLIT0. inv SPLIT1. inv TS23. }
    i. des. inv x1. econs; ss.
  - exploit Memory.lower_get0; eauto. i.
    apply EQMEM in x0. des.
    exploit Memory.split_get0; eauto. i. des. congr.
  - exploit Memory.lower_get0; eauto. i.
    apply EQMEM in x0. des.
    erewrite Memory.add_get0 in IN; eauto. congr.
  - exploit Memory.lower_get0; eauto. i.
    apply EQMEM in x0. des.
    exploit Memory.split_get0; eauto. i. des. congr.
Qed.

Lemma mem_eqlerel_add
      loc from to val released
      m1 m2 m2'
      (MEMLE: mem_eqlerel m1 m2)
      (ADD2: Memory.add m2 loc from to val released m2'):
  exists m1',
    <<ADD1: Memory.add m1 loc from to val released m1'>> /\
    <<MEMLE': mem_eqlerel m1' m2'>>.
Proof.
  exploit (@Memory.add_exists m1 loc from to);
    try by inv ADD2; inv ADD; eauto.
  { i. destruct msg2. eapply MEMLE in GET2. des.
    inv ADD2. inv ADD. eapply DISJOINT. eauto.
  }
  i. des. esplits; eauto.
  econs; splits; ii; revert IN.
  - erewrite Memory.add_o; eauto. erewrite (@Memory.add_o m2'); eauto.
    condtac; ss.
    + i. des. inv IN. esplits; eauto. refl.
    + i. eapply MEMLE. eauto.
  - erewrite Memory.add_o; eauto. erewrite (@Memory.add_o mem2); eauto.
    condtac; ss.
    + i. des. inv IN. esplits; eauto. refl.
    + i. eapply MEMLE. eauto.
Qed.

Lemma mem_eqlerel_split
      loc ts1 ts2 ts3 val2 val3 released2 released3
      m1 m2 m2' prm prm'
      (MEMLE: mem_eqlerel m1 m2)
      (PRM1: Memory.le prm m1)
      (SPLIT2: Memory.split m2 loc ts1 ts2 ts3 val2 val3 released2 released3 m2')
      (SPLITP2: Memory.split prm loc ts1 ts2 ts3 val2 val3 released2 released3 prm'):
  exists m1',
    <<SPLIT2: Memory.split m1 loc ts1 ts2 ts3 val2 val3 released2 released3 m1'>> /\
    <<MEMLE': mem_eqlerel m1' m2'>>.
Proof.
  exploit Memory.split_get0; eauto. i. des. apply PRM1 in GET3.
  exploit (@Memory.split_exists m1 loc ts1 ts2 ts3);
    try by inv SPLIT2; inv SPLIT; eauto. i. des.
  esplits; eauto.
  econs; splits; ii; revert IN.
  - erewrite Memory.split_o; eauto. erewrite (@Memory.split_o m2'); eauto.
    repeat condtac; ss.
    + i. des. inv IN. esplits; eauto. refl.
    + guardH o. i. des. inv IN. esplits; eauto. refl.
    + eapply MEMLE.
  - erewrite Memory.split_o; eauto. erewrite (@Memory.split_o mem2); eauto.
    repeat condtac; ss.
    + i. des. inv IN. esplits; eauto. refl.
    + guardH o. i. des. inv IN. esplits; eauto. refl.
    + eapply MEMLE.
Qed.

Lemma mem_eqlerel_lower
      loc from to val released1 released2
      m1 m2 m2' prm prm'
      (MEMLE: mem_eqlerel m1 m2)
      (PRM1: Memory.le prm m1)
      (LOWER2: Memory.lower m2 loc from to val released1 released2 m2')
      (LOWERP2: Memory.lower prm loc from to val released1 released2 prm'):
  exists m1',
    <<LOWER1: Memory.lower m1 loc from to val released1 released2 m1'>> /\
    <<MEMLE': mem_eqlerel m1' m2'>>.
Proof.
  exploit Memory.lower_get0; eauto. i. apply PRM1 in x0.
  exploit (@Memory.lower_exists m1 loc from to val released1 released2);
    try by inv LOWER2; inv LOWER; eauto; try by viewtac. i. des.
  esplits; eauto.
  econs; esplits; ii; revert IN.
  - erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o m2'); eauto.
    condtac; ss.
    + i. des. inv IN. esplits; eauto. refl.
    + eapply MEMLE.
  - erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o mem2); eauto.
    condtac; ss.
    + i. des. inv IN. esplits; eauto. refl.
    + eapply MEMLE.
Qed.

Lemma mem_eqlerel_promise
      loc from to val released kind
      m1 m2 m2' prm prm'
      (MEMLE: mem_eqlerel m1 m2)
      (PRM1: Memory.le prm m1)
      (PROMISE2: Memory.promise prm m2 loc from to val released prm' m2' kind):
  exists m1',
    <<PROMISE1: Memory.promise prm m1 loc from to val released prm' m1' kind>> /\
    <<MEMLE': mem_eqlerel m1' m2'>>.
Proof.
  inv PROMISE2.
  - exploit mem_eqlerel_add; eauto. i. des.
    esplits; eauto. econs; eauto.
  - exploit mem_eqlerel_split; eauto. i. des.
    esplits; eauto. econs; eauto.
  - exploit mem_eqlerel_lower; eauto. i. des.
    esplits; eauto. econs; eauto.
Qed.

Lemma mem_eqlerel_add_forward
      loc from to val released1 released2
      m1 m2 m2'
      (MEMLE: mem_eqlerel m2 m1)
      (ADD2: Memory.add m2 loc from to val released2 m2')
      (RELLE: View.opt_le released2 released1)
      (RELWF: View.opt_wf released1):
  exists m1',
    <<ADD1: Memory.add m1 loc from to val released1 m1'>> /\
    <<MEMLE': mem_eqlerel m2' m1'>>.
Proof.
  exploit (@Memory.add_exists m1 loc from to); eauto;
    try by inv ADD2; inv ADD; eauto.
  { i. destruct msg2. eapply MEMLE in GET2. des.
    inv ADD2. inv ADD. eapply DISJOINT. eauto.
  }
  i. des. esplits; eauto.
  econs; splits; ii; revert IN.
  - erewrite Memory.add_o; eauto. erewrite (@Memory.add_o mem2); eauto.
    condtac; ss.
    + i. des. inv IN. esplits; eauto.
    + i. eapply MEMLE. eauto.
  - erewrite Memory.add_o; eauto. erewrite (@Memory.add_o m2'); eauto.
    condtac; ss.
    + i. des. inv IN. esplits; eauto.
    + i. eapply MEMLE. eauto.
Qed.

Lemma mem_eqlerel_split_forward
      loc ts1 ts2 ts3 val2 val3 released2 released2' released3
      m1 m2 m2'
      (MEMLE: mem_eqlerel m2 m1)
      (SPLIT2: Memory.split m2 loc ts1 ts2 ts3 val2 val3 released2 released3 m2')
      (RELLE: View.opt_le released2 released2')
      (RELWF: View.opt_wf released2'):
  exists released3' m1',
    <<SPLIT2: Memory.split m1 loc ts1 ts2 ts3 val2 val3 released2' released3' m1'>> /\
    <<MEMLE': mem_eqlerel m2' m1'>>.
Proof.
  exploit Memory.split_get0; eauto. i. des.
  apply MEMLE in GET3. i. des.
  exploit (@Memory.split_exists m1 loc ts1 ts2 ts3); eauto;
    try by inv SPLIT2; inv SPLIT; eauto. i. des.
  esplits; eauto.
  econs; splits; ii; revert IN0.
  - erewrite Memory.split_o; eauto. erewrite (@Memory.split_o mem2); eauto.
    repeat condtac; ss.
    + i. des. inv IN0. esplits; eauto.
    + guardH o. i. des. inv IN0. esplits; eauto.
    + eapply MEMLE.
  - erewrite Memory.split_o; eauto. erewrite (@Memory.split_o m2'); eauto.
    repeat condtac; ss.
    + i. des. inv IN0. esplits; eauto.
    + guardH o. i. des. inv IN0. esplits; eauto.
    + eapply MEMLE.
Qed.

Lemma mem_eqlerel_lower_forward
      loc from to val released1 released2
      m1 m2 m2'
      (MEMLE: mem_eqlerel m2 m1)
      (LOWER2: Memory.lower m2 loc from to val released1 released2 m2'):
  exists released1' m1',
    <<LOWER1: Memory.lower m1 loc from to val released1' released2 m1'>> /\
    <<MEMLE': mem_eqlerel m2' m1'>>.
Proof.
  exploit Memory.lower_get0; eauto. i.
  apply MEMLE in x0. des.
  exploit (@Memory.lower_exists m1 loc from to val rel2 released2); eauto;
    try by inv LOWER2; inv LOWER; eauto; try by viewtac.
  { etrans; eauto. inv LOWER2. inv LOWER. auto. }
  i. des.
  esplits; eauto.
  econs; esplits; ii; revert IN0.
  - erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o mem2); eauto.
    condtac; ss.
    + i. des. inv IN0. esplits; eauto. refl.
    + eapply MEMLE.
  - erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o m2'); eauto.
    condtac; ss.
    + i. des. inv IN0. esplits; eauto. refl.
    + eapply MEMLE.
Qed.


From CE Require Export Tests.

Import ListNotations.

Goal
  exists n res eff, | [], 0, small_example, [] | -e> | n , res, eff |.
Proof.
  unfold small_example.
  eexists. eexists. eexists.
  solve.
Qed.


(** * Nondeterminism *)

(** Actually, bounded nondeterminism. *)

(* begin hide *)
Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
     String List.
Import ListNotations.

From ITree Require Import
     Basics.Basics
     Core.ITreeDefinition
     Indexed.Sum
     Core.Subevent
     Events.Exception.
(* end hide *)

(** Make nondeterministic choices. *)
Variant nondetE : Type -> Type :=
| Or : nondetE bool.

(** Choose one of two computations. *)
Definition or {E F} `{nondetE +? F -< E} {R} (t1 t2 : itree E R)
  : itree E R :=
  vis Or (fun b : bool => if b then t1 else t2).

(** Choose an element from a nonempty list (with the head and tail
    as separate arguments), so it cannot fail. *)
Definition choose1 {E F} `{nondetE +? F -< E} {X}
  : X -> list X -> itree E X
  := fix choose1' x xs : itree E X :=
       match xs with
       | [] => Ret x
       | x' :: xs => or (Ret x) (choose1' x' xs)
       end.

(** Pick any element in a list apart from the others. *)
Definition remove_from {X} : list X -> list (X * list X) :=
  let fix remove_from_ pre xs :=
      match xs with
      | [] => []
      | x :: xs' => (x, pre ++ xs') :: remove_from_ (pre ++ [x]) xs'
      end in
  remove_from_ [].

(** ** Empty nondeterminism *)

(** We can use [exceptE] events to model nullary branching. *)

(** Exception thrown by [choose]. *)
Variant no_choice : Set := NoChoice.

(** Choose an element from a list.

    This can fail if the list is empty, using the [exceptE no_choice] event.
 *)

Definition choose {E F G} `{nondetE +? F -< E} `{exceptE no_choice +? G -< E} {X}
  : list X -> itree E X
  := fix choose' xs : itree E X :=
       match xs with
       | [] => throw NoChoice
       | x :: xs =>
         or (Ret x) (choose' xs)
       end.


(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV 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.

  CFGV 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 CFGV.  If not, see <http://www.gnu.org/licenses/>.

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

*)
Require Export GVariables.
Set Implicit Arguments.

(** printing #  $\times$ #×# *)
(** printing &  $\times$ #×# *)

(** used in [bindingInfoCorrect] below.
   Also, see [ValidIndicesDecidable] below*)
Definition ValidIndices {A B : Type}
  (bindingInfo : list (nat * nat))
  (rhsSyms : list (A + B)) : [univ]
:= (
      forall n m,
      LIn (n,m) bindingInfo
      -> (m < length rhsSyms) # (n < length rhsSyms)
          # (true = liftNth isInl rhsSyms n)
   )
   #
   (
      forall n,
        (true = liftNth isInl rhsSyms n)
        -> LIn n (map (@fst _ _) bindingInfo)
   )
    #no_repeats bindingInfo.

(** For concretely specified grammars,
  one can just compute the following lemma to get the
  proof of [ValidIndices]. See the tactic (Ltac)
  [proveBindingInfoCorrect] below. *)
Lemma ValidIndicesDecidable:
  forall {A B : Type}
  (bindingInfo : list (nat * nat))
  (rhsSyms : list (A + B)),
  decidable (ValidIndices bindingInfo rhsSyms).
Proof.
  intros.
  unfold ValidIndices.
  apply decidable_prod;[|apply decidable_prod].
  - induction bindingInfo as [| (n,m) bindingInfo Hind];
      [left; dands |]; cpx.
    dorn Hind;[| right]; cpx.
    remember (liftNth isInl rhsSyms n) as bl.
    destruct (lt_dec m (length rhsSyms));
    destruct (lt_dec n (length rhsSyms));
    destruct bl; try rewrite <- Heqbl;
    try(left; introv Hin; repeat(in_reasoning); cpx; fail);
    [| | | | | | ];
    right; introv Hin;
    specialize (Hin _ _ (inl eq_refl));
    try rewrite <- Heqbl in Hin;
    dands; cpx.

  - remember ((map (fst (B:=nat)) bindingInfo)) as bif.
    clear dependent bindingInfo.
    revert bif. unfold liftNth;
    induction rhsSyms as [| rs rhsSyms Hind];
      [left; intro n; destruct n;
         simpl; cpx |].
    intro bifCons.
    remember (flat_map
      (fun n=> match n with
               |0 => []
               | S m => [m] end) bifCons)
      as bif.
    specialize (Hind bif).
    dorn Hind; [| right]; cpx.
    + destruct rs as [sa| sb];[|left; destruct n;
            allsimpl; cpx].
      * destruct (in_deq _ deq_nat 0 bifCons); cpx;
        [left; destruct n | right]; simpl;
        subst bif; cpx;[].

        introv Heq.
        apply Hind in Heq.
        apply lin_flat_map in Heq.
        exrepnd.
        destruct x; cpx.
        inverts Heq0; cpx; fail.

      * introv Heq. subst bif.
        specialize (Hind ( n)).
        apply Hind in Heq. clear Hind.
        apply lin_flat_map in Heq.
        exrepnd. destruct x; cpx.
        inverts Heq0; cpx.
    + introv Hc. apply Hind. clear Hind. introv Heq.
      subst bif. apply lin_flat_map.
      specialize (Hc (S n)). simpl in Hc.
      apply Hc in Heq.
      exists (S n). dands; cpx.

  - apply no_repeat_dec. apply deq_prod; exact deq_nat.
Defined.

(* using some ideas from
  http://gallium.inria.fr/~xleroy/publi/validated-parser.pdf

  Coq sources are linked in sources in [9].

  specifically, cparser/validator/Grammar.v

*)

(** CatchFileBetweenTagsCFGVStart *)
Record CFGV := {
  Terminal : Type;   VarSym : Type;
  TNonTerminal : Type;   PNonTerminal : Type;

  PatProd : Type;  EmbedProd : Type;  TermProd : Type;

  varSem : VarSym -> VarType;
  vSubstType : VarSym -> TNonTerminal;
  tSemType : Terminal -> Type;

  ppLhsRhs: PatProd ->
    (PNonTerminal * list (PNonTerminal
                           + (Terminal + VarSym)));

  epLhsRhs : EmbedProd -> (PNonTerminal * TNonTerminal);

  tpLhsRhs: TermProd ->
    (TNonTerminal * list ((PNonTerminal + VarSym)
                          +(Terminal+TNonTerminal)));

  bindingInfo : TermProd -> list (nat * nat);
  bindingInfoCorrect: forall (p: TermProd),
      ValidIndices (bindingInfo p) (snd (tpLhsRhs p));
(** }. CatchFileBetweenTagsCFGVEnd *)

  DeqVarSym : Deq VarSym;
  deqT : Deq Terminal;
  deqNT : Deq TNonTerminal;
  deqPT : Deq PNonTerminal;
  deqPr : Deq TermProd;
  deqEm : Deq EmbedProd;
  deqPPr : Deq PatProd;
  deqTSem : forall (t: Terminal), Deq (tSemType t)

}.

Definition vType {G: CFGV} (vc : VarSym G) : Type :=
  (typ (varSem G vc)).

(** A more intuitive way to denote symbols of a CFGV :
    instead of inl inr.... *)

(** CatchFileBetweenTagsGSymStart *)
Inductive GSym (G: CFGV) : Type :=
| gsymT : Terminal G -> GSym G
| gsymV : VarSym G -> GSym G
| gsymTN : TNonTerminal G -> GSym G
| gsymPN : PNonTerminal G -> GSym G.
(** CatchFileBetweenTagsGSymEnd *)

(** Make the [CFGV] argument implicit *)
Arguments gsymT {G} _.
Arguments gsymV {G} _.
Arguments gsymTN {G} _.
Arguments gsymPN {G} _.

Arguments bindingInfo {c} _.

Lemma deqGSym :  forall (G: CFGV),
  Deq (GSym G).
Proof.
intros.
intros sa sb.
destruct sa as [sa|sa|sa|sa]; destruct sb as [sb|sb|sb|sb];
try (right; introv Hc; inverts Hc; cpx; fail).
- destruct (deqT G sa sb);[left; subst|right; introv HC; inverts HC]; cpx.
- destruct (DeqVarSym G sa sb);[left; subst|right; introv HC; inverts HC]; cpx.
- destruct (deqNT G sa sb);[left; subst|right; introv HC; inverts HC]; cpx.
- destruct (deqPT G sa sb);[left; subst|right; introv HC; inverts HC]; cpx.
Defined.

Hint Resolve deqT deqTSem DeqVarSym deqNT deqPT deqGSym deqPr deqEm deqPPr: Deq.

Definition  prhs_aux {G : CFGV}
  (symSum :((PNonTerminal G + VarSym G)
              +(Terminal G + TNonTerminal G))) : (GSym G) :=
match symSum with
| inl (inl p) => gsymPN p
| inl (inr vc) => gsymV vc
| inr (inl t) => gsymT t
| inr (inr nt) => gsymTN nt
end.

Definition tpRhsSym {G: CFGV} (p:TermProd G) : list (GSym G)
:=map (prhs_aux) (snd (tpLhsRhs G p)).

Definition  ptrhs_aux {G : CFGV}
  (symSum :((PNonTerminal G)+ (Terminal G + VarSym G)))
      : (GSym G) :=
match symSum with
| (inl p) => gsymPN p
| inr (inl t) => gsymT t
| inr (inr v) => gsymV v
end.

Definition gsymNotNT {G : CFGV} (s : GSym G) :=
match s with
| gsymT _ => True
| gsymV _ => True
| gsymTN _ => False
| gsymPN _ => True
end.

Lemma ptrhs_aux_nonNT : forall {G: CFGV}
    (symSum :((PNonTerminal G)+ (Terminal G + VarSym G))) ,
  gsymNotNT (ptrhs_aux symSum).
Proof.
  intros.
  dorn symSum;[|dorn symSum]; simpl; auto.
Qed.

Definition ppRhsSym {G: CFGV} (p:PatProd G) : list (GSym G)
:=map (ptrhs_aux) (snd (ppLhsRhs G p)).

Definition tpLhs (G: CFGV) (p:TermProd G) : TNonTerminal G
:= (fst (tpLhsRhs G p)).

Definition epLhs (G: CFGV) (p:EmbedProd G) : PNonTerminal G
:= (fst (epLhsRhs G p)).

Definition epRhs (G: CFGV) (p:EmbedProd G) : TNonTerminal G
:= (snd (epLhsRhs G p)).

Definition ppLhs (G: CFGV) (p:PatProd G) : PNonTerminal G
:= (fst (ppLhsRhs G p)).

Definition gsymNotP {G : CFGV} (s : GSym G) :=
match s with
| gsymT _ => True
| gsymV _ => True
| gsymTN _ => True
| gsymPN _ => False
end.

Arguments DeqVarSym {c}  _ _.

Definition flatten {A : Type} (l : list (list A)) : list A:=
  flat_map (fun x => x) l.

(* how many times the nth symbol in rhs of production p is bound.
    (not the most efficient algorithm) *)
Definition bindCount {G : CFGV} (p: TermProd G) (n : nat) :=
  let lnat := (map (@fst _ _) (bindingInfo p))
    in count_occ deq_nat lnat n.

(* the following can be written better using [LIn]
Definition isBound {G : CFGV} (p: TermProd G) (n : nat) :=
  negb (beq_nat (bindCount p n) 0).
*)

(* Now we (parially)
    define the semantics of the language,
    It is essentially a parse tree.
    The full semantics also needs
    to formalize variable binding semantics;
    e.g. alpha equality and substitution.

    The parse tree s parametrized by the
    head symbol.
 *)

Definition prhsIsBound {G : CFGV} (p: TermProd G) : list bool :=
 (map isInl (snd (tpLhsRhs G p))).

Definition MixtureParam {G : CFGV} :=
  list (bool * (GSym G)).

Definition MParamCorrectb {G : CFGV} (pp: @MixtureParam G)
   : bool :=
forallb  (fun p=> match p with
                   | (false, gsymPN _) => false
                   | _ => true
                   end)
          pp.

(* augment rhs with indicators whether a pattern is bound somewhere*)
Definition tpRhsAugIsPat {G : CFGV} (p: TermProd G)
    : MixtureParam :=
 combine (prhsIsBound p) (tpRhsSym p).

(* TODO: Show some examples. encode Coq in the standard inductive
    way and then use this CFGV. Prove bijection.
    Ignore bindings to begin with.
*)

Definition bindingSourcesNth {G:CFGV}
  (p: TermProd G) (k:nat) : list nat :=
flat_map
     (fun pp : (nat * nat)
                => let (n,m) := pp in
                    if (beq_nat k m) then [n] else [])
     (bindingInfo p).

Definition ValidNthSrc (len : nat) (ln: list nat):=
  no_repeats ln
  # lForall (fun n =>  n < len) ln.

Lemma bsNthValid : forall {G:CFGV}
(p: TermProd G) (k:nat),
ValidNthSrc (length (tpRhsSym p)) (bindingSourcesNth p k).
Proof.
  intros. unfold ValidNthSrc.
  unfold bindingSourcesNth, bindingInfo, tpRhsSym.
  autorewrite with fast.
  pose proof (bindingInfoCorrect G p) as XX.
  destruct (tpLhsRhs G p) as [lhs ls].
  destruct G; allsimpl; cpx.

  allsimpl. remember ((bindingInfo0 p)) as bi. clear Heqbi.
  allsimpl. clear  bindingInfoCorrect0.
  repnud XX. clear XX1.
  induction bi; dands; allsimpl;  cpx;
  allrw no_repeats_cons;
  exrepnd;

  apply IHbi in XX1; exrepnd; cpx;
  remember (beq_nat k a) as bn; destruct bn; cpx;
  allrw no_repeats_cons; allsimpl; dands;  cpx.
  - introv Hin. rw lin_flat_map in Hin.
    exrepnd.
    remember (beq_nat k x) as bkx; destruct bkx; allsimpl; cpx.
    dorn Hin0; subst; cpx.
    allapply beq_nat_eq.
    subst. subst. cpx.
  - pose proof (XX0 _ _ (inl eq_refl)).
    repnd; cpx.
Qed.

Definition bndngPatIndices {G:CFGV}
  (p: TermProd G) : list  (list nat) :=
map (bindingSourcesNth p) (seq 0 (length (tpRhsSym p))).

Definition validBsl (len:nat) (lln: list (list nat)) :=
lforall (ValidNthSrc len) lln.

Lemma  bndngPatIndicesValid : forall
{G:CFGV} (p: TermProd G),
validBsl (length (tpRhsSym p)) (bndngPatIndices p).
Proof.
  intros.
  unfolds_base.
  unfold bndngPatIndices.
  introv Hin.
  apply in_map_iff in Hin.
  exrepnd.
  subst.
  apply bsNthValid.
Qed.

Lemma  bndngPatIndicesValid2 : forall
{G:CFGV} (p: TermProd G),
validBsl (length (snd (tpLhsRhs G p))) (bndngPatIndices p).
Proof.
  intros.
  pose proof (bndngPatIndicesValid p) as X.
  unfold tpRhsSym in X.
  autorewrite with fast in X.
  trivial.
Qed.

Lemma DeqVtype : forall  {G:CFGV} (vc : VarSym G),
     Deq (vType vc).
Proof.
  intros. unfold vType.
  match goal with
  [ |- Deq (typ ?xx)] => destruct xx as [? vd]
  end.
  repnud vd. auto.
Defined.

Hint Resolve DeqVtype : Deq.

Definition vFreshVar
  {G : CFGV}
  {vc : VarSym G}
  (lvAvoid: list (vType vc))
  (v: (vType vc)) : vType vc :=
  ((fresh (varSem G vc)) lvAvoid [v]).

Definition GFreshVars
  {G : CFGV}
  {vc : VarSym G}
  (lvAvoid: list (vType vc))
  (lv: list (vType vc)) : list (vType vc)  :=
  (FreshDistinctVars (varSem G vc) lv lvAvoid).

Lemma FreshDistVarsSpec: forall
  {G : CFGV} {vc : VarSym G}
  (lvAvoid: list (vType vc))
  (lv: list (vType vc)),
  let lvn := (GFreshVars  lvAvoid lv) in
  no_repeats lvn # disjoint lvn lvAvoid # length lvn= length lv.
Proof.
  intros.
  subst lvn.
  unfold GFreshVars.
  pose proof(
    FreshDistVarsSpec  lv lvAvoid).
  allsimpl.
  exrepnd; dands; cpx.
Qed.

Lemma vFreshVarSpec : forall
  {G : CFGV}
  {vc : VarSym G}
  (lvAvoid: list (vType vc))
  (v: (vType vc)),
  ! LIn (vFreshVar lvAvoid v) lvAvoid.
Proof.
  intros.
  unfold vFreshVar.
  revert v. revert lvAvoid.
  unfold vType.
  destruct  (varSem G vc) as [T vd Vf Vfc].
  allsimpl.
  exrepnd. allsimpl.
  cpx.
Qed.

(** also guaranteed to be different from the input *)
Definition vFreshDiff
  {G : CFGV}
  {vc : VarSym G}
  (lvAvoid: list (vType vc))
  (v: (vType vc)) :=
  (fresh (varSem G vc)) (v::lvAvoid) [v].

Lemma vFreshDiffSpec : forall
  {G : CFGV}
  {vc : VarSym G}
  (lvAvoid: list (vType vc))
  (v: (vType vc)),
  ! LIn (vFreshDiff (lvAvoid) v) (v::lvAvoid).
Proof.
  intros.
  apply vFreshVarSpec.
Qed.

Lemma length_pRhsAugIsPat : forall {G : CFGV}  (p : TermProd G),
  length (tpRhsAugIsPat p) = length ((snd (tpLhsRhs G p))).
Proof.
  intros. simpl.
  unfold tpRhsAugIsPat, prhsIsBound , tpRhsSym.
  rewrite combine_length.
  autorewrite with fast.
  rewrite min_eq; refl.
Qed.

Lemma GFreshDistRenWSpec: forall
   {G:CFGV} (vc : VarSym G)
  (lv :list (vType vc))
  (lvAvoid :list (vType vc)),
  {lvn : list (vType vc) $
  no_repeats lvn # disjoint lvn lvAvoid
  # length lvn= length lv}.
Proof.
  intros. eapply FreshDistRenWSpec; eauto.
Defined.

Lemma deqMixP : forall {G}, Deq (@MixtureParam G).
Proof.
  unfold MixtureParam.
  eauto with Deq.
Defined.

Lemma deqSigVType :
  forall {G}, (Deq (sigT (@vType G))).
Proof.
  intros.
  apply sigTDeq;
  eauto with Deq.
Defined.

Lemma deqSigTSemType :
  forall {G}, (Deq (sigT (tSemType G))).
Proof.
  intros.
  apply sigTDeq;
  eauto with Deq.
Defined.

Definition decDisjointV {G} (vc : VarSym G)
   (la lb : list (vType vc)) :
    (disjoint la lb[+]!disjoint la lb)
  := dec_disjoint (DeqVtype vc) la lb.

Ltac proveBindingInfoCorrect :=
  let p:= fresh "tprod" in
  let d:= fresh "decVal" in
  let Heqd:= fresh "Heq" d in
  intro p;
  match goal with
  [ |- ValidIndices ?binf ?rhsSyms ] =>
    remember (ValidIndicesDecidable binf rhsSyms) as d eqn:Heqd;
      destruct p; unfold ValidIndicesDecidable in Heqd; allsimpl;
      destruct d; auto; inverts Heqd
  end.

Ltac proveDeqInductiveNonrec :=
  let x:= fresh "xdl" in
  let y:= fresh "axr" in
  let Hc:= fresh "Hcontra" in
  intros x y ; destruct x; destruct y;
    try (left; cpx; fail); (try right; introv Hc; inverts Hc ; cpx).
(*
*** Local Variables:
*** coq-load-path: ("../")
*** End:
*)

(*
Definition vFreshDistRenLL
  {G : CFGV} (vc : VarSym G):=
  FreshDistinctRenListList (snd (projT2 (vSemType G vc))).
*)

(* Lemma  : forall {G : CFGV},
  Deq (VarSym G).
Proof.
  intros.
  destruct G.
  simpl.
  (* info_eauto with Deq. *)
    apply Finite_Deq.
    exact FinV0.
Defined. *)

(*
with Patterns {G : CFGV} :
  list (GSym G) -> Type :=
| pnil : Patterns []
| pcons : forall  {h: GSym G}
        {tl: list (GSym G) }
        (ph: Pattern h )
        (ptl: Patterns tl),
          Patterns (h::tl)
*)
(* not necessary till we do parsing.
  these implied decidability of equality.
  We added those to make
  depedent destruction to work.

  FinV: Finite VarSym;
  FinPt: Finite PNonTerminal;
  FinT: Finite Terminal;
  FinPr: Finite TermProd;
  FinEmb: Finite EmbedProd;
  FinNT: Finite TNonTerminal;
  FinPat: Finite PatProd;
*)
(* The following legitimate definition is
    rejected by Coq's too strict strict-positivity checker.
[[
Require Import Tuples.
Inductive ParseTree (G : CFGV) : (GSymb G) -> Type :=
| leaf : forall (t :Token G), ParseTree G (Token2Gsymb t)
| tnode : forall (p: TermProd G),
    tuple (map (ParseTree G) (prhs G p))
    -> (ParseTree G  (gsymTN _ _ _ (tpLhs G p))).
]]
*)


Require Import Coq.ZArith.ZArith.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Context (max_const_val : Z).

      Definition VerifiedRewriterArith : VerifiedRewriter_with_args false false true (arith_rewrite_rules_proofs max_const_val).
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterArith.
      Let optsT := Eval hnf in optsT VerifiedRewriterArith.

      Definition RewriteArith (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterArith opts t.

      Lemma Wf_RewriteArith opts {t} e (Hwf : Wf e) : Wf (@RewriteArith opts t e).
      Proof. now apply VerifiedRewriterArith. Qed.

      Lemma Interp_RewriteArith opts {t} e (Hwf : Wf e) : API.Interp (@RewriteArith opts t e) == API.Interp e.
      Proof. now apply VerifiedRewriterArith. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
#[global]
    Hint Resolve Wf_RewriteArith : wf wf_extra.
#[global]
    Hint Opaque RewriteArith : wf wf_extra interp interp_extra rewrite.
#[global]
    Hint Rewrite @Interp_RewriteArith : interp interp_extra.
  End Hints.
End Compilers.