 (*

  Copyright 2014 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 cvterm.
Require Export csubst.
Require Export computation3.
Require Export list. (* WTF!!*)

Definition mkcv_tnat {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_tnat.

Definition mk_isl {o} (t : @NTerm o) := mk_ite t mk_btrue mk_bfalse.

Lemma wf_term_decide_iff {p} :
  forall (a : @NTerm p) v1 b1 v2 b2,
    (wf_term a
     # wf_term b1
     # wf_term b2)
    <=> wf_term (mk_decide a v1 b1 v2 b2).
Proof.
  introv; split; intro wf; repnd.
  - allrw @wf_term_eq.
    constructor; simpl; unfold num_bvars; simpl; auto.
    sp; subst; constructor; auto.
  - allrw @wf_term_eq.
    inversion wf as [| | o l bwf e ]; subst.
    generalize (bwf (nobnd a)) (bwf (bterm [v1] b1)) (bwf (bterm [v2] b2)); clear bwf; intros bwf1 bwf2 bwf3.
    autodimp bwf1 hyp; autodimp bwf2 hyp; autodimp bwf3 hyp; try (complete (simpl; sp)).
    inversion bwf1; subst.
    inversion bwf2; subst.
    inversion bwf3; subst; sp.
Qed.

Lemma isprog_vars_decide_iff {p} :
  forall vs (a : @NTerm p) v1 a1 v2 a2,
    isprog_vars vs (mk_decide a v1 a1 v2 a2)
    <=> (isprog_vars vs a
         # isprog_vars (v1 :: vs) a1
         # isprog_vars (v2 :: vs) a2).
Proof.
  introv; split; intro k; try (repnd; apply isprog_vars_decide); auto.
  allrw @isprog_vars_eq; allsimpl.
  allrw remove_nvars_nil_l.
  allrw subvars_eq.
  allrw app_nil_r.
  allrw subset_app; repnd.
  allrw <- @wf_term_eq.
  apply wf_term_decide_iff in k; repnd.
  allrw <- subvars_eq.
  allrw subvars_remove_nvars.
  allrw subvars_eq.
  dands; auto.
  - introv i; simpl.
    apply k2 in i; allrw in_app_iff; allsimpl; sp.
  - introv i; simpl.
    apply k0 in i; allrw in_app_iff; allsimpl; sp.
Qed.

Lemma isprog_vars_ite {p} :
  forall vs (a b c : @NTerm p),
    (isprog_vars vs a # isprog_vars vs b # isprog_vars vs c)
    <=> isprog_vars vs (mk_ite a b c).
Proof.
  introv.
  unfold mk_ite.
  rw @isprog_vars_decide_iff.
  allrw @isprog_vars_cons_newvar; sp.
Qed.

Lemma isprog_vars_ite_implies {p} :
  forall vs (a b c : @NTerm p),
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs c
    -> isprog_vars vs (mk_ite a b c).
Proof.
  intros; apply isprog_vars_ite; sp.
Qed.

Definition mkcv_ite {p} (vs : list NVar) (a b c : @CVTerm p vs) :=
  let (t1,x1) := a in
  let (t2,x2) := b in
  let (t3,x3) := c in
  exist (isprog_vars vs)
        (mk_ite t1 t2 t3)
        (isprog_vars_ite_implies vs t1 t2 t3 x1 x2 x3).

Lemma isprog_vars_isl {o} :
  forall vs (t : @NTerm o), isprog_vars vs (mk_isl t) <=> isprog_vars vs t.
Proof.
  introv.
  unfold mk_isl.
  rw <- @isprog_vars_ite.
  split; intro k; repnd; dands; eauto 3 with slow.
Qed.

Lemma isprog_isl {o} :
  forall (t : @NTerm o),
    isprog (mk_isl t) <=> isprog t.
Proof.
  introv; unfold mk_isl.
  rw @isprog_decide_iff.
  split; intro k; repnd; dands; tcsp; eauto 3 with slow.
Qed.

Lemma implies_isprog_isl {o} :
  forall (t : @NTerm o), isprog t -> isprog (mk_isl t).
Proof.
  introv isp; apply isprog_isl; auto.
Qed.

Definition mkc_isl {o} (t : @CTerm o) : CTerm :=
  let (a,x) := t in exist isprog (mk_isl a) (implies_isprog_isl a x).

Definition mk_assert {o} (t : @NTerm o) := mk_ite t mk_unit mk_void.

Lemma isprog_vars_unit {o} :
  forall vs, @isprog_vars o vs mk_unit.
Proof.
  introv; rw @isprog_vars_eq; simpl; dands; eauto 3 with slow.
Qed.
Hint Resolve isprog_vars_unit : slow.

Lemma isprog_assert {o} :
  forall (t : @NTerm o),
    isprog (mk_assert t) <=> isprog t.
Proof.
  introv; unfold mk_assert.
  rw @isprog_decide_iff.
  split; intro k; repnd; dands; tcsp; eauto 3 with slow.
Qed.

Lemma implies_isprog_assert {o} :
  forall (t : @NTerm o), isprog t -> isprog (mk_assert t).
Proof.
  introv isp; apply isprog_assert; auto.
Qed.

Definition mkc_assert {o} (t : @CTerm o) : CTerm :=
  let (a,x) := t in exist isprog (mk_assert a) (implies_isprog_assert a x).

Definition mkcv_prod {p} vs (A B : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := A in
  let (b,y) := B in
  exist (isprog_vars vs) (mk_prod a b) (isprog_vars_prod_implies vs a b x y).

Definition mkcv_less_than {o} (vs : list NVar) (t1 t2 : @CVTerm o vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_less_than a b) (isprog_vars_less_than_implies a b vs x y).

Lemma mkc_natk_eq {o} :
  forall (t : @CTerm o),
    mkc_natk t
    = mkc_set
        mkc_int
        nvarx
        (mkcv_prod
           [nvarx]
           (mkcv_le [nvarx] (mkcv_zero [nvarx]) (mkc_var nvarx))
           (mkcv_less_than [nvarx] (mkc_var nvarx) (mk_cv [nvarx] t))).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; auto.
  unfold mk_natk.
  rw @newvar_prog; auto.
Qed.

Lemma closed_if_isprog {o} :
  forall (t : @NTerm o),
    isprog t -> closed t.
Proof.
  introv isp.
  apply closed_if_program.
  apply isprogram_eq; auto.
Qed.
Hint Resolve closed_if_isprog : slow.

Lemma mkcv_prod_substc {o} :
  forall v (a b : @CVTerm o [v]) t,
    alphaeqc
      (substc t v (mkcv_prod [v] a b))
      (mkc_prod (substc t v a) (substc t v b)).
Proof.
  introv.
  destruct_cterms.
  unfold alphaeqc; simpl.
  unfold subst.
  repeat (rw @cl_lsubst_lsubst_aux; eauto 3 with slow).
  simpl; fold_terms; rw memvar_singleton.
  constructor; simpl; auto.
  introv k.
  repeat (destruct n; tcsp).
  unfold selectbt; simpl.

  pose proof (newvar_prog (lsubst_aux x0 [(v, x)])) as h.
  autodimp h hyp.
  { apply isprog_vars_nil_implies_isprog.
    rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
    apply csubst.isprog_vars_lsubst; allsimpl; auto .
    introv j; repndors; subst; tcsp.
    apply isprogram_eq; auto. }
  rw h.

  boolvar.

  { rw @lsubst_aux_trivial_cl_term in h; allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw (lsubst_aux_trivial_cl_term x0 [(newvar x0,x)]); allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw h; rw @lsubst_aux_nil; auto. }

  { pose proof (ex_fresh_var (nvarx
                                :: (newvar x0)
                                :: (all_vars (lsubst_aux x0 [(v, x)]))
                                ++ (all_vars (lsubst_aux x0 [(v, x)])))) as fv;
    exrepnd; allsimpl; allrw in_app_iff.
    allrw not_over_or; repnd; GC.
    apply (al_bterm _ _ [v0]); allsimpl; auto.
    { rw disjoint_singleton_l; allrw in_app_iff; allrw not_over_or; sp. }
    unfold var_ren; simpl.

    assert (free_vars (lsubst_aux x0 [(v, x)]) = []) as f.
    { apply null_iff_nil.
      apply closed_null_free_vars.
      apply closed_if_isprog.
      apply isprog_vars_nil_implies_isprog.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      apply csubst.isprog_vars_lsubst; allsimpl; auto .
      introv j; repndors; subst; tcsp.
      apply isprogram_eq; auto. }

    repeat (rw @lsubst_trivial4; simpl; auto);
      allrw disjoint_singleton_l; try (rw f); simpl; tcsp;
      introv j; repndors; tcsp; ginv; simpl;
      apply disjoint_singleton_l; auto. }
Qed.

Lemma mkcv_fun_substc {o} :
  forall v (a b : @CVTerm o [v]) t,
    alphaeqc
      (substc t v (mkcv_fun [v] a b))
      (mkc_fun (substc t v a) (substc t v b)).
Proof.
  introv.
  destruct_cterms.
  unfold alphaeqc; simpl.
  unfold subst.
  repeat (rw @cl_lsubst_lsubst_aux; eauto 3 with slow).
  simpl; fold_terms; rw memvar_singleton.
  constructor; simpl; auto.
  introv k.
  repeat (destruct n; tcsp).
  unfold selectbt; simpl.

  pose proof (newvar_prog (lsubst_aux x0 [(v, x)])) as h.
  autodimp h hyp.
  { apply isprog_vars_nil_implies_isprog.
    rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
    apply csubst.isprog_vars_lsubst; allsimpl; auto .
    introv j; repndors; subst; tcsp.
    apply isprogram_eq; auto. }
  rw h.

  boolvar.

  { rw @lsubst_aux_trivial_cl_term in h; allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw (lsubst_aux_trivial_cl_term x0 [(newvar x0,x)]); allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw h; rw @lsubst_aux_nil; auto. }

  { pose proof (ex_fresh_var (nvarx
                                :: (newvar x0)
                                :: (all_vars (lsubst_aux x0 [(v, x)]))
                                ++ (all_vars (lsubst_aux x0 [(v, x)])))) as fv;
    exrepnd; allsimpl; allrw in_app_iff.
    allrw not_over_or; repnd; GC.
    apply (al_bterm _ _ [v0]); allsimpl; auto.
    { rw disjoint_singleton_l; allrw in_app_iff; allrw not_over_or; sp. }
    unfold var_ren; simpl.

    assert (free_vars (lsubst_aux x0 [(v, x)]) = []) as f.
    { apply null_iff_nil.
      apply closed_null_free_vars.
      apply closed_if_isprog.
      apply isprog_vars_nil_implies_isprog.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      apply csubst.isprog_vars_lsubst; allsimpl; auto .
      introv j; repndors; subst; tcsp.
      apply isprogram_eq; auto. }

    repeat (rw @lsubst_trivial4; simpl; auto);
      allrw disjoint_singleton_l; try (rw f); simpl; tcsp;
      introv j; repndors; tcsp; ginv; simpl;
      apply disjoint_singleton_l; auto. }
Qed.

Definition mkcv_not {p} vs (t : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t in
    exist (isprog_vars vs) (mk_not a) (implies_isprog_vars_not vs a x).

Lemma mkcv_le_eq {o} :
  forall vs (a b : @CVTerm o vs),
    mkcv_le vs a b = mkcv_not vs (mkcv_less_than vs b a).
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkc_not_eq {o} :
  forall (a : @CTerm o),
    mkc_not a = mkc_fun a mkc_void.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; auto.
Qed.

Definition mkcv_void {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_void.

Lemma mkcv_not_eq {o} :
  forall vs (a : @CVTerm o vs),
    mkcv_not vs a = mkcv_fun vs a (mkcv_void vs).
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkcv_not_substc {o} :
  forall v a (t : @CTerm o),
    substc t v (mkcv_not [v] a)
    = mkc_not (substc t v a).
Proof.
  introv.
  rw @mkc_not_eq.
  rw @mkcv_not_eq.

  destruct_cterms.
  apply cterm_eq; simpl.
  repeat unfsubst; simpl; fold_terms.
  allrw @sub_filter_nil_r.
  repeat (rw memvar_singleton; boolvar; allsimpl; tcsp).
  boolvar; tcsp.
Qed.

Definition mkcv_false {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_false.
Definition mkcv_true {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_true.

Lemma mkcv_less_than_eq {o} :
  forall vs (a b : @CVTerm o vs),
    mkcv_less_than vs a b = mkcv_less vs a b (mkcv_true vs) (mkcv_false vs).
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkc_less_than_eq {o} :
  forall a b : @CTerm o, mkc_less_than a b = mkc_less a b mkc_true mkc_false.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

Lemma mkcv_less_substc {o} :
  forall v a b c d (t : @CTerm o),
    substc t v (mkcv_less [v] a b c d)
    = mkc_less (substc t v a) (substc t v b) (substc t v c) (substc t v d).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  repeat unfsubst.
Qed.

Lemma mkcv_true_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_true [v])
    = mkc_true.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; tcsp.
Qed.

Lemma mkcv_false_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_false [v])
    = mkc_false.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  unfsubst; simpl.
  allrw memvar_singleton; boolvar; simpl; tcsp.
  boolvar; simpl; tcsp.
Qed.

Lemma mkcv_less_than_substc {o} :
  forall v a b (c : @CTerm o),
    substc c v (mkcv_less_than [v] a b)
    = mkc_less_than (substc c v a) (substc c v b).
Proof.
  introv.
  rw @mkcv_less_than_eq.
  rw @mkc_less_than_eq.
  rw @mkcv_less_substc.
  rw @mkcv_true_substc.
  rw @mkcv_false_substc.
  auto.
Qed.

Lemma mkcv_le_substc2 {o} :
  forall v a b (c : @CTerm o),
    substc c v (mkcv_le [v] a b)
    = mkc_le (substc c v a) (substc c v b).
Proof.
  introv.
  rw @mkcv_le_eq.
  rw @mkc_le_eq.
  rw @mkcv_not_substc.
  rw @mkcv_less_than_substc.
  auto.
Qed.

Lemma mkc_zero_eq {o} :
  @mkc_zero o = mkc_nat 0.
Proof.
  apply cterm_eq; simpl; auto.
Qed.

Lemma mkc_nat_eq {o} :
  forall n, @mkc_nat o n = mkc_integer (Z.of_nat n).
Proof.
  introv.
  apply cterm_eq; simpl; auto.
Qed.

Lemma isvalue_zero {o} : @isvalue o mk_zero.
Proof.
  unfold mk_zero; eauto with slow.
Qed.
Hint Resolve isvalue_zero : slow.

Lemma iscvalue_zero {o} : @iscvalue o mkc_zero.
Proof.
  unfold iscvalue; simpl; eauto 3 with slow.
Qed.
Hint Resolve iscvalue_zero : slow.

Lemma wf_fix_iff {p} :
  forall a : @NTerm p, wf_term (mk_fix a) <=> wf_term a.
Proof.
  introv; split; intro i.
  - allrw @wf_term_eq.
    inversion i as [| | o lnt k e]; subst; allsimpl.
    generalize (k (nobnd a)); intros k1.
    repeat (dest_imp k1 hyp).
    inversion k1; subst; sp.
  - apply wf_fix; auto.
Qed.

Lemma isprog_vars_fix {p} :
  forall (a : @NTerm p) vs,
    isprog_vars vs (mk_fix a) <=> isprog_vars vs a.
Proof.
  introv.
  repeat (rw @isprog_vars_eq; simpl).
  repeat (rw @remove_nvars_nil_l).
  rw @app_nil_r.
  allrw <- @wf_term_eq.
  allrw @wf_fix_iff; split; sp.
Qed.

Lemma isprog_vars_fix_implies {p} :
  forall (a : @NTerm p) vs,
    isprog_vars vs a
    -> isprog_vars vs (mk_fix a).
Proof.
  introv ispa.
  apply isprog_vars_fix; sp.
Qed.

Definition mkcv_fix {p} vs (t : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t in
    exist (isprog_vars vs) (mk_fix a) (isprog_vars_fix_implies a vs x).

Definition mkc_vbot {p} v : @CTerm p := mkc_fix (mkc_lam v (mkc_var v)).

Lemma isprog_get_cterm {o} :
  forall (t : @CTerm o), isprog (get_cterm t).
Proof.
  introv; destruct_cterms; auto.
Qed.
Hint Resolve isprog_get_cterm : slow.

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


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф__returnOrReinvest (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Definition DePoolContract_Ф__returnOrReinvest_while (Л_chunkSize Л_round1ValidatorsElectedFor: XInteger) : LedgerT (ErrorValue True XInteger) :=
    ( WhileE ( ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_startIndex ?< $ Л_chunkSize ) !&
    ( !¬ ( ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_stakes) ->empty ) ) )
 do
 (
 declareLocal {( Л_addr :>: XAddress , Л_stake :>: RoundsBase_ι_StakeValue )} := ( ↑17 U1! delMin LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_stakes ) (* ->get *) ;

 DePoolContract_Ф__returnOrReinvestForParticipant (!
          ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ,
          ↑17 D2! LocalState_ι__returnOrReinvest_Л_round0 ,
          $ Л_addr ,
          $ Л_stake ,
          $ xBoolFalse ,
          $ Л_round1ValidatorsElectedFor !) >>=
 fun ea => xErrorMapDefaultF (fun a => (↑17 U1! {( LocalState_ι__returnOrReinvest_Л_round0 , LocalState_ι__returnOrReinvest_Л_round2 )} := $ a ) >> continue! (xValue I))
           ea (fun er => break! (xError er)))) >>=
     fun r => return! (xProdSnd r).

Definition DePoolContract_Ф__returnOrReinvest_tailer ( Л_chunkSize Л_round1ValidatorsElectedFor: XInteger) : LedgerT (XErrorValue RoundsBase_ι_Round XInteger ) :=
    do _ ← DePoolContract_Ф__returnOrReinvest_while Л_chunkSize Л_round1ValidatorsElectedFor ?;
    ( RoundsBase_Ф_setRound0 (! ↑17 D2! LocalState_ι__returnOrReinvest_Л_round0 !) ) >>
( If ( ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_stakes ) ->empty )
then
{
   (↑17 U1! LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_step :=
                      ξ$ RoundsBase_ι_RoundStepP_ι_Completed ) >>

    this->sendMessage ( $ DePoolContract_Ф_ticktockF ) with {|| messageValue ::= $ DePool_ι_VALUE_FOR_SELF_CALL ,
                                       messageBounce ::= $ xBoolFalse||}
   } ) >>
return!! ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ) .

Definition DePoolContract_Ф__returnOrReinvest_header ( Л_round2 : RoundsBase_ι_Round ) ( Л_chunkSize : XInteger8 ) : LedgerT ( XErrorValue RoundsBase_ι_Round XInteger ) :=

( declareInit LocalState_ι__returnOrReinvest_Л_round2   := $ Л_round2 ) >>
tvm_accept () >>
( declareGlobal! LocalState_ι__returnOrReinvest_Л_round0 :>: RoundsBase_ι_Round := RoundsBase_Ф_getRound0 () ) >>
 U0! Л_round := ( RoundsBase_Ф_getRound1 () ) ;
 declareLocal Л_round1ValidatorsElectedFor :>: XInteger32 :=  $ Л_round ->> RoundsBase_ι_Round_ι_validatorsElectedFor ;
( declareGlobal! LocalState_ι__returnOrReinvest_Л_startIndex :>: XInteger := $ xInt0 ) >>
If!! ( !¬ ( ↑17 D1! ( D2! LocalState_ι__returnOrReinvest_Л_round2 ) ^^
            RoundsBase_ι_Round_ι_isValidatorStakeCompleted ) )
then
{
  ( ↑17 U1! LocalState_ι__returnOrReinvest_Л_round2 ^^
        RoundsBase_ι_Round_ι_isValidatorStakeCompleted := $ xBoolTrue ) >>
  declareLocal Л_optStake :>: (XMaybe RoundsBase_ι_StakeValue) := (D1! (↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ^^
                                                                           RoundsBase_ι_Round_ι_stakes)
         ->fetch ( ↑2 D2! ValidatorBase_ι_m_validatorWallet ) ) ;
   If! ( ( $ Л_optStake ) ->hasValue )
   then
   {
    declareLocal Л_stake :>: RoundsBase_ι_StakeValue := ( $ Л_optStake ) ->get ;
    ( ↑17 U1! LocalState_ι__returnOrReinvest_Л_startIndex := $ xInt1 ) >>
    ( ↑↑17 U2! delete LocalState_ι__returnOrReinvest_Л_round2 ^^
             RoundsBase_ι_Round_ι_stakes [[ ↑2 D2! ValidatorBase_ι_m_validatorWallet ]] ) >>
    U0! Л_rounds ?:=
        DePoolContract_Ф__returnOrReinvestForParticipant (!
         ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ,
         ↑17 D2! LocalState_ι__returnOrReinvest_Л_round0 ,
         ↑2 D2! ValidatorBase_ι_m_validatorWallet ,
         $ Л_stake ,
         $ xBoolTrue ,
         $ Л_round1ValidatorsElectedFor !) ;
( ↑17 U1! {( LocalState_ι__returnOrReinvest_Л_round0 , LocalState_ι__returnOrReinvest_Л_round2 )} := $ Л_rounds )
   } ; $ I
} ;  DePoolContract_Ф__returnOrReinvest_tailer Л_chunkSize Л_round1ValidatorsElectedFor .

Lemma DePoolContract_Ф__returnOrReinvest_eq:
DePoolContract_Ф__returnOrReinvest = DePoolContract_Ф__returnOrReinvest_header.
Proof.
    unfold DePoolContract_Ф__returnOrReinvest.
    unfold DePoolContract_Ф__returnOrReinvest_header.
    unfold DePoolContract_Ф__returnOrReinvest_while.
    auto.
Qed.

Opaque DePoolContract_Ф__returnOrReinvest_while DePoolContract_Ф__returnOrReinvestForParticipant DePoolContract_Ф__returnOrReinvest_tailer.

Lemma DePoolContract_Ф__returnOrReinvest_header_exec : forall (Л_round2 : RoundsBase_ι_Round ) ( chunkSize : XInteger8 )
                                                        (l: Ledger) ,
let round2 := Л_round2 in
let la := exec_state tvm_accept l in
let round0 := eval_state (↓ RoundsBase_Ф_getRound0) la in
let round1 := eval_state (↓ RoundsBase_Ф_getRound1) la in
let round1ValidatorsElectedFor := round1 ->> RoundsBase_ι_Round_ι_validatorsElectedFor in
let if1 := negb (round2 ->> RoundsBase_ι_Round_ι_isValidatorStakeCompleted) in
let m_validatorWallet := eval_state (↑2 ε ValidatorBase_ι_m_validatorWallet) la in
let stakes :=  round2 ->> RoundsBase_ι_Round_ι_stakes in
let optStake := stakes ->fetch m_validatorWallet in
let if2 := isSome optStake in
let stake := maybeGet optStake in
let startIndex := if if1 then if if2 then 1 else 0 else 0 in
let stakes := if if1 then if if2 then stakes ->delete m_validatorWallet else stakes else stakes in
let round2 := if if1 then if if2 then
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true);
                          (RoundsBase_ι_Round_ι_stakes, stakes) $} else
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true) $} else
            round2 in
let newl := {$la With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                      (LocalState_ι__returnOrReinvest_Л_round0, round0);
                      (LocalState_ι__returnOrReinvest_Л_startIndex, startIndex)  $} in

let (erounds, newl) := if if1 then
                            if if2 then
                            run (↓ DePoolContract_Ф__returnOrReinvestForParticipant round2 round0 m_validatorWallet stake true round1ValidatorsElectedFor) newl
                            else (Value (round0, round2), newl)
                      else (Value (round0, round2), newl) in
let ml1 := newl in
let bRounds := errorValueIsValue erounds in
let (round0, round2)  := errorMapDefault Datatypes.id erounds (round0, round2) in
let newl := {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                        (LocalState_ι__returnOrReinvest_Л_round0, round0) $} in
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) newl   in
let bl := exec_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) {$la With (LocalState_ι__returnOrReinvest_Л_startIndex, 0);
                                (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                (LocalState_ι__returnOrReinvest_Л_round0, round0)  $} in
exec_state (DePoolContract_Ф__returnOrReinvest_header Л_round2 chunkSize) l =
if if1 then
    if if2 then
        if bRounds then newl
        else ml1
    else bl
else bl .
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    all: try destructFunction6 DePoolContract_Ф__returnOrReinvestForParticipant; auto. idtac.
    all: try case_eq x; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    case_eq x0; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto.

Qed.

Lemma DePoolContract_Ф__returnOrReinvest_header_eval : forall (Л_round2 : RoundsBase_ι_Round ) ( chunkSize : XInteger8 )
                                                        (l: Ledger) ,
let round2 := Л_round2 in
let la := exec_state tvm_accept l in
let round0 := eval_state (↓ RoundsBase_Ф_getRound0) la in
let round1 := eval_state (↓ RoundsBase_Ф_getRound1) la in
let round1ValidatorsElectedFor := round1 ->> RoundsBase_ι_Round_ι_validatorsElectedFor in
let if1 := negb (round2 ->> RoundsBase_ι_Round_ι_isValidatorStakeCompleted) in
let m_validatorWallet := eval_state (↑2 ε ValidatorBase_ι_m_validatorWallet) la in
let stakes :=  round2 ->> RoundsBase_ι_Round_ι_stakes in
let optStake := stakes ->fetch m_validatorWallet in
let if2 := isSome optStake in
let stake := maybeGet optStake in
let startIndex := if if1 then if if2 then 1 else 0 else 0 in
let stakes := if if1 then if if2 then stakes ->delete m_validatorWallet else stakes else stakes in
let round2 := if if1 then if if2 then
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true);
                          (RoundsBase_ι_Round_ι_stakes, stakes) $} else
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true) $} else
            round2 in
