Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Fiat.Parsers.Reflective.Syntax.
Require Import Fiat.Parsers.Reflective.Syntactify.
Require Import Fiat.Common.NatFacts.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.List.Operations.
Set Implicit Arguments.

Local Open Scope list_scope.

Definition interp_SimpleTypeCode_step
           (interp_SimpleTypeCode : SimpleTypeCode -> Type)
           (t : SimpleTypeCode)
  : Type
  := match t with
     | cnat => nat
     | cbool => bool
     | cascii => Ascii.ascii
     | cstring => string
     | critem_ascii => Reflective.ritem Ascii.ascii
     | crchar_expr_ascii => Reflective.RCharExpr Ascii.ascii
     | clist T => list (interp_SimpleTypeCode T)
     | cprod A B => interp_SimpleTypeCode A * interp_SimpleTypeCode B
     end%type.

Fixpoint interp_SimpleTypeCode (t : SimpleTypeCode)
  := interp_SimpleTypeCode_step (@interp_SimpleTypeCode) t.

Fixpoint interp_TypeCode (t : TypeCode) : Type
  := match t with
     | csimple T => interp_SimpleTypeCode T
     | carrow A B => interp_TypeCode A -> interp_TypeCode B
     end%type.

Fixpoint apply_args_for {T}
         (f : interp_TypeCode T)
         (argsv : args_for interp_TypeCode T)
  : interp_TypeCode (range_of T)
  := match argsv in args_for _ T return interp_TypeCode T -> interp_TypeCode (range_of T) with
     | an_arg A B arg args => fun f => @apply_args_for _ (f arg) args
     | noargs T => fun f => f
     end f.

Section step.
  Context (interp_RLiteralTerm : forall {T}, RLiteralTerm T -> interp_TypeCode T).
  Context (interp_Term_gen : forall {T} (t : Term interp_TypeCode T), interp_TypeCode T).

  Definition interp_Term_gen_step {T} (t : Term interp_TypeCode T) : interp_TypeCode T
    := match t in (Term _ T') return interp_TypeCode T' with
       | RVar T v => v
       | RLambda A B f => fun x => @interp_Term_gen _ (f x)
       | RApp A B f x => @interp_Term_gen _ f (@interp_Term_gen _ x)
       | RLiteralApp c t args => apply_args_for (interp_RLiteralTerm t)
                                                (map_args_for (@interp_Term_gen) args)
       end.
End step.

Fixpoint interp_Term_gen (interp_RLiteralTerm : forall T, RLiteralTerm T -> interp_TypeCode T)
         {T} (t : Term interp_TypeCode T) : interp_TypeCode T
  := @interp_Term_gen_step interp_RLiteralTerm (@interp_Term_gen interp_RLiteralTerm) T t.

Definition interp_RLiteralTerm {T} (t : RLiteralTerm T) : interp_TypeCode T
  := match t with
     | RLC t'
       => match t' in (RLiteralConstructor T') return interp_TypeCode T' with
          | Rpair _ _ => @pair _ _
          | RS => S
          | RO => O
          | Rnil _ => @nil _
          | Rcons _ => @cons _
          | Rbool v
          | Rrchar_expr_ascii v
          | Rstring v
          | Rritem_ascii v
            => v
          end
     | RLNC t'
       => match t' in (RLiteralNonConstructor T') return interp_TypeCode T' with
          | Rfst _ _ => @fst _ _
          | Rsnd _ _ => @snd _ _
          | Rnth' A => nth'
          | Rnth A => @List.nth _
          | Rmap A B => @List.map _ _
          | Rfold_left A B => @List.fold_left _ _
          | Rorb => orb
          | Randb => andb
          | Randbr => andbr
          | Rorbr => orbr
          | Rminusr => minusr
          | Rpred => pred
          | Rplus => plus
          | Rleb => Compare_dec.leb
          | Rbeq_nat => EqNat.beq_nat
          | Rstring_beq => Equality.string_beq
          | Rlength _ => @List.length _
          | Rbool_rect_nodep _ => @bool_rect_nodep _
          | Rlist_rect_nodep _ _ => @list_rect_nodep _ _
          | Rlist_caset_nodep _ _ => @list_caset_nodep _ _
          | Rritem_rect_nodep _ => @Reflective.ritem_rect_nodep _ _
          | Rcombine _ _ => @List.combine _ _
          | Rfirst_index_default _ => @first_index_default _
          | Rrev _ => @List.rev _
          | Rup_to => up_to
          | Rmax => max
          | Rinterp_RCharExpr_ascii => Reflective.interp_RCharExpr
          end
     end.

Definition interp_Term {T} (t : Term interp_TypeCode T) : interp_TypeCode T
  := interp_Term_gen (@interp_RLiteralTerm) t.

(* Section equality.
  Context {M : Type -> Type}.

  Definition args_for_values_code {T} (a0 : @args_for_values M T)
    : @args_for_values M T -> Prop
    := match a0 in @args_for_values _ T return @args_for_values _ T -> Prop with
       | an_argv A B a0 as0
         => fun a1
            => a0 = ahdv a1 /\ as0 = atlv a1
       | noargsv _
         => fun a1 => noargsv = a1
       end.

  Global Instance args_for_values_code_refl {T} : RelationClasses.Reflexive (@args_for_values_code T).
  Proof.
    intro a; destruct a; simpl; repeat split.
  Qed.

  Lemma args_for_values_encode {T} (a0 a1 : @args_for_values M T)
    : a0 = a1 -> args_for_values_code a0 a1.
  Proof.
    intro; subst; reflexivity.
  Qed.
End equality.
 *)

Ltac fold_interp_Term :=
  change (@interp_Term_gen (@interp_RLiteralTerm)) with (@interp_Term) in *;
  fold @interp_TypeCode in *.

Ltac simpl_interp_Term :=
  unfold interp_Term; simpl @interp_Term_gen;
  fold_interp_Term.

Ltac simpl_interp_Term_in_all :=
  unfold interp_Term in *; simpl @interp_Term_gen in *;
  fold_interp_Term.

