(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Axioms.
Set Implicit Arguments.

Module Make(Import M: Memory.T).
  Module Export Derived_PairsExp := Axioms.Make(M).

 Definition permut {X Y}: term (X*Y) (Y*X) := pair pi2 pi1.
 Definition rpair {X Y Z} (f: term Y X) (g: term Z X): term (Y*Z) X := permut o pair g f.

 Definition inv_pi1 {X}: term (X*unit) X := pair id forget.

 Lemma is_rpair: forall k X Y Z (f1: term Y X) (f2: term Z X), RO f2 -> is k f1 -> is k f2 -> is k (rpair f1 f2). (* FIXED *)
 Proof. intros k X Y Z f1 f2 H1 H2 H3. induction k; decorate. Qed.

 Lemma is_permut X Y: is pure (@permut X Y).
 Proof. decorate. Qed.

 Lemma is_inv_pi1 X: is pure (@inv_pi1 X).
 Proof. decorate. Qed.

 Lemma s_rpair_eq: forall X Y' Y (f1: term Y X) (f2: term Y' X),
   RO f2 -> pi1 o rpair f1 f2 == f1.
 Proof.
     intros X Y' Y f1 f2 H0. unfold rpair. unfold permut. rewrite assoc.
     cut (pi1 o pair pi2 pi1 == (@pi2 Y' Y)).
       intro H1. rewrite H1.
       apply s_lpair_eq. exact H0.
     apply wtos; try decorate. apply w_lpair_eq; decorate.
 Qed.

 Lemma w_rpair_eq: forall X Y' Y (f1: term Y X) (f2: term Y' X),
   RO f2 -> pi2 o rpair f1 f2 ~ f2.
 Proof.
     intros X Y' Y f1 f2 H0. unfold rpair. unfold permut. rewrite assoc.
     rewrite s_lpair_eq; [apply w_lpair_eq; decorate| decorate].
 Qed.

 Lemma lpair_u: forall X Y Y'(f g: term (Y'*Y) X),
   (pi1 o f ~ pi1 o g) /\ (pi2 o f == pi2 o g) -> f == g.
 Proof.
     intros X Y Y' f g (H0&H1). apply effect.
     cut(forget o (@pi2 Y' Y) == forget).
       intro H2. rewrite <- H2.
       setoid_rewrite <- assoc. apply replsubs; [reflexivity| exact H1].
     (* 1st cut *)
     setoid_rewrite s_unit; [reflexivity| decorate].
     apply lpair_ueq. exact H0. apply stow. exact H1.
 Qed.

 Lemma rpair_u: forall X Y Y'(f g: term (Y'*Y) X),
   (pi1 o f == pi1 o g) /\ (pi2 o f ~ pi2 o g) -> f == g.
 Proof.
     intros X Y Y' f g (H0&H1). apply effect.
     cut(forget o (@pi1 Y' Y) == forget).
       intro H2. rewrite <- H2.
       setoid_rewrite <- assoc. apply replsubs; [reflexivity| exact H0].
     (* 1st cut *)
     setoid_rewrite s_unit; [reflexivity| decorate].
     apply lpair_ueq. apply stow. exact H0. exact H1.
 Qed.

(* -------------------- End of Derived Pairs -------------------- *)

End Make.


(******************************************************************************)
(** * Definition of executions (common basis for all types of executions) *)
(******************************************************************************)

From hahn Require Import Hahn.
Require Import AuxRel.
Require Import Labels Events.
Require Import Lia.
Require Import Arith.

Set Implicit Arguments.

(** Definition of an execution *)
Record execution :=
  { acts : Event -> Prop ;
    rf : Event -> Event -> Prop ;
    co : Event -> Event -> Prop ;
  }.

Ltac show_dom :=
  match goal with
    |- ?x ≡ _ =>
    rewrite <- restr_relE;
    split; [|solve [apply inclusion_restr]];
    try unfold x;
    repeat first [rewrite <- restr_ct |
                  rewrite restr_minus_alt |
                  rewrite restr_union |
                  rewrite restr_inter, inter_restr_absorb_r |
                  rewrite <- restr_seq |
                  rewrite restr_transp]
  end;
  repeat match goal with
           |- context[restr_rel ?D ?r] =>
           let X := fresh in
           assert (X: r ≡ ⦗D⦘ ⨾ r ⨾ ⦗D⦘) by auto with show_dom;
           rewrite <- restr_relE in X;
           rewrite <- X; clear X
         end; try done.

Section Execution.

Variable G : execution.

Notation "'E'" := G.(acts).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).

Notation "'R'" := (fun a => is_true (is_r a)).
Notation "'W'" := (fun a => is_true (is_w a)).
Notation "'RMW'" := (fun a => is_true (is_rmw a)).

Definition sb := ⦗E⦘ ⨾ ext_sb ⨾  ⦗E⦘.

Record Wf :=
  { wf_index : forall a b,
    E a /\ E b /\ tid a = tid b /\ same_index a b /\ ~ is_init a -> a = b ;
    wf_rfE : rf ≡ ⦗E⦘ ⨾ rf ⨾ ⦗E⦘ ;
    wf_rfD : rf ≡ ⦗W⦘ ⨾ rf ⨾ ⦗R⦘ ;
    wf_rfl : rf ⊆ same_loc ;
    wf_rfv : forall w r (RF: rf w r), valw w = valr r ;
    wf_rff : functional rf⁻¹ ;
    wf_coE : co ≡ ⦗E⦘ ⨾ co ⨾ ⦗E⦘ ;
    wf_coD : co ≡ ⦗W⦘ ⨾ co ⨾ ⦗W⦘ ;
    wf_col : co ⊆ same_loc ;
    co_trans : transitive co ;
    wf_co_total : forall x, is_total (E ∩₁ W ∩₁ (fun a => loc a = x)) co ;
    co_irr : irreflexive co ;
    wf_initE : is_init ⊆₁ E ;
    wf_co_init : co ⨾ ⦗is_init⦘ ≡ ∅₂ ;
    wf_tid_init : forall e (ACT : acts G e), tid e = 0 <-> is_init e ;
  }.

Implicit Type WF : Wf.

(******************************************************************************)
(** ** Derived relations  *)
(******************************************************************************)

(* reads-before, aka from-read *)
Definition fr := rf⁻¹ ⨾ co \ ⦗fun _ => True⦘.

Definition rfr := ⦗fun x => ~ is_w x⦘ ⨾ rf⁻¹ ⨾ co.

(* happens-before *)
Definition hb := (sb ∪ rf)⁺.

(* happens-before-sc *)
Definition hb_sc := (sb ∪ rf ∪ co ∪ fr)⁺.

(* extended coherence order *)
Definition eco := co ⨾ rf^? ∪ fr ⨾ rf^? ∪ rf.

(******************************************************************************)
(** ** Basic axioms *)
(******************************************************************************)

Definition bounded_threads := exists n, forall x, E x -> tid x < n.

Definition rf_complete := E ∩₁ R  ⊆₁ codom_rel rf.

Definition mem_fair := fsupp co /\ fsupp fr.

Definition rmw_atomicity := rf ⨾ ⦗W⦘ ⊆ co \ (co ⨾ co).

Definition SCpL := acyclic (restr_eq_rel Events.loc sb ∪ rf ∪ co ∪ fr).

(******************************************************************************)
(** ** Basic transitivity properties *)
(******************************************************************************)

Lemma sb_trans : transitive sb.
Proof using.
  unfold sb.
  rewrite <- restr_relE; apply transitive_restr, ext_sb_trans.
Qed.

Lemma sb_sb : sb ⨾ sb ⊆ sb.
Proof using.
  generalize sb_trans; basic_solver 21.
Qed.

Lemma sb_same_loc_trans: transitive (sb ∩ same_loc).
Proof using.
  apply restr_eq_trans, sb_trans.
Qed.

Lemma hb_trans : transitive hb.
Proof using.
  unfold hb. apply transitive_ct.
Qed.

Lemma sb_in_hb : sb ⊆ hb.
Proof using.
  unfold hb. rewrite <- ct_step. eauto with hahn.
Qed.

Lemma sb_hb_cr_in_hb : sb ⨾ hb^? ⊆ hb.
Proof using. rewrite sb_in_hb. generalize hb_trans. basic_solver. Qed.

(******************************************************************************)
(** ** Basic properties *)
(******************************************************************************)

Lemma sb_neq_loc_in_sb : sb \ same_loc ⊆ sb.
Proof using. basic_solver. Qed.

(******************************************************************************)
(** ** Same Location relations  *)
(******************************************************************************)

Lemma loceq_rf WF : funeq loc rf.
Proof using. apply WF. Qed.

Lemma loceq_co WF : funeq loc co.
Proof using. apply WF. Qed.

Hint Immediate loceq_rf loceq_co : core.

Lemma loceq_fr WF : funeq loc fr.
Proof using.
  eauto with hahn.
Qed.

Lemma loceq_rfr WF : funeq loc rfr.
Proof using.
  eauto with hahn.
Qed.

Lemma wf_frl WF : fr ⊆ same_loc.
Proof using.
  unfold fr.
  rewrite (wf_rfl WF), (wf_col WF).
  unfold Events.same_loc.
  unfolder; ins; desc; congruence.
Qed.

Lemma wf_rfrl WF : rfr ⊆ same_loc.
Proof using.
  unfold rfr.
  rewrite (wf_rfl WF), (wf_col WF).
  unfolder; ins; desc; congruence.
Qed.

(******************************************************************************)
(** ** Relations in graph *)
(******************************************************************************)

Lemma wf_sbE : sb ≡ ⦗E⦘ ⨾ sb ⨾ ⦗E⦘.
Proof using.
  unfold sb; basic_solver 42.
Qed.

Hint Resolve wf_sbE : show_dom.
Hint Immediate wf_rfE wf_coE : show_dom.

Lemma wf_frE WF : fr ≡ ⦗E⦘ ⨾ fr ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Hint Immediate wf_frE : show_dom.

Lemma wf_rfrE WF : rfr ≡ ⦗E⦘ ⨾ rfr ⨾ ⦗E⦘.
Proof using.
  apply dom_helper_2; unfold rfr.
  rewrite wf_rfE, wf_coE; ins.
  unfolder; ins; desf.
Qed.
Hint Immediate wf_rfrE : show_dom.

Lemma wf_hbE WF : hb ≡ ⦗E⦘ ⨾ hb ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Hint Immediate wf_frE : show_dom.

Lemma wf_hb_scE WF : hb_sc ≡ ⦗E⦘ ⨾ hb_sc ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Hint Immediate wf_hb_scE : show_dom.

Lemma wf_ct_rfE WF : (rf)⁺ ≡ ⦗E⦘ ⨾ (rf)⁺ ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Hint Immediate wf_ct_rfE : show_dom.

Lemma wf_ct_transp_rfE WF : (rf⁻¹)⁺ ≡ ⦗E⦘ ⨾ (rf^{-1})⁺ ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Hint Immediate wf_ct_transp_rfE : show_dom.

Lemma wf_sbhbcrE WF : sb ⨾ hb^? ⊆ ⦗acts G⦘ ⨾ sb ⨾ hb^? ⨾ ⦗acts G⦘.
Proof using. rewrite wf_sbE at 1. rewrite (wf_hbE WF) at 1. basic_solver 10. Qed.

(******************************************************************************)
(** ** Domains and codomains  *)
(******************************************************************************)

Lemma wf_frD WF : fr ≡ ⦗R⦘ ⨾ fr ⨾ ⦗W⦘.
Proof using.
  apply dom_helper_2; unfold fr.
  rewrite wf_rfD, wf_coD; ins.
  unfolder; ins; desf.
Qed.

Lemma wf_rfrD WF : rfr ≡ ⦗R \₁ W⦘ ⨾ rfr ⨾ ⦗W⦘.
Proof using.
  apply dom_helper_2; unfold rfr.
  rewrite wf_rfD, wf_coD; ins.
  unfolder; ins; desf.
Qed.

(******************************************************************************)
(** ** Irreflexive relations *)
(******************************************************************************)

Lemma sb_irr : irreflexive sb.
Proof using.
  unfold sb; unfolder; ins; desf.
  eby eapply ext_sb_irr.
Qed.

Lemma fr_irr WF : irreflexive fr.
Proof using.
  rewrite wf_frE; unfold fr; basic_solver.
Qed.

Lemma rfr_irr WF : irreflexive rfr.
Proof using.
  rewrite (wf_rfrD WF); ins; basic_solver.
Qed.

(******************************************************************************)
(** ** [fr] and [rfr] *)
(******************************************************************************)

Lemma rfr_in_fr WF :
  rfr ⊆ fr.
Proof using.
  rewrite wf_rfrD; ins;
    unfold fr, rfr; unfolder; ins; desf; splits; try intro; desf; eauto.
Qed.

Lemma frE WF (C : rf_complete) (ATOM : rmw_atomicity) :
  fr ≡ rfr ∪ ⦗R⦘ ⨾ co.
Proof using.
  rewrite wf_frE, wf_rfrE, wf_coE, wf_frD, wf_rfrD, wf_coD; ins.
  red in ATOM.
  unfold fr, rfr; unfolder; split; ins; desf; clarify_not.
  {
    classical_left; clarify_not; eauto 10.
    cut (~ is_w x); eauto 10.
    intro; eapply (wf_co_total WF) with (x := loc x) in H3; desf; ins.
      by destruct (ATOM z x) as [_ X]; unfolder; ins; apply X; vauto.
    unfolder; splits; ins.
    apply wf_rfl in H0; ins; apply wf_col in H4; ins; congruence.
  }
  splits; ins; eauto; try intro; desf.
  splits; ins; try intro; desf; eauto using (co_irr WF).
  destruct (C x) as [z RF]; ins.
  tertium_non_datur (z = y) as [|NEQ]; desf.
  {
    destruct (ATOM y x) as [X _]; vauto.
    exfalso; eapply co_irr, co_trans; eauto.
  }
  eapply wf_co_total in NEQ; ins; desf; eauto using (co_trans WF).
  { destruct (ATOM z x) as [X _]; vauto.
    exfalso; eapply co_irr, co_trans, co_trans; eauto.
  }
  hahn_rewrite (wf_rfE WF) in RF.
  hahn_rewrite (wf_rfD WF) in RF.
  hahn_rewrite (wf_rfl WF) in RF.
  hahn_rewrite (wf_col WF) in H0.
  unfolder in *; desf; splits; ins; congruence.
Qed.

Lemma w_fr_in_co WF (C : rf_complete) (ATOM : rmw_atomicity) :
  ⦗is_w⦘ ⨾ fr ⊆ co.
Proof using. rewrite frE; auto. rewrite (wf_rfrD WF). basic_solver. Qed.

(******************************************************************************)
(** ** Acyclic relations *)
(******************************************************************************)

Lemma sb_acyclic : acyclic sb.
Proof using.
  apply trans_irr_acyclic; [apply sb_irr| apply sb_trans].
Qed.

Lemma co_acyclic WF: acyclic co.
Proof using.
  by apply trans_irr_acyclic; [apply co_irr| apply co_trans].
Qed.

(******************************************************************************)
(** ** init *)
(******************************************************************************)

Lemma init_w WF: is_init ⊆₁ W \₁ RMW.
Proof using.
  unfolder; ins.
  unfold is_init in *; destruct x; desf.
Qed.

Lemma read_or_rmw_not_init WF a (A: R a) : ~ is_init a.
Proof using.
  intro.
  assert ((W \₁ RMW) a) by (apply init_w; basic_solver).
  unfolder in *; type_solver 20.
Qed.

Lemma no_sb_to_init : sb ≡ sb ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
  split; [|basic_solver].
  unfold sb; rewrite ext_sb_to_non_init at 1; basic_solver.
Qed.

Lemma no_rf_to_init WF : rf ≡ rf ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
  split; [|basic_solver].
  rewrite (wf_rfD WF) at 1.
  rewrite (wf_rfE WF) at 1.
  generalize (read_or_rmw_not_init WF).
  basic_solver 42.
Qed.

Lemma no_hb_to_init WF : hb ≡ hb ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
  split; [|basic_solver].
  unfold hb.
  rewrite ct_end.
  rewrite (no_rf_to_init WF) at 2.
  rewrite no_sb_to_init at 2.
  basic_solver 42.
Qed.

Lemma init_same_loc a b
  (A: is_init a) (B: is_init b) (LOC: loc a = loc b):
  a = b.
Proof using.
  destruct a, b; desf.
    by cut (x = x0); [ins; subst|simpls].
Qed.

Lemma rf_init_r WF x y : rf x y -> is_init y -> False.
Proof using.
  ins; eapply (wf_rfD WF) in H; unfolder in *; desf.
  destruct y; ins.
Qed.

Lemma hb_init_r WF x y : hb x y -> is_init y -> False.
Proof.
  induction 1; unfold sb, ext_sb in *; unfolder in *;
    desf; eauto using rf_init_r.
Qed.

Lemma sb_hb_cr_init_empty WF :
  (sb ⨾ hb^?) ⨾ ⦗is_init⦘ ⊆ ∅₂.
Proof using. rewrite sb_hb_cr_in_hb. generalize (hb_init_r WF). basic_solver. Qed.

Lemma co_init_l WF x y :
  is_init x -> is_w y -> (acts G \₁ is_init) y ->
  loc x = loc y -> co x y.
Proof.
  unfolder in *; ins; desc.
  assert (NEQ: x <> y) by (intro; desf).
  eapply wf_co_total in NEQ; eauto; unfolder; splits; ins; desf.
  - edestruct (proj1 (wf_co_init WF)). apply seq_eqv_r. split; eauto.
  - apply wf_initE; ins.
  - destruct x; ins.
Qed.

Lemma rf_in_hb : rf ⊆ hb.
Proof using.
  unfold hb. rewrite <- ct_step. eauto with hahn.
Qed.

(******************************************************************************)
(** ** More properties *)
(******************************************************************************)

Lemma sb_semi_total_l x y z
  WF (N: ~ is_init x) (NEQ: y <> z) (XY: sb x y) (XZ: sb x z):
  sb y z \/ sb z y.
Proof using.
  unfold sb in *; unfolder in *; desf.
  cut (ext_sb y z \/ ext_sb z y); [basic_solver 12|].
  eapply ext_sb_semi_total_l; eauto.
  intro A.
  assert (y = z).
  eapply WF; splits; eauto.
    by unfold ext_sb in *; destruct y,z; ins; desf; desf.
    by unfold ext_sb in *; destruct y,z; ins; desf; desf.
  eauto.
Qed.

Lemma sb_semi_total_r x y z
  WF (N: ~ is_init z) (NEQ: y <> z) (XY: sb y x) (XZ: sb z x):
  sb y z \/ sb z y.
Proof using.
cut ((sb ∪ sb⁻¹) y z); [basic_solver|].
unfold sb in *; unfolder in *; desf.
destruct (classic (is_init y)).
unfold ext_sb; basic_solver.
cut (ext_sb y z \/ ext_sb z y); [basic_solver|].
eapply ext_sb_semi_total_r; eauto.
intro A.
assert (y = z).
eapply WF; splits; eauto.
by unfold ext_sb in *; destruct y,z; ins; desf; desf.
eauto.
Qed.

Lemma sb_tid_init x y (SB : sb x y): tid x = tid y \/ is_init x.
Proof using.
generalize ext_sb_tid_init; unfold sb in *.
unfolder in *; basic_solver.
Qed.

Lemma sb_tid_init': sb ≡ sb ∩ same_tid ∪ ⦗is_init⦘ ⨾ sb.
Proof using.
  split; [|basic_solver].
  unfold sb.
  rewrite ext_sb_tid_init' at 1.
  basic_solver 42.
Qed.

Lemma tid_sb WF: ⦗E⦘ ⨾ same_tid ⨾  ⦗E⦘ ⊆ sb^? ∪ sb⁻¹ ∪ (is_init × is_init).
Proof using.
  unfold sb.
  rewrite tid_ext_sb.
  unfolder; intuition.
  unfold same_tid, same_index in *.
  destruct x, y; ins; desf; eauto.
  { apply (wf_tid_init WF) in H2; auto. simpls. desf. }
  repeat left; apply WF; splits; ins.
Qed.

Lemma tid_ninit_sb WF : ⦗E⦘ ⨾ same_tid ⨾ ⦗set_compl is_init⦘ ⨾ ⦗E⦘ ⊆ sb^? ∪ sb⁻¹.
Proof using.
  rewrite seq_eqvC; sin_rewrite tid_sb; ins.
  rewrite seq_union_l; apply inclusion_union_l; basic_solver.
Qed.

Lemma init_ninit_sb (WF : Wf) x y (INIT : is_init x) (ININE : E x) (INE : E y)
      (NINIT : ~ is_init y): sb x y.
Proof using.
  unfold sb, ext_sb; basic_solver.
Qed.

Lemma same_thread WF x y (X : E x) (Y : E y)
      (NINIT : ~ is_init x) (ST : tid x = tid y):
  sb^? x y \/ sb y x.
Proof using.
  eapply tid_ninit_sb; ins; unfolder; splits; ins.
  destruct x, y; ins; desf.
  apply (wf_tid_init WF) in X; auto. simpls. desf.
Qed.

Lemma sb_immediate_adjacent WF:
 ⦗set_compl is_init⦘ ⨾ immediate sb ≡ ⦗set_compl is_init⦘ ⨾ (adjacent sb ∩ sb).
Proof using.
apply immediate_adjacent.
- unfolder; ins; desf; destruct (classic (x=y)); auto.
  forward (apply (@sb_semi_total_r z y x)); eauto; tauto.
- unfolder; ins; desf; destruct (classic (x=y)); auto.
  forward (apply (@sb_semi_total_l z y x)); eauto; tauto.
- apply sb_trans.
- apply sb_irr.
Qed.

Lemma co_co WF: co ⨾ co ⊆ co.
Proof using. apply rewrite_trans, WF. Qed.

Lemma rel_ninit_l r (SUB: r ⊆ E × E) :
  ⦗E \₁ is_init⦘ ⨾ r ≡ ⦗set_compl is_init⦘ ⨾ r.
Proof using.
  unfolder in *; intuition; firstorder.
Qed.

Lemma sb_ninit_l :
  ⦗E \₁ is_init⦘ ⨾ sb ≡ ⦗set_compl is_init⦘ ⨾ sb.
Proof using.
  unfolder in *; intuition; firstorder.
Qed.

Lemma sb_ninit : sb ⨾ ⦗E \₁ is_init⦘  ≡ sb.
Proof using.
  unfold sb, ext_sb, is_init; unfolder; intuition; desf.
Qed.

Lemma rf_ninit WF : rf ⨾ ⦗E \₁ is_init⦘ ≡ rf.
Proof using.
  unfolder; intuition; desf.
  apply wf_rfE in H; unfolder in *; ins; desf.
  apply wf_rfD in H; unfolder in *; ins.
  unfold is_init, is_r in *; desf.
Qed.

Lemma co_ninit WF : co ⨾ ⦗E \₁ is_init⦘ ≡ co.
Proof using.
  unfolder; intuition; desf.
  apply wf_coE in H; unfolder in *; ins; desf.
  eapply wf_co_init; unfolder; eauto.
Qed.

Lemma fr_ninit WF : fr ⨾ ⦗E \₁ is_init⦘ ≡ fr.
Proof using.
  by unfold fr; rewrite <- seq_eqv_minus_lr, seqA, co_ninit.
Qed.

Lemma get_elem WF thread index :
  exists ! eo,
    match eo with
      None => forall l, ~ E (ThreadEvent thread index l)
    | Some (ThreadEvent t i l) =>
      E (ThreadEvent t i l) /\ t = thread /\ i = index
    | Some (InitEvent _) => False
    end.
Proof using.
  ins; tertium_non_datur (exists lab, E (ThreadEvent thread index lab)) as [X|X]; desc.
  exists (Some (ThreadEvent thread index lab)); split; ins; desf; desf;
      [|by edestruct H; eauto].
    now f_equal; eapply (wf_index WF); splits; ins.
  exists None; split; try red; ins; desf; desf; exfalso; eauto.
Qed.

Lemma fsupp_sb WF : fsupp (⦗set_compl is_init⦘ ⨾ sb).
Proof using.
  unfold sb, ext_sb; unfolder; ins.
  destruct y; [exists nil; ins; desf|].
  assert (X := get_elem WF thread); desc.
  eapply unique_choice in X; desc.
  exists (map_filter f (List.seq 0 index)); ins; desf; desf.
  rewrite in_map_filter; exists index0; specialize (X index0).
  rewrite in_seq0_iff; desf; desf; split; ins; [|edestruct X; edone].
  by f_equal; eapply (wf_index WF); splits; ins.
Qed.

Lemma fsupp_rf WF : fsupp rf.
Proof using. destruct WF; eauto with hahn. Qed.

Lemma fsupp_co (F : mem_fair) : fsupp co.
Proof using. apply F. Qed.

Lemma fsupp_fr (F : mem_fair) : fsupp fr.
Proof using. apply F. Qed.

Lemma fsupp_rfr WF (F : mem_fair) : fsupp rfr.
Proof using.
  rewrite rfr_in_fr; ins; apply F.
Qed.

Hint Immediate fsupp_sb fsupp_rf fsupp_co fsupp_fr fsupp_rfr : core.

Lemma fsupp_eco WF (FAIR : mem_fair) : fsupp eco.
Proof using. eauto 8 with hahn. Qed.

Hint Immediate fsupp_eco : core.

Lemma fsupp_hb WF (FAIR : mem_fair)
        (IRRhb: irreflexive hb)
        (THREADS: has_finite_antichains (E \₁ is_init) (⦗set_compl is_init⦘ ⨾ sb)) :
  fsupp (⦗set_compl is_init⦘ ⨾ hb).
Proof using.
  rewrite <- rel_ninit_l; [|rewrite wf_hbE; unfolder; tauto].
  unfold hb.
  arewrite (⦗E \₁ is_init⦘ ⨾ (sb ∪ rf)⁺ ≡
             (⦗E \₁ is_init⦘ ⨾ (sb ∪ rf))⁺)
    by rewrite ct_rotl, seq_union_l, sb_ninit, rf_ninit, ct_end.
  rewrite seq_union_r.
  eapply fsupp_ct, fsupp_union; ins; eauto.
  - by rewrite 2!inclusion_seq_eqv_l.
  - apply union_doma; apply seq_doma, eqv_doma.
  - by rewrite <- inclusion_union_r1, sb_ninit_l.
  - rewrite sb_ninit_l; eauto.
  - by rewrite inclusion_seq_eqv_l; eauto.
Qed.

Lemma dupE A (l : list A) (DUP: ~ NoDup l) :
  exists l1 a l2 l3, l = l1 ++ a :: l2 ++ a :: l3.
Proof using.
  induction l; ins.
  rewrite nodup_cons in *; clarify_not.
    by apply in_split in DUP; desf; exists nil; ins; eauto.
  specialize (IHl DUP); desf; eexists (_ :: _); ins; eauto.
Qed.

Lemma has_finite_antichains_sb WF (B: bounded_threads) :
  has_finite_antichains (E \₁ is_init) (⦗set_compl is_init⦘ ⨾ sb).
Proof using.
  destruct B as [n THR]; exists n; red; ins; unfolder in *.
  cut (exists a b, a <> b /\ In a l /\ In b l /\ tid a = tid b).
  { intro X; desc.
    destruct (INCL _ X0); destruct (INCL _ X1); desc.
    eapply same_thread in X2; unfolder in X2; desf.
    exists a, b; splits; eauto.
    exists b, a; splits; eauto. }
  assert (M: incl (map tid l) (List.seq 0 n)).
    red; ins; rewrite in_map_iff in *; desf.
    by apply in_seq0_iff, THR, INCL.
  destruct (classic (NoDup (map tid l))).
  { eapply NoDup_incl_length in M; ins.
    rewrite length_map, length_seq in *; lia. }
  apply dupE in H; desf.
  apply map_eq_app_inv in H; desf.
  destruct l2'; ins; desf.
  apply map_eq_app_inv in H0; desf.
  destruct l2'0; ins; desf.
  exists e0, e; splits; eauto with hahn.
  intro; desf; rewrite nodup_app, nodup_cons in *; desf; eauto with hahn.
Qed.

Hint Resolve has_finite_antichains_sb : core.

Lemma countable_ninit WF : countable (E \₁ is_init).
Proof using.
  assert (X := unique_choice _ (fun ti => get_elem WF (nat_fst ti) (nat_snd ti)));
    desc.
  assert (default: Event) by vauto.
  apply surjection_countable with
      (f := fun n => match f n with Some e => e | None => default end).
  unfolder; ins; desf; destruct a; ins.
  exists (nat_tup thread index); specialize (X (nat_tup thread index)); desf; desf.
    rewrite nat_fst_tup, nat_snd_tup in *; eapply (wf_index WF); splits; ins.
  eby edestruct X; rewrite nat_fst_tup, nat_snd_tup.
Qed.

Lemma exec_exists_enum WF (FAIR: mem_fair)
      (r : relation Event) (IRR: irreflexive r)
      (TRANS: transitive r) (FSUPP: fsupp (⦗set_compl is_init⦘ ⨾ r)) :
  exists nu,
    enumerates nu (E \₁ is_init) /\
    (forall i (LTi: lt_size i (E \₁ is_init))
            j (LTj: lt_size j (E \₁ is_init))
             (REL: r (nu i) (nu j)), i < j).
Proof using.
  forward apply countable_ninit as X; ins.
  eapply countable_ext with (s := E \₁ is_init) in X; eauto.
  2: split; [ by rewrite inclusion_seq_eqv_l |
              by unfolder; split; desf; eauto ].
  desf; [by destruct X; repeat constructor|].
  exists f; split; ins; eapply X0; eauto.
  unfolder; split; ins.
  intro NINIT; rewrite enumeratesE in X; desc.
  eapply RNG in LTi; unfolder in LTi; desf.
Qed.

(******************************************************************************)
(** ** external-internal restrictions *)
(******************************************************************************)

Definition rfe := rf \ sb.
Definition coe := co \ sb.
Definition fre := fr \ sb.
Definition rfi := rf ∩ sb.
Definition coi := co ∩ sb.
Definition fri := fr ∩ sb.

Lemma ri_union_re r : r ≡ r ∩ sb ∪ r \ sb.
Proof using. unfolder; split; ins; desf; tauto. Qed.

Lemma rfi_union_rfe : rf ≡ rfi ∪ rfe.
Proof using. apply ri_union_re. Qed.
Lemma coi_union_coe : co ≡ coi ∪ coe.
Proof using. apply ri_union_re. Qed.
Lemma fri_union_fre : fr ≡ fri ∪ fre.
Proof using. apply ri_union_re. Qed.

Lemma ri_dom r d1 d2 (DOM: r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘) : r ∩ sb ⊆ ⦗d1⦘ ⨾ r ∩ sb ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.
Lemma re_dom r d1 d2 (DOM: r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘) : r \ sb ⊆ ⦗d1⦘ ⨾ (r \ sb) ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.

Lemma wf_rfiE WF: rfi ≡ ⦗E⦘ ⨾ rfi ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Lemma wf_coiE WF: coi ≡ ⦗E⦘ ⨾ coi ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Lemma wf_friE WF: fri ≡ ⦗E⦘ ⨾ fri ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Lemma wf_rfeE WF: rfe ≡ ⦗E⦘ ⨾ rfe ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Lemma wf_coeE WF: coe ≡ ⦗E⦘ ⨾ coe ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Lemma wf_freE WF: fre ≡ ⦗E⦘ ⨾ fre ⨾ ⦗E⦘.
Proof using. show_dom. Qed.
Lemma wf_rfiD WF : rfi ≡ ⦗W⦘ ⨾ rfi ⨾ ⦗R⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_rfD WF)). Qed.
Lemma wf_coiD WF : coi ≡ ⦗W⦘ ⨾ coi ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_coD WF)). Qed.
Lemma wf_friD WF : fri ≡ ⦗R⦘ ⨾ fri ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_frD WF)). Qed.
Lemma wf_rfeD WF : rfe ≡ ⦗W⦘ ⨾ rfe ⨾ ⦗R⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_rfD WF)). Qed.
Lemma wf_coeD WF : coe ≡ ⦗W⦘ ⨾ coe ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_coD WF)). Qed.
Lemma wf_freD WF : fre ≡ ⦗R⦘ ⨾ fre ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_frD WF)). Qed.