let newl := {$la With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                      (LocalState_ι__returnOrReinvest_Л_round0, round0);
                      (LocalState_ι__returnOrReinvest_Л_startIndex, startIndex)  $} in

let (erounds, newl) := if if1 then
                            if if2 then
                            run (↓ DePoolContract_Ф__returnOrReinvestForParticipant round2 round0 m_validatorWallet stake true round1ValidatorsElectedFor) newl
                            else (Value (round0, round2), newl)
                      else (Value (round0, round2), newl) in
let ml1 := newl in
let bRounds := errorValueIsValue erounds in
let (round0, round2)  := errorMapDefault Datatypes.id erounds (round0, round2) in
let newl := {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                        (LocalState_ι__returnOrReinvest_Л_round0, round0) $} in
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) newl   in
let br := eval_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) {$la With (LocalState_ι__returnOrReinvest_Л_startIndex, 0);
                                (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                (LocalState_ι__returnOrReinvest_Л_round0, round0)  $} in

eval_state (DePoolContract_Ф__returnOrReinvest_header Л_round2 chunkSize) l =
if if1 then
    if if2 then
        if bRounds then eWhile
        else errorMapDefaultF (fun _ => Value default) erounds (fun e => Error e)
    else br
else br .
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    all: try destructFunction6 DePoolContract_Ф__returnOrReinvestForParticipant; auto. idtac.
    all: try case_eq x; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    case_eq x0; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto.

Qed.

Transparent DePoolContract_Ф__returnOrReinvest_tailer.

Lemma DePoolContract_Ф__returnOrReinvest_tailer_exec : forall (chunkSize round1ValidatorsElectedFor : XInteger8 )
                                                        (l: Ledger) ,
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_while chunkSize round1ValidatorsElectedFor) l in
let bWhile := errorValueIsValue eWhile in
let ml2 := newl in
let round0 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round0) newl in
let round2 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round2) newl in
let if3 : bool := xHMapIsNull (round2 ->> RoundsBase_ι_Round_ι_stakes)  in