Lemma interp_Term_syntactify_list {T : SimpleTypeCode}
      (ls : list (Term interp_TypeCode T))
: List.map interp_Term ls = interp_Term (Syntactify.syntactify_list ls).
Proof.
  unfold interp_Term; induction ls; simpl; [ reflexivity | ].
  rewrite <- IHls; reflexivity.
Qed.

Lemma interp_Term_syntactify_nat
      (v : nat)
: v = interp_Term (Syntactify.syntactify_nat _ v).
Proof.
  unfold interp_Term.
  induction v as [|v IHv]; [ reflexivity | simpl ].
  rewrite <- IHv; reflexivity.
Qed.

Lemma interp_Term_syntactify_rproductions
      ls
: ls = interp_Term (Syntactify.syntactify_rproductions _ ls).
Proof.
  repeat match goal with
         | [ |- ?x = ?x ] => reflexivity
         | _ => progress unfold Syntactify.syntactify_rproductions, syntactify_prod, syntactify_string
         | _ => progress simpl
         | _ => progress simpl_interp_Term
         | _ => rewrite <- interp_Term_syntactify_list, List.map_map
         | [ |- ?x = List.map _ ?x ]
           => etransitivity; [ symmetry; apply List.map_id | ]
         | [ |- List.map _ ?x = List.map _ ?x ]
           => apply List.map_ext; intro
         | [ |- _ = _ :> prod _ _ ]
           => apply injective_projections
         end.
Qed.


(** * System MALL for propositional multiplicative and additive linear logic

This file encodes the inference rules of the system MALL (two sided)
of propositional multiplicative additive linear logic.
 *)

Require Import LL.SL.FLL.Reasoning.
Require Import LL.SL.FLL.Specifications.Classical.OLCut.
Require Import LL.SL.FLL.Specifications.Classical.LK.Bipoles.
Set Implicit Arguments.

(** ** Well-formedness conditions *)

(** *** Constants *)
Lemma wellBipoleLKC : wellFormedC.
Proof with sauto.
  unfold wellFormedC;intros.
  destruct lab;destruct s.
 * exists BCFail.
    do 2 intro.
    apply FocusingClause in H...
   - inversion H3...
     solvePolarity.
   - inversion H3...
     solvePolarity.
 * exists BCAxiom.
    do 3 intro.
    apply FocusingClause in H...
   - left. exists x0... simpl. solveLL.
     intros.
      TFocus ((makeRRuleC TT )).
     inversion H1.
     FLLsplit [⌈ t_ccon TT ⌉] Delta1.
    simpl. solveLL.
   - right. split... simpl. solveLL.
     intros.
      TFocus ((makeRRuleC TT )).
     inversion H2.
     FLLsplit (@nil oo) Delta1.
    simpl. solveLL.
 * exists BCAxiom.
    do 3 intro.
    apply FocusingClause in H...
   - left. exists x0... simpl. solveLL.
     intros.
      TFocus ((makeLRuleC FF )).
     inversion H1.
     FLLsplit [⌊ t_ccon FF ⌋] Delta1.
    simpl. solveLL.
   - right. split... simpl. solveLL.
     intros.
      TFocus ((makeLRuleC FF )).
     inversion H2.
     FLLsplit (@nil oo) Delta1.
    simpl. solveLL.
 * exists BCFail.
    do 2 intro.
    apply FocusingClause in H...
   - inversion H3...
     solvePolarity.
   - inversion H3...
     solvePolarity.
Qed.

(** *** Unary connectives *)

Lemma wellBipoleLKU : wellFormedU.
Proof with sauto.
  unfold wellFormedU;intros.
  destruct lab.
Qed.