(******************************************************************************)
(** ** properties of external/internal relations *)
(******************************************************************************)

Lemma seq_ii r1 r2 r3 (A: r1 ⨾ r2 ⊆ r3): r1 ∩ sb ⨾ r2 ∩ sb ⊆ r3 ∩ sb.
Proof using.
generalize sb_trans.
unfolder in *; basic_solver 21.
Qed.

Lemma re_ri WF  r r' (IRR: irreflexive r)  (IRR2: irreflexive (r ⨾ sb))
  (N: r ⊆ r ⨾  ⦗ fun x => ~ is_init x ⦘): (r \ sb) ⨾ (r' ∩ sb) ⊆ r ⨾  r' \ sb.
Proof using.
rewrite N at 1.
unfolder; ins; desf; splits; eauto.
intro.
eapply sb_semi_total_r with (x:=y) (y:=x) in H1; eauto.
by desf; revert IRR2; basic_solver.
eby intro; subst; eapply IRR.
Qed.

Lemma ri_re WF  r r' (IRR: irreflexive r')  (IRR2: irreflexive (r' ⨾ sb)):
 ⦗ fun x => ~ is_init x ⦘ ⨾ (r ∩ sb) ⨾ (r' \ sb) ⊆ r ⨾  r' \ sb.
Proof using.
unfolder; ins; desf; splits; eauto.
intro.
eapply sb_semi_total_l with (x:=x) (y:=z) (z:=y) in H4; eauto.
by desf; revert IRR2; basic_solver.
eby intro; subst; eapply IRR.
Qed.

Lemma rfi_in_sbloc WF : rf ∩ sb ⊆ restr_eq_rel loc sb.
Proof using. rewrite wf_rfl; basic_solver 12. Qed.
Lemma coi_in_sbloc WF : co ∩ sb ⊆ restr_eq_rel loc sb.
Proof using. rewrite wf_col; basic_solver 12. Qed.
Lemma fri_in_sbloc WF : fr ∩ sb ⊆ restr_eq_rel loc sb.
Proof using. rewrite (funeq_same_loc (loceq_fr WF)).
unfolder; unfold Events.same_loc in *.
ins; desf; splits; eauto; congruence.
Qed.
Lemma rfi_in_sbloc' WF : rfi ⊆ sb ∩ same_loc.
Proof using. generalize (wf_rfl WF); unfold rfi; basic_solver 12. Qed.
Lemma coi_in_sbloc' WF : coi ⊆ sb ∩ same_loc.
Proof using. generalize (wf_col WF); unfold coi; basic_solver 12. Qed.
Lemma fri_in_sbloc' WF : fri ⊆ sb ∩ same_loc.
Proof using. generalize (wf_frl WF); unfold fri; basic_solver 12. Qed.

End Execution.

(******************************************************************************)
(** ** Tactics *)
(******************************************************************************)
#[global]
Hint Unfold rfe coe fre rfi coi fri : ie_unfolderDb.
Tactic Notation "ie_unfolder" :=  repeat autounfold with ie_unfolderDb in *.

(******************************************************************************)
(** ** Execution prefixes *)
(******************************************************************************)

Definition sub_execution G G' :=
  ⟪SUBev: acts G ⊆₁ acts G' ⟫ /\
  ⟪SUBrf: rf G ≡ rf G' ⨾ ⦗acts G⦘ ⟫ /\
  ⟪SUBco: co G ≡ ⦗acts G⦘ ⨾ co G' ⨾ ⦗acts G⦘ ⟫ /\
  ⟪DOMsb: dom_rel (sb G' ⨾ ⦗acts G⦘) ⊆₁ acts G ⟫ /\
  ⟪DOMrf: dom_rel (rf G) ⊆₁ acts G ⟫ /\
  ⟪INIT: is_init ⊆₁ acts G ⟫.

Lemma sub_execution_sb G G' (SE: sub_execution G G') :
  sb G ≡ sb G' ⨾ ⦗acts G⦘.
Proof using.
  cdes SE; unfold sb in *.
  split; [basic_solver|].
  clear - DOMsb; unfolder in *; ins; desf; splits; eauto 6.
Qed.

Lemma sub_execution_wf G G' :
  sub_execution G G' -> Wf G' -> Wf G.
Proof using.
  unfold sub_execution; ins; desc.
  destruct H0; split; ins; desf; eauto 8.
  { rewrite SUBrf, seqA; rels; rewrite <- SUBrf.
    apply (dom_rel_helper DOMrf). }
  { rewrite (dom_rel_helper DOMrf), SUBrf, ?seqA; rels.
    rewrite wf_rfD0 at 1; clear; basic_solver. }
  { rewrite SUBrf, wf_rfl0 at 1; clear; basic_solver. }
  { apply SUBrf in RF; revert RF; basic_solver. }
  { rewrite SUBrf; basic_solver. }
  { rewrite SUBco; basic_solver. }
  { rewrite SUBco; rewrite wf_coD0 at 1; clear; basic_solver. }
  { rewrite SUBco, wf_col0; clear; basic_solver. }
  { by rewrite SUBco, <- restr_relE; apply transitive_restr. }
  { revert wf_co_total0; rewrite SUBco; unfolder.
    ins; desf. eapply wf_co_total0 in NEQ; eauto; desf; eauto. }
  { rewrite SUBco; basic_solver. }
  rewrite SUBco, !seqA, seq_eqvC;
    seq_rewrite wf_co_init0; basic_solver.
Qed.

Lemma sub_execution_trans G G' G'' :
  sub_execution G G' ->
  sub_execution G' G'' ->
  sub_execution G G''.
Proof using.
  unfold sub_execution; ins; desf; splits; ins.
  - by rewrite SUBev0.
  - rewrite SUBrf0, SUBrf, !seqA; rewrite seq_eqvK_l; ins.
  - rewrite SUBco0, SUBco, !seqA; rewrite seq_eqvK_l; ins.
    seq_rewrite seq_eqvK_r; ins.
  - arewrite (⦗acts G⦘ <--> ⦗acts G'⦘  ⨾ ⦗acts G⦘) by rewrite seq_eqvK_l.
    seq_rewrite <- sub_execution_sb; ins.
Qed.

Section SubExecution.

Variables G G' : execution.
Hypothesis SE : sub_execution G G'.
Hypothesis WF : Wf G'.

Lemma sub_execution_fr :
  fr G ≡ ⦗G.(acts)⦘ ⨾ fr G' ⨾ ⦗G.(acts)⦘.
Proof using SE.
  cdes SE; unfold fr.
  rewrite SUBco, <- transp_eqv_rel.
  seq_rewrite <- transp_seq; rewrite <- (dom_rel_helper DOMrf).
  rewrite SUBrf, ?transp_seq, ?seqA; rels.
  split; basic_solver.
Qed.

Lemma sub_execution_rfr :
  rfr G ≡ ⦗G.(acts)⦘ ⨾ rfr G' ⨾ ⦗G.(acts)⦘.
Proof using SE.
  cdes SE; unfold rfr.
  rewrite SUBco; rewrite <- (transp_eqv_rel (acts G)) at 1.
  seq_rewrite <- transp_seq; rewrite <- (dom_rel_helper DOMrf).
  rewrite SUBrf, ?transp_seq, ?seqA; rels.
  split; basic_solver.
Qed.

End SubExecution.

(******************************************************************************)
(** ** Execution prefix by event enumeration *)
(******************************************************************************)

Definition exec_enum G (nu : nat -> Event) n :=
  let s := is_init ∪₁ (nu ↑₁ (fun x => x < n)) in
  {| acts := acts G ∩₁ s ;
     rf := ⦗s⦘ ⨾ rf G ⨾ ⦗s⦘ ;
     co := ⦗s⦘ ⨾ co G ⨾ ⦗s⦘
  |}.

Lemma le_lt_size A (s: A -> Prop) m (LS: lt_size m s)
      n (LE: n <= m) : lt_size n s.
Proof using.
  unfold lt_size in *; desf.
  exists dom; splits; ins; desf; lia.
Qed.

Lemma lt_lt_size A (s: A -> Prop) m (LS: lt_size m s)
      n (LE: n < m) : lt_size n s.
Proof using.
  unfold lt_size in *; desf.
  exists dom; splits; ins; desf; lia.
Qed.

Lemma sub_execution_enum G (WF: Wf G) nu
      (ENUM: enumerates nu (acts G \₁ is_init))
      (IMPL: forall i (LTi: lt_size i (acts G \₁ is_init))
            j (LTj: lt_size j (acts G \₁ is_init))
             (REL: (sb G ∪ rf G) (nu i) (nu j)), i < j)
      n (LT : lt_size n (acts G \₁ is_init)) :
  sub_execution (exec_enum G nu n) G.
Proof using.
  red; splits; ins.
  { unfolder; ins; splits; ins; desf; splits; eauto. }
  { rewrite (wf_rfE WF), ?seqA, ?id_inter; rels.
    unfolder; split; ins; desf; splits; ins; eauto.
    by exfalso; apply (wf_rfD WF) in H0; unfolder in H0; desf;
       unfold is_r, is_init in *; desf.
    classical_right.
    apply (wf_rfE WF) in H0; unfold seq, eqv_rel in H0; desf.
    rewrite enumeratesE in ENUM; desc.
    forward apply (SUR z); ins; desf.
    exists i; split; eauto.
    forward eapply IMPL with (i := i) (j := y0); vauto; try lia.
    eauto using lt_lt_size. }
  { rewrite (wf_coE WF), ?seqA.
    unfolder; split; ins; desf; splits; ins; eauto. }
  { rewrite wf_sbE, ?seqA; unfolder; ins; desf; splits; ins; eauto.
      by unfold sb, ext_sb in H0; unfolder in H0; desf.
    classical_right.
    apply (wf_sbE) in H0; unfold seq, eqv_rel in H0; desf.
    rewrite enumeratesE in ENUM; desc.
    forward apply (SUR z); ins; desf.
    exists i; split; eauto.
    forward eapply IMPL with (i := i) (j := y0); vauto; try lia.
    eauto using lt_lt_size. }
  { rewrite wf_rfE, ?seqA; unfolder; ins; desf; splits; ins; eauto. }
  { rewrite <- (wf_initE WF); unfolder; eauto. }
Qed.

Lemma sub_execution_enum_mon G (WF: Wf G) nu
      (ENUM: enumerates nu (acts G \₁ is_init))
      (IMPL: forall i (LTi: lt_size i (acts G \₁ is_init))
            j (LTj: lt_size j (acts G \₁ is_init))
             (REL: (sb G ∪ rf G) (nu i) (nu j)), i < j)
      n m (LT: n < m) (LS : lt_size m (acts G \₁ is_init)) :
  sub_execution (exec_enum G nu n) (exec_enum G nu m).
Proof using.
  red; splits; ins.
  { unfolder; ins; splits; ins; desf; splits; eauto.
    right; exists y; split; eauto; lia. }
  { rewrite (wf_rfE WF), ?seqA, ?id_inter; rels.
    unfolder; split; ins; desf; splits; ins; eauto using lt_trans.
    all: try by exfalso; apply (wf_rfD WF) in H0; unfolder in H0; desf;
       unfold is_r, is_init in *; desf.
    classical_right.
    apply (wf_rfE WF) in H0; unfold seq, eqv_rel in H0; desf.
    rewrite enumeratesE in ENUM; desc.
    exists y2; split; eauto.
    forward eapply IMPL with (i := y2) (j := y0); vauto; try lia.
    all: eauto using lt_lt_size.
    right; congruence. }
  { rewrite (wf_coE WF), ?seqA.
    unfolder; split; ins; desf; splits; ins; eauto using lt_trans. }
  { rewrite wf_sbE, ?seqA; unfolder; ins; desf; splits; ins; eauto.
    all: try solve [unfolder in H; desc; clarify].
      by unfold sb, ext_sb in H0; unfolder in H0; desf.
    classical_right.
    apply (wf_sbE) in H0; unfold seq, eqv_rel in H0; desf.
    rewrite enumeratesE in ENUM; desc.
    forward apply (SUR z); ins; desf; [by unfolder in H; desc; clarify|].
    exists i; split; eauto.
    forward eapply IMPL with (i := i) (j := y0); vauto; try lia.
    eauto using lt_lt_size.
    left; unfold sb in *; unfolder in *; desc; ins. }
  { rewrite wf_rfE, ?seqA; unfolder; ins; desf; splits; ins; eauto. }
  { rewrite <- (wf_initE WF); unfolder; eauto. }
Qed.

(* TODO: move to a more appropriate place. *)
Definition LTS_trace_param {Label State}
           (lts : LTS State Label)
           (s : nat -> State) (t : trace Label)  :=
  match t with
  | trace_fin l =>
    LTS_init lts (s 0) /\
    forall i (LLEN : i < length l) d,
      LTS_step lts (s i) (nth i l d) (s (S i))
  | trace_inf fl =>
    LTS_init lts (s 0) /\
    forall i, LTS_step lts (s i) (fl i) (s (S i))
  end.

Lemma LTS_trace_param' {State Label: Type} (lts: LTS State Label)
      st tr (LTS: LTS_trace_param lts st tr):
  LTS_init lts (st 0) /\
  (forall i,
      NOmega.lt_nat_l i (trace_length tr) ->
      forall d, LTS_step lts (st i) (trace_nth i tr d) (st (S i))).
Proof.
  destruct tr; simpl; vauto. red in LTS. desc. split; vauto.
Qed.

Lemma rf_irr G (SCPL: SCpL G) (WF: Wf G): irreflexive (rf G).
Proof.
  red in SCPL. red. ins.
  apply (SCPL x), ct_step. basic_solver.
Qed.

Lemma rmw_atom G (SCPL: SCpL G) (WF: Wf G): rmw_atomicity G.
Proof.
  unfold rmw_atomicity.
  rewrite wf_rfE, wf_rfD; ins; unfolder in *; ins; desc.
  destruct (classic (x = y)) as [|NEQ].
  { subst y. edestruct rf_irr; eauto. }
  eapply (wf_co_total WF) in NEQ.
  2, 3: by apply wf_rfl in H0; unfolder; splits; auto.
  des.
  2: { destruct (SCPL x). apply ct_begin. exists y. split; [basic_solver| ].
       apply rt_step. basic_solver. }
  split; auto.
  red. ins. desc.
  apply (SCPL y). apply ct_begin. exists z. split.
  2: { apply rt_step. basic_solver. }
  cut (fr G y z); [basic_solver| ]. red. split.
  2: { unfolder. red. ins. desc. subst. eapply co_irr; eauto. }
  exists x. split; auto.
Qed.


(** Coq coding by choukh, July 2021 **)

(* 哥德尔本体论公理在固定论域K系统中不一致 *)

Require Import CM.Logic.Classical.
Require Import CM.Logic.Modal.
Require Import CM.Logic.Entity.

Parameter 积极 : 泛性质 性质.
Definition 消极 := λ Φ, ¬ 积极 Φ.

Axiom 积极性质的反面消极 : ⌈∀ Φ, 积极 Φ → 消极 (反 Φ)⌋.

Axiom 积极的必然后果也积极 : ⌈∀ Φ Ψ : 性质, 积极 Φ → (Φ ⇒ Ψ) → 积极 Ψ⌋.

Theorem 积极性质可能存在实例 : ⌈∀ Φ, 积极 Φ → 一致 Φ⌋.
Proof.
  证明. intros Φ H. 反证.
  apply (爆炸原理 w Φ (反 Φ)) in 反设.
  apply (积极性质的反面消极 w Φ). apply H.
  now apply (积极的必然后果也积极 w Φ).
Qed.

(* P是x的本性，当且仅当x的任意性质都是P的必然后果 *)
Definition 本性 : 性质 → 实体 → 命题 :=
  λ Φ x, ∀ Ψ, Ψ x → Φ ⇒ Ψ.

(* 实体实在，当且仅当该实体的任意本性都必然存在实例 *)
Definition 实在性 : 性质 := λ x, ∀ Φ, 本性 Φ x → □ ∃ x, Φ x.

Axiom 实在性积极 : ⌈积极 实在性⌋.

Lemma 实在性可能存在实例 : ⌈一致 实在性⌋.
Proof. 证明. apply 积极性质可能存在实例. apply 实在性积极. Qed.

Lemma 可能必然存在反同一性实体 : ⌈◇ □ ∃ x, 反同一性 x⌋.
Proof.
  证明. eapply 可能性三段论1. apply 实在性可能存在实例.
  apply 𝗡. 证明. intros []. apply H. firstorder.
Qed.

Fact 公理不一致 : False.
Proof.
  destruct 存在世界 as [w].
  pose proof 可能必然存在反同一性实体. firstorder.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e216m2e108m1_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import A1_Plan A2_Orientation A4_Droite A5_Cercle A7_Tactics .
Require Import B1_ClockwiseProp B4_RaysProp B7_Tactics .
Require Import C1_Distance C5_TriangularInequality .
Require Import D1_IntersectionCirclesProp D3_SecondDimension D5_Tactics .
Require Import F2_MarkSegment F5_Tactics .
Require Import J4_Tactics .
Require Import L6_Tactics .
Require Import M1_SuperImposedLines M4_PerpendicularLines M5_Tactics.

Section DRAWING_PERPENDICULAR.

Definition  PerpendicularDown : forall (l : Line) (A : Point),
	~OnLine l A -> Line.
Proof.
	intros.
	destruct l as (B, C, Hbc).
	setCircle0 B B A ipattern:(c1).
	setCircle0 C C A ipattern:(c2).
	setIntersectionCircles3 c1 c2 ipattern:(D).
	 simpl in |- *; immediate11.
	 setIntersectionCircles3 c2 c1 ipattern:(E).
	   setLine0 D E ipattern:(d).
	  simpl in H; by2Cases1 H.
	   from12 E (A = E).
	     step12 H8.
	     step12 H3.
	   from12 D (A = D).
	     step12 H8.
	     step12 H6.
	  exact d.
Defined.

Ltac PerpendicularDownDef l A H B C Hbc H0 H1 D H2 E c1 c2 Hde := intros;
destruct l as (B, C, Hbc);
simpl in |- *;
simpl in H;
pose (H0 := TriangleSpecABCBAC B A C);
fold H0 in |- *;
pose (H1 := conj Hbc H0:SecantCircles (Compass B B A) (Compass C C A));
fold H1 in |- *;
setIntersectionCircles3 (Compass B B A) (Compass C C A) ipattern:(D);
fold D in |- *;
pose
 (H5 :=
  SecantCirclesSym (Compass B B A) (Compass C C A) H1
  :SecantCircles (Compass C C A) (Compass B B A));
 fold H5 in |- *;
setIntersectionCircles3 (Compass C C A) (Compass B B A) ipattern:(E);
 fold E in |- *;
pose
 (c1 :=
  fun H9 : Clockwise B C A =>
  eq_ind A (fun E0 : Point => D <> E0)
    (sym_not_eq
       (FigureDistinct (fun M : Point => Clockwise B C M) A D H9
          (fun H10 : Clockwise B C D =>
           False_ind False
             (NotClockwiseIntersectionCirclesPoint
                (Compass B B A) (Compass C C A) H1
                (ClockwiseBCA B C D H10))))) E
    (UniqueIntersectionCirclesPoint (Compass C C A)
       (Compass B B A) H5 A
       (eq_ind (Distance B D)
          (fun delta0 : Point =>
           Distance C D = Distance C A ->
           Distance C E = Distance C A ->
           Distance B E = delta0 -> Distance C A = Distance C A)
          (fun Heq0 : Distance C D = Distance C A =>
           eq_ind (Distance C D)
             (fun delta2 : Point =>
              Distance C E = delta2 ->
              Distance B E = Distance B D -> delta2 = delta2)
             (fun Heq1 : Distance C E = Distance C D =>
              eq_ind (Distance C E)
                (fun delta1 : Point =>
                 Distance B E = Distance B D -> delta1 = delta1)
                (fun _ : Distance B E = Distance B D =>
                 refl_equal (Distance C E)) (Distance C D) Heq1)
             (Distance C A) Heq0) (Distance B A)
          (OnCircle1IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle2IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle1IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5)
          (OnCircle2IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5))
       (eq_ind (Distance B D)
          (fun delta0 : Point =>
           Distance C D = Distance C A ->
           Distance C E = Distance C A ->
           Distance B E = delta0 -> delta0 = delta0)
          (fun Heq0 : Distance C D = Distance C A =>
           eq_ind (Distance C D)
             (fun delta2 : Point =>
              Distance C E = delta2 ->
              Distance B E = Distance B D -> Distance B D = Distance B D)
             (fun (_ : Distance C E = Distance C D)
                (Heq1 : Distance B E = Distance B D) =>
              eq_ind (Distance B E) (fun delta : Point => delta = delta)
                (refl_equal (Distance B E)) (Distance B D) Heq1)
             (Distance C A) Heq0) (Distance B A)
          (OnCircle1IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle2IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle1IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5)
          (OnCircle2IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5))
       (ClockwiseNotClockwise A B C (ClockwiseCAB B C A H9))));
fold c1 in |- *;
pose
 (c2 :=
  fun H9 : Clockwise C B A =>
  eq_ind A (fun D0 : Point => D0 <> E)
    (FigureDistinct (fun M : Point => Clockwise C B M) A E H9
       (fun H10 : Clockwise C B E =>
        False_ind False
          (NotClockwiseIntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5 (ClockwiseBCA C B E H10)))) D
    (UniqueIntersectionCirclesPoint (Compass B B A)
       (Compass C C A) H1 A
       (eq_ind (Distance B D)
          (fun delta0 : Point =>
           Distance C D = Distance C A ->
           Distance C E = Distance C A ->
           Distance B E = delta0 -> delta0 = delta0)
          (fun Heq0 : Distance C D = Distance C A =>
           eq_ind (Distance C D)
             (fun delta2 : Point =>
              Distance C E = delta2 ->
              Distance B E = Distance B D -> Distance B D = Distance B D)
             (fun (_ : Distance C E = Distance C D)
                (Heq1 : Distance B E = Distance B D) =>
              eq_ind (Distance B E) (fun delta : Point => delta = delta)
                (refl_equal (Distance B E)) (Distance B D) Heq1)
             (Distance C A) Heq0) (Distance B A)
          (OnCircle1IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle2IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle1IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5)
          (OnCircle2IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5))
       (eq_ind (Distance B D)
          (fun delta0 : Point =>
           Distance C D = Distance C A ->
           Distance C E = Distance C A ->
           Distance B E = delta0 -> Distance C A = Distance C A)
          (fun Heq0 : Distance C D = Distance C A =>
           eq_ind (Distance C D)
             (fun delta2 : Point =>
              Distance C E = delta2 ->
              Distance B E = Distance B D -> delta2 = delta2)
             (fun Heq1 : Distance C E = Distance C D =>
              eq_ind (Distance C E)
                (fun delta1 : Point =>
                 Distance B E = Distance B D -> delta1 = delta1)
                (fun _ : Distance B E = Distance B D =>
                 refl_equal (Distance C E)) (Distance C D) Heq1)
             (Distance C A) Heq0) (Distance B A)
          (OnCircle1IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle2IntersectionCirclesPoint (Compass B B A)
             (Compass C C A) H1)
          (OnCircle1IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5)
          (OnCircle2IntersectionCirclesPoint (Compass C C A)
             (Compass B B A) H5))
       (ClockwiseNotClockwise A C B (ClockwiseCAB C B A H9))));
fold c2 in |- *;
pose (Hde := or_ind c1 c2 (NotCollinearTwoCases B C A H)).

Lemma PerpendicularDownOnLine : forall (l : Line) (A : Point) (H : ~OnLine l A),
	OnLine (PerpendicularDown l A H) A.
Proof.
	PerpendicularDownDef ipattern:(l) ipattern:(A) ipattern:(H) ipattern:(B) ipattern:(C)
	 ipattern:(Hbc) ipattern:(H0) ipattern:(H1) ipattern:(D) ipattern:(H2) ipattern:(E)
	 ipattern:(c1) ipattern:(c2) ipattern:(Hde).
	by2Cases1 H.
	 from12 E (A = E).
	   step12 H10.
	 from12 D (A = D).
	   step12 H10.
Qed.

Lemma PerpendicularDownPerpendicular : forall (l : Line) (A : Point) (H : ~OnLine l A),
	Perpendicular l (PerpendicularDown l A H).
Proof.
	PerpendicularDownDef ipattern:(l) ipattern:(A) ipattern:(H) ipattern:(B) ipattern:(C)
	 ipattern:(Hbc) ipattern:(H0) ipattern:(H1) ipattern:(D) ipattern:(H2) ipattern:(E)
	 ipattern:(c1) ipattern:(c2) ipattern:(Hde).
	setMidLine9 D E ipattern:(m).
	assert (EqLine m (Ruler B C Hbc)).
	 step12 Hbc.
 	  apply H10; immediate12.
	  apply H10; immediate12.
	 step12 H11.
	   unfold m in |- *; immediate12.
Qed.

Definition  PerpendicularUp : forall (l : Line) (A : Point),
	OnLine l A -> Line.
Proof.
	destruct l as (B, C, Hbc); simpl in |- *; intros.
	setAddSegmentPoint5 B C A B C ipattern:(D).
	setSymmetricPoint5 D A ipattern:(E).
	 step12 H1.
	 setMidLine9 D E ipattern:(m).
	   exact m.
Defined.

Ltac PerpendicularUpDef l A H B C Hbc D Hda E Hde:=
intros l A H; destruct l as (B, C, Hbc); simpl in H;
unfold PerpendicularUp in |- *;
setAddSegmentPoint5 B C A B C ipattern:(D); fold D in |- *;
pose (Hda := DistinctEqDistanceDistinct B C D A Hbc
    (eq_ind_r
       (fun p : Point => Distance A D = Distance B C -> Distance B C = p)
       (fun Heq : Distance A D = Distance B C =>
        eq_ind_r (fun delta : Point => Distance B C = delta)
          (refl_equal (Distance B C)) Heq) (DistanceSym D A)
       (EqDistanceAddSegmentPoint B C A B C Hbc H)));
 fold Hda in |- *;
setSymmetricPoint5 D A ipattern:(E); fold E in |- *;
pose (Hde := BetweenDistinctAC D A E (BetweenSymmetricPoint D A Hda));
 fold Hde in |- *.

Lemma PerpendicularUpOnLine : forall (l : Line) (A : Point) (H : OnLine l A),
	OnLine (PerpendicularUp l A H) A.
Proof.
	PerpendicularUpDef ipattern:(l) ipattern:(A) ipattern:(H) ipattern:(B) ipattern:(C)
	 ipattern:(Hbc) ipattern:(D) ipattern:(Hda) ipattern:(E) ipattern:(Hde).
	immediate12.
Qed.

Lemma PerpendicularUpPerpendicular : forall (l : Line) (A : Point) (H : OnLine l A),
	Perpendicular l (PerpendicularUp l A H).
Proof.
	PerpendicularUpDef ipattern:(l) ipattern:(A) ipattern:(H) ipattern:(B) ipattern:(C) ipattern:(Hbc) ipattern:(D) ipattern:(Hda) ipattern:(E) ipattern:(Hde).
	from12 Hda (EqLine (Ruler D A Hda) (Ruler B C Hbc)).
	from12 H5 (EqLine (Ruler D E Hde) (Ruler B C Hbc)).
	 step12 Hda.
	 step12 H6.
Qed.

End DRAWING_PERPENDICULAR.


Set Implicit Arguments.
Unset Strict Implicits.

Require Import Ssreflect.ssreflect Ssreflect.ssrbool.
Require Import Coq.Program.Wf Coq.Classes.SetoidClass Coq.Logic.FunctionalExtensionality.

Require Import taseq monad union.

Inductive Eff (R : list (Type -> Type)) (A : Type) : Type :=
| Pure : A -> Eff R A
| Impure : forall {X}, Union R X -> SnocNel (Eff R) X A -> Eff R A.

Definition Arrs (R : list (Type -> Type)) (A B : Type) := SnocNel (Eff R) A B.

Program Fixpoint tapp {R} {A B} (q : Arrs R A B) (a : A) {measure (tsize q)} : Eff R B :=
  match tviewl q with
  | TOne k => k a
  | TCons _ k t =>
    match k a with
    | Pure a' => tapp t a'
    | Impure _ u q' => Impure u (q' |><| t)
    end
  end.
Next Obligation.
  by rewrite [tsize q]tviewl_preserve_size -Heq_anonymous /=.
Defined.

Section EqArrs.

  Variable R : list (Type -> Type).
  Variable A B : Type.

  Definition eqarrs (f g : Arrs R A B) :=
    forall a : A, tapp f a = tapp g a.

  Lemma arefl (f : Arrs R A B) : eqarrs f f.
  Proof. by done. Qed.
  Lemma asym (f g : Arrs R A B) : eqarrs f g -> eqarrs g f.
  Proof. by rewrite/eqarrs. Qed.
  Lemma atrans (f g h : Arrs R A B) : eqarrs f g -> eqarrs g h -> eqarrs f h.
  Proof.
      by rewrite/eqarrs=> H H' a; move: (H a) (H' a)=> -> ->.
  Qed.

  Program Instance arrs_setoid : Setoid (Arrs R A B) := {
    equiv := eqarrs
  }.
  Next Obligation.
    split.
    - by apply: arefl.
    - by apply: asym.
    - by apply: atrans.
  Qed.

  Axiom arrs_ext : forall f g, f == g -> f = g.
  (* It is impossible to prove (arrs |> eff_pure == arrs) *)
  (* What axiom to be able to prove (arrs |> eff_pure == arrs) ? *)
