(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

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

*)

Require Export continuity.
Require Export stronger_continuity_defs1.
Require Export stronger_continuity_defs3.
Require Export list.  (* WTF!! *)

Lemma cequiv_bound_nat_bound {o} :
  forall lib (a : get_patom_set o) (x e z : NVar) (k : nat) (f : @NTerm o),
    (forall t n,
       n < k
       -> computes_to_value lib t (mk_nat n)
       -> {j : nat & computes_to_value lib (mk_apply f t) (mk_nat j)})
    -> cequiv
         lib
         (bound_nat a x e z (bound x (mk_utoken a) (mk_nat k) f))
         (mk_lam x (mk_less (mk_var x) mk_zero (mk_vbot z)
                            (mk_less (mk_var x) (mk_nat k)
                                     (mk_apply f (mk_var x))
                                     (spexc a)))).
Proof.
  introv imp.

Abort.

Lemma cequiv_sp_bound_nat_c_bound_c {o} :
  forall lib v z (e n f : @CTerm o),
    cequivc
      lib
      (sp_bound_nat_c v z (bound_c e n f v))
      (bound2_c v z n f e).
Proof.
  introv.

  apply cequivc_lam; introv.
  allrw @mkcv_less_substc.
  allrw @mkcv_apply_substc.
  allrw @substc_mkcv_zero.
  allrw @mkc_var_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_vbot_substc.

  eapply cequivc_trans;
    [apply cequivc_mkc_less;
      [apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_apply_bound_c]
    |].
  rw @boundl_c_eq; auto.
Qed.

Lemma substc_mkcv_axiom {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_axiom v) = mkc_axiom.
Proof.
  introv; destruct_cterms.
  apply cterm_eq; simpl.
  unfsubst.
Qed.

Lemma spM_in_modulus_fun_type_u {o} :
  forall lib (F : @CTerm o),
    member lib F (mkc_fun nat2nat mkc_tnat)
    -> member lib (spM_c F) modulus_fun_type_u.
Proof.
  introv mF.

  unfold modulus_fun_type_u.
  apply equality_in_function2.
  fold (@modulus_fun_type_u o).
  dands; try (apply type_modulus_fun_type_u).
  introv e.
  rename a into n.
  rename a' into m.
  eapply alphaeqc_preserving_equality;[|apply alphaeqc_sym;apply substc_mkcv_fun].
  allrw @csubst_mk_cv.
  apply equality_in_fun.
  dands.

  - eapply type_respects_alphaeqc;[apply alphaeqc_sym;apply substc_mkcv_fun|].
    allrw @mkcv_tnat_substc.
    apply type_mkc_fun.
    dands.
    + eapply type_respects_alphaeqc;[apply alphaeqc_sym;apply mkcv_natk_substc|].
      rw @mkc_var_substc.
      apply equality_in_tnat in e.
      unfold equality_of_nat in e; exrepnd; spcast.
      apply type_mkc_natk.
      allrw @mkc_nat_eq.
      exists (Z.of_nat k); spcast; auto.
    + introv inh.
      apply type_tnat.

  - introv inh.
      apply tequality_bunion; dands.
      * apply type_tnat.
      * apply type_mkc_unit.

  - introv e1.
    allrw <- @mkc_apply2_eq.
    rename a into f.
    rename a' into g.
    eapply alphaeqc_preserving_equality in e1;[|apply substc_mkcv_fun].
    eapply alphaeqc_preserving_equality in e1;
      [|apply alphaeqc_mkc_fun;[apply mkcv_natk_substc|apply alphaeqc_refl] ].
    allrw @mkcv_tnat_substc.
    allrw @mkc_var_substc.

    apply equality_in_tnat in e.
    unfold equality_of_nat in e; exrepnd; spcast.

    (* let's get rid of [n] and [m] now *)
    eapply cequivc_preserving_equality in e1;
      [|apply cequivc_mkc_fun;[|apply cequivc_refl];
        apply cequivc_mkc_natk;
        apply computes_to_valc_implies_cequivc; exact e2].

    fold (@natk2nat o (mkc_nat k)) in e1.

    eapply equality_respects_cequivc_left;
      [apply implies_cequivc_apply2;[apply cequivc_refl|idtac|apply cequivc_refl];
       apply cequivc_sym; apply computes_to_valc_implies_cequivc; exact e2|].

    eapply equality_respects_cequivc_right;
      [apply implies_cequivc_apply2;[apply cequivc_refl|idtac|apply cequivc_refl];
       apply cequivc_sym; apply computes_to_valc_implies_cequivc; exact e0|].

    clear dependent n.
    clear dependent m.

    (* let's beta-reduce *)
    eapply equality_respects_cequivc_left;
      [apply cequivc_sym; apply cequivc_apply2_spM_c|].
    eapply equality_respects_cequivc_right;
      [apply cequivc_sym; apply cequivc_apply2_spM_c|].

    (* now let's apply bound to [f] and [g] *)
    pose proof (equality_in_natk2nat_implies_equality_bound lib f g k e1) as h.
    allrw @test_c_eq.

    destruct (fresh_atom o (getc_utokens F ++ getc_utokens f ++ getc_utokens g)) as [a nia].
    allrw in_app_iff; allrw not_over_or; repnd.

    (* let's get rid of fresh in the conclusion *)
    assert (equality
              lib
              (substc (mkc_utoken a) nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) f))
              (substc (mkc_utoken a) nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) g))
              (mkc_bunion mkc_tnat mkc_unit)) as equ;
      [|pose proof (cequivc_fresh_subst2 lib nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) f) a) as h1;
         repeat (autodimp h1 hyp);
         [ destruct_cterms; allsimpl;
           allunfold @getcv_utokens; allunfold @getc_utokens; allsimpl; allrw app_nil_r;
           allrw in_app_iff; tcsp
         | apply equality_refl in equ; apply member_bunion_nat_unit_implies_cis_spcan_not_atom; auto
         |];
         pose proof (cequivc_fresh_subst2 lib nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) g) a) as h2;
         repeat (autodimp h2 hyp);
         [ destruct_cterms; allsimpl;
           allunfold @getcv_utokens; allunfold @getc_utokens; allsimpl; allrw app_nil_r;
           allrw in_app_iff; tcsp
         | apply equality_sym in equ; apply equality_refl in equ; apply member_bunion_nat_unit_implies_cis_spcan_not_atom; auto
         |];
         spcast;
         eapply equality_respects_cequivc_left;[apply cequivc_sym;exact h1|];
         eapply equality_respects_cequivc_right;[apply cequivc_sym;exact h2|];
         complete auto
      ].

    repeat (rw @substc_test_try2_cv).

    pose proof (h a nvarx) as q.
    clear h.

    pose proof (apply_nat2natE_aux2
                  lib F
                  (bound_c (mkc_utoken a) (mkc_nat k) f nvarx)
                  (bound_c (mkc_utoken a) (mkc_nat k) g nvarx)
                  a nvarx nvarz) as ee.
    repeat (autodimp ee hyp); try (complete (intro xx; ginv));[].
    clear q.

    eapply equality_respects_cequivc_left in ee;
      [|apply implies_cequivc_apply;
         [apply cequivc_refl
         |apply cequiv_sp_bound_nat_c_bound_c]
      ].

    eapply equality_respects_cequivc_right in ee;
      [|apply implies_cequivc_apply;
         [apply cequivc_refl
         |apply cequiv_sp_bound_nat_c_bound_c]
      ].

    apply equality_in_natE_implies in ee; repndors.

    { unfold equality_of_nat_tt in ee; exrepnd.
      eapply equality_respects_cequivc_left;
        [apply cequivc_sym;
          apply computes_to_valc_implies_cequivc;
          eapply computes_to_valc_mkc_try;
          [exact ee1|apply computes_to_pkc_refl;apply mkc_utoken_eq_pk2termc]
        |].
      eapply equality_respects_cequivc_right;
        [apply cequivc_sym;
          apply computes_to_valc_implies_cequivc;
          eapply computes_to_valc_mkc_try;
          [exact ee0|apply computes_to_pkc_refl;apply mkc_utoken_eq_pk2termc]
        |].
      apply equality_in_disjoint_bunion; eauto 3 with slow.
      dands; eauto 3 with slow. }

    { repnd.
      eapply equality_respects_cequivc_left;
        [apply cequivc_sym;
          apply simpl_cequivc_mkc_try;
          [exact ee0|apply cequivc_refl]
        |].
      eapply equality_respects_cequivc_right;
        [apply cequivc_sym;
          apply simpl_cequivc_mkc_try;
          [exact ee|apply cequivc_refl]
        |].

      eapply equality_respects_cequivc_left;
        [apply cequivc_sym;
          apply reduces_toc_implies_cequivc;
          apply reduces_toc_mkc_try_exc
        |].
      eapply equality_respects_cequivc_right;
        [apply cequivc_sym;
          apply reduces_toc_implies_cequivc;
          apply reduces_toc_mkc_try_exc
        |].

      allrw @substc_mkcv_axiom.
      apply equality_in_disjoint_bunion; eauto 3 with slow.
      dands; eauto 3 with slow.
      right.
      apply equality_in_unit; dands; spcast; apply computes_to_valc_refl; eauto 3 with slow. }
Qed.

Definition get_ints_from_computes_to_value {o}
           (lib : @library o)
           (t u : @NTerm o)
           (comp : computes_to_value lib t u) : list Z :=
  match comp with
    | (c,_) => get_ints_from_computation lib t u c
  end.

Definition get_ints_from_computes_to_valc {o}
           (lib : @library o)
           (t u : @CTerm o)
           (comp : computes_to_valc lib t u) : list Z :=
  get_ints_from_computes_to_value lib (get_cterm t) (get_cterm u) comp.

Lemma cequivc_nat {o} :
  forall lib (t t' : @CTerm o) (n : nat),
    computes_to_valc lib t (mkc_nat n)
    -> cequivc lib t t'
    -> computes_to_valc lib t' (mkc_nat n).
Proof.
  introv comp ceq; destruct_cterms;
  allunfold @computes_to_valc; allunfold @cequivc; allsimpl.
  eapply cequiv_nat; eauto.
Qed.

Definition force_nat {o} (arg : @NTerm o) x z (f : @NTerm o) :=
  mk_cbv arg x (mk_less (mk_var x)
                        mk_zero
                        (mk_vbot z)
                        (mk_apply f (mk_var x))).

Definition force_nat_c {o} (arg : @CTerm o) x z (f : @CTerm o) : CTerm :=
  mkc_cbv
    arg
    x
    (mkcv_less
       [x]
       (mkc_var x)
       (mkcv_zero [x])
       (mkcv_vbot [x] z)
       (mkcv_apply [x] (mk_cv [x] f) (mkc_var x))).

Lemma get_cterm_force_nat_c {o} :
  forall (arg : @CTerm o) x z f,
    get_cterm (force_nat_c arg x z f)
    = force_nat (get_cterm arg) x z (get_cterm f).
Proof.
  introv; destruct_cterms; simpl; auto.
Qed.

Definition lam_force_nat_c {o} x z (f : @CTerm o) : CTerm :=
  mkc_lam
    x
    (mkcv_cbv
       [x]
       (mkc_var x)
       x
       (mkcv_dup1
          x
          (mkcv_less
             [x]
             (mkc_var x)
             (mkcv_zero [x])
             (mkcv_vbot [x] z)
             (mkcv_apply [x] (mk_cv [x] f) (mkc_var x))))).

Lemma cequivc_mkc_apply_lam_force_nat_c {o} :
  forall lib x z (f arg : @CTerm o),
    cequivc
      lib
      (mkc_apply (lam_force_nat_c x z f) arg)
      (force_nat_c arg x z f).
Proof.
  introv.
  eapply cequivc_trans;[unfold lam_force_nat_c;apply cequivc_beta|].
  rw @mkcv_cbv_substc_same.
  rw @mkc_var_substc.
  rw @mkcv_cont1_dup1; eauto 3 with slow.
Qed.

Lemma equality_lam_force_nat_c_in_nat2nat {o} :
  forall lib x z (f : @CTerm o),
    member lib f nat2nat
    -> equality lib f (lam_force_nat_c x z f) nat2nat.
Proof.
  introv mem.
  apply equality_in_fun; dands; eauto 3 with slow.
  introv equ.
  apply equality_in_tnat in equ.
  unfold equality_of_nat in equ; exrepnd; spcast.

  eapply equality_respects_cequivc_left;
    [apply cequivc_sym;
      apply implies_cequivc_apply;
      [apply cequivc_refl
      |apply computes_to_valc_implies_cequivc;exact equ1]
    |].

  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply cequivc_mkc_apply_lam_force_nat_c|].

  unfold force_nat_c.
  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply simpl_cequivc_mkc_cbv;
     apply computes_to_valc_implies_cequivc;exact equ0|].
  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply cequivc_mkc_cbv|]; eauto 3 with slow;[].
  rw @mkcv_less_substc.
  rw @substc_mkcv_zero.
  rw @mkcv_vbot_substc.
  rw @mkcv_apply_substc.
  rw @csubst_mk_cv.
  rw @mkc_var_substc.

  rw @mkc_zero_eq.

  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply cequivc_mkc_less_nat|].
  boolvar; tcsp.

  allrw @equality_in_fun; repnd.
  clear mem1 mem0.
  apply mem; eauto 3 with slow.
Qed.

Lemma eq_mkc_nat_implies {o} :
  forall k1 k2, @mkc_nat o k1 = mkc_nat k2 -> k1 = k2.
Proof.
  introv e.
  inversion e as [q].
  allapply Znat.Nat2Z.inj; auto.
Qed.

Definition bound2_cbv_c {o} x z (n f e : @CTerm o) :=
  mkc_lam
    x
    (mkcv_cbv
       [x]
       (mkc_var x)
       x
       (mkcv_dup1
          x
          (mkcv_less
             [x]
             (mkc_var x)
             (mkcv_zero [x])
             (mkcv_vbot [x] z)
             (mkcv_less
                [x]
                (mkc_var x)
                (mk_cv [x] n)
                (mkcv_apply [x] (mk_cv [x] f) (mkc_var x))
                (mk_cv [x] (mkc_exception e mkc_axiom)))))).

Lemma cequiv_bound2_c_cbv {o} :
  forall lib x z (n f e : @CTerm o),
    cequivc
      lib
      (bound2_c x z n f e)
      (bound2_cbv_c x z n f e).