(** *** Binary connectives *)
Lemma wellBipoleLKB : wellFormedB.
Proof with sauto.
  unfold wellFormedB;intros.
  destruct lab;destruct s.
  * exists  BOneP.
     do 3 intro. intros.
     apply FocusingClause in H...
     -  apply FocusingPlus in H4...
        + exists [⌊ Fo1 ⌋].
        exists x1, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        left.
       exists x0...
       simpl.
       FLLleft; solveLL.
       1-2: HProof.
       lia.
       intros.
       TFocus ((makeLRuleB AND Fo1 Go1)).
      inversion H4.
      FLLsplit [⌊ t_bcon AND Fo1 Go1 ⌋ ] Delta1.
      simpl.
     FLLleft; solveLL.
     LLExact H1.
        + exists [⌊ Go1 ⌋].
        exists x1, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        left.
       exists x0...
       simpl.
       FLLright; solveLL.
       1-2: HProof.
       lia.
       intros.
       TFocus ((makeLRuleB AND Fo1 Go1)).
      inversion H4.
      FLLsplit [⌊ t_bcon AND Fo1 Go1 ⌋ ] Delta1.
      simpl.
     FLLright; solveLL.
     LLExact H1.
     -  apply FocusingPlus in H4...
        + exists [⌊ Fo1 ⌋].
        exists x0, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        right.
       split...
       simpl.
       FLLleft; solveLL.
       1-2: HProof.
       lia.
       intros.
       simpl.
     FLLleft; solveLL.
     LLExact H.
        + exists [⌊ Go1 ⌋].
        exists x0, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        right.
       split...
       simpl.
       FLLright; solveLL.
       1-2: HProof.
       lia.
       intros.
       simpl.
     FLLright; solveLL.
     LLExact H.
  * exists BTwoPA.
     do 3 intro. intros.
     - apply FocusingClause in H...
        + apply FocusingWith in H4...
           eexists x0,  [⌈ Fo1 ⌉ ], [⌈ Go1 ⌉ ].
           exists x1, 4.
           split...
           1-2: OLSolve.
           1-2: inversion H0...
           1-2: inversion H...
           left.
          split...
          simpl... solveLL.
           1-2:HProof.
          LLExact H2.
          LLExact H5.
          lia.
          intros.
          TFocus ((makeRRuleB AND Fo1 Go1)).
          inversion H6.
          FLLsplit [⌈ t_bcon AND Fo1 Go1 ⌉] Delta12.
         simpl... solveLL.
         LLExact H1.
         LLExact H4.
        + apply FocusingWith in H4...
           eexists Delta,  [⌈ Fo1 ⌉ ], [⌈ Go1 ⌉ ].
           exists x0, 4.
           split...
           1-2: OLSolve.
           1-2: inversion H0...
           1-2: inversion H...
           right.
          split...
          simpl... solveLL.
           1-2:HProof.
          LLExact H2.
          LLExact H5.
          lia.
          intros.
         simpl... solveLL.
         LLExact H.
         LLExact H1.
  * exists BTwoPA.
     do 3 intro. intros.
     - apply FocusingClause in H...
        + apply FocusingWith in H4...
           eexists x0,  [⌊ Fo1 ⌋], [⌊ Go1 ⌋ ].
           exists x1, 4.
           split...
           1-2: OLSolve.
           1-2: inversion H0...
           1-2: inversion H...
           left.
          split...
          simpl... solveLL.
           1-2:HProof.
          LLExact H2.
          LLExact H5.
          lia.
          intros.
          TFocus ((makeLRuleB OR Fo1 Go1)).
          inversion H6.
          FLLsplit [⌊ t_bcon OR Fo1 Go1 ⌋ ] Delta12.
         simpl... solveLL.
         LLExact H1.
         LLExact H4.
        + apply FocusingWith in H4...
           eexists Delta, [⌊ Fo1 ⌋], [⌊ Go1 ⌋ ].
           exists x0, 4.
           split...
           1-2: OLSolve.
           1-2: inversion H0...
           1-2: inversion H...
           right.
          split...
          simpl... solveLL.
           1-2:HProof.
          LLExact H2.
          LLExact H5.
          lia.
          intros.
         simpl... solveLL.
         LLExact H.
         LLExact H1.
  * exists  BOneP.
     do 3 intro. intros.
     apply FocusingClause in H...
     -  apply FocusingPlus in H4...
        + exists [⌈ Fo1 ⌉ ].
        exists x1, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        left.
       exists x0...
       simpl.
       FLLleft; solveLL.
       1-2: HProof.
       lia.
       intros.
       TFocus ((makeRRuleB OR Fo1 Go1)).
      inversion H4.
      FLLsplit [⌈ t_bcon OR Fo1 Go1 ⌉ ] Delta1.
      simpl.
     FLLleft; solveLL.
     LLExact H1.
        + exists [⌈ Go1 ⌉ ].
        exists x1, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        left.
       exists x0...
       simpl.
       FLLright; solveLL.
       1-2: HProof.
       lia.
       intros.
       TFocus ((makeRRuleB OR Fo1 Go1)).
      inversion H4.
      FLLsplit [⌈ t_bcon OR Fo1 Go1 ⌉] Delta1.
      simpl.
     FLLright; solveLL.
     LLExact H1.
     -  apply FocusingPlus in H4...
        + exists [⌈ Fo1 ⌉ ].
        exists x0, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        right.
       split...
       simpl.
       FLLleft; solveLL.
       1-2: HProof.
       lia.
       intros.
       simpl.
     FLLleft; solveLL.
     LLExact H.
        + exists [⌈ Go1 ⌉ ].
        exists x0, 4.
        split...
        OLSolve.
        inversion H0...
        inversion H...
        right.
       split...
       simpl.
       FLLright; solveLL.
       1-2: HProof.
       lia.
       intros.
       simpl.
     FLLright; solveLL.
     LLExact H.
  * exists BTwoPM.
     do 3 intro. intros.
     - apply FocusingClause in H...
        + apply FocusingTensor in H4...
           eexists x2, x3, [⌈ Fo1 ⌉ ], [⌊ Go1 ⌋].
           exists x1, 4.
           split...
           1-2: OLSolve.
           1-2: inversion H0...
           1-2: inversion H...
           left.
          split...
          simpl...
          FLLsplit x2 x3.
          1-2: solveLL. 1-2:HProof.
          LLExact H1.
          LLExact H6.
          lia.
          intros.
          TFocus ((makeLRuleB IMP Fo1 Go1)).
          inversion H7.
          FLLsplit [⌊ t_bcon IMP Fo1 Go1 ⌋] ( Delta1 ++ Delta2).
         simpl...
         FLLsplit Delta1 Delta2.
         1-2: solveLL.
         LLExact H4.
         LLExact H5.
        + apply FocusingTensor in H4...
           eexists x1, x2, [⌈ Fo1 ⌉ ], [⌊ Go1 ⌋].
           exists x0, 4.
           split...
           1-2: OLSolve.
           1-2: inversion H0...
           1-2: inversion H...
           right.
          split...
          simpl...
          FLLsplit x1 x2.
          1-2: solveLL. 1-2:HProof.
          LLExact H1.
          LLExact H6.
          lia.
          intros.
          FLLsplit Delta1 Delta2.
         1-2: solveLL.
         LLExact H.
         LLExact H4.
  * exists  BOneP.
     do 3 intro. intros.
     apply FocusingClause in H...
     -  apply FocusingPar in H4...
        exists [⌈ Go1 ⌉;⌊ Fo1 ⌋ ].
        exists x1, 5.
        split...
        OLSolve.
        1-2: inversion H0...
        1-2: inversion H...
        left.
       exists x0...
       simpl. solveLL.
       1-2: HProof.
       lia.
      intros.
      TFocus ((makeRRuleB IMP Fo1 Go1)).
     inversion H4.
     FLLsplit [⌈ t_bcon IMP Fo1 Go1 ⌉] Delta1.
    simpl. solveLL.
    LLExact H2.
  -
    apply FocusingPar in H4...
    exists [⌈ Go1 ⌉;⌊ Fo1 ⌋].
    exists x0, 5.
    split...
    OLSolve.
    1-2: inversion H0...
    1-2: inversion H...
    right.
    split...
    simpl. solveLL.
    1-2: HProof.
    lia.
    intros.
    simpl. solveLL.
    LLExact H.