End EqArrs.

Section EffMonad.

  Definition eff_pure {R} {A} (a : A) := Pure R a.
  Definition eff_bind {R} {A B} (e : Eff R A) (f : A -> Eff R B) :=
    match e with
    | Pure a => f a
    | Impure _ u q => Impure u (q |> f)
    end.

  Existing Instance arrs_setoid.

  Lemma enq_pure_pure :
    forall R A,
      SOne (Eff R) (@eff_pure R A) |> eff_pure == (SOne _ eff_pure).
  Proof.
    move=> R A a.
    by compute.
  Qed.

  Lemma enq_f_pure :
    forall R A (f : A -> Eff R A),
      SOne _ f |> eff_pure == SOne _ f.
  Proof.
    move=> R A f a.
    compute.
    case H : (f a); first done.
    congr (_ _).
    admit.                      (* impossible *)
  Qed.

  Lemma enq_pure :
    forall R A B (arrs : Arrs R A B),
      arrs |> eff_pure == arrs.
  Proof.
    move=> R A B; elim=> //=.
    - move=> X k.
      rewrite/eqarrs=> a.
      case H : (k a).
      + compute; by rewrite H.
      + compute.
        rewrite H.
        congr (_ _).
        apply arrs_ext.
        admit.                  (* impossible *)
    - admit.
  Qed.

  Lemma enq_r_to_l :
    forall R A B C D (arrs : Arrs R A B) (k : B -> Eff R C) (h : C -> Eff R D),
      arrs |> (fun a => eff_bind (k a) h) == arrs |> k |> h.
  Proof.
    move=> R A B C D; elim=> //=.
    - move=> X f k h a.
      case H : (f a)=> [ x | X' u s ].
      + compute; rewrite H.
        by case H' : (k x).
      + compute; rewrite H.
        congr (_ _).
        admit.                  (* impossible *)
    - admit.
  Qed.

  Program Instance eff_is_monad (R : list (Type -> Type)) : Monad (Eff R) := {
    pure A := eff_pure;
    bind A B := eff_bind
  }.
  Next Obligation.
    elim: ma=> //=.
    move=> X u arrs; congr (_ _).
    apply: arrs_ext.
    by apply: enq_pure.
  Qed.
  Next Obligation.
    elim: ma=> //=.
    move=> X u arrs; congr (_ _).
    apply: arrs_ext.
    by apply: enq_r_to_l.
  Qed.
End EffMonad.


(** * Semantic Cut-Elimination (following Su & Sano ) *)

Require Import models nd forms decidability toolbox.
Require Import PslBase.Base.

Section Canonical.
  (**
We define the *canonical models*, whose worlds are the maximally consistent theories.
We first define the relations.
   **)
  Context {d : DerivationType}.
    Variable A0 : context.
  Variable s0 : form.
  Definition U' := scl (s0::(K ⊥)::A0).

  Record mcTheory := mkmcTheory {
                         T: list form;
                         B: form;
                         Tgood: ~(gen T B);
                         Tsubs: T <<= U' ;
                         Tlcons: forall A, A el U' -> A el T \/ (gen (A::T) B) ;
                       }.

  (** Define extension operator on theories  **)

  Definition single_extend (Ω: context) (A: form) (a: form) :=
    if (@gen_dec (a::Ω) A d) then Ω else (a::Ω).

  Lemma single_extend_subcontext  A Ω B: Ω <<= (single_extend Ω A B).
  Proof.
    intros a Ha.  unfold single_extend. destruct (gen_dec (B :: Ω) A d); eauto.
  Qed.
  Fixpoint extend (Ω: context) (A: form) (Γ: context) : context :=
    match Γ with
      nil => Ω
    | (a::Γ') =>
      single_extend (extend Ω A Γ') A a  end.

  Lemma extend_does_not_derive Ω A Γ: ~(gen Ω A) -> ~(gen (extend Ω A Γ) A).
  Proof.
    revert Ω.
    induction Γ; eauto.
    - intros.  destruct (gen_dec (a :: extend Ω A Γ) A d) eqn:di.
      +  simpl extend. unfold single_extend. rewrite di. apply IHΓ.  auto.
      +  simpl extend. unfold single_extend. rewrite di. apply n.
  Qed.

  Lemma extend_subset Ω Γ A: Ω <<= (extend Ω A Γ).
  Proof.
    revert Ω.
    induction Γ; eauto.
    - intro.  simpl extend. unfold single_extend.  destruct (gen_dec (a :: extend Ω A Γ) A d); eauto.
  Qed.

  Lemma extend_disjunction  Γ Ω A B: ~(gen Ω A) -> B el Γ ->  B el (extend Ω A Γ) \/ (gen (B::(extend Ω A Γ)) (A)).
  Proof.
    intros H H0. induction Γ.
    - inversion H0.
    -  destruct H0.
       + subst a. simpl extend. unfold single_extend. destruct (gen_dec (B :: extend Ω A Γ) A d).  tauto.   left. auto.
       + specialize (IHΓ H0).   destruct IHΓ. left.   simpl extend. unfold single_extend. destruct (gen_dec (a :: extend Ω A Γ) A d); eauto.
         * right. apply genW with ((B :: extend Ω A Γ)); auto.  intros x Hx. destruct Hx.
           -- subst x. eauto.
           --  right.   simpl extend. unfold single_extend. destruct (gen_dec (a :: extend Ω A Γ) A d); auto.
  Qed.

  Lemma extend_locally_prime Γ Ω A B C:  ~(gen Ω A) -> (B ∨ C) el (extend Ω A Γ)  -> B el Γ -> C el Γ -> B el (extend Ω A Γ) \/ C el (extend Ω A Γ).
  Proof.
    intros. destruct (extend_disjunction H H1); try tauto.  destruct (extend_disjunction H H2); try tauto. exfalso.
    specialize (@extend_does_not_derive Ω A Γ H). intro. apply H5. apply genOL with B C.  auto. auto. auto.
   Qed.

  Lemma extend_locally_easy_subset Ω A Γ: (extend Ω A Γ) <<= (Ω ++ Γ).
  Proof.
    revert Ω. induction Γ. eauto. intros.  simpl extend. unfold single_extend. destruct (gen_dec (a :: extend Ω A Γ) A d); auto.
    specialize (IHΓ Ω). intros b Hb.  apply  IHΓ in Hb. apply in_app_iff. apply in_app_iff in Hb. destruct Hb. tauto. right. right. assumption.
    intros b Hb.  destruct Hb; eauto. subst b; eauto. apply IHΓ in H.  apply in_app_iff in H; destruct H; apply in_app_iff; try tauto. right. right. auto.
  Qed.

  Lemma extend_locally_subset Γ A Ω: Ω <<= Γ -> (extend Ω A Γ) <<= Γ.
  Proof.
    intros. enough (extend Ω A Γ <<= Γ ++ Γ).  intros a Ha. specialize (H0 a Ha). apply in_app_iff in H0; destruct H0; assumption.
    enough (extend Ω A Γ <<= Ω ++ Γ). intros a Ha. specialize (H0 a Ha).  apply in_app_iff in H0. destruct H0; eauto.  apply extend_locally_easy_subset.
  Qed.
  (* Not deriven implies adding it causes us to derive A *)
  Definition U'_sfc : sf_closed U' := @scl_closed _.

  Definition subsetMKT (A B: mcTheory) :=  (T A) <<= (T B).
  Definition valuationMKT (A: mcTheory) (a: nat) := (Var a) el (T A).
  Definition subsetVerif (A B:mcTheory) := (unK (T A)) <<= (T B).

  Instance canonical: (KripkeModel).
  Proof.
    apply mkKripkeModel with (world := mcTheory) (cogn := subsetMKT) (val := valuationMKT) (verif := subsetVerif).
    firstorder.  firstorder.
    + intros A B c d' E. unfold subsetVerif in c.  apply c.  apply unK_in_iff.  eauto.
    +   intros x y z H H0. intros a Ha.  apply unK_in_iff in Ha. destruct Ha; auto.  apply H0. apply unK_in_iff. left. apply H. auto. apply H0. apply unK_in_iff. right. apply H.  auto.
  Defined.

  Definition Lindenbaum (Γ : list form) (A: form) (H: Γ <<= U') (H'': A el U') (H': ~(gen Γ A)) : mcTheory.
  Proof.
    eapply mkmcTheory.
    - apply extend_does_not_derive.  apply H'.
    - apply extend_locally_subset.     auto.
    - intro.
      intro.
      specialize (@extend_does_not_derive Γ A U' H'). intro.
      specialize (extend_disjunction H' H0). intro. destruct H2.
      +  left.  apply H2.
      +  right.   auto.
  Defined.

  Lemma mctheory_conjucntion (Δ: mcTheory) A B: (A ∧ B) el (T Δ) -> (A el (T Δ)) /\  (B el (T Δ)).
  Proof.
    intros.
    split.
    - destruct Δ. simpl.  cbn in H.  specialize (  Tlcons0 A). destruct Tlcons0. enough ((A ∧ B) el U'). apply U'_sfc in H0; tauto.  eauto.   auto. exfalso. apply Tgood0. apply genAL with A B.  auto.  apply genW with ((A :: T0)). auto.  firstorder eauto.
    - destruct Δ. simpl.  cbn in H.  specialize (  Tlcons0 B). destruct Tlcons0. enough ((A ∧ B) el U'). apply U'_sfc in H0; tauto.  eauto.   auto. exfalso. apply Tgood0. apply genAL with A B.  auto.  apply genW with ((B :: T0)). auto.  firstorder eauto.
  Qed.

  Lemma mctheory_disjunction (Δ: mcTheory) A B: (A ∨ B) el (T Δ) -> (A el (T Δ)) \/  (B el (T Δ)).
  Proof.
    destruct Δ. intros.
    intros. decide (A el (T0)); decide (B el (T0)). all: try tauto.
    cbn in H. cbn. enough (A el U'). enough (B el U'). pose proof (Tlcons0 A H0) as Ha.   pose proof (Tlcons0 B H1) as Hb.  destruct Ha; destruct Hb; try tauto.
    exfalso. apply Tgood0. apply genOL with  A B. auto. auto. auto. all: apply Tsubs0 in H;   apply U'_sfc in H; tauto.
  Qed.

  Lemma truth_lemma : forall (x: form), In x U' -> forall (t: (@world  canonical)), ( (x el (T t) -> (evalK x t))  /\( ~(gen (T t) x) -> ~(evalK x t))).
  Proof.
    intro x. intro Hx. induction x.
    - intros w. split.
      + intros H w' v.  apply IHx. apply U'_sfc in Hx. auto.   apply v. apply unK_in_iff. tauto.
      + intros D D1.   assert (~(gen (unK (T w)) x)).   intro. apply D. apply genKI. auto. apply U'_sfc in Hx.  specialize (IHx Hx).
        assert (exists Δ: mcTheory, (unK (T w)) <<= (T Δ)
                                   /\ ~(gen (T Δ) (x))).
        {
          assert ((unK (T w)) <<= U'). { destruct w.  intros a Ha. apply unK_in_iff in Ha.  destruct Ha; auto.  assert (K a el U') by auto.  apply U'_sfc in H1.  assumption. }
          eexists (@Lindenbaum  (unK (T w)) x H0 Hx H). split.
          - simpl. apply extend_subset.
          - simpl. apply extend_does_not_derive.  auto.
        }

        destruct H0 as (w' & Hw').
        specialize (IHx w').  destruct IHx. destruct Hw'.  specialize (H1 H3). specialize (D1 w').   apply H1. apply D1. auto.

    - intros w.  split.
      + intro H. apply U'_sfc in Hx. intros w' Hw' c. assert (x2 el (T w') \/ ~(gen (T w') x1)).
        {
          decide (x2 el (T w')); try tauto.
          right. intro.
          destruct w'. cbn in H0. destruct (Tlcons0 x2).  tauto. cbn in n. congruence.
          cbn in n. apply Tgood0. apply genIL with x1 x2.  auto. auto.  auto.
        }
        destruct H0.
        *  apply IHx2. tauto. auto.
        *  apply IHx1 in H0.   congruence. tauto.
      + intro. intro. assert (~ gen (x1::(T w)) x2). {
          intro. apply H. apply genIR. auto.
        }
        enough (exists w' : mcTheory, (x1::(T w)) <<= (T w') /\ ~(gen (T w') x2)).
        destruct H2 as (w' & Hw' & Hw'2).
        apply U'_sfc in Hx. destruct Hx as (Hx1 & Hx2). specialize (IHx2 Hx2 w'). specialize (IHx1 Hx1 w').    destruct IHx2. apply H3.  auto.
        apply H0. intros a Ha.  apply Hw'.  auto.  apply IHx1.  apply Hw'.  auto.
        assert ((x1::(T w)) <<= U'). {  intros a Ha. destruct Ha.  subst a. apply U'_sfc in Hx; tauto.  destruct w; eauto. }
                                    apply U'_sfc in Hx; destruct Hx.
          eexists (@Lindenbaum  (x1::(T w)) x2 H2 H4 H1). split.
          * simpl. apply extend_subset.
          * simpl. apply extend_does_not_derive.  auto.

    - intros w.  split.
      + intro. apply mctheory_conjucntion in H.  split.
        * apply IHx1. apply U'_sfc in Hx.  tauto.  tauto.
        * apply IHx2.  apply U'_sfc in Hx.  tauto.  tauto.
      + intro.    intro.  destruct H0.
        assert (~(gen (T w) x1) \/ ~(gen (T w) x2)). {
          destruct (gen_dec (T w) x1 d).  destruct (gen_dec (T w) x2 d).  exfalso. apply H. apply genAR; auto. tauto.  tauto.
        }
        apply U'_sfc in Hx.  destruct Hx as (Hx1 & Hx2). specialize (IHx1 Hx1 w). specialize (IHx2 Hx2 w). destruct IHx1, IHx2.   destruct H2.
        * specialize (H4 H2). congruence.
        * specialize (H6 H2). congruence.
    - intros w. split.
      + intro. apply mctheory_disjunction in H.  destruct H.
        * simpl evalK. left. apply IHx1. apply U'_sfc in Hx; tauto.  auto.
        * right. apply IHx2. apply U'_sfc in Hx; tauto.  auto.
      +  apply U'_sfc in Hx.  destruct Hx as (Hx1 & Hx2).
         intro. intro. apply H.   destruct H0.
         * apply genOR1. destruct (gen_dec (T w) x1 d); try tauto.   apply IHx1 in n.  congruence.  tauto.
         * apply genOR2. destruct (gen_dec (T w) x2 d); try tauto.   apply IHx2 in n.  congruence.  tauto.
    -  intros w. split.
       + intro.  simpl evalK. destruct w. apply Tgood0. apply genF. auto.
       + intro. intro.  unfold evalK in H0. auto.
    -  intros w. split.
       + intro. apply H.
       + intro.   intro. apply H. apply genV. apply H0.
  Qed.

  Lemma are_iel_models: d = normal -> forall w, exists u, verif w u.
  Proof.
    intros.
    assert (exists Δ: mcTheory, (unK (T w)) <<= (T Δ)).
    {
      destruct w.
      assert (~(gen (unK T0) (⊥))).
      intro. apply Tgood0. rewrite H.   apply genKB. apply genKI. subst d.   eapply H0.

      enough (unK (T0) <<= U').
      assert (⊥ el U'). {
        unfold U'. simpl.  firstorder eauto.
      }
      exists (Lindenbaum  H1 H2 H0).
      simpl T. enough (unK (T0) <<= (extend (unK T0) (⊥) U')).
      intros a Ha. apply H3. assumption.
      apply extend_subset; auto.
      intros a Ha.   apply unK_in_iff in Ha; destruct Ha; eauto.
      apply Tsubs0 in H1.  apply U'_sfc in H1.  auto.
    }
    destruct H0.  exists x.  firstorder eauto.
  Qed.

    Lemma completeness' Ω A: A el U' -> Ω <<= U' -> entails Ω A -> gen Ω A.
  Proof.
    intros Au U H. destruct (gen_dec Ω A d); auto.  exfalso.
    unfold entails in H.
    specialize (H (@canonical)).
     assert (exists Δ: mcTheory, ~(gen (T Δ) A) /\ (Ω <<= (T Δ))).
     {
       eexists (Lindenbaum  U Au n). split.
       - simpl.  apply extend_does_not_derive.   auto.
       - simpl.   apply extend_subset.
     }
     assert (model_constraint canonical). {
       destruct d eqn:dn; simpl; auto. unfold isIEL.  apply are_iel_models. auto.

     }
     specialize (H H1).
     destruct (H0) as [Δ H2].
     specialize (H Δ). destruct H2.
     decide (A el (T Δ)).
    + apply H2. apply genA.  auto.
    +
      pose proof (truth_lemma Au Δ).

      destruct H4. specialize (H5 H2).   apply H5.  apply H.   unfold evalK'.   intros s H6.
      apply truth_lemma.  auto.  auto.
  Qed.

End Canonical.

Lemma completeness Ω A (D: DerivationType): entails Ω A -> gen Ω A.
Proof.
  intro. apply completeness' with Ω A. unfold U'. apply scl_incl'. auto. intros a Ha. apply scl_incl'. auto. auto.
Qed.

Lemma soundnessGen (Γ: context) (A: form) {D: DerivationType}:
  gen Γ A -> entails Γ A.
Proof.
  intros H % gen2nd.  eapply soundness.  auto.
Qed.

(**
   ** Semantic Cut-Elimination
 **)

Lemma semaCut Γ A (D: DerivationType):
  nd Γ A -> gen Γ A.
Proof.
  intro. apply soundness in H. apply completeness.  assumption.
Qed.
(** Soundness w.r.t gen used by using nd soundness **)
Lemma semaCut' Γ A B (D: DerivationType):
  gen Γ A -> gen (A::Γ) B -> gen Γ B.
Proof.
  intros H1 % gen2nd H2 % gen2nd.
  apply semaCut.
  eauto.
Qed.


(** * Coproduct of natural transformations *)
Require Import Category.Core Functor.Core Category.Sum Functor.Sum NaturalTransformation.Core.

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

Section sum.
  Definition sum
             C C' D F G F' G'
             (T : @NaturalTransformation C D F G)
             (T' : @NaturalTransformation C' D F' G')
  : NaturalTransformation (F + F') (G + G').
  Proof.
    refine (Build_NaturalTransformation
              (F + F') (G + G')
              (fun x => match x with
                          | Datatypes.inl c => T c
                          | Datatypes.inr c' => T' c'
                        end)
              _).
    abstract (
        repeat (intros [] || intro); simpl;
        auto with natural_transformation
      ).
  Defined.
End sum.

Module Export NaturalTransformationSumNotations.
  Notation "T + U" := (sum T U) : natural_transformation_scope.
End NaturalTransformationSumNotations.


Require Export sequences_AX.

Module lub_proof(N:Num_w).

Import N.
Module Export UU := seq(N).

Axiom lim_not_lim : forall n v, lim n/\0<=n -> ~lim v/\0<=v -> n <v.

Lemma foo :
forall S : subset,
forall Hdec : forall alpha beta : HRw,
       beta [>] alpha -> {s : HRw | S s /\ s [>] alpha} + {upper_bound S beta},
forall s0 : HRw,
forall Hs0 : S s0,
forall b0' : HRw,
forall b0,
forall Hb0 : b0 = b0' [+] [1],
forall Hup : upper_bound S b0,
forall s_b_alpha_beta : forall (k : A) (Hk : std k /\ 0 <= k),
                 {sn : HRw & {bn : HRw & Psb S s0 b0 k Hk sn bn}},
forall Hs_b_alpha_beta : s_b_alpha_beta = def_s_b_alpha_beta S Hdec s0 b0 Hs0 Hup,
forall ss : forall k0 : A, std k0 /\ 0 <= k0 -> HRw,
forall Hss : ss = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) =>
      projT1 (s_b_alpha_beta k0 Hk0),
forall bb : forall k0 : A, std k0 /\ 0 <= k0 -> HRw,
forall Hbb : bb = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) =>
      projT1 (projT2 (s_b_alpha_beta k0 Hk0)),
forall ssA : forall k0 : A, std k0 /\ 0 <= k0 -> A,
forall HssA : ssA = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) => proj1_sig (ss k0 Hk0),
forall bbA : forall k0 : A, std k0 /\ 0 <= k0 -> A,
forall HbbA : bbA = fun (k0 : A) (Hk0 : std k0 /\ 0 <= k0) => proj1_sig (bb k0 Hk0),
forall v1 : A,
forall Hv1 : ~ lim v1 /\
      0 < v1 /\
      (forall k : A,
       0 <= k /\ k <= v1 -> extends ssA k <= min k (extends bbA)),
forall v2 : A,
forall Hv2 : ~ lim v2 /\
      0 < v2 /\
      (forall n : A,
       0 <= n /\ n <= v2 ->
       forall m : A, 0 <= m -> m < n -> extends ssA m <= extends ssA n),
forall n : A,
forall Hlim : std n,
forall Hlt : 0 <= n,
extends ssA n <= min (minA v1 v2) (extends bbA).
Proof.
intros.
elim (A0_dec (v1 + - v2)). (* Meaning ? *)
intros Hv1v2.
apply le_trans with (min v1 (extends bbA)).
apply le_trans with (extends ssA  v1).
decompose [and] Hv2.
apply H3.
split.
apply lt_le; solve[intuition].
setoid_replace v2 with (0+v2) by ring.
setoid_replace v1 with ((v1 + -v2)+v2) by ring.
apply le_plus.
elim Hv1v2; intros Hv1v2'.
apply lt_le; assumption.
rewrite Hv1v2'; apply le_refl.
apply le_refl.
assumption.
assert (nlim:lim n).
apply std_lim; assumption.
apply lim_not_lim; solve [intuition | intuition; apply lt_le; intuition].
decompose [and] Hv1.
apply H3; split;  solve[intuition | intuition; apply lt_le; intuition | apply le_refl ].
apply min_def2.
unfold minA; destruct (A0_dec (v1 +- v2)).
apply le_refl.
elim Hv1v2.
intros.
assert (Hf:False)
  by (apply contradict_lt_le with (s:=v1+ - v2) (x:=0); [ assumption | apply lt_le; assumption]).
destruct Hf.
intros Hrew; rewrite Hrew in l.
assert (Hf:False) by (apply not_lt_0_0; assumption).
destruct Hf.
intros Hv1v2.
apply le_trans with (min v2 (extends bbA)).
apply le_trans with (extends ssA  v2).
decompose [and] Hv2.
apply H3.
split.
apply lt_le; assumption.
apply le_refl.
assumption.
assert (nlim : lim n).
apply std_lim; assumption.
apply lim_not_lim;  solve [intuition | intuition; apply lt_le; intuition].
decompose [and] Hv1.
apply H3.
split.
apply lt_le; solve [intuition].
setoid_replace v2 with (0+v2) by ring.
setoid_replace v1 with ((v1 + -v2)+v2) by ring.
apply le_plus.
apply lt_le; assumption.
apply le_refl.
apply min_def2.
unfold minA.
destruct (A0_dec (v1 + - v2)).
destruct s.
assert (Hf:False)
  by (apply contradict_lt_le with (s:=v1+ - v2) (x:=0); [ assumption | apply lt_le; assumption]).
destruct Hf.
rewrite e in Hv1v2.
assert (Hf:False) by (apply not_lt_0_0; assumption).
destruct Hf.
apply le_refl.
Qed.

Lemma least_upper_bound_principle :
  forall S:subset, non_empty S -> bound_above S ->
    (forall alpha beta:HRw,  beta [>] alpha ->
      {s:HRw| S s /\ s [>] alpha}+{upper_bound S beta}) ->
   has_least_upper_bound S.
Proof.
intros S Hnon_empty Hbound Hdec.
elim Hnon_empty; intros s0 Hs0.
elim Hbound; intros b0' Hb0'.

pose (b0 := b0' [+] [1]).
assert (Hup:(upper_bound S b0)) by (unfold b0; apply HRwgt_upper_bound; assumption).
assert (b0 [>] s0) by (unfold b0; apply Hup; assumption).
pose (s_b_alpha_beta := (def_s_b_alpha_beta S Hdec s0 b0 Hs0 Hup)).
(* avec valeurs dans HRw *)
pose (ss := fun k0 Hk0 =>  (projT1  (s_b_alpha_beta k0 Hk0))).
pose (bb := fun k0 Hk0 => (projT1 (projT2  (s_b_alpha_beta k0 Hk0)))).
(* avec valeurs dans A *)
pose (ssA := (fun k0 Hk0 => proj1_sig (ss k0 Hk0))).
pose (bbA := (fun k0 Hk0 => proj1_sig (bb k0 Hk0))).

assert (Hbn_sup_sn : (forall n, std n /\ 0<=n ->  (forall k, forall Hk:(std k/\ 0 <=k), k<=n ->
  (ssA k Hk) <= (min_lim n bbA)))).
intros n (Hlimn, Hlen) k (Hlimk,Hlek) Hkn.
replace (ssA k (conj Hlimk Hlek)) with (proj1_sig (ss k (conj Hlimk Hlek))) by solve[trivial].
assert (HS:(S (ss k (conj Hlimk Hlek)))).
unfold ss.
elim (s_b_alpha_beta k (conj Hlimk Hlek)).
intros sk (bk, (Hsk,(Hbk,H'))).
simpl; solve [intuition].
apply min_lim_prop.
intros p (Hlimp,Hlep) Hpn.
apply lt_le.
assert (bb p (conj Hlimp Hlep) [>] ss k (conj Hlimk Hlek)).
unfold ss.
elim (s_b_alpha_beta k (conj Hlimk Hlek)).
intros sk (bk,(Hsk,(Hbk,H'))).
simpl; unfold bb.
elim (s_b_alpha_beta p (conj Hlimp Hlep)).
intros sp (bp,(Hsp,(Hbp,Hp'))).
simpl; unfold upper_bound in Hbp.
apply Hbp.
solve [intuition].
apply HRwgt_Zgt.
assumption.

assert (Hsn_increasing : forall n, forall Hn:std n/\0<= n, forall m, forall (Hm:std m/\0<= m),
  n <= m -> ssA n Hn <= ssA m Hm).
intros.
apply thm_Hsn_increasing with (S:=S) (Hdec:=Hdec) (s0:=s0) (b0:=b0) (Hs0:=Hs0) (Hb0S := Hup) (n:=m) (m:=n) (bbA:=bbA).
unfold ssA,ss, s_b_alpha_beta; trivial.
unfold bbA,bb, s_b_alpha_beta; trivial.
assumption.

assert (Hequal : forall n:A, forall Hn: std n /\ 0<= n,
  (HRwequal (HRwminus (bb n Hn) (ss n Hn))
                     (HRwmult (power two_third n Hn) (HRwminus b0 s0)))).
intros n Hn.
unfold bb,ss; elim (s_b_alpha_beta n Hn).
intros sn (bn, (Hsn,(Hbn,Hequaln))).
simpl.
unfold HRwminus in *.
subst.
assumption.

(* we overspill the min_bn_sup_sn using the magic function "extends" *)
assert (Hbn_sup_sn' : exists v:A, ~lim v /\ 0<v /\
  (forall k, 0 <=k /\ k<=v ->  (extends ssA) k <= (min k (extends bbA)))).
apply (overspill_principle' (fun m => extends ssA m <= min m (extends bbA))).
intros.
apply min_prop.
intros.
solve [intuition].
rewrite <- extends_id with (H:=H1).
intros.
assert (H2': std k /\ 0<=k).
solve [intuition].
rewrite <- extends_id with (H:=H2').
apply le_trans with (min_lim n bbA).
apply Hbn_sup_sn with (n:=n).
assumption.
apply le_refl.
apply min_lim_def.
assumption.
assumption.

assert (Hsn_increasing' : exists v:A,~lim v /\ 0<v /\ forall (n : A), 0 <= n /\ n<= v ->
forall (m : A), 0<=m -> m < n -> (extends ssA) m  <= (extends ssA) n).

assert (Hsn_increasing'' : exists v : A,
         ~ lim v /\
         0 < v /\
         (forall n : A,
          0 <= n /\ n <= v ->
          forall m : A, 0 <= m /\ m <= v -> m < n -> (extends ssA) m  <= (extends ssA) n)).
apply (overspill_principle2 (fun n m => m < n -> extends ssA m <= extends ssA n)).

intros.
rewrite <- (extends_id ssA n H1).
rewrite <- (extends_id ssA m H2).

apply Hsn_increasing.
apply lt_le; assumption.

destruct Hsn_increasing'' as [nv Hnv].
exists nv.
repeat split; try solve [intuition].
intros; apply Hnv; try solve [intuition].
split.
assumption.
apply le_trans with n.
apply lt_le.
assumption.
solve [intuition].

elim Hbn_sup_sn'.
intros v1 Hv1.
elim Hsn_increasing' .
intros v2 Hv2.
pose (bA:=min (minA v1 v2) (extends bbA)).
unfold has_least_upper_bound.
assert (Hb:(P bA)).
assert (Hl0:std 0/\0<=0) by (apply H0std). (*split; [apply lim0 | apply le_refl]).*)

elim (A0_dec bA). (* Meaning ? *)
intros HA0; elim HA0.
intros Hneg.
assert (ssA 0 Hl0 <= bA).
unfold bA.
decompose [and] Hv1.
rewrite (extends_id ssA).
eapply foo with (v1:=v1) (b0:=b0) (b0':=b0') (ss:=ss) (bb:=bb) (ssA:=ssA) (bbA:=bbA)(s_b_alpha_beta:=s_b_alpha_beta); try solve [intuition].
generalize (H0std).
assert (|bA|<=|ssA 0 Hl0|).
rewrite abs_neg_val.
rewrite abs_neg_val.
setoid_replace (-bA) with ((-a1)*bA) by ring.
setoid_replace (- ssA 0 Hl0) with ((-a1)*(ssA 0 Hl0)) by ring.
apply le_mult_neg.
apply lt_m1_0.
assumption.
apply le_trans with bA.
assumption.
apply lt_le; assumption.
apply lt_le; assumption.

assert (P (ssA 0 Hl0)).
replace (ssA 0 Hl0) with (proj1_sig (ss 0 Hl0)) by solve [auto].
apply HRw_P.
elim H3; intros n (Hlimn,(H0n, Hex)).
exists n.
split.
assumption.
split.
assumption.
apply le_trans with (|ssA 0 Hl0 |) ; assumption.
intros Hr; unfold P.
elim P0; intros nP0 HP0; exists nP0; rewrite Hr; solve [intuition].
intros Hpos.
unfold bA.
assert ((min (minA v1 v2) (extends bbA)) <= (extends bbA) 0).
apply min_def.
split.
apply le_refl.
apply minA_le; solve [apply lt_le; intuition].
assert (P (extends bbA 0)).

rewrite <- extends_id with (H:=Hl0) in *.
replace (bbA 0 Hl0) with (proj1_sig (bb 0 Hl0)) by solve [auto].
apply HRw_P.
elim H2; intros n (Hlimn,(H0n, Hex)).
exists n.
split.
assumption.
split.
assumption.
apply le_trans with (| extends bbA 0|).
rewrite abs_pos_val.
rewrite abs_pos_val.
assumption.
apply le_trans with (min (minA v1 v2) (extends bbA)).
apply lt_le; assumption.
assumption.
apply lt_le; assumption.
assumption.
(* ici, on a construit b et on va montrer que c'est bien la plus petite borne supérieure pour S *)
pose (b :=(exist
       (fun x0 : A => exists n1 : A, lim n1 /\ 0 < n1 /\ (|x0 |) <= n1 * w)
       bA Hb)).
exists b.

unfold least_upper_bound.
split.

intros s Hs.
assert (~ (s [>] b)).
intro Hsb.
assert (H1:exists n:A, std n /\ 0 <= n /\ forall (Hyp:std n/\0 <= n),
  (s [+] -w b) [>] ((bb n Hyp) [+] -w (ss n Hyp))). (* (1) *)
apply has_limit with (x:=(b0 [+] (-w s0))) (eps:=s [+] (-w b)).
apply HRwgt_HRwplus_inv_l with s0.
ring_simplify.
unfold upper_bound in Hup; apply Hup; assumption.
apply HRwgt_HRwplus_inv_l with b.
ring_simplify.
assumption.
assumption.

elim H1; clear H1.
intros n (Hlim,(Hlt,H1)).
generalize (H1 (conj Hlim Hlt)); clear H1; intros H1.
assert (H2:(bb n (conj Hlim Hlt) [+] -w (ss n (conj Hlim Hlt))) [>=]
        (bb n (conj Hlim Hlt) [+] -w b)). (* (2) *)
assert (b [>=] (ss n (conj Hlim Hlt))).
apply Zge_HRwge.
simpl.
replace (proj1_sig (ss n (conj Hlim Hlt))) with (ssA n (conj Hlim Hlt)) by solve [auto].
unfold bA.
rewrite extends_id with (H:=conj Hlim Hlt).
(* HHH *)
eapply foo with (v1:=v1) (b0:=b0) (b0':=b0') (ss:=ss) (bb:=bb) (ssA:=ssA) (bbA:=bbA)(s_b_alpha_beta:=s_b_alpha_beta); try solve [intuition].

assert (-w (ss n (conj Hlim Hlt)) [>=] -w b).
apply HRwge_HRwopp; assumption.

rewrite (HRwplus_comm _ (-w b)).
rewrite HRwplus_comm.
apply R2_4'; assumption.

generalize (HRwgt_HRwge_trans _ _ _ H1 H2); intros H3.
generalize (HRwgt_HRwplus_inv_r _ _ (-w b) H3); intros H4.
assert (bb n (conj Hlim Hlt) [>=] s).
unfold bb; elim (s_b_alpha_beta n (conj Hlim Hlt)).
intros sn (bn, (alphan, (betan, Hn))); simpl.
apply HRwgt_HRwge.
unfold upper_bound in *; intuition.
eapply contradict_HRwgt_HRwge ; eassumption.

apply not_HRwgt_HRwge; assumption.

intros b' Hbb'.
assert (H1:exists n:A, std n /\ 0 <= n /\ forall (Hyp:std n/\0 <= n),
  (b [+] -w b') [>] ((bb n Hyp) [+] -w (ss n Hyp))).
apply has_limit with (x:=b0 [+] (-w s0)) (eps:=b [+] (-w b')).
apply HRwgt_HRwplus_inv_l with s0.
ring_simplify.
unfold upper_bound in Hup; apply Hup; assumption.
apply HRwgt_HRwplus_inv_l with b'.
ring_simplify; assumption.
assumption.
elim H1; clear H1.
intros n (Hlim,(Hlt,H1)).
generalize (H1 (conj Hlim Hlt)); clear H1; intros H1.
assert ( (bb n (conj Hlim Hlt)) [>=] b).
apply Zge_HRwge.
change (proj1_sig b <= (bbA n (conj Hlim Hlt))).
unfold b; simpl.
assert (Hnn: (0 <=n /\ n <= minA v1 v2)).
split.
assumption.
assert (~lim (minA v1 v2)) by (apply minA_lim; solve [intuition]).
assert (nlim:lim n).
apply std_lim; assumption.
apply lt_le; apply lim_not_lim.
split; assumption.
split.
assumption.
apply minA_le; solve[apply lt_le; intuition].
rewrite extends_id.
apply (min_def (minA v1 v2) (extends bbA) n Hnn).
assert ((bb n (conj Hlim Hlt) [+] (-w (ss n (conj Hlim Hlt)))) [>=]
            (b [+] (-w (ss n (conj Hlim Hlt))))).
apply R2_4'; assumption.

assert (b [+] (-w b') [>] b [+] (-w ss n (conj Hlim Hlt))).
apply HRwgt_HRwge_trans with (bb n (conj Hlim Hlt) [+] (-w ss n (conj Hlim Hlt))); assumption.
assert ((b [+] (-w (ss n (conj Hlim Hlt)))) [+] ((ss n (conj Hlim Hlt)
           [+] (-w b'))) [>]
b [+] (-w (ss n (conj Hlim Hlt)))).
ring_simplify; unfold HRwminus.
assumption.
assert (H' : (ss n (conj Hlim Hlt) [+] (-w b')) [>] [0]).

apply HRwgt_HRwplus_inv_l with ((b [+] (-w ss n (conj Hlim Hlt)))).
rewrite (HRwplus_comm _ [0]); rewrite HRwplus_zero.
assumption.
revert H'.
unfold ss.
elim (s_b_alpha_beta n (conj Hlim Hlt)).
intros sn (bn, (Hsn,(Hbn,Hn'))).
simpl; intros H'.
exists sn.
split.
solve [intuition].
apply HRwgt_HRwplus_inv_l with (-w b').
rewrite (HRwplus_comm _ b').
rewrite HRwplus_opp.
rewrite HRwplus_comm.
assumption.
Qed.

End lub_proof.


From Hammer Require Import Hammer.

Require Import ExtLib.Core.Type.
Require Import ExtLib.Data.PreFun.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Structures.CoFunctor.
Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Global Instance proper_id (T : Type) {tT : type T} : proper (fun x => x).
Proof. hammer_hook "Fun" "Fun.proper_id".
repeat red; intros. apply H.
Qed.

Section functors.
Variable A : Type.

Instance FunFunctor A : Functor (Fun A) :=
{ fmap _A _B g f x := g (f x)
}.

Local Instance Functor_Fun : Functor (Fun A) :=
{ fmap _A _B g f x := g (f x) }.

Local Instance CoFunctor_Fun T : CoFunctor (fun x => x -> T) :=
{| cofmap := fun _ _ g f => fun x => f (g x) |}.

Local Instance Functor_functor F G (fF : Functor F) (fG : Functor G) : Functor (fun x => F (G x)) :=
{| fmap := fun _ _ g => @fmap F _ _ _ (@fmap G _ _ _ g) |}.

Local Instance CoFunctor_functor F G (fF : Functor F) (fG : CoFunctor G) : CoFunctor (fun x => F (G x)) :=
{| cofmap := fun _ _ g => @fmap F _ _ _ (@cofmap G _ _ _ g) |}.

Local Instance Functor_cofunctor F G (fF : CoFunctor F) (fG : Functor G) : CoFunctor (fun x => F (G x)) :=
{| cofmap := fun _ _ g => @cofmap F _ _ _ (@fmap G _ _ _ g) |}.

Local Instance CoFunctor_cofunctor F G (fF : CoFunctor F) (fG : CoFunctor G) : Functor (fun x => F (G x)) :=
{| fmap := fun _ _ g => @cofmap F _ _ _ (@cofmap G _ _ _ g) |}.

Local Instance Applicative_Fun : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

End functors.

Definition Monoid_compose T : Monoid (T -> T) :=
{| monoid_plus g f x := g (f x)
; monoid_unit x := x
|}.

Export PreFun.


Require Import core.Semantics.
Require Import core.Syntax.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import String.
Require Import EqNat.
Require Import List.
Require Import Expressions.
Require Import core.utils.Utils.
Require Import PeanoNat.
Require Import Lia.
Require Import FunctionalExtensionality.

(*********************************************************)
(** * Additivity in OutputPatternLink context            *)
(*********************************************************)

Fixpoint Rule_incl_patternElements {tc: TransformationConfiguration} (l1 l2: list OutputPatternElement) : Prop :=
  match l1, l2 with
  | o1 :: l1', o2 :: l2' =>
      OutputPatternElement_getName o1 = OutputPatternElement_getName o2
      /\ OutputPatternElement_getElementExpr o1 = OutputPatternElement_getElementExpr o2
      /\ (OutputPatternElement_getLinkExpr o1 = OutputPatternElement_getLinkExpr o2 \/
          OutputPatternElement_getLinkExpr o1 = (fun _ _ _ _ _ => None))
      /\ Rule_incl_patternElements l1' l2'
  | nil, nil => True
  | _, _ => False
  end.

Lemma Rule_incl_patternElements_exists:
  forall (tc: TransformationConfiguration) opes1 opes2 o1,
    Rule_incl_patternElements opes1 opes2 -> In o1 opes1 ->
      (exists o2, In o2 opes2 /\
         OutputPatternElement_getName o1 = OutputPatternElement_getName o2
      /\ OutputPatternElement_getElementExpr o1 = OutputPatternElement_getElementExpr o2
      /\ (OutputPatternElement_getLinkExpr o1 = OutputPatternElement_getLinkExpr o2 \/
          OutputPatternElement_getLinkExpr o1 = (fun _ _ _ _ _ => None)) ).
Proof.
intros.
revert H.
revert opes2.
revert H0.
induction opes1.
- contradiction.
- intros.
  simpl in H0.
  destruct H0.
  --  unfold Rule_incl_patternElements in H.
      destruct opes2.
      + contradiction.
      + exists o.
      split; crush.
  --  induction opes2.
      + unfold Rule_incl_patternElements in H.
        contradiction.
      + clear IHopes2.
        assert (Rule_incl_patternElements opes1 opes2).
        {
        unfold Rule_incl_patternElements.
        unfold Rule_incl_patternElements in H.
        crush.
        }
        specialize (IHopes1 H0 opes2 H1).
        destruct IHopes1.
        destruct H2.
        exists x.
        split; auto.
        simpl.
        right.
        auto.
Qed.

Fixpoint Transformation_incl_rules {tc: TransformationConfiguration} (l1 l2: list Rule) : Prop :=
  match l1, l2 with
  | r1 :: l1', r2 :: l2' =>
      Rule_getName r1 = Rule_getName r2
      /\ Rule_getGuardExpr r1 = Rule_getGuardExpr r2
      /\ Rule_getIteratorExpr r1 = Rule_getIteratorExpr r2
      /\ Rule_incl_patternElements (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2)
      /\ Transformation_incl_rules l1' l2'
  | nil, nil => True
  | _, _ => False
  end.

Definition Transformation_incl_links {tc: TransformationConfiguration} (t1 t2: Transformation) : Prop :=
  (Transformation_getArity t1 = Transformation_getArity t2) /\
  (Transformation_incl_rules (Transformation_getRules t1) (Transformation_getRules t2)).

Definition Model_incl {tc: TransformationConfiguration}  (m1 m2: TargetModel) : Prop :=
  incl (allModelElements m1) (allModelElements m2) /\
  incl (allModelLinks m1) (allModelLinks m2).

Lemma Transformation_incl_rules_exists:
  forall (tc: TransformationConfiguration) (rs1 rs2: list Rule) (r1: Rule),
    Transformation_incl_rules rs1 rs2 -> In r1 rs1 ->
      (exists r2, In r2 rs2 /\
         Rule_getName r1 = Rule_getName r2
      /\ Rule_getGuardExpr r1 = Rule_getGuardExpr r2
      /\ Rule_getIteratorExpr r1 = Rule_getIteratorExpr r2
      /\ Rule_incl_patternElements (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2) ).
Proof.
intros.
revert H.
revert rs2.
revert H0.
induction rs1.
- contradiction.
- intros.
  simpl in H0.
  destruct H0.
  --  unfold Transformation_incl_rules in H.
      destruct rs2.
      + contradiction.
      + exists r.
      split; crush.
  --  induction rs2.
      + unfold Transformation_incl_rules in H.
        contradiction.
      + clear IHrs2.
        assert (Transformation_incl_rules rs1 rs2).
        {
        unfold Transformation_incl_rules.
        unfold Transformation_incl_rules in H.
        crush.
        }
        specialize (IHrs1 H0 rs2 H1).
        destruct IHrs1.
        destruct H2.
        exists x.
        split; auto.
        simpl.
        right.
        auto.
Qed.

Lemma Rule_incl_patternElements_eq:
  forall  (tc: TransformationConfiguration)  x x0 sm opes1 opes2,
   Rule_incl_patternElements opes1 opes2 ->
    flat_map
  (fun o : OutputPatternElement =>
   optionToList
     (e <- evalOutputPatternElementExpr sm x x0 o;
      return buildTraceLink (x, x0, OutputPatternElement_getName o) e)) opes1 =
  flat_map
  (fun o : OutputPatternElement =>
   optionToList
     (e <- evalOutputPatternElementExpr sm x x0 o;
      return buildTraceLink (x, x0, OutputPatternElement_getName o) e)) opes2.
Proof.
intros.
revert H.
revert opes2.
induction opes1.
- intros.
  unfold Rule_incl_patternElements in H.
  destruct opes2.
  -- auto.
  -- contradiction.
- induction opes2.
  -- intros.
     unfold Rule_incl_patternElements in H.
     contradiction.
  -- clear IHopes2.
     intros.

     assert (Rule_incl_patternElements opes1 opes2). {
       unfold Rule_incl_patternElements in H.
       unfold Rule_incl_patternElements.
       crush.
     }
     specialize (IHopes1 opes2 H0).
     simpl.

     assert (optionToList
       (e <- evalOutputPatternElementExpr sm x x0 a;
       return buildTraceLink (x, x0, OutputPatternElement_getName a) e) =
        optionToList
       (e <- evalOutputPatternElementExpr sm x x0 a0;
       return buildTraceLink (x, x0, OutputPatternElement_getName a0) e)).
      {
      f_equal.
      unfold Rule_incl_patternElements in H.
      destruct H.
      destruct H1.
      clear H2.
      unfold evalOutputPatternElementExpr.
      rewrite H.
      rewrite H1.
      auto.
      }

     crush.
Qed.

Lemma matchPattern_eq:
  forall (tc: TransformationConfiguration)  t1 t2 sm x,
  Transformation_incl_links t1 t2 ->
    flat_map (fun r : Rule => traceRuleOnPattern r sm x)
      (matchPattern t1 sm x) =
    flat_map (fun r : Rule => traceRuleOnPattern r sm x)
      (matchPattern t2 sm x).
Proof.
intros.
revert H.
destruct t1 as [a1 rs1].
revert t2.
induction rs1.
- (* base case: rs1 = nil *)
  intros.
  unfold Transformation_incl_links in H.
  simpl in H.
  destruct H.
  destruct (Transformation_getRules t2) eqn: t2_res.
  -- (* case 1: rs2 = nil *)
     unfold trace.
     unfold tracePattern.
     destruct t2.
     simpl in t2_res.
     rewrite t2_res.
     simpl.
     auto.
  -- (* case 2: rs2 != nil, a contradiction w.r.t. Transformation_incl_links *)
     contradiction.
- intro.
  destruct t2 as [a2 rs2].
  induction rs2.
  -- (* base case: rs2 = nil, a contradiction w.r.t. Transformation_incl_links *)
     intro.
     unfold Transformation_incl_links in H.
     simpl in H.
     destruct H.
     contradiction.
  -- specialize (IHrs1 (buildTransformation a2 rs2)).
     intros.
     assert (Transformation_incl_links (buildTransformation a1 rs1)
              (buildTransformation a2 rs2) ).  (* derived from H *)
     {
      unfold Transformation_incl_links in H.
      unfold Transformation_incl_links.
      crush.
     }

     specialize (IHrs1 H0).
      clear IHrs2.

      unfold Transformation_incl_links in H.
      simpl in H.
      destruct H.
      destruct H1.
      destruct H2.
      destruct H3.
      destruct H4.

      unfold matchPattern.
      simpl.

      destruct (matchRuleOnPattern a sm x) eqn: ca1.
      + destruct (matchRuleOnPattern a0 sm x) eqn: ca2.
        ++ simpl.
      assert (traceRuleOnPattern a sm x = traceRuleOnPattern a0 sm x).
      { unfold traceRuleOnPattern.
        unfold evalIteratorExpr.
        rewrite H3.
        unfold traceIterationOnPattern, traceElementOnPattern, instantiateElementOnPattern.

        f_equal.
        apply functional_extensionality.
        intros.

        remember  (Rule_getOutputPatternElements a) as opes1.
        remember  (Rule_getOutputPatternElements a0) as opes2.

        apply Rule_incl_patternElements_eq.
        auto.
       }
      rewrite H6.
      assert (flat_map (fun r : Rule => traceRuleOnPattern r sm x)
        (filter (fun r : Rule => matchRuleOnPattern r sm x) rs1) =
      flat_map (fun r : Rule => traceRuleOnPattern r sm x)
        (filter (fun r : Rule => matchRuleOnPattern r sm x) rs2)).
      {  unfold matchPattern in IHrs1. simpl in IHrs1. auto. }
      rewrite H7.
      auto.
        ++ unfold matchRuleOnPattern in ca2.
           unfold evalGuardExpr in ca2.
           rewrite <- H2 in ca2.
           unfold matchRuleOnPattern in ca1.
           unfold evalGuardExpr in ca1.
           crush. (* contradiction in ca1 and ca2 *)
      + destruct (matchRuleOnPattern a0 sm x) eqn: ca2.
        ++ unfold matchRuleOnPattern in ca2.
           unfold evalGuardExpr in ca2.
           rewrite <- H2 in ca2.
           unfold matchRuleOnPattern in ca1.
           unfold evalGuardExpr in ca1.
           crush. (* contradiction in ca1 and ca2 *)
        ++ unfold matchPattern in IHrs1.
           simpl in IHrs1.
           auto.
Qed.

Lemma trace_eq:
  forall (tc: TransformationConfiguration)  t1 t2 sm,
  Transformation_incl_links t1 t2 ->
    (trace t1 sm) = (trace t2 sm).
Proof.
intros.
revert H.
destruct t1 as [a1 rs1].
revert t2.
induction rs1.
- (* base case: rs1 = nil *)
  intros.
  unfold Transformation_incl_links in H.
  simpl in H.
  destruct H.
  destruct (Transformation_getRules t2) eqn: t2_res.
  -- (* case 1: rs2 = nil *)
     unfold trace.
     unfold tracePattern.
     destruct t2.
     simpl in t2_res.
     rewrite t2_res.
     simpl.
     unfold allTuples.
     unfold maxArity.
     simpl.
     simpl in H.
     rewrite H.
     auto.
  -- (* case 2: rs2 != nil, a contradiction w.r.t. Transformation_incl_links *)
     contradiction.
- (* inductive case: rs1 *)
  intro.
  destruct t2 as [a2 rs2].
  induction rs2.
  -- (* base case: rs2 = nil, a contradiction w.r.t. Transformation_incl_links *)
     intro.
     unfold Transformation_incl_links in H.
     simpl in H.
     destruct H.
     contradiction.
  -- (* inductive case: rs2 = nil *)
     specialize (IHrs1 (buildTransformation a2 rs2)).
     intros.

     assert (Transformation_incl_links (buildTransformation a1 rs1)
              (buildTransformation a2 rs2) ).  (* derived from H *)
     {
      unfold Transformation_incl_links in H.
      unfold Transformation_incl_links.
      crush.
     }

     specialize (IHrs1 H0).
     unfold trace, tracePattern.
     f_equal.
     + (* traceRuleOnPattern on matchPattern of t1 and t2 are the same *)
       apply functional_extensionality.
       intros.
       apply matchPattern_eq.
       auto.
     + (* allTuples of t1 and t2 are the same *)
       unfold allTuples.
       simpl.
       unfold Transformation_incl_links in H0.
       destruct H0.
       simpl in H0.
       rewrite H0.
       auto.
Qed.

Theorem additivity_links:
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  (Transformation_incl_links t1 t2 ->
    Model_incl (execute t1 sm) (execute t2 sm)).
Proof.
  simpl.
  unfold Model_incl.
  unfold incl.
  unfold Transformation_incl_links.
intros.
split.
- intro.
  simpl.
  destruct H.
  intros.
  apply in_flat_map in H1 as [sp].
  destruct H1.
  apply in_flat_map in H2 as [r1].
  destruct H2.
  apply in_flat_map in H3 as [iter1].
  destruct H3.
  apply in_flat_map in H4 as [ope].
  destruct H4.
  unfold instantiateElementOnPattern in H5.
  destruct (evalOutputPatternElementExpr sm sp iter1 ope) eqn: outExpr.
  + simpl in H5.
    destruct H5.
    ++ apply in_flat_map.
exists sp.
assert ((allTuples t1 sm) = (allTuples t2 sm)) as allTup. {
  unfold allTuples.
  unfold maxArity.
  rewrite H.
  auto.
}
split.
+++ rewrite <- allTup. exact H1.
+++ apply in_flat_map.
    specialize (Transformation_incl_rules_exists tc (Transformation_getRules t1) (Transformation_getRules t2) r1 H0).
    intros.
    assert (In r1 (Transformation_getRules t1)). { unfold matchPattern in H2. apply filter_In in H2. destruct H2. exact H2. }
    specialize (H6 H7).
    repeat destruct H6.
    destruct H8.
    destruct H8.
    rename x into r2.
    exists r2.
    split.
    ++++  unfold matchPattern in H2.
          apply filter_In in H2.
          unfold matchPattern.
          apply filter_In.
          split.
          * auto.
          * destruct H2.
            unfold matchRuleOnPattern, evalGuardExpr.
          unfold matchRuleOnPattern, evalGuardExpr in H8.
          destruct H9.
          rewrite <- H9.
          auto.
    ++++  apply in_flat_map.
          exists iter1.
          split.
          +++++ unfold evalIteratorExpr.
                unfold evalIteratorExpr in H3.
                destruct H9.
                destruct H9.
                rewrite <- H9.
                auto.
          +++++ unfold instantiateIterationOnPattern.
                unfold instantiateElementOnPattern.
                assert (exists ope2, In ope2 (Rule_getOutputPatternElements r2) /\ evalOutputPatternElementExpr sm sp iter1 ope2 = return a).
                {
                destruct H9.
                destruct H9.
                specialize Rule_incl_patternElements_exists.
                intros.
                specialize (H11 tc (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2)).
                specialize (H11 ope H10 H4).
                destruct H11.
                destruct H11.
                destruct H12.
                destruct H13.
                clear H14.
                exists x.
                split; auto.
                unfold evalOutputPatternElementExpr.
                unfold evalOutputPatternElementExpr in outExpr.
                rewrite <- H13.
                rewrite <- H5.
                auto.
                }
                destruct H8.
                apply in_flat_map.
                exists x.
                split.
                * destruct H8.
                  auto.
                * destruct H8.
                rewrite H10.
                simpl.
                left.
                auto.
    ++ contradiction.
  + contradiction.
- intro.
  simpl.
  destruct H.
  intros.
  apply in_flat_map in H1 as [sp].
  destruct H1.
  apply in_flat_map in H2 as [r1].
  destruct H2.
  apply in_flat_map in H3 as [iter1].
  destruct H3.
  apply in_flat_map in H4 as [ope].
  destruct H4.
  unfold applyElementOnPattern in H5.
  destruct (evalOutputPatternElementExpr sm sp iter1 ope) eqn: outExpr.
  + destruct (evalOutputPatternLinkExpr sm sp t iter1 (trace t1 sm) ope) eqn: linkExpr.
    ++ simpl in H5.
       apply in_flat_map.
       exists sp.
       assert ((allTuples t1 sm) = (allTuples t2 sm)) as allTup. {
        unfold allTuples.
        unfold maxArity.
        rewrite H.
        auto.
       }
       split.
       +++  rewrite <- allTup. exact H1.
       +++  apply in_flat_map.
            specialize (Transformation_incl_rules_exists tc (Transformation_getRules t1) (Transformation_getRules t2) r1 H0).
            intros.
            assert (In r1 (Transformation_getRules t1)). { unfold matchPattern in H2. apply filter_In in H2. destruct H2. exact H2. }
            specialize (H6 H7).
            repeat destruct H6.
            destruct H8.
            destruct H8.
            rename x into r2.
            exists r2.
            split.
            ++++  unfold matchPattern in H2.
                  apply filter_In in H2.
                  unfold matchPattern.
                  apply filter_In.
                  split.
                  * auto.
                  * destruct H2.
                    unfold matchRuleOnPattern, evalGuardExpr.
                  unfold matchRuleOnPattern, evalGuardExpr in H8.
                  destruct H9.
                  rewrite <- H9.
                  auto.
            ++++  apply in_flat_map.
                  exists iter1.
                  split.
                  +++++ unfold evalIteratorExpr.
                        unfold evalIteratorExpr in H3.
                        destruct H9.
                        destruct H9.
                        rewrite <- H9.
                        auto.
                  +++++ assert ((trace t1 sm) = (trace t2 sm)).
                        {
                          apply trace_eq.
                          unfold Transformation_incl_links; auto.
                        }
                        unfold applyIterationOnPattern.
                        unfold applyElementOnPattern.
                        assert (exists ope2, In ope2 (Rule_getOutputPatternElements r2) /\
                                  evalOutputPatternElementExpr sm sp iter1 ope2 = return t /\
                                  evalOutputPatternLinkExpr sm sp t iter1 (trace t1 sm) ope2 = return l).
                        {
                        destruct H9.
                        destruct H9.
                        destruct H10.
                        specialize Rule_incl_patternElements_exists.
                        intros.
                        specialize (H11 tc (Rule_getOutputPatternElements r1) (Rule_getOutputPatternElements r2)).
                        specialize (H11 ope H10 H4).
                        destruct H11.
                        destruct H11.
                        destruct H12.
                        destruct H13.
                        exists x.
                        split; auto.
                        split.
                        * unfold evalOutputPatternElementExpr.
                          unfold evalOutputPatternElementExpr in outExpr.
                          rewrite <- H13.
                          auto.
                        * unfold evalOutputPatternLinkExpr.
                        unfold evalOutputPatternLinkExpr in linkExpr.
                        destruct H14.
                        ** rewrite <- H14.
                           auto.
                        ** rewrite H14 in linkExpr.
                        unfold evalExpr in linkExpr.
                        inversion linkExpr.
                        }
                        destruct H10.
                        apply in_flat_map.
                        exists x.
                        split.
                        * destruct H10.
                          auto.
                        * destruct H10.
                          destruct H11.
                          rewrite H11.
                          rewrite <- H8.
                          rewrite H12.
                          simpl.
                          exact H5.
    ++ contradiction.
  + contradiction.
Qed.

(*********************************************************)
(** * Additivity in OutputPatternLink context            *)
(** * Inductive Definitions                              *)
(*********************************************************)

Inductive Rule_incl_patternElements' {tc: TransformationConfiguration} : list OutputPatternElement -> list OutputPatternElement -> Prop :=
  | incl_e_nil : Rule_incl_patternElements' nil nil
  | incl_e_diff : forall x y xs ys, Rule_incl_patternElements' xs ys
    -> OutputPatternElement_getName x = OutputPatternElement_getName y
    -> OutputPatternElement_getElementExpr x = OutputPatternElement_getElementExpr y
    -> (OutputPatternElement_getLinkExpr x = OutputPatternElement_getLinkExpr y \/
        OutputPatternElement_getLinkExpr x = (fun _ _ _ _ _ => None))
    -> Rule_incl_patternElements' (x::xs) (y::ys).

Inductive Transformation_incl_rules' {tc: TransformationConfiguration} : list Rule -> list Rule -> Prop :=
  | incl_rules_nil : Transformation_incl_rules' nil nil
  | incl_rules_diff : forall x y xs ys, Transformation_incl_rules' xs ys
    -> Rule_getName x = Rule_getName y
    -> Rule_getGuardExpr x = Rule_getGuardExpr y
    -> Rule_getIteratorExpr x = Rule_getIteratorExpr y
    -> Rule_incl_patternElements' (Rule_getOutputPatternElements x) (Rule_getOutputPatternElements y)
    -> Transformation_incl_rules' (x::xs) (y::ys).

Definition Transformation_incl_links' {tc: TransformationConfiguration} (t1 t2: Transformation) : Prop :=
  (Transformation_getArity t1 = Transformation_getArity t2) /\
  (Transformation_incl_rules' (Transformation_getRules t1) (Transformation_getRules t2)).

Lemma tr_incl_equiv:
  forall (tc: TransformationConfiguration) t1 t2,
    Transformation_incl_links' t1 t2 -> Transformation_incl_links t1 t2.
Proof.
intros.
destruct  H.
unfold Transformation_incl_links.
split.
* auto.
*
  induction H0.
  ** unfold Transformation_incl_rules. auto.
  ** simpl. repeat split; auto.
     induction H4.
     - unfold Rule_incl_patternElements. auto.
     - simpl. repeat split; auto.
Qed.

Theorem additivity_links' :
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  (Transformation_incl_links' t1 t2 ->
    Model_incl (execute t1 sm) (execute t2 sm)).
Proof.
intros.
specialize (tr_incl_equiv tc t1 t2 H).
specialize (additivity_links tc t1 t2).
auto.
Qed.