(******************************************************************************)
(** * 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_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 H 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.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C IB XB IA X : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ IB B /\ (wd_ IA A /\ (wd_ XB B /\ (col_ B A IA /\ (col_ IA A C /\ (col_ B X A /\ (col_ XB X B /\ (col_ B B C /\ (col_ A XB C /\ col_ B XB IB)))))))))))) -> col_ B A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import PeanoNat tools algebra Bool relations.
Require Import bsp_terms pomsets bsp_pomsets.
(* Require Import series_parallel_pomsets. *)

Section s.
  Context {X : Set}.
  Context {decX : decidable_set X}.
  Section sub_pomsets.
    Context {P : Pomset X} {D : list ⌊P⌋}.

    Definition sub_pom_box := (fun b => existsb (fun b' => equivalentb b' (map (𝒯l {{D}}) b))
                                             (Boxes P))
                                :> 𝒫 (𝒯 {{D}}).

    Lemma sub_pom_box_spec b :
      b ∈ sub_pom_box <-> b ∈ 𝒫 (𝒯 {{D}}) /\ exists a, a ∈ Boxes P /\ a ≈ map (𝒯l {{D}}) b.
    Proof.
      unfold sub_pom_box.
      setoid_rewrite filter_In.
      setoid_rewrite existsb_exists.
      setoid_rewrite equivalentb_spec.
      reflexivity.
    Qed.

    Lemma sub_pom_list_incl b : map (𝒯l {{D}}) b ⊆ D.
    Proof.
      intros x Ix;apply in_map_iff in Ix as (y&<-&Iy).
      apply undup_equivalent,translation_internal.
    Qed.

    Lemma sub_pom_hnil : ~ [] ∈ sub_pom_box.
    Proof.
      rewrite sub_pom_box_spec.
      intros (_&(x&h&E)).
      destruct x as [|a x];[|cut (a∈[]);[simpl;tauto|apply E;now left]].
      simpl in *;eapply Pomset_hnil,h.
    Qed.

    Definition sub_pom : Pomset X.
    Proof.
      apply (@Build_Pomset X (𝒯{{D}}) (fun x => ℓ (𝒯e x)) (fun x y => 𝒯e x ≤[P] 𝒯e y)
                           sub_pom_box).
      - split;intro;intros;simpl.
        + reflexivity.
        + etransitivity;eassumption.
        + now apply (@is_injective _ _ _(translation_injective
                                           (NoDup_undup _))),antisymmetry.
      - apply sub_pom_hnil.
    Defined.

    Corollary sub_pom_Boxes b :
      b ∈ Boxes sub_pom <-> b ∈ 𝒫 (PomType sub_pom)
                          /\ exists a, a ∈ Boxes P /\ a ≈ map (𝒯l {{D}}) b.
    Proof. apply sub_pom_box_spec. Qed.

    Lemma sub_pom_invert_list b :
      b ⊆ D -> exists b' : list ⌊ sub_pom ⌋ , map (𝒯l {{D}}) b' = b .
    Proof.
      induction b.
      - intros _;exists [];reflexivity.
      - intros I;destruct IHb as (b'&<-);[intros ? ?;apply I;now right|].
        assert (Ia : a ∈ {{D}}) by (apply undup_equivalent,I;now left).
        destruct (translation_total Ia) as (a'&<-).
        exists (a'::b');simpl;reflexivity.
    Qed.

    Lemma sub_pom_invert_boxes b :
      b ∈ Boxes P -> b ⊆ D ->
      exists b' : list ⌊ sub_pom ⌋ , b' ∈ Boxes sub_pom /\ map (𝒯l {{D}}) b' ≈ b .
    Proof.
      intros Ib Incl.
      destruct (sub_pom_invert_list _ Incl) as (b'&<-).
      destruct (𝒫_spec b') as (b&Ib'&Eb).
      setoid_rewrite Eb;exists b;split;[|reflexivity].
      apply sub_pom_box_spec;split;[assumption|].
      setoid_rewrite <- Eb;eexists;split;[eassumption|reflexivity].
    Qed.

    Lemma sub_pom_T_internal (a : ⌊sub_pom⌋) : 𝒯e a ∈ D.
    Proof. apply undup_equivalent,translation_internal. Qed.

    Global Instance sub_pom_T_injective : injective (𝒯l {{D}}).
    Proof. apply translation_injective,NoDup_undup. Qed.

    Lemma sub_pom_T_invert a : a ∈ D -> {b : ⌊sub_pom⌋ | 𝒯e b = a}.
    Proof. intros I;apply translation_invert,undup_equivalent,I. Qed.

  End sub_pomsets.
  Arguments sub_pom : clear implicits.
  Infix " ⇂ " := sub_pom (at level 20).
  Arguments sub_pom_box : clear implicits.

  Lemma sub_pom_make_fun_expl P Q l m f :
    map f l ⊆ m -> forall x: ⌊P⇂l⌋, {y :⌊Q⇂m⌋ | 𝒯e y = f (𝒯e x)}.
  Proof.
    intro hyp.
    intros x.
    assert (Ix : f (𝒯e x) ∈ m)
      by (apply hyp,in_map_iff;exists (𝒯e x);split;
          [reflexivity|apply sub_pom_T_internal]).
    apply sub_pom_T_invert in Ix as (y&Iy).
    exists y;assumption.
  Qed.

  Definition sub_pom_lift_fun P Q l f (x : ⌊P⇂l⌋) : {y :⌊Q⇂(map f l)⌋ | 𝒯e y = f (𝒯e x)}.
  Proof. apply (sub_pom_make_fun_expl P Q l (map f l) f);reflexivity. Qed.

  Lemma sub_pom_make_fun P Q l m f :
    map f l ⊆ m -> exists g : ⌊P⇂l⌋ -> ⌊Q⇂m⌋ , forall x, 𝒯e (g x) = f (𝒯e x).
  Proof.
    intro hyp.
    pose proof (sub_pom_make_fun_expl P Q l m f hyp) as G.
    exists (fun x => proj1_sig (G x)).
    intros x;destruct (G x) as (y&hy);apply hy.
  Qed.

  Global Instance sub_pom_proper P :
    Proper (@equivalent _ ==> sequiv) (sub_pom P).
  Proof.
    intros l m E.
    destruct (@sub_pom_make_fun P P m l id) as (f&h__f);[rewrite map_id,E;reflexivity|].
    destruct (@sub_pom_make_fun P P l m id) as (g&h__g);[rewrite map_id,E;reflexivity|].
    unfold id in *;simpl in *.
    unfold id in h__f;simpl in h__f.
    exists f;split.
    - apply bijective_inverse_iff;exists g;split;intro a;
        apply is_injective;rewrite h__g,h__f||rewrite h__f,h__g;reflexivity.
    - intro a;simpl.
      rewrite h__f;reflexivity.
    - intros a b;simpl.
      rewrite h__f,h__f;reflexivity.
    - split;intros b Ib.
      + apply in_map_iff in Ib as (c&<-&Ic).
        apply sub_pom_Boxes in Ic as (Ic&b&Ib&Eb).
        destruct (𝒫_spec (map f c)) as (b'&Ib'&Eb').
        setoid_rewrite Eb'.
        exists b';split;[|reflexivity].
        apply sub_pom_Boxes;split;[assumption|].
        exists b;split;[assumption|].
        rewrite Eb,<-Eb',map_map.
        erewrite <- map_ext;[reflexivity|apply h__f].
      + apply sub_pom_Boxes in Ib as (Ib&b'&Ib'&Eb').
        destruct (𝒫_spec (map g b)) as (b''&Ib''&Eb'').
        exists (map f b'');split.
        * apply in_map_iff;exists b'';split;[reflexivity|].
          apply sub_pom_Boxes;split;[assumption|].
          exists b';split;[assumption|].
          rewrite Eb',<-Eb'',map_map.
          erewrite <- map_ext;[reflexivity|apply h__g].
        * rewrite <-Eb'',map_map.
          erewrite map_ext,map_id;[reflexivity|].
          intro a;apply is_injective;rewrite h__f,h__g;reflexivity.
  Qed.
  Lemma sub_pom_nil P : P ⇂ [] ≃ 𝟭.
  Proof.
    apply size_0_eq_unit.
    unfold sub_pom,size,sizePomset;reflexivity.
  Qed.

  Lemma sub_pom_full P : P ⇂ ⟪PomType P⟫ ≃ P.
  Proof.
    symmetry;exists (𝒯l {{⟪PomType P⟫}}).
    assert (B: bijective (𝒯l {{⟪PomType P⟫}})).
    - split;split;[apply is_injective|].
      intro y;apply translation_total,undup_equivalent;auto.
    - split.
      + assumption.
      + intro a;reflexivity.
      + intros a b;reflexivity.
      + split.
        * intros x Ib.
          apply in_map_iff in Ib as (b&<-&Ib).
          apply sub_pom_Boxes in Ib as (Ib&b'&Ib'&E).
          exists b';split;[|symmetry];tauto.
        * intros b Ib.
          destruct (sub_pom_invert_boxes _ Ib (@domain_incl _ _)) as (b'&Ib'&E).
          exists (map (𝒯l {{⟪ PomType P ⟫}}) b');split;[|symmetry;assumption].
          apply in_map_iff;exists b';tauto.
  Qed.

  Class Embedding (P Q : Pomset X) inclusion_map :=
    {
      Embedding_inj :> injective inclusion_map;
      Embedding_lbl : forall a, ℓ (inclusion_map a) = ℓ a;
      Embedding_ord : forall a a', a ≤[ P] a' <-> inclusion_map a ≤[ Q] inclusion_map a';
      Embedding_box : forall b, [b] ≲ Boxes P <-> [map inclusion_map b] ≲ Boxes Q
    }.

  Global Instance Embedding_id P : Embedding P P id.
  Proof.
    split.
    - split;unfold id;tauto.
    - reflexivity.
    - reflexivity.
    - intro;rewrite map_id;reflexivity.
  Qed.

  Global Instance Embedding_iso P Q (ϕ : ⌊P⌋ -> ⌊Q⌋) : isomorphism ϕ -> Embedding P Q ϕ.
  Proof.
    intros Iso;split.
    - apply Iso.
    - apply Iso.
    - apply Iso.
    - pose proof (@iso_Boxes _ _ _ _ Iso) as EB.
      intro;rewrite <- EB.
      split.
      + intros h ? [<-|F];[|exfalso;tauto].
        destruct (h b) as (b'&Ib'&Eb');[now left|].
        exists (map ϕ b');split;[|rewrite Eb';reflexivity].
        apply in_map_iff;exists b';tauto.
      + intros h ? [<-|F];[|exfalso;tauto].
        destruct (h (map ϕ b)) as (b''&Ib'&Eb');[now left|].
        apply in_map_iff in Ib' as (b'&<-&Ib').
        exists b';split;[assumption|].
        erewrite <- map_id,map_ext,<-map_map,<-Eb',map_map,map_ext,map_id.
        * reflexivity.
        * simpl;apply inverse_elim1.
        * intro;symmetry;apply inverse_elim1.
  Qed.

  Global Instance Embedding_compose P Q R f g :
    Embedding P Q f -> Embedding Q R g -> Embedding P R (g∘f).
  Proof.
    intros E1 E2.
    unfold Basics.compose;split.
    - apply injective_compose;apply Embedding_inj.
    - intros;repeat rewrite Embedding_lbl;reflexivity.
    - intros;repeat rewrite <- Embedding_ord;reflexivity.
    - intros;rewrite <- map_map;repeat rewrite <-Embedding_box.
      reflexivity.
  Qed.

  Lemma Embedding_is_sub_pom P Q ι : Embedding P Q ι -> P ≃ Q ⇂ (map ι ⟪PomType P⟫).
  Proof.
    intros Emb.
    rewrite <- sub_pom_full at 1.
    destruct (@sub_pom_make_fun P Q ⟪PomType P⟫ (map ι ⟪PomType P⟫) ι)
      as (f&h__f);[reflexivity|].
    symmetry;exists f;split.
    - split;split.
      + intros x y E.
        apply (@is_injective _ _ (𝒯l _));[typeclasses eauto|].
        apply Embedding_inj.
        rewrite <- h__f,E,h__f;reflexivity.
      + intros y.
        pose proof (sub_pom_T_internal y) as Iy.
        apply in_map_iff in Iy as (x'&Ex&Ix).
        apply sub_pom_T_invert in Ix as (x&<-).
        exists x;rewrite <- h__f in Ex;apply is_injective in Ex;assumption.
    - intros a;simpl.
      rewrite h__f,Embedding_lbl;reflexivity.
    - intros a b;simpl.
      rewrite h__f,h__f,Embedding_ord;reflexivity.
    - split;intros b Ib.
      + apply in_map_iff in Ib as (b'&<-&Eb').
        apply sub_pom_Boxes in Eb' as (Ib'&b&Ib&Eb).
        assert (I : [b] ≲ Boxes P)
          by (intros ? [<-|F];[exists b;split;[assumption|reflexivity]
                                |exfalso;apply F]).
        apply Embedding_box in I as (β&Iβ&Eβ);[now left|].
        assert (hβ : β ⊆ map ι ⟪ PomType P ⟫)
          by (rewrite <- Eβ,<-domain_incl;reflexivity).
        apply (sub_pom_invert_boxes _ Iβ) in hβ as (α&Iα&Eα).
        exists α;split;[assumption|].
        rewrite <- Eβ,Eb,map_map in Eα.
        erewrite <- (map_ext _ _ h__f) in Eα.
        intro a;transitivity (𝒯e a ∈ map (𝒯l {{map ι ⟪ PomType P ⟫}}) α).
        * rewrite Eα;split;intros I;apply in_map_iff in I as (x&Ex&Ix);
            apply in_map_iff.
          -- subst;exists x;tauto.
          -- apply is_injective in Ex as <-.
             exists x;tauto.
        * split;intros I.
          -- apply in_map_iff in I as (x&Ex&Ix).
             apply is_injective in Ex as ->;assumption.
          -- apply in_map_iff;exists a;auto.
      + apply sub_pom_Boxes in Ib as (Ib&b'&Ib'&Eb').
        assert (IIb' : b' ⊆ map ι ⟪PomType P⟫).
        * rewrite Eb'.
          intros a Ia;apply in_map_iff in Ia as (a'&<-&Ia').
          apply sub_pom_T_internal.
        * apply incl_map in IIb' as (c&->&_).
          assert (I : [map ι c] ≲ Boxes Q)
            by (intros ? [<-|F];[exists (map ι c);split;[assumption|reflexivity]
                                  |exfalso;apply F]).
          apply Embedding_box in I as (β&Iβ&Eβ);[now left|].
          destruct (sub_pom_invert_boxes _ Iβ (@domain_incl _ _)) as (γ&Iγ&Eγ).
          exists (map f γ);split;[apply in_map_iff;exists γ;tauto|].
          rewrite Eβ,<-Eγ,map_map in Eb'.
          erewrite <- map_ext in Eb' by apply h__f.
          intro a;transitivity (𝒯e a ∈ map (𝒯l {{map ι ⟪ PomType P ⟫}}) b).
          -- split;intros I.
             ++ apply in_map_iff;exists a;auto.
             ++ apply in_map_iff in I as (x&Ex&Ix).
                apply is_injective in Ex as ->;assumption.
          -- rewrite <- Eb';split;intros I;apply in_map_iff in I as (x&Ex&Ix);
               apply in_map_iff.
             ++ apply is_injective in Ex as <-.
                exists x;tauto.
             ++ subst;exists x;tauto.
  Qed.

  Lemma sub_pom_Embedding P l : Embedding (P⇂l) P (𝒯l {{l}}).
  Proof.
    split.
    - typeclasses eauto.
    - intro;reflexivity.
    - intros;reflexivity.
    - intros b;split;intros I ? [<-|F];try (exfalso;apply F).
      + destruct (I b) as (b'&Ib'&Eb');[now left|].
        apply sub_pom_Boxes in Ib' as (Ib'&β&Iβ&Eβ).
        exists β;split;[assumption|].
        rewrite Eb',Eβ;reflexivity.
      + destruct (I (map (𝒯l {{l}}) b)) as (b'&Ib'&Eb');[now left|].
        cut (b' ⊆ l).
        * intros h;apply (sub_pom_invert_boxes _ Ib') in h as (β&Iβ&Eβ).
          exists β;split;[assumption|].
          rewrite <- Eb' in Eβ.
          intro a;transitivity (𝒯e a ∈ (map (𝒯l {{l}}) β));[rewrite Eβ|symmetry];
            (split;[intro;apply in_map_iff;exists a;tauto
                   |intro Ia;apply in_map_iff in Ia as (x&Ex&Ix);
                    apply is_injective in Ex as ->;assumption]).
        * intros a Ia;apply Eb',in_map_iff in Ia as (x&<-&Ix).
          apply sub_pom_T_internal.
  Qed.

  Global Instance Embedding_seq_l P Q : Embedding P (P⋅Q) inl.
  Proof.
    split.
    - split;intros x y E;inversion E;reflexivity.
    - intro a;reflexivity.
    - intros a b;reflexivity.
    - intros b;split;intros h ? [<-|F];try (exfalso;apply F).
      + destruct (h b) as (b'&Ib'&Eb');[now left|].
        exists (map inl b');split;[|rewrite Eb';reflexivity].
        apply in_app_iff;left;apply in_map_iff;exists b';tauto.
      + destruct (h (map inl b)) as (b'&Ib'&Eb');[now left|].
        apply in_app_iff in Ib' as [Ib'|Ib'];apply in_map_iff in Ib' as (b''&<-&Ib'').
        * exists b'';split;auto.
          intros a;transitivity (@inl _ ⌊Q⌋ a ∈ map inl b);[symmetry|rewrite Eb'];
            (split;intros I;[apply in_map_iff in I as (x&E&Ix);inversion E;subst;assumption
                            |apply in_map_iff;exists a;tauto]).
        * exfalso.
          destruct b'' as [|e b''];[eapply Pomset_hnil,Ib''|].
          cut (@inr ⌊P⌋ _ e ∈ map inr (e::b''));[|now left].
          rewrite <- Eb';intros F;apply in_map_iff in F as (y&F&_);discriminate.
  Qed.

  Global Instance Embedding_seq_r P Q : Embedding Q (P⋅Q) inr.
  Proof.
    split.
    - split;intros x y E;inversion E;reflexivity.
    - intro a;reflexivity.
    - intros a b;reflexivity.
    - intros b;split;intros h ? [<-|F];try (exfalso;apply F).
      + destruct (h b) as (b'&Ib'&Eb');[now left|].
        exists (map inr b');split;[|rewrite Eb';reflexivity].
        apply in_app_iff;right;apply in_map_iff;exists b';tauto.
      + destruct (h (map inr b)) as (b'&Ib'&Eb');[now left|].
        apply in_app_iff in Ib' as [Ib'|Ib'];apply in_map_iff in Ib' as (b''&<-&Ib'').
        * exfalso.
          destruct b'' as [|e b''];[eapply Pomset_hnil,Ib''|].
          cut (@inl _ ⌊Q⌋ e ∈ map inl (e::b''));[|now left].
          rewrite <- Eb';intros F;apply in_map_iff in F as (y&F&_);discriminate.
        * exists b'';split;auto.
          intros a;transitivity (@inr ⌊P⌋ _ a ∈ map inr b);[symmetry|rewrite Eb'];
            (split;intros I;[apply in_map_iff in I as (x&E&Ix);inversion E;subst;assumption
                            |apply in_map_iff;exists a;tauto]).
  Qed.

  Global Instance Embedding_par_l P Q : Embedding P (P∥Q) inl.
  Proof.
    split.
    - split;intros x y E;inversion E;reflexivity.
    - intro a;reflexivity.
    - intros a b;reflexivity.
    - intros b;split;intros h ? [<-|F];try (exfalso;apply F).
      + destruct (h b) as (b'&Ib'&Eb');[now left|].
        exists (map inl b');split;[|rewrite Eb';reflexivity].
        apply in_app_iff;left;apply in_map_iff;exists b';tauto.
      + destruct (h (map inl b)) as (b'&Ib'&Eb');[now left|].
        apply in_app_iff in Ib' as [Ib'|Ib'];apply in_map_iff in Ib' as (b''&<-&Ib'').
        * exists b'';split;auto.
          intros a;transitivity (@inl _ ⌊Q⌋ a ∈ map inl b);[symmetry|rewrite Eb'];
            (split;intros I;[apply in_map_iff in I as (x&E&Ix);inversion E;subst;assumption
                            |apply in_map_iff;exists a;tauto]).
        * exfalso.
          destruct b'' as [|e b''];[eapply Pomset_hnil,Ib''|].
          cut (@inr ⌊P⌋ _ e ∈ map inr (e::b''));[|now left].
          rewrite <- Eb';intros F;apply in_map_iff in F as (y&F&_);discriminate.
  Qed.

  Global Instance Embedding_par_r P Q : Embedding Q (P∥Q) inr.
  Proof.
    split.
    - split;intros x y E;inversion E;reflexivity.
    - intro a;reflexivity.
    - intros a b;reflexivity.
    - intros b;split;intros h ? [<-|F];try (exfalso;apply F).
      + destruct (h b) as (b'&Ib'&Eb');[now left|].
        exists (map inr b');split;[|rewrite Eb';reflexivity].
        apply in_app_iff;right;apply in_map_iff;exists b';tauto.
      + destruct (h (map inr b)) as (b'&Ib'&Eb');[now left|].
        apply in_app_iff in Ib' as [Ib'|Ib'];apply in_map_iff in Ib' as (b''&<-&Ib'').
        * exfalso.
          destruct b'' as [|e b''];[eapply Pomset_hnil,Ib''|].
          cut (@inl _ ⌊Q⌋ e ∈ map inl (e::b''));[|now left].
          rewrite <- Eb';intros F;apply in_map_iff in F as (y&F&_);discriminate.
        * exists b'';split;auto.
          intros a;transitivity (@inr ⌊P⌋ _ a ∈ map inr b);[symmetry|rewrite Eb'];
            (split;intros I;[apply in_map_iff in I as (x&E&Ix);inversion E;subst;assumption
                            |apply in_map_iff;exists a;tauto]).
  Qed.

  Global Instance Embedding_bsp_seq_l s t : Embedding ⟦s⟧ ⟦s⋅t⟧ inl.
  Proof. apply Embedding_seq_l. Qed.

  Global Instance Embedding_bsp_seq_r s t : Embedding ⟦t⟧ ⟦s⋅t⟧ inr.
  Proof. apply Embedding_seq_r. Qed.

  Global Instance Embedding_bsp_par_l s t : Embedding ⟦s⟧ ⟦s∥t⟧ inl.
  Proof. apply Embedding_par_l. Qed.

  Global Instance Embedding_bsp_par_r s t : Embedding ⟦t⟧ ⟦s∥t⟧ inr.
  Proof. apply Embedding_par_r. Qed.

  Definition embedded : relation (Pomset X) := fun P Q => exists f, Embedding P Q f.

  Infix " ⫇ " := embedded (at level 80).

  Global Instance embedded_PreOrder : PreOrder embedded.
  Proof.
    split.
    - intro P;exists id;apply Embedding_id.
    - intros P Q R (f&Ef) (g&Eg);exists (g∘f);apply Embedding_compose;assumption.
  Qed.

  Lemma embedded_partialOrder : PartialOrder sequiv embedded.
  Proof.
    intros P Q;split.
    - intros E;split;[symmetry in E|];destruct E as (f&If);exists f;apply Embedding_iso,If.
    - unfold Basics.flip;intros ((f&Emb__f)&E).
      rewrite <- (sub_pom_full Q);etransitivity;
        [apply Embedding_is_sub_pom,Emb__f|apply sub_pom_proper].
      symmetry;apply domain_equiv.
      cut (⎢ PomType Q ⎥ <= ⎢ PomType P ⎥).
      + intros len;apply NoDup_length_incl.
        * apply NoDup_map_injective,domain_nodup.
          apply Embedding_inj.
        * rewrite map_length;apply len.
        * apply domain_incl.
      + destruct E as (g&Emb__g).
        apply Embedding_is_sub_pom in Emb__g.
        apply sizePomset_equiv in Emb__g;unfold size,sizePomset in Emb__g;rewrite Emb__g.
        unfold sub_pom,𝒯;simpl.
        rewrite bintree_of_nat_size.
        unfold size at 2,size_type.
        apply NoDup_length,NoDup_undup.
        apply domain_incl.
  Qed.

  Lemma embedded_seq_left P Q : P ⫇ P ⋅ Q.
  Proof. eexists;apply Embedding_seq_l. Qed.
  Lemma embedded_seq_right P Q : Q ⫇ P ⋅ Q.
  Proof. eexists;apply Embedding_seq_r. Qed.

  Lemma embedded_par_left P Q : P ⫇ P ∥ Q.
  Proof. eexists;apply Embedding_par_l. Qed.
  Lemma embedded_par_right P Q : Q ⫇ P ∥ Q.
  Proof. eexists;apply Embedding_par_r. Qed.

  Lemma embedded_iff_sub_pom P Q : P ⫇ Q <-> exists l, P ≃ Q ⇂ l.
  Proof.
    split.
    - intros (f&Ef);eexists;apply Embedding_is_sub_pom,Ef.
    - intros (l&E).
      apply embedded_partialOrder in E as (->&_).
      eexists;apply sub_pom_Embedding.
  Qed.

  Lemma embedded_unit P : 𝟭 ⫇ P.
  Proof. apply embedded_iff_sub_pom;exists [];symmetry;apply sub_pom_nil. Qed.

  Fixpoint sub_term t : list ⌊|t|⌋ -> bsp_terms X :=
    match t with
    | bsp_unit =>
      fun _ => bsp_unit
    | bsp_var x =>
      fun l => if l =?= [] then bsp_unit else bsp_var x
    | bsp_seq t1 t2 =>
      fun l => bsp_seq (sub_term t1 (bsp_get_seq_left l))
                    (sub_term t2 (bsp_get_seq_right l))
    | bsp_par t1 t2 =>
      fun l => bsp_par (sub_term t1 (bsp_get_par_left l))
                    (sub_term t2 (bsp_get_par_right l))
    | bsp_box s =>
      fun l => if equivalentb (get_box_boxes l) ⟨|s|⟩
            then bsp_box s
            else sub_term s (get_box_boxes l)
    end.

  Infix " ⨡ " := sub_term (at level 20).

  Lemma sub_pom_seq_dec t1 t2 l :
    t1 ⇂ get_seq_left l ⋅ t2 ⇂ get_seq_right l ≃ ( t1 ⋅ t2 ) ⇂ l.
  Proof.
    destruct (@sub_pom_make_fun t1 (t1 ⋅ t2) (get_seq_left l)
                                l inl) as (f1&Ef1);
      [intros a Ia;apply in_map_iff in Ia as (b&<-&Ib);
       apply get_seq_left_spec in Ib;assumption|].
    destruct (@sub_pom_make_fun t2 (t1⋅t2) (get_seq_right l)
                                l inr) as (f2&Ef2);
      [intros a Ia;apply in_map_iff in Ia as (b&<-&Ib);
       apply get_seq_right_spec in Ib;assumption|].
    symmetry.
    exists (sumFun f1 f2);split.
    + split;split.
      * intros x' y';unfold sumFun.
        destruct x' as [x|x],y' as [y|y].
        -- simpl;intros E;f_equal.
           apply (@is_injective _ _ _ (@sub_pom_T_injective _ _)).
           eapply (@is_injective _ _ _ (@injective_inl _ _)).
           rewrite <- Ef1,<-Ef1,E;reflexivity.
        -- intros F;exfalso.
           pose proof (Ef1 x) as E.
           rewrite F,Ef2 in E.
           discriminate.
        -- intros F;exfalso.
           pose proof (Ef2 x) as E.
           rewrite F,Ef1 in E.
           discriminate.
        -- intros E;f_equal.
           apply (@is_injective _ _ _ (@sub_pom_T_injective _ _)).
           eapply (@is_injective _ _ _ (@injective_inr _ _)).
           rewrite <- Ef2,<-Ef2,E;reflexivity.
      * intro y.
        pose proof (sub_pom_T_internal y) as Iy.
        apply get_seq_seq_proj in Iy.
        apply in_app_iff in Iy as [Iy|Iy];apply in_map_iff in Iy as (x&Ex&Ix);
          simpl.
        -- apply sub_pom_T_invert in Ix as (x'&<-);simpl.
           rewrite <- Ef1 in Ex.
           apply is_injective in Ex as <-.
           exists (inl x');reflexivity.
        -- apply sub_pom_T_invert in Ix as (x'&<-);simpl.
           rewrite <- Ef2 in Ex.
           apply is_injective in Ex as <-.
           exists (inr x');reflexivity.
    + intros [x|x];simpl;rewrite Ef1||rewrite Ef2;reflexivity.
    + intros [x|x] [y|y];simpl;repeat rewrite Ef1||rewrite Ef2;reflexivity.
    + simpl.
      repeat rewrite map_map||rewrite map_app.
      etransitivity;[apply equiv_set_app_Proper;apply eq_subrelation;
                     (typeclasses eauto)||(apply map_ext;apply map_map)|].
      simpl.
      split;intros b' Ib'.
      * apply in_app_iff in Ib' as [Ib|Ib];apply in_map_iff in Ib as (b&<-&Ib);
          apply sub_pom_Boxes in Ib as (Ib&β&Iβ&Eβ).
        -- assert (map inl β ∈ Boxes (t1 ⋅ t2)
                   /\ map inl β ⊆ l) as (Iβ'&h__β);[split|].
           ++ simpl;apply in_app_iff;left;apply in_map_iff;exists β;split;[reflexivity|apply Iβ].
           ++ rewrite Eβ,map_map.
              intros a Ia;apply in_map_iff in Ia as (x&<-&Ix).
              rewrite <- Ef1;apply (sub_pom_T_internal (f1 x)).
           ++ apply (sub_pom_invert_boxes _ Iβ') in h__β as (γ&Iγ&Eγ).
              exists γ;split;[assumption|].
              rewrite Eβ,map_map in Eγ.
              intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) γ).
              --- rewrite Eγ;repeat rewrite in_map_iff.
                  split;intros (x&E&Ix);exists x;subst;auto.
                  split;[|assumption].
                  rewrite <- (Ef1 x) in E.
                  apply is_injective in E;assumption.
              --- rewrite in_map_iff;split;[|intro I;exists a;tauto].
                  intros (y&E&Iy).
                  apply is_injective in E as ->;tauto.
        -- assert (map inr β ∈ Boxes (t1⋅t2)
                   /\ map inr β ⊆ l) as (Iβ'&h__β);[split|].
           ++ simpl;apply in_app_iff;right;apply in_map_iff;exists β;split;
                [reflexivity|apply Iβ].
           ++ rewrite Eβ,map_map.
              intros a Ia;apply in_map_iff in Ia as (x&<-&Ix).
              rewrite <- Ef2;apply (sub_pom_T_internal (f2 x)).
           ++ apply (sub_pom_invert_boxes _ Iβ') in h__β as (γ&Iγ&Eγ).
              exists γ;split;[assumption|].
              rewrite Eβ,map_map in Eγ.
              intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) γ).
              --- rewrite Eγ;repeat rewrite in_map_iff.
                  split;intros (x&E&Ix);exists x;subst;auto.
                  split;[|assumption].
                  rewrite <- (Ef2 x) in E.
                  apply is_injective in E;assumption.
              --- rewrite in_map_iff;split;[|intro I;exists a;tauto].
                  intros (y&E&Iy).
                  apply is_injective in E as ->;tauto.
      * apply (@sub_pom_box_spec _ l b') in Ib' as (Ib'&β&Iβ&Eβ).
        simpl in Iβ;apply in_app_iff in Iβ as [I|I];apply in_map_iff in I as (γ&<-&Iγ).
        -- assert (γ ⊆ get_seq_left l) as h__γ.
           ++ intros e Ie;apply get_seq_left_spec.
              cut (@inl _ ⌊|t2|⌋ e ∈ map (𝒯l {{l}}) b');[|apply Eβ,in_map_iff;exists e;tauto].
              intros h;apply in_map_iff in h as (x&E&Ix).
              replace (inl _) with (𝒯e x).
              apply (sub_pom_T_internal x).
           ++ apply (sub_pom_invert_boxes _ Iγ) in h__γ as (β&Iβ&Eγ).
              rewrite <- Eγ in Eβ;clear γ Eγ Iγ.
              exists (map f1 β);split.
              ** apply in_app_iff;left.
                 apply in_map_iff;exists β;split;[reflexivity|assumption].
              ** intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) b').
                 --- rewrite in_map_iff;split;[intro I;exists a;tauto|].
                     intros (x&E&Ix).
                     apply is_injective in E as ->;tauto.
                 --- rewrite <- Eβ,map_map;split;intro I;apply in_map_iff in I as (x&E&Ix);
                       apply in_map_iff;exists x;split;auto.
                     +++ apply (@is_injective _ _ _ sub_pom_T_injective).
                         rewrite Ef1;apply E.
                     +++ rewrite <- Ef1,E;reflexivity.
        -- assert (γ ⊆ get_seq_right l) as h__γ.
           ++ intros e Ie;apply get_seq_right_spec.
              cut (@inr _ ⌊|t2|⌋ e ∈ map (𝒯l {{l}}) b');[|apply Eβ,in_map_iff;exists e;tauto].
              intros h;apply in_map_iff in h as (x&E&Ix).
              replace (inr _) with (𝒯e x).
              apply (sub_pom_T_internal x).
           ++ apply (sub_pom_invert_boxes _ Iγ) in h__γ as (β&Iβ&Eγ).
              rewrite <- Eγ in Eβ;clear γ Eγ Iγ.
              exists (map f2 β);split.
              ** apply in_app_iff;right.
                 apply in_map_iff;exists β;split;[reflexivity|assumption].
              ** intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) b').
                 --- rewrite in_map_iff;split;[intro I;exists a;tauto|].
                     intros (x&E&Ix).
                     apply is_injective in E as ->;tauto.
                 --- rewrite <- Eβ,map_map;split;intro I;apply in_map_iff in I as (x&E&Ix);
                       apply in_map_iff;exists x;split;auto.
                     +++ apply (@is_injective _ _ _ sub_pom_T_injective).
                         rewrite Ef2;apply E.
                     +++ rewrite <- Ef2,E;reflexivity.
  Qed.
  Corollary sub_term_seq_dec t1 t2 l :
    ⟦ t1 ⟧ ⇂ bsp_get_seq_left l ⋅ ⟦ t2 ⟧ ⇂ bsp_get_seq_right l ≃ ⟦ t1 ⋅ t2 ⟧ ⇂ l.
  Proof. apply sub_pom_seq_dec. Qed.

  Lemma sub_pom_par_dec t1 t2 l :
     t1 ⇂ get_par_left l ∥ t2 ⇂ get_par_right l ≃ (t1 ∥ t2 ) ⇂ l.
  Proof.
    destruct (@sub_pom_make_fun t1 (t1∥t2) (get_par_left l)
                                l inl) as (f1&Ef1);
      [intros a Ia;apply in_map_iff in Ia as (b&<-&Ib);
       apply get_par_left_spec in Ib;assumption|].
    destruct (@sub_pom_make_fun t2 (t1∥t2) (get_par_right l)
                                l inr) as (f2&Ef2);
      [intros a Ia;apply in_map_iff in Ia as (b&<-&Ib);
       apply get_par_right_spec in Ib;assumption|].
    symmetry.
    exists (sumFun f1 f2);split.
    + split;split.
      * intros x' y';unfold sumFun.
        destruct x' as [x|x],y' as [y|y].
        -- simpl;intros E;f_equal.
           apply (@is_injective _ _ _ (@sub_pom_T_injective _ _)).
           eapply (@is_injective _ _ _ (@injective_inl _ _)).
           rewrite <- Ef1,<-Ef1,E;reflexivity.
        -- intros F;exfalso.
           pose proof (Ef1 x) as E.
           rewrite F,Ef2 in E.
           discriminate.
        -- intros F;exfalso.
           pose proof (Ef2 x) as E.
           rewrite F,Ef1 in E.
           discriminate.
        -- intros E;f_equal.
           apply (@is_injective _ _ _ (@sub_pom_T_injective _ _)).
           eapply (@is_injective _ _ _ (@injective_inr _ _)).
           rewrite <- Ef2,<-Ef2,E;reflexivity.
      * intro y.
        pose proof (sub_pom_T_internal y) as Iy.
        apply get_par_par_proj in Iy.
        apply in_app_iff in Iy as [Iy|Iy];apply in_map_iff in Iy as (x&Ex&Ix);
          simpl.
        -- apply sub_pom_T_invert in Ix as (x'&<-);simpl.
           rewrite <- Ef1 in Ex.
           apply is_injective in Ex as <-.
           exists (inl x');reflexivity.
        -- apply sub_pom_T_invert in Ix as (x'&<-);simpl.
           rewrite <- Ef2 in Ex.
           apply is_injective in Ex as <-.
           exists (inr x');reflexivity.
    + intros [x|x];simpl;rewrite Ef1||rewrite Ef2;reflexivity.
    + intros [x|x] [y|y];simpl;repeat rewrite Ef1||rewrite Ef2;reflexivity.
    + simpl.
      repeat rewrite map_map||rewrite map_app.
      etransitivity;[apply equiv_set_app_Proper;apply eq_subrelation;
                     (typeclasses eauto)||(apply map_ext;apply map_map)|].
      simpl.
      split;intros b' Ib'.
      * apply in_app_iff in Ib' as [Ib|Ib];apply in_map_iff in Ib as (b&<-&Ib);
          apply sub_pom_Boxes in Ib as (Ib&β&Iβ&Eβ).
        -- assert (map inl β ∈ Boxes (t1∥t2)
                   /\ map inl β ⊆ l) as (Iβ'&h__β);[split|].
           ++ simpl;apply in_app_iff;left;apply in_map_iff;exists β;split;[reflexivity|apply Iβ].
           ++ rewrite Eβ,map_map.
              intros a Ia;apply in_map_iff in Ia as (x&<-&Ix).
              rewrite <- Ef1;apply (sub_pom_T_internal (f1 x)).
           ++ apply (sub_pom_invert_boxes _ Iβ') in h__β as (γ&Iγ&Eγ).
              exists γ;split;[assumption|].
              rewrite Eβ,map_map in Eγ.
              intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) γ).
              --- rewrite Eγ;repeat rewrite in_map_iff.
                  split;intros (x&E&Ix);exists x;subst;auto.
                  split;[|assumption].
                  rewrite <- (Ef1 x) in E.
                  apply is_injective in E;assumption.
              --- rewrite in_map_iff;split;[|intro I;exists a;tauto].
                  intros (y&E&Iy).
                  apply is_injective in E as ->;tauto.
        -- assert (map inr β ∈ Boxes (t1∥t2)
                   /\ map inr β ⊆ l) as (Iβ'&h__β);[split|].
           ++ simpl;apply in_app_iff;right;apply in_map_iff;exists β;split;
                [reflexivity|apply Iβ].
           ++ rewrite Eβ,map_map.
              intros a Ia;apply in_map_iff in Ia as (x&<-&Ix).
              rewrite <- Ef2;apply (sub_pom_T_internal (f2 x)).
           ++ apply (sub_pom_invert_boxes _ Iβ') in h__β as (γ&Iγ&Eγ).
              exists γ;split;[assumption|].
              rewrite Eβ,map_map in Eγ.
              intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) γ).
              --- rewrite Eγ;repeat rewrite in_map_iff.
                  split;intros (x&E&Ix);exists x;subst;auto.
                  split;[|assumption].
                  rewrite <- (Ef2 x) in E.
                  apply is_injective in E;assumption.
              --- rewrite in_map_iff;split;[|intro I;exists a;tauto].
                  intros (y&E&Iy).
                  apply is_injective in E as ->;tauto.
      * apply (@sub_pom_box_spec _ l b') in Ib' as (Ib'&β&Iβ&Eβ).
        simpl in Iβ;apply in_app_iff in Iβ as [I|I];apply in_map_iff in I as (γ&<-&Iγ).
        -- assert (γ ⊆ get_par_left l) as h__γ.
           ++ intros e Ie;apply get_par_left_spec.
              cut (@inl _ ⌊|t2|⌋ e ∈ map (𝒯l {{l}}) b');[|apply Eβ,in_map_iff;exists e;tauto].
              intros h;apply in_map_iff in h as (x&E&Ix).
              replace (inl _) with (𝒯e x).
              apply (sub_pom_T_internal x).
           ++ apply (sub_pom_invert_boxes _ Iγ) in h__γ as (β&Iβ&Eγ).
              rewrite <- Eγ in Eβ;clear γ Eγ Iγ.
              exists (map f1 β);split.
              ** apply in_app_iff;left.
                 apply in_map_iff;exists β;split;[reflexivity|assumption].
              ** intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) b').
                 --- rewrite in_map_iff;split;[intro I;exists a;tauto|].
                     intros (x&E&Ix).
                     apply is_injective in E as ->;tauto.
                 --- rewrite <- Eβ,map_map;split;intro I;apply in_map_iff in I as (x&E&Ix);
                       apply in_map_iff;exists x;split;auto.
                     +++ apply (@is_injective _ _ _ sub_pom_T_injective).
                         rewrite Ef1;apply E.
                     +++ rewrite <- Ef1,E;reflexivity.
        -- assert (γ ⊆ get_par_right l) as h__γ.
           ++ intros e Ie;apply get_par_right_spec.
              cut (@inr _ ⌊|t2|⌋ e ∈ map (𝒯l {{l}}) b');[|apply Eβ,in_map_iff;exists e;tauto].
              intros h;apply in_map_iff in h as (x&E&Ix).
              replace (inr _) with (𝒯e x).
              apply (sub_pom_T_internal x).
           ++ apply (sub_pom_invert_boxes _ Iγ) in h__γ as (β&Iβ&Eγ).
              rewrite <- Eγ in Eβ;clear γ Eγ Iγ.
              exists (map f2 β);split.
              ** apply in_app_iff;right.
                 apply in_map_iff;exists β;split;[reflexivity|assumption].
              ** intro a;transitivity (𝒯e a ∈ map (𝒯l {{l}}) b').
                 --- rewrite in_map_iff;split;[intro I;exists a;tauto|].
                     intros (x&E&Ix).
                     apply is_injective in E as ->;tauto.
                 --- rewrite <- Eβ,map_map;split;intro I;apply in_map_iff in I as (x&E&Ix);
                       apply in_map_iff;exists x;split;auto.
                     +++ apply (@is_injective _ _ _ sub_pom_T_injective).
                         rewrite Ef2;apply E.
                     +++ rewrite <- Ef2,E;reflexivity.
  Qed.
  Corollary sub_term_par_dec t1 t2 l :
    ⟦ t1 ⟧ ⇂ bsp_get_par_left l ∥ ⟦ t2 ⟧ ⇂ bsp_get_par_right l ≃ ⟦ t1 ∥ t2 ⟧ ⇂ l.
  Proof. apply sub_pom_par_dec. Qed.

  Lemma sub_term_sub_pom t l : ⟦t ⨡ l⟧ ≃ ⟦t⟧⇂l.
  Proof.
    revert l;induction t;intro l;rsimpl.
    - rewrite IHt1,IHt2,sub_term_seq_dec;reflexivity.
    - rewrite IHt1,IHt2,sub_term_par_dec;reflexivity.
    - destruct l as [|[]];simpl.
      + rewrite eqX_refl, sub_pom_nil;reflexivity.
      + replace (_=?=_) with false by (symmetry;apply eqX_false;discriminate).
        symmetry;etransitivity;[|apply sub_pom_full].
        apply sub_pom_proper.
        symmetry;apply domain_equiv.
        intros [] _;now left.
    - case_eq (equivalentb (get_box_boxes l) ⟨|t|⟩);
        [|rewrite <-not_true_iff_false];rewrite equivalentb_spec;intros El.
      + symmetry;etransitivity;[|apply sub_pom_full];rsimpl.
        apply sub_pom_proper.
        apply El.
      + rewrite IHt.
        clear IHt.
        assert (exists e, ~ e ∈ (get_box_boxes l)) as (e&Ie)
            by (case_prop (exists e, ~ e ∈ (get_box_boxes l));auto;exfalso;apply El,antisymmetry;
                [apply domain_incl
                |intros f _;case_in f (get_box_boxes l);auto;exfalso;apply hyp;exists f;tauto]).
        clear El.
        revert l e Ie.
        unfold interpret,get_box_boxes,id;simpl.
        generalize (sem_bsp t);clear t;simpl.
        intros p l e Ie.
        exists id;split.
        * typeclasses eauto.
        * reflexivity.
        * reflexivity.
        * apply equivalent_equiv_sets;intro.
          destruct (Boxes_box_spec p) as [F|E].
          -- exfalso.
             symmetry in F;destruct F as (f&_).
             pose proof (domain_spec (f e)) as Ie'.
             apply Ie'.
          -- split.
             ++ intros I;apply in_map_iff in I as (y&<-&Iy).
                apply sub_pom_Boxes in Iy as (Iy&β&Iβ&Eβ).
                rewrite E in Iβ;destruct Iβ as [<-|Iβ].
                ** exfalso;apply Ie.
                   cut (e ∈ ⟪PomType p⟫);[|apply domain_spec].
                   rewrite Eβ;intro I;apply in_map_iff in I as (e'&<-&I).
                   apply (@sub_pom_T_internal p l e').
                ** apply sub_pom_Boxes;rewrite map_id;split;[apply Iy|].
                   exists β;split;assumption.
             ++ intro I;apply in_map_iff;exists x;split;[apply map_id|].
                apply sub_pom_Boxes in I as (Ix&y&Iy&Ey).
                apply sub_pom_Boxes;split;[assumption|].
                exists y;split;[|assumption].
                rewrite E;now right.
    - symmetry;etransitivity;[|apply sub_pom_nil].
      apply sub_pom_proper.
      destruct l as [|[]];reflexivity.
  Qed.

  Lemma sub_term_nil s : sub_term s [] ≡ 𝟭.
  Proof.
    apply bsp_size_unit.
    rewrite interpret_bsp_size.
    rewrite (sizePomset_equiv (sub_term_sub_pom _ _)).
    unfold size,sizePomset,sub_pom;simpl.
    reflexivity.
  Qed.

  Global Instance sub_term_proper s : Proper (@equivalent _ ==> eq) (sub_term s).
  Proof.
    induction s;intros l m E;simpl.
    - pose proof E as E'.
      apply bsp_get_seq_left_proper in E as ->.
      apply bsp_get_seq_right_proper in E' as ->.
      reflexivity.
    - pose proof E as E'.
      apply bsp_get_par_left_proper in E as ->.
      apply bsp_get_par_right_proper in E' as ->.
      reflexivity.
    - destruct l as [|a l],m as [|b m].
      + reflexivity.
      + exfalso;cut (b ∈ (b::m));[intro I;apply E in I;apply I|now left].
      + exfalso;cut (a ∈ (a::l));[intro I;apply E in I;apply I|now left].
      + repeat replace (_ =?= _) with false by (symmetry;apply eqX_false;discriminate).
        reflexivity.
    - replace (equivalentb (get_box_boxes l) ⟨|s|⟩)
        with (equivalentb (get_box_boxes m) ⟨|s|⟩).
      + destruct (equivalentb (get_box_boxes m) ⟨|s|⟩);[|rewrite E];reflexivity.
      + apply eq_true_iff_eq.
        repeat rewrite equivalentb_spec.
        rewrite E;reflexivity.
    - reflexivity.
  Qed.

  Lemma sub_term_full s : s ⨡⟨|s|⟩ = s.
  Proof.
    induction s;simpl.
    - f_equal;(erewrite sub_term_proper;[eassumption|]).
      + symmetry;apply domain_equiv.
        intros a _;apply get_seq_left_spec,in_app_iff;left.
        apply in_map_iff;exists a;split;[reflexivity|apply domain_spec].
      + symmetry;apply domain_equiv.
        intros a _;apply get_seq_right_spec,in_app_iff;right.
        apply in_map_iff;exists a;split;[reflexivity|apply domain_spec].
    - f_equal;(erewrite sub_term_proper;[eassumption|]).
      + symmetry;apply domain_equiv.
        intros a _;apply get_seq_left_spec,in_app_iff;left.
        apply in_map_iff;exists a;split;[reflexivity|apply domain_spec].
      + symmetry;apply domain_equiv.
        intros a _;apply get_seq_right_spec,in_app_iff;right.
        apply in_map_iff;exists a;split;[reflexivity|apply domain_spec].
    - replace (_ =?= _) with false by (symmetry;apply eqX_false;discriminate).
      reflexivity.
    - replace (get_box_boxes ⟨|bsp_box s|⟩)
        with ⟨|s|⟩.
      + replace (equivalentb _ _) with true;[reflexivity|].
        symmetry;apply equivalentb_spec;reflexivity.
      + clear.
        unfold get_box_boxes,interpret;simpl.
        destruct (sem_bsp s);simpl;reflexivity.
    - reflexivity.
  Qed.

End s.
Arguments sub_pom : clear implicits.
Arguments sub_pom {X} P D.
Infix " ⇂ " := sub_pom (at level 20).
Infix " ⫇ " := embedded (at level 80).
Infix " ⨡ " := sub_term (at level 20).

Arguments sub_pom_box : clear implicits.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.Values.

Require Import Cryptol.EvalTac.

Import HaskellListNotations.
Open Scope string.

Definition whole_program := [(NonRecursive (Decl (0,"demote") DPrim)),(NonRecursive (Decl (1,"+") DPrim)),(NonRecursive (Decl (2,"-") DPrim)),(NonRecursive (Decl (3,"*") DPrim)),(NonRecursive (Decl (4,"/") DPrim)),(NonRecursive (Decl (5,"%") DPrim)),(NonRecursive (Decl (6,"^^") DPrim)),(NonRecursive (Decl (7,"lg2") DPrim)),(NonRecursive (Decl (9,"True") DPrim)),(NonRecursive (Decl (10,"False") DPrim)),(NonRecursive (Decl (11,"negate") DPrim)),(NonRecursive (Decl (12,"complement") DPrim)),(NonRecursive (Decl (13,"<") DPrim)),(NonRecursive (Decl (14,">") DPrim)),(NonRecursive (Decl (15,"<=") DPrim)),(NonRecursive (Decl (16,">=") DPrim)),(NonRecursive (Decl (17,"==") DPrim)),(NonRecursive (Decl (18,"!=") DPrim)),(NonRecursive (Decl (19,"===") (DExpr (ETAbs (30,"a") (ETAbs (31,"b") (EAbs (89,"f") (EAbs (90,"g") (EAbs (91,"x") (EApp (EApp (ETApp (EVar (17,"==")) (ETyp (TVar (TVBound 31 KType)))) (EApp (EVar (89,"f")) (EVar (91,"x")))) (EApp (EVar (90,"g")) (EVar (91,"x")))))))))))),(NonRecursive (Decl (20,"!==") (DExpr (ETAbs (40,"a") (ETAbs (41,"b") (EAbs (94,"f") (EAbs (95,"g") (EAbs (96,"x") (EApp (EApp (ETApp (EVar (18,"!=")) (ETyp (TVar (TVBound 41 KType)))) (EApp (EVar (94,"f")) (EVar (96,"x")))) (EApp (EVar (95,"g")) (EVar (96,"x")))))))))))),(NonRecursive (Decl (21,"min") (DExpr (ETAbs (50,"a") (EAbs (98,"x") (EAbs (99,"y") (EIf (EApp (EApp (ETApp (EVar (13,"<")) (ETyp (TVar (TVBound 50 KType)))) (EVar (98,"x"))) (EVar (99,"y"))) (EVar (98,"x")) (EVar (99,"y"))))))))),(NonRecursive (Decl (22,"max") (DExpr (ETAbs (56,"a") (EAbs (101,"x") (EAbs (102,"y") (EIf (EApp (EApp (ETApp (EVar (14,">")) (ETyp (TVar (TVBound 56 KType)))) (EVar (101,"x"))) (EVar (102,"y"))) (EVar (101,"x")) (EVar (102,"y"))))))))),(NonRecursive (Decl (23,"/\\") (DExpr (EAbs (103,"x") (EAbs (104,"y") (EIf (EVar (103,"x")) (EVar (104,"y")) (EVar (10,"False")))))))),(NonRecursive (Decl (24,"\\/") (DExpr (EAbs (105,"x") (EAbs (106,"y") (EIf (EVar (105,"x")) (EVar (9,"True")) (EVar (106,"y")))))))),(NonRecursive (Decl (25,"==>") (DExpr (EAbs (107,"a") (EAbs (108,"b") (EIf (EVar (107,"a")) (EVar (108,"b")) (EVar (9,"True")))))))),(NonRecursive (Decl (26,"&&") DPrim)),(NonRecursive (Decl (27,"||") DPrim)),(NonRecursive (Decl (28,"^") DPrim)),(NonRecursive (Decl (29,"zero") DPrim)),(NonRecursive (Decl (30,"<<") DPrim)),(NonRecursive (Decl (31,">>") DPrim)),(NonRecursive (Decl (32,"<<<") DPrim)),(NonRecursive (Decl (33,">>>") DPrim)),(NonRecursive (Decl (34,"#") DPrim)),(NonRecursive (Decl (35,"splitAt") DPrim)),(NonRecursive (Decl (36,"join") DPrim)),(NonRecursive (Decl (37,"split") DPrim)),(NonRecursive (Decl (38,"reverse") DPrim)),(NonRecursive (Decl (39,"transpose") DPrim)),(NonRecursive (Decl (40,"@") DPrim)),(NonRecursive (Decl (41,"@@") DPrim)),(NonRecursive (Decl (42,"!") DPrim)),(NonRecursive (Decl (43,"!!") DPrim)),(NonRecursive (Decl (44,"update") DPrim)),(NonRecursive (Decl (45,"updateEnd") DPrim)),(NonRecursive (Decl (46,"updates") (DExpr (ETAbs (121,"a") (ETAbs (122,"b") (ETAbs (123,"c") (ETAbs (124,"d") (EAbs (166,"xs0") (EAbs (167,"idxs") (EAbs (168,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (ETyp (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 124 KNum)]))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)]))) (ETyp (TCon (TC (TCNum 0)) []))) (EVar (169,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 0)) []))) (ETyp (TCon (TC (TCNum 0)) [])))) [(Recursive [(Decl (169,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (ETyp (TCon (TC (TCNum 1)) []))) (ETyp (TVar (TVBound 124 KNum)))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)]))) (EList [(EVar (166,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (44,"update")) (ETyp (TVar (TVBound 121 KNum)))) (ETyp (TVar (TVBound 122 KType)))) (ETyp (TVar (TVBound 123 KNum)))) (EVar (170,"xs"))) (EVar (171,"i"))) (EVar (172,"b"))) [[(From (170,"xs") (EVar (169,"xss")))],[(From (171,"i") (EVar (167,"idxs")))],[(From (172,"b") (EVar (168,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (47,"updatesEnd") (DExpr (ETAbs (156,"a") (ETAbs (157,"b") (ETAbs (158,"c") (ETAbs (159,"d") (EAbs (177,"xs0") (EAbs (178,"idxs") (EAbs (179,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (ETyp (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 159 KNum)]))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)]))) (ETyp (TCon (TC (TCNum 0)) []))) (EVar (180,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 0)) []))) (ETyp (TCon (TC (TCNum 0)) [])))) [(Recursive [(Decl (180,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (ETyp (TCon (TC (TCNum 1)) []))) (ETyp (TVar (TVBound 159 KNum)))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)]))) (EList [(EVar (177,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (45,"updateEnd")) (ETyp (TVar (TVBound 156 KNum)))) (ETyp (TVar (TVBound 157 KType)))) (ETyp (TVar (TVBound 158 KNum)))) (EVar (181,"xs"))) (EVar (182,"i"))) (EVar (183,"b"))) [[(From (181,"xs") (EVar (180,"xss")))],[(From (182,"i") (EVar (178,"idxs")))],[(From (183,"b") (EVar (179,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (48,"fromThen") DPrim)),(NonRecursive (Decl (49,"fromTo") DPrim)),(NonRecursive (Decl (50,"fromThenTo") DPrim)),(NonRecursive (Decl (51,"infFrom") DPrim)),(NonRecursive (Decl (52,"infFromThen") DPrim)),(NonRecursive (Decl (53,"error") DPrim)),(NonRecursive (Decl (54,"pmult") DPrim)),(NonRecursive (Decl (55,"pdiv") DPrim)),(NonRecursive (Decl (56,"pmod") DPrim)),(NonRecursive (Decl (57,"random") DPrim)),(NonRecursive (Decl (61,"take") (DExpr (ETAbs (214,"front") (ETAbs (215,"back") (ETAbs (216,"elem") (EAbs (212,"__p1") (EWhere (EVar (214,"x")) [(NonRecursive (Decl (213,"__p2") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (ETyp (TVar (TVBound 214 KNum)))) (ETyp (TVar (TVBound 215 KNum)))) (ETyp (TVar (TVBound 216 KType)))) (EVar (212,"__p1")))))),(NonRecursive (Decl (214,"x") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 0))))),(NonRecursive (Decl (215,"__p0") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (62,"drop") (DExpr (ETAbs (231,"front") (ETAbs (232,"back") (ETAbs (233,"elem") (EAbs (219,"__p4") (EWhere (EVar (222,"y")) [(NonRecursive (Decl (220,"__p5") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (ETyp (TVar (TVBound 231 KNum)))) (ETyp (TVar (TVBound 232 KNum)))) (ETyp (TVar (TVBound 233 KType)))) (EVar (219,"__p4")))))),(NonRecursive (Decl (221,"__p3") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 0))))),(NonRecursive (Decl (222,"y") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (63,"tail") (DExpr (ETAbs (249,"a") (ETAbs (250,"b") (EAbs (225,"xs") (EApp (ETApp (ETApp (ETApp (EVar (62,"drop")) (ETyp (TCon (TC (TCNum 1)) []))) (ETyp (TVar (TVBound 249 KNum)))) (ETyp (TVar (TVBound 250 KType)))) (EVar (225,"xs"))))))))),(NonRecursive (Decl (64,"width") (DExpr (ETAbs (255,"bits") (ETAbs (256,"len") (ETAbs (257,"elem") (EAbs (229,"__p6") (ETApp (ETApp (EVar (0,"demote")) (ETyp (TVar (TVBound 256 KNum)))) (ETyp (TVar (TVBound 255 KNum))))))))))),(NonRecursive (Decl (65,"undefined") (DExpr (ETAbs (260,"a") (EApp (ETApp (ETApp (EVar (53,"error")) (ETyp (TVar (TVBound 260 KType)))) (ETyp (TCon (TC (TCNum 9)) []))) (EList [(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 117)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 110)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 100)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 101)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 102)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 105)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 110)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 101)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 100)) []))) (ETyp (TCon (TC (TCNum 8)) [])))])))))),(NonRecursive (Decl (66,"groupBy") (DExpr (ETAbs (265,"each") (ETAbs (266,"parts") (ETAbs (267,"elem") (ETApp (ETApp (ETApp (EVar (37,"split")) (ETyp (TVar (TVBound 266 KNum)))) (ETyp (TVar (TVBound 265 KNum)))) (ETyp (TVar (TVBound 267 KType)))))))))),(NonRecursive (Decl (68,"trace") DPrim)),(NonRecursive (Decl (69,"traceVal") (DExpr (ETAbs (273,"n") (ETAbs (274,"a") (EAbs (240,"msg") (EAbs (241,"x") (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (68,"trace")) (ETyp (TVar (TVBound 273 KNum)))) (ETyp (TVar (TVBound 274 KType)))) (ETyp (TVar (TVBound 274 KType)))) (EVar (240,"msg"))) (EVar (241,"x"))) (EVar (241,"x")))))))))),(NonRecursive (Decl (242,"encrypt") (DExpr (ETAbs (283,"a") (EAbs (246,"key") (EAbs (247,"plaintext") (EComp (EApp (EApp (ETApp (EVar (28,"^")) (ETyp (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]))) (EVar (248,"pt"))) (EVar (246,"key"))) [[(From (248,"pt") (EVar (247,"plaintext")))]]))))))),(NonRecursive (Decl (243,"decrypt") (DExpr (ETAbs (291,"a") (EAbs (250,"key") (EAbs (251,"ciphertext") (EComp (EApp (EApp (ETApp (EVar (28,"^")) (ETyp (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]))) (EVar (252,"ct"))) (EVar (250,"key"))) [[(From (252,"ct") (EVar (251,"ciphertext")))]]))))))),(NonRecursive (Decl (244,"roundtrip") (DExpr (ETAbs (313,"") (EAbs (253,"k") (EAbs (254,"ip") (EApp (EApp (ETApp (EVar (17,"==")) (ETyp (TCon (TC TCSeq) [TVar (TVBound 313 KNum),TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]]))) (EApp (EApp (ETApp (EVar (243,"decrypt")) (ETyp (TVar (TVBound 313 KNum)))) (EVar (253,"k"))) (EApp (EApp (ETApp (EVar (242,"encrypt")) (ETyp (TVar (TVBound 313 KNum)))) (EVar (253,"k"))) (EVar (254,"ip"))))) (EVar (254,"ip")))))))))].

Definition ge := bind_decl_groups whole_program gempty.

Definition encrypt : ident := (242,"encrypt").
Definition decrypt : ident := (243,"decrypt").


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This defines the functor that build consequences of proof-irrelevance *)

Require Export EqdepFacts.

Module Type ProofIrrelevance.

  Axiom proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.

End ProofIrrelevance.

Module ProofIrrelevanceTheory (M:ProofIrrelevance).

  (** Proof-irrelevance implies uniqueness of reflexivity proofs *)

  Module Eq_rect_eq.
    Lemma eq_rect_eq :
      forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
        x = eq_rect p Q x p h.
    Proof.
      intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p).
      reflexivity.
    Qed.
  End Eq_rect_eq.

  (** Export the theory of injective dependent elimination *)

  Module EqdepTheory := EqdepTheory(Eq_rect_eq).
  Export EqdepTheory.

  Scheme eq_indd := Induction for eq Sort Prop.

  (** We derive the irrelevance of the membership property for subsets *)

  Lemma subset_eq_compat :
    forall (U:Set) (P:U->Prop) (x y:U) (p:P x) (q:P y),
      x = y -> exist P x p = exist P y q.
  Proof.
    intros.
    rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H).
    elim H using eq_indd.
    reflexivity.
  Qed.

  Lemma subsetT_eq_compat :
    forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y),
      x = y -> existT P x p = existT P y q.
  Proof.
    intros.
    rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H).
    elim H using eq_indd.
    reflexivity.
  Qed.

End ProofIrrelevanceTheory.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This defines the functor that build consequences of proof-irrelevance *)

Require Export EqdepFacts.

Module Type ProofIrrelevance.

  Axiom proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.

End ProofIrrelevance.

Module ProofIrrelevanceTheory (M:ProofIrrelevance).

  (** Proof-irrelevance implies uniqueness of reflexivity proofs *)

  Module Eq_rect_eq.
    Lemma eq_rect_eq :
      forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
        x = eq_rect p Q x p h.
    Proof.
      intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p).
      reflexivity.
    Qed.
  End Eq_rect_eq.

  (** Export the theory of injective dependent elimination *)

  Module EqdepTheory := EqdepTheory(Eq_rect_eq).
  Export EqdepTheory.

  Scheme eq_indd := Induction for eq Sort Prop.

  (** We derive the irrelevance of the membership property for subsets *)

  Lemma subset_eq_compat :
    forall (U:Set) (P:U->Prop) (x y:U) (p:P x) (q:P y),
      x = y -> exist P x p = exist P y q.
  Proof.
    intros.
    rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H).
    elim H using eq_indd.
    reflexivity.
  Qed.

  Lemma subsetT_eq_compat :
    forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y),
      x = y -> existT P x p = existT P y q.
  Proof.
    intros.
    rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H).
    elim H using eq_indd.
    reflexivity.
  Qed.

End ProofIrrelevanceTheory.


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

Require Import ZFC.Elements.EST7_4.
Require Import ZFC.Elements.EST6_2.
Require Import ZFC.Lib.FuncFacts.

(* 有限序数 *)
Definition finord := λ α, α ⋵ 𝐎𝐍 ∧ finite α.
Notation 𝐎𝐍ᶠⁱⁿ := finord.

(* 无限序数 *)
Definition inford := λ α, α ⋵ 𝐎𝐍 ∧ infinite α.
Notation 𝐎𝐍ⁱⁿᶠ := inford.

(* 自然数集的非空有限子集有极大元 *)
Lemma finite_ords_is_bounded : ∀ A, ⦿ A → A ⪽ 𝐎𝐍 →
  finite A → ∃ α, sub_maximum α A.
Proof with auto; try congruence.
  intros A Hne Hords [n [Hn Hqn]].
  generalize dependent A.
  ω_induction n; intros A Hne Hords Hqn. {
    apply eqnum_empty in Hqn. apply EmptyNI in Hne. exfalso...
  }
  clear Hn n. destruct Hne as [α Hα].
  destruct (classic (sub_maximum α A)). exists α...
  apply not_and_or in H as []. exfalso...
  apply set_not_all_ex_not in H as [β [Hβ Hαβ]].
  apply Hords in Hα as Hoα. apply Hords in Hβ as Hoβ.
  apply ord_lt_iff_not_sub in Hαβ...
  apply split_one_element in Hα as HeqA. rewrite HeqA in Hqn.
  apply finite_set_remove_one_member in Hqn...
  specialize IH with (A - {α,}) as [μ [Hμ Hmax]]...
  { exists β. apply SepI... apply SingNI...
    intros Heq. apply (ord_irrefl α)...
  } {
    intros x Hx. apply SepE1 in Hx. apply Hords...
  }
  apply SepE1 in Hμ... apply Hords in Hμ as Hoμ.
  destruct (classic (β ⊆ μ)) as [Hβμ|Hμβ].
  - exists μ. split... intros γ Hγ.
    destruct (classic (γ = α)).
    + rewrite H. apply ord_lt_iff_psub...
    + apply Hmax. apply SepI... apply SingNI...
  - exists β. split... intros γ Hγ.
    apply ord_lt_iff_not_sub in Hμβ...
    destruct (classic (γ = α)).
    + rewrite H. apply ord_lt_iff_psub...
    + eapply sub_trans.
      * apply Hmax. apply SepI... apply SingNI...
      * apply ord_lt_iff_psub...
Qed.

(* 非零极限序数是无限序数 *)
Lemma limord_is_inford : ∀α ⋵ 𝐎𝐍ˡⁱᵐ, α ≠ ∅ → α ⋵ 𝐎𝐍ⁱⁿᶠ.
Proof with eauto; try congruence.
  intros α Hlim Hne. split. apply Hlim. intros Hfin.
  apply limord_no_maximum in Hlim as Hbnd.
  apply Hbnd. apply finite_ords_is_bounded...
  apply EmptyNE... apply ord_is_ords. apply Hlim.
Qed.

(* 非零有限序数是后继序数 *)
Lemma nonzero_finord_is_suc : ∀α ⋵ 𝐎𝐍ᶠⁱⁿ, α ≠ ∅ → α ⋵ 𝐎𝐍ˢᵘᶜ.
Proof with auto.
  intros α [Hord Hfin] Hne.
  apply sucord_or_limord in Hord as []...
  apply limord_is_inford in H as [_ Hinf]... exfalso...
Qed.

(* 任意序数与自身的单集不交 *)
Lemma ord_disjoint : ∀α ⋵ 𝐎𝐍, disjoint α {α,}.
Proof.
  intros n Hn. apply disjointI. intros [x [H1 H2]].
  apply SingE in H2. subst. eapply ord_irrefl; eauto.
Qed.

(* 自然数等价于有限序数 *)
Lemma nat_iff_finord : ∀ n, n ∈ ω ↔ n ⋵ 𝐎𝐍ᶠⁱⁿ.
Proof with neauto.
  split. {
    intros Hn. split... apply nat_finite...
  }
  intros [Hord [k [Hk Hqn]]].
  generalize dependent n.
  ω_induction k; intros n Hn Hqn.
  - apply eqnum_empty in Hqn. subst...
  - apply sucord_or_limord in Hn as [Hsuc|Hlim].
    + destruct Hsuc as [p [Hp Heq]]. subst n.
      apply ω_inductive. apply IH...
      eapply eqnum_sets_removing_one_element_still_eqnum...
      apply ord_disjoint...
      apply nat_disjoint...
    + destruct (classic (n = ∅)). subst...
      exfalso. apply limord_is_inford in Hlim as [_ Hinf]...
      apply Hinf. exists (m⁺). split... apply ω_inductive...
Qed.

(* ω是无限序数 *)
Lemma ω_is_inford : ω ⋵ 𝐎𝐍ⁱⁿᶠ.
Proof. split. apply ω_is_ord. apply ω_infinite. Qed.

(* 大于等于ω的序数是无限序数 *)
Lemma ord_geq_ω_infinite : ∀α ⋵ 𝐎𝐍, ω ⋸ α → α ⋵ 𝐎𝐍ⁱⁿᶠ.
Proof with eauto.
  intros α Hα Hle.
  apply ord_le_iff_sub in Hle... split...
  eapply parent_set_of_infinite_is_infinite...
  apply ω_infinite.
Qed.

(* 无限序数大于等于ω *)
Lemma inford_geq_ω : ∀α ⋵ 𝐎𝐍ⁱⁿᶠ, ω ⋸ α.
Proof with auto.
  intros α [Hα Hinf]. apply ord_le_iff_not_gt...
  intros Hlt. apply Hinf. apply nat_finite...
Qed.

(* 序数大于等于ω当且仅当该序数是无限序数 *)
Lemma ord_geq_ω_iff_inford : ∀ α, α ⋵ 𝐎𝐍 ∧ ω ⋸ α ↔ α ⋵ 𝐎𝐍ⁱⁿᶠ.
Proof with auto.
  split.
  - intros [Hα Hle]. apply ord_geq_ω_infinite...
  - intros Hinf. split. apply Hinf. apply inford_geq_ω...
Qed.

(* 无限序数与自身的后继等势 *)
Lemma inford_eqnum_its_suc : ∀α ⋵ 𝐎𝐍ⁱⁿᶠ, α⁺ ≈ α.
Proof with neauto; try congruence.
  intros α Hinf.
  apply inford_geq_ω in Hinf as Hgeω.
  destruct Hinf as [Hα Hinf].
  set (Func α⁺ α (λ x, match (ixm (x = α)) with
    | inl _ => ∅
    | inr _ => match (ixm (x ∈ ω)) with
      | inl _ => x⁺
      | inr _ => x
  end end)) as f.
  exists f. apply meta_bijection.
  - intros x Hx. destruct (ixm (x = α)).
    + apply ord_neq_0_gt_0... apply EmptyNI.
      apply infinite_set_nonempty...
    + apply BUnionE in Hx as []; [|apply SingE in H]...
      destruct (ixm (x ∈ ω))... destruct Hgeω as [Hlt|Heq].
      * apply (ord_trans α Hα _ ω)... eapply ω_inductive...
      * rewrite <- Heq. apply ω_inductive...
  - intros x1 H1 x2 H2 Heq.
    destruct (ixm (x1 = α)); destruct (ixm (x2 = α))...
    + exfalso. destruct (ixm (x2 ∈ ω)).
      * eapply suc_neq_0...
      * apply n0. subst x2...
    + exfalso. destruct (ixm (x1 ∈ ω)).
      * eapply suc_neq_0...
      * apply n0. subst x1...
    + destruct (ixm (x1 ∈ ω)); destruct (ixm (x2 ∈ ω))...
      * apply suc_injective...
      * exfalso. apply n1. rewrite <- Heq. apply ω_inductive...
      * exfalso. apply n1. rewrite Heq. apply ω_inductive...
  - intros y Hy.
    destruct (classic (y = ∅)). {
      exists α. split... destruct (ixm (α = α))...
    }
    destruct (classic (y ∈ ω)).
    + ω_destruct y... exists y. split.
      eapply ord_trans... apply ord_lt_suc_iff_sub...
      apply ord_le_iff_sub...
      destruct (ixm (y = α)).
      * subst. exfalso. apply ord_le_iff_not_gt in Hgeω...
      * destruct (ixm (y ∈ ω))...
    + exists y. split. apply BUnionI1...
      destruct (ixm (y = α)).
      * exfalso. eapply ord_irrefl...
      * destruct (ixm (y ∈ ω))...
Qed.

(* 无限序数的前驱（如果存在）是无限序数 *)
Lemma pred_of_inford_infinite : ∀α ⋵ 𝐎𝐍ⁱⁿᶠ, ∀ β, α = β⁺ → β ⋵ 𝐎𝐍ⁱⁿᶠ.
Proof with eauto.
  intros α [Hα Hinf] β Heq.
  assert (Hβ: β ⋵ 𝐎𝐍). {
    eapply ord_is_ords... rewrite Heq. apply suc_has_n.
  }
  split... apply (remove_one_member_from_infinite β) in Hinf.
  replace β with (α - {β,})... rewrite Heq. unfold Suc.
  apply add_one_member_then_remove. apply ord_irrefl...
Qed.

(* 初始无限序数是极限序数 *)
Fact initial_inford_is_limit : ∀α ⋵ 𝐎𝐍ⁱⁿⁱᵗ, α ⋵ 𝐎𝐍ⁱⁿᶠ → α ⋵ 𝐎𝐍ˡⁱᵐ.
Proof with eauto.
  intros α [Hα Hinit] Hinf.
  destruct (sucord_or_limord α)... exfalso.
  destruct H as [β [Hβ Heq]].
  apply (Hinit β); rewrite Heq.
  - apply suc_has_n.
  - apply inford_eqnum_its_suc.
    eapply pred_of_inford_infinite...
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C Bprime Aprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A Aprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ col_ O Eprime Aprime))))))))))) -> col_ O B A)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Category.

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