Qed.

 Theorem FocusingForallUP :
    forall n th (y: expr con) FX D G, proper y ->
    flln th n G D (DW (∀{ fun x : expr con => atom (up (FX x))})) ->
      exists m , n =  S (S (S m))  /\ flln th m G (atom (up (FX y ))::D) (UP [ ]).
  Proof with sauto.
    intros.
    inversion H0...
    inversion H6...
    2:{ inversion H8. }
    specialize (H9 _ H).
    inversion H9...
    eexists n0.
    split;eauto.
  Qed.

   Theorem FocusingForallDW :
    forall n th (y: expr con) FX D G, proper y ->
    flln th n G D (DW (∀{ fun x : expr con => atom (down (FX x))})) ->
      exists m , n =  S (S (S m))  /\ uniform_oo (fun x  => atom (down (FX x))) /\ flln th m G (atom (down (FX y))::D) (UP [ ]).
  Proof with sauto.
    intros.
    inversion H0...
    inversion H6...
    2:{ inversion H8. }
    specialize (H9 _ H).
    inversion H9...
    eexists n0.
    split...
  Qed.

   Theorem FocusingExistsUP :
    forall n th FX D G,
    flln th n G D (DW (∃{ fun x : expr con => atom (up (FX x))})) ->
      exists m t, n =  S (S (S m))  /\ proper t /\ flln th m G (atom (up (FX t))::D) (UP [ ]).
  Proof with sauto.
    intros.
    inversion H...
    2:{ inversion H1. }
    inversion H6...
    inversion H8...
    eexists n0, t.
    split;eauto.
  Qed.

   Theorem FocusingExistsDW :
    forall n th FX D G,
    flln th n G D (DW (∃{ fun x : expr con => atom (down (FX x))})) ->
      exists m t, n =  S (S (S m))  /\ proper t /\ flln th m G (atom (down (FX t))::D) (UP [ ]).
  Proof with sauto.
    intros.
    inversion H...
    2:{ inversion H1. }
    inversion H6...
    inversion H8...
    eexists n0, t.
    split;eauto.
  Qed.

(** *** Quantifiers *)
Lemma wellBipoleLKQ : wellFormedQ.
Proof with sauto.
  unfold wellFormedQ. intros.
  destruct lab.
Qed.

Lemma wellTheoryLK : wellFormedTheory.
Proof.
  split.
  apply wellBipoleLKC.
  split.
  apply wellBipoleLKU.
  split; [apply wellBipoleLKB | apply wellBipoleLKQ].
Qed.

(** ** Cut-coherency properties *)

Require Import SL.FLL.InvPositivePhase.

(** *** Binary Connectives *)
Lemma CutCoherenceAND: CutCoherenceBin cutR1  (rulesB AND).
Proof with sauto;try solveLL.
  unfold CutCoherenceBin;intros.
  simpl...
   LLPerm ((⌈ F ⌉^ ⊕ ⌈ G ⌉^):: ([⌊ F ⌋^])).
  apply InvPlus...
   LLPerm ((⌈ F ⌉^ ⊕ ⌈ G ⌉^):: ([⌊ G ⌋^])).
  apply InvPlusComm...
Qed.

Lemma CutCoherenceOR: CutCoherenceBin cutR1  (rulesB OR).
Proof with sauto; try solveLL.
  unfold CutCoherenceBin;intros.
  simpl...
   LLPerm ((⌊ F ⌋^ ⊕ ⌊ G ⌋^):: ([⌈ F ⌉^])).
  apply InvPlus...
   LLPerm ((⌊ F ⌋^ ⊕ ⌊ G ⌋^):: ([⌈ G ⌉^])).
  apply InvPlusComm...
Qed.

Lemma CutCoherenceIMP: CutCoherenceBin cutR1 (rulesB IMP).
Proof with sauto; try solveLL.
  unfold CutCoherenceBin;intros.
  simpl...
  LLPerm ((⌊ F ⌋^ ⊗ ⌈ G ⌉^):: ([⌈ F ⌉^] ++ [⌊ G ⌋^])).
  apply InvTensor'...
Qed.

Lemma CutCoherenceLK : CutCoherence cutR1.
Proof.
  split;intros.
  destruct lab...
  split;intros; try destruct lab.
  simpl. auto. simpl. solveLL.
  split;intros; try destruct lab.
  simpl. auto. simpl. solveLL.
  split;intros; try destruct lab.
  split;intros; try destruct lab.
  apply CutCoherenceAND.
  apply CutCoherenceOR.
  apply CutCoherenceIMP.
Qed.

Check OLCutElimination wellTheoryLK CutCoherenceLK.


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 RoundsBaseWrappers (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.

(* function isRoundPre0(uint64 id) internal inline returns (bool) { return id == m_roundQty - 1; } *)
(* Definition RoundsBase_Ф_isRoundPre0 (Л_id: XInteger64) : LedgerT XBool :=
  return!! (  $ Л_id ?== (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt1 ). *)

Lemma RoundsBase_Ф_isRoundPre0_exec: forall (id: XInteger64) (l: Ledger),
 exec_state (↓ RoundsBase_Ф_isRoundPre0 id) l = l .
Proof.
    intros.
    destructLedger l.
    compute.
    repeat destructIf_solve2.
Qed.

Lemma RoundsBase_Ф_isRoundPre0_eval: forall (id: XInteger64) (l: Ledger),
let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
 eval_state (↓ RoundsBase_Ф_isRoundPre0 id) l = (id =? m_roundQty - 1).
Proof.
    intros.
    destructLedger l.
    compute.
    repeat destructIf_solve2.
Qed.

(* function isRound0(uint64 id)    internal inline returns (bool) { return id == m_roundQty - 2; } *)
(* Definition RoundsBase_Ф_isRound0 (Л_id: XInteger64) : LedgerT XBool :=
  return!! (   $ Л_id ?== (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt2 ). *)

Lemma RoundsBase_Ф_isRound0_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_isRound0 id) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_isRound0_eval: forall (id: XInteger64) (l: Ledger),
 let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  eval_state (↓ RoundsBase_Ф_isRound0 id) l = (id =? m_roundQty - 2).
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function isRound1(uint64 id)    internal inline returns (bool) { return id == m_roundQty - 3; } *)
(* Definition RoundsBase_Ф_isRound1 (Л_id: XInteger64) : LedgerT XBool :=
   return!! (  $ Л_id ?== (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt3 ). *)

Lemma RoundsBase_Ф_isRound1_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_isRound1 id) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_isRound1_eval: forall (id: XInteger64) (l: Ledger),
 let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  eval_state (↓ RoundsBase_Ф_isRound1 id) l = (id =? m_roundQty - 3).
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function isRound2(uint64 id)    internal inline returns (bool) { return id == m_roundQty - 4; } *)
(* Definition RoundsBase_Ф_isRound2 (Л_id: XInteger64) : LedgerT XBool :=
   return!! (  $ Л_id ?== (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt4 ). *)

Lemma RoundsBase_Ф_isRound2_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_isRound2 id) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_isRound2_eval: forall (id: XInteger64) (l: Ledger),
 let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  eval_state (↓ RoundsBase_Ф_isRound2 id) l = (id =? m_roundQty - 4).
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function roundAt(uint64 id) internal returns (Round) {
    return m_rounds.fetch(id).get();
} *)
(* Definition RoundsBase_Ф_roundAt (Л_id: XInteger64) : LedgerT RoundsBase_ι_Round :=
   return!! (   (D1! (↑11 D2! RoundsBase_ι_m_rounds) ->fetch $ Л_id) ->get ). *)