let newl := exec_state (↓ RoundsBase_Ф_setRound0 round0) newl in
let round2 := if if3 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_Completed) $}
                     else round2 in

let oldMessages := VMState_ι_messages ( Ledger_ι_VMState newl ) in
let newMessage  := {| contractAddress :=  0 ;
                      contractFunction := DePoolContract_Ф_ticktockF  ;
                      contractMessage := {| messageValue :=  DePool_ι_VALUE_FOR_SELF_CALL ;
                                            messageFlag  := 0 ;
                                            messageBounce := false
                                            |} |} in
let newl := if if3 then {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                    (VMState_ι_messages, newMessage :: oldMessages) $} else newl in
exec_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) l =
if bWhile then newl
else ml2.
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_while; auto. idtac.
    case_eq x; intros; auto. idtac.
    Time repeat destructIf_solve2.

Qed.

Lemma DePoolContract_Ф__returnOrReinvest_tailer_eval : forall (chunkSize round1ValidatorsElectedFor : XInteger8 )
                                                        (l: Ledger) ,
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_while chunkSize round1ValidatorsElectedFor) l in
let bWhile := errorValueIsValue eWhile in
let ml2 := newl in
let round0 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round0) newl in
let round2 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round2) newl in
let if3 : bool := xHMapIsNull (round2 ->> RoundsBase_ι_Round_ι_stakes)  in

let newl := exec_state (↓ RoundsBase_Ф_setRound0 round0) newl in
let round2 := if if3 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_Completed) $}
                     else round2 in

let oldMessages := VMState_ι_messages ( Ledger_ι_VMState newl ) in
let newMessage  := {| contractAddress :=  0 ;
                      contractFunction := DePoolContract_Ф_ticktockF  ;
                      contractMessage := {| messageValue :=  DePool_ι_VALUE_FOR_SELF_CALL ;
                                            messageFlag  := 0 ;
                                            messageBounce := false
                                            |} |} in
let newl := if if3 then {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                    (VMState_ι_messages, newMessage :: oldMessages) $} else newl in
eval_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) l =
if bWhile then Value round2
else errorMapDefaultF (fun _ => Value default) eWhile (fun e => Error e).
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_while; auto. idtac.
    case_eq x; intros; auto. idtac.
    Time repeat destructIf_solve2.

Qed.

End DePoolContract_Ф__returnOrReinvest.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Ext_Cons.Arrow.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import Basic_Cons.Equalizer.
From Categories Require Import Basic_Cons.Facts.Equalizer_Monic.
From Categories Require Import Coq_Cats.Type_Cat.Card_Restriction.
From Categories Require Import Archetypal.Discr.Discr Archetypal.Discr.NatFacts.

From Categories Require Import Limits.GenProd_GenSum.
From Categories Require Import Limits.Limit.

Local Open Scope functor_scope.

