Require Import List.
Require Import ListDec.
Export ListNotations.

Require Import genT.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import K_Syntax.
Require Import K_GHC.
Require Import K_logics.
Require Import K_extens_interactions.

Lemma wThm_irrel : forall A B Γ, wKH_prv (Γ, A --> (B --> A)).
Proof.
intros A B Γ. apply Ax. apply AxRule_I. apply MA2_I. exists A. exists B. auto.
Qed.

Lemma wimp_Id_gen : forall A Γ, wKH_prv (Γ, A --> A).
Proof.
intros A Γ.
apply MP with (ps:=[(Γ, (((A --> A) --> A) --> A)  --> (A --> A));(Γ, (((A --> A) --> A) --> A))]).
2: apply MPRule_I. intros. inversion H ; subst.
apply MP with (ps:=[(Γ, (A --> ((A --> A) --> A)) --> (((A --> A) --> A) --> A) --> (A --> A));(Γ, (A --> ((A --> A) --> A)))]).
2: apply MPRule_I. intros. inversion H0 ; subst.
apply Ax. apply AxRule_I. apply MA1_I. exists A.
exists ((A --> A) --> A). exists A. auto. inversion H1. 2: inversion H2. subst.
apply Ax. apply AxRule_I. apply MA2_I. exists A.
exists (A --> A). auto. inversion H0. subst. 2: inversion H1.
apply Ax. apply AxRule_I. apply MA3_I. exists A. exists A. auto.
Qed.

Lemma Help8 : forall A B C D Γ,
  wKH_prv (Γ, (((A --> B) --> (C --> B)) --> D) --> ((C --> A) --> D)).
Proof.
intros.
apply MP with (ps:=[(Γ, ((C --> A) --> (A --> B) --> (C --> B)) --> ((((A --> B) --> (C --> B)) --> D) --> (C --> A) --> D));
(Γ, ((C --> A) --> (A --> B) --> (C --> B)))]).
2: apply MPRule_I. intros.
inversion H ; subst. apply Ax. apply AxRule_I. apply MA1_I.
exists (C --> A). exists ((A --> B) --> C --> B). exists D. auto.
inversion H0. subst. apply Ax. apply AxRule_I. apply MA1_I. exists C. exists A.
exists B. auto. inversion H1.
Qed.

Lemma Help10 : forall A B C Γ,
  wKH_prv (Γ, ((A --> B) --> C) --> (B --> C)).
Proof.
intros.
apply MP with (ps:=[(Γ, (B --> (A --> B)) --> ((A --> B) --> C) --> (B --> C));
(Γ, B --> (A --> B))]).
2: apply MPRule_I. intros.
inversion H ; subst. apply Ax. apply AxRule_I. apply MA1_I. exists B. exists (A --> B).
exists C. auto.
inversion H0. subst. apply Ax. apply AxRule_I. apply MA2_I. exists B. exists A ; auto.
inversion H1.
Qed.

Lemma Help33 : forall A B C D Γ,
  wKH_prv (Γ, (A --> (D --> C)) --> ((B --> D) --> (A --> (B --> C)))).
Proof.
intros.
apply MP with (ps:=[(Γ, ((((D --> C) --> (B --> C)) --> (A --> (B --> C)))--> ((B --> D) --> (A --> (B --> C)))) --> ((A --> (D --> C)) --> ((B --> D) --> (A --> (B --> C)))));
(Γ, (((D --> C) --> (B --> C)) --> (A --> (B --> C)))--> ((B --> D) --> (A --> (B --> C))))]).
2: apply MPRule_I. intros.
inversion H ; subst. apply Help8.
inversion H0. subst. apply Help8.
inversion H1.
Qed.

Lemma Contr_imp : forall A B Γ,
  wKH_prv (Γ, (A --> A --> B) --> (A --> B)).
Proof.
intros.
apply MP with (ps:=[(Γ, ((((A --> B) --> B)  --> (A --> B)) --> (A --> B)) --> ((A --> A --> B) --> (A --> B)));
(Γ, (((A --> B) --> B)  --> (A --> B)) --> (A --> B))]).
2: apply MPRule_I. intros. inversion H. subst. apply Help8.
inversion H0. subst. 2: inversion H1. apply Ax. apply AxRule_I.
apply MA3_I. exists (A --> B). exists B. auto.
Qed.

Lemma Help105 : forall A B Γ,
  wKH_prv (Γ, ((A --> B) --> A) -->  ((A --> B) --> B)).
Proof.
intros.
apply MP with (ps:=[(Γ, (((A --> B) --> (A --> B) --> B) --> ((A --> B) --> B)) --> ((A --> B) --> A) -->  ((A --> B) --> B));
(Γ, ((A --> B) --> (A --> B) --> B) --> ((A --> B) --> B))]).
2: apply MPRule_I. intros. inversion H. subst.
apply Help8. inversion H0. 2: inversion H1. subst. apply Contr_imp.
Qed.

Lemma Help316 : forall A B Γ,
  wKH_prv (Γ, A --> (A --> B) --> B).
Proof.
intros.
apply MP with (ps:=[(Γ, (((A --> B) --> A) --> ((A --> B) --> B)) --> (A --> (A --> B) --> B));
(Γ, ((A --> B) --> A) --> ((A --> B) --> B))]).
 2: apply MPRule_I. intros. inversion H. subst.
apply Help10. inversion H0. subst. apply Help105.
inversion H1.
Qed.

Lemma Swap_imp : forall A B C Γ,
  wKH_prv (Γ, (A --> B --> C) --> (B --> A --> C)).
Proof.
intros.
apply MP with (ps:=[(Γ, (B --> (B --> C) --> C) --> ((A --> B --> C) --> B --> A --> C));
(Γ, B --> (B --> C) --> C)]).
2: apply MPRule_I. intros. inversion H.
subst. apply Help33. inversion H0. subst. apply Help316.
inversion H1.
Qed.

Lemma MetaSwap_imp : forall A B C Γ,
  wKH_prv (Γ, A --> B --> C) ->
  wKH_prv (Γ, B --> A --> C).
Proof.
intros.
apply MP with (ps:=[(Γ, (A --> B --> C) --> (B --> A --> C));
(Γ, A --> B --> C)]).
2: apply MPRule_I. intros. inversion H0.
subst. apply Swap_imp. inversion H1. subst. auto.
inversion H2.
Qed.

Lemma Trans_imp : forall A B C Γ,
  wKH_prv (Γ, (A --> B --> C) --> (A --> B) --> A --> C).
Proof.
intros.
apply MP with (ps:=[(Γ, ((B --> A --> C) --> (A --> B) --> A --> C) --> ((A --> B --> C) --> (A --> B) --> A --> C));
(Γ, (B --> A --> C) --> (A --> B) --> A --> C)]). 2: apply MPRule_I.
intros. inversion H. subst.
apply MP with (ps:=[(Γ, ((A --> B --> C) --> (B --> A --> C)) --> ((B --> A --> C) --> (A --> B) --> A --> C) --> ((A --> B --> C) --> (A --> B) --> A --> C));
(Γ, (A --> B --> C) --> (B --> A --> C))]). 2: apply MPRule_I.
intros. inversion H0. subst.
apply Ax. apply AxRule_I. apply MA1_I. exists (A --> B --> C).
exists (B --> A --> C). exists ((A --> B) --> A --> C). auto. inversion H1.
2: inversion H2. subst. apply Swap_imp. inversion H0.
subst.
apply MP with (ps:=[(Γ, ((A --> B) --> ((B --> A --> C) --> A --> C)) --> ((B --> A --> C) --> (A --> B) --> A --> C));
(Γ, ((A --> B) --> ((B --> A --> C) --> A --> C)))]). 2: apply MPRule_I.
intros. inversion H1. subst. apply Swap_imp.
inversion H2. subst. 2: inversion H3.
apply MP with (ps:=[(Γ,  (((B --> A --> C) --> (A --> A --> C)) --> ((B --> A --> C) --> A --> C))--> ((A --> B) --> (B --> A --> C) --> A --> C));
(Γ, (((B --> A --> C) --> (A --> A --> C)) --> ((B --> A --> C) --> A --> C)))]). 2: apply MPRule_I.
intros. inversion H3. subst.
apply MP with (ps:=[(Γ,  ((A --> B) --> ((B --> A --> C) --> (A --> A --> C))) --> (((B --> A --> C) --> (A --> A --> C)) --> ((B --> A --> C) --> A --> C)) --> ((A --> B) --> (B --> A --> C) --> A --> C));
(Γ, ((A --> B) --> ((B --> A --> C) --> (A --> A --> C))))]). 2: apply MPRule_I.
intros. inversion H4. subst. apply Ax. apply AxRule_I.
apply MA1_I. exists (A --> B). exists (((B --> A --> C) --> (A --> A --> C))).
exists ((B --> A --> C) --> (A --> C)). auto. inversion H5 ; subst.
2: inversion H6. apply Ax. apply AxRule_I. apply MA1_I.
exists A. exists B. exists (A --> C). auto. inversion H4. subst.
2: inversion H5. 2: inversion H1.
apply MP with (ps:=[(Γ, ((A --> A --> C) --> (A --> C)) --> ((B --> A --> C) --> A --> A --> C) --> (B --> A --> C) --> A --> C);
(Γ, ((A --> A --> C) --> (A --> C)))]). 2: apply MPRule_I. intros. inversion H5.
subst.
apply MP with (ps:=[(Γ, (((B --> A --> C) --> A --> A --> C) --> ((A --> A --> C) --> A --> C) --> (B --> A --> C) --> A --> C) --> (((A --> A --> C) --> A --> C) --> ((B --> A --> C) --> A --> A --> C) --> (B --> A --> C) --> A --> C));
(Γ, ((B --> A --> C) --> A --> A --> C) --> ((A --> A --> C) --> A --> C) --> (B --> A --> C) --> A --> C)]).
2: apply MPRule_I. intros. inversion H6. subst. apply Swap_imp. inversion H7.
subst. 2: inversion H8. apply Ax. apply AxRule_I. apply MA1_I.
exists (B --> A --> C). exists (A --> A --> C). exists (A --> C). auto.
inversion H6. 2: inversion H7. subst. apply Contr_imp.
Qed.

Theorem wKH_Detachment_Theorem : forall s,
           (wKH_prv s) ->
           (forall A B Γ, (fst s = Γ) ->
                          (snd s = A --> B) ->
                          wKH_prv  (Union _ Γ (Singleton _ (A)), B)).