Lemma RoundsBase_Ф_roundAt_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_roundAt id) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_roundAt_eval: forall (id: XInteger64) (l: Ledger),
 let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
  eval_state (↓ RoundsBase_Ф_roundAt id) l = m_rounds [ id ].
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function getRoundPre0() internal inline returns (Round) { return roundAt(m_roundQty - 1); } *)
(* Definition RoundsBase_Ф_getRoundPre0  : LedgerT RoundsBase_ι_Round :=
  return!! (   RoundsBase_Ф_roundAt (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt1 !) ). *)
Lemma RoundsBase_Ф_getRoundPre0_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_getRoundPre0) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_getRoundPre0_eval: forall (id: XInteger64) (l: Ledger),
 let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
 let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  eval_state (↓ RoundsBase_Ф_getRoundPre0) l = m_rounds [ m_roundQty - 1  ].
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function getRound0()    internal inline returns (Round) { return roundAt(m_roundQty - 2); } *)
(* Definition RoundsBase_Ф_getRound0 : LedgerT RoundsBase_ι_Round :=
  return!! (   RoundsBase_Ф_roundAt (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt2 !) ). *)

Lemma RoundsBase_Ф_getRound0_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_getRound0) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

Lemma RoundsBase_Ф_getRound0_eval: forall (id: XInteger64) (l: Ledger),
 let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
 let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  eval_state (↓ RoundsBase_Ф_getRound0) l = m_rounds [ m_roundQty - 2 ].
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function getRound1()    internal inline returns (Round) { return roundAt(m_roundQty - 3); } *)
(* Definition RoundsBase_Ф_getRound1 : LedgerT RoundsBase_ι_Round :=
  return!! (   RoundsBase_Ф_roundAt (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt3 !) ). *)

Lemma RoundsBase_Ф_getRound1_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_getRound1) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

Lemma RoundsBase_Ф_getRound1_eval: forall (id: XInteger64) (l: Ledger),
 let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
 let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  eval_state (↓ RoundsBase_Ф_getRound1) l = m_rounds [ m_roundQty - 3 ].
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function getRound2()    internal inline returns (Round) { return roundAt(m_roundQty - 4); } *)
(* Definition RoundsBase_Ф_getRound2 : LedgerT RoundsBase_ι_Round :=
  return!! (   RoundsBase_Ф_roundAt (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt4 !) ). *)

Lemma RoundsBase_Ф_getRound2_exec: forall (id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_getRound2) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

Lemma RoundsBase_Ф_getRound2_eval: forall (id: XInteger64) (l: Ledger),
 let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
 let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  eval_state (↓ RoundsBase_Ф_getRound2) l = m_rounds [ m_roundQty - 4 ].
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function setRound(uint64 id, Round round) internal {
    m_rounds[id] = round;
} *)
(* Definition RoundsBase_Ф_setRound (Л_id: XInteger) ( Л_round: RoundsBase_ι_Round) : LedgerT True :=
     ↑11 U1! RoundsBase_ι_m_rounds [[ $Л_id ]] := $Л_round. *)

Lemma RoundsBase_Ф_setRound_exec: forall (id: XInteger64) ( Л_round: RoundsBase_ι_Round) (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
  exec_state (↓ RoundsBase_Ф_setRound id Л_round) l = {$ l With (RoundsBase_ι_m_rounds, m_rounds [id] ← Л_round ) $} .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_setRound_eval: forall (id: XInteger64) ( Л_round: RoundsBase_ι_Round) (l: Ledger),
  eval_state (↓ RoundsBase_Ф_setRound id Л_round ) l = I.
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function setRoundPre0(Round r) internal inline { setRound(m_roundQty - 1, r); } *)
(* Definition RoundsBase_Ф_setRoundPre0 ( Л_r: RoundsBase_ι_Round): LedgerT True :=
    RoundsBase_Ф_setRound (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt1 , $Л_r  !). *)

Lemma RoundsBase_Ф_setRoundPre0_exec: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  exec_state (↓ RoundsBase_Ф_setRoundPre0 Л_round) l = {$ l With (RoundsBase_ι_m_rounds, m_rounds [m_roundQty - 1] ← Л_round ) $} .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_setRoundPre0_eval: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
  eval_state (↓ RoundsBase_Ф_setRoundPre0 Л_round ) l = I.
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function setRound0(Round r)    internal inline { setRound(m_roundQty - 2, r); } *)
(* Definition RoundsBase_Ф_setRound0 ( Л_r: RoundsBase_ι_Round): LedgerT True :=
    RoundsBase_Ф_setRound (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt2 , $Л_r  !). *)