Section GenProd_Eq_Complete.
  Context {C : Category}.

  Local Ltac ElimUnit := repeat match goal with [H : unit |- _] => destruct H end.

  Section GenProd_Eq_Limits.
    Context {J : Category}.

    Context {OProd : ∀ (map : J → C), (Π map)%object}
            {HProd : ∀ (map : (Arrow J) → C), (Π map)%object}
            {Eqs : Has_Equalizers C}
    .

    Section Limits_Exist.
      Context (D : J –≻ C).

      Local Notation DTarg := (fun f => (D _o (Targ f))%object) (only parsing).
      Local Notation DF := Discr_Func (only parsing).
      Local Notation OPR := (OProd (D _o)%object) (only parsing).
      Local Notation HPR := (HProd DTarg) (only parsing).

      Program Definition Projs_Cone : Cone (DF DTarg) :=
        {|
          cone_apex := Const_Func 1 (OPR _o tt);
          cone_edge := {|Trans := fun f => Trans (cone_edge OPR) (Targ f)|}
        |}.

      Definition Projs : (OPR –≻ HPR)%morphism :=
        Trans (LRKE_morph_ex HPR Projs_Cone) tt.

      Program Definition D_imgs_Cone : Cone (DF DTarg) :=
        {|
          cone_apex := Const_Func 1 (OPR _o tt);
          cone_edge :=
            {|
              Trans :=
                fun f =>
                  (D _a (Arr f) ∘ (Trans (cone_edge OPR) (Orig f)))%morphism
            |}
        |}.

      Definition D_imgs : (OPR –≻ HPR)%morphism :=
        Trans (LRKE_morph_ex HPR D_imgs_Cone) tt.

      Program Definition Lim_Cone : Cone D :=
        {|
          cone_apex := Const_Func 1 (Eqs _ _ Projs D_imgs);
          cone_edge :=
            {|Trans :=
                fun d => ((Trans (cone_edge OPR) d)
                         ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
            |}
        |}.

      Next Obligation.
      Proof.
        simpl_ids.
        set (W :=
               f_equal
                 (fun t :
                        (((Const_Func 1 (((OProd (D _o)) _o) tt)%object)
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                          –≻ (DF DTarg))%nattrans
                  =>
                    ((Trans t {|Arr := h|})
                       ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
                 )
                 (cone_morph_com (LRKE_morph_ex HPR D_imgs_Cone))
            ).
        set (W' :=
               f_equal
                 (fun t :
                        (((Const_Func 1 (((OProd (D _o)) _o) tt)%object)
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                          –≻ (DF DTarg))%nattrans
                  =>
                    (Trans t {|Arr := h|}
                           ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
                 )
                 (cone_morph_com (LRKE_morph_ex HPR Projs_Cone))
            ).
        clearbody W W'.
        rewrite (assoc_sym _ _ ((D _a) h)).
        cbn in *.
        fold D_imgs in W.
        fold Projs in W'.
        rewrite W'.
        etransitivity; [|symmetry; apply W].
        clear W W'.
        repeat rewrite assoc.
        apply (
            f_equal
              (fun f =>
                 compose f
                         (Trans
                            (HProd (fun f : Arrow J => (D _o)%object (Targ f)))
                            {| Arr := h |}
                         )
              )
          ).
        apply (
            f_equal (
                fun f =>
                  compose f
                          (((HProd (fun f : Arrow J =>
                                      (D _o)%object (Targ f))) _a) tt)
              )
          ).
        apply equalizer_morph_com.
      Qed.

      Next Obligation.
      Proof.
        symmetry.
        apply Lim_Cone_obligation_1.
      Qed.

      Section Every_Cone_Equalizes.
        Context (Cn : Cone D).

        Local Hint Extern 1 => progress cbn.

        Program Definition Cone_to_DF_DCone : Cone (DF (D _o)%object) :=
          {|
            cone_apex := Cn;
            cone_edge :=
              @NatTrans_compose
                _ _
                (Cn ∘ (Functor_To_1_Cat (Discr_Cat J)))
                (Discr_Func ((Cn ∘ (Functor_To_1_Cat J))%functor _o)%object) _
                {|Trans := fun _ => id |} (Discretize (cone_edge Cn))
          |}.

        Definition From_Cone_to_OPR : (Cn –≻ OPR)%morphism :=
          Trans (LRKE_morph_ex OPR Cone_to_DF_DCone) tt.

        Program Definition Cone_to_DF_DTrag_Cone : Cone (DF DTarg) :=
          {|
            cone_apex := Cn;
            cone_edge := {|Trans :=
                             fun c => Trans (Discretize (cone_edge Cn)) (Targ c)|}
          |}.

        Program Definition Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1 :
          Cone_Morph _ Cone_to_DF_DTrag_Cone HPR :=
          {|
            cone_morph :=
              {|Trans :=
                  fun f =>
                    match f as u return (((Cn _o) u)%object –≻ (_ u))%morphism
                    with
                    | tt => (Projs ∘ From_Cone_to_OPR)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          do 2 rewrite From_Term_Cat.
          auto.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x; cbn.
          unfold Projs, From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (fun w :
                        ((Projs_Cone
                            ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J)))
                         ) –≻ (DF DTarg))%nattrans
                    =>
                      (
                        (Trans w x)
                          ∘ (Trans
                               (LRKE_morph_ex
                                  (OProd (D _o)%object) Cone_to_DF_DCone) tt)
                      )%morphism
                   )
                   (
                     cone_morph_com
                       (
                         LRKE_morph_ex
                           (HProd (fun f : Arrow J => (D _o)%object (Targ f)))
                           Projs_Cone
                       )
                   )
              );
            clearbody H; cbn in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((Cone_to_DF_DCone
                             ∘ (Functor_To_1_Cat (Discr_Cat J))
                          ) –≻ (DF (D _o)%object))%nattrans
                     =>
                       Trans w (Targ x)
                   )
                   (cone_morph_com (LRKE_morph_ex
                                      (OProd (D _o)%object) Cone_to_DF_DCone))
              ).
          cbn in *.
          rewrite From_Term_Cat in H; simpl_ids in H.
          trivial.
        Qed.

        Program Definition Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2 :
          Cone_Morph _ Cone_to_DF_DTrag_Cone HPR :=
          {|
            cone_morph :=
              {|Trans :=
                  fun f =>
                    match f as u return (((Cn _o)%object u) –≻ (_ u))%morphism
                    with
                    | tt => (D_imgs ∘ From_Cone_to_OPR)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          do 2 rewrite From_Term_Cat; simpl_ids; trivial.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          cbn.
          unfold D_imgs, From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((D_imgs_Cone
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J)))
                          ) –≻ (DF DTarg))%nattrans
                     =>
                       (
                         (Trans w x)
                           ∘ (Trans
                                (LRKE_morph_ex
                                   (OProd (D _o)%object) Cone_to_DF_DCone)tt)
                       )%morphism
                   )
                   (
                     cone_morph_com
                       (LRKE_morph_ex
                          (HProd (fun f : Arrow J =>
                                    (D _o)%object (Targ f))) D_imgs_Cone )
                   )
              );
            clearbody H; cbn in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((Cone_to_DF_DCone
                             ∘ (Functor_To_1_Cat (Discr_Cat J))
                          ) –≻ (DF (D _o)%object))%nattrans
                     =>
                       (((D _a) (Arr x)) ∘ (Trans w (Orig x)))%morphism
                   )
                   (cone_morph_com
                      (LRKE_morph_ex (OProd (D _o)%object) Cone_to_DF_DCone))
              );
            clearbody H; cbn in H.
          rewrite From_Term_Cat in H; simpl_ids in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          cbn_rewrite <- (@Trans_com _ _ _ _ Cn).
          rewrite From_Term_Cat; auto.
        Qed.

        Lemma From_Cone_to_Obj_Prod_Equalizes :
          (Projs ∘ From_Cone_to_OPR = D_imgs ∘ From_Cone_to_OPR)%morphism.
        Proof.
          match goal with
            [|- ?A = ?B] =>
            change A with
            (Trans Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1 tt);
              change B with
              (Trans Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2 tt)
          end.
          match goal with
            [|- Trans ?A tt = Trans ?B tt] =>
            assert (A = B) as Heq; [|rewrite Heq]; trivial
          end.
          apply (LRKE_morph_unique HPR).
        Qed.

        Definition From_Cone_to_Lim_Cone : (Cn –≻ Lim_Cone)%morphism :=
          equalizer_morph_ex _  From_Cone_to_Obj_Prod_Equalizes.

        Program Definition Cone_Morph_to_Lim_Cone : Cone_Morph D Cn Lim_Cone :=
          {|
            cone_morph :=
              {|
                Trans :=
                  fun c =>
                    match c as u return ((Cn _o u)%object –≻ _)%morphism with
                      tt => From_Cone_to_Lim_Cone
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          rewrite From_Term_Cat; auto.
        Qed.

        Next Obligation.
          symmetry.
          apply Cone_Morph_to_Lim_Cone_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          unfold From_Cone_to_Lim_Cone.
          cbn in *.
          set (H :=
                 equalizer_morph_ex_com
                   (Eqs _ _ Projs D_imgs)
                   From_Cone_to_Obj_Prod_Equalizes
              );
            clearbody H; cbn in H.
          simpl_ids.
          rewrite assoc.
          match goal with
            [|- _ = (?A ∘ ?B)%morphism] =>
            replace B with From_Cone_to_OPR
          end.
          clear H.
          unfold From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((Cone_to_DF_DCone ∘ (Functor_To_1_Cat (Discr_Cat J))
                          ) –≻ (DF (D _o)%object))%nattrans
                     =>
                       Trans w x
                   )
                   (cone_morph_com (LRKE_morph_ex
                                      (OProd (D _o)%object) Cone_to_DF_DCone))
              ).
          cbn in H.
          rewrite From_Term_Cat in H; simpl_ids in H.
          trivial.
        Qed.

      End Every_Cone_Equalizes.

      Section Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR.
        Context {Cn : Cone D} (h : Cone_Morph _ Cn Lim_Cone).

        Program Definition Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR :
          Cone_Morph _ (Cone_to_DF_DCone Cn) OPR :=
          {|
            cone_morph :=
              {|
                Trans :=
                  fun c =>
                    match c as u return
                          (((Cn _o) u)
                             –≻ (((OProd (D _o)) _o) u))%object%morphism
                    with
                    | tt => (equalizer_morph (Eqs _ _ Projs D_imgs)
                                            ∘ Trans h tt)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          rewrite From_Term_Cat; auto.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          cbn.
          set (H :=
                 f_equal
                   (fun w : ((Cn ∘ (Functor_To_1_Cat J)) –≻ D)%nattrans =>
                      Trans w x)
                   (cone_morph_com h)
              ).
          cbn in H.
          simpl_ids in H.
          rewrite From_Term_Cat; simpl_ids.
          rewrite assoc in H.
          trivial.
        Qed.

      End Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR.

      Local Notation CMCOPR :=
        Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR (only parsing).

      Program Definition Lim_Cone_is_Limit : Limit D :=
        {|
          LRKE := Lim_Cone;
          LRKE_morph_ex := Cone_Morph_to_Lim_Cone
        |}.

      Next Obligation.
      Proof.
        set (H := LRKE_morph_unique
                    (OProd (D _o)%object) _ (CMCOPR h) (CMCOPR h')).
        apply (
            f_equal
              (fun w : ((Cone_to_DF_DCone Cn) –≻ (OProd (D _o)%object))%nattrans =>
                 Trans w tt)
          ) in H.
        cbn in H.
        apply NatTrans_eq_simplify.
        extensionality x; destruct x.
        apply (@mono_morphism_monomorphic
                 _ _ _ (@Equalizer_Monic _ _ _ _ _ (Eqs _ _ Projs D_imgs))).
        trivial.
      Qed.

    End Limits_Exist.
  End GenProd_Eq_Limits.

  Section Restricted_Limits.
    Context (P : Card_Restriction)
            {CHRP : ∀ (A : Type) (map : A → C), (P A) → (Π map)%object}
            {HE : Has_Equalizers C}
    .

    Definition Restr_GenProd_Eq_Restr_Limits : Has_Restr_Limits C P :=
      fun J D PJ PA =>
        @Lim_Cone_is_Limit
          J
          (fun map => CHRP J map PJ)
          (fun map => CHRP (Arrow J) map PA)
          HE
          D
    .

  End Restricted_Limits.

  Section Complete.
    Context {CHAP : ∀ (A : Type) (map : A → C), (Π map)%object}
            {HE : Has_Equalizers C}.

    Definition GenProd_Eq_Complete : Complete C :=
      fun J =>
        Local_to_Global_Right
          _
          _
          (fun D => @Lim_Cone_is_Limit J (CHAP J) (CHAP (Arrow J)) HE D)
    .

  End Complete.

End GenProd_Eq_Complete.

Section GenSum_CoEq_Complete.
  Context {C : Category}.

  Section GenSum_CoEq_CoLimits.
    Context {J : Category}
            {OSum : ∀ (map : J → C), (Σ map)%object}
            {HSum : ∀ (map : (Arrow J) → C), (Σ map)%object}
            {Eqs : Has_CoEqualizers C}
    .

    Section Limits_Exist.
      Context (D : J –≻ C).

      Program Definition CoLim_CoCone_is_CoLimit : CoLimit D :=
        @Lim_Cone_is_Limit
          (C^op)
          (J^op)
          (fun map => GenSum_to_GenProd (OSum map))
          (fun map => GenSum_to_GenProd (GenSum_IsoType (Arrow_OP_Iso J) HSum map))
          Eqs
          (Opposite_Functor D)
      .

    End Limits_Exist.
  End GenSum_CoEq_CoLimits.

  Section Restricted_CoLimits.
    Context (P : Card_Restriction)
            {CHRP : ∀ (A : Type) (map : A → C), (P A) → (Σ map)%object}
            {HE : Has_CoEqualizers C}
    .

    Definition Restr_GenSum_CoEq_Restr_CoLimits : Has_Restr_CoLimits C P :=
      fun J D PJ PA =>
        @CoLim_CoCone_is_CoLimit
          J
          (fun map => CHRP J map PJ)
          (fun map => CHRP (Arrow J) map PA)
          HE
          D
    .

  End Restricted_CoLimits.

  Section CoComplete.
    Context {CHAP : ∀ (A : Type) (map : A → C), (Σ map)%object}
            {HE : Has_CoEqualizers C}
    .

    Definition GenSum_CoEq_CoComplete : CoComplete C :=
      fun J =>
        Local_to_Global_Left
          _
          _
          (fun D => @CoLim_CoCone_is_CoLimit J (CHAP J) (CHAP (Arrow J)) HE D)
    .

  End CoComplete.

End GenSum_CoEq_Complete.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, Collège de France and Inria Paris            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 2.1 of   *)
(*  the License, or  (at your option) any later version.               *)
(*  This file is also distributed under the terms of the               *)
(*  INRIA Non-Commercial License Agreement.                            *)
(*                                                                     *)
(* *********************************************************************)

(** Platform-specific built-in functions *)

Require Import String Coqlib.
Require Import AST Integers Floats Values.
Require Import Builtins0.

Inductive platform_builtin : Type :=
  | BI_fmin
  | BI_fmax.

Local Open Scope string_scope.

Definition platform_builtin_table : list (string * platform_builtin) :=
     ("__builtin_fmin", BI_fmin)
  :: ("__builtin_fmax", BI_fmax)
  :: nil.

Definition platform_builtin_sig (b: platform_builtin) : signature :=
  match b with
  | BI_fmin | BI_fmax =>
      mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default
  end.

Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
  match b with
  | BI_fmin =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Lt => f1
                      | Some Eq | Some Gt | None => f2
                      end)
  | BI_fmax =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Gt => f1
                      | Some Eq | Some Lt | None => f2
                      end)
  end.


Require Import GMuAnnot.Prelude.
Require Import GMuAnnot.Infrastructure.

Open Scope list_scope.

(* Proofs regarding proposition 2.1 from the paper *)
Section SimpleEquationProperties.

  Variable Σ : GADTEnv.

  Lemma teq_reflexivity : forall Δ T,
      entails_semantic Σ Δ (T ≡ T).
    cbn.
    intros.
    auto.
  Qed.

  Lemma teq_symmetry : forall Δ T U,
      entails_semantic Σ Δ (T ≡ U) ->
      entails_semantic Σ Δ (U ≡ T).
    cbn. intros.
    symmetry.
    auto.
  Qed.

  Lemma teq_transitivity : forall Δ T U V,
      entails_semantic Σ Δ (T ≡ U) ->
      entails_semantic Σ Δ (U ≡ V) ->
      entails_semantic Σ Δ (T ≡ V).
    cbn. intros.
    transitivity (subst_tt' U Θ); auto.
  Qed.

  Lemma subst_has_no_fv : forall Σ Δ Θ,
      subst_matches_typctx Σ Δ Θ ->
      (forall X U, List.In (X, U) Θ -> fv_typ U = \{}).
    induction 1; introv Hin.
    - false.
    - cbn in Hin.
      destruct Hin as [Hin | Hin].
      + inversions Hin.
        lets Hfv: wft_gives_fv H.
        cbn in Hfv.
        apply~ fset_extens.
      + apply* IHsubst_matches_typctx.
    - apply* IHsubst_matches_typctx.
  Qed.

  Lemma teq_axiom : forall Δ T U,
      List.In (tc_eq (T ≡ U)) Δ ->
      entails_semantic Σ Δ (T ≡ U).
    unfold entails_semantic.
    induction Δ; introv Hin M.
    - contradiction.
    - cbn in Hin.
      destruct Hin as [Hin | Hin].
      + subst. inversion M.
        easy.
      + inversion M; auto.
        cbn.
        repeat rewrite subst_tt_inside; auto.
        * f_equal.
          apply IHΔ; auto.
        * introv Uin.
          lets Fr: subst_has_no_fv Uin.
          -- eauto.
          -- rewrite Fr. apply notin_empty.
        * introv Uin.
          lets Fr: subst_has_no_fv Uin.
          -- eauto.
          -- rewrite Fr. apply notin_empty.
  Qed.

End SimpleEquationProperties.

Ltac fold_from_list :=
  repeat progress match goal with
  | [ H: context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} ?L]  |- _ ] =>
    fold (from_list L) in H
  | |- context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} ?L] =>
    fold (from_list L)
                  end.

