Require Export Maximal_Principle.

(** Zorn Lemma **)

Module Type Zorn_Lemma.

Declare Module Max : Maximal_Principle.

Definition En_Fs X le x := \{ λ u, u∈X /\ Rrelation u le x \}.

Definition En_FF X A le := \{ λ u, exists a, u = (En_Fs X le a) /\ a∈A \}.
Axiom Property_FF : forall X A le a,
  (En_Fs X le a) ∈ (En_FF X A le) ->
  (forall b, En_Fs X le a = En_Fs X le b -> a = b).

Definition En_A X A le := \{ λ u, (En_Fs X le u) ∈ A \}.

Lemma Property_Fs : forall X le u v,
  PartialOrder le X -> u∈X ->
  (En_Fs X le u ⊂ En_Fs X le v <-> Rrelation u le v).
Proof.
  intros; unfold PartialOrder in H.
  destruct H, H1, H2, H3; split; intros.
  - assert (u ∈ (En_Fs X le u)).
    { unfold En_Fs; apply Axiom_Scheme; repeat split; Ens. }
    unfold Subclass in H5; apply H5 in H6; unfold En_Fs in H6.
    apply Axiom_Scheme in H6; try apply H6.
  - unfold Subclass; intros; unfold En_Fs in H6; unfold En_Fs.
    apply Axiom_Scheme in H6; apply Axiom_Scheme; destruct H6, H7.
    repeat split; auto; unfold Transitivity in H4; apply H4 with (v:=u).
    repeat split; auto; destruct H1; unfold Subclass in H9.
    unfold Rrelation in H5; apply H9 in H5; unfold Cartesian in H5.
    apply Axiom_SchemeP in H5; apply H5.
Qed.

Lemma LemmaZ1 : forall A X le,
  PartialOrderSet X le ->
  (Chain A X le <-> (En_FF X A le)⊂(En_FF X X le) /\ Nest(En_FF X A le) /\ A≠Φ).
