Require Import
  Coq.Structures.Orders.

Require Import
  Shuffle.Misc.

Module Type IsPartialOrder
  (Import E : EqualityType)
  (Import Le : HasLe E).
  Declare Instance le_preorder : PreOrder le.
  Declare Instance le_order : PartialOrder eq le.
  Declare Instance le_compat : Proper (eq ==> eq ==> iff) le.
End IsPartialOrder.

Module Type HasPartialCmp
  (Import E : Typ).
  Parameter Inline partial_compare :
    t ->
    t ->
    option comparison.
End HasPartialCmp.

Module Type PartialCmpSpec
  (Import E : EqLt')
  (Import C : HasPartialCmp E).
  Axiom partial_compare_spec :
    forall
    x y : t,
    OptionSpec
      (CompareSpec (x == y) (x < y) (y < x))
      (x ~= y /\ ~ x < y /\ ~ y < x)
      (partial_compare x y).
End PartialCmpSpec.

Module Type HasPartialCompare
  (E : EqLt) :=
  HasPartialCmp E <+
  PartialCmpSpec E.

Module Type StrOrderFull :=
  StrOrder <+
  HasLe <+
  LeIsLtEq.

Module GenericPartialOrder
  (Import O : StrOrder').

  Definition le
    (x y : t) :
    Prop :=
    x < y \/ x == y.

  Infix "<=" := le.

  Lemma le_lteq :
    forall
    x y : t,
    x <= y <->
    x < y \/ x == y.
  Proof.
    intros x y; reflexivity.
  Qed.

  Add Parametric Morphism : le
    with signature (eq ==> eq ==> iff) as le_compat.
  Proof.
    intros x x' x_eq_x' y y' y_eq_y'.
    now unfold le; rewrite x_eq_x', y_eq_y'.
  Qed.

  Instance le_preorder : PreOrder le.
  Proof.
    unfold le; split.
      now intros x; right.
    intros x y z x_le_y y_le_z.
    destruct x_le_y as [x_lt_y| x_eq_y].
      now destruct y_le_z as [y_lt_z| y_eq_z]; left;
        [transitivity y| rewrite <- y_eq_z].
    now rewrite x_eq_y.
  Qed.

  Instance le_order : PartialOrder eq le.
  Proof.
     intros x y.
     split.
      now intros x_eq_y;
      change (le x y /\ le y x); rewrite x_eq_y.
    intros [x_le_y x_ge_y]; change (y <= x) in x_ge_y.
    destruct x_le_y as [x_lt_y| x_eq_y];
      [destruct x_ge_y as [x_gt_y| y_eq_x]|]; try easy.
    now absurd (x < x); [apply irreflexivity| transitivity y].
  Qed.
End GenericPartialOrder.

Module GenericPartialCompare
  (Import E : EqLt')
  (Import C : HasCompare E) <:
  HasPartialCompare E.

  Definition partial_compare
    (self other : t) :
    option comparison :=
    Some (compare self other).

  Lemma partial_compare_spec :
    forall
    x y : t,
    OptionSpec
      (CompareSpec (x == y) (x < y) (y < x))
      (x ~= y /\ ~ x < y /\ ~ y < x)
      (partial_compare x y).
  Proof.
    intros x y; constructor; apply compare_spec.
  Qed.
End GenericPartialCompare.

Module GenericBooleanFunctions
  (Import O : StrOrderFull)
  (Import C : HasPartialCompare O).

  Definition eqb
    (self other : t) :
    bool :=
    match C.partial_compare self other with
    | Some Eq => true
    | _ => false
    end.

  Lemma lt_impl_neq :
    forall
    x y : O.t,
    O.lt x y ->
    O.eq x y ->
    False.
  Proof.
    intros x y x_lt_y x_eq_y.
    contradict x_lt_y; rewrite x_eq_y; apply irreflexivity.
  Qed.

  Lemma gt_impl_neq :
    forall
    x y : O.t,
    O.lt y x ->
    O.eq x y ->
    False.
  Proof.
    intros x y x_gt_y x_eq_y.
    now symmetry in x_eq_y; apply lt_impl_neq with y x.
  Qed.

  Lemma lt_impl_ngt :
    forall
    x y : O.t,
    O.lt x y ->
    O.lt y x ->
    False.
  Proof.
    intros x y x_lt_y x_gt_y.
    now absurd (lt x x); [apply irreflexivity| transitivity y].
  Qed.

  #[local]
  Hint Immediate lt_impl_neq gt_impl_neq lt_impl_ngt : partial.

  Lemma eqb_eq :
    forall
    x y : t,
    eqb x y = true <->
    eq x y.
  Proof.
    intros x y; unfold eqb.
    specialize partial_compare_spec with x y as [cmp_x_y [x_eq_y| x_lt_y| x_gt_y]|].
    2, 3, 4: now split; [intros [=]| intros x_eq_y; exfalso; eauto with partial].
    easy.
  Qed.

  Definition ltb
    (self other : t) :
    bool :=
    match C.partial_compare self other with
    | Some Lt => true
    | _ => false
    end.

  Lemma ltb_lt :
    forall
    x y : t,
    ltb x y = true <->
    lt x y.
  Proof.
    intros x y; unfold ltb.
    specialize C.partial_compare_spec with x y as [cmp_x_y [x_eq_y| x_lt_y| x_gt_y]|].
    1, 3, 4: now split; [intros [=]| intros x_lt_y; exfalso; eauto with partial].
    easy.
  Qed.

  Definition leb
    (self other : t) :
    bool :=
    match C.partial_compare self other with
    | Some (Lt | Eq) => true
    | _ => false
    end.

  Lemma leb_le :
    forall
    x y : t,
    leb x y = true <->
    le  x y.
  Proof.
    intros x y; unfold leb; rewrite le_lteq.
    specialize C.partial_compare_spec with x y as [cmp_x_y [x_eq_y| x_lt_y| x_gt_y]|].
      1, 2: tauto.
    1, 2: now split; [intros [=]| intros [x_lt_y| x_eq_y]; exfalso; eauto with partial].
  Qed.
End GenericBooleanFunctions.

Module ReflectSpec
  (Import O : EqLtLe')
  (Import F : HasBoolOrdFuns' O)
  (Import S : BoolOrdSpecs O F).

  Lemma eqb_spec :
    forall
    x y : t,
    Bool.reflect (x == y) (x =? y).
  Proof.
    intros x y.
    apply Bool.iff_reflect; symmetry; apply eqb_eq.
  Qed.

  Lemma ltb_spec :
    forall
    x y : t,
    Bool.reflect (x < y) (x <? y).
  Proof.
    intros x y.
    apply Bool.iff_reflect; symmetry; apply ltb_lt.
  Qed.

  Lemma leb_spec :
    forall
    x y : t,
    Bool.reflect (x <= y) (x <=? y).
  Proof.
    intros x y.
    apply Bool.iff_reflect; symmetry; apply leb_le.
  Qed.
End ReflectSpec.


From stdpp Require Import gmap.
From Perennial.goose_lang Require Export lang.
Require Import Program.

(* This file contains some metatheory about GooseLang,
  which is not needed for verifying programs. *)

Set Default Proof Using "Type".

Section goose_lang.
  Context `{ffi_sem: ffi_semantics}.

Definition binder_vars (b: binder) : gset string :=
  match b with
  | BNamed x => {[x]}
  | BAnon => ∅
  end.

(* This returns all variables, bound and free, occurring in an expression *)
Fixpoint expr_vars (e : expr) : gset string :=
  match e with
  | Val v => val_vars v
  | Var x => {[x]}
  | Primitive0 _ => ∅
  | Rec f x e => binder_vars f ∪ binder_vars x ∪ expr_vars e
  | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Load e
  | ExternalOp _ e | Primitive1 _ e =>
     expr_vars e
  | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | Atomically e1 e2
  | Primitive2 _ e1 e2 | ResolveProph e1 e2 =>
     expr_vars e1 ∪ expr_vars e2
  | If e0 e1 e2 | Case e0 e1 e2 | CmpXchg e0 e1 e2 =>
     expr_vars e0 ∪ expr_vars e1 ∪ expr_vars e2
  | NewProph => ∅
  end
with val_vars (v : val) : gset string :=
  match v with
  | LitV _ | ExtV _ => ∅
  | RecV f x e => binder_vars f ∪ binder_vars x ∪ expr_vars e
  | PairV v1 v2 => val_vars v1 ∪ val_vars v2
  | InjLV v | InjRV v => val_vars v
  end.

Lemma expr_vars_subst e x es : x ∉ expr_vars e → subst x es e = e.
Proof.
  induction e; rewrite /=; try (destruct op); rewrite ?bool_decide_spec ?andb_True=> ?;
    repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
  set_solver.
Qed.

(* Closed expressions and values. *)
Fixpoint is_closed_expr (X : list string) (e : expr) : bool :=
  match e with
  | Val v => is_closed_val v
  | Var x => bool_decide (x ∈ X)
  | Primitive0 _ => true
  | Rec f x e => is_closed_expr (f :b: x :b: X) e
  | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Load e
  | ExternalOp _ e | Primitive1 _ e =>
     is_closed_expr X e
  | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | Atomically e1 e2
  | Primitive2 _ e1 e2 | ResolveProph e1 e2 =>
     is_closed_expr X e1 && is_closed_expr X e2
  | If e0 e1 e2 | Case e0 e1 e2 | CmpXchg e0 e1 e2 =>
     is_closed_expr X e0 && is_closed_expr X e1 && is_closed_expr X e2
  | NewProph => true
  end
with is_closed_val (v : val) : bool :=
  match v with
  | LitV _ | ExtV _ => true
  | RecV f x e => is_closed_expr (f :b: x :b: []) e
  | PairV v1 v2 => is_closed_val v1 && is_closed_val v2
  | InjLV v | InjRV v => is_closed_val v
  end.

Lemma is_closed_expr_prim1_iff X op e:
  is_closed_expr X (Primitive1 op e) <-> is_closed_expr X e.
Proof.
  destruct op; eauto.
Qed.

Lemma is_closed_expr_prim2_iff X op e1 e2:
  is_closed_expr X (Primitive2 op e1 e2) <-> is_closed_expr X e1 && is_closed_expr X e2.
Proof.
  destruct op; eauto.
Qed.

Lemma is_closed_weaken X Y e : is_closed_expr X e → X ⊆ Y → is_closed_expr Y e.
Proof. revert X Y; induction e; try naive_solver (eauto; set_solver).
       - intros. move: H. rewrite ?is_closed_expr_prim1_iff; eauto.
       - intros. move: H. rewrite ?is_closed_expr_prim2_iff; eauto.
         naive_solver.
Qed.

Lemma is_closed_weaken_nil X e : is_closed_expr [] e → is_closed_expr X e.
Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed.

Lemma is_closed_subst X e x v :
  is_closed_val v → is_closed_expr (x :: X) e → is_closed_expr X (subst x v e).
Proof.
  intros Hv. revert X.
  induction e=> X /= ?; try destruct op; destruct_and?; split_and?; simplify_option_eq;
    try match goal with
    | H : ¬(_ ∧ _) |- _ => apply not_and_l in H as [?%dec_stable|?%dec_stable]
    end; eauto using is_closed_weaken with set_solver.
Qed.
Lemma is_closed_subst' X e x v :
  is_closed_val v → is_closed_expr (x :b: X) e → is_closed_expr X (subst' x v e).
Proof. destruct x; eauto using is_closed_subst. Qed.

(* Substitution *)
Lemma subst_is_closed X e x es : is_closed_expr X e → x ∉ X → subst x es e = e.
Proof.
  revert X. induction e=> X /=; try (destruct op); rewrite ?bool_decide_spec ?andb_True=> ??;
    repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
Qed.

Lemma subst_is_closed_nil e x v : is_closed_expr [] e → subst x v e = e.
Proof. intros. apply subst_is_closed with []; set_solver. Qed.

Lemma subst_subst e x v v' :
  subst x v (subst x v' e) = subst x v' e.
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst' e x v v' :
  subst' x v (subst' x v' e) = subst' x v' e.
Proof. destruct x; simpl; auto using subst_subst. Qed.

Lemma subst_subst_ne e x y v v' :
  x ≠ y → subst x v (subst y v' e) = subst y v' (subst x v e).
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using eq_sym, subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst_ne' e x y v v' :
  x ≠ y → subst' x v (subst' y v' e) = subst' y v' (subst' x v e).
Proof. destruct x, y; simpl; auto using subst_subst_ne with congruence. Qed.

Lemma subst_rec' f y e x v :
  x = f ∨ x = y ∨ x = BAnon →
  subst' x v (Rec f y e) = Rec f y e.
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
Lemma subst_rec_ne' f y e x v :
  (x ≠ f ∨ f = BAnon) → (x ≠ y ∨ y = BAnon) →
  subst' x v (Rec f y e) = Rec f y (subst' x v e).
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.

Lemma  bin_op_eval_closed op v1 v2 v':
  is_closed_val v1 → is_closed_val v2 → bin_op_eval op v1 v2 = Some v' →
  is_closed_val v'.
Proof.
  rewrite /bin_op_eval /bin_op_eval_bool /bin_op_eval_shift /bin_op_eval_word /bin_op_eval_string /bin_op_eval_eq;
    repeat case_match; try by naive_solver.
Qed.

Lemma heap_closed_alloc σ l n w :
  (0 < n)%Z →
  is_closed_val w →
  map_Forall (λ _ v, is_closed_val (snd v)) (heap σ) →
  (∀ i : Z, (0 ≤ i)%Z → (i < n)%Z → heap σ !! (l +ₗ i) = None) →
  map_Forall (λ _ v, is_closed_val (snd v))
             (heap_array l (replicate (Z.to_nat n) (Free w)) ∪ heap σ).
Proof.
  intros Hn Hw Hσ Hl.
  eapply (map_Forall_ind
            (λ k v, ((heap_array l (fmap Free (replicate (Z.to_nat n) w)) ∪ heap σ)
                       !! k = Some v))).
  - apply map_Forall_empty.
  - intros m i x Hi Hix Hkwm Hm.
    apply map_Forall_insert_2; auto.
    apply lookup_union_Some in Hix; last first.
    { eapply heap_array_map_disjoint. rewrite fmap_replicate.
        rewrite replicate_length Z2Nat.id; auto with lia. }
    destruct Hix as [Hlook|[j Hj]%elem_of_map_to_list%elem_of_list_lookup_1].
    + eapply heap_array_lookup in Hlook as (?&?&?&Hlook).
      rewrite list_lookup_fmap in Hlook.
      eapply fmap_Some_1 in Hlook as (?&Hlook&Hf).
      eapply lookup_replicate_1 in Hlook as [-> Hlt%inj_lt].
      rewrite !Z2Nat.id in Hlt; subst; eauto with lia.
    + apply map_Forall_to_list in Hσ.
      by eapply Forall_lookup in Hσ; eauto; simpl in *.
  - apply map_Forall_to_list, Forall_forall.
    intros [? ?] ?%elem_of_map_to_list.
    by rewrite fmap_replicate.
Qed.

Lemma fill_item_closed X K e :
  is_closed_expr X (fill_item K e) →
  is_closed_expr X e.
Proof.
  revert e. induction K => e //=; try naive_solver; try (destruct op; naive_solver).
Qed.

Lemma fill_closed X K e :
  is_closed_expr X (fill K e) →
  is_closed_expr X e.
Proof.
  revert e. induction K => e; first done.
  rewrite /= => Hclo.  apply IHK in Hclo. eapply fill_item_closed; eauto.
Qed.

(* The stepping relation preserves closedness *)
(*
Lemma head_step_is_closed e1 σ1 obs e2 σ2 es :
  is_closed_expr [] e1 →
  map_Forall (λ _ v, is_closed_val (snd v)) σ1.(heap) →
  head_step e1 σ1 obs e2 σ2 es →

  is_closed_expr [] e2 ∧ Forall (is_closed_expr []) es ∧
  map_Forall (λ _ v, is_closed_val (snd v)) σ2.(heap).
Proof.
  intros Cl1 Clσ1 STEP.
  induction STEP; simpl in *; split_and!.
    try apply map_Forall_insert_2; try by naive_solver.
  - subst. repeat apply is_closed_subst'; naive_solver.
  - unfold un_op_eval in *. repeat case_match; naive_solver.
  - eapply bin_op_eval_closed; eauto; naive_solver.
  - by apply heap_closed_alloc.
  - case_match; try apply map_Forall_insert_2; by naive_solver.
Qed.
*)

(* Parallel substitution with maps of values indexed by strings *)
Definition binder_delete {A} (x : binder) (vs : gmap string A) : gmap string A :=
  if x is BNamed x' then delete x' vs else vs.
Definition binder_insert {A} (x : binder) (v : A) (vs : gmap string A) : gmap string A :=
  if x is BNamed x' then <[x':=v]>vs else vs.

Lemma binder_insert_fmap {A B : Type} (f : A → B) (x : A) b vs :
  f <$> binder_insert b x vs = binder_insert b (f x) (f <$> vs).
Proof. destruct b; rewrite ?fmap_insert //. Qed.
Lemma binder_delete_fmap {A B : Type} (f : A → B) b vs :
  f <$> binder_delete b vs = binder_delete b (f <$> vs).
Proof. destruct b; rewrite ?fmap_delete //. Qed.
Lemma lookup_binder_delete_None {A : Type} (vs : gmap string A) x y :
  binder_delete x vs !! y = None ↔ x = BNamed y ∨ vs !! y = None.
Proof. destruct x; rewrite /= ?lookup_delete_None; naive_solver. Qed.

Fixpoint subst_map (vs : gmap string val) (e : expr) : expr :=
  match e with
  | Val _ => e
  | Var y => if vs !! y is Some v then Val v else Var y
  | Rec f y e => Rec f y (subst_map (binder_delete y (binder_delete f vs)) e)
  | App e1 e2 => App (subst_map vs e1) (subst_map vs e2)
  | UnOp op e => UnOp op (subst_map vs e)
  | BinOp op e1 e2 => BinOp op (subst_map vs e1) (subst_map vs e2)
  | If e0 e1 e2 => If (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | Pair e1 e2 => Pair (subst_map vs e1) (subst_map vs e2)
  | Fst e => Fst (subst_map vs e)
  | Snd e => Snd (subst_map vs e)
  | InjL e => InjL (subst_map vs e)
  | InjR e => InjR (subst_map vs e)
  | Case e0 e1 e2 => Case (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | Fork e => Fork (subst_map vs e)
  | Atomically el e => Atomically (subst_map vs el) (subst_map vs e)
  | Primitive0 op => Primitive0 op
  | Primitive1 op e => Primitive1 op (subst_map vs e)
  | Primitive2 op e1 e2 => Primitive2 op (subst_map vs e1) (subst_map vs e2)
  | ExternalOp op e => ExternalOp op (subst_map vs e)
  | CmpXchg e0 e1 e2 => CmpXchg (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | NewProph => NewProph
  | ResolveProph e1 e2 => ResolveProph (subst_map vs e1) (subst_map vs e2)
  end.

Lemma subst_map_empty e : subst_map ∅ e = e.
Proof.
  assert (∀ x, binder_delete x (∅:gmap _ val) = ∅) as Hdel.
  { intros [|x]; by rewrite /= ?delete_empty. }
  induction e; simplify_map_eq; rewrite ?Hdel; auto with f_equal.
Qed.
Lemma subst_map_insert x v vs e :
  subst_map (<[x:=v]>vs) e = subst x v (subst_map (delete x vs) e).
Proof.
  revert vs. assert (∀ (y : binder) (vs : gmap _ val), y ≠ BNamed x →
    binder_delete y (<[x:=v]> vs) = <[x:=v]> (binder_delete y vs)) as Hins.
  { intros [|y] vs ?; rewrite /= ?delete_insert_ne //; congruence. }
  assert (∀ (y : binder) (vs : gmap _ val),
    binder_delete y (delete x vs) = delete x (binder_delete y vs)) as Hdel.
  { by intros [|y] ?; rewrite /= 1?delete_commute. }
  induction e=> vs; simplify_map_eq; auto with f_equal.
  - match goal with
    | |- context [ <[?x:=_]> _ !! ?y ] =>
       destruct (decide (x = y)); simplify_map_eq=> //
    end. by case (vs !! _); simplify_option_eq.
  - destruct (decide _) as [[??]|[<-%dec_stable|[<-%dec_stable ?]]%not_and_l_alt].
    + rewrite !Hins // !Hdel. eauto with f_equal.
    + by rewrite /= delete_insert_delete delete_idemp.
    + by rewrite /= Hins // delete_insert_delete !Hdel delete_idemp.
Qed.
Lemma subst_map_insert' x v vs e:
    subst_map (<[x:=v]> vs) e = subst_map vs (subst x v e).
Proof.
  revert vs. assert (∀ (y : binder) (vs : gmap _ val), y ≠ BNamed x →
    binder_delete y (<[x:=v]> vs) = <[x:=v]> (binder_delete y vs)) as Hins.
  { intros [|y] vs ?; rewrite /= ?delete_insert_ne //; congruence. }
  induction e=> vs; simplify_map_eq; auto with f_equal.
  - match goal with
    | |- context [ <[?x:=_]> _ !! ?y ] =>
       destruct (decide (x = y)); simplify_map_eq=> //
    end.
  - destruct (decide _) as [[??]|[<-%dec_stable|[<-%dec_stable ?]]%not_and_l_alt].
    + rewrite !Hins // IHe //.
    + by rewrite /= delete_insert_delete.
    + by rewrite /= Hins // delete_insert_delete.
Qed.
Lemma subst_map_subst_comm x v vs e:
  x ∉ dom vs →
  subst x v (subst_map vs e) = subst_map vs (subst x v e).
Proof.
  intros Hnin.
  rewrite -subst_map_insert'. rewrite subst_map_insert. f_equal.
  f_equal. rewrite delete_notin //.
  apply not_elem_of_dom; eauto.
Qed.
Lemma subst_map_binder_insert b v vs e :
  subst_map (binder_insert b v vs) e =
  subst' b v (subst_map (binder_delete b vs) e).
Proof. destruct b; rewrite ?subst_map_insert //. Qed.
Lemma subst_map_binder_insert' b v vs e:
  subst_map (binder_insert b v vs) e =
  subst_map vs (subst' b v e).
Proof. destruct b; rewrite ?subst_map_insert' //=. Qed.

Lemma binder_delete_commute b1 b2 (vs: gmap string val):
  binder_delete b1 (binder_delete b2 vs) =
  binder_delete b2 (binder_delete b1 vs).
Proof. destruct b1, b2; rewrite //= delete_commute //. Qed.

(* subst_map on closed expressions *)
Lemma subst_map_is_closed X e vs :
  is_closed_expr X e →
  (∀ x, x ∈ X → vs !! x = None) →
  subst_map vs e = e.
Proof.
  revert X vs. assert (∀ x x1 x2 X (vs : gmap string val),
    (∀ x, x ∈ X → vs !! x = None) →
    x ∈ x2 :b: x1 :b: X →
    binder_delete x1 (binder_delete x2 vs) !! x = None).
  { intros x x1 x2 X vs ??. rewrite !lookup_binder_delete_None. set_solver. }
  induction e=> X vs /= ? HX; try (dependent destruction op); repeat case_match; naive_solver eauto with f_equal.
Qed.

Lemma subst_map_is_closed_nil e vs : is_closed_expr [] e → subst_map vs e = e.
Proof. intros. apply subst_map_is_closed with []; set_solver. Qed.

End goose_lang.


(* Example transaction flow for managing pricing information about cars *)

Require Import List.
Require Import Lia.
Require Import Logic.FunctionalExtensionality.

Require Import SfLib.
Require Import LibTactics.
Require Import MyUtils.
Require Import Entities.
Require Import TransFlow.

Definition emp `(key_tp : Type) `(val_tp : Type) : mp_tp key_tp val_tp :=
  fun k => None.

Definition car1 := Key 1.
Definition car2 := Key 2.

Definition cp_ws : world_state :=
  mp_upd key (prod val ver) beq_key_dec
         (mp_upd key (prod val ver) beq_key_dec (emp key (prod val ver))
                 car1 (PrimVal 200, Ver 1))
         car2 (PrimVal 300, Ver 1).

Definition cp_chaincode_id : chaincode_id := CcId 1.

Definition cp_rset0 : read_set := emp key ver.
Definition cp_wset0 : write_set := emp key val_or_del.

Definition cp_rset11 : read_set := emp key ver.
Definition cp_wset11 : write_set :=
  mp_upd key val_or_del beq_key_dec (emp key val_or_del)
         car1 (Val_or_del1 (PrimVal 200)).

Definition cp_rset12 : read_set := emp key ver.
Definition cp_wset12 : write_set :=
  mp_upd key val_or_del beq_key_dec (emp key val_or_del)
         car2 (Val_or_del1 (PrimVal 300)).

Definition cp_rset21 : read_set :=
  mp_upd key ver beq_key_dec (emp key ver) car1 (Ver 1).
Definition cp_wset21 : write_set :=
  mp_upd key val_or_del beq_key_dec (emp key val_or_del)
         car1 (Val_or_del1 (PrimVal 180)).

Definition cp_rset22 : read_set :=
  mp_upd key ver beq_key_dec (emp key ver) car2 (Ver 1).
Definition cp_wset22 : write_set :=
    mp_upd key val_or_del beq_key_dec (emp key val_or_del)
         car2 (Val_or_del1 (PrimVal 270)).

Eval compute in (Nat.div (100 * 4) 5).

Theorem beq_op_dec : forall (op1 op2 : operation), {op1 = op2} + {op1 <> op2}.
Proof. repeat decide equality. Qed.

Definition cp_upd_op1 : operation := Oper 1.
Definition cp_upd_op2 : operation := Oper 2.
Definition cp_dc_op1 : operation := Oper 3.
Definition cp_dc_op2 : operation := Oper 4.

(* peer_interp_oper : operation -> world_state -> (prod read_set write_set) *)
Definition cp_op_interp : operation -> world_state -> (prod read_set write_set) :=
  func_upd _ _ beq_op_dec
           (func_upd _ _ beq_op_dec
                     ((func_upd _ _ beq_op_dec
                                (func_upd _ _ beq_op_dec
                                          (fun op => fun ws => (cp_rset0, cp_wset0))
                                          cp_upd_op1 (fun ws => (cp_rset11, cp_wset11))))
                        cp_upd_op2 (fun ws => (cp_rset12, cp_wset12)))
                     cp_dc_op1
                     (fun ws => match ws car1 with
                                  Some (PrimVal n, Ver i) => (
                                    (mp_upd _ _ beq_key_dec (emp key ver) car1 (Ver i)),
                                    (mp_upd _ _ beq_key_dec (emp key val_or_del)
                                            car1 (Val_or_del1 (PrimVal (Nat.div (n * 9) 10))))
                                  )
                                | _ => (cp_rset0, cp_wset0)
                                end))
           cp_dc_op2
           (fun ws => match ws car2 with
                        Some (PrimVal n, Ver i) => (
                          (mp_upd _ _ beq_key_dec (emp key ver) car2 (Ver i)),
                          (mp_upd _ _ beq_key_dec (emp key val_or_del)
                                  car2 (Val_or_del1 (PrimVal (Nat.div (n * 9) 10)))))
                      | _ => (cp_rset0, cp_wset0)
                      end).

Variable hf : hash_func.

Definition cp_cli_id : client_id := ClId 1.
Definition cp_peer1_id : peer_id := PrId 1.
Definition cp_peer2_id : peer_id := PrId 2.

Definition cp_ep : endorsement_pol :=
  fun sigs =>
    andb
      (List.existsb (fun s => match s with Sig (PubK 1) _ => true | _ => false end) sigs)
      (List.existsb (fun s => match s with Sig (PubK 2) _ => true | _ => false end) sigs).

Check (andb).

Definition cp_epcc : chaincode_id -> option (prod endorsement_pol chaincode) :=
  mp_upd _ _ beq_cc_id_dec
         (emp chaincode_id (prod endorsement_pol chaincode))
         cp_chaincode_id
         (cp_ep, Chaincode [cp_upd_op1; cp_upd_op2; cp_dc_op1; cp_dc_op2]).

Definition cp_txp11_1 : tx_proposal_field :=
  TxProposal cp_peer1_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_upd_op1 (TS 1)))
             cp_chaincode_id cp_upd_op1 cp_rset11 cp_wset11.

(* endorsement for transaction 1 in block 1 by peer 1 *)
Definition cp_ed11_1 : trans_endorsed_msg :=
   Trans_endorsed_msg cp_txp11_1
                      (Sig (PubK 1) (hf tx_proposal_field cp_txp11_1)).

Definition cp_txp11_2 : tx_proposal_field :=
  TxProposal cp_peer2_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_upd_op1 (TS 1)))
             cp_chaincode_id cp_upd_op1 cp_rset11 cp_wset11.

(* endorsement for transaction 1 in block 1 by peer 2 *)
Definition cp_ed11_2 : trans_endorsed_msg :=
  Trans_endorsed_msg cp_txp11_2
                     (Sig (PubK 2) (hf tx_proposal_field cp_txp11_2)).

(* transaction 1 in block 1 *)
Definition cp_tx11 : transaction :=
  Trans cp_chaincode_id cp_upd_op1 (cp_rset11, cp_wset11) (cp_ed11_1 :: cp_ed11_2 :: nil).

Definition cp_txp12_1 : tx_proposal_field :=
  TxProposal cp_peer1_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_upd_op2 (TS 2)))
             cp_chaincode_id cp_upd_op2 cp_rset12 cp_wset12.

(* endorsement for transaction 2 in block 1 by peer 1 *)
Definition cp_ed12_1 : trans_endorsed_msg :=
   Trans_endorsed_msg cp_txp12_1
                      (Sig (PubK 1) (hf tx_proposal_field cp_txp12_1)).

Definition cp_txp12_2 : tx_proposal_field :=
  TxProposal cp_peer2_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_upd_op2 (TS 2)))
             cp_chaincode_id cp_upd_op2 cp_rset12 cp_wset12.

(* endorsement for transaction 2 in block 1 by peer 2 *)
Definition cp_ed12_2 : trans_endorsed_msg :=
  Trans_endorsed_msg cp_txp12_2
                     (Sig (PubK 2) (hf tx_proposal_field cp_txp12_2)).

(* transaction 2 in block 1 *)
Definition cp_tx12 : transaction :=
  Trans cp_chaincode_id cp_upd_op2 (cp_rset12, cp_wset12) (cp_ed12_1 :: cp_ed12_2 :: nil).

Definition cp_blk1 : block :=
  Blk
    (Blk_header 1
                (hf (list transaction) (cp_tx11 :: cp_tx12 :: nil))
                (hf (list transaction) nil))
    (cp_tx11 :: cp_tx12 :: nil)
    (true :: true :: nil).

Definition wsc :=
  mp_upd chaincode_id world_state beq_cc_id_dec (emp chaincode_id world_state)
         cp_chaincode_id cp_ws.

Definition cp_txp21_1 : tx_proposal_field :=
  TxProposal cp_peer1_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_dc_op1 (TS 3)))
             cp_chaincode_id cp_dc_op1 cp_rset21 cp_wset21.

(* endorsement for transaction 1 in block 2 by peer 1 *)
Definition cp_ed21_1 : trans_endorsed_msg :=
   Trans_endorsed_msg cp_txp21_1
                      (Sig (PubK 1) (hf tx_proposal_field cp_txp21_1)).

Definition cp_txp21_2 : tx_proposal_field :=
  TxProposal cp_peer2_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_dc_op1 (TS 3)))
             cp_chaincode_id cp_dc_op1 cp_rset21 cp_wset21.

(* endorsement for transaction 2 in block 1 by peer 2 *)
Definition cp_ed21_2 : trans_endorsed_msg :=
  Trans_endorsed_msg cp_txp21_2
                     (Sig (PubK 2) (hf tx_proposal_field cp_txp21_2)).

(* transaction 1 in block 2 -- not yet in the block in the beginning *)
Definition cp_tx21 : transaction :=
  Trans cp_chaincode_id cp_dc_op1 (cp_rset21, cp_wset21) (cp_ed21_1 :: cp_ed21_2 :: nil).

Definition cp_txp22_1 : tx_proposal_field :=
  TxProposal cp_peer1_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4)))
             cp_chaincode_id cp_dc_op2 cp_rset22 cp_wset22.

(* endorsement for transaction 2 in block 2 by peer 1 *)
Definition cp_ed22_1 : trans_endorsed_msg :=
   Trans_endorsed_msg cp_txp22_1
                      (Sig (PubK 1) (hf tx_proposal_field cp_txp22_1)).

Definition cp_txp22_2 : tx_proposal_field :=
  TxProposal cp_peer2_id
             (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4)))
             cp_chaincode_id cp_dc_op2 cp_rset22 cp_wset22.

(* endorsement for transaction 2 in block 2 by peer 2 *)
Definition cp_ed22_2 : trans_endorsed_msg :=
   Trans_endorsed_msg cp_txp22_2
                      (Sig (PubK 2) (hf tx_proposal_field cp_txp22_2)).

(* transaction 2 in block 2 -- not yet in the block in the beginning *)
Definition cp_tx22 : transaction :=
  Trans cp_chaincode_id cp_dc_op2 (cp_rset22, cp_wset22) (cp_ed22_1 :: cp_ed22_2 :: nil).

Definition cp_peer1 : peer_node :=
  {| peer_public_key := PubK 1;
     peer_ep_cc := cp_epcc;
     peer_ledger := (Ledger (BC (cp_blk1 :: nil)) wsc);
     peer_pmsgs := nil;
     peer_interp_oper := cp_op_interp |}.

Definition cp_peer2 : peer_node :=
  {| peer_public_key := PubK 2;
     peer_ep_cc := cp_epcc;
     peer_ledger := (Ledger (BC (cp_blk1 :: nil)) wsc);
     peer_pmsgs := nil;
     peer_interp_oper := cp_op_interp |}.

Definition cp_cli : client :=
  {| cli_timestamp := TS 4;
     cli_pending_proposals := nil;
     cli_received_eds := fun hs => nil
  |}.

Definition cp_os : ordering_service :=
  {| os_blk_size := 2;
     os_last_blk_num := 1;
     os_last_blk_hash := (hf (list transaction) (cp_tx11 :: cp_tx12 :: nil));
     os_pending_trans := (cp_tx21 :: nil);
     os_blks_created := (fun n => match n with 1 => Some cp_blk1 | _ => None end)
  |}.

Definition cp_blk2 : block :=
  Blk
    (Blk_header 2
                (hf (list transaction) (cp_tx21 :: cp_tx22 :: nil))
                (hf (list transaction) (cp_tx11 :: cp_tx12 :: nil)))
    (cp_tx21 :: cp_tx22 :: nil)
    (true :: true :: nil).

Definition cp_ws' :=
  mp_upd key (prod val ver) beq_key_dec
         (mp_upd key (prod val ver) beq_key_dec (emp key (prod val ver))
                 car1 (PrimVal 180, Ver 2))
         car2 (PrimVal 270, Ver 2).

Definition wsc' :=
  mp_upd chaincode_id world_state beq_cc_id_dec (emp chaincode_id world_state)
         cp_chaincode_id cp_ws'.

Definition cp_peer1' : peer_node :=
  {| peer_public_key := PubK 1;
     peer_ep_cc := cp_epcc;
     peer_ledger := (Ledger (BC (cp_blk1 :: cp_blk2 :: nil)) wsc');
     peer_pmsgs := nil;
     peer_interp_oper := cp_op_interp |}.

Definition cp_peer2' : peer_node :=
  {| peer_public_key := PubK 2;
     peer_ep_cc := cp_epcc;
     peer_ledger := (Ledger (BC (cp_blk1 :: cp_blk2 :: nil)) wsc');
     peer_pmsgs := nil;
     peer_interp_oper := cp_op_interp |}.

Definition cp_cli' : client :=
  {| cli_timestamp := TS 5;
     cli_pending_proposals := nil;
     cli_received_eds := fun hs => nil
  |}.

Definition cp_blk20 : block :=
  Blk
    (Blk_header 2
                (hf (list transaction) (cp_tx21 :: cp_tx22 :: nil))
                (hf (list transaction) (cp_tx11 :: cp_tx12 :: nil)))
    (cp_tx21 :: cp_tx22 :: nil)
    (nil).

Definition cp_os' : ordering_service :=
  {| os_blk_size := 2;
     os_last_blk_num := 2;
     os_last_blk_hash := (hf (list transaction) (cp_tx21 :: cp_tx22 :: nil));
     os_pending_trans := nil;
     os_blks_created := (fun n => match n with
                                    1 => Some cp_blk1
                                  | 2 => Some cp_blk20
                                  | _ => None
                                  end)
  |}.

Definition multi_step (hf : hash_func) :=
  multi (fun conf conf' => (exists act, (step_rel_act hf act conf conf'))).

Definition cp_clients :=
  mp_upd client_id client beq_cli_id_dec (emp client_id client)
         cp_cli_id cp_cli.

Definition cp_peers :=
  mp_upd peer_id peer_node beq_peer_id_dec
         (mp_upd peer_id peer_node beq_peer_id_dec (emp peer_id peer_node)
                 cp_peer1_id cp_peer1)
         cp_peer2_id cp_peer2.

Definition cp_clients' :=
    mp_upd client_id client beq_cli_id_dec (emp client_id client)
           cp_cli_id cp_cli'.

Definition cp_peers' :=
  mp_upd peer_id peer_node beq_peer_id_dec
         (mp_upd peer_id peer_node beq_peer_id_dec (emp peer_id peer_node)
                 cp_peer1_id cp_peer1')
         cp_peer2_id cp_peer2'.

Lemma cp_peers_1 : cp_peers cp_peer1_id = Some cp_peer1.
Proof.
  unfold cp_peers.
  rewrite mp_upd_neq. rewrite mp_upd_eq. auto.
  intro H. inversion H.
Qed.

Lemma cp_peers_2 : cp_peers cp_peer2_id = Some cp_peer2.
Proof.
  unfold cp_peers.
  rewrite mp_upd_eq.
  auto.
Qed.

Lemma same_rwsets21 :
  same_rwsets_lst
    [Trans_endorsed_msg cp_txp21_1 (Sig (PubK 1) (hf tx_proposal_field cp_txp21_1));
       Trans_endorsed_msg cp_txp21_2 (Sig (PubK 2) (hf tx_proposal_field cp_txp21_2))]
    cp_rset21 cp_wset21.
Proof.
  unfold same_rwsets_lst.
  intros.
  destruct i.
  simpl in H1.
  inversion H1; subst.
  simpl. split; auto.
  destruct i.
  simpl in H1.
  inversion H1; subst.
  simpl. split; auto.
  simpl in H0.
  assert (~(S (S i) < 2)) by lia. apply ex_falso_quodlibet.
  apply H2. auto.
Qed.

Lemma same_rwsets22 :
  same_rwsets_lst
    [Trans_endorsed_msg cp_txp22_1 (Sig (PubK 1) (hf tx_proposal_field cp_txp22_1));
       Trans_endorsed_msg cp_txp22_2 (Sig (PubK 2) (hf tx_proposal_field cp_txp22_2))]
    cp_rset22 cp_wset22.
Proof.
  unfold same_rwsets_lst.
  intros.
  destruct i.
  simpl in H1.
  inversion H1; subst.
  simpl. split; auto.
  destruct i.
  simpl in H1.
  inversion H1; subst.
  simpl. split; auto.
  simpl in H0.
  assert (~(S (S i) < 2)) by lia. apply ex_falso_quodlibet.
  apply H2. auto.
Qed.

Lemma blk_integrate :
  mp_upd nat block beq_nat_dec
         (fun n : nat => match n with | 1 => Some cp_blk1 | _ => None end) 2
         (Blk
            (Blk_header 2 (hf (list transaction) [cp_tx21; cp_tx22])
                        (hf (list transaction) [cp_tx11; cp_tx12]))
            [cp_tx21; cp_tx22] [])
  = (fun n => (
      match n with
        1 => Some cp_blk1
      | 2 => Some (Blk
                     (Blk_header 2 (hf (list transaction) [cp_tx21; cp_tx22])
                                 (hf (list transaction) [cp_tx11; cp_tx12]))
                     [cp_tx21; cp_tx22] [])
      | _ => None
      end)).
Proof.
  unfold mp_upd.
  unfold func_upd.
  apply functional_extensionality. intro j.
  destruct (beq_nat_dec j 2); simpl.
  rewrite e; simpl; auto.
  destruct j; auto.
  destruct j; auto.
  assert (j > 0). lia.
  assert (exists j', j = S j').
  { destruct j. lia. exists j. auto. }
  inversion H0; subst.
  auto.
Qed.

Lemma trans_validate_res :
  trans_lst_validate [cp_tx21; cp_tx22]
    (fun ccid : chaincode_id =>
     match cp_epcc ccid with
     | Some (a, _) => Some a
     | None => None
     end) wsc wsc' [true; true].
Proof.
  eapply Trans_lst_val_inc with
      (ws' := mp_upd key (prod val ver) beq_key_dec
                     (mp_upd key (prod val ver) beq_key_dec (emp key (prod val ver))
                             car1 (PrimVal 180, Ver 2))
                     car2 (PrimVal 300, Ver 1)).
  eauto.
  unfold cp_epcc. unfold cp_tx21; simpl.
  rewrite mp_upd_eq.
  auto.
  unfold cp_tx21; simpl.
  unfold wsc. rewrite mp_upd_eq. auto.

  (* first trans *)
  econstructor.
  unfold cp_tx21. auto.
  unfold cp_ed21_1. unfold cp_ed21_2.
  apply same_rwsets21.
  unfold cp_ed21_1. unfold cp_ed21_2.
  simpl. unfold cp_ep. simpl. auto.
  unfold cp_rset21; simpl. intros.
  destruct (beq_key_dec k car1).
  rewrite e. unfold cp_ws; simpl.
  rewrite mp_upd_neq. rewrite mp_upd_eq.
  rewrite e in H. rewrite mp_upd_eq in H.
  inverts H. exists (PrimVal 200). auto.
  discriminate.
  rewrite mp_upd_neq in H. unfold emp in H; simpl in H.
  inversion H. auto.
  intros.
  destruct (beq_key_dec k car1).
  right. left.
  repeat eexists.
  unfold cp_wset21. rewrite e. rewrite mp_upd_eq. auto.
  rewrite e. unfold cp_ws. rewrite mp_upd_neq. rewrite mp_upd_eq. auto.
  discriminate.
  rewrite e. rewrite mp_upd_neq. rewrite mp_upd_eq. auto.
  discriminate.
  left.
  destruct (beq_key_dec k car2).
  rewrite e. rewrite mp_upd_eq.
  split. unfold cp_wset21. rewrite mp_upd_neq. unfold emp. auto.
  discriminate.
  unfold cp_ws. rewrite mp_upd_eq. auto.
  split.
  unfold cp_wset21. rewrite mp_upd_neq.
  unfold emp. auto. auto.
  rewrite mp_upd_neq. rewrite mp_upd_neq. unfold emp.
  unfold cp_ws. rewrite mp_upd_neq. rewrite mp_upd_neq.
  unfold emp. auto.
  auto. auto. auto. auto.

  eapply Trans_lst_val_inc with
      (ws' := mp_upd key (prod val ver) beq_key_dec
                     (mp_upd key (prod val ver) beq_key_dec (emp key (prod val ver))
                             car1 (PrimVal 180, Ver 2))
                     car2 (PrimVal 270, Ver 2)).
  auto.
  unfold cp_tx22. simpl. unfold cp_epcc. rewrite mp_upd_eq.
  auto.
  unfold cp_tx22. simpl. rewrite mp_upd_eq. auto.

  (* second trans *)
  econstructor.
  unfold cp_tx22. auto.
  unfold cp_ed22_1. unfold cp_ed22_2.
  apply same_rwsets22.
  simpl. unfold cp_ep. auto.
  intros.
  destruct (beq_key_dec k car2).
  exists (PrimVal 300).
  rewrite e.
  rewrite mp_upd_eq.
  rewrite e in H. unfold cp_rset22 in H. rewrite mp_upd_eq in H.
  inverts H. auto.
  unfold cp_rset22 in H. rewrite mp_upd_neq in H.
  unfold emp in H. inversion H. auto.
  intros.
  destruct (beq_key_dec k car2).
  right. left.
  repeat eexists.
  unfold cp_wset22. subst. rewrite mp_upd_eq. auto.
  subst. rewrite mp_upd_eq. auto.
  subst. rewrite mp_upd_eq. auto.
  left.
  destruct (beq_key_dec k car1).
  subst. rewrite mp_upd_neq. rewrite mp_upd_eq. unfold cp_wset22.
  rewrite mp_upd_neq. unfold emp.
  split. auto. rewrite mp_upd_neq. rewrite mp_upd_eq. auto.
  auto.
  auto.
  auto.
  unfold cp_wset22. repeat (rewrite mp_upd_neq; auto).

  (* finalization *)
  unfold cp_epcc. simpl. rewrite mp_upd_mp_upd_eq.
  fold cp_ws'. unfold wsc. rewrite mp_upd_mp_upd_eq. fold wsc'.
  apply Trans_lst_val_empty.
Qed.

Theorem cp_trans_flow :
  multi_step hf
             (cp_clients, (cp_peers, cp_os))
             (cp_clients', (cp_peers', cp_os')).
Proof.
  unfold multi_step.
  remember
    (mp_upd client_id client beq_cli_id_dec cp_clients cp_cli_id
            (inc_cli_timestamp
               (cli_add_pending_propose_msg
                  cp_cli
                  (ProposeMsg (TxField cp_cli_id cp_chaincode_id cp_dc_op2
                                       (cli_timestamp cp_cli)))))) as cp_clients1.
  remember
    (add_pmsg_for_peers
       (ProposeMsg (TxField cp_cli_id cp_chaincode_id cp_dc_op2
                            (cli_timestamp cp_cli)))
       cp_peers [cp_peer1_id; cp_peer2_id]) as cp_peers1.

  apply Multi_step with (y := (cp_clients1, (cp_peers1, cp_os))).
  exists (Act_cli_prop cp_cli_id (cp_peer1_id :: cp_peer2_id :: nil)).
  unfold step_rel_act.
  exists cp_clients. exists cp_peers. exists cp_os.
  exists cp_clients1. exists cp_peers1. exists cp_os.

  split; auto.
  split; auto.

  econstructor.
  (* dig into the first step -- cli prop *)
  unfold cp_clients. rewrite mp_upd_eq. auto.
  intro idx. intro H_idx_in_pid12.
  inversion H_idx_in_pid12.
  exists cp_peer1. rewrite <- H. apply cp_peers_1.
  exists cp_peer2.
  inversion H. rewrite <- H0. apply cp_peers_2.
  inversion H0.
  auto.

  eauto.
  eauto.
  auto.

  (* simp of the clients after the first step *)
  unfold cli_add_pending_propose_msg in Heqcp_clients1.
  unfold cli_pending_proposals in Heqcp_clients1. simpl in Heqcp_clients1.
  unfold upd_cli_pending_proposals in Heqcp_clients1. simpl in Heqcp_clients1.
  unfold inc_cli_timestamp in Heqcp_clients1. simpl in Heqcp_clients1.

  (* simp of the peers after the first step *)
  unfold add_pmsg_for_peers in Heqcp_peers1.
  unfold fold_left in Heqcp_peers1.
  rewrite cp_peers_1 in *. simpl in Heqcp_peers1.
  unfold peer_add_trans_propose_msg in Heqcp_peers1.
  simpl in Heqcp_peers1.
  rewrite func_upd_neq in Heqcp_peers1; auto.
  2: { intro H_neq; inversion H_neq. }
  rewrite cp_peers_2 in Heqcp_peers1.
  unfold cp_peer2 in Heqcp_peers1.
  simpl in Heqcp_peers1.
  unfold upd_peer_pmsgs in Heqcp_peers1; simpl in Heqcp_peers1.

  remember
    (mp_upd
       client_id client beq_cli_id_dec cp_clients1 cp_cli_id
       {| cli_timestamp := TS 5;
          cli_pending_proposals := [ProposeMsg
                                      (TxField cp_cli_id cp_chaincode_id
                                               cp_dc_op2 (TS 4))];
          cli_received_eds :=
            func_upd hash (list trans_endorsed_msg) beq_hash_dec (fun tid => [])
                     (hf tx_field
                         (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4)))
                     [Trans_endorsed_msg
                       cp_txp22_1 (Sig (PubK 1) (hf tx_proposal_field cp_txp22_1))]
       |}) as cp_clients2.

  remember
    (mp_upd peer_id peer_node beq_peer_id_dec cp_peers1 cp_peer1_id
            {| peer_public_key := PubK 1;
               peer_ep_cc := cp_epcc;
               peer_ledger := (Ledger (BC [cp_blk1]) wsc);
               peer_pmsgs := nil;
               peer_interp_oper := cp_op_interp |})
    as cp_peers2.

  apply Multi_step with (y :=  (cp_clients2, (cp_peers2, cp_os))).
  exists (Act_peer_resp cp_peer1_id cp_cli_id).
  unfold step_rel_act.
  exists cp_clients1. exists cp_peers1. exists cp_os.
  exists cp_clients2. exists cp_peers2. exists cp_os.

  split; auto.
  split; auto.

  eapply Step_peer_resp with (pmsg_idx := 0).
  rewrite Heqcp_peers1. rewrite func_upd_neq. rewrite func_upd_eq. auto.
  intro H_neq; inversion H_neq.
  simpl.
  auto.
  unfold peer_pmsgs. simpl. auto.
  auto.
  auto. (* ?tid = ... *)
  unfold cp_epcc. simpl.
  rewrite mp_upd_eq. auto. (* cp_epcc _ = Some (?ep, _) *)
  simpl. right. right. right. left. auto.
  unfold wsc. rewrite mp_upd_eq. auto.
  unfold peer_interp_oper.
  unfold cp_op_interp.
  rewrite func_upd_eq. unfold cp_ws. rewrite mp_upd_eq.
  auto.
  auto.
  simpl. auto. (* ?epsig *)
  auto.

  rewrite Heqcp_clients1. rewrite mp_upd_eq. eauto.
  simpl. fold cp_rset22. fold cp_wset22. fold cp_txp22_1.
  unfold cli_add_endorsed_msg. simpl.
  unfold upd_cli_received_eds. simpl.
  eauto. (* ?clients *)
  unfold upd_peer_pmsgs. simpl.
  eauto. (* ?peers *)
  eauto.

  (* simp of the clients map after the second step *)
  rewrite Heqcp_clients1 in Heqcp_clients2.
  rewrite mp_upd_mp_upd_eq in Heqcp_clients2.

  (* simp of the peers map after the second step *)
  rewrite Heqcp_peers1 in Heqcp_peers2.
  rewrite func_upd_switch in Heqcp_peers2.
  2: { intro H_neq; inversion H_neq. }
  rewrite mp_upd_func_upd_eq in Heqcp_peers2.
  unfold mp_upd in Heqcp_peers2.
  rewrite func_upd_switch in Heqcp_peers2.
  2: { intro H_neq; inversion H_neq. }

  clear Heqcp_clients1; clear Heqcp_peers1.

  remember
    (mp_upd
       client_id client beq_cli_id_dec cp_clients2 cp_cli_id
       {| cli_timestamp := TS 5;
          cli_pending_proposals :=
            [ProposeMsg (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4))];
          cli_received_eds :=
            func_upd hash (list trans_endorsed_msg) beq_hash_dec
                     (fun _ : hash => [])
                     (hf tx_field
                         (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4)))
                     ([Trans_endorsed_msg
                         cp_txp22_1 (Sig (PubK 1) (hf tx_proposal_field cp_txp22_1))]
                        ++
                        [Trans_endorsed_msg
                           cp_txp22_2 (Sig (PubK 2) (hf tx_proposal_field cp_txp22_2))]

                     )%list |})
    as cp_clients3.

  remember
    (mp_upd
       peer_id peer_node beq_peer_id_dec cp_peers2 cp_peer2_id
       {| peer_public_key := PubK 2;
          peer_ep_cc := cp_epcc;
          peer_ledger := (Ledger (BC [cp_blk1]) wsc);
          peer_pmsgs := nil;
          peer_interp_oper := cp_op_interp |})
    as cp_peers3.

  apply Multi_step with (y := (cp_clients3, (cp_peers3, cp_os))).
  exists (Act_peer_resp cp_peer2_id cp_cli_id).

  unfold step_rel_act.
  exists cp_clients2. exists cp_peers2. exists cp_os.
  exists cp_clients3. exists cp_peers3. exists cp_os.

  split; auto.
  split; auto.

  (* look into the third step *)
  eapply Step_peer_resp with (pmsg_idx := 0).
  rewrite Heqcp_peers2. rewrite func_upd_eq. auto.
  simpl. auto.
  unfold peer_pmsgs; simpl.
  auto.
  auto. (* TxField ... *)
  auto.
  unfold cp_epcc. apply mp_upd_eq.
  simpl. right. right. right. left. auto. (* List.In cp_dc_op [...] *)
  unfold wsc. rewrite mp_upd_eq.
  auto.
  unfold peer_interp_oper. unfold cp_op_interp.
  rewrite func_upd_eq.
  unfold cp_ws. rewrite mp_upd_eq. auto. (* (?rset, ?wset) *)
  auto.
  auto.
  auto.
  rewrite Heqcp_clients2. rewrite mp_upd_eq. auto.

  simpl. fold cp_rset22. fold cp_wset22. fold cp_txp22_2.
  unfold cli_add_endorsed_msg. simpl.
  unfold upd_cli_received_eds. simpl.
  rewrite func_upd_eq. rewrite func_upd_func_upd_eq.
  auto. (* ?clients *)

  unfold upd_peer_pmsgs. simpl.
  auto.
  auto.

  (* simp of the clients map after the third step *)
  rewrite Heqcp_clients2 in Heqcp_clients3.
  rewrite mp_upd_mp_upd_eq in Heqcp_clients3.

  (* simp of the peers map after the third step *)
  rewrite Heqcp_peers2 in Heqcp_peers3.
  rewrite mp_upd_func_upd_eq in Heqcp_peers3.
  unfold mp_upd in Heqcp_peers3.

  clear Heqcp_clients2. clear Heqcp_peers2.

  remember
    (mp_upd
       client_id client beq_cli_id_dec cp_clients3 cp_cli_id
       {| cli_timestamp := TS 5;
          cli_pending_proposals := [];
          cli_received_eds :=
            func_upd hash (list trans_endorsed_msg) beq_hash_dec
                     (fun _ : hash => [])
                     (hf tx_field
                         (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4)))
                     [] |})
    as cp_clients4.

  remember
    ({| os_blk_size := 2;
        os_last_blk_num := 1;
        os_last_blk_hash := (hf (list transaction) [cp_tx11; cp_tx12]);
        os_pending_trans :=
          ([cp_tx21]
             ++
             [Trans cp_chaincode_id cp_dc_op2 (cp_rset22, cp_wset22)
                    [Trans_endorsed_msg
                       cp_txp22_1 (Sig (PubK 1) (hf tx_proposal_field cp_txp22_1));
                     Trans_endorsed_msg
                       cp_txp22_2 (Sig (PubK 2) (hf tx_proposal_field cp_txp22_2))]])%list;
        os_blks_created := (fun n : nat => match n with
                                           | 1 => Some cp_blk1
                                           | _ => None
                                           end) |})
    as cp_os4.

  apply Multi_step with (y := (cp_clients4, (cp_peers3, cp_os4))).
  exists (Act_cli_send_trans cp_cli_id).

  unfold step_rel_act.
  exists cp_clients3. exists cp_peers3. exists cp_os.
  exists cp_clients4. exists cp_peers3. exists cp_os4.

  split; auto.
  split; auto.

  (* look into the fourth step *)
  eapply Step_client_send_trans with (prop_idx := 0) (pn1_id := cp_peer1_id).
  (* econstructor. *)
  rewrite Heqcp_clients3. rewrite mp_upd_eq. auto.
  rewrite Heqcp_peers3; simpl.
  rewrite func_upd_neq; auto.
  rewrite func_upd_eq. eauto.
  discriminate.

  unfold upd_cli_pending_proposals. simpl. auto.
  unfold ccid_of_txfield. auto.
  unfold peer_ep_cc. unfold cp_epcc. rewrite mp_upd_eq. auto.
  auto. auto. auto.
  unfold cp_ep. simpl.
  rewrite func_upd_eq. simpl. auto.

  simpl. rewrite func_upd_eq.
  exists cp_rset22. exists cp_wset22.
  split.
  apply same_rwsets22.
  auto.

  simpl.
  auto.  (* ?cli_no_prop *)
  unfold client_clear_emsgs. simpl.
  unfold upd_cli_received_eds. simpl.
  rewrite func_upd_func_upd_eq.
  auto. (* ?clients' *)
  auto. (* ?peers' *)
  unfold upd_os_pending_trans. simpl.
  auto. (* ?os' *)

  rewrite Heqcp_clients3 in Heqcp_clients4.
  simpl in Heqcp_clients4. rewrite mp_upd_mp_upd_eq in Heqcp_clients4.

  clear Heqcp_clients3.

  remember
    ({| os_blk_size := 2;
        os_last_blk_num := 2;
        os_last_blk_hash := (hf (list transaction) [cp_tx21; cp_tx22]);
        os_pending_trans := nil;
        os_blks_created :=
          (fun n : nat =>
             match n with
             | 1 => Some cp_blk1
             | 2 => Some
                      (Blk (Blk_header 2 (hf (list transaction) [cp_tx21; cp_tx22])
                                       (hf (list transaction) [cp_tx11; cp_tx12]))
                           [cp_tx21; cp_tx22] [])
             | _ => None
             end) |})
    as cp_os5.

  apply Multi_step with (y := (cp_clients4, (cp_peers3, cp_os5))).
  exists (Act_ord_crt_blk).
  unfold step_rel_act.

  exists cp_clients4. exists cp_peers3. exists cp_os4.
  exists cp_clients4. exists cp_peers3. exists cp_os5.

  split; auto.
  split; auto.

  (* look into the fifth step *)
  econstructor.

  rewrite Heqcp_os4; simpl.
  auto.
  simpl. rewrite Heqcp_os4. auto.
  rewrite Heqcp_os4. simpl. auto.
  auto.
  rewrite Heqcp_os4. simpl. auto.
  rewrite Heqcp_os4; simpl.
  auto.
  rewrite Heqcp_os4; simpl.
  auto.

  auto. (* ?clients' *)
  auto.
  rewrite Heqcp_os4; simpl.
  unfold upd_os_pending_trans. simpl.
  auto.
  unfold inc_os_blk_num; simpl.
  unfold upd_os_last_blk_hash; simpl.
  unfold os_record_new_blk; simpl.
  unfold blk_no; simpl.
  unfold upd_os_blks_created; simpl.
  fold cp_ed22_1. fold cp_ed22_2.
  fold cp_tx22.
  rewrite blk_integrate.
  auto. (* ?os' *)

  clear Heqcp_os4.

  (* peer2 integrates the new block *)

  remember
    (mp_upd
       peer_id peer_node beq_peer_id_dec cp_peers3 cp_peer2_id
       {|
         peer_public_key := PubK 2;
         peer_ep_cc := cp_epcc;
         peer_ledger := (Ledger (BC [cp_blk1; cp_blk2]) wsc');
         peer_pmsgs := nil;
         peer_interp_oper := cp_op_interp |})
    as cp_peers6.

  eapply Multi_step with (y := (cp_clients4, (cp_peers6, cp_os5))).
  exists (Act_peer_add_blk cp_peer2_id).
  unfold step_rel_act.
  exists cp_clients4. exists cp_peers3. exists cp_os5.
  exists cp_clients4. exists cp_peers6. exists cp_os5.

  split; auto.
  split; auto.

  (* look into the sixth step *)
  eapply Step_peer_add_block with
      (new_blk :=
         (Blk (Blk_header 2
                          (hf (list transaction) [cp_tx21; cp_tx22])
                          (hf (list transaction) [cp_tx11; cp_tx12]))
              [cp_tx21; cp_tx22] [])) (wsc' := wsc') (flags := [true; true]).
  rewrite Heqcp_peers3. rewrite func_upd_eq. auto.
  rewrite Heqcp_os5. unfold blk_no; simpl. auto.
  auto. (* Blk ?new_hdr ?new_trans_lst ?new_valid_lst *)
  simpl. auto.
  split. intro H_len_blks_zero. inversion H_len_blks_zero.
  intro H_len_gt_zero.
  intro last_blk.
  intro H_last_blk_idx.
  simpl in H_last_blk_idx.
  inversion H_last_blk_idx; subst.
  split; auto.
  apply trans_validate_res.
  auto.
  auto.
  unfold peer_update_ledger. simpl.
  unfold upd_peer_ledger. simpl.
  fold cp_blk2. auto. (* ?peers *)
  auto. (* ?os *)

  (* simp of the peers after the sixth step *)
  rewrite Heqcp_peers3 in Heqcp_peers6.
  rewrite mp_upd_func_upd_eq in Heqcp_peers6.
  unfold mp_upd in Heqcp_peers6.
  clear Heqcp_peers3.

  (* peer1 integrates the new block *)

  remember
    (mp_upd
       peer_id peer_node beq_peer_id_dec cp_peers6 cp_peer1_id
       {|
         peer_public_key := PubK 1;
         peer_ep_cc := cp_epcc;
         peer_ledger := (Ledger (BC [cp_blk1; cp_blk2]) wsc');
         peer_pmsgs := nil;
         peer_interp_oper := cp_op_interp |})
    as cp_peers7.

  eapply Multi_step with (y := (cp_clients4, (cp_peers7, cp_os5))).
  exists (Act_peer_add_blk cp_peer1_id).
  unfold step_rel_act.
  exists cp_clients4. exists cp_peers6. exists cp_os5.
  exists cp_clients4. exists cp_peers7. exists cp_os5.

  split; auto.
  split; auto.

  (* look into the seventh step *)
  eapply Step_peer_add_block with
      (new_blk :=
         (Blk (Blk_header 2
                          (hf (list transaction) [cp_tx21; cp_tx22])
                          (hf (list transaction) [cp_tx11; cp_tx12]))
              [cp_tx21; cp_tx22] [])) (wsc' := wsc') (flags := [true; true]).
  rewrite Heqcp_peers6. rewrite func_upd_neq.
  rewrite func_upd_eq. auto.
  discriminate.
  rewrite Heqcp_os5. simpl. auto.
  auto.
  simpl. auto.
  split. intro H_len_blks_zero. inversion H_len_blks_zero.
  intro H_len_gt_zero.
  intro H_last_blk.
  intro H_last_blk_idx.
  simpl in H_last_blk_idx.
  inversion H_last_blk_idx; subst.
  split; auto.
  apply trans_validate_res.
  auto.
  auto. (* ?clients *)
  auto.
  auto.

  rewrite Heqcp_peers6 in Heqcp_peers7.
  rewrite func_upd_switch in Heqcp_peers7.
  2:{ intro H_neq; inversion H_neq. }
  rewrite mp_upd_func_upd_eq in Heqcp_peers7.
  unfold mp_upd in Heqcp_peers7.
  rewrite func_upd_switch in Heqcp_peers7.
  2:{ intro H_neq; inversion H_neq. }
  clear Heqcp_peers6.

  fold cp_peer1' in Heqcp_peers7.
  fold cp_peer2' in Heqcp_peers7.
  asserts_rewrite  (cp_peers7 = cp_peers').
  {
    rewrite Heqcp_peers7. unfold cp_peers'. unfold mp_upd.
    unfold emp. unfold cp_peers.
    repeat unfold mp_upd.
    rewrite func_upd_switch. rewrite func_upd_func_upd_eq.
    rewrite func_upd_switch. rewrite func_upd_func_upd_eq.
    auto.
    discriminate. discriminate.
  }
  clear Heqcp_peers7.

  asserts_rewrite (
      func_upd hash (list trans_endorsed_msg) beq_hash_dec
               (fun _ : hash => [])
               (hf tx_field
                   (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4))) []
      = fun hs => nil) in Heqcp_clients4.
  {
    apply functional_extensionality.
    intro hs.
    unfold func_upd.
    destruct
      (beq_hash_dec
         hs (hf tx_field (TxField cp_cli_id cp_chaincode_id cp_dc_op2 (TS 4))));
      auto.
  }
  fold cp_cli' in Heqcp_clients4.
  asserts_rewrite (cp_clients4 = cp_clients').
  {
    unfold cp_clients'.
    rewrite Heqcp_clients4.
    unfold cp_clients. rewrite mp_upd_mp_upd_eq. auto.
  }
  clear Heqcp_clients4.

  fold cp_blk1 in Heqcp_os5.
  fold cp_blk20 in Heqcp_os5.
  asserts_rewrite (cp_os5 = cp_os').
  {
    unfold cp_os'; auto.
  }

  apply Multi_refl.

Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Decidable setoid equality theory.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Set Implicit Arguments.
Unset Strict Implicit.

Generalizable Variables A B .

(** Export notations. *)

Require Export Coq.Classes.SetoidClass.

(** The [DecidableSetoid] class asserts decidability of a [Setoid].
   It can be useful in proofs to reason more classically. *)

Require Import Coq.Logic.Decidable.

Class DecidableSetoid `(S : Setoid A) :=
  setoid_decidable : forall x y : A, decidable (x == y).

(** The [EqDec] class gives a decision procedure for a particular setoid
   equality. *)

Class EqDec `(S : Setoid A) :=
  equiv_dec : forall x y : A, { x == y } + { x =/= y }.

(** We define the [==] overloaded notation for deciding equality. It does not
   take precedence of [==] defined in the type scope, hence we can have both
   at the same time. *)

Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70).

Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
  match x with
    | left H => @right _ _ H
    | right H => @left _ _ H
  end.

Require Import Coq.Program.Program.

Local Open Scope program_scope.

(** Invert the branches. *)

Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y).

(** Overloaded notation for inequality. *)

Infix "=/=" := nequiv_dec (no associativity, at level 70).

(** Define boolean versions, losing the logical information. *)

Definition equiv_decb `{EqDec A} (x y : A) : bool :=
  if x == y then true else false.

Definition nequiv_decb `{EqDec A} (x y : A) : bool :=
  negb (equiv_decb x y).

Infix "==b" := equiv_decb (no associativity, at level 70).
Infix "<>b" := nequiv_decb (no associativity, at level 70).

(** Decidable leibniz equality instances. *)

Require Import Coq.Arith.Arith.

(** The equiv is burried inside the setoid, but we can recover
  it by specifying which setoid we're talking about. *)

Program Instance eq_setoid A : Setoid A | 10 :=
  { equiv := eq ; setoid_equiv := eq_equivalence }.

Program Instance nat_eq_eqdec : EqDec (eq_setoid nat) :=
  eq_nat_dec.

Require Import Coq.Bool.Bool.

Program Instance bool_eqdec : EqDec (eq_setoid bool) :=
  bool_dec.

Program Instance unit_eqdec : EqDec (eq_setoid unit) :=
  fun x y => in_left.

  Next Obligation.
  Proof.
    destruct x ; destruct y.
    reflexivity.
  Qed.

Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B))
 : EqDec (eq_setoid (prod A B)) :=
  fun x y =>
    let '(x1, x2) := x in
    let '(y1, y2) := y in
    if x1 == y1 then
      if x2 == y2 then in_left
      else in_right
    else in_right.

  Solve Obligations with unfold complement ; program_simpl.

(** Objects of function spaces with countable domains like bool
  have decidable equality. *)

Program Instance bool_function_eqdec `(! EqDec (eq_setoid A))
 : EqDec (eq_setoid (bool -> A)) :=
  fun f g =>
    if f true == g true then
      if f false == g false then in_left
      else in_right
    else in_right.

  Solve Obligations with try red ; unfold complement ; program_simpl.

  Next Obligation.
  Proof.
    extensionality x.
    destruct x ; auto.
  Qed.


Require Import List.
Require Import String.
Require Import ZArith.

Open Scope list_scope.
Open Scope string_scope.
Open Scope Z_scope.

Require Import StructTactics.
Require Import ImpSyntax.
Require Import ImpCommon.
Require Import ImpEval.
Require Import ImpSemanticsFacts.

Import ListNotations.

Lemma eval_stmt_while_elim :
  forall (I : store -> heap -> Prop) env s h e p s' h',
    I s h ->
    (forall s0 h0 s1 h1,
        I s0 h0 ->
        eval_e s0 h0 e (Vbool true) ->
        eval_s env s0 h0 p s1 h1 ->
        I s1 h1) ->
    eval_s env s h (Swhile e p) s' h' ->
    I s' h' /\ eval_e s' h' e (Vbool false).
Proof.
  intros.
  prep_induction H1.
  induction H1; intros; subst;
    try discriminate; find_inversion; eauto.
Qed.

Lemma read_write_same :
  forall h h' a x,
    write h a x = Some h' ->
    read h' a = Some x.
Proof.
  induction h; simpl; intros.
  - discriminate.
  - repeat break_match; repeat find_inversion; auto; try congruence.
    all: cbn [read]; auto.
Qed.

Lemma read_write_neq :
  forall h h' a b x,
    write h a x = Some h' ->
    a <> b ->
    read h' b = read h b.
Proof.
  induction h; simpl; intros.
  - discriminate.
  - repeat break_match; repeat find_inversion; try congruence.
    all: cbn[read]; eauto.
    all: eapply IHh; eauto; omega.
Qed.

Lemma read_write_nop :
  forall h a x,
    read h a = Some x ->
    write h a x = Some h.
Proof.
  induction h; simpl; intros.
  - discriminate.
  - destruct a0.
    + solve_by_inversion.
    + rewrite IHh; auto.
    + rewrite IHh; auto.
Qed.

Fixpoint array_at' (base : Z) (contents : list Z) (h : heap) : Prop :=
  match contents with
  | [] => True
  | z :: contents => read h base = Some (Vint z) /\ array_at' (base + 1) contents h
  end.

Lemma array_at'_read_nth_error :
  forall contents base h x i,
    array_at' base contents h ->
    0 <= i < Zlength contents ->
    read h (base + i) = Some (Vint x) ->
    nth_error contents (Z.to_nat i) = Some x.
Proof.
  induction contents; simpl; intros.
  - rewrite Zlength_nil in *. omega.
  - rewrite Zlength_cons in *. break_and.
    destruct (Z.to_nat i) eqn:?.
    + simpl. change 0%nat with (Z.to_nat 0) in Heqn.
      apply Z2Nat.inj in Heqn; try omega.
      subst i.
      rewrite Z.add_0_r in *. congruence.
    + simpl. zify.
      rewrite Z2Nat.id in * by auto.
      assert (0 < i) by omega.
      subst i.
      rewrite <- Nat2Z.id with (n := n).
      eapply IHcontents; eauto.
      * omega.
      * rewrite <- H1. f_equal. omega.
Qed.

Definition array_at (base : Z) (contents : list Z) (h : heap) : Prop :=
  match read h base with
  | None => False
  | Some l => l = Vint (Zlength contents) /\
             array_at' (base + 1) contents h
  end.

Lemma array_at_array_at' :
  forall a l h,
    array_at a l h ->
    array_at' (a + 1) l h.
Proof.
  unfold array_at.
  intros.
  break_match; intuition.
Qed.

Lemma array_at'_extend_r :
  forall l h a i x,
    array_at' a l h ->
    read h i = Some (Vint x) ->
    i = a + Zlength l ->
    array_at' a (l ++ [x]) h.
Proof.
  induction l; intros.
  - rewrite Zlength_correct in *.
    simpl in *.
    intuition.
    assert (i = a) by omega.
    subst a.
    auto.
  - rewrite Zlength_correct in *.
    simpl in *. intuition.
    eapply IHl; eauto.
    zify. omega.
Qed.

Lemma array_at'_extend_l :
  forall l h a x,
    array_at' (a + 1) l h ->
    read h a = Some (Vint x) ->
    array_at' a (x :: l) h.
Proof.
  intros.
  simpl.
  intuition.
Qed.

Lemma array_at'_write_preserve :
  forall l h h' a i x,
    array_at' a l h ->
    write h i x = Some h' ->
    ~ a <= i < a + Zlength l ->
    array_at' a l h'.
Proof.
  induction l; intros.
  - simpl. auto.
  - cbn [array_at'] in *. break_and.
    rewrite Zlength_correct in *.
    cbn [Datatypes.length] in *.
    split.
    + erewrite read_write_neq; eauto.
      zify. omega.
    + eapply IHl; eauto.
      zify. omega.
Qed.

Lemma array_at'_write_extend_r :
  forall l h h' a i x,
    array_at' a l h ->
    write h i (Vint x) = Some h' ->
    i = a + Zlength l ->
    array_at' a (l ++ [x]) h'.
Proof.
  intros.
  eapply array_at'_extend_r.
  eapply array_at'_write_preserve.
  eauto.
  eauto.
  omega.
  erewrite read_write_same; eauto.
  auto.
Qed.

Lemma array_at'_write_extend_l :
  forall l h h' a x,
    array_at' (a + 1) l h ->
    write h a (Vint x) = Some h' ->
    array_at' a (x :: l) h'.
Proof.
  intros.
  eapply array_at'_extend_l.
  eapply array_at'_write_preserve.
  eauto.
  eauto.
  omega.
  erewrite read_write_same; eauto.
Qed.

Lemma array_at'_shrink_r :
  forall l a h,
    array_at' a l h ->
    array_at' a (removelast l) h.
Proof.
  induction l; simpl; repeat break_match; intuition.
  cbn [array_at']. intuition.
Qed.

Lemma array_at'_read_nth :
  forall contents base h i d,
    array_at' base contents h ->
    0 <= i < Zlength contents ->
    read h (base + i) = Some (Vint (nth (Z.to_nat i) contents d)).
Proof.
    induction contents; simpl; intros.
  - rewrite Zlength_nil in *. omega.
  - rewrite Zlength_cons in *. break_and.
    destruct (Z.to_nat i) eqn:?.
    + simpl. change 0%nat with (Z.to_nat 0) in Heqn.
      apply Z2Nat.inj in Heqn; try omega.
      subst i.
      rewrite Z.add_0_r in *. congruence.
    + simpl. zify.
      rewrite Z2Nat.id in * by auto.
      assert (0 < i) by omega.
      subst i.
      replace (base + Z.succ (Z.of_nat n)) with ((base + 1) + Z.of_nat n) by omega.
      erewrite IHcontents; eauto; try omega.
      rewrite !Nat2Z.id. eauto.
Qed.

Lemma array_at'_app :
  forall l1 a1 a2 l2 h,
    array_at' a1 l1 h ->
    array_at' a2 l2 h ->
    a2 = a1 + Zlength l1 ->
    array_at' a1 (l1 ++ l2) h.
Proof.
  induction l1; simpl; intuition.
  - rewrite Zlength_nil in *.
    assert (a2 = a1) by omega.
    subst a1.
    auto.
  - rewrite Zlength_correct in *.
    cbn [Datatypes.length] in *.
    eapply IHl1; eauto.
    zify. omega.
Qed.

Lemma lkup_update :
  forall s x1 x2 v,
    lkup (update s x1 v) x2 = if String.string_dec x1 x2 then Some v else lkup s x2.
Proof.
  induction s; simpl; intros.
  - repeat break_if; congruence.
  - repeat (break_match; simpl in * ); try congruence.
    + rewrite IHs. break_if; congruence.
    + rewrite IHs. break_if; congruence.
Qed.

Lemma lkup_update_neq :
  forall s x1 x2 v,
    x1 <> x2 ->
    lkup (update s x1 v) x2 = lkup s x2.
Proof.
  intros.
  rewrite lkup_update.
  break_if; congruence.
Qed.

Lemma lkup_update_same :
  forall s x v,
    lkup (update s x v) x = Some v.
Proof.
  intros.
  rewrite lkup_update.
  break_if; congruence.
Qed.

Lemma array_at_read_nth_error :
  forall a contents h i x,
    array_at a contents h ->
    0 <= i < Zlength contents ->
    read h (Z.succ (a + i)) = Some (Vint x) ->
    nth_error contents (Z.to_nat i) = Some x.
Proof.
  unfold array_at.
  intros.
  break_match; intuition.
  subst v.
  eapply array_at'_read_nth_error. eauto. omega.
  rewrite <- H1. f_equal. omega.
Qed.

Lemma array_at_read_length :
  forall a contents h,
    array_at a contents h ->
    read h a = Some (Vint (Zlength contents)).
Proof.
  unfold array_at.
  intros.
  break_match; intuition.
  congruence.
Qed.

Hint Constructors eval_e.
Hint Constructors eval_binop.
Hint Extern 3 (lkup (update _ _ _) _ = _) => rewrite lkup_update_neq by discriminate.

Ltac break_eval_expr :=
  repeat match goal with
  | [ H : eval_unop _ _ ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_binop ?op _ _ ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_e _ _ (Eval _) ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_e _ _ (Evar _) ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_e _ _ (Eop1 _ _) ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_e _ _ (Eop2 _ _ _) ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_e _ _ (Eidx _ _) ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_e _ _ (Eidx ?a ?b) _ |- _ ] =>
    eapply eval_e_idx_a_inv with (e1 := a) (e2 := b) in H; eauto; [idtac]
  | [ H : eval_e _ _ (Elen _) ?x |- _ ] => remember x; invc H; [idtac]
  | [ H : eval_e _ _ (Elen _) ?x |- _ ] =>
    eapply eval_e_len_a_inv in H; eauto using array_at_read_length; [idtac]
  end.

Ltac step_forward :=
  match goal with
  | [ H : eval_s _ _ _ Snop _ _ |- _ ] => invc H
  | [ H : eval_s _ _ _ (Sset _ _) _ _ |- _ ] => invc H
  | [ H : eval_s _ _ _ (Swrite _ _ _) _ _ |- _ ] => invc H
  | [ H : eval_s _ _ _ (Salloc _ _ _) _ _ |- _ ] => invc H
  | [ H : eval_s _ _ _ (Scall _ _ _) _ _ |- _ ] => invc H
  | [ H : eval_s _ _ _ (Sseq _ _) _ _ |- _ ] => invc H
  | [ H : eval_s _ _ _ (Sifelse _ _ _) _ _ |- _ ] => invc H
  end.

Lemma pred_of_dec_true_elim :
  forall A (B : A -> A -> Prop)
    (dec : (forall a1 a2 : A, {B a1 a2} + {~ B a1 a2})) a1 a2,
    pred_of_dec dec a1 a2 = true ->
    B a1 a2.
Proof.
  unfold pred_of_dec.
  intros.
  break_if; congruence.
Qed.

Lemma pred_of_dec_false_elim :
  forall A (B : A -> A -> Prop)
    (dec : (forall a1 a2 : A, {B a1 a2} + {~ B a1 a2})) a1 a2,
    pred_of_dec dec a1 a2 = false ->
    ~ B a1 a2.
Proof.
  unfold pred_of_dec.
  intros.
  break_if; congruence.
Qed.

Ltac normalize_Z :=
      repeat rewrite !Z.add_assoc in *;
      repeat
        match goal with
        | [ H : array_at' ?x _ _ |- _ ] => revert H
        | [ H : read _ ?x = _  |- _ ] => revert H
        | [ H : write _ ?x _ = _  |- _ ] => revert H
        end;
      repeat (match goal with
        | [ |- array_at' ?x _ _ -> _ ] => ring_simplify x
        | [ |- read _ ?x = _ -> _ ] => ring_simplify x
        | [ |- write _ ?x _ = _ -> _ ] => ring_simplify x
        end; intro);
      repeat match goal with
      | [ |- array_at' ?x _ _ ] => ring_simplify x
      end;
      repeat match goal with
      | [ |- read _ ?x = _ ] => ring_simplify x
      end;
      repeat match goal with
      | [ |- write _ ?x _ = _ ] => ring_simplify x
      end.

Definition after env s h p (Q : store -> heap -> Prop) : Prop :=
  exists s' h',
    eval_s env s h p s' h' /\ Q s' h'.

Lemma after_seq :
  forall env s h p1 p2 Q,
    after env s h p1 (fun s' h' => after env s' h' p2 Q) ->
    after env s h (Sseq p1 p2) Q.
Proof.
  unfold after.
  intros.
  break_exists.
  break_and.
  break_exists.
  break_and.
  eauto using eval_seq.
Qed.

Lemma after_set :
  forall env s h x e v (Q : store -> heap -> Prop),
    eval_e s h e v ->
    Q (update s x v) h ->
    after env s h (Sset x e) Q.
Proof.
  unfold after.
  intros.
  eauto using eval_set.
Qed.

Lemma eval_stmt_while_intro :
  forall (I : store -> heap -> Prop) (f : store -> nat) env s h e p,
    I s h ->
    (forall s0 h0,
        I s0 h0 ->
        exists b,
          eval_e s0 h0 e (Vbool b)) ->
    (forall s0 h0,
        I s0 h0 ->
        eval_e s0 h0 e (Vbool true) ->
        exists s1 h1,
          eval_s env s0 h0 p s1 h1 /\
          I s1 h1 /\
          (f s1 < f s0)%nat) ->
    exists s' h',
      eval_s env s h (Swhile e p) s' h' /\
      I s' h' /\
      eval_e s' h' e (Vbool false).
Proof.
  intros.
  assert (forall n s h, (f s < n)%nat -> I s h ->
                   exists s1 h1,
                     eval_s env s h (Swhile e p) s1 h1 /\
                     I s1 h1 /\
                     eval_e s1 h1 e (Vbool false) /\
                     (f s1 <= f s)%nat).
  {
    induction n; intros.
    - omega.
    - copy_apply H0 H3.
      break_exists.
      destruct b.
      + copy_eapply H1 H4; eauto.
        break_exists. break_and.
        eapply IHn in H6; [|omega].
        break_exists_exists.
        intuition.
        eauto using eval_while_t.
      + eauto 10 using eval_while_f.
  }

  apply H2 with (n := S (f s)) in H; [|omega].
  break_exists_exists.
  intuition.
Qed.

Lemma after_while :
  forall env s h e p (I Q : store -> heap -> Prop) (f : store -> nat),
    (forall s0 h0, I s0 h0 -> exists b, eval_e s0 h0 e (Vbool b)) ->
    I s h ->
    (forall s0 h0, I s0 h0 -> eval_e s0 h0 e (Vbool true) ->
              after env s0 h0 p (fun s1 h1 => I s1 h1 /\ (f s1 < f s0)%nat)) ->
    (forall s0 h0, I s0 h0 -> eval_e s0 h0 e (Vbool false) -> Q s0 h0) ->
    after env s h (Swhile e p) Q.
Proof.
  unfold after.
  intros.
  pose proof eval_stmt_while_intro I f env s h e p.
  repeat concludes.
  firstorder.
Qed.

Lemma nth_error_nth :
  forall A (l : list A) n x d,
    nth_error l n = Some x ->
    nth n l d = x.
Proof.
  induction l; destruct n; simpl; intros; try discriminate.
  - congruence.
  - eauto.
Qed.

Lemma nth_nth_error :
  forall A (l : list A) n d,
    (0 <= n < Datatypes.length l)%nat ->
    nth_error l n = Some (nth n l d).
Proof.
  induction l; destruct n; simpl; intros.
  - omega.
  - omega.
  - auto.
  - apply IHl. omega.
Qed.

Lemma array_at'_nth_error_read :
  forall contents base h x i,
    array_at' base contents h ->
    0 <= i < Zlength contents ->
    nth_error contents (Z.to_nat i) = Some x ->
    read h (base + i) = Some (Vint x).
Proof.
  induction contents; simpl; intros.
  - rewrite Zlength_nil in *. omega.
  - break_and.
    generalize dependent i.
    refine (natlike_ind _ _ _); intros.
    + simpl in *. find_inversion. rewrite Z.add_0_r. auto.
    + rewrite Z2Nat.inj_succ in * by auto.
      simpl in *.
      rewrite <- Z.add_succ_comm.
      apply IHcontents; auto.
      rewrite Zlength_cons in *. omega.
Qed.

Lemma array_at'_nth_read :
  forall contents base h i,
    array_at' base contents h ->
    0 <= i < Zlength contents ->
    read h (base + i) = Some (Vint (nth (Z.to_nat i) contents 0)).
Proof.
  intros.
  assert (exists x, nth_error contents (Z.to_nat i) = Some x).
  {
    destruct (nth_error contents (Z.to_nat i)) eqn:?; eauto.
    exfalso.
    find_apply_lem_hyp nth_error_None.
    rewrite Zlength_correct in *.
    zify. rewrite Z2Nat.id in * by omega. omega. }
  break_exists.
  eapply array_at'_nth_error_read; eauto.
  erewrite nth_error_nth; eauto.
Qed.

Lemma array_at_read_nth :
  forall contents base h i,
    array_at base contents h ->
    0 <= i < Zlength contents ->
    read h (Z.succ (base + i)) = Some (Vint (nth (Z.to_nat i) contents 0)).
Proof.
  intros.
  rewrite <- Z.add_succ_l.
  eapply array_at'_nth_read.
  eauto using array_at_array_at'.
  auto.
Qed.


(** * Identity pseudofunctor *)
Require Import FunctorCategory.Morphisms.
Require Import Category.Core Functor.Core.
Require Import NaturalTransformation.Isomorphisms.
Require Import NaturalTransformation.Paths.
Require Import Cat.Core.
Require Import Pseudofunctor.Core.

(** Bring things into scope. *)
Import NaturalTransformation.Identity.
Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Import Category.Morphisms.
Import FunctorCategory.Core.

Require Import PathGroupoids.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope natural_transformation_scope.

Section identity.
  Context `{Funext}.

  Variable P : PreCategory -> Type.
  Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation cat := (@sub_pre_cat _ P HF).

  Local Ltac t :=
    path_natural_transformation;
    abstract (
        autorewrite with functor morphism;
        unfold morphism_isomorphic;
        rewrite ap_idmap, idtoiso_components_of;
        rewrite ?Functor.Composition.Laws.associativity_fst,
        ?Functor.Composition.Laws.left_identity_fst,
        ?Functor.Composition.Laws.right_identity_fst;
        reflexivity
      ).

  Lemma identity_associativity
        (w x y z : PreCategory) (f : Functor w x)
        (g : Functor x y) (h : Functor y z)
  : associator_1 h g f o (1 oR f o 1) =
    h oL 1 o (1 o @morphism_isomorphic _ _ _ (idtoiso (w -> z) (ap idmap (Functor.Composition.Laws.associativity f g h)))).
  Proof.
    t.
  Defined.

  Lemma identity_left_identity
        (x y : PreCategory) (f : Functor x y)
  : 1 oR f o 1 =
    (left_identity_natural_transformation_2 f)
      o @morphism_isomorphic _ _ _ (idtoiso (x -> y) (ap idmap (Functor.Composition.Laws.left_identity f))).
  Proof.
    t.
  Defined.

  Lemma identity_right_identity
        (x y : PreCategory) (f : Functor x y)
  : f oL 1 o 1 =
    (right_identity_natural_transformation_2 f)
      o @morphism_isomorphic _ _ _ (idtoiso (x -> y) (ap idmap (Functor.Composition.Laws.right_identity f))).
  Proof.
    t.
  Defined.

  (** There is an identity pseudofunctor.  It does the obvious thing. *)
  Definition identity : Pseudofunctor cat
    := Build_Pseudofunctor
         cat
         (fun C => C.1)
         (fun _ _ F => F)
         (fun _ _ _ _ _ => reflexivity _)
         (fun _ => reflexivity _)
         (fun x y z w => @identity_associativity x.1 y.1 z.1 w.1)
         (fun x y => @identity_left_identity x.1 y.1)
         (fun x y => @identity_right_identity x.1 y.1).
End identity.

Module Export PseudofunctorIdentityNotations.
  Notation "1" := (identity _) : pseudofunctor_scope.
End PseudofunctorIdentityNotations.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

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

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

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

*)

Require Export chalts.
Require Export sequents_tacs2.
Require Export cequiv_props.
Require Export subst_tacs.
Require Export per_props_equality.
Require Export per_can.
Require Export computation_cft.
Require Export cequiv_props2.
Require Export list. (* why? *)

(* [18] ============ ISPAIR (and other canonical form test) EXCEPTION CASES ============ *)

(*   H |- a = b in T

     By ispairExceptionCases

     H |- isexc(it t is a pair then u else v )
     H, x : has_value(u) |- a = b in T
     H, x : isexc(t) |- a = b in T
     H |- t in Base
 *)
Definition rule_can_test_exception_cases {o}
           (H : barehypotheses)
           test
           (a b T t u v: @NTerm o)
           (x: NVar) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality a b T)))
    [ mk_baresequent H (mk_conclax (mk_isexc (mk_can_test test t u v))),
      mk_baresequent (snoc H (mk_hyp x ( mk_halts t)))
                     (mk_conclax (mk_equality a b T)),
      mk_baresequent (snoc H (mk_hyp x (mk_isexc t)))
                     (mk_conclax (mk_equality a b T)),
      mk_baresequent H (mk_conclax (mk_member t mk_base))
    ]
    [].

Lemma rule_can_test_exception_cases_true {o} :
  forall lib test (a b T t u v : NTerm),
  forall x : NVar,
  forall H : @barehypotheses o,
    rule_true lib (rule_can_test_exception_cases H test a b T t u v x).
Proof.
  unfold rule_can_test_exception_cases, rule_true, closed_type_baresequent,
                closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract H (mk_conclax (mk_equality a b T))) as cs.
  clear hyp1 hyp2 hyp3 hyp4.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars u)
          # !LIn x (free_vars v)
          # !LIn x (free_vars T)
          # !LIn x (free_vars b)
          # !LIn x (free_vars a)
          # !LIn x (vars_hyps H)) as vhyps.

  clear hyp1 hyp2 hyp3 hyp4.
   dwfseq.
  sp; GC;
  try (complete (discover; allapply @subset_hs_vars_hyps; sp)).

  destruct vhyps as [ nxu vhyps ].
  destruct vhyps as [ nxv vhyps ].
  destruct vhyps as [ nxT vhyps ].
  destruct vhyps as [ nxb vhyps ].
  destruct vhyps as [ nxa nxH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  exrepnd.

  lsubst_tac.
  allrw @tequality_mkc_isexc.
  allrw <- @member_isexc_iff.
  applydup hyp0 in hyp1.
  clear hyp0.
  rw <- @member_equality_iff.
  rw @tequality_mkc_equality.

  apply if_raises_exceptionc_can_test in hyp1.
  repndors; exrepnd.

  - (* t raises exception *)
    vr_seq_true in hyp3.
    pose proof (hyp3 (snoc s1 (x,mkc_axiom)) (snoc s2 (x,mkc_axiom))) as hyp.
    clear hyp3.
    repeat (autodimp hyp hyp').

    { apply hyps_functionality_snoc2; simpl; auto;[].
      introv equ' sim'.
      lsubst_tac.
      apply tequality_mkc_isexc.
      split; intro h; auto. GC;[].

      vr_seq_true in hyp4.

      pose proof (hyp4 s1 s') as hyp; clear hyp4.
      repeat (autodimp hyp hyp');[].
      exrepnd.
      lsubst_tac.
      apply tequality_mkc_member_base in hyp0.
      apply cequiv_stable in hyp0.
     eapply raises_exceptionc_preserves_cequivc;[exact hyp0|]; auto.
    }

    { assert (wf_term (mk_isexc t))as wit.
      { apply wf_isexc; auto. }
      assert (cover_vars (mk_isexc t) s1) as cvit.
      { apply cover_vars_isexc; auto. }
      sim_snoc.
      dands; auto.
      lsubst_tac.
      apply member_isexc_iff; auto.
    }

    exrepnd.
    lsubst_tac.
    rw <- @member_equality_iff in hyp3.
    rw @tequality_mkc_equality in hyp0; repnd.
    sp.

  - (* t has a value,  so we use hyp2 *)
    vr_seq_true in hyp2.
     pose proof (hyp2 (snoc s1 (x,mkc_axiom)) (snoc s2 (x,mkc_axiom))) as hyp.
    clear hyp2.
    repeat (autodimp hyp hyp').
     { (* Hyp Functionality *)
      apply hyps_functionality_snoc2; simpl; auto.
      -  introv equ' sim'.
        lsubst_tac.
     (* because by hyp4, t in Base,  halts(t) is well formed *)

      vr_seq_true in hyp4.

      pose proof (hyp4 s1 s') as hyp; clear hyp4.
      repeat (autodimp hyp hyp');[].
      exrepnd.
      lsubst_tac.
      apply tequality_mkc_member_base in hyp0.
      apply cequiv_stable in hyp0.
      generalize_lsubstc_terms t1.
      generalize_lsubstc_terms t2.
       apply tequality_mkc_halts.
      split; introv hlts.
      apply cequivc_preserves_chaltsc in hyp0; auto.
      apply cequivc_sym in hyp0.
      apply cequivc_preserves_chaltsc in hyp0; auto.
      }
    { (* Similarity *)
      assert (wf_term (mk_halts t)) as wit. apply wf_halts; auto.
      assert (cover_vars (mk_halts t) s1) as cvit.
      { apply cover_vars_halts; dands; auto.
      }
      sim_snoc.
      dands; auto.
      lsubst_tac.
      apply equality_in_halts.
      sp; spcast; try (apply computes_to_valc_refl); eauto 3 with slow.
    }

   { (* Functionality and Truth *)
    exrepnd.
    lsubst_tac.
    rw <- @member_equality_iff in hyp2.
    rw @tequality_mkc_equality in hyp0; repnd.
    sp.
   }
Qed.

(* begin hide *)

(* end hide *)

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


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Monad.
Require Export Category.Functor.Structure.Monoidal.
Require Export Category.Instance.Fun.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Transformer.

Context {C : Category}.
Context {M : C ⟶ C}.
Context `{@Monad C M}.
Context {T : (C ⟶ C) -> (C ⟶ C)}.
Context `{@Monad C (T M)}.

Class MonadTransformer := {
  lift {a} : M a ~> T M a;

  lift_return {a} : lift ∘ @ret C M _ a ≈ ret;
  lift_bind {a b} (f : a ~> M b) :
    lift ∘ join ∘ fmap f ≈ join ∘ fmap (lift ∘ f) ∘ lift
}.

End Transformer.

Arguments MonadTransformer {_ _ _} T {_}.

(******************************************************************************
 * Species 1: Identity transformations.
 ******************************************************************************)

Program Definition IdentityT {C : Category} (M : C ⟶ C) : C ⟶ C := {|
  fobj := fobj[M];
  fmap := fun _ _ => fmap[M]
|}.
Next Obligation. apply fmap_comp. Qed.

Program Definition IdentityT_Monad {C : Category} (M : C ⟶ C) `{@Monad C M} :
  @Monad C (@IdentityT C M) := {|
  ret  := fun _ => ret[M];
  join := fun _ => join[M]
|}.
Next Obligation. destruct H; intuition. Qed.
Next Obligation. destruct H; intuition. Qed.
Next Obligation. destruct H; intuition. Qed.
Next Obligation. destruct H; intuition. Qed.
Next Obligation. destruct H; intuition. Qed.

Program Instance IdentityT_MonadTransformer {C : Category} (M : C ⟶ C) `{@Monad C M} :
  @MonadTransformer C M _ (@IdentityT C) (IdentityT_Monad M) := {
  lift := fun _ => id
}.

(*
(******************************************************************************)
(* Free monad transformer *)
(******************************************************************************)

Inductive FreeF (F : Type -> Type) (A B : Type) :=
  | PureF : A -> FreeF F A B
  | JoinF : F B -> FreeF F A B.

Inductive FreeT (F : Type -> Type) (M : Type -> Type) (A : Type) :=
  | mkFreeT : forall x, (x -> FreeT F M A) -> M (FreeF F A x) -> FreeT F M A.

Import MonadLaws.

Class MonadTransformerLaws `{MonadLaws M} `{FunctorLaws F} := {
  _ : Monad (FreeT F M);
  _ : MonadLaws (FreeT F M)
}.

(******************************************************************************)
(* Algebraic monad transformer *)
(******************************************************************************)

(* Q: Are they traversable? *)

Inductive Alg (c f g : Type -> Type) a :=
  | Const : c a -> Alg c f g a
  | Unit  : f a -> Alg c f g a
  | Prod  : f a * g a -> Alg c f g a
  | Sum   : f a + g a -> Alg c f g a.

(* Theorem: For all algebraic monads, we should be able to automatically
   derive prod from MonadCompose. *)

(* Program Instance Alg_Distributes (c t : Type -> Type) : *)
(*   Monad_Distributes Alg c t. *)

(* Program Instance Alg_DistributesLaws (c t : Type -> Type) : *)
(*   Monad_DistributesLaws Alg c t. *)

(******************************************************************************)
(* Monad transformer of a certain subclass of exponential monads *)
(******************************************************************************)

(* Q: Are they distributive? *)

(* M : Monad *)
(* C : Contravariant *)

(* M t = 1 *)
(* M t = t *)
(* M t = C t -> t *)
(* M t = A t * B t *)
(* M t = A t + t (??) *)

(* Theorem: Does M have a monad instance for any contravariant functor C? *)

(* For monads M and L: T M L t = M (L t) *)

(* M (r -> a) *)
(* r -> M a *)

(* c -> t            =>     c -> L t *)
(* (t -> c) -> t     =>     (L t -> c) -> L t *)

(******************************************************************************)
(* Monad transformers of monads from adjunctions *)
(******************************************************************************)

(* F ⊣ U *)

(* U ∘ F    T L = U ∘ L ∘ F *)

(* ULFULF = id *)
(* ULLF -> ULF : by join of L *)

(* MaybeT (State s) a =    StateT s Maybe a *)
(* s -> s * L t       =    s -> L (s * t) *)

(* Q : Is MaybeT (State s) a incorrect? *)

(* (ReaderT $ StateT $ ...) *)

(* T (t1 ∘ t2 ∘ t3 (l)) m *)

(* t1 ∘ t2 ∘ t3 ∘ tl (m ) *)
*)

(******************************************************************************
 * Species 2: Constant mapping transformations.
 ******************************************************************************)

Program Definition ConstT {C : Category} (K M : C ⟶ C) : C ⟶ C := {|
  fobj := fobj[K];
  fmap := fun _ _ => fmap[K]
|}.
Next Obligation. apply fmap_comp. Qed.

Program Definition ConstT_Monad {C : Category} (K M : C ⟶ C) `{@Monad C K} :
  @Monad C (@ConstT C K M) := {|
  ret  := fun _ => ret[K];
  join := fun _ => join[K]
|}.
Next Obligation. apply H. Qed.
Next Obligation. apply H. Qed.
Next Obligation. apply H. Qed.
Next Obligation. apply H. Qed.
Next Obligation. apply H. Qed.

(* This is not a valid monad transformer, since there cannot be a morphism
   [M A ~> K A]. *)
Fail Definition ConstT_MonadTransformer {C : Category} (K M : C ⟶ C)
        `{@Monad C K} `{@Monad C M} :
  @MonadTransformer C M _ (@ConstT C K) (ConstT_Monad K M) := {|
  lift := fun _ => _
|}.


(* This program is free software; you can redistribute it and/or      *)
(* modify it 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 program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Tiroirs.
Require Export Parts2.
Require Export Classical_Pred_Type.
Require Export Compare_dec.

Lemma not_injective_prop :
 forall (A B : Setoid) (f : MAP A B),
 ~ injective f ->
 exists x : A, (exists y : A, ~ Equal x y /\ Equal (f x) (f y)).
unfold injective in |- *.
intros A B f H'; try assumption.
cut
 (ex
    (fun x : A =>
     ~ (forall y : A, ~ (~ Equal x y /\ Equal (Ap f x) (Ap f y))))).
intros H'0; try assumption.
elim H'0; intros x E; try exact E; clear H'0.
exists x; try assumption.
cut (ex (fun y : A => ~ ~ (~ Equal x y /\ Equal (Ap f x) (Ap f y)))).
intros H'0; try assumption.
elim H'0; intros y E0; try exact E0; clear H'0.
exists y; try assumption.
apply NNPP; auto with *.
apply
 not_all_ex_not
  with (P := fun y : A => ~ (~ Equal x y /\ Equal (Ap f x) (Ap f y)));
 auto with *.
apply
 not_all_ex_not
  with
    (P := fun x : A =>
          forall y : A, ~ (~ Equal x y /\ Equal (Ap f x) (Ap f y)));
 auto with *.
red in |- *.
intros H'0; try assumption.
apply H'.
intros x y H'1; try assumption.
specialize  H'0 with (n := x) (y := y); rename H'0 into H'3; try exact H'3.
apply NNPP; tauto.
Qed.

Lemma not_surjective_prop :
 forall (A B : Setoid) (f : MAP A B),
 ~ surjective f -> exists y : B, ~ in_part y (image_map f).
intros A B f H'; try assumption.
apply not_all_ex_not with (P := fun y : B => in_part y (image_map f)).
red in |- *.
red in H'.
intros H'0; try assumption.
lapply H'; [ intros H'1; try exact H'1; clear H' | clear H' ].
red in |- *.
simpl in H'0.
intros y; try assumption.
elim (H'0 y); intros x E; elim E; intros H'1 H'2; try exact H'2; clear E.
exists x; try assumption.
Qed.
Parameter
  image_empty :
    forall (E F : Setoid) (f : MAP E F) (A : part_set E),
    Equal A (empty E) -> Equal (image f A) (empty F).
Hint Resolve image_empty: algebra.
Parameter
  image_union :
    forall (E F : Setoid) (f : MAP E F) (A B : part_set E),
    Equal (image f (union A B)) (union (image f A) (image f B)).
Hint Resolve image_union: algebra.
Parameter
  image_single :
    forall (E F : Setoid) (f : MAP E F) (A : part_set E) (x : E),
    Equal (image f (single x)) (single (f x)).
Hint Resolve image_single: algebra.
Parameter
  union_single_in :
    forall (E : Setoid) (A : part_set E) (x : E),
    in_part x A -> Equal (union A (single x)) A.
Hint Resolve union_single_in: algebra.

Lemma cardinal_image_lesser :
 forall (E F : Setoid) (f : MAP E F) (A : part_set E) (n : nat),
 cardinal A n -> exists m : nat, cardinal (image f A) m /\ m <= n.
intros E F f A n H'; try assumption.
apply
 cardinal_ind2
  with
    (P := fun (n : nat) (A : part_set E) (c : cardinal A n) =>
          ex (fun m : nat => cardinal (image f A) m /\ m <= n)).
intros A0 H'0; try assumption.
exists 0; split; [ idtac | auto with * ].
apply cardinal_empty; auto with *.
intros n0 H'0 A0 B x H'1 H'2 H'3; try assumption.
case (classic (in_part (f x) (image f B))).
intros H'4; try assumption.
elim (H'0 B);
 [ intros m E0; elim E0; intros H'7 H'8; try exact H'7; clear E0 | idtac ].
exists m; split; [ idtac | try assumption ].
apply cardinal_comp with (image f B) m; auto with *.
apply Sym.
apply Trans with (image f (add_part B x)); auto with *.
unfold add_part in |- *.
apply Trans with (union (image f B) (image f (single x))); auto with *.
apply Trans with (union (image f B) (single (Ap f x))); auto with *.
auto with *.
apply cardinal_S with A0 x; auto with *.
intros H'4; try assumption.
elim (H'0 B);
 [ intros m E0; elim E0; intros H'7 H'8; try exact H'7; clear E0 | idtac ].
exists (S m); split; [ try assumption | idtac ].
apply cardinal_add with (image f B) (Ap f x); auto with *.
unfold add_part in |- *.
unfold add_part in H'2.
apply Trans with (image f (union B (single x))); auto with *.
apply Trans with (union (image f B) (image f (single x))); auto with *.
auto with *.
apply cardinal_S with A0 x; auto with *.
auto with *.
Qed.

Lemma cardinal_image_injective :
 forall (E F : Setoid) (f : MAP E F) (A : part_set E) (n : nat),
 cardinal A n -> injective f -> cardinal (image f A) n.
intros E F f A n H' H'0; try assumption.
case (cardinal_image_lesser f H').
intros x H'1; try assumption.
elim H'1; intros H'2 H'3; try exact H'2; clear H'1.
cut (x < n \/ x = n).
intros H'1; try assumption.
elim H'1; [ intros H'4; try exact H'4; clear H'1 | intros H'4; clear H'1 ].
case
 (tiroirs (E:=E) (F:=F) (f:=f) (n:=n) (Chaussettes:=A) H' (m:=x)
    (Tiroirs:=image f A) H'2 H'4).
auto with *.
intros x0 H'1; try assumption.
elim H'1; intros y E0; elim E0; intros H'5 H'6; try exact H'5; clear E0 H'1.
red in H'0.
absurd (Equal x0 y); auto with *.
apply cardinal_comp with (image f A) x; auto with *.
case (lt_eq_lt_dec x n).
intros H'1; elim H'1;
 [ intros H'4; try exact H'4; clear H'1 | intros H'4; clear H'1 ];
 auto with *.
intros H'1; try assumption.
absurd (n < x); auto with *.
Qed.
Parameter
  not_in_part_comp_r :
    forall (E : Setoid) (A B : part_set E) (x : E),
    ~ in_part x A -> Equal A B -> ~ in_part x B.
Parameter
  diff_single_not_in :
    forall (E : Setoid) (A : part_set E) (x : E),
    ~ in_part x (diff A (single x)).
Hint Resolve diff_single_not_in: algebra.
Parameter
  diff_el_union_single :
    forall (E : Setoid) (A : part_set E) (x : E),
    in_part x A -> Equal A (union (diff A (single x)) (single x)).
Hint Resolve diff_el_union_single: algebra.

Lemma cardinal_image_strict_lesser :
 forall (E F : Setoid) (f : MAP E F) (n : nat),
 cardinal (full E) n ->
 ~ injective f -> exists m : nat, cardinal (image_map f) m /\ m < n.
intros E F f n; try assumption.
case n.
intros H' H'0; try assumption.
case (not_injective_prop H'0).
intros x H'1; try assumption.
absurd (in_part x (full E)); auto with *.
apply not_in_part_comp_r with (empty E); auto with *.
inversion H'.
auto with *.
intros n0 H' H'0; try assumption.
case (not_injective_prop H'0).
intros x H'1; try assumption.
elim H'1; intros y E0; elim E0; intros H'2 H'3; try exact H'2; clear E0 H'1.
cut (cardinal (diff (full E) (single x)) n0).
intros H'1; try assumption.
case (cardinal_image_lesser f H'1).
intros m H'4; try assumption.
exists m; split; [ try assumption | idtac ].
elim H'4; intros H'5 H'6; try exact H'5; clear H'4.
apply cardinal_comp with (image f (diff (full E) (single x))) m; auto with *.
apply included_antisym.
unfold image_map in |- *.
apply image_included; auto with *.
unfold image_map in |- *.
unfold included in |- *.
intros x0 H'4; try assumption.
elim H'4.
intros x1 H'7; try assumption.
case (classic (Equal x1 x)).
intros H'8; try assumption.
simpl in |- *.
exists y; split; [ idtac | try assumption ].
split; [ idtac | try assumption ].
auto with *.
auto with *.
apply Trans with (f x); auto with *.
elim H'7; intros H'9 H'10; try exact H'10; clear H'7.
apply Trans with (f x1); auto with *.
intros H'8; try assumption.
simpl in |- *.
exists x1; split; [ idtac | try assumption ].
auto with *.
elim H'7; intros H'9 H'10; try exact H'10; clear H'7.
elim H'4; intros H'5 H'6; try exact H'6; clear H'4; auto with *.
apply cardinal_S with (full E) x; auto with *.
unfold add_part in |- *.
auto with *.
Qed.

Lemma cardinal_image_equal_injective :
 forall (E F : Setoid) (f : MAP E F) (n : nat),
 cardinal (full E) n -> cardinal (image_map f) n -> injective f.
intros E F f n H' H'0; try assumption.
apply NNPP.
red in |- *; intros H'1; try exact H'1.
case (cardinal_image_strict_lesser H' H'1).
intros x H'2; elim H'2; intros H'3 H'4; try exact H'4; clear H'2.
absurd (x = n); auto with *.
red in |- *; intros H'2; try exact H'2.
absurd (x < n); auto with *.
rewrite H'2.
auto with *.
apply cardinal_unique with (E := F) (A := image_map f); auto with *.
Qed.
Parameter
  cardinal_equal_included_equal :
    forall (E : Setoid) (A B : part_set E) (n : nat),
    cardinal A n -> cardinal B n -> included B A -> Equal B A.
Parameter
  image_full_surjective :
    forall (E F : Setoid) (f : MAP E F),
    Equal (image_map f) (full F) -> surjective f.
Hint Resolve image_full_surjective: algebra.

Lemma finite_injective_surjective :
 forall (E F : Setoid) (f : MAP E F) (n : nat),
 cardinal (full E) n -> cardinal (full F) n -> injective f -> surjective f.
intros E F f n H' H'0 H'1; try assumption.
generalize (cardinal_image_injective H' H'1).
intros H'2; try assumption.
apply image_full_surjective; auto with *.
unfold image_map in |- *.
apply cardinal_equal_included_equal with n; auto with *.
Qed.
Parameter
  surjective_image_full :
    forall (E F : Setoid) (f : MAP E F),
    surjective f -> Equal (image_map f) (full F).
Hint Resolve surjective_image_full: algebra.

Lemma finite_surjective_injective :
 forall (E F : Setoid) (f : MAP E F) (n : nat),
 cardinal (full E) n -> cardinal (full F) n -> surjective f -> injective f.
intros E F f n H' H'0 H'1; try assumption.
apply cardinal_image_equal_injective with n; auto with *.
apply cardinal_comp with (full F) n; auto with *.
apply Sym; auto with *.
Qed.

Lemma not_included_exist :
 forall (E : Setoid) (A B : part_set E),
 included B A -> ~ Equal B A -> exists x : E, in_part x A /\ ~ in_part x B.
intros E A B; simpl in |- *.
unfold eq_part in |- *; simpl in |- *.
intros H' H'0; try assumption.
cut
 (ex
    (fun x : E =>
     ~ ((in_part x B -> in_part x A) /\ (in_part x A -> in_part x B)))).
intros H'1; try assumption.
elim H'1; intros x E0; try exact E0; clear H'1.
exists x; split; [ try assumption | idtac ].
red in E0.
apply NNPP.
red in |- *; intros H'1; try exact H'1.
lapply E0; [ intros H'2; apply H'2; clear E0 | clear E0 ].
split; [ idtac | intros H'2; try assumption ].
intros H'2; try assumption.
apply H'; auto with *.
absurd (in_part x A); auto with *.
red in |- *.
red in E0.
intros H'1; try assumption.
lapply E0; [ intros H'2; apply H'2; clear E0 | clear E0 ].
split; [ try assumption | idtac ].
intros H'2; try assumption.
apply H'; auto with *.
auto with *.
apply
 not_all_ex_not
  with
    (P := fun x : E =>
          (in_part x B -> in_part x A) /\ (in_part x A -> in_part x B));
 auto with *.
Qed.

Lemma cardinal_included :
 forall (E : Setoid) (A : part_set E) (n : nat),
 cardinal A n ->
 forall B : part_set E,
 included B A -> exists m : nat, cardinal B m /\ m <= n.
intros E A n H'; try assumption.
apply
 cardinal_ind2
  with
    (P := fun (n : nat) (A : part_set E) (c : cardinal A n) =>
          forall B : part_set E,
          included B A -> ex (fun m : nat => cardinal B m /\ m <= n)).
intros A0 H'0 B H'1; exists 0; split; [ try assumption | idtac ]; auto with *.
apply cardinal_empty.
inversion H'0.
cut (included B (empty E)); auto with *.
apply included_comp with B A0; auto with *.
intros n0 H'0 A0 B x H'1 H'2 H'3 B0 H'4; try assumption.
case (classic (Equal B0 A0)); intros.
exists (S n0); split; [ idtac | try assumption ].
apply cardinal_comp with A0 (S n0); auto with *.
auto with *.
case (not_included_exist H'4 H).
intros x0 H'5; try assumption.
elim H'5; intros H'6 H'7; try exact H'6; clear H'5.
lapply (H'0 (minus_part A0 x0));
 [ intros H'8; elim (H'8 B0);
    [ intros m E0; elim E0; intros H'11 H'12; try exact H'11; clear E0
    | idtac ]
 | idtac ]; auto with *.
exists m; split; [ try assumption | idtac ].
apply le_trans with n0; auto with *.
unfold minus_part in |- *; simpl in |- *.
red in |- *.
intros x1 H'5; try assumption.
simpl in |- *.
split; [ try assumption | idtac ].
apply H'4; auto with *.
red in |- *.
intros H'9; try assumption.
apply H'7.
apply in_part_comp_l with x1; auto with *.
apply cardinal_S with A0 x0; auto with *.
apply Sym.
apply minus_add; auto with *.
auto with *.
Qed.

Lemma map_not_injective :
 forall (A B : Setoid) (f : MAP A B) (n m : nat),
 cardinal (full A) n -> cardinal (full B) m -> m < n -> ~ injective f.
intros A B f n m H' H'0 H'1; red in |- *; intros H'2; try exact H'2.
red in H'2.
case (tiroirs (E:=A) (F:=B) (f:=f) H' H'0 H'1); auto with *.
intros x H'3; try assumption.
elim H'3; intros y E; elim E; intros H'4 H'5; try exact H'4; clear E H'3;
 auto with *.
Qed.

Definition finite (A : Setoid) := exists n : nat, cardinal (full A) n.