Lemma notin_from_list : forall As (A : var),
    ~ (List.In A As) ->
    A \notin from_list As.
  intros.
  intro HF.
  lets [A' [Hin Heq]]: in_from_list HF.
  subst.
  auto.
Qed.

Lemma spawn_unit_subst : forall Σ As,
    DistinctList As ->
    exists Θ, length Θ = length As /\ subst_matches_typctx Σ (tc_vars As) Θ /\ substitution_sources Θ = from_list As.
  induction As as [| Ah Ats]; introv ADist.
  - cbn.
    exists (@nil (var * typ)).
    splits~.
    constructor.
  - inversions ADist.
    destruct IHAts as [LT [Len [Match Src]]]; auto.
    exists ((Ah, typ_unit) :: LT).
    splits.
    + cbn. auto.
    + constructor;
        fold (List.map tc_var Ats);
        fold (tc_vars Ats);
        auto.
      * rewrite Src.
        apply~ notin_from_list.
      * apply notin_dom_tc_vars.
        apply~ notin_from_list.
    + cbn.
      fold_from_list.
      fold (substitution_sources LT).
      rewrite Src.
      trivial.
Qed.

Lemma only_vars_is_tc_vars : forall Δ,
    (forall tc, List.In tc Δ -> exists A, tc = tc_var A) ->
    exists As, Δ = tc_vars As.
  induction Δ as [| [A | eq] Δt].
  - cbn. intros. exists (@nil var). cbn. trivial.
  - cbn. intro Hin.
    lets* [Ats EQ]: IHΔt.
    exists (A :: Ats). cbn.
    fold (tc_vars Ats).
    f_equal.
    auto.
  - cbn. intro Hin.
    false~ Hin. congruence.
Qed.

Lemma contradictory_env_test_0 : forall Σ Δ,
    entails_semantic Σ Δ (typ_unit ≡ (typ_unit ** typ_unit)) ->
    contradictory_bounds Σ Δ.
  introv Heq.
  unfold contradictory_bounds.
  intros.
  unfold entails_semantic in *.
  introv Hmatch.
  exfalso.
  lets HF: Heq Hmatch.
  rewrite subst_ttΘ_fresh in HF.
  - rewrite subst_ttΘ_fresh in HF.
    + false.
    + cbn. rewrite union_empty_r.
      rewrite~ inter_empty_r.
  - cbn.
    rewrite~ inter_empty_r.
Qed.

Lemma subst_ttΘ_into_abs : forall Θ A B,
    subst_tt' (A ==> B) Θ
    =
    (subst_tt' A Θ) ==> (subst_tt' B Θ).
  induction Θ as [| [X T] Θ]; cbn in *; trivial.
Qed.
Lemma subst_ttΘ_into_tuple : forall Θ A B,
    subst_tt' (A ** B) Θ
    =
    (subst_tt' A Θ) ** (subst_tt' B Θ).
  induction Θ as [| [X T] Θ]; cbn in *; trivial.
Qed.

Lemma contradictory_env_test : forall Σ Δ A B C D,
    entails_semantic Σ Δ ((A ==> B) ≡ (C ** D)) ->
    contradictory_bounds Σ Δ.
  introv Heq.
  unfold contradictory_bounds.
  intros.
  unfold entails_semantic in *.
  introv Hmatch.
  exfalso.
  lets HF: Heq Hmatch.
  rewrite subst_ttΘ_into_abs in HF.
  rewrite subst_ttΘ_into_tuple in HF.
  congruence.
Qed.

Lemma empty_is_not_contradictory : forall Σ,
    ~ (contradictory_bounds Σ emptyΔ).
  intros.
  intro HF.
  unfold contradictory_bounds in HF.
  asserts M: (subst_matches_typctx Σ emptyΔ (@nil (var*typ)));
    try econstructor.
  lets F: HF typ_unit (typ_unit ** typ_unit) (@nil (var * typ)) M.
  cbn in F.
  false.
Qed.

Lemma typing_exfalso : forall Σ Δ E e T1 T2 TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T1 ->
    contradictory_bounds Σ Δ ->
    wft Σ Δ T2 ->
    {Σ, Δ, E} ⊢(Tgen) e ∈ T2.
  introv Typ Bounds.
  eapply typing_eq; eauto.
Qed.

Lemma inversion_typing_eq : forall Σ Δ E e T TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T ->
    exists T',
      {Σ, Δ, E} ⊢(Treg) e ∈ T' /\ entails_semantic Σ Δ (T ≡ T').
  introv Htyp.
  lets Htyp2: Htyp.
  induction Htyp;
    try match goal with
        | [ H: {Σ, Δ, E} ⊢(Treg) ?e ∈ ?T |- _ ] =>
          exists T; split~; auto using teq_reflexivity
        end.
  lets [T' [IHTyp IHeq]]: IHHtyp Htyp.
  exists T'.
  split~.
  eauto using teq_symmetry, teq_transitivity.
Qed.

Lemma subst_has_no_fv2 : forall Σ Δ Θ Y,
    subst_matches_typctx Σ Δ Θ ->
    (forall A U, List.In (A, U) Θ -> Y \notin fv_typ U).
  introv M Hin.
  lets EQ: subst_has_no_fv M Hin.
  rewrite EQ.
  auto.
Qed.

Lemma inversion_eq_arrow : forall Σ Δ TA1 TB1 TA2 TB2,
    entails_semantic Σ Δ ((TA1 ==> TB1) ≡ (TA2 ==> TB2)) ->
    entails_semantic Σ Δ (TA1 ≡ TA2) /\
    entails_semantic Σ Δ (TB1 ≡ TB2).
  introv Sem; cbn in *.
  split~;
       introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_arrow in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_tuple : forall Σ Δ TA1 TB1 TA2 TB2,
    entails_semantic Σ Δ ((TA1 ** TB1) ≡ (TA2 ** TB2)) ->
    entails_semantic Σ Δ (TA1 ≡ TA2) /\
    entails_semantic Σ Δ (TB1 ≡ TB2).
  introv Sem; cbn in *.
  split~;
       introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_tuple in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_typ_all : forall Σ Δ T U,
    entails_semantic Σ Δ (typ_all T ≡ typ_all U) ->
    entails_semantic Σ Δ (T ≡ U).
  introv Sem; cbn in *.
  introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_typ_all in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_typ_gadt : forall Σ Δ Ts Us N,
    List.length Ts = List.length Us ->
    entails_semantic Σ Δ (typ_gadt Ts N ≡ typ_gadt Us N) ->
    List.Forall2 (fun T U => entails_semantic Σ Δ (T ≡ U)) Ts Us.
  introv Len Sem.
  apply F2_iff_In_zip.
  split~.
  intros T U In.
  cbn in *.
  introv M.
  lets EQ: Sem M.
  repeat rewrite subst_tt_prime_reduce_typ_gadt in EQ.
  inversion EQ as [EQ2].
  lets~ : lists_map_eq EQ2 In.
Qed.

Lemma equations_from_lists_map : forall F F1 F2 Ts Us,
    List.length Ts = List.length Us ->
    (forall T U, List.In (T,U) (zip Ts Us) -> F (tc_eq (T ≡ U)) = tc_eq (F1 T ≡ F2 U)) ->
    List.map F (equations_from_lists Ts Us)
    =
    equations_from_lists (List.map F1 Ts) (List.map F2 Us).
  induction Ts as [| T Ts]; destruct Us as [| U Us];
    introv Len;  try solve [inversion~ Len].
  introv EQ.
  cbn.
  fold (equations_from_lists Ts Us).
  fold (equations_from_lists (List.map F1 Ts) (List.map F2 Us)).
  f_equal.
  - apply EQ. cbn. auto.
  - apply* IHTs.
    introv In.
    apply EQ. cbn. auto.
Qed.


(*** Framework.v: Abstract framework where we prove non interference from unwindings lemmas *)
Require Export Wf_nat.
Require Export Omega.
Require Export Max.
Require Export Level.
Require Export cdr.
Require Export Axioms.
Require Export Tactics.
Require Import Setoid.

 Import L.

Section A.
Variable observable : L.t.

Variable PC : Set.
Variable Method : Type.
Variable Kind: Set.
Variable step : Method -> PC -> option PC -> Prop.
Variable PM : Method -> Prop.
Variable cdr : forall m, PM m -> CDR (step m).
Implicit Arguments region.

Variable Reg : Set.

Variable Sign : Set.

Record SignedMethod : Type := SM {unSign:Method; sign:Sign}.
Coercion unSign :  SignedMethod >-> Method.

Variable istate rstate : Type.
Variable exec : Method -> istate -> istate+rstate -> Prop.

Variable pc : istate -> PC.

Notation "m |- p1 => p2" := (step m p1 (Some p2)) (at level 30).
Notation "m |- p1 => " := (step m p1 None) (at level 30).
Variable exec_step_some : forall m s s',
  PM m -> exec m (* kd *) s (inl _ s')-> m |- (pc s) => (pc s').
Variable exec_step_none : forall m s s',
  PM m -> exec m (* kd *) s (inr _ s')-> m |- (pc s) =>.

Variable registertypes : Type.

Variable texec : forall m, PM m ->
      Sign -> (PC->L.t) -> PC ->
      registertypes -> option registertypes -> Prop.
Variable high_reg : registertypes -> Reg -> Prop.
Variable indist_reg_val : istate -> istate -> Reg -> Prop.
Variable indist_reg_val_trans : forall s1 s2 s3 r,
  indist_reg_val s1 s2 r -> indist_reg_val s2 s3 r -> indist_reg_val s1 s3 r.
Variable indist_reg_val_sym : forall s1 s2 r,
  indist_reg_val s1 s2 r -> indist_reg_val s2 s1 r.
Inductive indist_reg : registertypes -> registertypes -> istate -> istate -> Reg -> Prop :=
  | high_indist_reg : forall rt1 rt2 s1 s2 r,
      high_reg rt1 r -> high_reg rt2 r -> indist_reg rt1 rt2 s1 s2 r
  | low_indist_reg : forall rt1 rt2 s1 s2 r, indist_reg_val s1 s2 r -> indist_reg rt1 rt2 s1 s2 r.
Variable indist : Sign -> registertypes -> registertypes -> istate -> istate -> Prop.
Variable indist_from_reg : forall sgn rt1 rt2 s1 s2,
  (forall r, indist_reg rt1 rt2 s1 s2 r) -> indist sgn rt1 rt2 s1 s2.
Variable indist_reg_from_indist : forall sgn rt1 rt2 s1 s2,
  indist sgn rt1 rt2 s1 s2 ->
  forall r,
    (high_reg rt1 r -> high_reg rt2 r -> indist_reg rt1 rt2 s1 s2 r) /\
    ((~high_reg rt1 r /\ ~high_reg rt2 r) \/
      (high_reg rt1 r /\ ~high_reg rt2 r) \/
      (~high_reg rt1 r /\ high_reg rt2 r) ->
    indist_reg_val s1 s2 r).
Variable rindist : Sign -> rstate -> rstate -> Prop.
Variable indist_sym : forall m rt1 rt2 s1 s2,
 indist m rt1 rt2 s1 s2 -> indist m rt2 rt1 s2 s1.
Variable rindist_sym : forall m s1 s2,
 rindist m s1 s2 -> rindist m s2 s1.

Variable high_result : Sign -> rstate -> Prop.

Variable rt0 : Method-> Sign -> registertypes.
Variable init_pc : Method -> PC -> Prop.

Inductive evalsto (m:Method) : nat -> istate -> rstate -> Prop :=
  | evalsto_res : forall (* k *) s res,
      exec m (* k *) s (inr _ res) -> evalsto m 1 s res
  | evalsto_intra : forall (* k *) n s1 s2 res,
     exec m (* k *) s1 (inl _ s2) ->
     evalsto m n s2 res ->
     evalsto m (S n) s1 res.

Variable P : SignedMethod -> Prop.

Variable PM_P : forall m, P m -> PM m.

Definition ni :=
  forall m p p' sgn s s' r r',
  P (SM m sgn) ->
(*   rt0 m sgn rt -> *)
  indist sgn (rt0 m sgn) (rt0 m sgn) s s' ->
  pc s = pc s' ->
  init_pc m (pc s) ->
  init_pc m (pc s') ->
  evalsto m p s r ->
  evalsto m p' s' r' ->
  rindist sgn r r'.

(* seems weird to have same rt *)
Variable indist2_intra : forall m sgn se rt ut ut' s s' u u',
  forall H0:P (SM m sgn),
  indist sgn rt rt s s' ->
  pc s = pc s' ->
  exec m s (inl _ u) ->
  exec m s' (inl _ u') ->
  texec m (PM_P _ H0) sgn se (pc s) rt (Some ut) ->
  texec m (PM_P _ H0) sgn se (pc s) rt (Some ut') ->
    indist sgn ut ut' u u'.

Variable indist2_return : forall m sgn se rt s s' u u',
  forall H0:P (SM m sgn),
  indist sgn rt rt s s' ->
  pc s = pc s' ->
  exec m s (inr _ u) ->
  exec m s' (inr _ u')->
  texec m (PM_P _ H0) sgn se (pc s) rt None ->
  texec m (PM_P _ H0) sgn se (pc s) rt None ->
    rindist sgn u u'.

(* high branching *)
Variable soap2_basic_intra : forall m sgn se rt ut ut' s s' u u',
  forall (h:P (SM m sgn)),
  indist sgn rt rt s s' ->
  pc s = pc s' ->
  exec m s (inl _ u) ->
  exec m s' (inl _ u') ->
  texec m (PM_P _ h) sgn se (pc s) rt (Some ut) ->
  texec m (PM_P _ h) sgn se (pc s) rt (Some ut') ->
  pc u <> pc u' ->
    (forall j:PC, (region (cdr m (PM_P _ h)) (pc s) j) -> ~ leql (se j) observable).

Variable sub : registertypes -> registertypes -> Prop.
Variable sub_simple : forall sgn rt rt' rt0 s s0,
  indist sgn rt0 rt s0 s ->
  sub rt rt' ->
  indist sgn rt0 rt' s0 s.

Inductive typed_exec (m:Method) (H:PM m) (sgn:Sign) (se:PC->L.t) (RT:PC->registertypes)
: istate -> istate + rstate -> Prop :=
  typed_exec_def1 : forall s1 s2 rt',
   exec m s1 (inl _ s2) ->
   sub rt' (RT (pc s2)) ->
   texec m H sgn se (pc s1) (RT (pc s1)) (Some rt') ->
   typed_exec m H sgn se RT s1 (inl _ s2)
| big_exec_def2 : forall s1 s2,
   exec m s1 (inr _ s2) ->
   texec m H sgn se (pc s1) (RT (pc s1)) None ->
   typed_exec m H sgn se RT s1 (inr _ s2).

Inductive tevalsto (m:Method) (H:PM m) (sgn:Sign) (se:PC->L.t) (RT:PC->registertypes) : nat -> istate -> rstate -> Prop :=
  | tevalsto_res : forall s res,
      typed_exec m H sgn se RT s (inr _ res) -> tevalsto m H sgn se RT 1 s res
  | tevalsto_intra : forall n s1 s2 res,
     typed_exec m H sgn se RT s1 (inl _ s2) ->
     tevalsto m H sgn se RT n s2 res ->
     tevalsto m H sgn se RT (S n) s1 res.

(* Hendra additional *)
Variable tevalsto_high_result' : forall m sgn (H:PM m) se s RT res,
  ~L.leql (se m sgn (pc s)) observable ->
  exec m s (inr res) ->
  texec m H sgn (se m sgn) (pc s) (RT m sgn (pc s)) None -> high_result sgn res.

Variable tevalsto_diff_high_result : forall se RT m sgn s s' p res res' (H:PM m),
  pc s = pc s' -> 1 < p ->
  tevalsto m H sgn (se m sgn) (RT m sgn) 1 s res -> tevalsto m H sgn (se m sgn) (RT m sgn) p s' res' ->
  high_result sgn res /\ high_result sgn res'.

Variable high_result_indist : forall sgn res res0,
  high_result sgn res -> high_result sgn res0 -> rindist sgn res res0.

Variable eq_map : registertypes -> registertypes -> Prop.
Variable eq_map_refl : reflexive registertypes eq_map.
Variable eq_map_sym : symmetric registertypes eq_map.
Variable eq_map_trans : transitive registertypes eq_map.
Theorem map_setoid: Setoid_Theory registertypes eq_map.
 split.
 exact eq_map_refl.
 exact eq_map_sym.
 exact eq_map_trans.
Qed.
Add Setoid registertypes eq_map map_setoid as eq_map_rel.

Variable indist_morphism_proof : forall (y : Sign) (x y0 : registertypes),
eq_map x y0 ->
forall x0 y1 : registertypes,
eq_map x0 y1 -> forall y2 y3 : istate, indist y x x0 y2 y3 <-> indist y y0 y1 y2 y3.
Add Morphism indist : indist_morphism. Proof. exact indist_morphism_proof. Qed.

Definition Typable (m:Method) (H:PM m) (sgn:Sign) (se:Method->Sign->PC->L.t) (RT:Method->Sign->PC->registertypes) : Prop :=
  (forall i, init_pc m i -> eq_map (RT m sgn i) (rt0 m sgn)) /\
  (forall i,
     m |- i => ->
     texec m H sgn (se m sgn) i (RT m sgn i) None) /\
  (forall i j,
    m |- i =>j ->
    exists rt,
      texec m H sgn (se m sgn) i (RT m sgn i) (Some rt)
      /\ sub rt (RT m sgn j)).

Definition TypableProg se S :=
  forall m sgn (H:P (SM m sgn)), Typable m (PM_P _ H) sgn se S.

Lemma typable_evalsto : forall se RT m sgn n s r
  (H:PM m),
  Typable m H sgn se RT ->
  evalsto m n s r ->
  tevalsto m H sgn (se m sgn) (RT m sgn) n s r.
Proof.
  intros until r; intros HP H.
  destruct H as [_ [H0 H1]].
  induction 1.
  (* ret *)
  constructor 1; auto.
  constructor; auto.
  apply H0; auto.
  eapply exec_step_none; eauto.
  (* next *)
  constructor 2 with s2; auto.
  elim H1 with (pc s1) (pc s2).
  intros st (HT,Hs).
  constructor 1 with st; auto.
  eapply exec_step_some; eauto.
Qed.

Lemma tevalsto_evalsto : forall se RT m sgn p s r
  (h:PM m),
  tevalsto m h sgn (se m sgn) (RT m sgn) p s r ->
  evalsto m p s r.
Proof.
  induction 1.
  inversion H.
  constructor 1; auto.
  inversion H.
  constructor 2 with s2; auto.
Qed.

Lemma tevalsto_high_result : forall m sgn (H:PM m) se RT s res,
  ~L.leql (se m sgn (pc s)) observable ->
  tevalsto m H sgn (se m sgn) (RT m sgn) 1 s res -> high_result sgn res.
Proof.
  intros.
  apply tevalsto_high_result' with (m:=m) (H:=H) (sgn:=sgn) (se:=se) (s:=s) (RT:=RT); auto.
  apply tevalsto_evalsto in H1. inversion H1; auto. inversion H4.
  inversion H1; auto. inversion H2; auto. inversion H4.
Qed.

Implicit Arguments tevalsto_evalsto.

Hint Resolve PM_P.

Section TypableProg.
Variable se : Method -> Sign -> PC -> L.t.
Variable RT : Method -> Sign -> PC -> registertypes.
Variable T : TypableProg se RT.

Definition high_region m (h:PM m) sgn (i:PC) :=
  forall j:PC, region (cdr m h) i j ->
    ~ leql (se m sgn j) observable.

Hint Immediate indist_sym rindist_sym.
Hint Resolve exec_step_some exec_step_none.

Lemma final_bighighstep_aux : forall m sgn i p s res (H: P (SM m sgn)),
  tevalsto m (PM_P _ H) sgn (se m sgn) (RT m sgn) p s res ->
  region (cdr m (PM_P _ H)) i (pc s) ->
  (forall jun, ~junc (cdr m (PM_P _ H)) i jun) ->
  high_region m (PM_P _ H) sgn i ->
  high_result sgn res.
Proof.
  intros.
  induction H0.
  apply tevalsto_high_result with (m:=m) (H:=(PM_P _ H)) (se:=se) (RT:=RT) (s:=s); auto.
    constructor 1; auto.
  apply IHtevalsto; auto.
  inversion H0.
    eapply exec_step_some with (1:=PM_P _ H) in H6; eauto.
    elim (soap2 (cdr m (PM_P _ H))) with i (pc s1) (pc s2); auto.
    intros. unfold not in H2. apply H2 in H10. contradiction.
Qed.

Lemma final_bighighstep : forall m sgn p i s0 s res res0
  (H:P (SM m sgn)),
  pc s = pc s0 ->
  evalsto m p s res->
  evalsto m 1 s0 res0 ->
  region (cdr m (PM_P _ H)) i (pc s)->
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s0)) s s0 ->
  high_region m (PM_P _ H) sgn i ->
    rindist sgn res res0.
Proof.
  intros.
  inversion H2; try (inversion H8).
  destruct (T m sgn H). inversion_mine H11.
  apply high_result_indist.
  (* high result res *)
    apply final_bighighstep_aux with (m:=m) (i:=i) (p:=p) (s:=s) (H:=H); auto.
    apply typable_evalsto; auto.
    intros.
    apply soap3 with (j:=pc s0).
    rewrite <- H0; auto.
    apply exec_step_none with (1:=PM_P _ H) in H6.
    unfold result; eauto.
  (* high result res0 *)
    apply tevalsto_high_result with (m:=m) (H:=(PM_P _ H)) (se:=se) (RT:=RT) (s:=s0).
        rewrite <- H0; auto.
      apply typable_evalsto; auto.
Qed.

Lemma my_double_ind:forall P:(nat->nat->Prop),
   (forall n m:nat, (forall p q:nat, lt p n -> lt q m -> P p q) -> P n m) ->
   forall p q:nat, P p q.
Proof.
  intros P0 H.
  apply lt_wf_double_ind.
  intros.
  apply H.
  intros.
  apply H0.
  assumption.
Qed.

Lemma execution_reach_junction_or_return_1 : forall m sgn ns i s res (H: P (SM m sgn)),
  region (cdr m (PM_P _ H)) i (pc s) ->
  evalsto m ns s res ->
  (exists u, exists ps,
    evalsto m ps u res /\ ps < ns /\
    junc (cdr m (PM_P _ H)) i (pc u))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) i jun).