Proof.
  intros; split; intros.
  - double H; unfold PartialOrderSet in H1; unfold Chain in H0.
    apply H0 in H1; clear H0; destruct H1, H0; split.
    + unfold Subclass; intros; apply Axiom_Scheme in H3; apply Axiom_Scheme.
      destruct H3, H4, H4; split; auto; exists x; split; auto.
    + split; auto; unfold Nest; intros; destruct H3; apply Axiom_Scheme in H3.
      apply Axiom_Scheme in H4; destruct H3, H4, H5, H5, H6, H6.
      generalize (classic (x=x0)); intros; destruct H9.
      * rewrite H9 in H5; rewrite H5, H6.
        right; unfold Subclass; intros; auto.
      * unfold TotalOrder in H1; destruct H1; clear H1; double H7.
        add (x0∈A) H7; apply H10 in H7; auto; clear H10; clear H9.
        unfold PartialOrderSet in H; unfold PartialOrder in H.
        destruct H, H9, H10 as [H11 H10], H10 as [H12 H10]; clear H11 H12.
        unfold Transitivity in H10; rewrite H5, H6; destruct H7.
        -- left; unfold Subclass; intros; apply Axiom_Scheme in H11.
           destruct H11, H12; apply Axiom_Scheme; repeat split; auto.
           assert (Rrelation x le x0).
           { unfold Rrelation in H7; unfold Rrelation.
             apply Theorem4' in H7; apply H7. }
           unfold Subclass in H0; apply H0 in H1; apply H0 in H8.
           apply H10 with (v:= x); auto.
        -- right; unfold Subclass; intros; apply Axiom_Scheme in H11.
           destruct H11, H12; apply Axiom_Scheme; repeat split; auto.
           assert (Rrelation x0 le x).
           { unfold Rrelation in H7; unfold Rrelation.
             apply Theorem4' in H7; apply H7. }
           unfold Subclass in H0; apply H0 in H1; apply H0 in H8.
           apply H10 with (v:= x0); auto.
  - destruct H0, H1; unfold Chain; intros; clear H3.
    assert (forall z, z∈A -> (En_Fs X le z) ∈ (En_FF X A le)).
    { intros; unfold En_FF; apply Axiom_Scheme; split.
      - assert (En_Fs X le z ⊂ X).
        { unfold Subclass; intros; apply Axiom_Scheme in H4; apply H4. }
        unfold PartialOrderSet in H; destruct H; clear H5.
        apply Theorem33 in H4; auto.
      - exists z; split; auto. }
    assert (A ⊂ X); try split; auto.
    { unfold Subclass; intros; unfold Subclass in H0.
      apply H3 in H4; apply H0 in H4; double H4; unfold En_FF in H5.
      apply Axiom_Scheme in H5; destruct H5, H6, H6.
      apply Property_FF with (A:=X) in H6; auto; rewrite H6; auto. }
    unfold PartialOrderSet in H; unfold PartialOrder in H; destruct H.
    destruct H5, H6, H7; unfold TotalOrder.
    split; try (apply Theorem33 with (x:=X); auto).
    unfold PartialOrder; repeat split; auto.
    + apply Theorem33 in H4; auto.
    + destruct H5; unfold Relation in H5; unfold Relation; intros.
      apply Theorem4' in H10; destruct H10; apply H5 in H10; auto.
    + unfold Subclass; intros; apply Theorem4' in H9; apply H9.
    + unfold Reflexivity; intros; unfold Rrelation; apply Theorem4'.
      unfold Reflexivity in H6; double H9; unfold Subclass in H4.
      apply H4 in H10; apply H6 in H10; unfold Rrelation in H10.
      split; auto; unfold Cartesian; apply Axiom_SchemeP; Ens.
    + unfold Antisymmetry in H7; unfold Antisymmetry; intros.
      destruct H9, H10; apply H7; auto; unfold Rrelation in H10, H12.
      apply Theorem4' in H10; apply Theorem4' in H12; destruct H10, H12.
      unfold Rrelation; split; auto.
    + unfold Transitivity in H8; unfold Transitivity; intros.
      destruct H9, H10, H9, H12; assert ((u∈X /\ v∈X /\ w∈X) /\
      Rrelation u le v /\ Rrelation v le w).
      { unfold Subclass in H4; apply H4 in H9; apply H4 in H12.
        apply H4 in H13; repeat split; auto; unfold Rrelation.
        - unfold Rrelation in H10; apply Theorem4' in H10; apply H10.
        - unfold Rrelation in H11; apply Theorem4' in H11; apply H11. }
      apply H8 in H14; unfold Rrelation in H14; clear H8.
      unfold Rrelation; apply Theorem4'; split; auto.
      unfold Cartesian; apply Axiom_SchemeP; Ens.
    + intros; destruct H9; unfold Nest in H1.
      assert ((En_Fs X le x) ∈ (En_FF X A le) /\ (En_Fs X le y) ∈
      (En_FF X A le)). { apply H3 in H9; apply H3 in H11; split; auto. }
      apply H1 in H12; clear H1; clear H2; destruct H12.
      * { left; unfold Rrelation; apply Theorem4'; split.
          - apply Property_ProperSubclass in H1; destruct H1.
            + unfold ProperSubclass in H1; destruct H1; clear H2.
              apply Property_Fs in H1; unfold Rrelation in H1; auto.
              unfold PartialOrder; auto.
            + assert ((En_Fs X le x) ∈ (En_FF X A le)).
              { unfold En_FF; apply Axiom_Scheme; double H9.
                apply H3 in H11; split; Ens. }
              apply Property_FF with (A:=A) in H1; auto; contradiction.
          - unfold Cartesian; apply Axiom_SchemeP; repeat split; auto.
            apply Theorem49; split; Ens. }
      * { right; unfold Rrelation; apply Theorem4'; split.
          - apply Property_ProperSubclass in H1; destruct H1.
            + unfold ProperSubclass in H1; destruct H1; clear H2.
              apply Property_Fs in H1; unfold Rrelation in H1; auto.
              unfold PartialOrder; auto.
            + assert ((En_Fs X le y) ∈ (En_FF X A le)).
              { unfold En_FF; apply Axiom_Scheme; double H9.
                apply H3 in H11; split; Ens. }
              apply Property_FF with (A:=A) in H1; auto.
              symmetry in H1; contradiction.
          - unfold Cartesian; apply Axiom_SchemeP; repeat split; auto.
            apply Theorem49; split; Ens. }
Qed.

Lemma LemmaZ2 : forall A X le y,
  PartialOrderSet X le /\ X ≠ Φ ->
  (BoundU y A X le -> (forall x, x ∈ (En_FF X A le) -> x ⊂ (En_Fs X le y))).
Proof.
  intros; double H.
  unfold BoundU in H0; apply H0 in H2; clear H0; destruct H2, H2.
  unfold En_FF in H1; apply Axiom_Scheme in H1; destruct H1.
  destruct H4 as [a H4], H4; rewrite H4; unfold Subclass; intros.
  unfold En_Fs in H6; unfold En_Fs.
  apply Axiom_Scheme in H6; apply Axiom_Scheme.
  double H5; apply H3 in H5; destruct H6, H8, H; clear H10.
  repeat split; auto; unfold PartialOrderSet, PartialOrder in H.
  destruct H, H10, H11, H12; unfold Transitivity in H13.
  apply H13 with (v:=a); repeat split; auto.
Qed.

Lemma LemmaZ3 : forall X le y,
  PartialOrderSet X le /\ X ≠ Φ ->
  (MaxElement y X le <-> MaxMember (En_Fs X le y) (En_FF X X le)).
Proof.
  intros; destruct H; split; intros.
  - unfold MaxElement in H1; apply H1 in H0; clear H1; destruct H0.
    unfold PartialOrderSet, PartialOrder in H; destruct H.
    unfold MaxMember; intros; clear H3; repeat split; intros.
    + unfold En_FF; apply Axiom_Scheme; split.
      * assert ((En_Fs X le y) ⊂ X).
        { unfold Subclass; intros; apply Axiom_Scheme in H3; apply H3. }
        apply Theorem33 in H3; auto.
      * exists y; split; auto.
    + apply Axiom_Scheme in H3; destruct H3, H4, H4; rewrite H4; intro.
      apply H1 in H5; apply not_and_or in H5; destruct H5.
      * unfold ProperSubclass in H6; destruct H6; clear H7.
        apply Property_Fs in H6; unfold Rrelation in H6; try apply H2; auto.
        unfold PartialOrder; auto.
      * apply NNPP in H5; rewrite H5 in H6; unfold ProperSubclass in H6.
        destruct H6; contradiction.
  - unfold PartialOrderSet, PartialOrder in H; destruct H.
    unfold MaxElement; intros; clear H3.
    unfold MaxMember in H1; assert (En_FF X X le ≠ Φ).
    { apply Property_NotEmpty in H0; destruct H0.
      apply Property_NotEmpty; exists (En_Fs X le x).
      unfold En_FF; apply Axiom_Scheme; split.
      - apply Theorem33 with (x:= X); auto; unfold Subclass; intros.
        unfold En_Fs in H3; apply Axiom_Scheme in H3; apply H3.
      - exists x; split; auto. }
    apply H1 in H3; clear H1; clear H0; destruct H3; double H0.
    unfold En_FF in H3; apply Axiom_Scheme in H3; destruct H3, H4, H4.
    apply Property_FF with (A:= X) in H4; auto; rewrite <- H4 in H5.
    split; intros; auto; assert (En_Fs X le y0 ∈ (En_FF X X le)).
    { unfold En_FF; apply Axiom_Scheme; split.
      - assert (En_Fs X le y0 ⊂ X).
        { unfold Subclass; intros; apply Axiom_Scheme in H7; apply H7. }
        apply Theorem33 in H7; auto.
      - exists y0; split; auto. }
    apply H1 in H7; intro; elim H7; destruct H8.
    unfold ProperSubclass; split.
    + apply Property_Fs; auto; unfold PartialOrder; auto.
    + intro; apply Property_FF with (A:=X) in H10; auto.
Qed.

Theorem Zorn : forall X le,
  PartialOrderSet X le -> (forall A, Chain A X le -> exists y, BoundU y A X le)
  -> exists v, MaxElement v X le.
Proof.
  intros.
  generalize (classic (X = Φ)); intros; destruct H1.
  - exists Φ; rewrite H1; unfold MaxElement; contradiction.
  - assert (Ensemble (En_FF X X le)).
    { unfold PartialOrderSet, PartialOrder in H; destruct H.
      clear H2; assert ((En_FF X X le) ⊂ pow(X)).
      { unfold Subclass; intros; unfold En_FF in H2.
        apply Axiom_Scheme in H2; destruct H2, H3, H3.
        unfold PowerClass; apply Axiom_Scheme; split; auto.
        rewrite H3; unfold Subclass; intros.
        unfold En_Fs in H5; apply Axiom_Scheme in H5; apply H5. }
      apply Theorem38 in H; auto; apply Theorem33 in H2; auto. }
    apply Max.MaxPrinciple in H2.
    + destruct H2 as [M H2]; double H2; unfold MaxMember in H3.
      assert (En_FF X X le ≠ Φ).
      { apply Property_NotEmpty in H1; destruct H1.
        apply Property_NotEmpty; exists (En_Fs X le x).
        unfold En_FF; apply Axiom_Scheme; split.
        - destruct H; apply Theorem33 with (x:= X); auto.
          unfold Subclass; intros; apply Axiom_Scheme in H5; apply H5.
        - exists x; split; auto. }
      apply H3 in H4; clear H3; destruct H4.
      unfold En_FF in H3; apply Axiom_Scheme in H3; destruct H3.
      destruct H5 as [v H5], H5; rewrite H5 in H2; add (X ≠ Φ) H.
      exists v; apply LemmaZ3 with (y:=v) in H; auto; apply H; auto.
    + intro B; intros; destruct H3.
      generalize (classic (B = Φ)); intros; destruct H5.
      { rewrite H5; apply Property_NotEmpty in H1.
        destruct H1 as [z H1]; exists (En_Fs X le z); split.
        - unfold En_FF; apply Axiom_Scheme; split.
          + destruct H; apply Theorem33 with (x:=X); auto.
            unfold Subclass; intros; apply Axiom_Scheme in H7; apply H7.
          + exists z; split; auto.
        - intros; generalize (Theorem16 u); contradiction. }
      assert ( (En_FF X (En_A X B le) le) ⊂ (En_FF X X le) /\
      Nest (En_FF X (En_A X B le) le) /\ (En_A X B le) ≠ Φ).
      { assert ((En_FF X (En_A X B le) le) ⊂ (En_FF X X le)).
        { intros; unfold Subclass; intros.
          apply Axiom_Scheme in H6; destruct H6, H7 as [a H7], H7.
          apply Axiom_Scheme in H8; destruct H8.
          apply Axiom_Scheme; split; auto.
          unfold Subclass in H3; apply H3 in H9; unfold En_FF in H8.
          double H9; apply Axiom_Scheme in H10; destruct H10, H11 as [a1 H11].
          destruct H11; apply Property_FF with (b:= a1) in H9; auto.
          rewrite H9 in H7; exists a1; auto. }
        repeat split; auto; unfold Nest; intros.
        - destruct H7; apply Axiom_Scheme in H7; apply Axiom_Scheme in H8.
          destruct H7, H8, H9 as [a H9], H10 as [b H10], H9, H10.
          apply Axiom_Scheme in H11; apply Axiom_Scheme in H12.
          destruct H11, H12; rewrite H9, H10.
          unfold Nest in H4; add ((En_Fs X le b) ∈ B) H13.
        - apply Property_NotEmpty in H5; destruct H5; double H5.
          apply H3 in H7; apply Axiom_Scheme in H7; destruct H7, H8, H8.
          rewrite H8 in H5; apply Property_NotEmpty; exists x0.
          apply Axiom_Scheme; split; Ens. }
      double H; apply LemmaZ1 with (A:= (En_A X B le)) in H7.
      apply H7 in H6; clear H7; double H6; apply H0 in H6; clear H0.
      destruct H6 as [y H0]; unfold Chain in H7; double H.
      unfold PartialOrderSet in H6; apply H7 in H6; clear H7.
      destruct H6; exists (En_Fs X le y); split; intros.
      * unfold BoundU in H0; double H; add (X≠Φ) H8; apply H0 in H8.
        clear H0; destruct H8, H8 as [H9 H8]; clear H9.
        unfold En_FF; apply Axiom_Scheme; split.
        -- assert (En_Fs X le y ⊂ X).
           { unfold Subclass; intros; apply Axiom_Scheme in H9; apply H9. }
           destruct H; apply Theorem33 in H9; auto.
        -- exists y; split; auto.
      * double H8; unfold Subclass in H3; apply H3 in H9.
        apply Axiom_Scheme in H9; destruct H9, H10, H10; add (X≠Φ) H.
        apply LemmaZ2 with (A:=En_A X B le)(y:=y)(x:=u) in H; auto.
        apply Axiom_Scheme; split; auto; exists x; split; auto.
        apply Axiom_Scheme; split; Ens; rewrite <- H10; auto.
Qed.

Hint Resolve Zorn : Axiom_of_Choice.

End Zorn_Lemma.


(*
 * DATA AND FUNCTIONS
 *)

(* Introduce a new type. *)
Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

(* Define a function. *)
Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

(* `Compute` evaluates the expression and prints the result. *)
Compute (next_weekday friday).
Compute (next_weekday monday).

(* Makes an assertion and gives it a name. *)
Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

(* Verify the last assertion.
 *
 * Notice that `Example` does not verify if the assertion is valid, it only
 * names it. To verify it, one must use `Proof`.
 *)
Proof. simpl. reflexivity. Qed.

(******************************************************************************)

From Coq Require Export String.

(*
 * BOOLEANS
 *)

Inductive bool : Type :=
  | true
  | false.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Example test_negb1: (negb true) = false.
Proof. simpl. reflexivity. Qed.
Example test_negb2: (negb false) = true.
Proof. simpl. reflexivity. Qed.

Definition andb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Example test_andb1: (andb true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb2: (andb true false) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb3: (andb false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb4: (andb false false) = false.
Proof. simpl. reflexivity. Qed.

Definition orb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb false false) = false.
Proof. simpl. reflexivity. Qed.

Notation "a && b" := (andb a b).
Notation "a || b" := (orb a b).

Example test_andb_notation: true && false = false.
Proof. simpl. reflexivity. Qed.

Example test_orb_notation: false || true = true.
Proof. simpl. reflexivity. Qed.

(* Exercise 1 *)

Definition nandb (b1 : bool) (b2 : bool) : bool :=
  negb (andb b1 b2).

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

(* Exercise 2 *)

Definition andb3 (b1 : bool) (b2 : bool) (b3 : bool) : bool :=
  andb b1 (andb b2 b3).

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

(******************************************************************************)

(*
 * TYPES
 *)

(* `Check` prints the given expression's type. *)
Check true.

(* `Check` may also be used to check the type. *)
Check andb: bool -> bool -> bool.
Check negb: bool -> bool.
Check (negb true) : bool.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  (* Constructors may take arguments. Here we say the `color` constructor
   * `primary` takes an argument of type `rgb`.
   *)
  | primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | primary _ => false
  end.

(******************************************************************************)

(*
 * MODULES
 *)

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b :bool := true.

Check Playground.b : rgb.
Check b : bool.

(******************************************************************************)

(*
 * TUPLES
 *)

Module TuplePlayground.

  Inductive bit : Type :=
    | B0
    | B1.

  (* One may declare a tuple-like structure by using an inductively-defined type
   * with only one variant.
   *)
  Inductive nybble : Type :=
    | bits (b0 b1 b2 b3 : bit).

  Check (bits B1 B0 B1 B0) : nybble.

  Definition all_zero (nb : nybble) : bool :=
    match nb with
    | (bits B0 B0 B0 B0) => true
    | (bits _ _ _ _) => false
    end.

  Example test_all_zero1: all_zero (bits B1 B0 B1 B0) = false.
  Proof. simpl. reflexivity. Qed.
  Example test_all_zero2: all_zero (bits B0 B0 B0 B0) = true.
  Proof. simpl. reflexivity. Qed.

End TuplePlayground.

(******************************************************************************)

(*
 * NUMBERS
 *)

Module NatPlayground1.

  (* Up until this point, all types defined here compose a finite set. Natural
   * numbers, however, comprehend an infinite set. Hence, how one might
   * represent them?
   *
   * Just like computers use a binary representation to facilitate circuitry, a
   * person who's trying to prove something must pick a representation that
   * eases such proofs.
   *
   * Unary representation?
   *)
  Inductive nat : Type :=
    | O                    (* zero *)
    | S (n : nat).         (* successor of another nat *)

  (* That's indeed a powerful definition.
   *
   * The constructor `O` belongs to the set `nat`.
   * For all `n` that belongs to `nat`, `S n` will also belong to `nat`.
   *
   * So:
   *     - Zero may be encoded as `O`,
   *     - One as `S O`,
   *     - Two as `S (S O)`,
   *     - (...)
   *)

  Check O: nat.
  Check S: nat -> nat.

  Definition pred (n : nat) : nat :=
    match n with
    | O => O
    | S n' => n'
    end.

  Example test_pred1: pred O = O.
  Proof. simpl. reflexivity. Qed.
  Example test_pred2: pred (S O) = O.
  Proof. simpl. reflexivity. Qed.
  Example test_pred3: pred (S (S O)) = S O.
  Proof. simpl. reflexivity. Qed.

  (* Notice that, since the previous `nat` definition is inside a module, all
   * other scopes do not use it. Rather, they use `nat` defined in the std lib.
   *)

End NatPlayground1.

Check (S (S (S (O)))). (* Will print 3, built-in Coq magic notation. *)

Example coq_nat_magic: (S (S (S (O)))) = 3.
Proof. simpl. reflexivity. Qed.

  Definition suc (n : nat) : nat := S (n).

  Example test_suc1: suc O = 1.
  Proof. simpl. reflexivity. Qed.
  Example test_suc2: suc (S O) = 2.
  Proof. simpl. reflexivity. Qed.

Definition minustwo (n : nat) :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Example test_minustwo1: minustwo O = 0.
Proof. simpl. reflexivity. Qed.
Example test_minustwo2: minustwo (S O) = 0.
Proof. simpl. reflexivity. Qed.
Example test_minustwo3: minustwo (S (S O)) = 0.
Proof. simpl. reflexivity. Qed.
Example test_minustwo4: minustwo (S (S (S O))) = 1.
Proof. simpl. reflexivity. Qed.

(* Notice that, while the terms `S` and `pred` have the same type, they do not
 * represent the same concept.
 *
 * `S` is a constructor. It just creates a value an does nothing with it.
 * `pred` is a _computation_ rule (i.e., a function). It takes a value and
 * does something with it.
 *)
Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

(* Use `Fixpoint` to define a recursive function. *)
Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.

Definition odd (n : nat) : bool :=
  negb (even n).

Example test_odd1: odd 0 = false.
Proof. simpl. reflexivity. Qed.
Example test_odd2: odd 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_odd3: odd 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

Fixpoint plus (m n : nat) : nat :=
  match m with
  | O => n
  | S m' => S (plus m' n)
  end.

  Example test_plus1: plus 2 3 = 5.
  Proof. simpl. reflexivity. Qed.

  (* What's even happening above??
   *
   *   plus [(S (S O)) (S (S (S O)))] = plus [2 3]
   *                   ^^^^^^^^^^^^^
   *
   * = S (plus [(S (S O)) (S (S O))])
   *   ^                  ^^^^^^^^^
   *
   * = S (S (plus [(S (S O)) (S O)]))
   *   ^  ^                  ^^^^^
   *
   * = S (S (S (plus [(S (S O)) O])))
   *   ^  ^  ^        ----2---- *
   *
   * = S (S (S (S (S O))))
   *   ^  ^  ^  ---2---
   *
   * = 5
   *)

  Fixpoint minus (m n : nat) : nat :=
    match m, n with
    | O, _ => O
    | m, O => m
    | S m', S n' => minus m' n'
    end.

  Example test_minus1: minus 2 0 = 2.
  Proof. simpl. reflexivity. Qed.
  Example test_minus2: minus 0 2 = 0.
  Proof. simpl. reflexivity. Qed.
  Example test_minus3: minus 5 3 = 2.
  Proof. simpl. reflexivity. Qed.
  Example test_minus4: minus 3 5 = 0.
  Proof. simpl. reflexivity. Qed.

  Fixpoint mult (m n : nat) : nat :=
    match n with
    | O => O
    | S n' => plus m (mult m n')
    end.

  Example test_mult1: mult 3 0 = 0.
  Proof. simpl. reflexivity. Qed.
  Example test_mult2: mult 3 1 = 3.
  Proof. simpl. reflexivity. Qed.
  Example test_mult3: mult 3 2 = 6.
  Proof. simpl. reflexivity. Qed.

End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
  end.

Example test_exp1: exp 3 0 = 1.
Proof. simpl. reflexivity. Qed.
Example test_exp2: exp 3 1 = 3.
Proof. simpl. reflexivity. Qed.
Example test_exp3: exp 3 2 = 9.
Proof. simpl. reflexivity. Qed.

(* Exercise 3 *)

Fixpoint factorial (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => mult n (factorial n')
  end.

Example test_factorial1: factorial 3 = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: factorial 5 = mult 10 12.
Proof. simpl. reflexivity. Qed.

(* Common notation *)
Notation "x + y" := (plus x y)
  (at level 50, left associativity)
  : nat_scope.
Notation "x - y" := (minus x y)
  (at level 50, left associativity)
  : nat_scope.
Notation "x * y" := (mult x y)
  (at level 40, left associativity)
  : nat_scope.

Check ((0 + 1) + 1) : nat.

(* Checks if both arguments are equal. *)
Fixpoint eqb (m n : nat) : bool :=
  match m, n with
  | O, O => true
  | O, _ => false
  | _, O => false
  | S m', S n' => eqb m' n'
  end.

Example test_eqb1: eqb 0 5 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb2: eqb 5 0 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb3: eqb 4 5 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb4: eqb 5 4 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb5: eqb 5 5 = true.
Proof. simpl. reflexivity. Qed.

(* Checks if the first argument is less than or equal to the first. *)
Fixpoint leb (m n : nat) : bool :=
  match m, n with
  | O, _       => true
  | S _, O     => false
  | S m', S n' => leb m' n'
  end.

Example test_leb1: leb 4 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: leb 3 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: leb 4 3 = false.
Proof. simpl. reflexivity. Qed.

(* Common notation. *)
Notation "x =? y" := (eqb x y)
  (at level 70)
  : nat_scope.
Notation "x <=? y" := (leb x y)
  (at level 70)
  : nat_scope.

Example test_leb4: (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

(* Notice the difference between `=` and `=?`.
 *
 * The former, built into Coq, is used to define a proposition (i.e. a logical
 * claim which may be proved later). The latter, however, may be seen as a
 * simple function (a notation for `eqb`), which may be used to compute a
 * value.
 *)

(* Exercise 4 *)

(* Checks if the first argument is less than the second. *)
Definition ltb (m n : nat) : bool :=
  if eqb m n
    then false
    else leb m n.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

(******************************************************************************)

(*
 * PROOF BY SIMPLIFICATION
 *)

(* Notice that the previous proofs used `simpl` to simplify both sides of the
 * equation while `reflexivity` was used to check that both sides contain
 * identical values.
 *
 * In such examples, however, `simpl` was not needed at all since `reflexivity`
 * can perform simplifications when checking that two sides are equal.
 * Indeed, `reflexivity` is a little bit more powerful since it can also
 * _unfold_ defined terms.
 *)

(* `intros`, `simpl` and `reflexivity` are called tactics. A tactic is a command
 * used between `Prof` and `Qed` to guide the process of checking some claim.
 *
 * `Theorem`, `Example`, `Lemma`, `Fact` and `Remark` are almost analogous.
 *)

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

(* Theorem plus 1 on the left. *)
Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

(* Theorem mult 0 on the left. *)
Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof.
  intros n. simpl. reflexivity. Qed.

(******************************************************************************)

(*
 * PROOF BY REWRITING
 *)

Theorem plus_id_example : forall m n : nat,
  m = n ->
  m + m = n + n.
Proof.
  (* Move both quantifiers, `m` and `n`, into the context. *)
  intros m n.
  (* Move the hypothesis, `m = n`, into the context. *)
  intros Hyp.
  (* Rewrite the goal, `m + m = n + n`, using the hypothesis,
   * so we get `n + n = n + n`.
   *
   * The arrow below tells Coq to rewrite from left to right. *)
  rewrite -> Hyp.
  reflexivity.
Qed.

(* The `rewrite` tactic may be used with a previously proved theorem instead
 * of an hypothesis from the context.
 *)

(* Exercise 5 *)

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1.
  intros H2.
  rewrite <- H2.
  rewrite -> H1.
  reflexivity.
Qed.

(* Provided by the standard library: *)
Check mult_n_O:
  forall n : nat, 0 = n * 0.
Check mult_n_Sm:
  forall n m : nat, n * m + n = n * S m.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  (* Notice the `<-`. I want to go from `n * 0` to `0`,
   * and not from `0` to `n * 0`. *)
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  simpl.
  reflexivity.
Qed.

(* Exercise 6 *)

(* Use those two lemmas about multiplication that we just checked to prove the
 * following theorem. Hint: recall that 1 is S O. *)
Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intros p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  simpl.
  reflexivity.
Qed.

(******************************************************************************)

(*
 * PROOF BY CASE ANALYSIS
 *)

(* Not everything can be proved by simple calculation and rewriting.
 * In general, unknown and hypothetical values can block simplification.
 *)

Theorem plus_1_neq_0_first_try : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  simpl.
Abort.

(* The `simpl` tactic cannot do anything meaningful above since both `+` and
 * `=?` perform a `match` in the first argument (here, `n` and `n + 1`,
 * respectively). Since those are expressions with unknown values,
 * simplification becomes impossible.
 *
 * To make progress, one must consider the possible forms of the given unknown
 * value separately. Given `n: nat`, we must consider the constructors `O` and
 * `S`. The tactic `destruct` can be used here.
 *)

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  destruct n as [| n'] eqn:E.
  - simpl plus. (* May be elided. `reflexivity` already does that. *)
    simpl eqb.  (* May be elided. *)
    reflexivity.
  - simpl plus. (* `simpl` again won't do anything since `n'` is unknown. *)
    simpl eqb.  (* See `eqb` definition. *)
    reflexivity.
Qed.

(* The tactic `destruct` will generate two sub goals from the original goal.
 * Each of then will have to be proven separately.
 *
 * ` as [| n'] ` is an **intro pattern**. It tells what variable names should be
 * introduced in each sub goal. In general, it is a list of list of names,
 * separated by `|`.
 * In this case, the first element is empty since the `O` constructor is
 * nullary. The second element gives a single name, ` n' ` to `S`'s element.
 *
 * `eqn:E` tells `destruct` to give the name `E` to the equation. Since the
 * sub goal's equation is named, their assumptions (e.g. `n: nat`, introduced by
 * `intros n`) are not elided (the default behavior without `eqn:E`).
 *
 * `-` signs a bullet. For each sub goal generated by `destruct`, one must
 * handle the respective bullet. Other allowed signals are `-`, `+`, `*`, or a
 * repetition of them, such as `--` or `***`. Useful in nested `destruct`s.
 *)

(* Involutive means that negation is its own inverse. *)
Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b.
  destruct b eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative : forall b c : bool,
  andb b c = andb c b.
Proof.
  intros b c.
  destruct b eqn:EqnB.
  - destruct c eqn:EqnC.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:EqnC.
    + reflexivity.
    + reflexivity.
Qed.

(* The pattern `intros n. destruct n as [| n'] eqn:E.` is so common that
 * exists a shorthand for it. One may perform case analysis on a variable
 * when introducing it by using an intro pattern instead of a variable name.
 *)
Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

(* If there aren't any constructors that need names, `[]` may be used. *)
Theorem andb_commutative' : forall b c : bool,
  andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(* Exercise 7 *)

(* Prove the following claim, marking cases (and sub cases) with bullets when
 * you use destruct. Hint: delay introducing the hypothesis until after you
 * have an opportunity to simplify it. *)
 Theorem andb_true_elim2 : forall b c : bool,
 andb b c = true -> c = true.
Proof.
 intros b c.
 destruct c eqn:EqnC.
 - reflexivity.
 - intros H. rewrite <- H. destruct b eqn:EqnB.
   + reflexivity.
   + reflexivity.
Qed.

(* Exercise 8 *)

Theorem zero_nbeq_plus_1 : forall n : nat,
  eqb 0 (n + 1) = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

(******************************************************************************)

(*
 * FIXPOINTS AND STRUCTURAL RECURSION
 *)

(* A fixpoint definition operates on structural recursion. In order to guarantee
 * that every function that can be defined in Coq will terminate on all inputs,
 * Coq demands that at least one argument of every `Fixpoint` is _decreasing_.
 *)

 (* Fixpoint factorial' (n i acc : nat) : nat :=
  if i =? n
    then i * acc
    else (factorial' n (i + 1) (acc * i)). *)

(******************************************************************************)

(*
 * MORE EXERCISES
 *)

(* Exercise 9 *)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool),
  f (f b) = b.
Proof.
  intros hyp1 hyp2 b.
  rewrite -> hyp2. rewrite -> hyp2.
  reflexivity.
Qed.

(* Exercise 10 *)

Definition manual_grade_for_negation_fn_applied_twice :
  option (nat * string) := None.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool),
  f (f b) = b.
Proof.
  intros hyp1 hyp2 b.
  rewrite -> hyp2. rewrite -> hyp2.
  destruct b.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(* Exercise 11 *)

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c.
  destruct b.
  - simpl. intros hyp. rewrite <- hyp. reflexivity.
  - simpl. intros hyp. rewrite <- hyp. reflexivity.
Qed.

(* Exercise 12 *)

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Fixpoint incr (m : bin) : bin :=
  match m with
  | Z => B1 Z
  | B0 m' => B1 m'
  | B1 m' => B0 (incr m')
  end.

Fixpoint decr (m : bin) : bin :=
  match m with
  | Z => Z
  | B0 m' => B1 (decr m')
  | B1 Z => Z
  | B1 m' => B0 m'
  end.

Fixpoint bin_to_nat (m : bin) : nat :=
  match m with
  | Z => 0
  | B0 m' => 2 * (bin_to_nat m')
  | B1 m' => 1 + 2 * (bin_to_nat m')
  end.

Example test_bin_decr1 : (decr Z) = Z.
Proof. simpl. reflexivity. Qed.
Example test_bin_decr2 : (decr (B1 Z)) = Z.
Proof. simpl. reflexivity. Qed.
Example test_bin_decr3 : (decr (B0 (B1 Z))) = B1 Z.
Proof. simpl. reflexivity. Qed.
Example test_bin_decr4 : (decr (B1 (B1 Z))) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_decr5 : (decr (B0 (B0 (B1 Z)))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr4 : bin_to_nat (B0 (B1 Z)) = 2.
Proof. simpl. reflexivity. Qed.
Example test_bin_incr5 :
        bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr6 :
        bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
Proof. simpl incr. simpl bin_to_nat. simpl. reflexivity. Qed.


(*********************************************************************************

 Every monad gives rise to an adjunction

 If a bicategory has Eilenberg-Moore objects, then every monad arises from an
 adjunction. This is the so-called free-algebra adjunction.

 This generalizes the construction in Monads.MonadAlgebras.v.
 Note: since we can instantiate this construction for Kleisli objects as well, the
 construction also generalizes the construction in Monads.KleisliCategory.v

 Contents
 1. Adjunction from monad
 2. The monad from the adjunction from a monad is equivalent to the original monad

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Monads.Examples.AdjunctionToMonad.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion.

Local Open Scope cat.

Section MonadToAdjunction.
  Context {B : bicat}
          (HB : bicat_has_em B)
          (m : mnd B).

  Let x : B := ob_of_mnd m.
  Let f : x --> x := endo_of_mnd m.
  Let η : id₁ _ ==> f := unit_of_mnd m.
  Let μ : f · f ==> f := mult_of_mnd m.

  Let e : em_cone m := pr1 (HB m).
  Let He : has_em_ump _ e := pr2 (HB m).

  Let l : e --> x := mor_of_mnd_mor (mor_of_em_cone _ e).
  Let lf : l · f ==> l := mnd_mor_endo (mor_of_em_cone _ e) • lunitor _.

  (**
   1. Adjunction from monad
   *)
  Definition free_alg_1cell_cone
    : em_cone m.
  Proof.
    use make_em_cone.
    - exact x.
    - exact f.
    - exact (μ • linvunitor _).
    - abstract
        (refine (!(id2_left _) @ _) ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         refine (!_) ;
         exact (mnd_unit_right m)).
    - abstract
        (rewrite !vassocr ;
         apply maponpaths_2 ;
         rewrite !vassocl ;
         use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
         rewrite !vassocr ;
         rewrite rwhisker_vcomp ;
         rewrite !vassocl ;
         rewrite linvunitor_lunitor ;
         rewrite id2_right ;
         rewrite !vassocr ;
         exact (!(mnd_mult_assoc m))).
  Defined.

  Definition free_alg_1cell
    : x --> e
    := em_ump_1_mor _ He free_alg_1cell_cone.

  Definition mnd_to_unit
    : id₁ x ==> free_alg_1cell · l
    := η • cell_of_mnd_cell ((em_ump_1_inv2cell _ He free_alg_1cell_cone)^-1).

  Definition mnd_to_counit_cell_data
    : mnd_cell_data
        (# (mnd_incl B) (l · free_alg_1cell) · mor_of_em_cone m e)
        (# (mnd_incl B) (id₁ e) · mor_of_em_cone m e)
    := rassociator _ _ _
       • (_ ◃ cell_of_mnd_cell (em_ump_1_inv2cell _ He free_alg_1cell_cone))
       • mnd_mor_endo (mor_of_em_cone m e).

  Local Definition em_ump_mnd_cell_endo_help
    : (_ ◃ mnd_mor_endo (mor_of_em_cone m e))
      • lassociator _ _ _
      • (runitor _ ▹ _)
      • cell_of_mnd_cell (em_ump_1_inv2cell m He free_alg_1cell_cone)
      =
      lassociator _ _ _
      • (cell_of_mnd_cell (em_ump_1_inv2cell m He free_alg_1cell_cone) ▹ endo_of_mnd m)
      • μ.
  Proof.
    refine (_ @ vassocr _ _ _).
    use vcomp_move_L_pM ; [ is_iso | ].
    use (vcomp_rcancel (linvunitor _)) ; [ is_iso | ].
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite linvunitor_natural.
      rewrite <- lwhisker_hcomp.
      rewrite linvunitor_assoc.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      apply idpath.
    }
    refine (_ @ mnd_cell_endo (em_ump_1_inv2cell m He free_alg_1cell_cone)).
    rewrite !vassocr.
    apply idpath.
  Qed.

  Definition mnd_to_counit_is_mnd_cell
    : is_mnd_cell mnd_to_counit_cell_data.
  Proof.
    unfold is_mnd_cell ; cbn.
    unfold mnd_to_counit_cell_data.
    rewrite runitor_lunitor_identity.
    rewrite lunitor_linvunitor.
    rewrite id2_rwhisker.
    rewrite id2_right.
    rewrite !vassocl.
    rewrite lassociator_rassociator.
    rewrite id2_right.
    rewrite !vassocr.
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    etrans.
    {
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite lwhisker_hcomp.
        rewrite <- inverse_pentagon_3.
        rewrite <- rwhisker_hcomp.
        apply idpath.
      }
      rewrite !vassocl.
      rewrite lwhisker_lwhisker_rassociator.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        do 3 apply maponpaths_2.
        rewrite rwhisker_vcomp.
        apply maponpaths.
        rewrite linvunitor_assoc.
        rewrite !vassocl.
        rewrite rassociator_lassociator.
        rewrite id2_right.
        rewrite <- runitor_triangle.
        apply idpath.
      }
      rewrite !vassocl.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          apply maponpaths_2.
          rewrite rwhisker_rwhisker_alt.
          rewrite !vassocl.
          rewrite vcomp_whisker.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        do 4 apply maponpaths_2.
        rewrite rwhisker_hcomp.
        rewrite !vassocl.
        rewrite <- inverse_pentagon_4.
        rewrite <- lwhisker_hcomp.
        apply idpath.
      }
      apply maponpaths.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      rewrite !vassocr.
      apply em_ump_mnd_cell_endo_help.
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    rewrite <- rassociator_rassociator.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rassociator_lassociator.
      rewrite lwhisker_id2.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite rwhisker_lwhisker_rassociator.
    rewrite !vassocl.
    apply maponpaths.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite <- linvunitor_assoc.
      rewrite lwhisker_hcomp.
      rewrite <- linvunitor_natural.
      apply idpath.
    }
    use vcomp_move_R_pM ; [ is_iso | ].
    rewrite !vassocr.
    use vcomp_move_R_Mp ; [ is_iso | ].
    refine (!_).
    refine (_ @ mnd_mor_mu (mor_of_em_cone m e)).
    rewrite !vassocl.
    do 4 apply maponpaths.
    refine (!_).
    apply lunitor_triangle.
  Qed.

  Definition mnd_to_counit_mnd_cell
    : # (mnd_incl B) (l · free_alg_1cell) · mor_of_em_cone m e
      ==>
      # (mnd_incl B) (id₁ e) · mor_of_em_cone m e.
  Proof.
    use make_mnd_cell.
    - exact mnd_to_counit_cell_data.
    - exact mnd_to_counit_is_mnd_cell.
  Defined.

  Definition mnd_to_counit
    : l · free_alg_1cell ==> id₁ e
    := em_ump_2_cell _ He mnd_to_counit_mnd_cell.

  Definition mnd_to_left_adjoint_data
    : left_adjoint_data free_alg_1cell
    := l ,, (mnd_to_unit ,, mnd_to_counit).

  Local Definition em_ump_mnd_cell_endo_inv_help
    : (cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) ▹ endo_of_mnd m)
      • rassociator _ _ _
      • (_ ◃ mnd_mor_endo (mor_of_em_cone m e))
      =
      μ
      • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)
      • (_ ◃ linvunitor _).
  Proof.
    use (vcomp_rcancel (lassociator _ _ _ • ((runitor _) ▹ _) • linvunitor _)) ; [ is_iso | ].
    refine (!_).
    etrans.
    {
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite lwhisker_hcomp.
      rewrite !vassocr.
      etrans.
      {
        do 2 apply maponpaths_2.
        apply triangle_l_inv.
      }
      rewrite <- rwhisker_hcomp.
      apply maponpaths_2.
      refine (rwhisker_vcomp _ _ _ @ _).
      rewrite rinvunitor_runitor.
      apply id2_rwhisker.
    }
    rewrite id2_left.
    rewrite linvunitor_natural.
    rewrite <- lwhisker_hcomp.
    refine (vassocr _ _ _ @ _).
    refine (mnd_cell_endo ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) @ _).
    rewrite !vassocl.
    apply maponpaths.
    cbn.
    rewrite !vassocl.
    do 3 apply maponpaths.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocl.
    apply maponpaths.
    rewrite linvunitor_assoc.
    apply idpath.
  Qed.

  Definition mnd_to_left_adjoint_axioms
    : left_adjoint_axioms mnd_to_left_adjoint_data.
  Proof.
    split.
    - use (em_ump_eq _ He).
      + apply id₂.
      + use eq_mnd_cell ; cbn.
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !rwhisker_hcomp.
          rewrite <- triangle_l.
          rewrite <- lwhisker_hcomp, <- rwhisker_hcomp.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker_rassociator.
          apply maponpaths_2.
          do 2 apply maponpaths.
          exact (maponpaths
                   cell_of_mnd_cell
                   (em_ump_2_eq _ He mnd_to_counit_mnd_cell)).
        }
        cbn ; unfold mnd_to_counit_cell_data.
        rewrite !vassocl.
        rewrite lwhisker_vcomp.
        rewrite !vassocl.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite <- !lwhisker_vcomp.
          rewrite !vassocr.
          rewrite rassociator_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_rwhisker_alt.
          rewrite !vassocl.
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        unfold mnd_to_unit.
        rewrite !vassocr.
        rewrite <- linvunitor_assoc.
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite vcomp_whisker.
          rewrite !vassocl.
          apply idpath.
        }
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          apply maponpaths_2.
          apply em_ump_mnd_cell_endo_inv_help.
        }
        etrans.
        {
          rewrite !vassocr.
          etrans.
          {
            do 5 apply maponpaths_2.
            rewrite lwhisker_hcomp.
            rewrite <- linvunitor_natural.
            apply idpath.
          }
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            do 3 apply maponpaths_2.
            apply mnd_unit_left.
          }
          rewrite id2_left.
          rewrite !vassocr.
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            exact (maponpaths
                     cell_of_mnd_cell
                     (vcomp_rinv (em_ump_1_inv2cell m He free_alg_1cell_cone))).
          }
          apply id2_left.
        }
        rewrite lwhisker_vcomp.
        rewrite linvunitor_lunitor.
        apply lwhisker_id2.
      + rewrite psfunctor_id2.
        apply id2_rwhisker.
    - cbn.
      rewrite !vassocl.
      unfold mnd_to_unit.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        apply maponpaths_2.
        exact (maponpaths
                 cell_of_mnd_cell
                 (em_ump_2_eq _ He mnd_to_counit_mnd_cell)).
      }
      simpl.
      unfold mnd_to_counit_cell_data.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        do 2 apply maponpaths_2.
        apply maponpaths.
        exact (maponpaths
                 cell_of_mnd_cell
                 (vcomp_linv (em_ump_1_inv2cell m He free_alg_1cell_cone))).
      }
      cbn.
      rewrite lwhisker_id2.
      rewrite id2_left.
      rewrite !vassocr.
      use vcomp_move_R_Mp ; [ is_iso | ].
      refine (!(mnd_mor_unit (mor_of_em_cone m e)) @ _).
      cbn.
      rewrite id2_rwhisker.
      rewrite id2_left, id2_right.
      apply idpath.
  Qed.

  Definition mnd_to_left_adjoint
    : left_adjoint free_alg_1cell
    := mnd_to_left_adjoint_data ,, mnd_to_left_adjoint_axioms.

  Definition mnd_to_adjunction
    : adjunction x e
    := free_alg_1cell ,, mnd_to_left_adjoint.

  (**
   2. The monad from the adjunction from a monad is equivalent to the original monad
   *)
  Definition mnd_to_adjunction_to_mnd_data
    : mnd_mor_data
        (mnd_from_adjunction mnd_to_adjunction)
        m.
  Proof.
    use make_mnd_mor_data.
    - exact (id₁ _).
    - exact (lunitor _
             • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone)^-1)
             • rinvunitor _).
  Defined.

  Definition mnd_to_adjunction_to_mnd_law₁
    : linvunitor (id₁ x)
      • (mnd_to_unit ▹ id₁ x)
      =
      rinvunitor (id₁ x)
      • (id₁ x ◃ unit_of_mnd m)
      • ((lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1))
     • rinvunitor _).
  Proof.
    rewrite lunitor_V_id_is_left_unit_V_id.
    rewrite !vassocl.
    apply maponpaths.
    unfold mnd_to_unit.
    rewrite !vassocr.
    rewrite vcomp_lunitor.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite lunitor_runitor_identity.
    rewrite runitor_rinvunitor.
    rewrite id2_left.
    apply idpath.
  Qed.

  Definition mnd_to_adjunction_to_mnd_law₂
    : lassociator (id₁ _) f f
      • ((lunitor f
          • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)
          • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e)))
         ▹ endo_of_mnd m)
      • rassociator (free_alg_1cell · l) (id₁ x) f
      • (free_alg_1cell · l
           ◃ (lunitor f
              • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)
              • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e))))
      • lassociator (free_alg_1cell · l) (free_alg_1cell · l) (id₁ x)
      • ((((rassociator free_alg_1cell l (free_alg_1cell · l)
            • (free_alg_1cell ◃ lassociator l free_alg_1cell l))
            • (free_alg_1cell ◃ (mnd_to_counit ▹ l)))
            • (free_alg_1cell ◃ lunitor l)) ▹ id₁ x)
      =
      (id₁ x ◃ μ)
      • ((lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1))
      • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e))).
  Proof.
    rewrite <- !lwhisker_vcomp.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocr.
    rewrite lunitor_triangle.
    rewrite vcomp_lunitor.
    rewrite !vassocl.
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      do 7 apply maponpaths_2.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite lwhisker_id2.
      apply idpath.
    }
    rewrite id2_left.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rinvunitor_triangle.
      rewrite !vassocl.
      rewrite !rwhisker_vcomp.
      rewrite rwhisker_hcomp.
      rewrite <- rinvunitor_natural.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      do 4 apply maponpaths.
      apply maponpaths_2.
      apply maponpaths.
      pose (p := maponpaths cell_of_mnd_cell (em_ump_2_eq m He mnd_to_counit_mnd_cell)).
      cbn in p.
      exact p.
    }
    unfold mnd_to_counit_cell_data.
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      etrans.
      {
        do 2 apply maponpaths_2.
        rewrite <- !lwhisker_vcomp.
        rewrite !vassocr.
        apply maponpaths_2.
        apply lwhisker_lwhisker_rassociator.
      }
      apply maponpaths_2.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      do 3 apply maponpaths_2.
      rewrite lwhisker_vcomp.
      etrans.
      {
        apply maponpaths.
        exact (maponpaths
                 cell_of_mnd_cell
                 (vcomp_linv (em_ump_1_inv2cell m He free_alg_1cell_cone))).
      }
      apply lwhisker_id2.
    }
    rewrite id2_left.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    use (vcomp_rcancel (linvunitor _)) ; [ is_iso | ].
    pose (p := mnd_cell_endo ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)).
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      rewrite linvunitor_natural.
      rewrite <- lwhisker_hcomp.
      rewrite !vassocr.
      exact p.
    }
    apply maponpaths.
    cbn.
    rewrite !vassocl.
    apply maponpaths.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    rewrite <- linvunitor_assoc.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    rewrite <- !lwhisker_vcomp.
    rewrite runitor_rwhisker.
    apply idpath.
  Qed.

  Definition mnd_to_adjunction_to_mnd_laws
    : mnd_mor_laws mnd_to_adjunction_to_mnd_data.
  Proof.
    split.
    - exact mnd_to_adjunction_to_mnd_law₁.
    - exact mnd_to_adjunction_to_mnd_law₂.
  Qed.

  Definition mnd_to_adjunction_to_mnd
    : mnd_from_adjunction mnd_to_adjunction
      -->
      m.
  Proof.
    use make_mnd_mor.
    - exact mnd_to_adjunction_to_mnd_data.
    - exact mnd_to_adjunction_to_mnd_laws.
  Defined.

  Definition mnd_to_adjunction_to_mnd_adj_equivalence
             (HB_2_0 : is_univalent_2_0 B)
    : left_adjoint_equivalence mnd_to_adjunction_to_mnd.
  Proof.
    use to_equivalence_mnd.
    - exact HB_2_0.
    - apply internal_adjoint_equivalence_identity.
    - cbn.
      is_iso.
      apply (from_invertible_mnd_2cell
               (inv_of_invertible_2cell (em_ump_1_inv2cell m He free_alg_1cell_cone))).
  Defined.