Proof.
  introv.
  apply cequivc_lam; introv.
  allrw @mkcv_less_substc.
  allrw @mkcv_cbv_substc_same.
  allrw @mkcv_cont1_dup1.
  allrw @mkcv_apply_substc.
  allrw @substc_mkcv_zero.
  allrw @mkc_var_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_vbot_substc.

  apply approxc_implies_cequivc; apply approxc_assume_hasvalue; intro hv.

  - apply hasvalue_likec_less in hv.
    repndors; exrepnd.

    + clear hv1 hv3 hv2.
      eapply cequivc_approxc_trans;
      [apply cequivc_mkc_less;
        [apply reduces_toc_implies_cequivc;exact hv0
        |apply cequivc_refl
        |apply cequivc_refl
        |apply cequivc_mkc_less;
          [apply reduces_toc_implies_cequivc;exact hv0
          |apply cequivc_refl
          |apply implies_cequivc_apply;
            [apply cequivc_refl
            |apply reduces_toc_implies_cequivc;exact hv0]
          |apply cequivc_refl]
        ]
      |].

      eapply approxc_cequivc_trans;
        [|apply cequivc_sym;
           apply simpl_cequivc_mkc_cbv;
           apply reduces_toc_implies_cequivc;exact hv0
        ].

      clear dependent u.

      rw @mkc_zero_eq.
      rw @mkc_nat_eq.
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_less_int|].
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym; apply cequivc_mkc_cbv]; eauto 3 with slow;[].

      allrw @mkcv_less_substc.
      allrw @mkcv_apply_substc.
      allrw @substc_mkcv_zero.
      allrw @mkc_var_substc.
      allrw @mkcv_vbot_substc.
      allrw @csubst_mk_cv.
      rw @mkc_zero_eq.
      rw @mkc_nat_eq.
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym; apply cequivc_mkc_less_int].

      boolvar; eauto 3 with slow; try (apply approxc_refl).

    + clear hv1.

      allrw @computes_to_excc_iff_reduces_toc.

      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_less;
          [apply reduces_toc_implies_cequivc;exact hv0
          |apply cequivc_refl
          |apply cequivc_refl
          |apply cequivc_refl]
        |].
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_less_exc|].

      eapply approxc_cequivc_trans;
        [|apply cequivc_sym;
           apply simpl_cequivc_mkc_cbv;
           apply reduces_toc_implies_cequivc;exact hv0
        ].
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym;
           apply cequivc_mkc_cbv_exc
        ].
      apply approxc_refl.

    + apply (computes_to_valc_and_excc_false _ _ _ mkc_zero) in hv2; tcsp.
      apply computes_to_valc_refl; eauto 3 with slow.

  - apply @hasvalue_likec_cbv in hv.
    apply @hasvalue_likec_implies_or in hv.
    repndors.

    + apply hasvaluec_computes_to_valc_implies in hv; exrepnd.
      eapply cequivc_approxc_trans;
        [apply simpl_cequivc_mkc_cbv;
          apply computes_to_valc_implies_cequivc;
          exact hv0|].
      eapply approxc_cequivc_trans;
        [|apply cequivc_mkc_less;
           [apply cequivc_sym
           |apply cequivc_refl
           |apply cequivc_refl
           |apply cequivc_mkc_less;
             [apply cequivc_sym
             |apply cequivc_refl
             |apply implies_cequivc_apply;
               [apply cequivc_refl
               |apply cequivc_sym]
             |apply cequivc_refl]
           ];
           apply computes_to_valc_implies_cequivc;
           exact hv0
        ].
      rw @computes_to_valc_iff_reduces_toc in hv0; repnd.
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_cbv;complete auto|].

      allrw @mkcv_less_substc.
      allrw @mkcv_apply_substc.
      allrw @substc_mkcv_zero.
      allrw @mkc_var_substc.
      allrw @mkcv_vbot_substc.
      allrw @csubst_mk_cv.
      apply approxc_refl.

    + allrw @raises_exceptionc_as_computes_to_excc; exrepnd.
      allrw @computes_to_excc_iff_reduces_toc.

      eapply cequivc_approxc_trans;
        [apply simpl_cequivc_mkc_cbv;
          apply reduces_toc_implies_cequivc;
          exact hv1|].
      eapply approxc_cequivc_trans;
        [|apply cequivc_mkc_less;
           [apply cequivc_sym
           |apply cequivc_refl
           |apply cequivc_refl
           |apply cequivc_refl];
           apply reduces_toc_implies_cequivc;
           exact hv1
        ].
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym; apply cequivc_mkc_less_exc].
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_cbv_exc|].
      apply approxc_refl.
Qed.

Definition sp_force_nat {o} (arg : @NTerm o) x z (f : @NTerm o) :=
  mk_cbv arg x (mk_less (mk_var x) mk_zero (mk_vbot z) (mk_apply f (mk_var x))).

Definition bound2_cbv {o} arg x z (n : nat) (f : @NTerm o) a : NTerm :=
  mk_cbv
    arg
    x
    (mk_less
       (mk_var x)
       mk_zero
       (mk_vbot z)
       (mk_less (mk_var x) (mk_nat n) (mk_apply f (mk_var x)) (spexc a))).

Lemma alpha_eq_sp_force_nat {o} :
  forall (arg1 arg2 : @NTerm o) x1 x2 z1 z2 f1 f2,
    isprog f1
    -> alpha_eq f1 f2
    -> alpha_eq arg1 arg2
    -> alpha_eq (sp_force_nat arg1 x1 z1 f1) (sp_force_nat arg2 x2 z2 f2).
Proof.
  introv ispf aeq1 aeq2.
  applydup @alpha_eq_preserves_isprog in aeq1; auto.
  unfold sp_force_nat, mk_cbv, mk_less, mk_apply, mk_vbot, mk_lam, mk_fix, mk_zero, nobnd.

  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: free_vars f1
                               ++ bound_vars f1
                               ++ free_vars f2
                               ++ bound_vars f2)) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v]); simpl; auto.

  { unfold all_vars; simpl.
    allrw remove_nvars_nil_l; allrw app_nil_r.
    allrw @remove_nvars_eq; allsimpl.
    allrw disjoint_singleton_l; allsimpl.
    repeat (allrw in_app_iff; simpl).
    tcsp. }

  allrw <- beq_var_refl.
  allrw memvar_singleton.
  repeat (rw (lsubst_aux_trivial_cl_term2 f1); eauto 2 with slow).
  repeat (rw (lsubst_aux_trivial_cl_term2 f2); eauto 2 with slow).

  prove_alpha_eq4.
  introv ln.

  repeat (destruct n; tcsp; try omega); eauto 3 with slow;
  clear ln;
  apply alphaeqbt_nilv2;
  prove_alpha_eq4;
  introv ln;
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;[].
  clear ln.

  apply alphaeqbt_nilv2.
  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: [])) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v0]); simpl; auto.

  { unfold all_vars; simpl; repeat (boolvar; allsimpl);
    allrw disjoint_singleton_l; allsimpl; tcsp. }

  repeat (boolvar; simpl); tcsp; eauto 2 with slow.
Qed.

Lemma alpha_eq_bound2_cbv {o} :
  forall (arg1 arg2 : @NTerm o) x1 x2 z1 z2 b f1 f2 a,
    isprog f1
    -> alpha_eq f1 f2
    -> alpha_eq arg1 arg2
    -> alpha_eq (bound2_cbv arg1 x1 z1 b f1 a) (bound2_cbv arg2 x2 z2 b f2 a).
Proof.
  introv ispf aeq1 aeq2.
  applydup @alpha_eq_preserves_isprog in aeq1; auto.
  unfold bound2_cbv, mk_cbv, mk_less, mk_apply, mk_vbot, mk_lam, mk_fix, mk_zero, nobnd.

  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: free_vars f1
                               ++ bound_vars f1
                               ++ free_vars f2
                               ++ bound_vars f2)) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v]); simpl; auto.

  { unfold all_vars; simpl.
    allrw remove_nvars_nil_l; allrw app_nil_r.
    allrw @remove_nvars_eq; allsimpl.
    allrw disjoint_singleton_l; allsimpl.
    repeat (allrw in_app_iff; simpl).
    tcsp. }

  allrw <- beq_var_refl.
  allrw memvar_singleton.
  repeat (rw (lsubst_aux_trivial_cl_term2 f1); eauto 2 with slow).
  repeat (rw (lsubst_aux_trivial_cl_term2 f2); eauto 2 with slow).

  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;
  clear ln;
  apply alphaeqbt_nilv2;
  prove_alpha_eq4;
  introv ln;
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;
  clear ln;
  apply alphaeqbt_nilv2;
  prove_alpha_eq4;
  introv ln;
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: [])) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v0]); simpl; auto.

  { unfold all_vars; simpl; repeat (boolvar; allsimpl);
    allrw disjoint_singleton_l; allsimpl; tcsp. }

  repeat (boolvar; simpl); tcsp; eauto 2 with slow.
Qed.

Lemma so_alphaeq_preserves_no_utokens {o} :
  forall (t1 t2 : @SOTerm o),
    so_alphaeq t1 t2
    -> no_utokens t1
    -> no_utokens t2.
Proof.
  introv aeq nout.
  apply get_utokens_so_soalphaeq in aeq.
  allunfold @no_utokens.
  rw aeq in nout; auto.
Qed.
Hint Resolve so_alphaeq_preserves_no_utokens : slow.

Definition computation_fails {o} lib (t : @NTerm o) :=
  {s : String.string
   & {u : NTerm
   & {k : nat
   & compute_at_most_k_steps lib k t = cfailure s u}}}.

Lemma alpha_eq_subst_sp_force_nat_alpha_eq {o} :
  forall v z (f : @NTerm o) t,
    isprog f
    -> alpha_eq
         (subst (mk_less (mk_var v) mk_zero (mk_vbot z) (mk_apply f (mk_var v))) v t)
         (mk_less t mk_zero (mk_vbot z) (mk_apply f t)).