Proof.
intros s D. induction D.
(* Id *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id2. subst.
  simpl. apply MP with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A B);(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Id.
  apply IdRule_I. apply Union_introl. assumption. inversion H2. subst.
  apply Id. apply IdRule_I. apply Union_intror. apply In_singleton. inversion H3.
(* Ax *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id2. subst. simpl.
  apply MP with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A B);(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Ax.
  apply AxRule_I. assumption. inversion H2. subst. apply Id. apply IdRule_I.
  apply Union_intror. apply In_singleton. inversion H3.
(* MP *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id2. subst. simpl.
  assert (J01: List.In (Γ0, A0 --> A --> B) [(Γ0, A0 --> A --> B); (Γ0, A0)]). apply in_eq.
  assert (J1: Γ0 = Γ0). reflexivity.
  assert (J2: A0 --> A --> B = A0 --> A --> B). reflexivity.
  pose (H0 (Γ0, A0 --> A --> B) J01 A0 (Imp A B) Γ0 J1 J2).
  assert (wKH_prv (Γ0, A --> B)).
  assert (J3: (forall A1 : MPropF, fst (Union _ Γ0 (Singleton _ A0), A --> B) A1 ->
  wKH_prv (Γ0, A1))).
  intro. simpl. intro. inversion H2. subst. apply Id.
  apply IdRule_I. assumption. subst. inversion H3. subst.
  assert (J02: List.In (Γ0, A1) [(Γ0, A1 --> A --> B); (Γ0, A1)]). apply in_cons. apply in_eq.
  pose (H (Γ0, A1) J02). assumption.
  pose (wKH_comp (Union _ Γ0 (Singleton _ A0), A --> B) w Γ0 J3). simpl in w0. assumption.
  apply MP with (ps:=[(Union _ Γ0 (Singleton _ A), (Imp A B));(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply MP with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A0 (Imp A B));(Union _ Γ0 (Singleton _ A), A0)]).
  2: apply MPRule_I. intros. inversion H4. subst.
  assert (J4: Included _ (fst (Γ0, A0 --> A --> B)) (Union _ Γ0 (Singleton _ A))).
  simpl. intro. intro. apply Union_introl. assumption. pose (H (Γ0, A0 --> A --> B) J01).
  pose (wKH_monot (Γ0, A0 --> A --> B) w0 (Union _ Γ0 (Singleton _ A)) J4). assumption.
  inversion H5. subst.
  assert (J4: Included _ (fst (Γ0, A0 --> A --> B)) (Union _ Γ0 (Singleton _ A))).
  simpl. intro. intro. apply Union_introl. assumption.
  pose (wKH_monot (Γ0, A0)). apply w0. apply H. apply in_cons. apply in_eq.
  auto. inversion H6. inversion H4. subst. apply Id. apply IdRule_I. apply Union_intror.
  apply In_singleton. inversion H5.
(* wNec *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id2. subst. inversion id2.
Qed.

Theorem wKH_Deduction_Theorem : forall s,
           (wKH_prv s) ->
           (forall A B Γ, (fst s = Union _ Γ (Singleton _ (A))) ->
                          (snd s = B) ->
                          wKH_prv (Γ, A --> B)).
Proof.
intros s D. induction D.
(* Id *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id1. subst. simpl. inversion H0.
  + subst. apply MP with (ps:=[(Γ, A0 --> A --> A0);(Γ, A0)]). 2: apply MPRule_I. intros. inversion H2. subst.
    apply wThm_irrel. inversion H3. subst. apply Id. apply IdRule_I. assumption.
    inversion H4.
  + subst. inversion H1. subst. apply wimp_Id_gen.
(* Ax *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id1. subst. simpl.
  apply MP with (ps:=[(Γ, A0 --> A --> A0);(Γ, A0)]). 2: apply MPRule_I. intros. inversion H1. subst.
  apply wThm_irrel. inversion H2. subst.
  apply Ax. apply AxRule_I. assumption. inversion H3.
(* MP *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: A0 --> B0 = A0 --> B0). reflexivity.
  assert (J20: List.In (Union (MPropF) Γ (Singleton (MPropF) A), A0 --> B0) [(Union (MPropF) Γ (Singleton (MPropF) A), A0 --> B0); (Union (MPropF) Γ (Singleton (MPropF) A), A0)]).
  apply in_eq.
  pose (H0 (Union (MPropF) Γ (Singleton (MPropF) A),  A0 --> B0) J20
  A (Imp A0 B0) Γ J1 J2).
  assert (J3: A0 = A0). reflexivity.
  apply MP with (ps:=[(Γ, (A --> A0) --> (A --> B0));(Γ, A --> A0)]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(Γ, (A --> (A0 --> B0)) --> (A --> A0) --> (A --> B0));(Γ, A --> (A0 --> B0))]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply Trans_imp. inversion H4. subst. auto. inversion H5. inversion H3.
  subst.
  assert (J30: List.In (Union (MPropF) Γ (Singleton (MPropF) A), A0) [(Union (MPropF) Γ (Singleton (MPropF) A), A0 --> B0); (Union (MPropF) Γ (Singleton (MPropF) A), A0)]).
  apply in_cons. apply in_eq. assert (J40: A0 = A0). reflexivity.
  pose (H0 (Union (MPropF) Γ (Singleton (MPropF) A), A0) J30
  A A0 Γ J1 J40). auto. inversion H4.
(* wNec *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J1: wKH_prv (Empty_set _, Box A0)).
  apply wNec with (ps:=[(Empty_set _, A0)]). 2: apply wNecRule_I. assumption.
  assert (J2: Included _ (fst (Empty_set _, Box A0)) Γ). intro. intro. inversion H2.
  pose (wKH_monot (Empty_set _, Box A0) J1 Γ J2). simpl in w.
  apply MP with (ps:=[(Γ, (Box A0) --> A --> (Box A0)); (Γ, Box A0)]).
  2: apply MPRule_I. intros. inversion H2. subst. apply wThm_irrel.
  inversion H3. subst. 2: inversion H4. assumption.
Qed.

Theorem wKH_Detachment_Deduction_Theorem : forall A B Γ,
      wKH_prv (Union _ Γ (Singleton _ (A)), B) <-> wKH_prv (Γ, A --> B).
Proof.
intros. split ; intro.
apply wKH_Deduction_Theorem with (s:=(Union MPropF Γ (Singleton MPropF A), B)) ; auto.
apply wKH_Detachment_Theorem with (s:=(Γ, A --> B)) ; auto.
Qed.

(* ---------------------------------------------------------------------------------------------------------- *)

(* Some results about remove. *)

Lemma In_remove : forall (A : MPropF) B (l : list (MPropF)), List.In A (remove eq_dec_form B l) -> List.In A l.
Proof.
intros A B. induction l.
- simpl. auto.
- intro. simpl in H. destruct (eq_dec_form B a).
  * subst. apply in_cons. apply IHl. assumption.
  * inversion H.
    + subst. apply in_eq.
    + subst. apply in_cons. apply IHl. auto.
Qed.

Lemma InT_remove : forall (A : MPropF) B (l : list (MPropF)), InT A (remove eq_dec_form B l) -> InT A l.
Proof.
intros A B. induction l.
- simpl. auto.
- intro. simpl in H. destruct (eq_dec_form B a).
  * subst. apply InT_cons. apply IHl. assumption.
  * inversion H.
    + subst. apply InT_eq.
    + subst. apply InT_cons. apply IHl. auto.
Qed.

Lemma NoDup_remove : forall A (l : list (MPropF)), NoDup l -> NoDup (remove eq_dec_form A l).
Proof.
intro A. induction l.
- intro. simpl. apply NoDup_nil.
- intro H. simpl. destruct (eq_dec_form A a).
  * subst. apply IHl. inversion H. assumption.
  * inversion H. subst. apply NoDup_cons. intro. apply H2. apply In_remove with (B:= A).
    assumption. apply IHl. assumption.
Qed.

(* To help for the results about sKH. *)

Lemma eq_dec_nat : forall (n m : nat), (n = m) + (n <> m).
Proof.
induction n.
- destruct m.
  * auto.
  * auto.
- intro m. destruct m.
  * auto.
  * destruct IHn with (m:=m).
    + left. lia.
    + right. lia.
Qed.

Lemma thm_irrel_Imp_Box_power : forall (n : nat) (A B : MPropF),
  wKH_prv (Empty_set _, B --> (Imp_Box_power n A B)).
Proof.
induction n ; intros ; simpl.
- apply wThm_irrel.
- pose (wKH_Deduction_Theorem (Singleton _ B,  A --> Imp_Box_power n (Box A) B)).
  apply w ; auto. 2: simpl. clear w.
  pose (wKH_Deduction_Theorem (Union _ (Singleton _ B) (Singleton _ A),  Imp_Box_power n (Box A) B)).
  apply w ; auto. clear w. remember (Union MPropF (Singleton MPropF B) (Singleton MPropF A)) as X.
  apply MP with (ps:=[(X, B --> Imp_Box_power n (Box A) B);(X, B)]).
  2: apply MPRule_I. intros. inversion H. rewrite <- H0.
  pose (wKH_monot (Empty_set _, B --> Imp_Box_power n (Box A) B)). apply w ; auto.
  intro. simpl ; intro. inversion H1. inversion H0. subst. 2: inversion H1.
  apply Id. apply IdRule_I. apply Union_introl. apply In_singleton.
  apply Extensionality_Ensembles. split ; intro ; intros. apply Union_intror ; auto.
  inversion H. inversion H0. auto.
Qed.

Lemma Imp_Box_power_le : forall (n m: nat) (A B : MPropF), (n <= m) ->
  wKH_prv (Empty_set _, (Imp_Box_power n A B) --> (Imp_Box_power m A B)).
Proof.
induction n.
- simpl. destruct m.
  + simpl. intros. apply wimp_Id_gen.
  + intros. simpl. assert (J1: 0 <= m). lia.
     pose (wKH_Deduction_Theorem (Singleton _ (A --> B),  A --> Imp_Box_power m (Box A) B)).
     apply w ; auto. 2: simpl. clear w.
     pose (wKH_Deduction_Theorem (Union _ (Singleton _ (A --> B)) (Singleton _ A),  Imp_Box_power m (Box A) B)).
     apply w ; auto. clear w. remember (Union MPropF (Singleton MPropF (A --> B)) (Singleton MPropF A)) as X.
     apply MP with (ps:=[(X, B --> Imp_Box_power m (Box A) B);(X, B)]).
     2: apply MPRule_I. intros. inversion H0. rewrite <- H1.
     pose (wKH_monot (Empty_set _, B --> Imp_Box_power m (Box A) B)). apply w.
     apply thm_irrel_Imp_Box_power. intro. intros. inversion H2. inversion H1.
     rewrite <- H2. 2: inversion H2.
     apply MP with (ps:=[(X, A --> B);(X, A)]). 2: apply MPRule_I.
     intros. inversion H3. subst. apply Id. apply IdRule_I. apply Union_introl.
     apply In_singleton. inversion H4. subst. 2: inversion H5. apply Id.
     apply IdRule_I. apply Union_intror. apply In_singleton.
     apply Extensionality_Ensembles. split ; intro ; intros. apply Union_intror. auto.
     inversion H0. subst. inversion H1. auto.
- simpl. destruct m.
  + intros. inversion H.
  + intros. simpl.
     pose (wKH_Deduction_Theorem (Singleton _ (A --> Imp_Box_power n (Box A) B),  A --> Imp_Box_power m (Box A) B)).
     apply w ; auto. 2: simpl. clear w.
     pose (wKH_Deduction_Theorem (Union _ (Singleton _ (A --> Imp_Box_power n (Box A) B)) (Singleton _ A),  Imp_Box_power m (Box A) B)).
     apply w ; auto. clear w. remember (Union MPropF (Singleton MPropF (A --> Imp_Box_power n (Box A) B)) (Singleton MPropF A)) as X.
     apply MP with (ps:=[(X, Imp_Box_power n (Box A) B --> Imp_Box_power m (Box A) B);(X, Imp_Box_power n (Box A) B)]).
     2: apply MPRule_I. intros. inversion H0. rewrite <- H1.
     pose (wKH_monot (Empty_set _, Imp_Box_power n (Box A) B --> Imp_Box_power m (Box A) B)). apply w. clear w.
     apply IHn ; lia. intro. intros. inversion H2. inversion H1.
     rewrite <- H2. 2: inversion H2.
     apply MP with (ps:=[(X, A --> Imp_Box_power n (Box A) B);(X, A)]). 2: apply MPRule_I.
     intros. inversion H3. subst. apply Id. apply IdRule_I. apply Union_introl.
     apply In_singleton. inversion H4. subst. 2: inversion H5. apply Id.
     apply IdRule_I. apply Union_intror. apply In_singleton.
     apply Extensionality_Ensembles. split ; intro ; intros. apply Union_intror. auto.
     inversion H0. subst. inversion H1. auto.
Qed.

Lemma Imp_Box_power_MP_deep : forall (n : nat) (A B C : MPropF),
  wKH_prv (Empty_set _, (Imp_Box_power n A B) --> (Imp_Box_power n A (B --> C)) --> (Imp_Box_power n A C)).
Proof.
induction n.
- intros. simpl.
  pose (wKH_Deduction_Theorem (Singleton _ (A --> B),  (A --> B --> C) --> A --> C)).
  apply w ; auto. 2: simpl. clear w.
  pose (wKH_Deduction_Theorem (Union _ (Singleton _ (A --> B)) (Singleton _ (A --> B --> C)),  A --> C)).
  apply w ; auto. clear w.
  pose (wKH_Deduction_Theorem (Union _ (Union _ (Singleton _ (A --> B)) (Singleton _ (A --> B --> C))) (Singleton _ A),  C)).
  apply w ; auto. clear w. remember (Union MPropF (Union MPropF (Singleton MPropF (A --> B)) (Singleton MPropF (A --> B --> C))) (Singleton MPropF A)) as X.
  apply MP with (ps:=[(X, B --> C);(X, B)]). 2: apply MPRule_I.
  intros. inversion H. rewrite <- H0.
  apply MP with (ps:=[(X, A --> B --> C);(X, A)]). 2: apply MPRule_I.
  intros. inversion H1. rewrite <- H2. apply Id. apply IdRule_I.
  subst. apply Union_introl. apply Union_intror. apply In_singleton.
  inversion H2. rewrite <- H3. apply Id. apply IdRule_I. subst.
  apply Union_intror. apply In_singleton. inversion H3. inversion H0.
  rewrite <- H1. apply MP with (ps:=[(X, A --> B);(X, A)]).
  intros. 2: apply MPRule_I. inversion H2. rewrite <- H3. apply Id.
  apply IdRule_I. subst. apply Union_introl. apply Union_introl. apply In_singleton.
  inversion H3. rewrite <- H4. apply Id. apply IdRule_I. subst. apply Union_intror.
  apply In_singleton. inversion H4. inversion H1. apply Extensionality_Ensembles.
  split. intro. intros. inversion H. subst. apply Union_intror. apply In_singleton.
  intro. intros. inversion H. subst. inversion H0. subst. auto.
- intros. simpl.
  pose (wKH_Deduction_Theorem (Singleton _ (A --> Imp_Box_power n (Box A) B),  (A --> (Imp_Box_power n (Box A) (B --> C))) --> A --> Imp_Box_power n (Box A) C)).
  apply w ; auto. 2: simpl. clear w.
  pose (wKH_Deduction_Theorem (Union _ (Singleton _ (A --> Imp_Box_power n (Box A) B)) (Singleton _ (A --> (Imp_Box_power n (Box A) (B --> C)))),  A --> Imp_Box_power n (Box A) C)).
  apply w ; auto. clear w.
  pose (wKH_Deduction_Theorem (Union _ (Union _ (Singleton _ (A --> Imp_Box_power n (Box A) B)) (Singleton _ (A --> (Imp_Box_power n (Box A) (B --> C))))) (Singleton _ A),  Imp_Box_power n (Box A) C)).
  apply w ; auto. clear w. remember (Union MPropF (Union MPropF (Singleton MPropF (A --> Imp_Box_power n (Box A) B)) (Singleton MPropF (A --> (Imp_Box_power n (Box A) (B --> C))))) (Singleton MPropF A)) as X.
  apply MP with (ps:=[(X, (Imp_Box_power n (Box A) (B --> C)) --> Imp_Box_power n (Box A) C);
  (X, (Imp_Box_power n (Box A) (B --> C)))]). 2: apply MPRule_I.
  intros. inversion H. rewrite <- H0.
  apply MP with (ps:=[(X, (Imp_Box_power n (Box A) B) --> (Imp_Box_power n (Box A) (B --> C) --> Imp_Box_power n (Box A) C));(X, Imp_Box_power n (Box A) B)]). 2: apply MPRule_I.
  intros. inversion H1. rewrite <- H2.
  pose (wKH_monot ((Empty_set _, Imp_Box_power n (Box A) B --> Imp_Box_power n (Box A) (B --> C) --> Imp_Box_power n (Box A) C))).
  apply w. apply IHn. intro. simpl. intros. inversion H3.
  inversion H2. rewrite <- H3.
  apply MP with (ps:=[(X, A --> Imp_Box_power n (Box A) B);(X, A)]). 2: apply MPRule_I.
  intros. inversion H4. rewrite <- H5. apply Id. apply IdRule_I.
  subst. apply Union_introl. apply Union_introl. apply In_singleton.
  inversion H5. rewrite <- H6. subst. apply Id. apply IdRule_I.
  apply Union_intror. apply In_singleton. inversion H6. inversion H3.
  inversion H0. rewrite <- H1.
  apply MP with (ps:=[(X, A --> Imp_Box_power n (Box A) (B --> C));(X, A)]). 2: apply MPRule_I.
  intros. inversion H2. rewrite <- H3. subst. apply Id. apply IdRule_I. apply Union_introl.
  apply Union_intror. apply In_singleton. inversion H3. subst. apply Id. apply IdRule_I.
  apply Union_intror. apply In_singleton. inversion H4. inversion H1.
  apply Extensionality_Ensembles. split. intro. intros. inversion H. subst.
  apply Union_intror. apply In_singleton. intro. intros. inversion H. subst. inversion H0. subst. auto.
Qed.

Lemma Distrib_Box_Imp_Box_power : forall (n : nat) (A B : MPropF) Γ,
  wKH_prv (Γ, (Box (Imp_Box_power n A B)) --> (Imp_Box_power n (Box A) (Box B))).
Proof.
induction n ; intros ; cbn.
- apply Ax. apply AxRule_I. apply MA5_I. exists A. exists B. auto.
- pose (wKH_Deduction_Theorem (Union _ Γ (Singleton _ (Box (A --> Imp_Box_power n (Box A) B))), Box A --> Imp_Box_power n (Box (Box A)) (Box B))).
  apply w ; auto. clear w.
  pose (wKH_Deduction_Theorem (Union _ (Union _ Γ (Singleton _ (Box (A --> Imp_Box_power n (Box A) B)))) (Singleton _ (Box A)), Imp_Box_power n (Box (Box A)) (Box B))).
  apply w ; auto. clear w. remember (Union MPropF (Union MPropF Γ (Singleton MPropF (Box (A --> Imp_Box_power n (Box A) B)))) (Singleton MPropF (Box A))) as X.
  apply MP with (ps:=[(X, Box (Imp_Box_power n (Box A) B) --> Imp_Box_power n (Box (Box A)) (Box B));(X, Box (Imp_Box_power n (Box A) B))]).
  2: apply MPRule_I. intros. inversion H. rewrite <- H0.
  pose (wKH_monot (Γ, Box (Imp_Box_power n (Box A) B) --> Imp_Box_power n (Box (Box A)) (Box B))).
  apply w ; cbn ; auto. clear w. subst. intro. intros. apply Union_introl. apply Union_introl. auto.
  inversion H0. rewrite <- H1. 2: inversion H1.
  apply MP with (ps:=[(X, Box A --> Box (Imp_Box_power n (Box A) B));(X, Box A)]).
  2: apply MPRule_I. intros. inversion H2. rewrite <- H3.
  apply MP with (ps:=[(X, Box (A --> Imp_Box_power n (Box A) B) --> Box A --> Box (Imp_Box_power n (Box A) B));(X, Box (A --> Imp_Box_power n (Box A) B))]).
  2: apply MPRule_I. intros. inversion H4. rewrite <- H5. apply Ax. apply AxRule_I.
  apply MA5_I. exists A. exists (Imp_Box_power n (Box A) B). auto. inversion H5.
  rewrite <- H6. apply Id. subst. apply IdRule_I. apply Union_introl. apply Union_intror.
  apply In_singleton. inversion H6. inversion H3. subst. apply Id. apply IdRule_I.
  apply Union_intror. apply In_singleton. inversion H4.
Qed.

(* To help for the completeness of wKH. *)

Lemma NegNeg_elim : forall Γ A, wKH_prv (Γ, (A --> Bot) --> Bot) ->
    wKH_prv (Γ, A).
Proof.
intros.
apply MP with (ps:=[(Γ, ((A --> Bot) --> A) --> A);(Γ, (A --> Bot) --> A)]).
2: apply MPRule_I. intros. inversion H0. subst.
apply Ax. apply AxRule_I. apply MA3_I. exists A. exists Bot. auto.
inversion H1. subst. 2: inversion H2.
apply wKH_Deduction_Theorem with (s:=(Union _ Γ (Singleton _ (A --> Bot)), A)) ; auto.
apply MP with (ps:=[(Union MPropF Γ (Singleton MPropF (A --> Bot)), Bot --> A);
(Union MPropF Γ (Singleton MPropF (A --> Bot)), Bot)]).
2: apply MPRule_I. intros. inversion H2. subst. apply Ax. apply AxRule_I.
apply MA4_I. exists A ; auto. inversion H3. subst. 2: inversion H4.
apply wKH_Detachment_Theorem with (s:=(Γ, (A --> Bot) --> Bot)) ; auto.
Qed.

(* To help for the Lindenbaum lemma. *)

Lemma Explosion : forall Γ A B,
  wKH_prv (Γ, (B --> Bot) --> (B --> A)).
Proof.
intros.
apply wKH_Deduction_Theorem with (s:=(Union _ Γ (Singleton _ (B --> Bot)),  B --> A)) ; auto.
apply wKH_Deduction_Theorem with (s:=(Union _ (Union _ Γ (Singleton _ (B --> Bot))) (Singleton _ B), A)) ; auto.
remember (Union MPropF (Union MPropF Γ (Singleton MPropF (B --> Bot))) (Singleton MPropF B)) as X.
apply MP with (ps:=[(X, Bot --> A);(X, Bot)]). 2: apply MPRule_I.
intros. inversion H. subst. apply Ax. apply AxRule_I. apply MA4_I. exists A ; auto.
inversion H0. 2: inversion H1. rewrite <- H1.
apply MP with (ps:=[(X, B --> Bot);(X, B)]). 2: apply MPRule_I.
intros. inversion H2. subst. apply Id. apply IdRule_I. apply Union_introl.
apply Union_intror. apply In_singleton. inversion H3. subst.
apply Id. apply IdRule_I. apply Union_intror. apply In_singleton. inversion H4.
Qed.

Lemma All_cases_LEM : forall Γ A B,
  wKH_prv (Γ, ((B --> Bot) --> A) --> (B --> A) --> A).
Proof.
intros.
apply wKH_Deduction_Theorem with (s:=(Union _ Γ (Singleton _ ((B --> Bot) --> A)),  (B --> A) --> A)) ; auto.
apply wKH_Deduction_Theorem with (s:=(Union _ (Union _ Γ (Singleton _ ((B --> Bot) --> A))) (Singleton _ (B --> A)), A)) ; auto.
remember (Union MPropF (Union MPropF Γ (Singleton MPropF ((B --> Bot) --> A))) (Singleton MPropF (B --> A))) as X.
apply NegNeg_elim.
apply wKH_Deduction_Theorem with (s:=(Union _ X (Singleton _ (A --> Bot)), Bot)) ; auto.
remember (Union MPropF X (Singleton MPropF (A --> Bot))) as X0.
apply MP with (ps:=[(X0, A --> Bot);(X0, A)]). 2: apply MPRule_I.
intros. inversion H. rewrite <- H0. apply Id. apply IdRule_I. subst.
apply Union_intror. apply In_singleton. inversion H0. 2: inversion H1.
rewrite <- H1.
apply MP with (ps:=[(X0, (B --> Bot) --> A);(X0, B --> Bot)]). 2: apply MPRule_I.
intros. inversion H2. rewrite <- H3. apply Id. apply IdRule_I. subst.
apply Union_introl. apply Union_introl. apply Union_intror. apply In_singleton.
inversion H3. rewrite <- H4. 2: inversion H4.
apply wKH_Deduction_Theorem with (s:=(Union _ X0 (Singleton _ B), Bot)) ; auto.
apply MP with (ps:=[(Union MPropF X0 (Singleton MPropF B), A --> Bot);
(Union MPropF X0 (Singleton MPropF B), A)]). 2: apply MPRule_I.
intros. inversion H5. rewrite <- H6. apply Id. subst. apply IdRule_I.
apply Union_introl. apply Union_intror. apply In_singleton.
inversion H6. 2: inversion H7. rewrite <- H7.
apply MP with (ps:=[(Union MPropF X0 (Singleton MPropF B), B --> A);
(Union MPropF X0 (Singleton MPropF B), B)]). 2: apply MPRule_I.
intros. inversion H8. rewrite <- H9. apply Id. apply IdRule_I. subst.
apply Union_introl. apply Union_introl. apply Union_intror. apply In_singleton.
inversion H9. subst. apply Id. apply IdRule_I. apply Union_intror. apply In_singleton.
inversion H10.
Qed.

Lemma Imp_list_Imp : forall l Γ A B,
    wKH_prv (Γ, list_Imp (A --> B) l) <->
    wKH_prv (Γ, A --> list_Imp B l).
Proof.
induction l ; simpl ; intros.
- split ; intro ; auto.
- split ; intro.
  * apply wKH_Deduction_Theorem with (s:=(Union _ Γ (Singleton _ A), a --> list_Imp B l)) ; auto.
    apply wKH_Deduction_Theorem with (s:=(Union _ (Union _ Γ (Singleton _ A)) (Singleton _ a), list_Imp B l)) ; auto.
    assert (Union MPropF (Union MPropF Γ (Singleton MPropF A)) (Singleton MPropF a) =
    Union MPropF (Union MPropF Γ (Singleton MPropF a)) (Singleton MPropF A)).
    apply Extensionality_Ensembles. split ; intro ; intros. inversion H0. subst.
    inversion H1. subst. apply Union_introl. apply Union_introl  ; auto. subst.
    inversion H2. subst. apply Union_intror. apply In_singleton. subst. apply Union_introl.
    apply Union_intror. auto. inversion H0. subst. inversion H1. subst. apply Union_introl.
    apply Union_introl. auto. subst. apply Union_intror. auto. subst.
    apply Union_introl. apply Union_intror. auto. rewrite H0.
    apply wKH_Detachment_Theorem with (s:=(Union MPropF Γ (Singleton MPropF a),
    A --> list_Imp B l)) ; auto. apply IHl.
    apply wKH_Detachment_Theorem with (s:=(Γ, a --> list_Imp (A --> B) l)) ; auto.
  * apply wKH_Deduction_Theorem with (s:=(Union _ Γ (Singleton _ a), list_Imp (A --> B) l)) ; auto.
    apply IHl.
    apply wKH_Deduction_Theorem with (s:=(Union _ (Union _ Γ (Singleton _ a)) (Singleton _ A), list_Imp B l)) ; auto.
    assert (Union MPropF (Union MPropF Γ (Singleton MPropF A)) (Singleton MPropF a) =
    Union MPropF (Union MPropF Γ (Singleton MPropF a)) (Singleton MPropF A)).
    apply Extensionality_Ensembles. split ; intro ; intros. inversion H0. subst.
    inversion H1. subst. apply Union_introl. apply Union_introl  ; auto. subst.
    inversion H2. subst. apply Union_intror. apply In_singleton. subst. apply Union_introl.
    apply Union_intror. auto. inversion H0. subst. inversion H1. subst. apply Union_introl.
    apply Union_introl. auto. subst. apply Union_intror. auto. subst.
    apply Union_introl. apply Union_intror. auto. rewrite <- H0. clear H0.
    apply wKH_Detachment_Theorem with (s:=(Union MPropF Γ (Singleton MPropF A),
    a --> list_Imp B l)) ; auto.
    apply wKH_Detachment_Theorem with (s:=(Γ, A --> a --> list_Imp B l)) ; auto.
Qed.

Lemma wKH_Imp_list_Detachment_Deduction_Theorem : forall l (Γ: Ensemble MPropF) A,
    (forall B : MPropF, (Γ B -> List.In B l) * (List.In B l -> Γ B)) ->
    ((wKH_prv (Γ, A)) <-> (wKH_prv (Empty_set _, list_Imp A l))).
Proof.
induction l ; simpl ; intros.
- split ; intro.
  * assert (Γ = Empty_set MPropF). apply Extensionality_Ensembles.
    split ; intro ; intros. apply H in H1. exfalso ; auto. inversion H1.
    rewrite H1 in H0 ; auto.
  * assert (Γ = Empty_set MPropF). apply Extensionality_Ensembles.
    split ; intro ; intros. apply H in H1. exfalso ; auto. inversion H1.
    rewrite H1 ; auto.
- split ; intro.
  * assert (decidable_eq MPropF). unfold decidable_eq. intros.
    destruct (eq_dec_form x y). subst. unfold Decidable.decidable. auto.
    unfold Decidable.decidable. auto.
    pose (In_decidable H1 a l). destruct d.
    + assert (J0: forall B : MPropF, (Γ B -> List.In B l) * (List.In B l -> Γ B)).
       intros. split ; intro. pose (H B). destruct p. apply o in H3. destruct H3.
       subst. auto. auto. apply H. auto.
       pose (IHl Γ A J0). apply i in H0.
       apply MP with (ps:=[(Empty_set MPropF, (list_Imp A l) --> (a --> list_Imp A l));
       (Empty_set MPropF, list_Imp A l)]).
       2: apply MPRule_I. intros. inversion H3. subst.
       apply Ax. apply AxRule_I. apply MA2_I. exists (list_Imp A l).
       exists a. auto. inversion H4. subst. 2: inversion H5. auto.
    + assert (J0: forall B : MPropF,
       ((fun y : MPropF => In MPropF Γ y /\ y <> a) B -> List.In B l) *
       (List.In B l -> (fun y : MPropF => In MPropF Γ y /\ y <> a) B)).
       intros. split ; intro. destruct H3. pose (H B). destruct p.
       apply o in H3. destruct H3 ; subst. exfalso. apply H4 ; auto.
       auto. split ; auto. apply H ; auto. intro. subst. auto.
       pose (IHl (fun y => (In _ Γ y) /\ (y <> a)) (a --> A) J0).
       destruct i. apply Imp_list_Imp. apply H3.
       apply wKH_Deduction_Theorem with (s:=(Γ, A)) ; simpl ; auto.
       apply Extensionality_Ensembles. split ; intro ; intros. unfold In.
       destruct (eq_dec_form a x). subst. apply Union_intror. apply In_singleton.
       apply Union_introl. unfold In. split ; auto. inversion H5. subst.
       inversion H6. auto. subst. inversion H6. subst. apply H. auto.
  * assert (decidable_eq MPropF). unfold decidable_eq. intros.
    destruct (eq_dec_form x y). subst. unfold Decidable.decidable. auto.
    unfold Decidable.decidable. auto.
    pose (In_decidable H1 a l). destruct d.
    + assert (J0: forall B : MPropF, (Γ B -> List.In B l) * (List.In B l -> Γ B)).
       intros. split ; intro. pose (H B). destruct p. apply o in H3. destruct H3.
       subst. auto. auto. apply H. auto.
       apply Imp_list_Imp in H0.
       pose (IHl Γ (a --> A)).
       apply MP with (ps:=[(Γ, a --> A);(Γ, a)]).
       2: apply MPRule_I. intros. inversion H3. subst. apply i. intros.
       split ; intros. pose (H B). destruct p. apply o in H4. destruct H4 ; subst.
       auto. auto. apply H. auto. auto. inversion H4 ; subst.
       apply Id. apply IdRule_I. apply H. auto. inversion H5.
    + assert (J0: forall B : MPropF,
       ((fun y : MPropF => In MPropF Γ y /\ y <> a) B -> List.In B l) *
       (List.In B l -> (fun y : MPropF => In MPropF Γ y /\ y <> a) B)).
       intros. split ; intro. destruct H3. pose (H B). destruct p.
       apply o in H3. destruct H3 ; subst. exfalso. apply H4 ; auto.
       auto. split ; auto. apply H ; auto. intro. subst. auto.
       pose (IHl (fun y => (In _ Γ y) /\ (y <> a)) (a --> A) J0).
       destruct i. apply Imp_list_Imp in H0. apply H4 in H0.
       pose (wKH_Detachment_Theorem (fun y : MPropF => In MPropF Γ y /\ y <> a, a --> A)
       H0 a A (fun y : MPropF => In MPropF Γ y /\ y <> a)). simpl in w.
       assert (Γ = Union MPropF (fun y : MPropF => In MPropF Γ y /\ y <> a)
       (Singleton MPropF a)).
       apply Extensionality_Ensembles. split ; intro ; intros. unfold In.
       destruct (eq_dec_form a x). subst. apply Union_intror. apply In_singleton.
       apply Union_introl. unfold In. split ; auto. inversion H5. subst.
       inversion H6. auto. subst. inversion H6. subst. apply H. auto.
       rewrite H5. apply w ; auto.
Qed.

Lemma K_list_Imp : forall l Γ A,
wKH_rules (Γ, Box (list_Imp A l) --> list_Imp (Box A) (Box_list l)).
Proof.
induction l ; simpl ; intros.
- apply wimp_Id_gen.
- apply wKH_Deduction_Theorem with (s:=(Union _ Γ (Singleton _ (Box (a --> list_Imp A l))),  Box a --> list_Imp (Box A) (Box_list l))) ; auto.
  apply wKH_Deduction_Theorem with (s:=(Union _ (Union _ Γ (Singleton _ (Box (a --> list_Imp A l)))) (Singleton _ (Box a)),  list_Imp (Box A) (Box_list l))) ; auto.
  remember (Union MPropF (Union MPropF Γ (Singleton MPropF (Box (a --> list_Imp A l)))) (Singleton MPropF (Box a))) as X.
  apply MP with (ps:=[(X, Box (list_Imp A l) --> list_Imp (Box A) (Box_list l));(X,Box (list_Imp A l))]).
  2: apply MPRule_I. intros. inversion H. rewrite <- H0. auto.
  inversion H0. 2: inversion H1. rewrite <- H1.
  apply MP with (ps:=[(X, Box a --> Box (list_Imp A l));(X, Box a)]).
  2: apply MPRule_I. intros. inversion H2. rewrite <- H3.
  apply MP with (ps:=[(X, Box (a --> list_Imp A l) --> (Box a --> Box (list_Imp A l)));(X, Box (a --> list_Imp A l))]).
  2: apply MPRule_I. intros. inversion H4. rewrite <- H5. apply Ax.
  apply AxRule_I. apply MA5_I. exists a. exists (list_Imp A l). auto.
  inversion H5. subst. apply Id. apply IdRule_I. apply Union_introl.
  apply Union_intror. apply In_singleton. inversion H6.
  inversion H3. subst. apply Id. apply IdRule_I. apply Union_intror.
  apply In_singleton. inversion H4.
Qed.

Lemma Box_distrib_list_Imp : forall l A,
    wKH_prv (Empty_set MPropF, list_Imp A l) ->
    wKH_prv (Empty_set MPropF, list_Imp (Box A) (Box_list l)).
Proof.
induction l ; simpl ; intros.
- apply wNec with (ps:=[(Empty_set MPropF, A)]).
  2: apply wNecRule_I. intros. inversion H0 ; subst ; auto.
  inversion H1.
- apply MP with (ps:=[(Empty_set MPropF, (Box (list_Imp A l) --> list_Imp (Box A) (Box_list l)) --> (Box a --> list_Imp (Box A) (Box_list l)));
  (Empty_set MPropF, Box (list_Imp A l) --> list_Imp (Box A) (Box_list l))]).
  2: apply MPRule_I. intros. inversion H0. subst.
  apply MP with (ps:=[(Empty_set MPropF, (Box a --> Box (list_Imp A l)) --> ((Box (list_Imp A l) --> list_Imp (Box A) (Box_list l)) --> (Box a --> list_Imp (Box A) (Box_list l))));
  (Empty_set MPropF, Box a --> Box (list_Imp A l))]).
  2: apply MPRule_I. intros. inversion H1. subst.
  apply Ax. apply AxRule_I. apply MA1_I. exists (Box a).
  exists (Box (list_Imp A l)). exists (list_Imp (Box A) (Box_list l)). auto.
  inversion H2 ; subst. 2: inversion H3.
  apply MP with (ps:=[(Empty_set MPropF, Box (a --> (list_Imp A l)) --> (Box a --> Box (list_Imp A l)));
  (Empty_set MPropF, Box (a --> (list_Imp A l)))]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply Ax. apply AxRule_I. apply MA5_I. exists a. exists (list_Imp A l).
  auto. inversion H4. subst. 2: inversion H5.
  apply wNec with (ps:=[(Empty_set MPropF, a --> list_Imp A l)]).
  2: apply wNecRule_I. intros. inversion H5 ; subst. 2: inversion H6.
  auto. inversion H1 ; subst. 2: inversion H2. apply K_list_Imp.
Qed.

Lemma In_list_In_Box_list : forall l A,
    List.In A l -> List.In (Box A) (Box_list l).
Proof.
induction l ; intros ; simpl.
- inversion H.
- inversion H ;  subst ; auto.
Qed.

Lemma In_Box_list_In_list : forall l A,
     List.In A (Box_list l) -> (exists B, List.In B l /\ A = Box B).
Proof.
induction l ; simpl ; intros.
- inversion H.
- destruct H ; subst. exists a. split ; auto. apply IHl in H.
  destruct H. destruct H. subst. exists x ; auto.
Qed.

Lemma K_rule : forall Γ A, wKH_prv (Γ, A) ->
    wKH_prv ((fun x => (exists B, In _ Γ B /\ x = Box B)), Box A).
Proof.
intros. apply wKH_finite in H. simpl in H. destruct H. destruct H. destruct p.
destruct e.
pose (wKH_monot (fun x1 : MPropF => exists B : MPropF, List.In B x0 /\ x1 = Box B, Box A)).
apply w0 ; simpl ; auto. clear w0.
pose (wKH_Imp_list_Detachment_Deduction_Theorem x0 x A H).
apply i0 in w. clear i0.
apply Box_distrib_list_Imp in w.
remember (fun y => exists B : MPropF, List.In B x0 /\ y = Box B) as Boxed_x.
pose (wKH_Imp_list_Detachment_Deduction_Theorem (Box_list x0) Boxed_x  (Box A)).
apply i0 in w ; auto. intros. split ; intro. subst. destruct H1. destruct H1. subst.
simpl. apply In_list_In_Box_list ; auto. subst. apply In_Box_list_In_list in H1.
auto. intro. intros. inversion H0. destruct H1. subst. unfold In.
exists x2 ; split ; auto. apply i. apply H ; auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD P1 R1 I : Universe, ((wd_ IAB IAC /\ (wd_ IAB IBD /\ (wd_ C1 P1 /\ (wd_ C2 P1 /\ (wd_ IAC P1 /\ (wd_ D1 R1 /\ (wd_ D2 R1 /\ (wd_ IBD R1 /\ (wd_ IAC IBD /\ (wd_ B1 B2 /\ (wd_ D1 D2 /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ B1 C1 /\ (wd_ B1 C2 /\ (wd_ B2 C1 /\ (wd_ B2 C2 /\ (wd_ A1 D1 /\ (wd_ A1 D2 /\ (wd_ A2 D1 /\ (wd_ A2 D2 /\ (col_ A1 A2 IAB /\ (col_ B1 B2 IAB /\ (col_ A1 A2 IAC /\ (col_ C1 C2 IAC /\ (col_ B1 B2 IBD /\ (col_ D1 D2 IBD /\ (col_ IAB IAC A1 /\ (col_ IAB IAC A2 /\ (col_ IAB IBD B1 /\ (col_ IAB IBD B2 /\ (col_ C1 C2 P1 /\ (col_ D1 D2 R1 /\ (col_ IAC P1 I /\ col_ IBD R1 I)))))))))))))))))))))))))))))))))) -> col_ C1 C2 I)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19synthconj1 : forall  (lv0 : natural), (@eq natural (plus Zero (plus Zero lv0)) lv0).
Admitted.
QuickChick conj19synthconj1.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RmiOps.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition smc_realm_destroy_spec0 (rd_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match rd_addr with
    | VZ64 _rd_addr =>
      rely is_int64 _rd_addr;
      when'' _g_rd_base, _g_rd_ofst, adt == find_lock_unused_granule_spec (VZ64 _rd_addr) (VZ64 2) adt;
      when _t'6 == is_null_spec (_g_rd_base, _g_rd_ofst) adt;
      rely is_int _t'6;
      if (_t'6 =? 0) then
        when'' _rd_base, _rd_ofst, adt == granule_map_spec (_g_rd_base, _g_rd_ofst) 2 adt;
        when'' _g_rtt_base, _g_rtt_ofst == get_rd_g_rtt_spec (_rd_base, _rd_ofst) adt;
        rely is_int _g_rtt_ofst;
        when'' _g_rec_list_base, _g_rec_list_ofst == get_rd_g_rec_list_spec (_rd_base, _rd_ofst) adt;
        rely is_int _g_rec_list_ofst;
        when adt == buffer_unmap_spec (_rd_base, _rd_ofst) adt;
        when adt == granule_lock_spec (_g_rtt_base, _g_rtt_ofst) adt;
        when' _t'5, adt == get_g_rtt_refcount_spec (_g_rtt_base, _g_rtt_ofst) adt;
        rely is_int64 _t'5;
        if (negb (_t'5 =? 0)) then
          when adt == granule_unlock_spec (_g_rtt_base, _g_rtt_ofst) adt;
          let _ret := 1 in
          when adt == granule_unlock_spec (_g_rd_base, _g_rd_ofst) adt;
          Some (adt, (VZ64 _ret))
        else
          when adt == realm_destroy_ops_spec (_g_rtt_base, _g_rtt_ofst) (_g_rec_list_base, _g_rec_list_ofst) (_g_rd_base, _g_rd_ofst) adt;
          let _ret := 0 in
          when adt == granule_unlock_spec (_g_rd_base, _g_rd_ofst) adt;
          Some (adt, (VZ64 _ret))
      else
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require Import Omega.
Require Import RelationClasses.

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

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

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

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import FulfillStep.
Require Import MemoryReorder.
Require Import Configuration.
Require Import SmallStep.

Set Implicit Arguments.

Definition promise_consistent (lc:Local.t): Prop :=
  forall loc ts from msg
    (PROMISE: Memory.get loc ts lc.(Local.promises) = Some (from, msg)),
    Time.lt (lc.(Local.tview).(TView.cur).(View.rlx) loc) ts.

Definition promise_consistent_th (tid: Ident.t) (c: Configuration.t) : Prop :=
  forall lst lc
         (THREAD: IdentMap.find tid c.(Configuration.threads) = Some (lst, lc)),
  promise_consistent lc.

Lemma promise_step_promise_consistent
      lc1 mem1 loc from to val released lc2 mem2 kind
      (STEP: Local.promise_step lc1 mem1 loc from to val released lc2 mem2 kind)
      (CONS: promise_consistent lc2):
  promise_consistent lc1.
Proof.
  inv STEP. ii. destruct msg.
  exploit Memory.promise_promises_get1; eauto. i. des.
  exploit CONS; eauto.
Qed.

Lemma read_step_promise_consistent
      lc1 mem1 loc to val released ord lc2
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
      (CONS: promise_consistent lc2):
  promise_consistent lc1.
Proof.
  inv STEP. ii. exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto. ss.
  etrans; [|apply Time.join_l]. etrans; [|apply Time.join_l]. refl.
Qed.

Lemma fulfill_unset_promises
      loc from ts val rel
      promises1 promises2
      l t f m
      (FULFILL: Memory.remove promises1 loc from ts val rel promises2)
      (TH1: Memory.get l t promises1 = Some (f, m))
      (TH2: Memory.get l t promises2 = None):
  l = loc /\ t = ts /\ f = from /\ m.(Message.val) = val /\ View.opt_le rel m.(Message.released).
Proof.
  revert TH2. erewrite Memory.remove_o; eauto. condtac; ss; [|congr].
  des. subst. erewrite Memory.remove_get0 in TH1; eauto. inv TH1.
  esplits; eauto. refl.
Qed.

Lemma write_step_promise_consistent
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (CONS: promise_consistent lc2):
  promise_consistent lc1.
Proof.
  inv STEP. ii.
  destruct (Memory.get loc0 ts promises2) as [[]|] eqn:X.
  - apply CONS in X. eapply TimeFacts.le_lt_lt; eauto.
    s. etrans; [|apply Time.join_l]. refl.
  - destruct msg. inv WRITE.
    exploit Memory.promise_promises_get1; eauto. i. des.
    exploit fulfill_unset_promises; eauto. i. des. subst.
    apply WRITABLE.
Qed.

Lemma fence_step_promise_consistent
      lc1 sc1 mem1 ordr ordw lc2 sc2
      (STEP: Local.fence_step lc1 sc1 ordr ordw lc2 sc2)
      (WF: Local.wf lc1 mem1)
      (SC: Memory.closed_timemap sc1 mem1)
      (MEM: Memory.closed mem1)
      (CONS: promise_consistent lc2):
  promise_consistent lc1.
Proof.
  exploit Local.fence_step_future; eauto. i. des.
  inversion STEP. subst. ii. exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto. apply TVIEW_FUTURE.
Qed.

Lemma ordering_relaxed_dec
      ord:
  Ordering.le ord Ordering.relaxed \/ Ordering.le Ordering.strong_relaxed ord.
Proof. destruct ord; auto. Qed.

Lemma step_promise_consistent
      lang pf e th1 th2
      (STEP: @Thread.step lang pf e th1 th2)
      (CONS: promise_consistent th2.(Thread.local))
      (WF1: Local.wf th1.(Thread.local) th1.(Thread.memory))
      (SC1: Memory.closed_timemap th1.(Thread.sc) th1.(Thread.memory))
      (MEM1: Memory.closed th1.(Thread.memory)):
  promise_consistent th1.(Thread.local).
Proof.
  inv STEP; [inv STEP0|inv STEP0; inv LOCAL]; ss.
  - eapply promise_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
  - eapply write_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
    eapply write_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
Qed.

Lemma rtc_all_step_promise_consistent
      lang th1 th2
      (STEP: rtc (@Thread.all_step lang) th1 th2)
      (CONS: promise_consistent th2.(Thread.local))
      (WF1: Local.wf th1.(Thread.local) th1.(Thread.memory))
      (SC1: Memory.closed_timemap th1.(Thread.sc) th1.(Thread.memory))
      (MEM1: Memory.closed th1.(Thread.memory)):
  promise_consistent th1.(Thread.local).
Proof.
  revert_until STEP. induction STEP; auto. i.
  inv H. inv USTEP. exploit Thread.step_future; eauto. i. des.
  eapply step_promise_consistent; eauto.
Qed.

Lemma rtc_tau_step_promise_consistent
      lang th1 th2
      (STEP: rtc (@Thread.tau_step lang) th1 th2)
      (CONS: promise_consistent th2.(Thread.local))
      (WF1: Local.wf th1.(Thread.local) th1.(Thread.memory))
      (SC1: Memory.closed_timemap th1.(Thread.sc) th1.(Thread.memory))
      (MEM1: Memory.closed th1.(Thread.memory)):
  promise_consistent th1.(Thread.local).
Proof.
  eapply rtc_all_step_promise_consistent; cycle 1; eauto.
  eapply rtc_implies; [|eauto].
  apply tau_union.
Qed.

Lemma consistent_promise_consistent
      lang th
      (CONS: @Thread.consistent lang th)
      (WF: Local.wf th.(Thread.local) th.(Thread.memory))
      (SC: Memory.closed_timemap th.(Thread.sc) th.(Thread.memory))
      (MEM: Memory.closed th.(Thread.memory)):
  promise_consistent th.(Thread.local).
Proof.
  exploit CONS; eauto; try refl. i. des.
  eapply rtc_tau_step_promise_consistent; (try by destruct th; eauto).
  ii. rewrite PROMISES, Memory.bot_get in *. congr.
Qed.

Lemma promise_consistent_promise_read
      lc1 mem1 loc to val ord released lc2
      f t m
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
      (PROMISE: Memory.get loc t lc1.(Local.promises) = Some (f, m))
      (CONS: promise_consistent lc2):
  Time.lt to t.
Proof.
  inv STEP. exploit CONS; eauto. s. i.
  apply TimeFacts.join_lt_des in x. des.
  apply TimeFacts.join_lt_des in AC. des.
  revert BC0. unfold View.singleton_ur_if. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
Qed.

Lemma promise_consistent_promise_write
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      f t m
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (PROMISE: Memory.get loc t lc1.(Local.promises) = Some (f, m))
      (CONS: promise_consistent lc2):
  Time.le to t.
Proof.
  destruct (Memory.get loc t (Local.promises lc2)) as [[]|] eqn:X.
  - inv STEP. inv WRITE. destruct m.
    exploit CONS; eauto. i. ss.
    apply TimeFacts.join_lt_des in x. des.
    left. revert BC. unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - inv STEP. inv WRITE. destruct m.
    exploit Memory.promise_promises_get1; eauto. i. des.
    exploit fulfill_unset_promises; eauto. i. des. subst. refl.
Qed.

Lemma thread_step_unset_promises
      lang loc pf e from ts msg (th1 th2:Thread.t lang)
      (STEP: Thread.step pf e th1 th2)
      (TH1: Memory.get loc ts th1.(Thread.local).(Local.promises) = Some (from, msg))
      (TH2: Memory.get loc ts th2.(Thread.local).(Local.promises) = None):
  exists ord from val rel,
  <<EVENT: ThreadEvent.is_writing e = Some (loc, from, ts, val, rel, ord)>> /\
  <<ORD: Ordering.le ord Ordering.relaxed>> /\
  <<TIME: Time.lt (th1.(Thread.local).(Local.tview).(TView.cur).(View.rlx) loc) ts>>.
Proof.
  inv STEP.
  { inv STEP0. inv LOCAL. destruct msg. ss.
    exploit Memory.promise_promises_get1; eauto. i. des. congr.
  }
  destruct msg.
  inv STEP0; ss; inv LOCAL; ss;
    (try congr);
    (try by inv LOCAL0; ss; congr).
  - inv LOCAL0. inv WRITE.
    exploit Memory.promise_promises_get1; eauto. i. des.
    exploit fulfill_unset_promises; eauto. i. des. subst.
    unfold Memory.get in *.
    esplits; s; eauto.
    + edestruct ordering_relaxed_dec; eauto.
      apply RELEASE in H. des. subst. ss.
      exploit H; eauto. s. i. subst. inv RELEASED. inv x4.
      revert H1. unfold TView.write_released. condtac; ss.
      destruct ord; inv COND. ss.
    + inv WRITABLE. eauto.
  - inv LOCAL1. inv LOCAL2. inv WRITE.
    exploit Memory.promise_promises_get1; eauto. i. des.
    exploit fulfill_unset_promises; eauto. i. des. subst.
    unfold Memory.get in *.
    esplits; s; eauto.
    + edestruct ordering_relaxed_dec; eauto.
      apply RELEASE in H. des. subst. ss.
      exploit H; eauto. s. i. subst. inv RELEASED. inv x4.
      revert H1. unfold TView.write_released. condtac; ss.
      destruct ordw; inv COND. ss.
    + inv WRITABLE. inv READABLE. ss. move TS at bottom.
      eapply TimeFacts.le_lt_lt; eauto.
      repeat (etrans; [|apply Time.join_l]). refl.
Qed.

Lemma rtc_small_step_unset_promises
      tid loc ts c1 lst1 lc1 c2 lst2 lc2 from msg withprm
      (STEPS: rtc (small_step_evt withprm tid) c1 c2)
      (WF: Configuration.wf c1)
      (FIND1: IdentMap.find tid c1.(Configuration.threads) = Some (lst1, lc1))
      (GET1: Memory.get loc ts lc1.(Local.promises) = Some (from, msg))
      (FIND2: IdentMap.find tid c2.(Configuration.threads) = Some (lst2, lc2))
      (GET2: Memory.get loc ts lc2.(Local.promises) = None):
  Time.lt (lc1.(Local.tview).(TView.cur).(View.rlx) loc) ts.
Proof.
  ginduction STEPS; i; subst.
  { ss. rewrite FIND1 in FIND2. depdes FIND2.
    by rewrite GET1 in GET2.
  }
  inv H.
  exploit small_step_future; eauto. intros [WF2 _].
  inv USTEP. ss. rewrite FIND1 in TID. depdes TID.
  destruct (Memory.get loc ts lc3.(Local.promises)) as [[t m]|] eqn: PRM.
  - rewrite IdentMap.gss in IHSTEPS.
    exploit IHSTEPS; eauto.
    intro LT. move STEP at bottom.
    eapply TimeFacts.le_lt_lt; eauto.
    inv WF. exploit thread_step_tview_le; try exact STEP; eauto.
    { eapply WF0. rewrite FIND1. eauto. }
    s. i. apply x1.
  - guardH PFREE.
    eapply thread_step_unset_promises in STEP; eauto. des.
    eauto using small_step_write_lt.
Qed.

Lemma promise_consistent_th_small_step
      tid c1 c2 withprm tid'
      (STEP: small_step_evt withprm tid c1 c2)
      (WF: Configuration.wf c1)
      (FULFILL: promise_consistent_th tid' c2):
  promise_consistent_th tid' c1.
Proof.
  destruct (Ident.eq_dec tid' tid); cycle 1.
  { ii. eapply FULFILL; eauto.
    inv STEP. inv USTEP. s. rewrite IdentMap.gso; eauto.
  }
  subst.
  ii. destruct (IdentMap.find tid (Configuration.threads c2)) as [[lang2 lc2]|] eqn: THREAD2; cycle 1.
  { inv STEP. inv USTEP. ss. by rewrite IdentMap.gss in THREAD2. }
  destruct (Memory.get loc ts (Local.promises lc2)) as [[from2 msg2]|] eqn: PROMISE2; cycle 1.
  - apply Operators_Properties.clos_rt1n_step in STEP.
    eapply rtc_small_step_unset_promises; eauto.
  - eapply FULFILL in PROMISE2; eauto.
    eapply TimeFacts.le_lt_lt; eauto.
    inv STEP. inv USTEP. ss.
    rewrite THREAD in TID. inv TID.
    rewrite IdentMap.gss in THREAD2. inv THREAD2.
    inv WF. exploit thread_step_tview_le; try exact STEP; eauto.
    { eapply WF0. rewrite THREAD. eauto. }
    s. i. apply x0.
Qed.

Lemma promise_consistent_th_rtc_small_step
      tid c1 c2 withprm tid'
      (STEP: rtc (small_step_evt withprm tid) c1 c2)
      (WF: Configuration.wf c1)
      (FULFILL: promise_consistent_th tid' c2):
  promise_consistent_th tid' c1.
Proof.
  ginduction STEP; eauto.
  i. eapply promise_consistent_th_small_step; eauto.
  eapply IHSTEP; eauto.
  inv H. eapply small_step_future; eauto.
Qed.

Lemma consistent_promise_consistent_th
      tid c
      (WF: Configuration.wf c)
      (CONSISTENT: Configuration.consistent c):
  promise_consistent_th tid c.
Proof.
  ii. assert (X:= WF). inv X. inv WF0. destruct lst as [lang st].
  exploit CONSISTENT; eauto; try reflexivity.
  i. des. destruct e2.
  exploit rtc_thread_step_rtc_small_step; [eauto|..].
  { ss. eapply rtc_implies, STEPS. apply tau_union. }
  intro STEPS2.
  eapply rtc_small_step_unset_promises in STEPS2; eauto.
  - destruct c. eapply rtc_small_step_future; eauto.
  - s. rewrite IdentMap.gss. eauto.
  - ss. rewrite PROMISES. apply Cell.bot_get.
Grab Existential Variables. exact true.
Qed.

Lemma promise_consistent_th_small_step_forward
      withprm tid e c1 c2
      (STEP: small_step withprm tid e c1 c2)
      (PRCONS: forall tid0, promise_consistent_th tid0 c1)
      (PRCONS2: promise_consistent_th tid c2)
      (WF: Configuration.wf c1):
  forall tid0, promise_consistent_th tid0 c2.
Proof.
  i. s. destruct (Ident.eq_dec tid0 tid) eqn: EQ.
  - subst. eauto.
  - ii. exploit small_step_find; eauto.
    s; intro X. rewrite <-X in THREAD.
    eapply (PRCONS tid0); eauto.
Qed.

Lemma rtc_promise_consistent_th_small_step_forward
      withprm tid c1 c2
      (STEP: rtc (small_step_evt withprm tid) c1 c2)
      (PRCONS: forall tid0, promise_consistent_th tid0 c1)
      (PRCONS2: promise_consistent_th tid c2)
      (WF: Configuration.wf c1):
  forall tid0, promise_consistent_th tid0 c2.
Proof.
  apply Operators_Properties.clos_rt_rt1n_iff,
        Operators_Properties.clos_rt_rtn1_iff in STEP.
  ginduction STEP; eauto.
  apply Operators_Properties.clos_rt_rtn1_iff,
        Operators_Properties.clos_rt_rt1n_iff in STEP.
  i. inv H. hexploit promise_consistent_th_small_step_forward; eauto; cycle 1.
  { eapply rtc_small_step_future; eauto.
    eapply rtc_implies, STEP. eauto. }
  i. hexploit IHSTEP; eauto.
  eapply promise_consistent_th_small_step; eauto.
  eapply rtc_small_step_future; eauto.
  eapply rtc_implies, STEP. eauto.
Qed.

Lemma promise_consistent_th_small_step_backward
      withprm tid e c1 c2
      (STEP: small_step withprm tid e c1 c2)
      (PRCONS: forall tid0, promise_consistent_th tid0 c2)
      (WF: Configuration.wf c1):
  forall tid0, promise_consistent_th tid0 c1.
Proof.
  i. s. destruct (Ident.eq_dec tid0 tid) eqn: EQ.
  - subst. hexploit promise_consistent_th_small_step; eauto.
  - ii. exploit small_step_find; eauto.
    s; intro X. rewrite X in THREAD.
    eapply (PRCONS tid0); eauto.
Qed.

Lemma rtc_promise_consistent_th_small_step_backward
      withprm tid c1 c2
      (STEP: rtc (small_step_evt withprm tid) c1 c2)
      (PRCONS: forall tid0, promise_consistent_th tid0 c2)
      (WF: Configuration.wf c1):
  forall tid0, promise_consistent_th tid0 c1.
Proof.
  ginduction STEP; eauto.
  i. inv H.
  i. hexploit promise_consistent_th_small_step_backward; eauto.
  i. hexploit IHSTEP; eauto.
  eapply small_step_future; eauto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD P1 R1 I : Universe, ((wd_ IAB IAC /\ (wd_ IAB IBD /\ (wd_ C1 P1 /\ (wd_ C2 P1 /\ (wd_ IAC P1 /\ (wd_ D1 R1 /\ (wd_ D2 R1 /\ (wd_ IBD R1 /\ (wd_ IAC IBD /\ (wd_ B1 B2 /\ (wd_ D1 D2 /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ B1 C1 /\ (wd_ B1 C2 /\ (wd_ B2 C1 /\ (wd_ B2 C2 /\ (wd_ A1 D1 /\ (wd_ A1 D2 /\ (wd_ A2 D1 /\ (wd_ A2 D2 /\ (col_ A1 A2 IAB /\ (col_ B1 B2 IAB /\ (col_ A1 A2 IAC /\ (col_ C1 C2 IAC /\ (col_ B1 B2 IBD /\ (col_ D1 D2 IBD /\ (col_ IAB IAC A1 /\ (col_ IAB IAC A2 /\ (col_ IAB IBD B1 /\ (col_ IAB IBD B2 /\ (col_ C1 C2 P1 /\ (col_ D1 D2 R1 /\ (col_ IAC P1 I /\ col_ IBD R1 I)))))))))))))))))))))))))))))))))) -> col_ D1 D2 I)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Word.WordInterface.
Require Import Common.Types.
Require Import Network.NetworkPacket.
Require Import OpenFlow.OpenFlow0x01Types.

Definition get_packet_handler := switchId -> portId -> packet -> unit.

Inductive predicate : Type :=
  | And : predicate -> predicate -> predicate
  | Or : predicate -> predicate -> predicate
  | Not : predicate -> predicate
  | All : predicate
  | NoPackets : predicate
  | Switch : switchId -> predicate
  | InPort : portId -> predicate
  | DlSrc : dlAddr -> predicate
  | DlDst : dlAddr -> predicate.
  (* TODO(arjun): fill in others *)

Inductive action :=
  | To : portId -> action
  | ToAll : action
  | GetPacket : get_packet_handler -> action.

Inductive policy :=
  | Policy : predicate -> list action -> policy
  | Par : policy -> policy -> policy. (** parallel composition *)


Require Import CoqlibC Maps Postorder.
Require Import AST Linking.
Require Import ValuesC Memory GlobalenvsC Events Smallstep.
Require Import Op Registers ClightC Renumber.
Require Import CtypesC CtypingC.
Require Import sflib.
Require Import IntegersC.

Require Import MutrecHeader.
Require Import MutrecA MutrecAspec.
Require Import Simulation.
Require Import Skeleton Mod ModSem SimMod SimModSemLift SimSymb SimMemLift AsmregsC MatchSimModSem.
Require SoundTop.
Require SimMemInjC SimMemInjInvC.
Require Import Clightdefs.
Require Import CtypesC.

Set Implicit Arguments.

Definition memoized_inv: SimMemInjInv.memblk_invariant :=
  SimMemInjInv.memblk_invarant_mk
    (fun mem =>
       forall
         chunk ofs ind
         (BOUND: 0 <= ind < 1000)
         (INT: chunk = Mint32)
         (INDEX: size_chunk Mint32 * ind = ofs),
       exists i,
         (<<VINT: mem chunk ofs = Some (Vint i)>>) /\
         (<<VAL: forall (NZERO: i.(Int.intval) <> 0),
             (<<MEMO: i = sum (Int.repr ind)>>)>>))
    (fun chunk ofs p =>
       exists ind,
         (<<CHUNK: chunk = Mint32>>) /\ (<<BOUND: 0 <= ind < 1000>>) /\
         (<<INDEX: ofs = size_chunk Mint32 * ind>>) /\ (<<WRITABLE: p = Writable>>)).

Local Instance SimMemMemoizedA: SimMem.class := SimMemInjInvC.SimMemInjInv
                                                 SimMemInjInv.top_inv memoized_inv.

Definition symbol_memoized: ident -> Prop := eq _memoized.

Lemma memoized_inv_store_le i ind blk ofs m_tgt
      (sm0 sm1: SimMemInjInv.t')
      (MWF: SimMem.wf sm0)
      (INVAR: sm0.(SimMemInjInv.mem_inv_tgt) blk)
      (SUM: i = sum (Int.repr ind))
      (OFS: ofs = size_chunk Mint32 * ind)
      (STR: Mem.store Mint32 sm0.(SimMemInjInv.minj).(SimMemInj.tgt) blk ofs (Vint i) = Some m_tgt)
      (MREL: sm1 = SimMemInjInv.mk
                     (SimMemInjC.update
                        (sm0.(SimMemInjInv.minj))
                        (sm0.(SimMemInjInv.minj).(SimMemInj.src))
                        m_tgt
                        (sm0.(SimMemInjInv.minj).(SimMemInj.inj)))
                     sm0.(SimMemInjInv.mem_inv_src)
                     sm0.(SimMemInjInv.mem_inv_tgt))
  :
    (<<MLE: SimMem.le sm0 sm1>>) /\
    (<<MWF: SimMem.wf sm1>>).
Proof.
  inv MWF. split.
  - econs; ss; eauto. econs; ss; eauto.
    + refl.
    + eapply Mem.store_unchanged_on; eauto.
      ii. inv WF. exploit INVRANGETGT; eauto. i. des.
      exfalso. eauto.
    + eapply SimMemInj.frozen_refl. + eapply SimMemInj.frozen_refl.
    + ii. eapply Mem.perm_store_2; eauto.
  - inv WF. econs; ss; eauto.
    + unfold SimMemInjC.update. econs; ss; eauto.
      * eapply MemoryC.private_unchanged_inject; eauto.
        { eapply Mem.store_unchanged_on; eauto.
          instantiate (1:=~2
                        loc_out_of_reach (SimMemInj.inj (SimMemInjInv.minj sm0))
                        (SimMemInj.src (SimMemInjInv.minj sm0))).
          ss. ii. eapply H0.
          exploit INVRANGETGT; eauto. i. des. eapply H1. }
        { ss. }
      * etrans; eauto.
        unfold SimMemInj.tgt_private, SimMemInj.valid_blocks in *. ss.
        ii. des. split; auto. eapply Mem.store_valid_block_1; eauto.
      * rpapply TGTLE. eapply Mem.nextblock_store; eauto.
    + ii. exploit SATTGT; eauto. i. inv H. econs; ss.
      * i. exploit PERMISSIONS; eauto. i.
        eapply Mem.store_valid_access_1; eauto.
      * i. exploit LOADVALS; eauto. i. des. destruct (peq blk blk0).
        { clarify. destruct (zeq ind ind0).
          - clarify. exists (sum (Int.repr ind0)).
            esplits; eauto. erewrite Mem.load_store_same; eauto. ss.
          - exists i. erewrite Mem.load_store_other; eauto.
            right. clear - n. ss. omega. }
        { exists i. erewrite Mem.load_store_other; eauto. }
Qed.

Section SIMMODSEM.

Variable skenv_link: SkEnv.t.
Variable sm_link: SimMem.t.
Let md_src: Mod.t := (MutrecAspec.module).
Let md_tgt: Mod.t := (ClightC.module2 prog).
Hypothesis (INCL: SkEnv.includes skenv_link (Mod.sk md_src)).
Hypothesis (WF: SkEnv.wf skenv_link).
Let ge := (SkEnv.project skenv_link (Mod.sk md_src)).
Let tge := Build_genv (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_tgt)) prog) prog.(prog_comp_env).
Definition msp: ModSemPair.t :=
  ModSemPair.mk (md_src skenv_link) (md_tgt skenv_link) (SimMemInjInvC.mk symbol_memoized md_src md_tgt) sm_link.

Inductive match_states_internal: nat -> MutrecAspec.state -> Clight.state -> Prop :=
| match_callstate_nonzero
    idx i m_src m_tgt
    fptr
    (RANGE: 0 <= i.(Int.intval) < MAX)
    (FINDF: Genv.find_funct (Smallstep.globalenv (modsem2 skenv_link prog)) fptr = Some (Internal func_f))
    (IDX: (idx > 3)%nat)
  :
    match_states_internal idx (Callstate i m_src) (Clight.Callstate fptr (Tfunction
                                                                            (Tcons tint Tnil) tint cc_default)
                                                                    [Vint i] Kstop m_tgt)
| match_returnstate
    idx i m_src m_tgt
  :
    match_states_internal idx (Returnstate i m_src) (Clight.Returnstate (Vint i) Kstop m_tgt)
.

Inductive match_states
          (idx: nat) (st_src0: MutrecAspec.state) (st_tgt0: Clight.state) (sm0: SimMem.t): Prop :=
| match_states_intro
    (MATCHST: match_states_internal idx st_src0 st_tgt0)
    (MCOMPATSRC: (get_mem st_src0) = sm0.(SimMem.src))
    (MCOMPATTGT: (ClightC.get_mem st_tgt0) = sm0.(SimMem.tgt))
    (MWF: SimMem.wf sm0)
.

Lemma g_blk_exists
  :
    exists g_blk,
      (<<FINDG: Genv.find_symbol
                  (SkEnv.revive (SkEnv.project skenv_link (CSk.of_program signature_of_function prog)) prog)
                  g_id = Some g_blk>>)
      /\
      (<<FINDG: Genv.find_funct_ptr
                  (SkEnv.revive (SkEnv.project skenv_link (CSk.of_program signature_of_function prog)) prog)
                  g_blk = None>>)
      /\
      (<<FINDG: exists skd, Genv.find_funct_ptr skenv_link g_blk = Some skd /\
                            Some (signature_of_type (Tcons tint Tnil) tint cc_default) = Sk.get_csig skd>>)
.
Proof.
  exploit (prog_defmap_norepet prog g_id); eauto.
  { unfold prog_defs_names. ss. repeat (econs; eauto).
    - ii; ss; des; ss.
    - ii; ss; des; ss. }
  { ss. eauto. }
  intro T; des.
  exploit SkEnv.project_impl_spec; eauto. intro PROJ.
  assert(PREC: SkEnv.genv_precise
                 (SkEnv.revive (SkEnv.project skenv_link (CSk.of_program signature_of_function prog)) prog)
                 prog).
  { eapply CSkEnv.project_revive_precise; ss; et. }
  inv PREC.
  exploit (P2GE g_id); eauto. i; des. des_ifs.
  rename b into g_blk.
  eexists. splits; et.
  { unfold Genv.find_funct_ptr. des_ifs. }
  { inv INCL.
    exploit (CSk.of_program_prog_defmap prog signature_of_function); et. rewrite T. intro S.

    remember ((prog_defmap (CSk.of_program signature_of_function prog)) ! g_id) as U in *.
    destruct U eqn:V; try (by ss). inv S. inv H1.

    exploit DEFS; eauto. i; des.
    assert(blk = g_blk).
    { inv PROJ. exploit SYMBKEEP; et.
      - instantiate (1:= g_id). unfold defs. des_sumbool. ss. et.
      - i. rewrite SYMB0 in *. clear - SYMB H. unfold SkEnv.revive in *. rewrite Genv_map_defs_symb in *. ss.
        rewrite SYMB in *. des. clarify.
    }
    clarify. inv MATCH.
    esplits; eauto.
    - unfold Genv.find_funct_ptr. rewrite DEF0. et.
    - ss. des_ifs. clear - H1. inv H1; ss.
  }
Qed.

Lemma match_states_lxsim
      idx st_src0 st_tgt0 sm0
      (SIMSK: SimSymb.sim_skenv
                sm0 (SimMemInjInvC.mk symbol_memoized md_src md_tgt)
                (SkEnv.project skenv_link (CSk.of_program signature_of_function prog))
                (SkEnv.project skenv_link (CSk.of_program signature_of_function prog)))
      (MATCH: match_states idx st_src0 st_tgt0 sm0)
  :
    <<XSIM: lxsimL (md_src skenv_link) (md_tgt skenv_link)
                   (fun st => unit -> exists su m_init, SoundTop.sound_state su m_init st)
                   top3 (fun _ _ => SimMem.le)
                   (Ord.lift_idx lt_wf idx) st_src0 st_tgt0 sm0>>
.
Proof.
  revert_until tge.
  pcofix CIH.
  i.
  pfold.
  generalize g_blk_exists; et. i; des.
  inv MATCH; subst. ss. inv MATCHST; ss; clarify.
  - (* call *)
    destruct (classic (i = Int.zero)).
    + (* zero *)
      clarify.
      econs 2. ii.
      econs 2.
      { split.
        - econs 2.
          + ss. econs 1.
          + econs 1.
          + ss.
        - eapply Ord.lift_idx_spec.
          instantiate (1:=3%nat). nia. }
      refl.

      left. pfold.
      econs 1. i; des.
      econs 2.

      * split; cycle 1.
        { apply Ord.lift_idx_spec.
          instantiate (1:=2%nat). nia. }

        eapply plus_left with (t1 := E0) (t2 := E0); ss.
        { econs; eauto.
          { eapply modsem2_determinate; eauto. }
          econs; eauto.
          econs; ss; eauto; try (by repeat (econs; ss; eauto)).
          unfold _x. unfold _t'1. rr. ii; ss. des; ss; clarify.
        }

        eapply star_left with (t1 := E0) (t2 := E0); ss.
        { econs; eauto.
          { eapply modsem2_determinate; eauto. }
          econs; eauto.
        }

        eapply star_left with (t1 := E0) (t2 := E0); ss.
        { econs; eauto.
          { eapply modsem2_determinate; eauto. }
          econs; eauto.
          - repeat econs; et.
          - ss.
        }

        eapply star_left with (t1 := E0) (t2 := E0); ss.
        { econs; eauto.
          { eapply modsem2_determinate; eauto. }
          econs; eauto.
          - repeat econs; et.
          - ss.
          - ss.
        }

        apply star_refl.
      * refl.
      * right. eapply CIH; eauto. econs; ss; eauto.
        replace (Int.repr 0) with (sum Int.zero).
        { econs; eauto. }
        { rewrite sum_recurse. des_ifs. }

    + (* nonzero *)

      destruct (Genv.find_symbol
                  (SkEnv.project skenv_link (CSk.of_program signature_of_function prog))
                  _memoized) eqn:BLK; cycle 1.
      { exfalso. clear - INCL BLK. inversion INCL; subst.
        exploit DEFS; eauto.
        - instantiate (2:=_memoized). ss.
        - i. des.
          exploit SkEnv.project_impl_spec. eapply INCL. i. inv H. ss.
          exploit SYMBKEEP. instantiate (1:=_memoized). ss. i.
          rr in H. rewrite H in *. clarify. }

      inv MWF. ss.

      assert (INVAR: SimMemInjInv.mem_inv_tgt sm0 b).
      { inv SIMSK. ss. inv INJECT.
        eapply INVCOMPAT; eauto. ss. }

      hexploit SATTGT; eauto. intros SAT0.
      exploit SAT0; eauto. i. inv H0. ss.
      hexploit LOADVALS; eauto. i. des.

      destruct (zeq (Int.intval i0) 0).
      {
        econs 2. ii.
        econs 2.
        { split.
          - econs 2; ss.
            + econs 2; eauto.
              clear - H.
              exploit Int.eq_false; eauto. i.
              unfold Int.eq in *. ss. des_ifs.
            + econs; eauto.
            + ss.
          - eapply Ord.lift_idx_spec. eauto. }
        refl.

        left. pfold.
        econs.
        i; des.
        econs 2; eauto.
        * esplits; cycle 1.
          { eapply Ord.lift_idx_spec. eauto. }

          eapply plus_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
            econs; ss; eauto; try (by repeat (econs; ss; eauto)).
            unfold _x. unfold _t'1. rr. ii; ss. des; ss; clarify.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
            - repeat econs; et.
            - ss. rewrite Int.eq_false; ss.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto; swap 1 2.
            - econs.
              + ss. econs. econs; ss.
                * econs.
                  { eapply eval_Evar_global; ss.
                    instantiate (1:=b). eauto. }
                  { econs 2; ss. }
                * econs; ss.
                * ss.
              + econs 1; ss. psimpl.
                replace (Ptrofs.unsigned (Ptrofs.mul (Ptrofs.repr 4) (Ptrofs.of_ints i)))
                  with (4 * Int.intval i); cycle 1.
                { unfold Ptrofs.mul. ss.
                  destruct i. ss. unfold Ptrofs.of_ints. ss.
                  unfold Int.signed. ss. des_ifs; cycle 1;
                  unfold Int.half_modulus, Int.modulus, two_power_nat in *; ss;
                    unfold MAX in *; rewrite <- Zdiv2_div in *; ss.
                  { lia. }
                  repeat rewrite Ptrofs.unsigned_repr. auto.
                  all : unfold Ptrofs.max_unsigned; rewrite Ptrofs.modulus_power;
                  unfold Ptrofs.zwordsize, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize; des_ifs; ss; omega. } eauto. }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            ss. econs; eauto.
            - econs; ss.
              + econs; ss.
              + econs; ss.
              + ss.
            - ss. instantiate (1:=true).
              unfold Cop.bool_val. ss.
              unfold Int.eq. unfold Val.of_bool.
              destruct (zeq (Int.unsigned i0) (Int.unsigned (Int.repr 0))) eqn:EQ; ss. }
          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto; swap 1 2.
            - econs.
              + eapply eval_Evar_global; ss. et.
              + econs 2; et.
            - unfold Cop.classify_fun. ss.
            - repeat econs; ss; et.
          }

          eapply star_refl.

        * refl.

        * left. pfold. econs 3; et.
          { econs; eauto. }
          { econs. econs; eauto. }
          ii; des.
          inv ATSRC. ss; clarify.

          unfold Clight.fundef in *.
          assert(g_fptr = g_blk).
          { unfold SkEnv.revive in FINDG. rewrite Genv_map_defs_symb in *. clarify. }
          clarify.
          eexists (Args.mk _ [Vint (Int.sub i (Int.repr 1))] _).
          exists sm0.
          esplits; ss; eauto.
          { econs; ss; eauto.
            instantiate (1:=Vptr g_blk Ptrofs.zero).
            inv SIMSK. inv SIMSKENV. inv INJECT. ss.
            econs. eapply DOMAIN; eauto.
            exploit Genv.genv_symb_range. unfold Genv.find_symbol in *. eauto.
            i. ss. ii.
            exploit INVCOMPAT; eauto. i. rewrite <- H1 in H0. ss.
            rewrite Ptrofs.add_zero_l. ss. }
          { refl. }
          { econs; eauto. }
          i. inv AFTERSRC. inv SIMRETV; ss; clarify.

          hexploit Mem.valid_access_store.
          { instantiate (4:=sm_ret.(SimMemInjInv.minj).(SimMemInj.tgt)).
            inv MWF. inv WF. exploit SATTGT0; eauto.
            - inv MLE. erewrite <- MINVEQTGT. eauto.
            - i. inv H0. hexploit PERMISSIONS0; eauto. ss.
              esplits; eauto. }
          intros [m_tgt STR].

          exploit SimMemInjInvC.unlift_wf; try apply MLE; eauto.
          { econs; eauto. } intros MLE1.
          exploit memoized_inv_store_le; eauto.
          i. des.

          esplits.
          { econs; eauto. }
          { apply MLE0. }

          left. pfold. econs; eauto. i; des. econs 2; eauto.
          {
            esplits; eauto; cycle 1.
            { instantiate (1:= (Ord.lift_idx lt_wf 14%nat)). eapply Ord.lift_idx_spec; et. }

            eapply plus_left with (t1 := E0) (t2 := E0); ss.
            { econs; eauto.
              { eapply modsem2_determinate; eauto. }
              econs; eauto.
            }

            eapply star_left with (t1 := E0) (t2 := E0); ss.
            { econs; eauto.
              { eapply modsem2_determinate; eauto. }
              econs; eauto.
            }

            eapply star_left with (t1 := E0) (t2 := E0); ss.
            { econs; eauto.
              { eapply modsem2_determinate; eauto. }
              econs; eauto. econs; eauto.
              - econs; eauto. ss.
              - econs; eauto. ss.
              - inv RETV. ss. unfold typify. des_ifs. }

            eapply star_left with (t1 := E0) (t2 := E0); ss.
            { econs; eauto.
              { eapply modsem2_determinate; eauto. }
              econs; eauto.
            }

            eapply star_left with (t1 := E0) (t2 := E0); ss.
            { econs; eauto.
              { eapply modsem2_determinate; eauto. }
              econs; eauto.
              - econs; eauto. econs; eauto.
                + econs; eauto.
                  * eapply eval_Evar_global; ss.
                    instantiate (1:=b). ss.
                  * ss. econs 2; eauto.
                + econs; eauto. ss.
                + econs; eauto.
              - econs; eauto. ss.
              - ss.
              - ss. psimpl. econs; ss; eauto.
                rpapply STR. f_equal.
                + unfold Ptrofs.mul. ss.
                  destruct i. ss. unfold Ptrofs.of_ints. ss.
                  unfold Int.signed. ss. des_ifs; cycle 1;
                  unfold Int.half_modulus, Int.modulus, two_power_nat in *; ss;
                    unfold MAX in *; rewrite <- Zdiv2_div in *; ss.
                  { lia. }
                  repeat rewrite Ptrofs.unsigned_repr. auto.
                  all : unfold Ptrofs.max_unsigned; rewrite Ptrofs.modulus_power;
                    unfold Ptrofs.zwordsize, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize; des_ifs; ss; omega.
                + f_equal.
                  rewrite Int.repr_unsigned.
                  rewrite sum_recurse with (i := i). des_ifs.
                  rewrite Z.eqb_eq in Heq.
                  exploit Int.eq_spec. instantiate (1:=i). instantiate (1:=Int.zero).
                  unfold Int.eq. unfold Int.unsigned. rewrite Heq. des_ifs. i. subst i.
                  rewrite Int.sub_zero_r. rewrite sum_recurse. des_ifs. }

            eapply star_left with (t1 := E0) (t2 := E0); ss.
            { econs; eauto.
              { eapply modsem2_determinate; eauto. }
              econs; eauto.
            }

            eapply star_left with (t1 := E0) (t2 := E0); ss.
            { econs; eauto.
              { eapply modsem2_determinate; eauto. }
              econs; eauto.
              - econs; eauto. ss.
              - econs; eauto.
              - econs; eauto. }

            eapply star_refl.
          }
          { refl. }

          right. eapply CIH.
          { eapply SimMemInjInvC.sim_skenv_inj_lepriv; cycle 1; eauto.
            etrans; eauto.
            { exploit (SimMemLift.lift_priv sm0); eauto. ss. }
            etrans; eauto; cycle 1.
            { hexploit SimMem.pub_priv; try apply MLE0. eauto. }
            etrans; eauto.
            { hexploit SimMem.pub_priv; try apply MLE; eauto. }
            hexploit SimMemLift.unlift_priv; revgoals.
            { intro T. ss. eauto. }
            { eauto. }
            { eauto. }
            { exploit (SimMemLift.lift_priv sm0); eauto. ss. }
            { econs; eauto. } }
          { econs; ss.
            - replace (Int.add (sum (Int.sub i Int.one)) i) with (sum i); cycle 1.
              { rewrite sum_recurse with (i := i). des_ifs.
                rewrite Z.eqb_eq in Heq.
                exploit Int.eq_spec. instantiate (1:=i). instantiate (1:=Int.zero).
                unfold Int.eq. unfold Int.unsigned. rewrite Heq. des_ifs. i. subst i.
                rewrite Int.sub_zero_r. rewrite sum_recurse. des_ifs. }

              econs 2.
          }
      }

      { hexploit VAL; eauto. i. des. clarify.

        econs 2. ii.
        econs 2.
        { split.
          - econs 2; ss.
            + econs; eauto.
            + econs; eauto.
            + ss.
          - eapply Ord.lift_idx_spec. eauto. }
        refl.

        left. pfold.
        econs.
        i; des.
        econs 2; eauto.
        * esplits; cycle 1.
          { eapply Ord.lift_idx_spec. eauto. }

          eapply plus_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
            econs; ss; eauto; try (by repeat (econs; ss; eauto)).
            unfold _x. unfold _t'1. rr. ii; ss. des; ss; clarify.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
            - repeat econs; et.
            - ss. rewrite Int.eq_false; ss.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto; swap 1 2.
            - econs.
              + ss. econs. econs; ss.
                * econs.
                  { eapply eval_Evar_global; ss.
                    instantiate (1:=b). ss. }
                  { econs 2; ss. }
                * econs; ss.
                * ss.
              + econs 1; ss. psimpl.
                replace (Ptrofs.unsigned (Ptrofs.mul (Ptrofs.repr 4) (Ptrofs.of_ints i)))
                  with (4 * Int.intval i); cycle 1.
                { unfold Ptrofs.mul. ss.
                  destruct i. ss. unfold Ptrofs.of_ints. ss.
                  unfold Int.signed. ss. des_ifs; cycle 1;
                  unfold Int.half_modulus, Int.modulus, two_power_nat in *; ss;
                    unfold MAX in *; rewrite <- Zdiv2_div in *; ss.
                  { lia. }
                  repeat rewrite Ptrofs.unsigned_repr. auto.
                  all : unfold Ptrofs.max_unsigned; rewrite Ptrofs.modulus_power;
                  unfold Ptrofs.zwordsize, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize; des_ifs; ss; omega. } eauto. }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            ss. econs; eauto.
            - econs; ss.
              + econs; ss.
              + econs; ss.
              + ss.
            - ss. instantiate (1:=false).
              unfold Cop.bool_val. ss.
              unfold Int.eq. unfold Val.of_bool.
              destruct (zeq (Int.unsigned (sum (Int.repr (Int.intval i))))
                            (Int.unsigned (Int.repr 0))) eqn:EQ; ss. }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
          }

          eapply star_left with (t1 := E0) (t2 := E0); ss.
          { econs; eauto.
            { eapply modsem2_determinate; eauto. }
            econs; eauto.
            - econs; ss.
            - econs.
            - ss. }

          apply star_refl.

        * refl.

        * right. eapply CIH; eauto.
          { econs; eauto.
            - ss. replace (Int.repr (Int.intval i)) with i.
              + econs; eauto.
              + symmetry. eapply Int.eqm_repr_eq.
                eapply Int.eqm_refl2. ss.
            - econs; eauto. }
      }

  - (* return *)
    econs 4; ss; eauto.
    + refl.
    + econs; ss; eauto.
Qed.

Theorem sim_modsem
  :
    ModSemPair.sim msp
.
Proof.
  eapply sim_mod_sem_implies.
  eapply ModSemPair.simL_intro with (has_footprint := top3) (mle_excl := fun _ _ => SimMem.le).
  { i. eapply SoundTop.sound_state_local_preservation. }
  { i. eapply Preservation.local_preservation_noguarantee_weak; eauto. eapply SoundTop.sound_state_local_preservation. }
  { ii; ss. r. etrans; eauto. }
  { ii. eauto. }
  i. ss. esplits; eauto.

  - i. des. inv SAFESRC.
    esplits; eauto.
    + refl.
    + econs; eauto.
    + instantiate (1:= (Ord.lift_idx lt_wf 15%nat)).
      inv INITTGT. inv TYP. ss.
      assert (FD: fd = func_f).
      { destruct args_src, args_tgt; ss. clarify.
        inv SIMARGS; ss. clarify. inv VALS. inv H1. inv H3. inv FPTR. ss.
        des_ifs.
        inv SIMSKENV. ss. inv SIMSKE. ss. inv INJECT. ss.
        exploit IMAGE; eauto.
        { exploit Genv.genv_symb_range.
          unfold Genv.find_symbol in SYMB. eauto. i. ss. eauto. }
        ii. des. subst. clarify.

        rewrite Genv.find_funct_ptr_iff in FINDF.
        unfold Genv.find_def in FINDF. ss.
        do 2 rewrite MapsC.PTree_filter_map_spec, o_bind_ignore in *.
        des_ifs.
        destruct (Genv.invert_symbol
                    (SkEnv.project skenv_link (CSk.of_program signature_of_function prog)) b2) eqn:SKENVSYMB; ss.
        unfold o_bind in FINDF. ss.
        exploit Genv.find_invert_symbol. eauto. i.
        rewrite H in *. clarify.
        destruct ((prog_defmap prog) ! f_id) eqn:DMAP; ss. clarify. } clarify.

      inv SIMARGS; ss. rewrite VS in *. inv VALS.
      inv H3. inv H1.
      unfold typify_list, zip, typify. ss. des_ifs; ss.

      eapply match_states_lxsim; ss.
      * inv SIMSKENV; eauto.
      * econs; eauto.
        { econs; eauto. omega. }

  - (* init progress *)
    i.
    des. inv SAFESRC.
    inv SIMARGS; ss.

    esplits; eauto. econs; eauto.
    + instantiate (1:= func_f).
      ss.
      inv VALS; ss. inv H1. inv H0. inv FPTR0. ss.
      des_ifs.
      inv SIMSKENV. ss. inv SIMSKE. ss. inv INJECT. ss.
      exploit IMAGE; eauto.
      { exploit Genv.genv_symb_range.
        unfold Genv.find_symbol in SYMB. eauto. i. ss. eauto. }
      ii. des. subst. clarify.

      rewrite Genv.find_funct_ptr_iff in *.
      unfold Genv.find_def in *; ss.
      do 2 rewrite MapsC.PTree_filter_map_spec, o_bind_ignore in *.
      des_ifs.
      exploit Genv.find_invert_symbol. eauto. i.
      rewrite H0 in *. clarify.
    + econs; ss. erewrite <- inject_list_length; eauto.
      rewrite VS. auto.
Qed.

End SIMMODSEM.

Theorem sim_mod
  :
    ModPair.sim (ModPair.mk (MutrecAspec.module) (ClightC.module2 prog) (SimMemInjInvC.mk symbol_memoized (MutrecAspec.module) (ClightC.module2 prog)))
.
Proof.
  econs; ss.
  - econs; ss.
    + i. inv SS. esplits; ss; eauto.
      * econs; ss.
        ii. des. econs.
        { ii. ss. des. clarify. econs; ss.
          - ii. eapply PERM; eauto. unfold MAX in *. lia.
          - eapply Z.divide_factor_l. }
        { ss. i. clarify. erewrite INIT; ss; eauto.
          - esplits; eauto. i. rewrite sum_recurse. des_ifs.
          - lia.
          - unfold MAX. lia.
          - eapply Z.divide_factor_l. }
      * ii. des; clarify.
    + ii. destruct H. eapply in_prog_defmap in PROG.
      ss. unfold update_snd in PROG. ss.
      des; clarify; inv DROP; ss.
      des; clarify.
  - ii. ss.
    inv SIMSKENVLINK. inv SIMSKENV.
    eapply sim_modsem; eauto.
Qed.


Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.BasicFacts.
Require Import UFO.Rel.Monotone.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Set Implicit Arguments.

Section section_ccompat_tm_app_tm.

Context (EV LV : Set).
Context (Ξ : XEnv EV LV).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (S : ty ∅ EV LV ∅) (σ : ms ∅ EV LV ∅) (ℓ : lbl LV ∅) (E : eff ∅ EV LV ∅).

Lemma ccompat_tm_app_tm2 n ξ₁ ξ₂ (v₁ v₂ : val0) (s₁ s₂ : tm0) :
  n ⊨ 𝓥⟦ Ξ ⊢ (ty_ms (ms_tm S σ) ℓ) ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ →
  n ⊨ 𝓣⟦ Ξ ⊢ S # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ s₁ s₂ →
  n ⊨ 𝓣⟦ Ξ ⊢ (ty_ms σ ℓ) # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (tm_app_tm v₁ s₁) (tm_app_tm v₂ s₂).
Proof.
intros Hv Hs.
change (tm_app_tm (tm_val v₁) s₁)
with (ktx_plug (ktx_app_tm2 ktx_hole v₁) s₁).
change (tm_app_tm (tm_val v₂) s₂)
with (ktx_plug (ktx_app_tm2 ktx_hole v₂) s₂).
eapply plug0 ; try apply Hs ;
  [ crush | crush | | apply postfix_refl | apply postfix_refl ].

iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
iintro u₁ ; iintro u₂ ; iintro Hu.
simpl ktx_plug.

destruct v₁ as [ | | | m₁ [ | X₁ ] | m₁ [ | X₁ ] ], v₂ as [ | | | m₂ [ | X₂ ] | m₂ [ | X₂ ] ] ; simpl 𝓥_Fun in Hv ;
idestruct Hv as m₁' Hv ; idestruct Hv as m₂' Hv ;
idestruct Hv as X₁' Hv ; idestruct Hv as X₂' Hv ;
idestruct Hv as Hv Hr ; ielim_prop Hv ; destruct Hv as [Hv₁ Hv₂] ;
inversion Hv₁ ; inversion Hv₂ ; clear Hv₁ Hv₂ ; subst m₁' m₂' X₁' X₂'.

idestruct Hr as HX₁X₂ Hr ; idestruct Hr as m₁' Hr ; idestruct Hr as m₂' Hr ;
idestruct Hr as Hm Hr ; ielim_prop Hm ; destruct Hm ; subst m₁ m₂.
eapply 𝓣_step_r ; [ apply step_app_tm | ].
eapply 𝓣_step_l ; [ apply step_app_tm | ].
iintro_later.
apply 𝓥_in_𝓣.
simpl 𝓥_Fun.
repeat ieexists ; repeat isplit ; [ crush | assumption | ].

ielim_vars Hr ; [ | eassumption | eassumption ].
iespecialize Hr ; ispecialize Hr ; [ eassumption | ].
apply Hr.
Qed.

Lemma ccompat_tm_app_tm n ξ₁ ξ₂ (t₁ t₂ s₁ s₂ : tm0) :
  n ⊨ 𝓣⟦ Ξ ⊢ (ty_ms (ms_tm S σ) ℓ) # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ →
  n ⊨ ( ∀ᵢ ξ₁' ξ₂' (_ : postfix ξ₁ ξ₁') (_ : postfix ξ₂ ξ₂'),
        𝓣⟦ Ξ ⊢ S # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁' ξ₂' s₁ s₂
      ) →
  n ⊨ 𝓣⟦ Ξ ⊢ (ty_ms σ ℓ) # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (tm_app_tm t₁ s₁) (tm_app_tm t₂ s₂).
Proof.
intros Ht Hs.
change (tm_app_tm t₁ s₁)
with (ktx_plug (ktx_app_tm1 ktx_hole s₁) t₁).
change (tm_app_tm t₂ s₂)
with (ktx_plug (ktx_app_tm1 ktx_hole s₂) t₂).
eapply plug0 ; try apply Ht ;
  [ crush | crush | | apply postfix_refl | apply postfix_refl ].

iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
iintro v₁ ; iintro v₂ ; iintro Hv.
simpl ktx_plug.

ielim_vars Hs ; [ | eassumption | eassumption ].
apply ccompat_tm_app_tm2 ; eauto.
Qed.

End section_ccompat_tm_app_tm.

Section section_compat_tm_app_tm.

Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (S : ty ∅ EV LV ∅) (σ : ms ∅ EV LV ∅) (ℓ : lbl LV ∅) (E : eff ∅ EV LV ∅).

Lemma compat_tm_app_tm n t₁ t₂ s₁ s₂ :
n ⊨ ⟦ Ξ Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : (ty_ms (ms_tm S σ) ℓ) # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ s₁ ≼ˡᵒᵍ s₂ : S # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (tm_app_tm t₁ s₁) ≼ˡᵒᵍ (tm_app_tm t₂ s₂) : (ty_ms σ ℓ) # E ⟧.
Proof.
intros Ht Hs.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
simpl subst_tm.
eapply ccompat_tm_app_tm.
+ iespecialize Ht.
  ispecialize Ht ; [ eassumption | ].
  ispecialize Ht ; [ eassumption | ].
  ispecialize Ht ; [ eassumption | ].
  ispecialize Ht ; [ eassumption | ].
  apply Ht.
+ iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
  ispecialize Hs ξ₁' ; ispecialize Hs ξ₂' ; iespecialize Hs.
  ispecialize Hs.
  { ielim_prop Hξ ; iintro_prop ; eapply 𝜩_monotone ; eauto. }
  ispecialize Hs.
  { eapply δ_is_closed_monotone ; eassumption. }
  ispecialize Hs.
  { ielim_prop Hρ ; iintro_prop ; eapply ρ₁ρ₂_are_closed_monotone ; eauto. }
  ispecialize Hs.
  { eapply 𝜞_monotone ; eauto. }
  apply Hs.
Qed.

Lemma compat_ktx_app_tm1 n T' E' K₁ K₂ s₁ s₂ :
  n ⊨ ⟦ Ξ Γ ⊢ K₁ ≼ˡᵒᵍ K₂ : T' # E' ⇢ (ty_ms (ms_tm S σ) ℓ) # E ⟧ →
  n ⊨ ⟦ Ξ Γ ⊢ s₁ ≼ˡᵒᵍ s₂ : S # E ⟧ →
  n ⊨ ⟦ Ξ Γ ⊢ (ktx_app_tm1 K₁ s₁) ≼ˡᵒᵍ (ktx_app_tm1 K₂ s₂) : T' # E' ⇢ (ty_ms σ ℓ) # E ⟧.
Proof.
intros HK Hs.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro t₁ ; iintro t₂ ; iintro Ht.
iespecialize HK.
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ielim_vars HK ; [ | eassumption | eassumption ].
iespecialize HK ; ispecialize HK ; [ apply Ht | ].

simpl ktx_plug.
eapply ccompat_tm_app_tm ; [ apply HK | ].
iintro ξ₁'' ; iintro ξ₂'' ; iintro Hξ₁'' ; iintro Hξ₂''.
ispecialize Hs ξ₁''; ispecialize Hs ξ₂'' ; iespecialize Hs.
ispecialize Hs.
{ ielim_prop Hξ ; iintro_prop ; eapply 𝜩_monotone ; eauto using postfix_trans. }
ispecialize Hs.
{ eapply δ_is_closed_monotone ; eauto using postfix_trans. }
ispecialize Hs.
{ ielim_prop Hρ ; iintro_prop ; eapply ρ₁ρ₂_are_closed_monotone ; eauto using postfix_trans. }
ispecialize Hs.
{ eapply 𝜞_monotone ; eauto using postfix_trans. }
apply Hs.
Qed.

Lemma compat_ktx_app_tm2 n T' E' K₁ K₂ v₁ v₂ :
  n ⊨ ⟦ Ξ Γ ⊢ K₁ ≼ˡᵒᵍ K₂ : T' # E' ⇢ S # E ⟧ →
  n ⊨ ⟦ Ξ Γ ⊢ v₁ ≼ˡᵒᵍᵥ v₂ : ty_ms (ms_tm S σ) ℓ ⟧ →
  n ⊨ ⟦ Ξ Γ ⊢ (ktx_app_tm2 K₁ v₁) ≼ˡᵒᵍ (ktx_app_tm2 K₂ v₂) : T' # E' ⇢ (ty_ms σ ℓ) # E ⟧.
Proof.
intros HK Hs.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro t₁ ; iintro t₂ ; iintro Ht.
iespecialize HK.
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ielim_vars HK ; [ | eassumption | eassumption ].
iespecialize HK ; ispecialize HK ; [ apply Ht | ].

simpl ktx_plug.
eapply ccompat_tm_app_tm2 ; [ | apply HK ].
ispecialize Hs ξ₁'; ispecialize Hs ξ₂' ; iespecialize Hs.
ispecialize Hs.
{ ielim_prop Hξ ; iintro_prop ; eapply 𝜩_monotone ; eauto using subset_trans. }
ispecialize Hs.
{ eapply δ_is_closed_monotone ; eauto using subset_trans. }
ispecialize Hs.
{ ielim_prop Hρ ; iintro_prop ; eapply ρ₁ρ₂_are_closed_monotone ; eauto using subset_trans. }
ispecialize Hs.
{ eapply 𝜞_monotone ; eauto using subset_trans. }
apply Hs.
Qed.

End section_compat_tm_app_tm.


Require Import HoareDef STB CannonRA CannonMain0 CannonMain1 Cannon1 SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import HTactics ProofMode.

Set Implicit Arguments.

Section SIMMODSEM.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG CannonRA Σ}.

  Let W: Type := Any.t * Any.t.

  Variable GlobalStb: Sk.t -> gname -> option fspec.
  Hypothesis GlobalStb_fire: forall sk, GlobalStb sk "fire" = Some fire_spec.

  Let wf: _ -> W -> Prop :=
    @mk_wf
      _
      unit
      (fun _ _ _ => (True)%I)
  .

  Theorem correct: refines2 [CannonMain0.Main 1] [CannonMain1.Main 1 GlobalStb].
  Proof.
    eapply adequacy_local2. econs; ss.
    i. econstructor 1 with (wf:=wf) (le:=top2); et; ss; cycle 1.
    { exists tt. red. econs. eapply to_semantic. iIntros "H". ss. }
    econs; ss. init. harg.
    mDesAll. des; clarify. steps.
    unfold ccallU. steps. rewrite GlobalStb_fire. steps.
    hcall _ _ with "A".
    { iModIntro. iSplits; ss. }
    { splits; ss. }
    mDesAll. des; clarify. steps. hret _; ss.
    Unshelve. all: ss. all: try exact 0.
  Qed.

End SIMMODSEM.