End MonadToAdjunction.


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

Require Import Arith Lia.
Require Import Classical Peano_dec.
(*From hahn*) Require Import Hahn.
Require Import Events.

Set Implicit Arguments.

(** Definition of an execution *)
Record execution :=
  { acts : list actid;
    lab : actid -> label;
    iico_data : actid -> actid -> Prop ;   (** intrinsic data dependency *)
    iico_ctrl : actid -> actid -> Prop ;   (** intrinsic control dependency *)

    data : actid -> actid -> Prop ;   (** data dependency *)
    addr : actid -> actid -> Prop ;   (** address dependency *)
    ctrl : actid -> actid -> Prop ;   (** control dependency *)
    lxsx : actid -> actid -> Prop ;   (** load-exclusive -> store-exclusive *)
    amo : actid -> actid -> Prop ;    (** read -> write of atomic operation *)

    (* Representation of a data dependency to CAS.
        It goes from a read to an exclusive read.
        Consider the example:

        a := read (x);
        CAS(y, a, 1);

        In the execution, there is an rmw_dep edge between a read event representing `a := ⦗x⦘'
        and a read event representing `CAS(y, a, 1)'.
     *)
    (* rmw_dep : actid -> actid -> Prop ; *)

    rf : actid -> actid -> Prop ;
    co : actid -> actid -> Prop ;
  }.