Proof.
  introv isp.
  pose proof (unfold_lsubst
                [(v,t)]
                (mk_less (mk_var v) mk_zero (mk_vbot z) (mk_apply f (mk_var v))))
    as unf; exrepnd.
  unfold subst.
  rw unf0; clear unf0.
  allapply @alpha_eq_mk_less; exrepnd; subst.
  allapply @alpha_eq_mk_var; subst.
  allapply @alpha_eq_mk_vbot; exrepnd; subst.
  allapply @alpha_eq_mk_zero; subst.
  allapply @alpha_eq_mk_apply; exrepnd; subst.
  allapply @alpha_eq_mk_var; subst.

  allsimpl; cpx; ginv.

  allrw app_nil_r.
  allrw disjoint_cons_l.
  repnd.
  rename a' into f'.

  allrw memvar_singleton.
  allrw <- @beq_var_refl.
  rw (@lsubst_aux_trivial_cl_term2 o f'); eauto 3 with slow.

  unfold mk_less, mk_apply, mk_vbot, mk_zero, mk_nat, mk_integer, mk_fix, mk_lam, mk_var, nobnd.
  repeat (prove_alpha_eq4; eauto 2 with slow).

  { pose proof (ex_fresh_var (v' :: z :: [])) as fv.
    exrepnd; allsimpl; allrw not_over_or; repnd; GC.
    apply (al_bterm_aux [v0]); simpl; auto;
    repeat (boolvar; simpl); tcsp;
    allrw disjoint_singleton_l; allsimpl; tcsp. }
Qed.

Lemma wf_bound2_cbv {o} :
  forall (arg : @NTerm o) x z b f a,
    wf_term (bound2_cbv arg x z b f a) <=> (wf_term arg # wf_term f).
Proof.
  introv.
  unfold bound2_cbv.
  rw <- @wf_cbv_iff.
  repeat (rw <- @wf_less_iff).
  rw <- @wf_apply_iff.
  split; intro h; repnd; dands; eauto 3 with slow.
Qed.

Lemma wf_sp_force_nat {o} :
  forall (arg : @NTerm o) x z f,
    wf_term (sp_force_nat arg x z f) <=> (wf_term arg # wf_term f).
Proof.
  introv.
  rw <- @wf_cbv_iff.
  repeat (rw <- @wf_less_iff).
  rw <- @wf_apply_iff.
  split; intro h; repnd; dands; eauto 3 with slow.
Qed.

Lemma hasvalue_like_vbot {o} :
  forall (lib : @library o) z,
    !hasvalue_like lib (mk_vbot z).
Proof.
  introv hv.
  unfold hasvalue_like in hv; exrepnd.
  apply reduces_to_vbot_if_isvalue_like in hv1; sp.
Qed.

Lemma not_hasvalue_like_fresh {o} :
  forall lib (v : NVar), !@hasvalue_like o lib (mk_fresh v (mk_var v)).
Proof.
  introv hv.
  unfold hasvalue_like in hv; exrepnd.
  apply reduces_in_atmost_k_step_fresh_id in hv1; sp.
Qed.

Lemma hasvalue_like_subst_less_seq {o} :
  forall lib (f : @ntseq o) v a b c,
    hasvalue_like
      lib
      (subst (mk_less (mk_var v) a b c) v (sterm f))
    -> False.
Proof.
  introv comp.
  unfold subst, lsubst in comp; allsimpl; boolvar;
  repndors; try (subst v'); tcsp;
  allrw not_over_or; repnd; GC;
  try (complete (match goal with
                   | [ H : context[fresh_var ?l] |- _ ] =>
                     let h := fresh "h" in
                     pose proof (fresh_var_not_in l) as h;
                   unfold all_vars in h;
                   simpl in h;
                   repeat (rw in_app_iff in h);
                   repeat (rw not_over_or in h);
                   repnd; allsimpl; tcsp
                 end));
  allsimpl; boolvar; tcsp; fold_terms; allrw app_nil_r.

  unfold hasvalue_like, reduces_to in comp; exrepnd.

  destruct k.

  - allrw @reduces_in_atmost_k_steps_0; repnd; subst.
    unfold isvalue_like in comp0; allsimpl; tcsp.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf comp2; allsimpl; ginv.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import CtxtSwitchAux.Specs.save_ns_state_sysreg_state.
Require Import CtxtSwitchAux.LowSpecs.save_ns_state_sysreg_state.
Require Import CtxtSwitchAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       get_rec_sysregs_spec
       sysreg_write_spec
    .

  Lemma save_ns_state_sysreg_state_spec_exists:
    forall habd habd'  labd
           (Hspec: save_ns_state_sysreg_state_spec  habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', save_ns_state_sysreg_state_spec0  labd = Some labd' /\ relate_RData habd' labd'.
    Proof.
      Local Opaque ptr_eq get_reg set_reg.
      intros. destruct Hrel.
      unfold save_ns_state_sysreg_state_spec, save_ns_state_sysreg_state_spec0 in *.
      unfold sysreg_read_spec, set_ns_state_spec.
      autounfold in Hspec.
      hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec.
      destruct regs_is_int64_dec in C; [|inversion C].
      unfold Assertion.
      repeat (unfold bind64 at 1; rewrite e; repeat simpl_update_reg; repeat (simpl priv; simpl cpu_regs; simpl_field);
              unfold bind at 1; simpl ns_regs_el2).
      eexists; split. reflexivity. constructor. reflexivity.
    Qed.

End Refine.


From iris.base_logic.lib Require Export invariants.
From iris.algebra Require Import auth gmap agree.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.

(** The CMRAs we need. *)
Class boxG Σ :=
  boxG_inG :> inG Σ (prodR
    (authR (optionUR (exclR boolC)))
    (optionR (agreeR (laterC (iPreProp Σ))))).

Definition boxΣ : gFunctors := #[ GFunctor (authR (optionUR (exclR boolC)) *
                                            optionRF (agreeRF (▶ ∙)) ) ].

Instance subG_boxΣ Σ : subG boxΣ Σ → boxG Σ.
Proof. solve_inG. Qed.

Section box_defs.
  Context `{invG Σ, boxG Σ} (N : namespace).

  Definition slice_name := gname.

  Definition box_own_auth (γ : slice_name) (a : auth (option (excl bool))) : iProp Σ :=
    own γ (a, None).

  Definition box_own_prop (γ : slice_name) (P : iProp Σ) : iProp Σ :=
    own γ (ε, Some (to_agree (Next (iProp_unfold P)))).

  Definition slice_inv (γ : slice_name) (P : iProp Σ) : iProp Σ :=
    (∃ b, box_own_auth γ (● Excl' b) ∗ if b then P else True)%I.

  Definition slice (γ : slice_name) (P : iProp Σ) : iProp Σ :=
    (box_own_prop γ P ∗ inv N (slice_inv γ P))%I.

  Definition box (f : gmap slice_name bool) (P : iProp Σ) : iProp Σ :=
    (∃ Φ : slice_name → iProp Σ,
      ▷ (P ≡ [∗ map] γ ↦ _ ∈ f, Φ γ) ∗
      [∗ map] γ ↦ b ∈ f, box_own_auth γ (◯ Excl' b) ∗ box_own_prop γ (Φ γ) ∗
                         inv N (slice_inv γ (Φ γ)))%I.
End box_defs.

Instance: Params (@box_own_prop) 3.
Instance: Params (@slice_inv) 3.
Instance: Params (@slice) 5.
Instance: Params (@box) 5.

Section box.
Context `{invG Σ, boxG Σ} (N : namespace).
Implicit Types P Q : iProp Σ.

Global Instance box_own_prop_ne γ : NonExpansive (box_own_prop γ).
Proof. solve_proper. Qed.
Global Instance box_own_prop_contractive γ : Contractive (box_own_prop γ).
Proof. solve_contractive. Qed.

Global Instance box_inv_ne γ : NonExpansive (slice_inv γ).
Proof. solve_proper. Qed.

Global Instance slice_ne γ : NonExpansive (slice N γ).
Proof. solve_proper. Qed.
Global Instance slice_contractive γ : Contractive (slice N γ).
Proof. solve_contractive. Qed.
Global Instance slice_proper γ : Proper ((≡) ==> (≡)) (slice N γ).
Proof. apply ne_proper, _. Qed.

Global Instance slice_persistent γ P : Persistent (slice N γ P).
Proof. apply _. Qed.

Global Instance box_contractive f : Contractive (box N f).
Proof. solve_contractive. Qed.
Global Instance box_ne f : NonExpansive (box N f).
Proof. apply (contractive_ne _). Qed.
Global Instance box_proper f : Proper ((≡) ==> (≡)) (box N f).
Proof. apply ne_proper, _. Qed.

Lemma box_own_auth_agree γ b1 b2 :
  box_own_auth γ (● Excl' b1) ∗ box_own_auth γ (◯ Excl' b2) ⊢ ⌜b1 = b2⌝.
Proof.
  rewrite /box_own_prop -own_op own_valid prod_validI /= and_elim_l.
  by iDestruct 1 as % [[[] [=]%leibniz_equiv] ?]%auth_valid_discrete.
Qed.

Lemma box_own_auth_update γ b1 b2 b3 :
  box_own_auth γ (● Excl' b1) ∗ box_own_auth γ (◯ Excl' b2)
  ==∗ box_own_auth γ (● Excl' b3) ∗ box_own_auth γ (◯ Excl' b3).
Proof.
  rewrite /box_own_auth -!own_op. apply own_update, prod_update; last done.
  by apply auth_update, option_local_update, exclusive_local_update.
Qed.

Lemma box_own_agree γ Q1 Q2 :
  box_own_prop γ Q1 ∗ box_own_prop γ Q2 ⊢ ▷ (Q1 ≡ Q2).
Proof.
  rewrite /box_own_prop -own_op own_valid prod_validI /= and_elim_r.
  rewrite option_validI /= agree_validI agree_equivI later_equivI /=.
  iIntros "#HQ". iNext. rewrite -{2}(iProp_fold_unfold Q1).
  iRewrite "HQ". by rewrite iProp_fold_unfold.
Qed.

Lemma box_alloc : box N ∅ True%I.
Proof.
  iIntros. iExists (λ _, True)%I. iSplit; by auto.
Qed.

Lemma slice_insert_empty E q f Q P :
  ▷?q box N f P ={E}=∗ ∃ γ, ⌜f !! γ = None⌝ ∗
    slice N γ Q ∗ ▷?q box N (<[γ:=false]> f) (Q ∗ P).
Proof.
  iDestruct 1 as (Φ) "[#HeqP Hf]".
  iMod (own_alloc_strong (● Excl' false ⋅ ◯ Excl' false,
    Some (to_agree (Next (iProp_unfold Q)))) (dom _ f))
    as (γ) "[Hdom Hγ]"; first done.
  rewrite pair_split. iDestruct "Hγ" as "[[Hγ Hγ'] #HγQ]".
  iDestruct "Hdom" as % ?%not_elem_of_dom.
  iMod (inv_alloc N _ (slice_inv γ Q) with "[Hγ]") as "#Hinv".
  { iNext. iExists false; eauto. }
  iModIntro; iExists γ; repeat iSplit; auto.
  iNext. iExists (<[γ:=Q]> Φ); iSplit.
  - iNext. iRewrite "HeqP". by rewrite big_opM_fn_insert'.
  - rewrite (big_opM_fn_insert (λ _ _ P',  _ ∗ _ _ P' ∗ _ _ (_ _ P')))%I //.
    iFrame; eauto.
Qed.

Lemma slice_delete_empty E q f P Q γ :
  ↑N ⊆ E →
  f !! γ = Some false →
  slice N γ Q -∗ ▷?q box N f P ={E}=∗ ∃ P',
    ▷?q (▷ (P ≡ (Q ∗ P')) ∗ box N (delete γ f) P').
Proof.
  iIntros (??) "[#HγQ Hinv] H". iDestruct "H" as (Φ) "[#HeqP Hf]".
  iExists ([∗ map] γ'↦_ ∈ delete γ f, Φ γ')%I.
  iInv N as (b) "[>Hγ _]".
  iDestruct (big_opM_delete _ f _ false with "Hf")
    as "[[>Hγ' #[HγΦ ?]] ?]"; first done.
  iDestruct (box_own_auth_agree γ b false with "[-]") as %->; first by iFrame.
  iModIntro. iSplitL "Hγ"; first iExists false; eauto.
  iModIntro. iNext. iSplit.
  - iDestruct (box_own_agree γ Q (Φ γ) with "[#]") as "HeqQ"; first by eauto.
    iNext. iRewrite "HeqP". iRewrite "HeqQ". by rewrite -big_opM_delete.
  - iExists Φ; eauto.
Qed.

Lemma slice_fill E q f γ P Q :
  ↑N ⊆ E →
  f !! γ = Some false →
  slice N γ Q -∗ ▷ Q -∗ ▷?q box N f P ={E}=∗ ▷?q box N (<[γ:=true]> f) P.
Proof.
  iIntros (??) "#[HγQ Hinv] HQ H"; iDestruct "H" as (Φ) "[#HeqP Hf]".
  iInv N as (b') "[>Hγ _]".
  iDestruct (big_opM_delete _ f _ false with "Hf")
    as "[[>Hγ' #[HγΦ Hinv']] ?]"; first done.
  iMod (box_own_auth_update γ b' false true with "[$Hγ $Hγ']") as "[Hγ Hγ']".
  iModIntro. iSplitL "Hγ HQ"; first (iNext; iExists true; by iFrame).
  iModIntro; iNext; iExists Φ; iSplit.
  - by rewrite big_opM_insert_override.
  - rewrite -insert_delete big_opM_insert ?lookup_delete //.
    iFrame; eauto.
Qed.

Lemma slice_empty E q f P Q γ :
  ↑N ⊆ E →
  f !! γ = Some true →
  slice N γ Q -∗ ▷?q box N f P ={E}=∗ ▷ Q ∗ ▷?q box N (<[γ:=false]> f) P.
Proof.
  iIntros (??) "#[HγQ Hinv] H"; iDestruct "H" as (Φ) "[#HeqP Hf]".
  iInv N as (b) "[>Hγ HQ]".
  iDestruct (big_opM_delete _ f with "Hf")
    as "[[>Hγ' #[HγΦ Hinv']] ?]"; first done.
  iDestruct (box_own_auth_agree γ b true with "[-]") as %->; first by iFrame.
  iFrame "HQ".
  iMod (box_own_auth_update γ with "[$Hγ $Hγ']") as "[Hγ Hγ']".
  iModIntro. iSplitL "Hγ"; first (iNext; iExists false; by repeat iSplit).
  iModIntro; iNext; iExists Φ; iSplit.
  - by rewrite big_opM_insert_override.
  - rewrite -insert_delete big_opM_insert ?lookup_delete //.
    iFrame; eauto.
Qed.

Lemma slice_insert_full E q f P Q :
  ↑N ⊆ E →
  ▷ Q -∗ ▷?q box N f P ={E}=∗ ∃ γ, ⌜f !! γ = None⌝ ∗
    slice N γ Q ∗ ▷?q box N (<[γ:=true]> f) (Q ∗ P).
Proof.
  iIntros (?) "HQ Hbox".
  iMod (slice_insert_empty with "Hbox") as (γ ?) "[#Hslice Hbox]".
  iExists γ. iFrame "%#". iMod (slice_fill with "Hslice HQ Hbox"); first done.
  by apply lookup_insert. by rewrite insert_insert.
Qed.

Lemma slice_delete_full E q f P Q γ :
  ↑N ⊆ E →
  f !! γ = Some true →
  slice N γ Q -∗ ▷?q box N f P ={E}=∗
  ∃ P', ▷ Q ∗ ▷?q ▷ (P ≡ (Q ∗ P')) ∗ ▷?q box N (delete γ f) P'.
Proof.
  iIntros (??) "#Hslice Hbox".
  iMod (slice_empty with "Hslice Hbox") as "[$ Hbox]"; try done.
  iMod (slice_delete_empty with "Hslice Hbox") as (P') "[Heq Hbox]"; first done.
  { by apply lookup_insert. }
  iExists P'. iFrame. rewrite -insert_delete delete_insert ?lookup_delete //.
Qed.

Lemma box_fill E f P :
  ↑N ⊆ E →
  box N f P -∗ ▷ P ={E}=∗ box N (const true <$> f) P.
Proof.
  iIntros (?) "H HP"; iDestruct "H" as (Φ) "[#HeqP Hf]".
  iExists Φ; iSplitR; first by rewrite big_opM_fmap.
  iEval (rewrite internal_eq_iff later_iff big_sepM_later) in "HeqP".
  iDestruct ("HeqP" with "HP") as "HP".
  iCombine "Hf" "HP" as "Hf".
  rewrite -big_opM_opM big_opM_fmap; iApply (fupd_big_sepM _ _ f).
  iApply (@big_sepM_impl with "Hf").
  iIntros "!#" (γ b' ?) "[(Hγ' & #$ & #$) HΦ]".
  iInv N as (b) "[>Hγ _]".
  iMod (box_own_auth_update γ with "[Hγ Hγ']") as "[Hγ $]"; first by iFrame.
  iModIntro. iSplitL; last done. iNext; iExists true. iFrame.
Qed.

Lemma box_empty E f P :
  ↑N ⊆ E →
  map_Forall (λ _, (true =)) f →
  box N f P ={E}=∗ ▷ P ∗ box N (const false <$> f) P.
Proof.
  iDestruct 1 as (Φ) "[#HeqP Hf]".
  iAssert (([∗ map] γ↦b ∈ f, ▷ Φ γ) ∗
    [∗ map] γ↦b ∈ f, box_own_auth γ (◯ Excl' false) ∗  box_own_prop γ (Φ γ) ∗
      inv N (slice_inv γ (Φ γ)))%I with "[> Hf]" as "[HΦ ?]".
  { rewrite -big_opM_opM -fupd_big_sepM. iApply (@big_sepM_impl with "[$Hf]").
    iIntros "!#" (γ b ?) "(Hγ' & #HγΦ & #Hinv)".
    assert (true = b) as <- by eauto.
    iInv N as (b) "[>Hγ HΦ]".
    iDestruct (box_own_auth_agree γ b true with "[-]") as %->; first by iFrame.
    iMod (box_own_auth_update γ true true false with "[$Hγ $Hγ']") as "[Hγ $]".
    iModIntro. iSplitL "Hγ"; first (iNext; iExists false; iFrame; eauto).
    iFrame "HγΦ Hinv". by iApply "HΦ". }
  iModIntro; iSplitL "HΦ".
  - rewrite internal_eq_iff later_iff big_sepM_later. by iApply "HeqP".
  - iExists Φ; iSplit; by rewrite big_opM_fmap.
Qed.

Lemma slice_iff E q f P Q Q' γ b :
  ↑N ⊆ E → f !! γ = Some b →
  ▷ □ (Q ↔ Q') -∗ slice N γ Q -∗ ▷?q box N f P ={E}=∗ ∃ γ' P',
    ⌜delete γ f !! γ' = None⌝ ∗ ▷?q ▷ □ (P ↔ P') ∗
    slice N γ' Q' ∗ ▷?q box N (<[γ' := b]>(delete γ f)) P'.
Proof.
  iIntros (??) "#HQQ' #Hs Hb". destruct b.
  - iMod (slice_delete_full with "Hs Hb") as (P') "(HQ & Heq & Hb)"; try done.
    iDestruct ("HQQ'" with "HQ") as "HQ'".
    iMod (slice_insert_full with "HQ' Hb") as (γ' ?) "[#Hs' Hb]"; try done.
    iExists γ', _. iIntros "{$∗ $# $%} !>". do 2 iNext. iRewrite "Heq".
    iAlways. by iSplit; iIntros "[? $]"; iApply "HQQ'".
  - iMod (slice_delete_empty with "Hs Hb") as (P') "(Heq & Hb)"; try done.
    iMod (slice_insert_empty with "Hb") as (γ' ?) "[#Hs' Hb]"; try done.
    iExists γ', (Q' ∗ P')%I. iIntros "{$∗ $# $%} !>".  do 2 iNext. iRewrite "Heq".
    iAlways. by iSplit; iIntros "[? $]"; iApply "HQQ'".
Qed.

Lemma slice_split E q f P Q1 Q2 γ b :
  ↑N ⊆ E → f !! γ = Some b →
  slice N γ (Q1 ∗ Q2) -∗ ▷?q box N f P ={E}=∗ ∃ γ1 γ2,
    ⌜delete γ f !! γ1 = None⌝ ∗ ⌜delete γ f !! γ2 = None⌝ ∗ ⌜γ1 ≠ γ2⌝ ∗
    slice N γ1 Q1 ∗ slice N γ2 Q2 ∗ ▷?q box N (<[γ2 := b]>(<[γ1 := b]>(delete γ f))) P.
Proof.
  iIntros (??) "#Hslice Hbox". destruct b.
  - iMod (slice_delete_full with "Hslice Hbox") as (P') "([HQ1 HQ2] & Heq & Hbox)"; try done.
    iMod (slice_insert_full with "HQ1 Hbox") as (γ1 ?) "[#Hslice1 Hbox]"; first done.
    iMod (slice_insert_full with "HQ2 Hbox") as (γ2 ?) "[#Hslice2 Hbox]"; first done.
    iExists γ1, γ2. iIntros "{$% $#} !>". iSplit; last iSplit; try iPureIntro.
    { by eapply lookup_insert_None. }
    { by apply (lookup_insert_None (delete γ f) γ1 γ2 true). }
    iNext. iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq] Hbox").
    iNext. iRewrite "Heq". iPureIntro. by rewrite assoc (comm _ Q2).
  - iMod (slice_delete_empty with "Hslice Hbox") as (P') "[Heq Hbox]"; try done.
    iMod (slice_insert_empty with "Hbox") as (γ1 ?) "[#Hslice1 Hbox]".
    iMod (slice_insert_empty with "Hbox") as (γ2 ?) "[#Hslice2 Hbox]".
    iExists γ1, γ2. iIntros "{$% $#} !>". iSplit; last iSplit; try iPureIntro.
    { by eapply lookup_insert_None. }
    { by apply (lookup_insert_None (delete γ f) γ1 γ2 false). }
    iNext. iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq] Hbox").
    iNext. iRewrite "Heq". iPureIntro. by rewrite assoc (comm _ Q2).
Qed.

Lemma slice_combine E q f P Q1 Q2 γ1 γ2 b :
  ↑N ⊆ E → γ1 ≠ γ2 → f !! γ1 = Some b → f !! γ2 = Some b →
  slice N γ1 Q1 -∗ slice N γ2 Q2 -∗ ▷?q box N f P ={E}=∗ ∃ γ,
    ⌜delete γ2 (delete γ1 f) !! γ = None⌝ ∗ slice N γ (Q1 ∗ Q2) ∗
    ▷?q box N (<[γ := b]>(delete γ2 (delete γ1 f))) P.
Proof.
  iIntros (????) "#Hslice1 #Hslice2 Hbox". destruct b.
  - iMod (slice_delete_full with "Hslice1 Hbox") as (P1) "(HQ1 & Heq1 & Hbox)"; try done.
    iMod (slice_delete_full with "Hslice2 Hbox") as (P2) "(HQ2 & Heq2 & Hbox)"; first done.
    { by simplify_map_eq. }
    iMod (slice_insert_full _ _ _ _ (Q1 ∗ Q2)%I with "[$HQ1 $HQ2] Hbox")
      as (γ ?) "[#Hslice Hbox]"; first done.
    iExists γ. iIntros "{$% $#} !>". iNext.
    iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq1 Heq2] Hbox").
    iNext. iRewrite "Heq1". iRewrite "Heq2". by rewrite assoc.
  - iMod (slice_delete_empty with "Hslice1 Hbox") as (P1) "(Heq1 & Hbox)"; try done.
    iMod (slice_delete_empty with "Hslice2 Hbox") as (P2) "(Heq2 & Hbox)"; first done.
    { by simplify_map_eq. }
    iMod (slice_insert_empty with "Hbox") as (γ ?) "[#Hslice Hbox]".
    iExists γ. iIntros "{$% $#} !>". iNext.
    iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq1 Heq2] Hbox").
    iNext. iRewrite "Heq1". iRewrite "Heq2". by rewrite assoc.
Qed.
End box.

Typeclasses Opaque slice box.


Require Import Common.Definitions.
Require Import Common.Memory.
Require Import Intermediate.Machine.
Require Import Lib.Monads.
Require Import Intermediate.GlobalEnv.
Require Import Old.Intermediate.MachineExtra.

Import Intermediate.
Import Machine.Intermediate.
Import MachineExtra.Intermediate.

From mathcomp Require Import ssreflect ssrfun.

Set Bullet Behavior "Strict Subproofs".

Definition empty_global_env := {|
  genv_interface := emptym;
  genv_procedures := emptym;
  genv_entrypoints := emptym
|}.

Lemma prepare_global_env_empty_prog:
  prepare_global_env empty_prog = empty_global_env.
Proof.
  unfold prepare_global_env.
  rewrite prepare_procedures_initial_memory_empty_program.
  reflexivity.
Qed.

Lemma genv_procedures_program_link_left_in :
  forall {p Cid},
    Cid \in domm (prog_interface p) ->
  forall {c},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
    (genv_procedures (prepare_global_env (program_link p c))) Cid =
    (genv_procedures (prepare_global_env p)) Cid.
Proof.
  intros p Cid Hin c Hwfp Hwfc Hlinkable Hmains.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable Hmains).
  unfold global_env_union; simpl.
  rewrite unionmE.
  assert
    (exists procs, (genv_procedures (prepare_global_env p)) Cid = Some procs)
    as [procs Hprocs]
    by (apply /dommP; rewrite domm_genv_procedures; assumption).
  setoid_rewrite Hprocs.
  assumption.
Qed.

Lemma find_label_in_procedure_2:
  forall G pc pc' l,
    find_label_in_procedure G pc l = Some pc' ->
    Pointer.block pc = Pointer.block pc'.
Proof.
  eapply find_label_in_procedure_guarantees.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.

See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2013-07-30

* Interpretation of positive inductive data type systems

as computability predicates so that the accessible arguments (that
must satisfy some positivity condition) of a computable constructor
term are computable.
*)

Set Implicit Arguments.

From Coq Require Import IndefiniteDescription Structures.OrderedType.
From CoLoR Require Import LogicUtil SN LCompSimple Tarski VecUtil SetUtil
     RelUtil.
From CoLoR Require Union SetUtil RelUtil AccUtil.

(****************************************************************************)
(** * Accessible supterm relation. *)

Module Export Def.

  Section supterm_acc.

    Variables F X : Type.
    Notation Fun := (@Fun F X).
    Notation Te := (@Te F X).

    Variable So : Type.
    Notation Ty := (@Ty So).

    Variable typ : F -> Ty.
    Notation TypArgs := (@TypArgs F X So typ).

    Variables (Acc : F -> set nat)
      (Acc_arity : forall f i, Acc f i -> i < arity (typ f)).

    Inductive supterm_acc : relation Te :=
    | stacc_intro : forall f (ts : TypArgs f) i (hi : Acc f i),
      supterm_acc (apps (Fun f) ts) (Vnth ts (Acc_arity hi)).

    Lemma stacc_intro' f (ts : TypArgs f) i (hi : Acc f i) t u :
      t = apps (Fun f) ts -> u = Vnth ts (Acc_arity hi) -> supterm_acc t u.

    Proof. intros e1 e2. subst. apply stacc_intro. Qed.

  End supterm_acc.

End Def.

(****************************************************************************)
(** * Structure on base types for defining their interpretation as computability predicates. *)

Module Type BI_Struct.

  (** We assume given an ST structure. *)

  Declare Module Export ST : ST_Struct.

  (** We assume given a decidable total ordering structure on base
  types. *)

  Declare Module Export BOrd : OrderedType
  with Definition t := So
  with Definition eq := @Logic.eq So.

  Infix "<B" := lt (at level 70).
  Notation gtB := (transp lt) (only parsing).
  Infix ">B" := gtB (at level 70).

  (** We assume that [ltB] is well-founded (in Coq sense). *)

  Parameter ltB_wf : well_founded lt.

  (** For each symbol [f : T_0 ~~> .. ~~> T_{n-1} -> A], we assume
     given a set [Acc f] of accessible argument positions [i] between
     [0] and [n-1] such that, for every base type [B] occurring in
     [T_i], either [B] is smaller than [A], or [B] is equivalent to
     [A] and occurs only positively in [T_i]. *)

  Parameter Acc : F -> set nat.
  Parameter Acc_arity : forall f i, Acc f i -> i < arity (typ f).
  Parameter Acc_ok : forall f i (hi : Acc f i) a,
    occurs a (Vnth (inputs (typ f)) (Acc_arity hi)) ->
    a <B output_base (typ f)
    \/ (a = output_base (typ f)
      /\ pos a (Vnth (inputs (typ f)) (Acc_arity hi))).

  Arguments Acc_ok [f i hi a] _.

  (** Notations. *)

  Notation aeq := (@aeq F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation vaeq := (Vforall2 aeq).
  Notation supterm_acc := (@supterm_acc F X So typ Acc Acc_arity).

End BI_Struct.

(****************************************************************************)
(** * Definition of the interpretation of base types

given an ST structure for terms, a CP structure for the rewrite
relation, and a BI structure. *)

Module Make (Export ST : ST_Struct)
  (Export CP : CP_Struct with Module L := ST.L)
  (Export BI : BI_Struct with Module ST := ST).

  Module Import P := OrderedTypeFacts BOrd.
  Module Export CS := LCompSimple.Make ST CP.

  (*COQ: why is it needed?*)
  Infix "=>R" := (clos_aeq (clos_mon Rh)).
  Infix "=>R*" := (R_aeq*).

(****************************************************************************)
(** ** Properties of [supterm_acc]. *)

  Lemma supterm_acc_supterm : supterm_acc << supterm!.

  Proof. intros t u [f ts i hi]. apply supterm_nth. Qed.

  Lemma supterm_acc_wf : WF supterm_acc.

  Proof.
    eapply WF_incl. apply supterm_acc_supterm. apply WF_tc. apply supterm_wf.
  Qed.

  Global Instance size_subpterm_acc : Proper (supterm_acc --> Peano.lt) size.

  Proof. intros t u tu. inversion tu; subst. apply size_apps_r_nth. Qed.

  Lemma supterm_acc_size : supterm_acc << transp (ltof size).

  Proof. intros t u tu. apply size_subpterm_acc. hyp. Qed.

  Lemma aeq_supterm_acc_commut : aeq @ supterm_acc << supterm_acc @ aeq.

  Proof.
    intros t u [t' [tt' t'u]]. inversion t'u; clear t'u; subst.
    inv_aeq tt'; subst. exists (Vnth us (Acc_arity hi)). split.
    apply stacc_intro. apply Vforall2_elim_nth. hyp.
  Qed.

  Lemma aeq_tc_supterm_acc_commut :
    aeq @ (supterm_acc!) << (supterm_acc!) @ aeq.

  Proof. apply commut_tc_inv. apply aeq_supterm_acc_commut. Qed.

  Lemma supterm_acc_subs : forall s t u,
    supterm_acc t u -> supterm_acc (subs s t) (subs s u).

  Proof.
    intros s t u tu. inversion tu; clear tu; subst.
    rewrite subs_apps, <- Vnth_map. apply stacc_intro.
  Qed.

  Lemma tc_supterm_acc_subs : forall s t u,
    supterm_acc! t u -> supterm_acc! (subs s t) (subs s u).

  Proof.
    intros s t u tu. revert t u tu; induction 1.
    apply t_step. apply supterm_acc_subs. hyp.
    trans (subs s y); fo.
  Qed.

  Section tc_supterm_acc_R_mon_wf.

    Variables (R : relation Te) (R_mon : Monotone R).

    Lemma supterm_acc_R_mon_commut : supterm_acc @ R << R @ supterm_acc.

    Proof.
      intros t v [u [tu uv]]. inversion tu; clear tu; subst.
      exists (apps (Fun f) (Vreplace ts (Acc_arity hi) v)).
      split. (*COQ:rewrite <- (Vreplace_nth_eq ts (Acc_arity hi)) at 1.*)
      set (ts' := Vreplace ts (Acc_arity hi) v).
      rewrite <- (Vreplace_nth_eq ts (Acc_arity hi)). unfold ts'. mon.
      rewrite <- (Vnth_replace (Acc_arity hi) (Acc_arity hi) ts v) at 2.
      apply stacc_intro.
    Qed.

    Lemma tc_supterm_acc_R_mon_commut : supterm_acc! @ R << R @ supterm_acc!.

    Proof. apply commut_tc. apply supterm_acc_R_mon_commut. Qed.

    Lemma tc_supterm_acc_R_mon_wf : WF R -> WF (supterm_acc! U R).

    Proof.
      intro R_wf. apply Union.WF_union_commut.
      apply WF_tc. apply supterm_acc_wf. hyp.
      apply tc_supterm_acc_R_mon_commut.
    Qed.

    Import RelUtil.

    Section restrict.

      Variables (P : set Te) (P_R : Proper (R ==> impl) P).

      Lemma restrict_tc_supterm_acc_R_mon_wf :
        WF (restrict P R) -> WF (restrict P (supterm_acc! U R)).

      Proof.
        intro R_wf. rewrite restrict_union. apply Union.WF_union_commut.
        apply wf_restrict_sn. intros t ht. apply WF_tc. apply supterm_acc_wf.
        hyp. intros t v [u [[ht tu] [hu uv]]].
        assert (a : (supterm_acc! @ R) t v). exists u. fo.
        destruct (tc_supterm_acc_R_mon_commut a) as [u' [tu' u'v]]. exists u'.
        split; split; auto. eapply P_R. apply tu'. hyp.
      Qed.

    End restrict.

    Lemma restrict_SN_tc_supterm_acc_R_mon_wf :
      WF (restrict (SN R) (supterm_acc! U R)).

    Proof.
      apply restrict_tc_supterm_acc_R_mon_wf. class.
      apply wf_restrict_sn. refl.
    Qed.

  End tc_supterm_acc_R_mon_wf.

(****************************************************************************)
(** ** Properties of [clos_aeq supterm_acc]. *)

  Lemma clos_aeq_supterm_acc_wf : WF (clos_aeq supterm_acc).

  Proof. apply clos_aeq_wf_size. apply supterm_acc_size. Qed.

  Global Instance clos_aeq_tc_supterm_cc_trans : Transitive (clos_aeq (supterm_acc!)).

  Proof.
    rewrite <- trans_intro. rewrite clos_aeq_eq, !comp_assoc.
    rewrite (commut_comp (tc_supterm_acc_R_mon_commut (R:=aeq) _)), !comp_assoc.
    rewrite (commut_comp (tc_supterm_acc_R_mon_commut (R:=aeq) _)), !comp_assoc.
    rewrite !(comp_incl_assoc (trans_comp_incl _)). refl.
  Qed.

  Lemma clos_aeq_tc_supterm_acc_eq :
    clos_aeq (supterm_acc!) == (clos_aeq supterm_acc)!.

  Proof.
    split.
    (* << *)
    intros t u tu. inversion tu; clear tu; subst.
    revert u' v' H1 t H u H0; induction 1; intros t tt' u uu'.
    apply t_step. eapply clos_aeq_intro. apply tt'. apply uu'. hyp.
    trans y; firstorder auto with crelations.
    (* >> *)
    apply tc_min. 2: class. apply clos_aeq_incl. apply incl_tc. refl.
  Qed.

  Lemma clos_aeq_tc_supterm_acc_wf : WF (clos_aeq (supterm_acc!)).

  Proof.
    apply clos_aeq_wf_size. apply tc_incl_trans. apply transp_trans. class.
    apply supterm_acc_size.
  Qed.

  Lemma clos_aeq_tc_supterm_acc_subs : forall s t u,
    clos_aeq (supterm_acc!) t u ->
    clos_aeq (supterm_acc!) (subs s t) (subs s u).

  Proof.
    intros s t u tu.
    destruct (clos_aeq_inv tu) as [t' [u' [tt' [uu' t'u']]]]; clear tu.
    rewrite tt', uu'. apply clos_aeq_intro_refl.
    apply tc_supterm_acc_subs. hyp.
  Qed.

  Section clos_aeq_tc_supterm_acc_R_mon_wf.

    Variables (R : relation Te) (R_mon : Monotone R)
      (R_aeq : Proper (aeq ==> aeq ==> impl) R).

    Lemma clos_aeq_supterm_acc_R_mon_commut :
      clos_aeq supterm_acc @ R << R @ clos_aeq supterm_acc.

    Proof.
      intros t v [u [tu uv]].
      inversion tu; clear tu; subst; rename u' into t'; rename v' into u'.
      assert (a : (supterm_acc @ R) t' v). exists u'. rewrite H0 in uv. fo.
      destruct (supterm_acc_R_mon_commut R_mon a) as [w [t'w wv]].
      exists w. split. rewrite H. hyp. apply clos_aeq_intro_refl. hyp.
    Qed.

    Lemma clos_aeq_tc_supterm_acc_R_mon_commut :
      clos_aeq (supterm_acc!) @ R << R @ clos_aeq (supterm_acc!).

    Proof.
      rewrite clos_aeq_tc_supterm_acc_eq. apply commut_tc.
      apply clos_aeq_supterm_acc_R_mon_commut.
    Qed.

    Lemma clos_aeq_tc_supterm_acc_R_mon_wf :
      WF R -> WF (clos_aeq (supterm_acc!) U R).

    Proof.
      intro R_wf. apply Union.WF_union_commut.
      apply clos_aeq_tc_supterm_acc_wf. hyp.
      apply clos_aeq_tc_supterm_acc_R_mon_commut.
    Qed.

    Import SetUtil RelUtil.

    Section restrict.

      Variables (P : set Te) (P_R : Proper (R ==> impl) P).

      Lemma restrict_clos_aeq_tc_supterm_acc_R_mon_wf :
        WF (restrict P R) -> WF (restrict P (clos_aeq (supterm_acc!) U R)).

      Proof.
        intro R_wf. rewrite restrict_union. apply Union.WF_union_commut.
        apply wf_restrict_sn. intros t ht. apply clos_aeq_tc_supterm_acc_wf.
        hyp. intros t v [u [[ht tu] [hu uv]]].
        assert (a : (clos_aeq (supterm_acc!) @ R) t v). exists u. fo.
        destruct (clos_aeq_tc_supterm_acc_R_mon_commut a) as [u' [tu' u'v]].
        exists u'. split; split; auto. eapply P_R. apply tu'. hyp.
      Qed.

    End restrict.

    Lemma restrict_SN_clos_aeq_tc_supterm_acc_R_mon_wf :
      WF (restrict (SN R) (clos_aeq (supterm_acc!) U R)).

    Proof.
      apply restrict_clos_aeq_tc_supterm_acc_R_mon_wf. class.
      apply wf_restrict_sn. refl.
    Qed.

  End clos_aeq_tc_supterm_acc_R_mon_wf.

(****************************************************************************)
(** ** Interpretation of types

The interpretation [I] will be defined by well-founded induction
on [ltB] using Coq's corresponding combinator [Wf.Fix], which requires
a function [F] computing the interpretation of a base type [a] from
the interpretation [I_lt_a] for each base type strictly smaller than
[a]. The interpretation of [a] itself is defined as the least fixpoint
of some variant of the following monotone function [G]. *)

  Import SetUtil AccUtil.

  Section fixpoint.

    Variable a : So.

    Definition G I : set Te := fun t =>
      SN R_aeq t /\ forall f, output_base (typ f) = a ->
        forall ts : Tes (arity (typ f)), R_aeq* t (apps (Fun f) ts) ->
          forall i (hi : Acc f i),
            int I (Vnth (inputs (typ f)) (Acc_arity hi))
                  (Vnth ts (Acc_arity hi)).

    Variable I_lt_a : forall b, b <B a -> set Te.

    Definition update (X : set Te) b :=
      match BOrd.compare b a with
        | LT h => I_lt_a h
        | EQ _ => X
        | GT _ => SN R_aeq
      end.

    Definition G' X := G (update X).

    Definition F := lfp subset set_glb G'.

  End fixpoint.

  Definition I : So -> set Te := Fix ltB_wf F.

(** We now check that [G] is monotone. *)

  Section G'_props.

    Variables (a : So) (I_lt_a : forall b, b <B a -> set Te).

    Global Instance G'_mon : Proper (subset ==> subset) (G' I_lt_a).

    Proof.
      intros X Y XY t [snt ht]. split. hyp. intros f hf ts h i hi.
      apply int_pos with (I:=update I_lt_a X) (a:=a). apply BOrd.eq_dec.
      (* [update X a [= update Y a] *)
      unfold update. destruct (BOrd.compare a a). refl. hyp. refl.
      intros b n. unfold update. destruct (BOrd.compare b a). refl. fo. refl.
      (* [pos a Ti] *)
      set (Ti := Vnth (inputs (typ f)) (Acc_arity hi)).
      destruct (occurs_dec BOrd.eq_dec a Ti).
      destruct (Acc_ok o) as [l|[_ l]].
      rewrite hf in l. apply BOrd.lt_not_eq in l. unfold BOrd.eq in l. cong.
      hyp.
      apply not_occurs_pos. hyp.
      (* [int (update X) ti Ti] *)
      apply ht; hyp.
    Qed.

    Global Instance G'_equiv : Proper (equiv ==> equiv) (G' I_lt_a).

    Proof.
      intros X Y. rewrite 2!equiv_elim. intros [XY YX]. split.
      rewrite XY. refl. rewrite YX. refl.
    Qed.

  End G'_props.

(** We also check that [G] and [F] are compatible with [equiv]. *)

  Section G_ext.

    Variables (a : So) (I J : So -> set Te)
      (e : forall b, ~b >B a -> I b [=] J b).

    Lemma G_ext : G a I [=] G a J.

    Proof.
      intro t. apply iff_and. split. refl.
      cut (forall f, output_base (typ f) = a ->
        forall ts : Tes (arity (typ f)), t =>R* apps (Fun f) ts ->
          forall i (hi : Acc f i),
            int I (Vnth (inputs (typ f)) (Acc_arity hi))
                  (Vnth ts (Acc_arity hi))
        <-> int J (Vnth (inputs (typ f)) (Acc_arity hi))
                  (Vnth ts (Acc_arity hi))).
      intro h1. split.
      intros h2 f hf ts r i hi. rewrite <- h1; auto.
      intros h2 f hf ts r i hi. rewrite h1; auto.
      intros f hf ts r i hi. apply int_equiv. intros b h. apply e.
      destruct (Acc_ok h) as [j|[j1 j2]]. rewrite hf in j. intro k.
      absurd (b <B b). apply lt_antirefl. trans a; hyp.
      subst. apply lt_antirefl.
    Qed.

  End G_ext.

  Section F_ext.

    Variables (a : So) (I_lt_a J_lt_a : forall b, b <B a -> set Te)
      (e : forall b (h : b <B a), I_lt_a h [=] J_lt_a h).

    Lemma G'_ext : forall X Y, X [=] Y -> G' I_lt_a X [=] G' J_lt_a Y.

    Proof.
      intros X Y XY t. unfold G'. apply G_ext. intro b. unfold update.
      destruct (BOrd.compare b a); fo.
    Qed.

    Lemma F_ext : F I_lt_a [=] F J_lt_a.

    Proof.
      unfold F. apply lfp_ext. fo. fo. fo. intro X. apply G'_ext. refl.
    Qed.

  End F_ext.

(** Fixpoint equation satisfied by [I]. *)

  Definition I' a b (_ : b <B a) := I b.

  Arguments I' _ [_] _ _.

  Lemma I_eq_F : forall a, I a [=] F (I' a).

  Proof. intro a. unfold I. rewrite Fix_eq. refl. apply F_ext. Qed.

  Lemma I_eq_G' : forall a, I a [=] G' (I' a) (I a).

  Proof.
    intro a. rewrite I_eq_F at 1. unfold F. rewrite set_lfp_eq. 2: apply G'_mon.
    apply G'_ext. refl. rewrite I_eq_F. refl.
  Qed.

  Lemma I_eq : forall a, I a [=] G a I.

  Proof.
    intro a. rewrite I_eq_G'. unfold G'. apply G_ext. intros b h.
    unfold update. destruct (BOrd.compare b a). refl. rewrite e. refl. fo.
  Qed.

(** We now check that base types are interpreted by computability
predicates. *)

  Section cp.

    Variables (a : So) (I_lt_a : forall b, b <B a -> set Te)
      (I_lt_a_cp_aeq : forall b (h : b<B a), cp_aeq (I_lt_a h))
      (I_lt_a_cp_sn : forall b (h : b<B a), cp_sn (I_lt_a h))
      (I_lt_a_cp_red : forall b (h : b<B a), cp_red (I_lt_a h))
      (I_lt_a_cp_neutral : forall b (h : b<B a), cp_neutral (I_lt_a h))
      (X : set Te) (X_cp_aeq : cp_aeq X) (X_cp_sn : cp_sn X)
      (X_cp_red : cp_red X) (X_cp_neutral : cp_neutral X).

    Lemma G'_cp_aeq : cp_aeq (G' I_lt_a X).

    Proof.
      intros t u tu [ht1 ht2]. split. rewrite <- tu. hyp.
      intros f hf ts. rewrite <- tu. fo.
    Qed.

    Lemma G'_cp_sn : cp_sn (G' I_lt_a X).

    Proof. fo. Qed.

    Lemma G'_cp_red : cp_red (G' I_lt_a X).

    Proof.
      intros t u tu [ht1 ht2]. split. eapply SN_inv. apply tu. hyp.
      intros f hf ts hu. assert (ht : t =>R* apps (Fun f) ts).
      trans u. apply at_step. hyp. hyp. apply ht2; hyp.
    Qed.

    Lemma  G'_cp_neutral :
      (forall f n (ts : Tes n), ~neutral (apps (Fun f) ts)) ->
      cp_neutral (G' I_lt_a X).

    Proof.
      intros hn t ht1 ht2. split.
      apply SN_intro. intros u tu. destruct (ht2 _ tu) as [h _]. hyp.
      intros f hf ts r. destruct (clos_aeq_trans_inv _ r) as [h|[u [h1 h2]]].
      rewrite h in ht1. fo.
      eapply ht2. apply h1. hyp. hyp.
    Qed.

  End cp.

  Lemma I_cp : (forall f n (ts : Tes n), ~neutral (apps (Fun f) ts)) ->
    forall a, cp (I a).

  Proof.
    intros hn a. induction (ltB_wf a) as [a _ IH]. rewrite I_eq_G'.
    constructor. apply G'_cp_aeq. apply G'_cp_sn. apply G'_cp_red.
    apply G'_cp_neutral. hyp.
  Qed.

(** Computability of accessible arguments. *)

  Lemma comp_acc : forall f (ts : Tes (arity (typ f))),
    I (output_base (typ f)) (apps (Fun f) ts) -> forall i (hi : Acc f i),
      int I (Vnth (inputs (typ f)) (Acc_arity hi)) (Vnth ts (Acc_arity hi)).

  Proof.
    intros f ts. set (a := output_base (typ f)).
    (*COQ: rewrite I_eq. does not work here! *)
    gen (I_eq a); unfold equiv, pointwise_relation; intro e; rewrite e; clear e.
    intros [h1 h2] i hi. apply h2; refl.
  Qed.

(** Computability of function symbols. *)

  Lemma comp_fun : (forall f n (ts : Tes n), ~neutral (apps (Fun f) ts)) ->
    forall f (ts : Tes (arity (typ f))), vint I (inputs (typ f)) ts ->
      (forall u, apps (Fun f) ts =>R u -> I (output_base (typ f)) u) ->
      I (output_base (typ f)) (apps (Fun f) ts).

  Proof.
    intros hn f ts hts h. set (a := output_base (typ f)).
    gen (I_cp hn a). intros [a1 a2 a3 a4].
    (*COQ: rewrite I_eq. does not work here! *)
    gen (I_eq a); unfold equiv, pointwise_relation; intro e; rewrite e; clear e.
    split.
    apply SN_intro. fo.
    intros g hg us r i hi. destruct (clos_aeq_trans_inv _ r) as [j|[v [h1 h2]]].
    inv_aeq j; subst. gen (eq_apps_fun_head i0). intro e. subst g.
    apply eq_apps_nb_args_args in i0. subst us0. apply vint_elim_nth.
    (*COQ:rewrite i2.*) eapply vint_vaeq. apply I_cp. hyp. sym. apply i2. hyp.
    gen (h _ h1). fold a. (*COQ: rewrite I_eq.*)
    gen (I_eq a); unfold equiv, pointwise_relation; intro e; rewrite e; clear e.
    intros [i1 i2]. apply i2; hyp.
  Qed.

End Make.


Require Import Arith.
Require Import ZArith.
Require Import List.
Import ListNotations.
Require Import Sorted.
Require Import Omega.
Require Import Psatz.

Require Import v1.NeutronTactics.
Require Import v1.Util.
Require Import v1.Multi.
Require Import v1.MForall.
Require Import v1.FloatAux.

Require Import epics.SpecTypes.
Require Import expr.Expr.
Require Import floatabs.Records.
Require Import floatabs.RecordData.
Require Import util.ListLemmas.

Require expr.Dbl.
Require floatabs.AbsExpr.

Set Default Timeout 10.

Local Open Scope Z.

Module Dbl := expr.Dbl.
Module Abs := floatabs.AbsExpr.

Definition D := Dbl.dbl_eval_bits.
Definition A := Abs.abs_eval_bits.

Inductive ty_rel : Dbl.dbl_tydesc -> Abs.abs_tydesc -> Prop :=
| TrNil : ty_rel Dbl.Nil Abs.Nil
| TrDbl : ty_rel Dbl.Dbl Abs.Abs
.
Hint Constructors ty_rel.

Definition lift (fd : tydesc D -> Type) (fa : tydesc A -> Type) :
    (forall dty aty, fd dty -> fa aty -> Prop) ->
    ({ ty : tydesc D & fd ty } -> { ty : tydesc A & fa ty } -> Prop).
intro P.
intros dsig asig.
destruct dsig as [d d'], asig as [a a'].
eapply P; eassumption.
Defined.

Inductive refine_dbl : e_double -> abs_value -> Prop :=
| RdNone : forall d, refine_dbl d None
| RdSome : forall d z min max,
        fwhole_eq d z ->
        (min <= z <= max)%Z ->
        refine_dbl d (Some (min, max)).

Inductive refine_value : forall dty aty, ty_denote D dty -> ty_denote A aty -> Prop :=
| RvNil : refine_value Dbl.Nil Abs.Nil tt tt
| RvDbl : forall d a,
        refine_dbl d a ->
        refine_value Dbl.Dbl Abs.Abs d a.
Definition refine_value' :
    ({ ty : tydesc D & ty_denote D ty } -> { ty : tydesc A & ty_denote A ty } -> Prop) :=
    lift _ _ refine_value.

Inductive refine_unop dty1 aty1 :
    forall dtyR atyR
        (df : unop_impl _ dty1 dtyR)
        (af : unop_impl _ aty1 atyR),
        Prop :=
| RefineUnop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1,
        refine_value dty1 aty1 dx1 ax1 ->
        refine_value dtyR atyR (df dx1) (af ax1)) ->
    refine_unop dty1 aty1 dtyR atyR df af.
Definition refine_unop' dty1 aty1 :=
    lift _ _ (refine_unop dty1 aty1).

Inductive refine_binop dty1 aty1 dty2 aty2 :
    forall dtyR atyR
        (df : binop_impl _ dty1 dty2 dtyR)
        (af : binop_impl _ aty1 aty2 atyR),
        Prop :=
| RefineBinop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1 dx2 ax2,
        refine_value dty1 aty1 dx1 ax1 ->
        refine_value dty2 aty2 dx2 ax2 ->
        refine_value dtyR atyR (df dx1 dx2) (af ax1 ax2)) ->
    refine_binop dty1 aty1 dty2 aty2 dtyR atyR df af.
Definition refine_binop' dty1 aty1 dty2 aty2 :=
    lift _ _ (refine_binop dty1 aty1 dty2 aty2).

Inductive refine_ternop dty1 aty1 dty2 aty2 dty3 aty3 :
    forall dtyR atyR
        (df : ternop_impl _ dty1 dty2 dty3 dtyR)
        (af : ternop_impl _ aty1 aty2 aty3 atyR),
        Prop :=
| RefineTernop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    ty_rel dty3 aty3 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1 dx2 ax2 dx3 ax3,
        refine_value dty1 aty1 dx1 ax1 ->
        refine_value dty2 aty2 dx2 ax2 ->
        refine_value dty3 aty3 dx3 ax3 ->
        refine_value dtyR atyR (df dx1 dx2 dx3) (af ax1 ax2 ax3)) ->
    refine_ternop dty1 aty1 dty2 aty2 dty3 aty3 dtyR atyR df af.
Definition refine_ternop' dty1 aty1 dty2 aty2 dty3 aty3 :=
    lift _ _ (refine_ternop dty1 aty1 dty2 aty2 dty3 aty3).

Inductive refine_varop dty1 aty1 :
    forall dtyR atyR
        (df : varop_impl _ dty1 dtyR)
        (af : varop_impl _ aty1 atyR),
        Prop :=
| RefineVarop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1,
        Forall2 (refine_value dty1 aty1) dx1 ax1 ->
        refine_value dtyR atyR (df dx1) (af ax1)) ->
    refine_varop dty1 aty1 dtyR atyR df af.
Definition refine_varop' dty1 aty1 :=
    lift _ _ (refine_varop dty1 aty1).

Inductive refine_state_fn :
    forall dtyR atyR
        (df : state_fn D 12 (ty_denote D dtyR))
        (af : state_fn A 12 (ty_denote A atyR)),
        Prop :=
| RefineStateFn : forall dtyR atyR df af,
    ty_rel dtyR atyR ->
    (forall dsv dsx asv asx dsv' dsx' dr asv' asx' ar,
        MForall2 (refine_value _ _) dsv asv ->
        MForall2 (refine_value _ _) dsx asx ->
        df dsv dsx = (dsv', dsx', dr) ->
        af asv asx = (asv', asx', ar) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        MForall2 (refine_value _ _) dsx' asx' /\
        refine_value _ _ dr ar) ->
    refine_state_fn dtyR atyR df af.
Definition refine_state_fn' :=
    lift _ _ (refine_state_fn).

Inductive refine_state_fn_list :
    forall dtyR atyR
        (df : state_fn D 12 (list (ty_denote D dtyR)))
        (af : state_fn A 12 (list (ty_denote A atyR))),
        Prop :=
| RefineStateFnList : forall dtyR atyR df af,
    ty_rel dtyR atyR ->
    (forall dsv dsx asv asx dsv' dsx' drs asv' asx' ars,
        MForall2 (refine_value _ _) dsv asv ->
        MForall2 (refine_value _ _) dsx asx ->
        df dsv dsx = (dsv', dsx', drs) ->
        af asv asx = (asv', asx', ars) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        MForall2 (refine_value _ _) dsx' asx' /\
        Forall2 (refine_value _ _) drs ars) ->
    refine_state_fn_list dtyR atyR df af.
Definition refine_state_fn_list' :=
    lift _ _ (refine_state_fn_list).

Inductive refine_state_fn_noxvar :
    forall dtyR atyR
        (df : state_fn_noxvar D 12 (ty_denote D dtyR))
        (af : state_fn_noxvar A 12 (ty_denote A atyR)),
        Prop :=
| RefineStateFnNoXVar : forall dtyR atyR df af,
    ty_rel dtyR atyR ->
    (forall dsv asv dsv' dr asv' ar,
        MForall2 (refine_value _ _) dsv asv ->
        df dsv = (dsv', dr) ->
        af asv = (asv', ar) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        refine_value _ _ dr ar) ->
    refine_state_fn_noxvar dtyR atyR df af.
Definition refine_state_fn_noxvar' :=
    lift _ _ (refine_state_fn_noxvar).

Lemma double_abs_refine : forall d,
    refine_dbl d (Abs.double_abs d).
intros. unfold Abs.double_abs. break_match.
- econstructor.
  + eapply B2Z_safe_correct. eassumption.
  + omega.
- constructor.
Qed.

Lemma convert_lit_refine : forall x,
    refine_value' (convert_lit D x) (convert_lit A x).
intros. simpl.  constructor. eauto using double_abs_refine.
Qed.

Local Hint Resolve (tydesc_eq_dec D) : eq_dec.
Local Hint Resolve (tydesc_eq_dec A) : eq_dec.

Lemma abs_bool_refine : forall d,
    (d = d_zero \/ d = d_one) ->
    refine_dbl d Abs.abs_bool.
intros0 Hor. destruct Hor.
- econstructor.
  + subst. eapply fwhole_eq_Z2B.
    eapply Z.pow_pos_nonneg; omega.
  + omega.

- econstructor.
  + subst. eapply fwhole_eq_Z2B.
    rewrite Z.abs_eq by omega.
    replace 1 with (1 ^ (53 - 1)) at 1 by (eapply Z.pow_1_l; omega).
    eapply Z.pow_lt_mono_l; omega.
  + omega.
Qed.

Lemma unop_denote_refine : forall op dty1 aty1 dden,
    ty_rel dty1 aty1 ->
    unop_denote D op dty1 = Some dden ->
    exists aden,
        unop_denote A op aty1 = Some aden /\
        refine_unop' _ _ dden aden.
destruct op, dty1; inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_unop', lift.
all: constructor; eauto.
all: inversion 1; constructor.
all: fix_existT; subst.

- on >refine_dbl, invc; [ solve [constructor] | ].
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bopp; eauto.
  + omega.

- eapply abs_bool_refine.  break_if; eauto.

Qed.

Lemma Z_mult_range_max_l : forall x y0 y1 y,
    y0 <= y <= y1 ->
    x * y <= Z.max (x * y0) (x * y1).
intros. destruct (Z_le_gt_dec 0 x).
- eapply Z.le_trans with (m := x * y1).
  + eapply Z.mul_le_mono_nonneg_l; omega.
  + eapply Z.le_max_r.
- eapply Z.le_trans with (m := x * y0).
  + eapply Z.mul_le_mono_nonpos_l; omega.
  + eapply Z.le_max_l.
Qed.

Lemma Z_mult_range_max_r : forall x0 x1 x y,
    x0 <= x <= x1 ->
    x * y <= Z.max (x0 * y) (x1 * y).
intros. destruct (Z_le_gt_dec 0 y).
- eapply Z.le_trans with (m := x1 * y).
  + eapply Z.mul_le_mono_nonneg_r; omega.
  + eapply Z.le_max_r.
- eapply Z.le_trans with (m := x0 * y).
  + eapply Z.mul_le_mono_nonpos_r; omega.
  + eapply Z.le_max_l.
Qed.

Lemma Z_mult_range_max : forall x0 x1 y0 y1 x y,
    x0 <= x <= x1 ->
    y0 <= y <= y1 ->
    let z1 := Z.max (Z.max (x0 * y0) (x0 * y1)) (Z.max (x1 * y0) (x1 * y1)) in
    x * y <= z1.
intros.
eapply Z.le_trans with (m := Z.max (x0 * y) (x1 * y)).
- eapply Z_mult_range_max_r. eauto.
- eapply Z.max_le_compat; eapply Z_mult_range_max_l; eauto.
Qed.

Lemma Z_mult_range_min_l : forall x y0 y1 y,
    y0 <= y <= y1 ->
    Z.min (x * y0) (x * y1) <= x * y.
intros. destruct (Z_le_gt_dec 0 x).
- eapply Z.le_trans with (m := x * y0).
  + eapply Z.le_min_l.
  + eapply Z.mul_le_mono_nonneg_l; omega.
- eapply Z.le_trans with (m := x * y1).
  + eapply Z.le_min_r.
  + eapply Z.mul_le_mono_nonpos_l; omega.
Qed.

Lemma Z_mult_range_min_r : forall x0 x1 x y,
    x0 <= x <= x1 ->
    Z.min (x0 * y) (x1 * y) <= x * y.
intros. destruct (Z_le_gt_dec 0 y).
- eapply Z.le_trans with (m := x0 * y).
  + eapply Z.le_min_l.
  + eapply Z.mul_le_mono_nonneg_r; omega.
- eapply Z.le_trans with (m := x1 * y).
  + eapply Z.le_min_r.
  + eapply Z.mul_le_mono_nonpos_r; omega.
Qed.

Lemma Z_mult_range_min : forall x0 x1 y0 y1 x y,
    x0 <= x <= x1 ->
    y0 <= y <= y1 ->
    let z0 := Z.min (Z.min (x0 * y0) (x0 * y1)) (Z.min (x1 * y0) (x1 * y1)) in
    z0 <= x * y.
intros.
eapply Z.le_trans with (m := Z.min (x0 * y) (x1 * y)).
- eapply Z.min_le_compat; eapply Z_mult_range_min_l; eauto.
- eapply Z_mult_range_min_r. eauto.
Qed.

Lemma Z_mult_range : forall x0 x1 y0 y1 x y,
    x0 <= x <= x1 ->
    y0 <= y <= y1 ->
    let z0 := Z.min (Z.min (x0 * y0) (x0 * y1)) (Z.min (x1 * y0) (x1 * y1)) in
    let z1 := Z.max (Z.max (x0 * y0) (x0 * y1)) (Z.max (x1 * y0) (x1 * y1)) in
    z0 <= x * y <= z1.
intros. split; eauto using Z_mult_range_min, Z_mult_range_max.
Qed.

Lemma binop_denote_refine : forall op dty1 aty1 dty2 aty2 dden,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    binop_denote D op dty1 dty2 = Some dden ->
    exists aden,
        binop_denote A op aty1 aty2 = Some aden /\
        refine_binop' _ _ _ _ dden aden.
destruct op, dty1, dty2; do 2 inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_unop', lift.
all: constructor; eauto.
all: do 2 inversion 1; constructor.
all: fix_existT; subst.

- do 2 (on >refine_dbl, invc; [ solve [constructor] | ]).
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bplus; eauto.
    rewrite Z_abs_range. change (53 - 1) with 52. omega.
  + omega.

- do 2 (on >refine_dbl, invc; [ solve [constructor] | ]).
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bminus; eauto.
    rewrite Z_abs_range. change (53 - 1) with 52. omega.
  + omega.

- do 2 (on >refine_dbl, invc; [ solve [constructor] | ]).
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bmult; eauto.
    rewrite Z_abs_range. change (53 - 1) with 52.
    forward eapply Z_mult_range with (x := z) (y := z0); eauto.
    cbv zeta in *. omega.
  + eapply Z_mult_range; eauto.

- constructor.

- eapply abs_bool_refine.  unfold Dbl.b64_ge. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_gt. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_le. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_lt. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_ne. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_eq. do 2 (break_match; eauto).

- eapply abs_bool_refine.  unfold Dbl.b64_and. do 2 (break_if; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_or. do 2 (break_if; eauto).

Qed.

Lemma ternop_denote_refine : forall op dty1 aty1 dty2 aty2 dty3 aty3 dden,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    ty_rel dty3 aty3 ->
    ternop_denote D op dty1 dty2 dty3 = Some dden ->
    exists aden,
        ternop_denote A op aty1 aty2 aty3 = Some aden /\
        refine_ternop' _ _ _ _ _ _ dden aden.
destruct op, dty1, dty2, dty3; do 3 inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_unop', lift.
all: constructor; eauto.
all: do 3 inversion 1; constructor.
all: fix_existT; subst.

- on (refine_dbl dx2 _), invc; [ solve [constructor] | ].
  on (refine_dbl dx3 _), invc; [ solve [constructor] | ].
  simpl. unfold Abs.check_overflow. do 3 (break_if; try solve [constructor]).
  + econstructor; eauto. lia.
  + econstructor; eauto. lia.

Qed.

Lemma min_fwhole_eq : forall dx dy zx zy,
    fwhole_eq dx zx ->
    fwhole_eq dy zy ->
    fwhole_eq (Dbl.b64_min dx dy) (Z.min zx zy).
intros0 Hx Hy.
unfold Dbl.b64_min, Z.min. break_match; [ break_match | ].
all: erewrite fwhole_eq_Bcompare in * by eauto.
4: discriminate.
all: inject_some; find_rewrite.
all: eauto.

(* Eq case needs a bit more. *)
rewrite Z.compare_eq_iff in *. subst. auto.
Qed.

Lemma max_fwhole_eq : forall dx dy zx zy,
    fwhole_eq dx zx ->
    fwhole_eq dy zy ->
    fwhole_eq (Dbl.b64_max dx dy) (Z.max zx zy).
intros0 Hx Hy.
unfold Dbl.b64_max, Z.max. break_match; [ break_match | ].
all: erewrite fwhole_eq_Bcompare in * by eauto.
4: discriminate.
all: inject_some; find_rewrite.
all: eauto.
Qed.

Lemma min_refine : forall dx dy ax ay,
    refine_dbl dx ax ->
    refine_dbl dy ay ->
    refine_dbl (Dbl.b64_min dx dy) (Abs.abs_min ax ay).
intros0 Hx Hy.
invc Hx; invc Hy; simpl; try solve [constructor].
unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
eapply RdSome with (z := Z.min z z0).
- eapply min_fwhole_eq; eauto.
- lia.
Qed.

Lemma max_refine : forall dx dy ax ay,
    refine_dbl dx ax ->
    refine_dbl dy ay ->
    refine_dbl (Dbl.b64_max dx dy) (Abs.abs_max ax ay).
intros0 Hx Hy.
invc Hx; invc Hy; simpl; try solve [constructor].
unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
eapply RdSome with (z := Z.max z z0).
- eapply max_fwhole_eq; eauto.
- lia.
Qed.

Lemma minimum_refine : forall dxs axs,
    Forall2 refine_dbl dxs axs ->
    refine_dbl (Dbl.b64_minimum dxs) (Abs.abs_minimum axs).
induction dxs; intros0 Hfa; invc Hfa; simpl.
- eapply RdSome with (z := 0).
  + unfold d_zero. eapply fwhole_eq_Z2B. eapply Z.pow_pos_nonneg; lia.
  + lia.
- eapply min_refine; eauto.
Qed.

Lemma maximum_refine : forall dxs axs,
    Forall2 refine_dbl dxs axs ->
    refine_dbl (Dbl.b64_maximum dxs) (Abs.abs_maximum axs).
induction dxs; intros0 Hfa; invc Hfa; simpl.
2: on >Forall2, invc.
- eapply RdSome with (z := 0).
  + unfold d_zero. eapply fwhole_eq_Z2B. eapply Z.pow_pos_nonneg; lia.
  + lia.
- auto.
- eapply max_refine; eauto.
Qed.

Lemma refine_value_dbl : forall dx ax,
    refine_value Dbl.Dbl Abs.Abs dx ax <->
    refine_dbl dx ax.
intros. split; intro Hr.
- inversion Hr. fix_existT. subst. auto.
- constructor. auto.
Qed.

Lemma refine_value_dbl_list : forall dx ax,
    Forall2 (refine_value Dbl.Dbl Abs.Abs) dx ax <->
    Forall2 refine_dbl dx ax.
induction dx; intros; split; intro Hr; invc Hr; eauto.
- rewrite refine_value_dbl in *. rewrite IHdx in *. eauto.
- rewrite <- refine_value_dbl in *. rewrite <- IHdx in *. eauto.
Qed.

Lemma varop_denote_refine : forall op dty1 aty1 dden,
    ty_rel dty1 aty1 ->
    varop_denote D op dty1 = Some dden ->
    exists aden,
        varop_denote A op aty1 = Some aden /\
        refine_varop' _ _ dden aden.

destruct op, dty1; inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_varop', lift.
all: constructor; eauto.
all: constructor.

- rewrite refine_value_dbl_list in *.
  eapply minimum_refine; eauto.

- rewrite refine_value_dbl_list in *.
  eapply maximum_refine; eauto.
Qed.

Ltac specialize_refinement :=
    repeat match goal with
    (* First, try to destruct some applications.  This will fail if the arguments
       used in the LHS have not been filled in yet, and we will fall through to the
       spec_evar case below. *)
    | [ H : forall x, _ |- _ ] =>
            match type of H with
            | context [ ?x = (_, _, _) ] =>
                    match x with
                    | (_, _, _) => fail 1
                    | _ => destruct x as [[? ?] ?] eqn:?
                    end
            end
    (* Main case: try to fill in arguments using evar or eassumption *)
    | [ H : forall x : ?T, _ |- _ ] =>
            match type of T with
            | Set => spec_evar H
            | Prop =>
                    match goal with
                    | [ H' : _ |- _ ] => specialize (H H'); clear H'
                    end
            end
    (* Also handle @eq premises with reflexivity *)
    | [ H : _ = _ -> _ |- _ ] => spec H by reflexivity
    (* Final cleanup: break `exists` and `and`. *)
    | [ H : exists _, _ |- _ ] => destruct H
    | [ H : _ /\ _ |- _ ] => destruct H
    end.

Lemma var_ty_rel : ty_rel (var_ty D) (var_ty A).
constructor.
Qed.

Lemma xvar_ty_rel : ty_rel (xvar_ty D) (xvar_ty A).
constructor.
Qed.

Lemma nil_ty_rel : ty_rel (nil_ty D) (nil_ty A).
constructor.
Qed.

Lemma ty_rel_inj : forall dty aty1 aty2,
    ty_rel dty aty1 ->
    ty_rel dty aty2 ->
    aty1 = aty2.
do 2 inversion 1; eauto.
Qed.

Lemma ty_rel_nil_sur : forall dty1 dty2,
    ty_rel dty1 (nil_ty A) ->
    ty_rel dty2 (nil_ty A) ->
    dty1 = dty2.
do 2 inversion 1; eauto.
Qed.

Lemma nil_rel_fwd : forall aty,
    ty_rel (nil_ty D) aty ->
    aty = nil_ty A.
intros. eapply ty_rel_inj; eauto using nil_ty_rel.
Qed.

Lemma nil_rel_rev : forall dty,
    ty_rel dty (nil_ty A) ->
    dty = nil_ty D.
intros. eapply ty_rel_nil_sur; eauto using nil_ty_rel.
Qed.

Lemma unpack_opt_helper1
    DI DP DR dopt (didx : DI) dval df drhs
    AI AP AR aopt (aidx : AI) aval af
        (P : AR -> Prop):
    unpack_opt (R := DR) dopt df = Some drhs ->
    dopt = Some (existT DP didx dval) ->
    aopt = Some (existT AP aidx aval) ->
    (df didx dval = Some drhs ->
        exists arhs, af aidx aval = Some arhs /\ P arhs) ->
    exists arhs, unpack_opt (R := AR) aopt af = Some arhs /\ P arhs.
intros0 Hunpack Hdden Haden Hinner.
subst dopt aopt. simpl in *.
eauto.
Qed.

Lemma unpack_opt_some_inv : forall I P R (opt : option { x : I & P x }) f rhs
        (Q : Prop),
    (forall idx val,
        opt = Some (existT P idx val) ->
        f idx val = Some rhs ->
        Q) ->
    unpack_opt (R := R) opt f = Some rhs -> Q.
intros.
destruct opt as [ s | ]; try discriminate.
destruct s. eauto.
Qed.

Lemma unpack_opt_some_inv' : forall I P R (opt : option { x : I & P x }) f rhs
        (Q : Prop),
    (forall idx val,
        opt = Some (existT P idx val) ->
        Q) ->
    unpack_opt (R := R) opt f = Some rhs -> Q.
inversion 2 using unpack_opt_some_inv. eauto.
Qed.

Lemma unpack_opt_some_ex
    I P R opt (idx : I) val f (Q : R -> Prop):
    opt = Some (existT P idx val) ->
    (exists rhs, f idx val = Some rhs /\ Q rhs) ->
    (exists rhs, unpack_opt (R := R) opt f = Some rhs /\ Q rhs).
intros0 Hopt Hinner.
subst opt. simpl in *. eauto.
Qed.

Ltac handle_unpack_opt :=
    let dden' := fresh "dden'" in
    let aden' := fresh "aden'" in
    let Hdden := fresh "Hdden" in
    let Haden := fresh "Haden" in
    let dty := fresh "dty" in
    let aty := fresh "aty" in
    let Hex := fresh "Hex" in
    let Hrefine := fresh "Hrefine" in

    match goal with
    | [ H : unpack_opt ?dden ?df = Some _ |-
        exists aden', unpack_opt ?aden ?af = Some _ /\ _ ] =>

            eapply unpack_opt_some_inv with (2 := H); clear H;
            intros dty dden' Hdden H;

            simple refine (let Hex : exists aden', aden = Some aden' /\ _ aden' := _ in _);
            [ shelve
            | eauto (* or defer to caller *)
            | clearbody Hex;
              destruct Hex as (aden' & Haden & Hrefine);
              destruct aden' as [aty aden'];
              eapply unpack_opt_some_ex; simpl in *; eauto
            ]
    end.

Lemma if_tydesc_eq_dec_inv : forall
    (T : Set) (A : eval_bits T)
    (P : tydesc A -> tydesc A -> Type)
    (ty xty : tydesc A)
    (x : forall ty xty, P ty xty)
    (y : forall ty xty, P ty xty)
    (z : forall ty xty, P ty xty)
    (Q : tydesc A -> Prop),
    (x xty xty = z xty xty -> Q xty) ->
    (ty <> xty ->
        y ty xty = z ty xty ->
        Q ty) ->
    ((if tydesc_eq_dec A ty xty then x ty xty else y ty xty) = z ty xty) -> Q ty.
intros.
destruct (tydesc_eq_dec _ _ _).
- subst. eauto.
- eauto.
Qed.

Lemma if_tydesc_eq_dec_eq_ex : forall
    (T : Set) (A : eval_bits T)
    (ty xty : tydesc A)
    (R : Type) (f g : tydesc A -> tydesc A -> option R)
    (Q : R -> Prop),
    ty = xty ->
    (exists rhs, f xty xty = Some rhs /\ Q rhs) ->
    (exists rhs, (if tydesc_eq_dec A ty xty then f ty xty else g ty xty) = Some rhs /\ Q rhs).
intros.
destruct (tydesc_eq_dec _ _ _); [ | exfalso; congruence ].
subst. auto.
Qed.

Lemma if_tydesc_eq_dec_ne_ex : forall
    (T : Set) (A : eval_bits T)
    (ty xty : tydesc A)
    (R : Type) (f g : tydesc A -> tydesc A -> option R)
    (Q : R -> Prop),
    ty <> xty ->
    (exists rhs, g ty xty = Some rhs /\ Q rhs) ->
    (exists rhs, (if tydesc_eq_dec A ty xty then f ty xty else g ty xty) = Some rhs /\ Q rhs).
intros.
destruct (tydesc_eq_dec _ _ _); [ exfalso; congruence | ].
auto.
Qed.

Lemma unpack_ty_helper1
    (DT : Set) (D : eval_bits DT) (DP : forall ty : tydesc D, Type) DR
        dden dty dden' (df : DP dty -> option DR) drhs
    (AT : Set) (A : eval_bits AT) (AP : forall ty : tydesc A, Type) AR
        aden aty aden' (af : AP aty -> option AR)
        (P : AR -> Prop) :
    unpack_ty (R := DR) D dty dden df = Some drhs ->
    dden = Some (existT DP dty dden') ->
    aden = Some (existT AP aty aden') ->
    (df dden' = Some drhs ->
        exists arhs, af aden' = Some arhs /\ P arhs) ->
    exists arhs, unpack_ty (R := AR) A aty aden af = Some arhs /\ P arhs.
intros0 Hunpack Hdden Haden Hinner.
subst dden aden. simpl in *.
destruct (tydesc_eq_dec _ dty dty); [ | exfalso; congruence ].
destruct (tydesc_eq_dec _ aty aty); [ | exfalso; congruence ].
fix_eq_rect; eauto using tydesc_eq_dec.
Qed.

Lemma unpack_ty_some_ex
    (T : Set) (A : eval_bits T) (P : forall ty : tydesc A, Type) R
        den ty den' (f : P ty -> option R)
        (Q : R -> Prop) :
    den = Some (existT P ty den') ->
    (exists rhs, f den' = Some rhs /\ Q rhs) ->
    (exists rhs, unpack_ty (R := R) A ty den f = Some rhs /\ Q rhs).
intros0 Hden Hinner.
subst den. simpl in *.
destruct (tydesc_eq_dec _ ty ty); [ | exfalso; congruence ].
fix_eq_rect; eauto using tydesc_eq_dec.
Qed.

Lemma unpack_ty_some_inv : forall
    (T : Set) (D : eval_bits T) (P : forall ty : tydesc D, Type) R
        xty den f rhs
        (Q : Prop),
    (forall val,
        den = Some (existT P xty val) ->
        f val = Some rhs ->
        Q) ->
    unpack_ty (R := R) D xty den f = Some rhs -> Q.
intros0 HQ Hunpack.
destruct den as [ s | ]; try discriminate.
destruct s. simpl in Hunpack.
destruct (tydesc_eq_dec _ _ _); try discriminate.
subst xty. fix_eq_rect; eauto using tydesc_eq_dec.
Qed.

Lemma denote'_refine : forall e dden,
    denote' D e = Some dden ->
    exists aden,
        denote' A e = Some aden /\
        refine_state_fn' dden aden.
induction e using expr_rect_mut with
    (Pl := fun es => forall ddens,
        denote'_list D es = Some ddens ->
        exists adens,
            denote'_list A es = Some adens /\
            refine_state_fn_list' ddens adens);
[ .. | eauto | eauto ];
intros0 Hden.

Local Opaque multi.
Local Opaque multi_get.
Local Opaque multi_set.
Local Opaque A.
Local Opaque D.

all: simpl in *; unfold pack_denot in *; inject_some.
all: try (eexists; split; [reflexivity|]; unfold refine_state_fn', lift).

- constructor.  { constructor. }
  intros. inject_pair.
  split; [|split]; auto.
  + eapply MForall2_get. assumption.

- constructor.  { constructor. }
  intros. inject_pair.
  split; [|split]; auto.
  + eapply MForall2_get. assumption.

- constructor.  { constructor. }
  intros. inject_pair.
  split; [|split]; auto.
  + eapply convert_lit_refine.

- (* Unary *)
  handle_unpack_opt.
  handle_unpack_opt.
    { on >refine_state_fn, invc. eapply unop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_unop, invc. auto. }
  intros.  clear IHe.

  on >refine_state_fn, invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_unop, invc.  specialize_refinement.

  eauto.

- (* Binary *)
  handle_unpack_opt.
  handle_unpack_opt.
  handle_unpack_opt.
    { inv Hrefine. inv Hrefine0. eapply binop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_binop, invc. auto. }
  intros.  clear IHe1 IHe2.

  on >(refine_state_fn dty), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >(refine_state_fn dty0), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_binop, invc.  specialize_refinement.

  eauto.

- (* Varary *)
  fold (denote'_list D xs) in *.
  fold (denote'_list A xs) in *.
  handle_unpack_opt.
  handle_unpack_opt.
    { inv Hrefine. eapply varop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_varop, invc. auto. }
  intros.  clear IHe.

  on >refine_state_fn_list, invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_varop, invc.  specialize_refinement.

  eauto.

- (* Assign *)

  (* TODO - put unpack_ty stuff into the handle_unpack_opt tactic *)
  on _, invc_using unpack_ty_some_inv.
    destruct (IHe _ **) as ([? ?] & HH & ?). simpl in *.
    on >refine_state_fn, invc.
    assert (x = var_ty A) by eauto using ty_rel_inj, var_ty_rel. subst x.
    eapply unpack_ty_some_ex; eauto.  clear HH.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { eauto using nil_ty_rel. }
  intros.  clear IHe.

  specialize_refinement.
    repeat find_rewrite. inject_pair.

  split; [|split]; eauto using set_MForall2.
  + econstructor.

- (* XAssign *)

  on _, invc_using unpack_ty_some_inv.
    destruct (IHe _ **) as ([? ?] & HH & ?). simpl in *.
    on >refine_state_fn, invc.
    assert (x = xvar_ty A) by eauto using ty_rel_inj, xvar_ty_rel. subst x.
    eapply unpack_ty_some_ex; eauto.  clear HH.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { eauto using nil_ty_rel. }
  intros.  clear IHe.

  specialize_refinement.
    repeat find_rewrite. inject_pair.

  split; [|split]; eauto using set_MForall2.
  + econstructor.

- (* Cond *)
  handle_unpack_opt.
  handle_unpack_opt.
  handle_unpack_opt.
  handle_unpack_opt.
    { do 3 on >refine_state_fn, invc. eapply ternop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_ternop, invc. auto. }
  intros.  clear IHe1 IHe2 IHe3.

  on >(refine_state_fn dty), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >(refine_state_fn dty0), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >(refine_state_fn dty1), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_ternop, invc.  specialize_refinement.

  eauto.

- (* Seq *)
  handle_unpack_opt.
  handle_unpack_opt.
  destruct (tydesc_eq_dec D _ _); [ | destruct (tydesc_eq_dec D _ _); [ | discriminate Hden ] ].

  + assert (aty = nil_ty A). { eapply nil_rel_fwd. invc Hrefine. auto. }
    subst aty. destruct (tydesc_eq_dec A _ _); [ | exfalso; congruence ].
    eexists. split; [ reflexivity | ]. inject_some. simpl.
    constructor. { invc Hrefine0. auto. } intros.

    on >(refine_state_fn (nil_ty D)), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    on >(refine_state_fn dty0), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

  + assert (aty <> nil_ty A).
      { on (dty <> _), contradict. eapply nil_rel_rev. invc Hrefine. auto. }
    destruct (tydesc_eq_dec A _ _); [ exfalso; congruence | ].
    assert (aty0 = nil_ty A). { eapply nil_rel_fwd. invc Hrefine0. auto. }
    subst aty0. destruct (tydesc_eq_dec A _ _); [ | exfalso; congruence ].
    eexists. split; [ reflexivity | ]. inject_some. simpl.
    constructor. { invc Hrefine. auto. } intros.

    on >(refine_state_fn dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    on >(refine_state_fn (nil_ty D)), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

- (* nil *) discriminate.

- destruct es as [| e' es ].

  + (* singleton list *)
    handle_unpack_opt.

    eexists. split; [reflexivity|]. inject_some. simpl.

    constructor.  { on >refine_state_fn, invc. auto. }
    intros.  clear IHe IHe0.

    on >(refine_state_fn dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

  + (* singleton list *)
    remember (e' :: es) as e'_es.
    handle_unpack_opt.
    handle_unpack_opt.
    destruct (tydesc_eq_dec _ _ _); try discriminate.
      subst dty0.

    destruct (tydesc_eq_dec _ _ _); cycle 1.
      { on (aty <> _), contradict.
        invc Hrefine. invc Hrefine0.
        eapply ty_rel_inj; eauto. }
      subst aty0.

    eexists. split; [reflexivity|]. inject_some. simpl.

    constructor.  { on >refine_state_fn, invc. auto. }
    intros.  clear IHe IHe0.

    on >(refine_state_fn dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    on >(refine_state_fn_list dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

Qed.

Local Transparent A.
Local Transparent D.

Lemma denote_refine : forall e dden,
    Dbl.denote e = Some dden ->
    exists aden,
        Abs.denote e = Some aden /\
        refine_state_fn_noxvar Dbl.Dbl Abs.Abs dden aden.
intros. unfold Dbl.denote in *.

on _, invc_using unpack_ty_some_inv.
forward eapply denote'_refine as HH; eauto.  destruct HH as (aden & Haden & Hrefine).
  simpl in Hrefine. destruct aden as [aty aden].
  change e_double with (ty_denote D Dbl.Dbl) in val.
  assert (aty = Abs.Abs).  { inv Hrefine. on >ty_rel, invc. auto. }  subst aty.
unfold Abs.denote.
eapply unpack_ty_some_ex; eauto.

eexists. split; [ reflexivity | ]. inject_some.
constructor. { invc Hrefine. auto. }  intros.
change (tt, tt, tt, tt, tt, tt, tt, tt, tt, tt, tt, tt) with (multi_rep 12 tt) in *.

assert (MForall2 (refine_value (xvar_ty D) (xvar_ty A)) (multi_rep 12 tt) (multi_rep 12 tt)).
  { eapply rep_MForall2. constructor. }

on >refine_state_fn, invc.  specialize_refinement.
  repeat find_rewrite. inject_pair.
auto.
Qed.

Lemma refine_state_fn_noxvar_dbl_abs_inv : forall df af,
    refine_state_fn_noxvar Dbl.Dbl Abs.Abs df af ->
    (forall dsv asv dsv' dr asv' ar,
        MForall2 (refine_value _ _) dsv asv ->
        df dsv = (dsv', dr) ->
        af asv = (asv', ar) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        refine_value _ _ dr ar).
inversion 1. auto.
Qed.


(*===========================================================================
    I/O actions
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrbool Ssreflect.ssrfun Ssreflect.eqtype Ssreflect.tuple Ssreflect.seq.
Require Import x86proved.bitsrep x86proved.bitsops x86proved.bitsprops.

Definition Chan := WORD.
Definition Data := BYTE.

Inductive Action :=
| Out (c:Chan) (d:Data)
| In (c:Chan) (d:Data).

Definition actionEq a1 a2 :=
  match a1, a2 with
  | Out c1 d1, Out c2 d2 => (c1 == c2) && (d1 == d2)
  | In c1 d1, In c2 d2 => (c1 == c2) && (d1 == d2)
  | _, _ => false
  end.

Lemma action_eqP: Equality.axiom actionEq.
Proof. case => c1 d1.  case => c2 d2. simpl.
+ case E1: (c1 == c2).
  case E2: (d1 == d2).
  simpl. rewrite (eqP E1) (eqP E2). by apply ReflectT.
  apply ReflectF => H.  inversion H.
  rewrite H2 in E2. by rewrite eq_refl in E2.
  apply ReflectF => H. inversion H.
  rewrite H1 in E1. by rewrite eq_refl in E1.
  by apply ReflectF => H.
  case => c2 d2.
  by apply ReflectF => H.
simpl.
case E1: (c1 == c2).
case E2: (d1 == d2).
  simpl. rewrite (eqP E1) (eqP E2). by apply ReflectT.
  apply ReflectF => H.  inversion H.
  rewrite H2 in E2. by rewrite eq_refl in E2.
  apply ReflectF => H. inversion H.
  rewrite H1 in E1. by rewrite eq_refl in E1.
Qed.

Canonical action_eqMixin := EqMixin action_eqP.
Canonical action_eqType := Eval hnf in EqType _ action_eqMixin.

Definition Actions := seq Action.

Definition preActions (a1 a2: Actions) := exists a', a2 = a1 ++ a'.
Definition preActionsOp a1 a2 := preActions a2 a1.
Definition strictPreActions (a1 a2: Actions) :=
  exists o a', a2 = a1 ++ o::a'.

Definition postActions (a1 a2: Actions) := exists a', a2 = a'++a1.
Definition postActionsOp a1 a2 := postActions a2 a1.
Definition strictPostActions (a1 a2: Actions) :=
  exists o a', a2 = a'++o::a1.

Require Import Coq.Classes.RelationClasses Coq.Program.Basics.

Instance preActions_Pre: PreOrder preActions.
Proof. repeat constructor; hnf.
move => a. exists nil. by rewrite cats0.
move => x y z [a1 ->] [a2 ->]. exists (a1++a2). by rewrite catA.
Qed.

Instance preActionsOp_Pre: PreOrder preActionsOp.
Proof. repeat constructor; hnf.
move => a. exists nil. by rewrite cats0.
move => x y z [a1 ->] [a2 ->]. exists (a2++a1). by rewrite catA.
Qed.

Instance postActionsOp_Pre: PreOrder postActionsOp.
Proof. repeat constructor; hnf.
move => a. by exists nil.
move => x y z [a1 ->] [a2 ->]. exists (a1++a2). by rewrite catA.
Qed.

Lemma cat_preActions a : forall a1 a2, preActions a1 a2 -> preActions (a++a1) (a++a2).
Proof. induction a => // a1 a2 [a' ->]. exists a'. by rewrite catA. Qed.

Require Import Coq.Setoids.Setoid x86proved.charge.csetoid Coq.Classes.RelationClasses Coq.Classes.Morphisms.

Instance ActionsEquiv : Equiv Actions := {
   equiv a1 a2 := a1 = a2
}.

Instance ActionsType : type Actions.
Proof.
  split.
  move => x; by reflexivity.
  move => x y H; by symmetry.
  move => x y z H1 H2; by rewrite H1 H2.
Qed.

Definition outputToActions o : Actions := map (fun p => Out p.1 p.2) o.

Lemma preActionsOp_strictPre x t t':
  preActionsOp t t' -> strictPreActions x t' -> strictPreActions x t.
Proof. move => PRE [a [b H]]. destruct t'. destruct x => //.
+ destruct x. destruct PRE as [d ->]. simpl. by exists a0, (t'++d).
+ inversion H. subst. destruct PRE as [d ->]. simpl.
exists a, (b++d). by rewrite /= -!catA. Qed.

Lemma strictPre_implies_preActionsOp x y :
  strictPreActions x y -> preActionsOp y x.
Proof. move => [a [b ->]]. by exists (a::b).  Qed.

Lemma preActionsOpDef o o' : preActions o o' <-> preActionsOp o' o.
Proof. by unfold preActionsOp. Qed.

Lemma strictPost_implies_postActionsOp x y :
  strictPostActions x y -> postActionsOp y x.
Proof. move => [a [b ->]]. unfold postActionsOp. exists (b++[::a]). by rewrite -catA/=. Qed.

Lemma postActionsOpDef o o' : postActions o o' <-> postActionsOp o' o.
Proof. by unfold postActionsOp. Qed.