Proof.
  intros m sgn ns.
  pattern ns. apply lt_wf_ind.
  clear ns; intros ns Hind; intros.
  inversion H1; auto.
  right.
  apply exec_step_none with (1:=PM_P _ H) in H2.
  intros; apply soap3 with (k:=jun) in H0; auto.
  elim (soap2 (cdr m (PM_P _ H))) with i (pc s) (pc s2); auto.
  intros.
  elim Hind with (m0:=n) (i:=i) (s:=s2) (res:=res) (H:=H); auto; try omega.
  intros [U [ps [sH1 [sH2 sH3]]]].
  left. exists U. exists ps. repeat (split; auto).
  intros.
  left. exists s2. exists n. repeat (split; auto).
  apply exec_step_some with (1:=PM_P _ H) in H2; auto.
Qed.

Lemma execution_reach_junction_or_return_2 : forall m sgn ns ns' i s s' res res' (H: P (SM m sgn)),
  region (cdr m (PM_P _ H)) i (pc s) ->
  region (cdr m (PM_P _ H)) i (pc s') ->
  evalsto m ns s res ->
  evalsto m ns' s' res' ->
  (exists u, exists u', exists ps, exists ps',
    evalsto m ps u res /\ ps < ns /\
    evalsto m ps' u' res' /\ ps' < ns' /\
    junc (cdr m (PM_P _ H)) i (pc u) /\ junc (cdr m (PM_P _ H)) i (pc u'))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) i jun).
Proof.
    intros.
  apply execution_reach_junction_or_return_1 with (sgn:=sgn) (i:=i) (H:=H) in H2; auto.
  apply execution_reach_junction_or_return_1 with (sgn:=sgn) (i:=i) (H:=H) in H3; auto.
  inversion H2; inversion H3; auto.
  left.
  inversion H4; inversion H6; inversion H5; inversion H8.
  exists x; exists x1; exists x0; exists x2; auto.
  Cleanexand.
  repeat (split; auto).
Qed.

Lemma execution_reach_junction_or_return : forall m sgn ns ns' s s' u u' res res' (H: P (SM m sgn)),
  pc s = pc s' ->
  exec m s (inl u) -> exec m s' (inl u') ->
  pc u <> pc u' ->
  evalsto m ns u res ->
  evalsto m ns' u' res' ->
  (exists v, exists v', exists ps, exists ps',
    evalsto m ps v res /\ ps <= ns /\
    evalsto m ps' v' res' /\ ps' <= ns' /\
    junc (cdr m (PM_P _ H)) (pc s) (pc v) /\ junc (cdr m (PM_P _ H)) (pc s') (pc v'))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) (pc s) jun /\ forall jun, ~junc (cdr m (PM_P _ H)) (pc s') jun).