Section Execution.

Variable G : execution.

Definition acts_set := fun x => In x (acts G).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Notation "'E'" := acts_set.
Notation "'lab'" := (lab G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'lxsx'" := (lxsx G).
Notation "'amo'" := (amo G).
Notation "'data'" := (data G).
Notation "'addr'" := (addr G).
Notation "'ctrl'" := (ctrl G).

Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'same_loc'" := (same_loc lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Br'" := (fun a => is_true (is_br lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).

Definition po := ⦗E⦘ ⨾ ext_sb ⨾  ⦗E⦘.
Definition si := ⦗E⦘ ⨾ ext_si ⨾  ⦗E⦘.
Definition rmw := lxsx ∪ amo.

Record Wf :=
  { data_in_po : data ⊆ po ;
    wf_dataD : data ≡ ⦗R⦘ ⨾ data ⨾ ⦗W⦘ ;
    addr_in_po : addr ⊆ po ;
    wf_addrD : addr ≡ ⦗R⦘ ⨾ addr ⨾ ⦗RW⦘ ;
    ctrl_in_po : ctrl ⊆ po ;
    wf_ctrlD : ctrl ≡ ⦗R⦘ ⨾ ctrl ;
    ctrl_po : ctrl ⨾ po ⊆ ctrl ;
    wf_rmwD : rmw ≡ ⦗R⦘ ⨾ rmw ⨾ ⦗W⦘ ;
    wf_rmwl : rmw ⊆ same_loc ;
    wf_rmwi : rmw ⊆ immediate po ;

    wf_siD     : forall x y, si x y -> si_matching_label (lab x) (lab y) ;
    wf_sil     : si ∩ same_loc ≡ ⦗ E ⦘ ;
    wf_si_data : si ⨾ data ⨾ si ⊆ data ;
    wf_si_ctrl : si ⨾ ctrl ⨾ si ⊆ ctrl ;
    wf_si_addr : si ⨾ addr ⨾ si ⊆ addr ;
    si_lxsx    : si ⨾ lxsx ≡ lxsx ⨾ si ;
    si_amo     : si ⨾ amo ≡ amo ⨾ si ;

    wf_rfE : rf ≡ ⦗E⦘ ⨾ rf ⨾ ⦗E⦘ ;
    wf_rfD : rf ≡ ⦗W⦘ ⨾ rf ⨾ ⦗R⦘ ;
    wf_rfl : rf ⊆ same_loc ;
    wf_rfv : funeq val rf ;
    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 ol, is_total (E ∩₁ W ∩₁ (fun x => loc x = ol)) co ;
    co_irr : irreflexive co ;
    wf_init : forall l, (exists b, E b /\ loc b = Some l) -> E (InitEvent l) ;
    wf_init_lab : forall l, lab (InitEvent l) = Astore false Opln_write l 0 ;
  }.

Implicit Type WF : Wf.

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

(* reads-before, aka from-read *)
Definition fr := rf⁻¹ ⨾ co.

Definition deps := data ∪ addr ∪ ctrl.

(******************************************************************************)
(** ** Consistency definitions  *)
(******************************************************************************)

Definition complete := E ∩₁ R  ⊆₁ codom_rel rf.
Definition rmw_atomicity := rmw ∩ ((fr \ po) ⨾ (co \ po)) ⊆ ∅₂.

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

Lemma po_trans : transitive po.
Proof using.
  unfold po; unfolder; ins; desf; splits; auto.
  eby eapply ext_sb_trans.
Qed.

Lemma po_po : po ⨾ po ⊆ po.
Proof using.
  generalize po_trans; basic_solver 21.
Qed.

Lemma po_same_loc_trans: transitive (po ∩ same_loc).
Proof using.
  apply transitiveI.
  unfold Events.same_loc.
  unfolder; ins; desf; eauto.
  splits.
  generalize po_trans; basic_solver 21.
  congruence.
Qed.

Lemma po_same_loc_W_trans : transitive (po ∩ same_loc ⨾ ⦗W⦘).
Proof using.
  generalize po_same_loc_trans; unfold transitive.
  basic_solver 21.
Qed.

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

Lemma po_neq_loc_in_po : po \ same_loc ⊆ po.
Proof using. basic_solver. Qed.

Lemma fr_co WF : fr ⨾ co ⊆ fr.
Proof using. by unfold fr; rewrite seqA, rewrite_trans; [|apply WF]. Qed.

Lemma rmw_in_po WF: rmw ⊆ po.
Proof using. rewrite wf_rmwi; basic_solver. Qed.

Lemma deps_in_po WF: deps ⊆ po.
Proof using. unfold deps; unionL; apply WF. Qed.

Lemma amo_in_po WF: amo ⊆ po.
Proof using. eapply inclusion_trans, rmw_in_po; vauto. Qed.

Lemma lxsx_in_po WF: lxsx ⊆ po.
Proof using. eapply inclusion_trans, rmw_in_po; vauto. 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.

Lemma loceq_rmw WF : funeq loc rmw.
Proof using. apply WF. Qed.

Lemma loceq_fr WF : funeq loc fr.
Proof using.
  generalize (loceq_co WF), (loceq_rf WF).
  unfold funeq, fr; unfolder; ins; desf.
  transitivity (loc z); eauto using sym_eq.
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.

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

Lemma wf_poE : po ≡ ⦗E⦘ ⨾ po ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; unfold po; basic_solver.
Qed.

Lemma wf_dataE WF: data ≡ ⦗E⦘ ⨾ data ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite data_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_addrE WF: addr ≡ ⦗E⦘ ⨾ addr ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite addr_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_ctrlE WF: ctrl ≡ ⦗E⦘ ⨾ ctrl ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite ctrl_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_depsE WF: deps ≡ ⦗E⦘ ⨾ deps ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite deps_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_amoE WF: amo ≡ ⦗E⦘ ⨾ amo ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite amo_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_lxsxE WF: lxsx ≡ ⦗E⦘ ⨾ lxsx ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite lxsx_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_rmwE WF : rmw ≡ ⦗E⦘ ⨾ rmw ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite rmw_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_frE WF : fr ≡ ⦗E⦘ ⨾ fr ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; unfold fr;
    rewrite wf_rfE, wf_coE; basic_solver.
Qed.

Lemma wf_siE WF: si ≡ ⦗E⦘ ⨾ si ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; unfold si; basic_solver.
Qed.

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

Lemma wf_frD WF : fr ≡ ⦗R⦘ ⨾ fr ⨾ ⦗W⦘.
Proof using.
  apply doms_helper; unfold fr;
    rewrite wf_rfD, wf_coD; basic_solver.
Qed.

Lemma wf_depsD WF : deps ≡ ⦗R⦘ ⨾ deps.
Proof using.
  split; [|basic_solver].
  unfold deps.
  rewrite (wf_dataD WF) at 1.
  rewrite (wf_ctrlD WF) at 1.
  rewrite (wf_addrD WF) at 1.
  basic_solver.
Qed.

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

Lemma po_irr : irreflexive po.
Proof using.
  unfold po; unfolder; ins; desf.
  eby eapply ext_sb_irr.
Qed.

Lemma fr_irr WF : irreflexive fr.
Proof using.
  rewrite (wf_frD WF); type_solver.
Qed.

(******************************************************************************)
(** ** Same instruction *)
(******************************************************************************)

Lemma si_po : si ⨾ po ≡ po.
Proof using.
  unfold si, po, ext_si, ext_sb; unfolder; splits; ins; desf; desf; splits; ins.
  exists (InitEvent l); ins.
  eexists (ThreadEvent _ _ _); splits; ins; eauto.
Qed.

Lemma po_si : po ⨾ si ≡ po.
Proof using.
  unfold si, po; unfolder; splits; ins; desf; splits; ins;
    try exists y; unfold ext_si, ext_sb in *; desf; desf.
Qed.

Lemma si_refl x (EV: E x) :  si x x.
Proof using.
  unfold si in *; unfolder; auto using ext_si_refl.
Qed.

Lemma si_sym :  symmetric si.
Proof using.
  unfold si in *; unfolder; ins; desf.
  eauto 8 using ext_si_symm.
Qed.

Lemma si_trans : transitive si.
Proof using.
  unfold si in *; unfolder; ins; desf; eauto using ext_si_trans.
Qed.

Lemma si_si : si ⨾ si ≡ si.
Proof using.
  unfold si; unfolder; split; ins; desf; splits; ins.
  eapply ext_si_trans; eauto.
  eauto 6 using ext_si_refl.
Qed.

Lemma si_rmw WF : si ⨾ rmw ≡ rmw ⨾ si.
Proof using.
  unfold rmw; relsf; rewrite si_amo, si_lxsx; ins.
Qed.

Lemma addr_si WF : addr ⨾ si ≡ addr.
Proof using.
  rewrite wf_addrE; ins.
  assert (X := wf_si_addr WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma ctrl_si WF : ctrl ⨾ si ≡ ctrl.
Proof using.
  rewrite wf_ctrlE; ins.
  assert (X := wf_si_ctrl WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma data_si WF : data ⨾ si ≡ data.
Proof using.
  rewrite wf_dataE; ins.
  assert (X := wf_si_data WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma si_addr WF : si ⨾ addr ≡ addr.
Proof using.
  rewrite wf_addrE; ins.
  assert (X := wf_si_addr WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma si_ctrl WF : si ⨾ ctrl ≡ ctrl.
Proof using.
  rewrite wf_ctrlE; ins.
  assert (X := wf_si_ctrl WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold Execution.si in *; unfolder in *; desf.
Qed.

Lemma si_data WF : si ⨾ data ≡ data.
Proof using.
  rewrite wf_dataE; ins.
  assert (X := wf_si_data WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold Execution.si in *; unfolder in *; desf.
Qed.

Lemma W_si WF : ⦗W⦘ ⨾ si ≡ si ⨾ ⦗W⦘.
Proof using.
  unfolder; ins; desf; splits; ins; desf; splits; eauto.
  eapply (wf_siD WF) in H0; unfolder in *; desf; type_solver.
  eapply (wf_siD WF) in H; unfolder in *; desf; type_solver.
Qed.

Lemma R_si WF : ⦗R⦘ ⨾ si ≡ si ⨾ ⦗R⦘.
Proof using.
  unfolder; ins; desf; splits; ins; desf; splits; eauto.
  eapply (wf_siD WF) in H0; unfolder in *; desf; type_solver.
  eapply (wf_siD WF) in H; unfolder in *; desf; type_solver.
Qed.

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

Lemma po_acyclic : acyclic po.
Proof using.
  apply trans_irr_acyclic; [apply po_irr| apply po_trans].
Qed.

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

Lemma wf_po : well_founded po.
Proof using.
  eapply wf_finite; auto.
  apply po_acyclic.
  rewrite (dom_l wf_poE).
  unfold doma; basic_solver.
Qed.

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

Lemma init_w WF: is_init ⊆₁ W.
Proof using.
  unfolder; ins.
  unfold is_init in *; destruct x; desf.
  specialize (wf_init_lab WF l); unfold is_w; desf.
Qed.

Lemma read_or_fence_is_not_init WF a (A: R a \/ F a) : ~ is_init a.
Proof using.
  generalize ((init_w WF) a).
  type_solver.
Qed.

Lemma no_po_to_init : po ≡ po ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
  split; [|basic_solver].
  unfold po; 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.
  generalize (read_or_fence_is_not_init WF).
  basic_solver 42.
Qed.

Lemma rmw_from_non_init WF : rmw ≡ ⦗fun x => ~ is_init x⦘ ⨾ rmw.
Proof using.
  split; [|basic_solver].
  rewrite (wf_rmwD WF).
  generalize (read_or_fence_is_not_init WF).
  basic_solver 42.
Qed.

Lemma rmw_non_init_lr WF : rmw ≡ ⦗set_compl is_init⦘ ⨾ rmw ⨾ ⦗set_compl is_init⦘.
Proof using.
  split; [|basic_solver].
  rewrite (rmw_from_non_init WF) at 1.
  rewrite <- seqA.
  apply codom_rel_helper.
  rewrite (rmw_in_po WF).
  rewrite no_po_to_init.
  basic_solver.
Qed.

Lemma init_same_loc WF a b (A: is_init a) (B: is_init b) (LOC: loc a = loc b):
  a = b.
Proof using.
destruct a, b; desf.
cut (l = l0); [by ins; subst|].
unfold Events.loc in LOC.
rewrite (wf_init_lab WF l), (wf_init_lab WF l0) in LOC; desf.
Qed.

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

Lemma po_semi_total_l x y z :
  po x y -> po x z -> is_init x /\ ~ is_init y /\ ~ is_init z \/ po y z \/ po z y \/ si y z.
Proof using.
  unfold Execution.po, Execution.si, ext_sb, ext_si; ins; unfolder in *; desf; desf;
    ins; eauto 6.
  right; forward eapply (Nat.lt_trichotomy index0 index1) as K; desf.
    + left; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; right; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; left; eexists; splits; eauto; eexists; splits; eauto; ins.
Qed.

Lemma po_semi_total_r x y z :
  po y x -> po z x -> po y z \/ po z y \/ is_init y /\ is_init z \/ si y z.
Proof using.
  unfold Execution.po, Execution.si, ext_sb, ext_si; ins; unfolder in *; desf; desf; eauto.
  - left; eexists; splits; eauto; eexists; splits; eauto; ins.
  - right; left; eexists; splits; eauto; eexists; splits; eauto; ins.
  - forward eapply (Nat.lt_trichotomy index index1) as K; desf.
    + left; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; right; right; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; left; eexists; splits; eauto; eexists; splits; eauto; ins.
Qed.

Lemma po_tid_init x y (PO : po x y): tid x = tid y \/ is_init x.
Proof using.
  generalize ext_sb_tid_init; unfold po in *.
  unfolder in *; basic_solver.
Qed.

Lemma E_ntid_po_prcl thread :
  dom_rel (⦗set_compl is_init⦘ ⨾ po ⨾ ⦗E ∩₁ NTid_ thread⦘) ⊆₁ E ∩₁ NTid_ thread.
Proof using.
  rewrite (dom_l wf_poE).
  unfolder. ins. desf. splits; auto.
  match goal with
  | H : po _ _ |- _ => rename H into PO
  end.
  apply po_tid_init in PO. desf.
  intros BB. rewrite BB in *. desf.
Qed.

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

Lemma ninit_po_same_tid : ⦗ set_compl is_init ⦘ ⨾ po ⊆ same_tid.
Proof using.
  rewrite po_tid_init'.
  basic_solver.
Qed.

Lemma same_tid_trans : transitive same_tid.
Proof using.
  red. unfold same_tid. ins.
  etransitivity; eauto.
Qed.

Lemma rf_rf WF : rf ⨾ rf ≡ ∅₂.
Proof using. rewrite (wf_rfD WF); type_solver. Qed.
Lemma rf_co WF : rf ⨾ co ≡ ∅₂.
Proof using. rewrite (wf_rfD WF), (wf_coD WF); type_solver. Qed.
Lemma co_transp_rf WF : co ⨾  rf⁻¹ ≡ ∅₂.
Proof using. rewrite (wf_rfD WF), (wf_coD WF); type_solver. Qed.
Lemma co_fr WF : co ⨾ fr ≡ ∅₂.
Proof using. rewrite (wf_coD WF), (wf_frD WF); type_solver. Qed.
Lemma fr_fr WF : fr ⨾ fr ≡ ∅₂.
Proof using. rewrite (wf_frD WF); type_solver. Qed.
Lemma rf_transp_rf WF: rf ⨾ rf⁻¹ ⊆ ⦗fun _ => True⦘.
Proof using. by apply functional_alt, WF. Qed.
Lemma rf_fr WF : rf ⨾ fr ⊆ co.
Proof using. unfold fr; sin_rewrite rf_transp_rf; rels. Qed.
Lemma rmw_in_po_loc WF: rmw ⊆ po ∩ same_loc.
Proof using. by rewrite (loceq_same_loc (loceq_rmw WF)), (rmw_in_po WF). Qed.
Lemma rf_irr WF: irreflexive rf.
Proof using. rewrite (wf_rfD WF); type_solver. Qed.
Lemma co_co WF: co ⨾ co ⊆ co.
Proof using. apply rewrite_trans, WF. Qed.

Lemma wf_rmwf WF: functional rmw.
Proof using.
  rewrite (rmw_from_non_init WF).
  arewrite (rmw ⊆ rmw ∩ rmw).
  rewrite (wf_rmwi WF) at 1.
  rewrite (wf_rmwl WF) at 1.
  unfolder; ins; desc.
  forward eapply po_semi_total_l with (y:=y) (z:=z) as X; eauto; desf.
  all: try solve [exfalso; eauto].
  apply (wf_sil WF); split; ins; congruence.
Qed.

Lemma wf_rmw_invf WF: functional (rmw)⁻¹.
Proof using.
  rewrite (rmw_from_non_init WF).
  arewrite (rmw ⊆ rmw ∩ rmw).
  rewrite (wf_rmwi WF) at 1.
  rewrite (wf_rmwl WF) at 1.
  unfolder; ins; desc.
  forward eapply po_semi_total_r with (y:=y) (z:=z) as X; eauto; desf.
  all: try solve [exfalso; eauto].
  apply (wf_sil WF); split; ins; congruence.
Qed.

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

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

Lemma ri_union_re r : r ≡ r ∩ po ∪ r \ po.
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 ∩ po ⊆ ⦗d1⦘ ⨾ r ∩ po ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.
Lemma re_dom r d1 d2 (DOM: r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘) : r \ po ⊆ ⦗d1⦘ ⨾ (r \ po) ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.

Lemma wf_rfiE WF: rfi ≡ ⦗E⦘ ⨾ rfi ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_rfE WF)). Qed.
Lemma wf_coiE WF: coi ≡ ⦗E⦘ ⨾ coi ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_coE WF)). Qed.
Lemma wf_friE WF: fri ≡ ⦗E⦘ ⨾ fri ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_frE WF)). Qed.
Lemma wf_rfeE WF: rfe ≡ ⦗E⦘ ⨾ rfe ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_rfE WF)). Qed.
Lemma wf_coeE WF: coe ≡ ⦗E⦘ ⨾ coe ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_coE WF)). Qed.
Lemma wf_freE WF: fre ≡ ⦗E⦘ ⨾ fre ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_frE WF)). 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.