Lemma RoundsBase_Ф_setRound0_exec: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  exec_state (↓ RoundsBase_Ф_setRound0 Л_round) l = {$ l With (RoundsBase_ι_m_rounds, m_rounds [m_roundQty - 2] ← Л_round ) $} .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_setRound0_eval: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
  eval_state (↓ RoundsBase_Ф_setRound0 Л_round ) l = I.
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function setRound1(Round r)    internal inline { setRound(m_roundQty - 3, r); } *)
(* Definition RoundsBase_Ф_setRound1 ( Л_r: RoundsBase_ι_Round): LedgerT True :=
    RoundsBase_Ф_setRound (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt3 , $Л_r  !). *)

Lemma RoundsBase_Ф_setRound1_exec: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  exec_state (↓ RoundsBase_Ф_setRound1 Л_round) l = {$ l With (RoundsBase_ι_m_rounds, m_rounds [m_roundQty - 3] ← Л_round ) $} .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_setRound1_eval: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
  eval_state (↓ RoundsBase_Ф_setRound1 Л_round ) l = I.
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(* function setRound2(Round r)    internal inline { setRound(m_roundQty - 4, r); } *)
(* Definition RoundsBase_Ф_setRound2 ( Л_r: RoundsBase_ι_Round): LedgerT True :=
    RoundsBase_Ф_setRound (!  (↑11 D2! RoundsBase_ι_m_roundQty) !- $ xInt4 , $Л_r  !). *)

Lemma RoundsBase_Ф_setRound2_exec: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
let m_roundQty := eval_state (↑11 D2! RoundsBase_ι_m_roundQty) l in
  exec_state (↓ RoundsBase_Ф_setRound2 Л_round) l = {$ l With (RoundsBase_ι_m_rounds, m_rounds [m_roundQty - 4] ← Л_round ) $} .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

 Lemma RoundsBase_Ф_setRound2_eval: forall ( Л_round: RoundsBase_ι_Round) (l: Ledger),
  eval_state (↓ RoundsBase_Ф_setRound2 Л_round ) l = I.
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

(*
function fetchRound(uint64 id) internal returns (optional(Round)) {
    return m_rounds.fetch(id);
} *)
(* Definition RoundsBase_Ф_fetchRound (Л_id: XInteger64) : LedgerT (XMaybe RoundsBase_ι_Round) :=
  return!!   (D1! (↑11 D2! RoundsBase_ι_m_rounds) ->fetch $ Л_id) . *)

Lemma RoundsBase_Ф_fetchRound_exec: forall ( Л_id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_fetchRound Л_id) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