Proof.
  intros.
  apply exec_step_some with (1:=PM_P _ H) in H1; apply exec_step_some with (1:=PM_P _ H) in H2; auto.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc u) (pc u'); try (rewrite H0; auto; fail); auto; intros.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc u') (pc u); try (rewrite H0; auto; fail); auto; intros.
  (* both are in the region *)
  apply execution_reach_junction_or_return_2 with (ns:=ns) (ns':=ns') (s:=u) (s':=u') (res:=res) (res':=res') in H6; auto.
  inversion H6.
  left.
  Cleanexand.
  exists x; exists x0; exists x1; exists x2. repeat (split; auto).
  omega. omega.
  rewrite H0 in H13; auto.
  right. split; auto. rewrite H0 in H8; auto.
  (* one is in the region *)
  apply execution_reach_junction_or_return_1 with (ns:=ns') (s:=u') (res:=res') in H6; auto.
  inversion H6; Cleanexand.
  left.
  exists u; exists x; exists ns; exists x0; repeat (split; auto).
  omega. rewrite H0 in H10; auto.
  right. split; auto. rewrite H0 in H8; auto.
  (* *)
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc u') (pc u); try (rewrite H0; auto; fail); auto; intros.
  (* one is in the region *)
  apply execution_reach_junction_or_return_1 with (ns:=ns) (s:=u) (res:=res) in H7; auto.
  inversion H7; Cleanexand.
  left.
  exists x; exists u'; exists x0; exists ns'; repeat (split; auto).
  omega. rewrite H0 in H6; auto.
  right. split; auto. rewrite H0 in H8; auto.
  (* both are junction point *)
  left.
  exists u; exists u'; exists ns; exists ns'; repeat (split;auto).
  rewrite H0 in H6; auto.
Qed.

Inductive path (m:Method) (i:istate) : istate -> Type :=
  | path_base : forall j, exec m i (inl j) -> path m i j
  | path_step : forall j k, path m k j -> exec m i (inl k) -> path m i j.

Inductive path_prop (m:Method) (i j:istate) (p:path m i j) : Prop := path_prop_cons : path_prop m i j p.

Inductive path_in_region (m:Method) (cdr: CDR (step m)) (s:PC) (i j:istate) : (path m i j) -> Prop :=
  | path_in_reg_base : forall (Hexec:exec m i (inl j)), region cdr s (pc i) ->
      path_in_region m cdr s i j (path_base m i j Hexec)
  | path_in_reg_ind : forall k (Hexec:exec m i (inl k)) (p:path m k j), region cdr s (pc i) ->
      path_in_region m cdr s k j p -> path_in_region m cdr s i j (path_step m i j k p Hexec).

Lemma evalsto_path : forall m sgn n s i res (H: P (SM m sgn)),
  region (cdr m (PM_P _ H)) s (pc i) ->
  evalsto m n i res ->
  (exists j p, junc (cdr m (PM_P _ H)) s (pc j) /\ path_prop m i j p /\
    path_in_region m (cdr m (PM_P _ H)) s i j p /\
    (exists n', evalsto m n' j res /\ n' < n))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) s jun).
Proof.
  intros m sgn n. pattern n. apply lt_wf_ind.
  clear n. intros n IH.
  intros s i res H Hreg Hevalsto.
  inversion Hevalsto.
  (* the case where i is immediately a return point *)
  apply exec_step_none with (1:=PM_P _ H) in H0.
  right. intros. apply soap3 with (j:=pc i); auto.
  (* inductive case *)
  elim soap2 with PC (step m) (cdr m (PM_P _ H)) s (pc i) (pc s2); intros; auto.
  (* path stays in region *)
  elim IH with (H:=H) (s:=s) (m0:=n0) (i:=s2) (res:=res); simpl; intros; auto.
  Cleanexand.
  left.
  exists x. exists (path_step m i x s2 x0 H0).
  repeat (split; auto).
  constructor 2; auto.
  exists x1. split; auto.
  omega.

  (* path is the junction *)
  left. exists s2. exists (path_base m i s2 H0).
  repeat (split; auto).
  constructor 1; auto.

  (* final case *)
  exists n0; repeat (split; auto).
  apply exec_step_some with (1:=PM_P _ H); auto.
Qed.

Variable changed : forall (m:Method) (i j:istate), path m i j -> Reg -> Prop.
Variable changed_high : forall m sgn s i j r (H:P (SM m sgn)) (Hpath: path m i j),
  (forall k:PC, region (cdr m (PM_P _ H)) s k -> ~ L.leql (se m sgn k) observable) ->
  path_in_region m (cdr m (PM_P _ H)) s i j Hpath ->
  region (cdr m (PM_P _ H)) s (pc i) ->
  junc (cdr m (PM_P _ H)) s (pc j) ->
  changed m i j Hpath r ->
    high_reg (RT m sgn (pc j)) r.
Variable not_changed_same : forall m sgn i j (Hpath: path m i j) r (H: P (SM m sgn)) ,
  ~changed m i j Hpath r ->
  (indist_reg_val i j r) /\ (high_reg (RT m sgn (pc i)) r ->
    high_reg (RT m sgn (pc j)) r).
Variable high_reg_dec : forall rt r, high_reg rt r \/ ~high_reg rt r.
Variable changed_dec : forall m i j r (p:path m i j),
  changed m i j (p) r \/ ~changed m i j (p) r.

Lemma junction_indist : forall m sgn ns ns' s s' u u' res res' i (H: P (SM m sgn)),
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s')) s s' ->
  exec m s (inl u) -> exec m s' (inl u') ->
  region (cdr m (PM_P _ H)) i (pc u) ->
  region (cdr m (PM_P _ H)) i (pc u') ->
  high_region m (PM_P _ H) sgn i ->
  evalsto m ns u res ->
  evalsto m ns' u' res' ->
  indist sgn (RT m sgn (pc u)) (RT m sgn (pc u')) u u' ->
  (exists v, exists v', exists ps, exists ps',
    evalsto m ps v res /\ ps <= ns /\
    evalsto m ps' v' res' /\ ps' <= ns' /\
    junc (cdr m (PM_P _ H)) i (pc v) /\
    junc (cdr m (PM_P _ H)) i (pc v') /\
    indist sgn (RT m sgn (pc v)) (RT m sgn (pc v')) v v')
  \/ (high_result sgn res /\ high_result sgn res').
Proof.
  intros.
  elim evalsto_path with (1:=H3) (2:=H6);
  elim evalsto_path with (1:=H4) (2:=H7); intros.
  left. destruct H10 as [v H10]; destruct H10 as [path H10]; destruct H9 as [v' H9]; destruct H9 as [path' H9].
    exists v; exists v'.
    Cleanexand.
    exists x; exists x0.
    repeat (split; auto).
    omega. omega.
    apply indist_from_reg.
    intros.
    elim changed_dec with (m:=m) (i:=u) (j:=v) (p:=path) (r:=r);
    elim changed_dec with (m:=m) (i:=u') (j:=v') (p:=path') (r:=r); intros; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H19;
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H20; auto.
    constructor; auto.
    constructor 1; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H20; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H20; auto.
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v) (j2:=pc v'); auto.
    constructor 1; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H19; auto.
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v') (j2:=pc v); auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H19; auto.
    apply not_changed_same with (m:=m) (sgn:=sgn) (i:=u') (j:=v') in H19; auto.
    apply not_changed_same with (m:=m) (sgn:=sgn) (i:=u) (j:=v) in H20; auto.
    inversion H19; inversion H20.
    destruct high_reg_dec with (rt:=RT m sgn (pc u)) (r:=r);
    destruct high_reg_dec with (rt:=RT m sgn (pc u')) (r:=r).
    specialize H22 with (1:=H26); specialize H24 with (1:=H25).
    constructor 1; auto.
    specialize H24 with (1:=H25).
    constructor 1; auto.
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v) (j2:=pc v'); auto.
    specialize H22 with (1:=H26).
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v') (j2:=pc v); auto.
    constructor 1; auto.
    constructor 2; auto.
    apply indist_reg_val_trans with (s2:=u).
    apply indist_reg_val_sym; auto.
    apply indist_reg_val_trans with (s2:=u'); auto.
    apply indist_reg_from_indist with (r:=r) in H8.
    Cleanexand.
    apply H29; auto.
  (* one of them doesn't have a junction point *)
  Cleanexand. specialize H9 with (pc x). contradiction.
  Cleanexand. specialize H10 with (pc x). contradiction.
  (* both are junction points *)
  right.
  split.
  apply typable_evalsto with (1:=T m sgn H) (se:=se) (RT:=RT) in H6.
  apply final_bighighstep_aux with (m:=m) (sgn:=sgn) (H:=H)
    (s:=u) (i:=i) (p:=ns); auto.
  (* the other high result *)
  apply typable_evalsto with (1:=T m sgn H) (se:=se) (RT:=RT) in H7.
  apply final_bighighstep_aux with (m:=m) (sgn:=sgn) (H:=H)
    (s:=u') (i:=i) (p:=ns'); auto.
Qed.

Lemma junction_indist_2 : forall m sgn ns ns' s s' u u' res res' i (H: P (SM m sgn)),
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s')) s s' ->
  exec m s (inl u) -> exec m s' (inl u') ->
  region (cdr m (PM_P _ H)) i (pc u) ->
  junc (cdr m (PM_P _ H)) i (pc u') ->
  high_region m (PM_P _ H) sgn i ->
  evalsto m ns u res ->
  evalsto m ns' u' res' ->
  indist sgn (RT m sgn (pc u)) (RT m sgn (pc u')) u u' ->
  (exists v, exists ps,
    evalsto m ps v res /\ ps <= ns /\
    junc (cdr m (PM_P _ H)) i (pc v) /\
    indist sgn (RT m sgn (pc v)) (RT m sgn (pc u')) v u').
Proof.
  intros.
  elim evalsto_path with (1:=H3) (2:=H6); intros.
  destruct H9 as [v [Hpath H9]].
  exists v.
  Cleanexand.
  exists x. repeat (split; auto).
  omega.
  apply indist_from_reg.
  intro r.
  elim changed_dec with (m:=m) (i:=u) (j:=v) (r:=r) (p:=Hpath); intros; auto.
  constructor 1.
  apply changed_high with (m:=m) (sgn:=sgn) (H:=H) (s:=i) in H14; auto.
  apply changed_high with (m:=m) (sgn:=sgn) (H:=H) (s:=i) in H14; auto.
  elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v) (j2:=pc u'); auto.
  (* dealing with the value when it is not changed *)
  apply not_changed_same with (m:=m) (sgn:=sgn) (i:=u) (j:=v) in H14; auto.
  Cleanexand.
  destruct high_reg_dec with (rt:=RT m sgn (pc u)) (r:=r);
  destruct high_reg_dec with (rt:=RT m sgn (pc u')) (r:=r).
  specialize H15 with (1:=H16).
  constructor 1; auto.
  constructor 1; auto.
  elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
    (j1:=pc v) (j2:=pc u'); auto.
  constructor 1; auto.
  elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
    (j1:=pc u') (j2:=pc v); auto.
  constructor 2; auto.
  apply indist_reg_val_sym; auto.
  apply indist_reg_val_trans with (s2:=u).
  apply indist_reg_from_indist with (r:=r) in H8.
  Cleanexand. apply indist_reg_val_sym. apply H18; auto.
  apply H14; auto.
  specialize H9 with (pc u'); contradiction.
Qed.

Definition tni :=
  forall m sgn p p' s s' r r' (H:P (SM m sgn)),
  pc s = pc s' ->
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s)) s s' ->
  tevalsto m (PM_P _ H) sgn (se m sgn) (RT m sgn) p s r ->
  tevalsto m (PM_P _ H) sgn (se m sgn) (RT m sgn) p' s' r' ->
  rindist sgn r r'.

Lemma tni_ni : tni -> ni.
Proof.
  unfold tni, ni; intros.
  destruct (T _ _ H0) as [T1 [T2 T3]].
  apply H with m p p' s s' H0; auto.
  rewrite T1; auto.
  apply typable_evalsto; auto.
  apply typable_evalsto; auto.
Qed.

Variable branch_indist : forall m sgn s s' u u' (H:P (SM m sgn)),
  pc s = pc s' ->
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s')) s s' ->
  exec m s (inl u) ->
  exec m s' (inl u') ->
  pc u <> pc u' ->
  indist sgn (RT m sgn (pc u)) (RT m sgn (pc u')) u u'.

Lemma ni_ind : tni.
Proof.
  intros m sgn.
  intros ns ns'. pattern ns, ns'. apply my_double_ind.
  clear ns ns'; intros ns ns' Hind.
  intros s s' r r' H Hpc Hindist Htevalsto Htevalsto'.
  set (HM:=PM_P _ H).
  inversion Htevalsto; inversion Htevalsto'.
  (* *)
  inversion H0; inversion H4.
  subst.
  rewrite <- Hpc in H15.
  eapply indist2_return with (1:=Hindist) (5:=H11) (6:=H15); auto.

  (* *)
  subst.
  apply tevalsto_diff_high_result with (s:=s) (res:=r) in Htevalsto'; auto.
  inversion Htevalsto'; apply high_result_indist; auto.
  destruct n; auto. inversion H5. omega.
  (* *)
  subst.
  apply tevalsto_diff_high_result with (s:=s') (res:=r') in Htevalsto; auto.
  inversion Htevalsto; apply high_result_indist; auto.
  destruct n; auto. inversion H1. omega.
  (* *)
  inversion H0; inversion H5; subst.
  elim eq_excluded_middle with PC (pc s2) (pc s3); intros.
  (* pc s = pc s' *)
  rewrite <- Hpc in H19.
  assert (H11':=H11).
  apply indist2_intra with (1:=Hindist) (2:=Hpc) (4:=H16) (5:=H14) (6:=H19) in H11;
    try (auto); try (rewrite <- Hpc; auto; fail).
  apply Hind with (q:=n0) (p:=n) (s:=s2) (s':=s3) (r:=r) (r':=r') (H:=H); auto; try omega.
  apply sub_simple with (rt:=rt'0).
  apply indist_sym. apply sub_simple with (rt:=rt'); auto.
  rewrite H2; auto.

  (* pc s <> pc s' *)
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc s2) (pc s3); try (rewrite Hpc; auto; fail); auto; intros.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc s3) (pc s2); try (rewrite Hpc; auto; fail); auto; intros.
  (* both are still in the region *)
  elim junction_indist with (m:=m) (sgn:=sgn) (ns:=n) (ns':=n0) (s:=s) (s':=s')
    (u:=s2) (u':=s3) (res:=r) (res':=r') (i:=pc s) (H:=H); auto.
  intros. Cleanexand.
  assert (pc x = pc x0) as Hpcx. apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s); auto.
  apply Hind with (p:=x1) (q:=x2) (s:=x) (s':=x0) (r:=r) (r':=r') (H:=H); auto; try omega.
  rewrite <- Hpcx in H18; auto.
  apply typable_evalsto; auto.
  apply typable_evalsto; auto.
  intros. inversion H7; apply high_result_indist; auto.
  rewrite <- Hpc; auto.
  assert ((forall j:PC, (region (cdr m (PM_P _ H)) (pc s) j) -> ~ leql (se m sgn j) observable)).
    intros. apply soap2_basic_intra with (m:=m) (sgn:=sgn) (rt:=RT m sgn (pc s))
      (ut:=rt') (ut':=rt'0) (s:=s) (s':=s') (u:=s2) (u':=s3) (h:=H); auto.
    rewrite Hpc; auto.
    unfold high_region. auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply branch_indist with (s:=s) (s':=s'); auto. rewrite <- Hpc; auto.
  (* one region one junction *)
  elim junction_indist_2 with (m:=m) (sgn:=sgn) (ns:=n0) (ns':=n) (s:=s') (s':=s)
    (u:=s3) (u':=s2) (res:=r') (res':=r) (i:=pc s) (H:=H); auto.
  intros. Cleanexand.
  assert (pc x = pc s2) as Hpcx. apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s); auto.
  apply Hind with (p:=n) (q:=x0) (s:=s2) (s':=x) (r:=r) (r':=r') (H:=H); auto; try omega.
  apply indist_sym; rewrite Hpcx in H10; auto.
  apply typable_evalsto; auto.
  apply indist_sym; rewrite <- Hpc; auto.
  assert ((forall j:PC, (region (cdr m (PM_P _ H)) (pc s) j) -> ~ leql (se m sgn j) observable)).
    intros. apply soap2_basic_intra with (m:=m) (sgn:=sgn) (rt:=RT m sgn (pc s))
      (ut:=rt') (ut':=rt'0) (s:=s) (s':=s') (u:=s2) (u':=s3) (h:=H); auto.
    rewrite Hpc; auto.
    unfold high_region; auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply branch_indist with (s:=s') (s':=s); auto.
  apply indist_sym. rewrite <- Hpc; auto.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc s3) (pc s2); try (rewrite H0; auto; fail); auto; intros.
  (* one junction one region *)
  elim junction_indist_2 with (m:=m) (sgn:=sgn) (ns:=n) (ns':=n0) (s:=s) (s':=s')
    (u:=s2) (u':=s3) (res:=r) (res':=r') (i:=pc s) (H:=H); auto.
  intros. Cleanexand.
  assert (pc x = pc s3) as Hpcx. apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s); auto.
  apply Hind with (p:=x0) (q:=n0) (s:=x) (s':=s3) (r:=r) (r':=r') (H:=H); auto; try omega.
  rewrite <- Hpcx in H10; auto.
  apply typable_evalsto; auto.
  rewrite <- Hpc; auto.
  assert ((forall j:PC, (region (cdr m (PM_P _ H)) (pc s) j) -> ~ leql (se m sgn j) observable)).
    intros. apply soap2_basic_intra with (m:=m) (sgn:=sgn) (rt:=RT m sgn (pc s))
      (ut:=rt') (ut':=rt'0) (s:=s) (s':=s') (u:=s2) (u':=s3) (h:=H); auto.
    rewrite Hpc; auto.
    unfold high_region; auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply branch_indist with (s:=s) (s':=s'); auto.
  rewrite <- Hpc; auto.
  (* both are junctions *)
  apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s) (j1:=pc s2) in H3; auto.
  contradiction.
  apply exec_step_some with (1:=PM_P _ H) in H16. rewrite Hpc; auto.
Qed.

Theorem safe_ni : forall m sgn p p' s s' r r',
  P (SM m sgn) ->
  init_pc m (pc s) ->
  init_pc m (pc s') ->
  indist sgn (rt0 m sgn) (rt0 m sgn) s s' ->
  pc s = pc s' ->
  evalsto m p s r ->
  evalsto m p' s' r' ->
    rindist sgn r r'.
Proof.
  intros.
  apply (@ni_ind m sgn p p' s s' r r' H); auto.
  destruct (T _ _ H) as [T1 _]. rewrite T1; auto.
  apply typable_evalsto; auto.
  apply typable_evalsto; auto.
Qed.

End TypableProg.
End A.


Require Import Terms.
Require Import LNaVSyntax.
Require Import LThrowDBigStep. (* reusing helpers *)

(** * Continuations and partial configurations *)

Inductive Frame : Type :=
| RLet : Var -> Tm -> Frame
| RRet : Env -> Frame
| RBrk : Lab -> Lab -> Frame (* final label + original pc *)
| RCatch : Var -> Tm -> Frame.

Definition Cont := list Frame.

Definition PCfg := prod (prod Lab Env) Cont.

Inductive RCfg : Type :=
| CR : Tm -> RCfg    (* term to be reduced *)
| CA : Atom -> RCfg  (* return atom *)
| CT : Excp -> RCfg. (* thrown exception *)

Definition Cfg := prod PCfg RCfg.

Notation "v @ L" := (v,L) (at level 5).

Notation "<< pc , r , k , X >>" := (((pc, r), k), X) (at level 5).

Definition result_to_rcfg r :=
  match r with
  | Suc a => CA a
  | Throw e => CT e
  end.

(** * Small-step semantics defined as a total(!) function *)

Definition step (c : Cfg) : Cfg :=
  match c with
  (* s_var *)
  | << pc, rho, k, CR (TVar x) >> =>
    match get rho x with
    | Some a =>
      << pc, rho, k, CA a >>
    | None =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_const *)
  | << pc, rho, k, CR (TConst c) >> =>
    << pc, rho, k, CA (V (VConst c))@bot>>
  (* s_let_start *)
  | << pc, rho, k, CR (TLet x t1 t2) >> =>
    << pc, rho, RLet x t2 :: k, CR t1 >>
  (* s_let_bind *)
  | << pc, rho, RLet x t :: k, CA a >> =>
    << pc, (x,a) :: rho, RRet rho :: k, CR t >>
  (* s_let_unwind *)
  | << pc, rho, RLet x t :: k, CT e >> =>
    << pc, rho, k, CT e >>
  (* s_abs *)
  | << pc, rho, k, CR (TAbs x t) >> =>
    << pc, rho, k, CA (V (VClos rho x t))@bot >>
  (* s_app *)
  | << pc, rho, k, CR (TApp x1 x2) >> =>
    match get rho x1, get rho x2 with
    | Some ((V (VClos rho' x t))@L), Some a =>
      << pc\_/L, (x,a) :: rho', RRet rho :: k, CR t >>
    | Some (b,L), Some a =>
      << pc\_/L, rho, k, CT (propagate_d b) >>
    | _, _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_return *)
  | << pc, rho, RRet rho' :: k, CA a >> =>
    << pc, rho', k, CA a >>
  (* s_return_unwind *)
  | << pc, rho, RRet rho' :: k, CT e >> =>
    << pc, rho', k, CT e >>
  (* s_inx *)
  | << pc, rho, k, CR (TInx d x) >> =>
    match get rho x with
    | Some a =>
      << pc, rho, k, CA (V (VInx d a))@bot >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_match *)
  | << pc, rho, k, CR (TMatch x x' t1 t2) >> =>
    match get rho x with
    | Some (V (VInx DLeft a), l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t1 >>
    | Some (V (VInx DRight a), l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t2 >>
    | Some (V _, l) =>
      << pc\_/l, rho, k, CT eType >>
    | Some (D e, l) =>
      << pc\_/l, rho, k, CT e >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_tag *)
  | << pc, rho, k, CR (TTag x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc\_/l, rho, k, result_to_rcfg (tag_res b) >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bop *)
  | << pc, rho, k, CR (TBOp bo x' x'') >> =>
    match get rho x', get rho x'' with
    | Some (b', l0'), Some (b'', l0'') =>
      << pc\_/l0' \_/ l0'', rho, k, result_to_rcfg (bop_res bo b' b'') >>
    | _, _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bracket_start *)
  | << pc, rho, k, CR (TBracket x t) >> =>
    match get rho x with
    | Some ((V (VConst (CLab L)))@L') =>
      << pc\_/L', rho, RBrk L (pc\_/L') :: k, CR t >>
    | Some (b,L') =>
      << pc\_/L', rho, k, CT (propagate_d b) >>
    | None =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bracket_end *)
  | << pc, rho, RBrk L' pc' :: k, CA b@L >> =>
    << pc', rho, k, CA (bracket_box (Suc b@L) pc (L' \_/ pc'))@L' >>
  | << pc, rho, RBrk L' pc' :: k, CT e >> =>
    << pc', rho, k, CA (bracket_box (Throw e) pc (L' \_/ pc'))@L' >>
  (* s_label_of *)
  | << pc, rho, k, CR (TLabelOf x) >> =>
    match get rho x with
    | Some (_,l) =>
      << pc, rho, k, CA (V (VConst (CLab l)))@bot >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_get_pc *)
  | << pc, rho, k, CR TGetPc >> =>
    << pc, rho, k, CA (V (VConst (CLab pc)))@bot >>
  (* s_throw *)
  | << pc, rho, k, CR (TThrow x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc\_/l, rho, k, CT (throw_excp b) >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_catch *)
  | << pc, rho, k, CR (TCatch t x t') >> =>
    << pc, rho, RCatch x t' :: k, CR t >>
  (* s_catch_no_excp *)
  | << pc, rho, RCatch x t' :: k, CA a >> =>
    << pc, rho, k, CA a >>
  (* s_catch_excp *)
  | << pc, rho, RCatch x t' :: k, CT e >> =>
    << pc, (x,((V (vExcp e))@bot)) :: rho, RRet rho :: k, CR t' >>
  (* s_to_sum *)
  | << pc, rho, k, CR (TToSum x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc, rho, k, CA (to_sum_box b)@l >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* stack underflow (you're already done?) *)
  | << pc, rho, nil, CA _ >> =>
      << pc, rho, nil, CT eStack >>
  | << pc, rho, nil, CT e >> =>
      << pc, rho, nil, CT e >>
  (* terms not from this language *)
  (* s_mk_nav *)
  | << pc, rho, k, CR (TMkNav _) >> =>
      << pc, rho, k, CT eLanguage >>
  end.

Definition final (c : Cfg) : bool :=
  match c with
  | << pc, rho, nil, CA _ >> => true
  | << pc, rho, nil, CT _ >> => true
  | _ => false
  end.

Fixpoint nstep (n : nat) (cm : Cfg*nat) : Cfg*nat :=
  match n with
  | S n' =>
    match cm with
    | (c,m) => if final c then (c,m) else nstep n' (step c, m+1)
    end
  | O => cm
  end.

Definition mstep (n : nat) (t : Tm) : Cfg*nat :=
  nstep n (<< bot, nil, nil, CR t >>, 0).

Definition sstep (n : nat) (t : Tm) : option ((Result*Lab)*nat) :=
  match mstep n t with
  | (<< pc, rho, nil, CA a >>, m) => Some ((Suc a,pc),m)
  | (<< pc, rho, nil, CT e >>, m) => Some ((Throw e,pc),m)
  | _ => None (* looping or need more steps *)
  end.