Lemma rfi_in_po : rfi ⊆ po.
Proof using. unfold rfi; basic_solver. Qed.

Lemma rfi_in_rf : rfi ⊆ rf.
Proof using. unfold rfi; basic_solver. Qed.

Lemma rfe_in_rf : rfe ⊆ rf.
Proof using. unfold rfe; basic_solver. Qed.

Lemma coi_in_po : coi ⊆ po.
Proof using. unfold coi; basic_solver. Qed.

Lemma coi_in_co : coi ⊆ co.
Proof using. unfold coi; basic_solver. Qed.

Lemma coe_in_co : coe ⊆ co.
Proof using. unfold coe; basic_solver. Qed.

Lemma ninit_rfi_same_tid : ⦗ set_compl is_init ⦘ ⨾ rfi ⊆ same_tid.
Proof using.
  arewrite (rfi ⊆ po).
  apply ninit_po_same_tid.
Qed.

Lemma coi_trans WF : transitive coi.
Proof using.
  apply transitiveI.
  generalize po_trans (co_trans WF). intros PO CO.
  unfold coi.
  unfolder. ins. desf.
  split; [eapply CO|eapply PO]; eauto.
Qed.

Lemma fri_in_po : fri ⊆ po.
Proof using. unfold fri; basic_solver. Qed.