Section Terminal.

Context {C : Category}.

Class Terminal := {
terminal_obj : C;
one {x} : x ~> terminal_obj;

one_unique {x} (f g : x ~> terminal_obj) : f ≈ g
}.

End Terminal.

Notation "1" := terminal_obj : object_scope.

Hint Resolve @one_unique : category_laws.

Corollary one_comp `{@Terminal C} {x y : C} {f : x ~> y} :
one ∘ f ≈ one.
Proof. hammer_hook "Terminal" "Terminal.one_comp". intros; apply one_unique. Qed.

Hint Rewrite @one_comp : categories.

Notation "one[ C ]" := (@one _ _ C)
(at level 9, format "one[ C ]") : morphism_scope.

Definition const `{@Terminal C} {x y : C} {f : 1 ~> y} := f ∘ one[x].


From mathcomp Require Import
     all_ssreflect.

(** * Paramters
    This file contains basic paramters for the protocol, as well as a few synononyms.
**)

Parameter Transactions : eqType.
Parameter Hash : eqType.
Parameter Party : finType.

(* Type synononyms *)
Definition Slot := nat.
Definition SlotZero := 0.
Definition Delay := nat.
Definition Parties := seq Party.

(* List of initial parites *)
Parameter InitParties : Parties.

(* Lottery parameter *)
Parameter Winner: Party -> Slot -> bool.