Lemma RoundsBase_Ф_fetchRound_eval: forall ( Л_id: XInteger64) (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
 eval_state (↓ RoundsBase_Ф_fetchRound Л_id ) l =  m_rounds [ Л_id ]?.
Proof.
    intros.
    destructLedger l.
    compute.
    repeat destructIf_solve2.
Qed.

  (* function minRound() internal view returns(optional(uint64, Round)) {
    return m_rounds.min();
} *)

(* Definition RoundsBase_Ф_minRound : LedgerT (XMaybe (XInteger64 # RoundsBase_ι_Round)) :=
    return!!  (D1! (↑11 D2! RoundsBase_ι_m_rounds) ->min) . *)

 Lemma RoundsBase_Ф_minRound_exec: forall (l: Ledger),
  exec_state (↓ RoundsBase_Ф_minRound) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

Lemma RoundsBase_Ф_minRound_eval: forall (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
 eval_state (↓ RoundsBase_Ф_minRound ) l =  hmapMinM m_rounds.
Proof.
    intros.
    destructLedger l.
    compute.
    repeat destructIf_solve2.
Qed.

 (* function nextRound(uint64 id) internal view returns(optional(uint64, Round)) {
     return m_rounds.next(id);
 } *)
(*  Definition RoundsBase_Ф_nextRound (Л_id: XInteger64) : LedgerT (XMaybe (XInteger64 # RoundsBase_ι_Round)) :=
    return!!  (D1! (↑11 D2! RoundsBase_ι_m_rounds) ->next $ Л_id) .
  *)

Lemma RoundsBase_Ф_nextRound_exec: forall  (Л_id: XInteger64) (l: Ledger),
  exec_state (↓ RoundsBase_Ф_nextRound Л_id) l = l .
 Proof.
     intros.
     destructLedger l.
     compute.
     repeat destructIf_solve2.
 Qed.

Lemma RoundsBase_Ф_nextRound_eval: forall  (Л_id: XInteger64) (l: Ledger),
let m_rounds := eval_state (↑11 D2! RoundsBase_ι_m_rounds) l in
 eval_state (↓ RoundsBase_Ф_nextRound Л_id ) l =  hmapNextM m_rounds Л_id.
Proof.
    intros.
    destructLedger l.
    compute.
    repeat destructIf_solve2.
Qed.

End RoundsBaseWrappers.


From Coq Require Import ssreflect ssrfun.
From Mon.sprop Require Import SPropBase.

(* Import SPropNotations. *)

Goal forall A P (x x':@Ssig A P), x = x'.
Proof.
  move=> ? ? [? ?] [? ?].
  match goal with
  | [|- context c [Sexists _ _ ?H]] =>
    let H' := fresh "H" in set (H':=H) in * at 1
  end.
  clearbody H.

  Goal forall A P (x:@Ssig A P) (f :forall (p:SProp) (H:p), Type), f _ (Spr2 x).
Proof.
  intros.
  destruct x.
  match goal with
  | [|- context c [Sexists _ _ ?H]] =>
    let H' := fresh "H" in set (H':=H)
  end.
  clearbody H.


Require Export Setoid Coq.Classes.Morphisms.
Require Import EqDec Computable Util AutoIndTac.
Require Export CSet  Containers.SetDecide MoreList OptionR.
Require Export LengthEq MapBasics MapLookup MapUpdate MapComposition.

Set Implicit Arguments.

Definition defined_on {X} `{OrderedType X} {Y} (G:set X) (E:X -> option Y)
  := forall x, x ∈ G -> exists y, E x = Some y.

Lemma defined_on_update_some X `{OrderedType X} Y (G:set X) (E:X -> option Y) x v
  : defined_on (G \ {{x}}) E
    -> defined_on G (E [x <- Some v]).
Proof.
  unfold defined_on; intros. lud.
  - eauto.
  - eapply H0; eauto. cset_tac; intuition.
Qed.

Lemma defined_on_update_some' X `{OrderedType X} Y (G:set X) (E:X -> option Y) x v
  : defined_on (G \ singleton x) E
    -> defined_on G (E [x <- Some v]).
Proof.
  unfold defined_on; intros. lud.
  - eauto.
  - eapply H0; eauto. cset_tac; intuition.
Qed.

Lemma defined_on_incl X `{OrderedType X} Y (G G':set X) (E:X -> option Y)
  : defined_on G E
    -> G' ⊆ G
    -> defined_on G' E.
Proof.
  unfold defined_on; intros; eauto.
Qed.

Lemma defined_on_update_list X `{OrderedType X} Y lv (E: X -> option Y) Z vl
: length vl = length Z
  -> defined_on (lv \ of_list Z) E
  -> defined_on lv (E [Z <-- List.map Some vl]).
Proof.
  unfold defined_on; intros.
  decide (x ∈ of_list Z).
  - length_equify. clear H1.
    general induction H0; simpl in * |- *.
    + lud; eauto.
      eapply IHlength_eq; eauto; cset_tac; intuition.
  - edestruct H1; eauto. cset_tac.
    exists x0. rewrite <- H3.
    eapply update_with_list_no_update; eauto.
Qed.

Instance defined_on_morph_incl X `{OrderedType X} Y
  : Proper (flip Subset ==> eq ==> impl) (@defined_on X _ Y).
Proof.
  unfold Proper, respectful, impl; intros; subst.
  eapply defined_on_incl; eauto.
Qed.

Instance defined_on_morph_equal X `{OrderedType X} Y
  : Proper (Equal ==> eq ==> iff) (@defined_on X _ Y).
Proof.
  unfold Proper, respectful, flip, impl; intros; subst.
  eapply eq_incl in H0; dcr; split; intros; eauto using defined_on_incl.
Qed.

Lemma defined_on_agree X `{OrderedType X} Y R D (f g:X->option Y)
  : defined_on D f
    -> agree_on (option_eq R) D f g
    -> defined_on D g.
Proof.
  intros; hnf; intros.
  edestruct H0; eauto.
  exploit H1; eauto.
  rewrite H3 in H4. inv H4. eauto.
Qed.

Lemma defined_on_agree_eq X `{OrderedType X} Y D (f g:X->option Y)
  : defined_on D f
    -> agree_on eq D f g
    -> defined_on D g.
Proof.
  intros; hnf; intros.
  edestruct H0; eauto.
  exploit H1; eauto.
  rewrite H3 in H4. inv H4. eauto.
Qed.

Lemma defined_on_union X `{OrderedType X} Y (f:X -> option Y) s t
  : defined_on s f
    -> defined_on t f
    -> defined_on (s ∪ t) f.
Proof.
  intros; hnf; intros. cset_tac.
Qed.

Inductive defined X : list (option X) -> Prop :=
| NilDefined : defined nil
| ConsDefined x xs: defined xs -> defined (Some x::xs).

Lemma defined_get X (L:list (option X)) n x
  : defined L
    -> get L n x
    -> exists y, x = Some y.
Proof.
  intros. general induction H0; invt defined; eauto.
Qed.

Lemma defined_on_update_list' X `{OrderedType X} Y (E:X -> option Y) L L' (Len:❬L❭=❬L'❭) s
  : defined_on (s \ of_list L) E
    -> defined L'
    -> defined_on s (E [L <-- L']).
Proof.
  intros.
  hnf; intros. decide (x ∈ of_list L).
  - edestruct update_with_list_lookup_in_list; try eapply i; dcr; eauto.
    rewrite H6. exploit defined_get; eauto.
  - rewrite lookup_set_update_not_in_Z; eauto.
    eapply H0; cset_tac.
Qed.

Lemma get_defined X (L:list (option X))
  : (forall n x, get L n x -> exists y, x = Some y)
    -> defined L.
Proof.
  intros. general induction L; eauto using defined, get.
  edestruct H; dcr; eauto using get. subst.
  eauto using defined, get.
Qed.

Lemma defined_on_defined X `{OrderedType X} Y (V:X->option Y) L
      `{Proper _ (_eq ==> eq) V}
  : defined_on (of_list L) V
    <-> defined (V ⊝ L).
Proof.
  split; intros.
  - eapply get_defined; intros; inv_get.
    eapply get_in_of_list in H2. eauto.
  - hnf; intros.
    edestruct of_list_get_first; eauto; dcr.
    eapply defined_get; eauto.
    rewrite <- H4. eapply map_get_1; eauto.
Qed.

Lemma defined_on_comp X `{OrderedType X} Y (f:X->X) D (V:X -> option Y)
      `{Proper _ (_eq ==> _eq) f}  `{Proper _ (_eq ==> eq) V}
  : defined_on (map f D) V <-> defined_on D (f ∘ V).
Proof.
  split; intros; hnf; intros.
  - exploit H2; eauto with cset.
  - eapply map_iff in H3; dcr; eauto.
    setoid_rewrite H6; eauto.
Qed.

Lemma defined_on_update_list_disj X `{OrderedType X} Y lv (E: X -> option Y) (Z:list X) vl
: defined_on lv E
  -> disj (of_list Z) lv
  -> defined_on lv (E [Z <-- vl]).
Proof.
  unfold defined_on; intros.
  general induction Z; destruct vl; simpl in *; eauto.
  - lud.
    + exfalso. eapply H1; eauto. simpl. cset_tac.
    + eapply IHZ; eauto with cset.
Qed.

Lemma defined_on_agree_fstNoneOrR (X : Type) `{H : OrderedType X}
      (Y : Type) (R : relation Y) (D : ⦃X⦄) (f g : X -> ؟ Y)
  : defined_on D f -> agree_on (fstNoneOrR R) D f g -> defined_on D g.
Proof.
  intros Def Agr.
  hnf; intros. edestruct Def; eauto.
  exploit Agr; eauto. rewrite H1 in H2. inv H2; eauto.
Qed.


Require Import ImpPrelude.
Require Import PCM.
Require Import ModSem.
Require Import Imp.
Require Import ImpNotations.

Set Implicit Arguments.

Section Knot.

  Import ImpNotations.

  Local Open Scope expr_scope.
  Local Open Scope stmt_scope.

  Context `{Σ: GRA.t}.

  Definition knot : function := {|
    fn_params := ["fb"];
    fn_vars := ["blk"; "rb"];
    fn_body :=
      "blk" =#& "_f" ;#
      "blk" *=# "fb" ;#
      "rb" =#& "rec" ;#
      return# "rb"
  |}.

  Definition rec : function := {|
    fn_params := ["n"];
    fn_vars := ["blk"; "fb"; "rb"; "ret"];
    fn_body :=
      "blk" =#& "_f" ;#
      "fb" =#* "blk" ;#
      "rb" =#& "rec" ;#
      "ret" =@* "fb" ["rb" : expr; "n" : expr] ;#
      return# "ret"
  |}.

  Definition Knot_prog : program := {|
    name := "Knot";
    ext_vars := [];
    ext_funs := [];
    prog_vars := [("_f", 0%Z)];
    prog_funs := [("rec", rec); ("knot", knot)];
  |}.

  Definition KnotSem ge : ModSem.t := ImpMod.modsem Knot_prog ge.
  Definition Knot : Mod.t := ImpMod.get_mod Knot_prog.

End Knot.


From Equations Require Import Equations.

Require Import Coq.Lists.List.

Require Export SystemFR.RedTactics.
Require Export SystemFR.ReducibilityOpenEquivalent.

Opaque reducible_values.
Opaque makeFresh.

Lemma reducible_value_let:
  forall ρ v t A B,
    wf t 1 ->
    pfv t term_var = nil ->
    is_erased_term t ->
    valid_interpretation ρ ->
    is_erased_type B ->
    [ ρ ⊨ v : A ]v ->
    [ ρ ⊨ open 0 t v : open 0 B v ] ->
    [ ρ ⊨ app (notype_lambda t) v : open 0 B v ].
Proof.
  steps.
  eapply backstep_reducible; eauto using red_is_val with smallstep;
    repeat step || list_utils;
    eauto 2 with fv;
    eauto 2 with wf;
    eauto with erased.
Qed.

Lemma reducible_let:
  forall ρ t1 t2 A B,
    wf t2 1 ->
    wf B 1 ->
    fv t2 = nil ->
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : A ] ->
    is_erased_term t2 ->
    is_erased_type B ->
    fv B = nil ->
    (forall v,
        cbv_value v ->
        t1 ~>* v ->
        [ ρ ⊨ open 0 t2 v : open 0 B v ]) ->
    [ ρ ⊨ app (notype_lambda t2) t1 : open 0 B t1 ].
Proof.
  unfold reduces_to, closed_term; repeat step || list_utils; eauto with fv.
  createHypothesis;
    repeat step || t_values_info2.

  exists v0; steps; eauto using reducibility_values_rtl.
  eapply star_trans; eauto with cbvlemmas.
  eapply star_trans; eauto with cbvlemmas values.
  eapply star_trans;
    eauto with cbvlemmas;
    eauto with star smallstep.
Qed.

Lemma reducible_let2:
  forall ρ t1 t2 A B,
    wf t2 1 ->
    wf B 0 ->
    fv t2 = nil ->
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : A ] ->
    is_erased_term t2 ->
    is_erased_type B ->
    fv B = nil ->
    (forall v,
        cbv_value v ->
        t1 ~>* v ->
        [ ρ ⊨ open 0 t2 v : B ]) ->
    [ ρ ⊨ app (notype_lambda t2) t1 : B ].
Proof.
  intros.
  rewrite <- (open_none B 0 t1); steps.
  eapply reducible_let; eauto with wf;
    repeat step || rewrite (open_none B) by auto.
Qed.

Lemma open_reducible_let:
  forall Θ Γ t1 t2 A B x p,
    ~(p ∈ fv_context Γ) ->
    ~(p ∈ fv A) ->
    ~(p ∈ fv B) ->
    ~(p ∈ fv t1) ->
    ~(p ∈ fv t2) ->
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv A) ->
    ~(x ∈ fv B) ->
    ~(x ∈ fv t1) ->
    ~(x ∈ fv t2) ->
    ~(x = p) ->
    wf t2 1 ->
    wf B 1 ->
    is_erased_term t2 ->
    subset (fv A) (support Γ) ->
    subset (fv B) (support Γ) ->
    subset (fv t2) (support Γ) ->
    is_erased_type B ->
    [ Θ; Γ ⊨ t1 : A ] ->
    [ Θ; (p, T_equiv (fvar x term_var) t1) :: (x,A) :: Γ ⊨
        open 0 t2 (fvar x term_var) : open 0 B (fvar x term_var) ] ->
    [ Θ; Γ ⊨ app (notype_lambda t2) t1 : open 0 B t1 ].
Proof.
  unfold open_reducible; repeat step || t_substitutions.

  eapply reducible_let;
   repeat step || top_level_unfold reduces_to ||
          t_values_info2 || t_deterministic_star || t_termlist || t_instantiate_sat4;
      unshelve eauto with wf; eauto using subset_same with fv;
        eauto with erased.

  match goal with
  | H: _ ~>* ?v |- _ =>
    unshelve epose proof (H18 ρ ((p, uu) :: (x, v) :: lterms) _ _)
  end;
    repeat step || apply SatCons || list_utils || t_substitutions || simp_red;
    t_closer;
    try solve [ apply equivalent_sym; equivalent_star ];
    eauto with twf.
Qed.