Lemma fri_in_fr : fri ⊆ fr.
Proof using. unfold fri; basic_solver. Qed.

Lemma fre_in_fr : fre ⊆ fr.
Proof using. unfold fre; basic_solver. Qed.

Lemma fri_coi WF : fri ⨾ coi ⊆ fri.
Proof using.
  unfold fri, coi.
  unfolder. ins. desf.
  split.
  { apply fr_co; auto. basic_solver. }
  eapply po_trans; eauto.
Qed.

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

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

(*
Lemma re_ri WF  r r' (IRR: irreflexive r)  (IRR2: irreflexive (r ⨾ po))
  (N: r ⊆ r ⨾  ⦗ fun x => ~ is_init x ⦘): (r \ po) ⨾ (r' ∩ po) ⊆ r ⨾  r' \ po.
Proof using.
  rewrite N at 1.
  unfolder; ins; desf; splits; eauto.
  intro.
  forward eapply po_semi_total_r with (y:=x) (z:=z) as X; eauto; desf.
admit.
  eauto using po_irr.
  eapply po_irr; 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' ⨾ po)):
 ⦗ fun x => ~ is_init x ⦘ ⨾ (r ∩ po) ⨾ (r' \ po) ⊆ r ⨾  r' \ po.
Proof using.
unfolder; ins; desf; splits; eauto.
intro.
eapply po_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_poloc WF : rf ∩ po ⊆ restr_eq_rel loc po.
Proof using. rewrite wf_rfl; basic_solver 12. Qed.
Lemma coi_in_poloc WF : co ∩ po ⊆ restr_eq_rel loc po.
Proof using. rewrite wf_col; basic_solver 12. Qed.
Lemma fri_in_poloc WF : fr ∩ po ⊆ restr_eq_rel loc po.
Proof using. rewrite (loceq_same_loc (loceq_fr WF)).
unfolder; unfold Events.same_loc in *.
ins; desf; splits; eauto; congruence.
Qed.
Lemma rfi_in_poloc' WF : rfi ⊆ po ∩ same_loc.
Proof using. generalize (wf_rfl WF); unfold rfi; basic_solver 12. Qed.
Lemma coi_in_poloc' WF : coi ⊆ po ∩ same_loc.
Proof using. generalize (wf_col WF); unfold coi; basic_solver 12. Qed.
Lemma fri_in_poloc' WF : fri ⊆ po ∩ same_loc.
Proof using. generalize (wf_frl WF); unfold fri; basic_solver 12. Qed.

Lemma rf_rmw_po_minus_po WF: (rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘) \ po ⊆ rfe ⨾ rmw ⨾ po^? ⨾ ⦗W⦘.
Proof using.
rewrite (seq_minus_transitive po_trans).
unionL; [by unfold rfe; basic_solver 12|].
rewrite (rmw_in_po WF) at 1.
arewrite (po ⨾ po^? ⨾ ⦗W⦘ ⊆ po) by generalize po_trans; basic_solver 21.
relsf.
Qed.

Lemma rf_rmw_po_rt_rf WF: ((rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘)^* ⨾ rf) \ po ⊆ po^? ⨾ rfe ⨾ (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf)^*.
Proof using.
rewrite rtE; relsf.
rewrite rtE, minus_union_l.
relsf; unionL; [by unfold rfe; basic_solver 12|].
rewrite (seq_minus_transitive po_trans).
unionL; [|by unfold rfe; basic_solver 12].
unionR right.
rewrite (ct_minus_transitive po_trans).
arewrite ((rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘) ∩ po ⊆ po).
generalize po_trans; ins; relsf.
rewrite (rf_rmw_po_minus_po WF).
rewrite !seqA.
arewrite (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ (rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘)^* ⨾ rf ⊆ (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf )^+); [|done].
rewrite rtE; relsf; unionL; [by econs|].
rewrite ct_seq_swap, !seqA.
rewrite ct_begin at 2.
by rewrite inclusion_t_rt, !seqA.
Qed.

Lemma rmw_rf_ct WF : (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf)^+ ⊆ (rmw ⨾ po^? ⨾ ⦗W⦘ ∪ rfe)^+ ⨾ rf.
Proof using.
  apply inclusion_t_ind_left.
  { hahn_frame; vauto. }
  rewrite ct_begin; hahn_frame; relsf.
  arewrite (rfe ⊆ rf) at 2.
  seq_rewrite (rf_rf WF).
  relsf.
  rewrite rfi_union_rfe; relsf; unionL.
  { arewrite (rfi ⊆ po).
    rewrite (rmw_in_po WF) at 2.
    arewrite (po^? ⨾ ⦗W⦘ ⨾ po ⨾ po ⨾ po^? ⊆ po^?).
    generalize po_trans; basic_solver 21.
    basic_solver 21. }
  rewrite rt_begin at 2.
  rewrite rt_begin at 2.
  basic_solver 42.
Qed.

Lemma rmw_rf_rt_1 WF : (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf)^* ⊆ (rmw ⨾ po^? ⨾ ⦗W⦘ ∪ rfe)^* ⨾ rfi^?.
Proof using.
rewrite rtE; unionL; [basic_solver 12|].
rewrite (rmw_rf_ct WF).
rewrite rfi_union_rfe; relsf.
rewrite inclusion_t_rt.
relsf; unionL.
basic_solver 12.
rewrite rt_end at 2; basic_solver 12.
Qed.

(******************************************************************************)
(** ** exclusive reads/writes *)
(******************************************************************************)

Definition W_ex := codom_rel rmw.

Lemma W_ex_not_init WF : W_ex ⊆₁ set_compl is_init.
Proof using.
  unfolder. ins. desf.
  match goal with
  | H : W_ex _ |- _ => rename H into WEX
  end.
  destruct WEX as [z WEX].
  apply (rmw_in_po WF) in WEX.
  apply no_po_to_init in WEX. unfolder in WEX. desf.
Qed.

Lemma W_ex_in_W WF : W_ex ⊆₁ W.
Proof using.
unfold W_ex; rewrite (dom_r (wf_rmwD WF)); basic_solver.
Qed.

Lemma W_ex_in_E WF : W_ex ⊆₁ E.
Proof using.
  unfold W_ex. rewrite (dom_r (wf_rmwE WF)). basic_solver.
Qed.

Lemma W_ex_eq_EW_W_ex WF : W_ex ≡₁ E ∩₁ W ∩₁ W_ex.
Proof using.
  generalize (W_ex_in_E WF).
  generalize (W_ex_in_W WF).
  clear. basic_solver 10.
Qed.

Lemma rmw_W_ex : rmw ⊆ rmw ⨾ ⦗W_ex⦘.
Proof using.
  unfold W_ex; basic_solver.
Qed.

Lemma W_ex_si WF : ⦗W_ex⦘ ⨾ si ≡ si ⨾ ⦗W_ex⦘.
Proof using.
  unfold W_ex; unfolder; split; ins; desf.
  forward apply (proj2 (si_rmw WF) x0 y); unfolder; ins; desf; eauto.
  forward apply (proj2 (si_rmw WF) x0 x); unfolder; ins; desf; eauto using si_sym.
Qed.

(******************************************************************************)
(** ** rf ; rmw *)
(******************************************************************************)

Lemma wf_rfrmwE WF: rf ⨾ rmw ≡ ⦗ E ⦘ ⨾ (rf ⨾ rmw) ⨾ ⦗ E ⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_rfE WF) at 1.
rewrite (wf_rmwE WF) at 1.
basic_solver.
Qed.

Lemma wf_rfrmwD WF: rf ⨾ rmw ≡ ⦗ W ⦘ ⨾ (rf ⨾ rmw) ⨾ ⦗ W ⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_rfD WF) at 1.
rewrite (wf_rmwD WF) at 1.
basic_solver.
Qed.

Lemma wf_rfrmwl WF: rf ⨾ rmw ⊆ same_loc.
Proof using.
rewrite (wf_rfl WF), (wf_rmwl WF).
generalize same_loc_trans; basic_solver.
Qed.

Lemma wf_rfrmwf WF: functional (rf ⨾ rmw)⁻¹.
Proof using.
hahn_rewrite transp_seq.
by apply functional_seq; [apply wf_rmw_invf|apply WF].
Qed.

Lemma wf_rfirmwf WF : functional (rfi ⨾ rmw)⁻¹.
Proof using. arewrite (rfi ⊆ rf). eapply wf_rfrmwf; eauto. Qed.

Lemma wf_rfermwf WF : functional (rfe ⨾ rmw)⁻¹.
Proof using. arewrite (rfe ⊆ rf). eapply wf_rfrmwf; eauto. Qed.

Lemma rt_rf_rmw : (rf ⨾ rmw)^* ⊆ (rfi ⨾ rmw)^* ⨾ (rfe ⨾ rmw ⨾ (rfi ⨾ rmw)^*)^*.
Proof using.
  eapply rt_ind_left with (P:=fun r=> r); eauto with hahn.
  basic_solver 12.
  intros k H.
  rewrite !seqA, H.
  rewrite rfi_union_rfe; relsf; unionL.
  { rewrite rt_begin at 3.
    basic_solver 21. }
  rewrite (rt_begin (rfe ⨾ rmw ⨾ (rfi ⨾ rmw)^*)) at 2.
  basic_solver 21.
Qed.

Lemma rfi_rmw_in_po_same_loc_W WF : rfi ⨾ rmw ⊆ (po ∩ same_loc) ⨾ ⦗W⦘.
Proof using.
  rewrite (dom_r (wf_rmwD WF)).
  rewrite rfi_in_poloc', rmw_in_po_loc; auto.
  sin_rewrite rewrite_trans; [done|].
  apply po_same_loc_trans.
Qed.

Lemma rfi_rmw_in_po_loc WF : rfi ⨾ rmw ⊆ po ∩ same_loc.
Proof using.
  rewrite (rfi_rmw_in_po_same_loc_W WF). basic_solver.
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 *.