From TLC Require Import LibTactics LibLogic LibSet LibRelation LibFun LibEqual
                        LibInt.
From iris_time.union_find.math Require Import TLCBuffer.

From stdpp Require Import gmap.

From iris.bi Require Import big_op.
From iris_time.heap_lang Require Import proofmode.
From iris_time Require Import Combined.

(* Load extra math libraries. *)
From iris_time.union_find.math Require Import LibNatExtra InverseAckermann.
(* Load the mathematical analysis of UnionFind. *)
From iris_time.union_find.math Require Import UnionFind01Data
     UnionFind02EmptyCreate UnionFind03Link UnionFind04Compress
     UnionFind05IteratedCompression UnionFind06Join UnionFind11Rank
     UnionFind12RankEmptyCreate UnionFind13RankLink UnionFind14RankCompress
     UnionFind15RankJoin UnionFind41Potential UnionFind43PotentialAnalysis
     UnionFind44PotentialJoin.

(* Load the heap_lang code *)
From iris_time.union_find Require Import Code.

Section UnionFind.

Context `{!tctrHeapG Σ} (nmax : nat).

(* An object in the Union Find data structure is represented by an
   heap_lang location. *)
Notation elem := loc.

(* The logical type of the content of a vertex. *)
Inductive content :=
| Root : nat -> val -> content
| Link : elem -> content.

Definition val_of_content (c : content) : option val :=
  match c with
  | Root k v => (λ (k : mach_int), ROOTV(#k, v)) <$> to_mach_int k
  | Link e => Some $ LINKV #e
  end.

Lemma val_of_content_Some :
  forall c v,
    val_of_content c = Some v →
    (∃ (k1 : mach_int) (k2 : nat) v', v = ROOTV(#k1, v') /\ c = Root k2 v' /\ `k1 = k2)
    \/ (∃ e : elem, v = LINKV #e /\ c = Link e).
Proof.
  introv Hv. destruct c as [k2 v'|e]; [left|right].
  - simpl in Hv. destruct (to_mach_int k2) as [k1|] eqn:Hk12; [|done].
    eexists k1, k2, v'. repeat split; try naive_solver.
    unfold to_mach_int in Hk12. case_decide; inversion Hk12. done.
  - inversion Hv. eauto.
Qed.

Lemma val_of_content_Some_Root :
  forall k2 v v',
    val_of_content (Root k2 v') = Some v →
    (∃ (k1 : mach_int), v = ROOTV(#k1, v') /\ `k1 = k2).
Proof.
  introv [(? & ? & ? & -> & [= -> ->] & ?)|(? & ? & [=])]%val_of_content_Some. eauto.
Qed.

(* Hints for the type-checker. *)

(* It seems important that [D], [R], and [V] which are the public parameters to
   [UF], mention [elem] in their types, as opposed to [loc]. Internally [elem]
   is equal to [loc]. Ultimately, however, the type [elem] is made opaque. *)

Implicit Types x y r : elem.
Implicit Types v : val.
Implicit Types D : LibSet.set elem.  (* domain *)
Implicit Types F : binary elem.      (* edges *)
Implicit Types K : elem -> nat.      (* rank *)
Implicit Types R : elem -> elem.     (* functional view of [is_repr F] *)
Implicit Types V : elem -> val.      (* data stored at the roots *)
Implicit Types M : gmap elem content. (* view of the memory *)

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

(* Invariants and representation predicate. *)

(* The predicate [Mem ...] relates the mathematical graph encoded by [D/F/K/V]
   and the memory encoded by the finite map [M]. In short,
    1. elements of [D] have a mapping in M;
    2. the links in [M] coincide with the links in [F];
    3. the rank and data stored at a root in [M] agree with [K] and [V]. *)

Definition Mem D F K V M : Prop :=
  forall x, x \in D ->
    match M!!x with
    | Some (Link y)   => F x y
    | Some (Root k v) => is_root F x /\ k = K x /\ v = V x
    | None => False
    end.

(* The predicate [Inv ...] relates the mathematical graph encoded by [D/F/K/V]
   and the view that is exposed to the client, which is encoded by [D/R/V].
   In short,
   1. [D/F/K] form a ranked disjoint set forest, as per [is_rdsf];
   2. [R] is included in [is_repr F],
      which means that [R x = y] implies [is_repr F x y],
      or in other words, [R] agrees with [F];
   3. [V] agrees with [R]. *)

Record Inv D F K R V : Prop := {
  Inv_rdsf  : is_rdsf D F K;
  Inv_incl  : fun_in_rel R (is_repr F);
  Inv_data  : forall x, V x = V (R x)
}.

Hint Resolve is_rdsf_is_dsf : core.
Hint Resolve Inv_rdsf Inv_incl Inv_data : core.

(* Throughout, we instantiate the parameter [r] of Alstrup et al.'s proof
   with the value 1. Thus, we write just [Phi] for [Phi 1]. *)

Notation Phi := (Phi 1).

(* [UF D R V] is the representation predicate. It is an abstract predicate: the
   client uses this predicate, but does not know how it is defined. *)

(* The definition asserts the existence (and ownership) of a group of references,
   whose content is described by a finite map [M]. It asserts the two invariants
   above. Finally, it asserts the existence (and ownership) of [Phi] time credits,
   which have been set aside to help pay for future operations. The definition
   quantifies existentially over [F/K/M], which therefore are not exposed to the
   client. *)

Definition mapsto_M M : iProp Σ :=
  ([∗ map] l ↦ c ∈ M, from_option (mapsto l (DfracOwn 1)) False (val_of_content c))%I.

Definition UF D R V : iProp Σ :=
  (∃ F K M,
  ⌜ Inv D F K R V ⌝ ∗
  ⌜ Mem D F K V M ⌝ ∗
  mapsto_M M ∗
  TC (11 * Phi D F K) ∗
  TR (card D))%I.

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

(* The functions [V] and [R] are compatible with [R]. In other words, every
   member of an equivalence class must have the same image through [V] (see
   [Inv_data]) and through [R]. For this reason, when we wish to update one of
   these functions, we must update it not just at one point, but at a whole
   equivalence class. *)

(* The function [update1 R f x b] coincides with the function [f] everywhere,
   except on the equivalence class of [x], whose elements are mapped to [b]. *)

Definition update1 {B : Type} (f : elem -> B) R x (b : B) :=
  fcupdate f (fun z => R z = R x) b.

(* The function [update2 R f x y b] coincides with the function [f] everywhere,
   except on the equivalence classes of [x] and [y], whose elements are mapped
   to [b]. *)

Definition update2 {B : Type} (f : elem -> B) R x y b :=
  fcupdate f (fun z => R z = R x \/ R z = R y) b.

(* Updating [V] by mapping the equivalence classes of [x] and [x] to [V x]
   has no effect. *)

Lemma update2_V_self : forall D F K R V x,
  Inv D F K R V ->
  update2 V R x x (V x) = V.
Proof using.
  introv [ _ _ H ]. unfold update2.
  eapply fcupdate_self; intros.
  branches; rewrite H; congruence.
Qed.

(* If [x] is a root, then updating [R] by mapping the equivalence classes of [x]
   and [x] to [x] has no effect. *)

Lemma update2_R_self : forall R x,
  R x = x ->
  update2 R R x x x = R.
Proof using.
  intros. unfold update2.
  eapply fcupdate_self; intros.
  branches; congruence.
Qed.

(* Updating [f] at [R x] and [R y] is the same as updating [f] at [x] and [y]. *)

Lemma update2_root : forall (B : Type) (f : elem -> B) R x y b,
  idempotent R ->
  update2 f R (R x) (R y) b = update2 f R x y b.
Proof using.
  introv H. unfold update2. do 2 rewrite* H.
Qed.

(* Updating [V] at [x] and [y] is the same as updating [V] at [y] and [x]. *)

Lemma update2_sym : forall B (f : elem -> B) R x y b,
  update2 f R x y b = update2 f R y x b.
Proof using.
  intros. extens. intros z. unfold update2.
  f_equal. clear z. extens; intros z. tauto.
Qed.

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

(* Exploitation and preservation lemmas for the invariant [Inv]. *)

(* If [x] is in the domain and [r] is its representative, then [r] is in the
   domain and [r] is its own representative. *)

Lemma Inv_root : forall D F K R V x r,
  Inv D F K R V ->
  x \in D ->
  r = R x ->
  r \in D /\ R r = r.
Proof using.
  intros; subst; split.
  applys* sticky_R.
  applys* idempotent_R.
Qed.

(* The invariant is preserved when a new element [r] is created and the
   function [V] is updated at [r] in an arbitrary manner. *)

Lemma Inv_make : forall D R F K V D' V' r v,
  Inv D F K R V ->
  r \notin D ->
  D' = D \u \{r} ->
  V' = update1 V R r v ->
  Inv D' F K R V'.
Proof using.
  introv HI Dr ED EV. subst D'. lets [Hrdsf Hroots Hdata]: HI.
  constructor.
  { eauto using is_rdsf_create. }
  { auto. }
  { subst V'. eapply fcupdate_absorbs; intros; eauto.
    rewrites* (>> idempotent_R R). }
Qed.

(* The invariant is preserved by updating [V] at one equivalence class. *)

Lemma Inv_update1 : forall D F K R V x v,
  Inv D F K R V ->
  Inv D F K R (update1 V R x v).
Proof using.
  introv [? ? ?]. constructors~; intros.
  eapply fcupdate_absorbs; intros; eauto.
  rewrites* (>> idempotent_R R).
Qed.

(* The invariant is preserved by a [link] operation. *)

(* The hypothesis is that the invariant holds and [x] and [y] are distinct roots
   in the domain. The conclusion is that the invariant holds again and the
   potential [Phi] grows by at most 2. The domain [D] is unchanged, while the
   other parameters [F'/K'/R'/V'/z] are described by five equations. *)

Lemma Inv_link: forall D R F K V F' K' V' x y z,
  (* Hypotheses: *)
  Inv D F K R V ->
  x ≠ y ->
  x \in D ->
  y \in D ->
  R x = x ->
  R y = y ->
  (* Five equations, describing the situation after the link: *)
  z = new_repr_by_rank K x y ->
  F' = link_by_rank_F F K x y ->
  K' = link_by_rank_K K x y ->
  V' = update2 V R x y (V z) ->
  let R' := link_by_rank_R R x y z in
  (* Conclusions: *)
  Inv D F' K' R' V' /\
  (Phi D F' K' <= Phi D F K + 2)%nat.
Proof.
  introv HI. intros. subst R' F' K' V' z. split. constructor.
  (* Preservation of [is_rdsf]. *)
  { eauto 8 using is_rdsf_link, R_self_is_root. }
  (* Preservation of the agreement between [R] and [F]. *)
  { eauto 8 using link_by_rank_R_link_by_rank_F_agree, R_self_is_root. }
  (* Preservation of the agreement between [V] and [R]. *)
  { intros w.
    unfold update2, fcupdate, link_by_rank_R. repeat case_if~.
    { false. forwards* HR: idempotent_R R. rewrite ->HR in *. tauto. }
    { rewrites~ <- (>> Inv_data HI). }
  }
  (* Change in potential. *)
  { eapply potential_increase_during_link; eauto using R_self_is_root. }
Qed.

(* This tactic helps apply the above lemma. The user is supposed to supply
   expressions for [F'/K'/V'/z], which we prove equal to what we expect.
   This allows some flexibility. *)

Ltac Inv_link F' K' V' x y z :=
  match goal with HInv: Inv ?D ?F ?K ?R ?V |- _ =>
    let Hpotential := fresh in
    (* Apply [Inv_link] to appropriate parameters. *)
    forwards* (?&Hpotential):
      (Inv_link _ _ _ _ _ F' K' V' x y z HInv);
    (* We expect to see some equations as sub-goals. We prove them by
       unfolding definitions and performing a simple case analysis. *)
    try solve [
       unfold new_repr_by_rank, link_by_rank_F, link_by_rank_K;
       case_if; solve [ eauto | math ]
     | congruence
    ]
  end.

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

(* Exploitation and preservation lemmas for the invariant [Mem]. *)

(* If [x] is in the domain and is a root, then [M] maps [x] to [Root]
   with rank [K x] and data [V x]. *)

Lemma Mem_root : forall D R F K M V x,
  Inv D F K R V ->
  Mem D F K V M ->
  x \in D ->
  R x = x ->
  M!!x = Some (Root (K x) (V x)).
Proof using.
  introv HI HM Dx Rxx.
  forwards~ HV: HM x. destruct (M!!x) as [[]|]; [| |done].
    destruct HV as (?&?&?). congruence.
    false* (>> R_self_is_root HI HV).
Qed.

(* Conversely, if [M] maps [x] to [Root], then [x] is a root whose
   rank and data are as predicted by [M]. *)

Lemma Mem_root_inv : forall D F K M V x rx vx,
  Mem D F K V M ->
  x \in D ->
  M!!x = Some(Root rx vx) ->
  is_root F x /\ rx = K x /\ vx = V x.
Proof using.
  introv HM Dx HE. forwards~ HVx: HM x.
  destruct (M!!x) as [[]|]; [|false|done]. inverts* HE.
Qed.

(* [Mem] is preserved when a new element [r] is created with rank 0 and the
   function [V] is updated at [r] in an arbitrary manner. *)

Lemma Mem_make : forall D R F K D' r M V v,
  Inv D F K R V ->
  Mem D F K V M ->
  is_rdsf D F K ->
  r \notin D ->
  D' = D \u \{r} ->
  Mem D' F K (update1 V R r v) (<[r:=Root 0 v]>M).
Proof using.
  introv HI HV HG Dr -> Dx.
  rewrite in_union_eq in_single_eq in Dx. destruct Dx as [Dx| ->].
  { rewrite lookup_insert_ne; [|naive_solver].
    rewrite /update1 fcupdate_miss; [by apply HV|].
    intro. forwards* : R_is_identity_outside_D R r.
    forwards*: Inv_root x (R x). intuition congruence. }
  { rewrite lookup_insert /update1 fcupdate_hit //. splits.
    { eauto using only_roots_outside_D with is_dsf. }
    { (* We use the fact that [K] is zero outside the domain. *)
      erewrite is_rdsf_zero_rank_outside_domain; eauto. }
    { done. } }
Qed.

(* [Mem] is preserved by installing a link from a root [x] to a root [y]
   without updating any rank. *)

Lemma Mem_link : forall D F R K F' M V V' x y,
  Inv D F K R V ->
  Mem D F K V M ->
  x \in D ->
  x = R x ->
  y = R y ->
  F' = UnionFind03Link.link F x y ->
  V' = update2 V R x y (V y) ->
  Mem D F' K V' (<[x:=Link y]>M).
Proof using.
  introv HI HR Dx Rx Ry EG' HV. subst F'.
  intros a Da. specializes HR Da.
  destruct (decide (x = a)) as [->|].
  { rewrite lookup_insert. eauto using link_appears. }
  rewrite lookup_insert_ne //. destruct (M!!a) as [[]|]; [| |done]; first last.
  { eauto using link_previous. }
  rewrite~ HV. destruct HR as (?&?&E). splits*.
  { applys* is_root_link. }
  rewrites (rm E).
  unfold update2, fcupdate. rewrites <- (rm Rx). rewrites <- (rm Ry).
  forwards* Ra: is_root_R_self a. rewrite Ra. case_if~.
  branches. false. congruence.
Qed.

(* [Mem] is preserved by installing a link from a root [x] to a root [y]
   and incrementing the rank of [y]. *)

Lemma Mem_link_incr : forall D F R K F' K' M V V' x y (rx : nat) v,
  Inv D F K R V ->
  Mem D F K V M ->
  x \in D ->
  y \in D ->
  x = R x ->
  y = R y ->
  x ≠ y ->
  rx = K x ->
  F' = UnionFind03Link.link F x y ->
  K' = fupdate K y (1 + K x)%nat ->
  v = V y ->
  V' = update2 V R x y (V y) ->
  Mem D F' K' V' (<[y:=Root (rx + 1) v]>(<[x:=Link y]>M)).
Proof using.
  introv HI HM Dx Dy Rx Ry HN Hy Kx HK. introv Hv HV'.
  forwards* HV: (>> Mem_link V V' x y HM).
  sets M': (<[x := Link y]>M). clearbody M'.
  intros a Da. specializes HV Da. destruct (decide (y = a)) as [->|].
  { rewrite lookup_insert. splits.
    { subst F'. applys* is_root_link. applys* R_self_is_root. }
    { subst K'. subst rx. rewrite fupdate_same. math. }
    { subst v. subst V'. rewrite /update2 fcupdate_hit; by auto. } }
  rewrite lookup_insert_ne //. destruct (M'!!a) as [[]|]; [| |done].
  { subst F' K'. destruct HV. split~. unfolds fupdate. case_if~. }
  { subst F'. auto. }
Qed.

(* [Mem] is preserved by installing a direct link from [x] to [y] during
   path compression. *)

Lemma Mem_compress : forall D F K F' M V x y,
  Mem D F K V M ->
  x \in D ->
  F' = compress F x y ->
  Mem D F' K V (<[x:=Link y]>M).
Proof using.
  introv HR Dx EG'. subst.
  intros a Da. specializes HR Da. destruct (decide (x = a)) as [->|].
  { rewrite lookup_insert. eauto using compress_x_z. }
  { rewrite lookup_insert_ne //. destruct (M!!a) as [[]|];
      [|by eauto using compress_preserves_other_edges|done].
    destruct HR. split*.
    eauto using compress_preserves_roots_other_than_x. }
Qed.

(* [Mem] is preserved when [V] is updated at one equivalence class and [M]
   is updated at the representative element. *)

Lemma Mem_update1 : forall D R F K M V r x v,
  Inv D F K R V ->
  Mem D F K V M ->
  x \in D ->
  r = R x ->
  Mem D F K (update1 V R x v) (<[r := Root (K r) v]>M).
Proof using.
  introv HI HM E Rx. forwards* (Dr&Rr): Inv_root x r.
  intros y Dy. specializes HM Dy. destruct (decide (r = y)) as [->|].
  { rewrite lookup_insert. splits.
    { applys* R_self_is_root. }
    { done. }
    { rewrite /update1 fcupdate_hit; congruence. } }
  { rewrite lookup_insert_ne // /update1 /fcupdate. case_if~.
    destruct~ (M!!y) as [[]|]; [|done..]. destruct HM as (H1&H2&H3).
    forwards*: is_root_R_self H1. congruence. }
Qed.

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

(* Private lemmas about the representation predicate and about [mapsto_M]. *)

Lemma mapsto_M_acc : forall M x c,
  M !! x = Some c ->
  mapsto_M M -∗
    ∃ v, ⌜val_of_content c = Some v⌝ ∗ x ↦ v ∗
     (∀ c' v', ⌜val_of_content c' = Some v'⌝ -∗
               x ↦ v' -∗ mapsto_M (<[x:=c']>M)).
Proof.
  introv HM. iIntros "HM".
  rewrite -[in mapsto_M M](insert_id M _ _ HM) -insert_delete_insert /mapsto_M.
  rewrite big_sepM_insert ?lookup_delete //. iDestruct "HM" as "[Hc HM]".
  destruct (val_of_content c); [|done]. iExists _. iFrame. iSplit; [done|].
  iIntros (c' v' Hv') "?".
  rewrite -insert_delete_insert big_sepM_insert ?lookup_delete // Hv'. iFrame.
Qed.

Lemma mapsto_M_acc_same : forall M x c,
  M !! x = Some c ->
  mapsto_M M -∗
    ∃ v, ⌜val_of_content c = Some v⌝ ∗ x ↦ v ∗ (x ↦ v -∗ mapsto_M M).
Proof.
  introv HM. iIntros "HM".
  iDestruct (mapsto_M_acc with "HM") as (v Hv) "[Hv HM]"; [done|].
  iExists _. iFrame. iSplit; [done|].
  iSpecialize ("HM" $! _ _ Hv). by rewrite insert_id.
Qed.

(* TODO : that should go into Iris libraries for big ops *)
Lemma mapsto_M_union : forall M1 M2,
  M1 ##ₘ M2 ->
  mapsto_M M1 ∗ mapsto_M M2 ⊣⊢ mapsto_M (M1 ∪ M2).
Proof.
  introv HM12. unfold mapsto_M.
  induction M1 as [|l x M1 ? IH] using map_ind.
  { by rewrite big_opM_empty !left_id. }
  rewrite -insert_union_l !big_sepM_insert //; last first.
  { apply lookup_union_None; split; [done|]. specialize (HM12 l).
    rewrite lookup_insert in HM12. revert HM12. case: (M2 !! l)=>//=. }
  rewrite -assoc. f_equiv. apply IH. by eapply map_disjoint_insert_l.
Qed.

Lemma mapsto_M_insert : forall M x c v,
  M !! x = None ->
  val_of_content c = Some v ->
  x ↦ v ∗ mapsto_M M ⊣⊢ mapsto_M (<[x:=c]>M).
Proof.
  introv Mxc Hcv. by rewrite /mapsto_M big_sepM_insert // Hcv.
Qed.

Lemma mapsto_M_disjoint : forall M1 M2,
  mapsto_M M1 -∗ mapsto_M M2 -∗ ⌜ M1 ##ₘ M2 ⌝.
Proof.
  iIntros "* HM1 HM2" (x). unfold mapsto_M.
  destruct (M1!!x) eqn:HM1, (M2!!x) eqn:HM2=>//.
  iDestruct (big_sepM_lookup with "HM1") as "H1"=>//.
  iDestruct (big_sepM_lookup with "HM2") as "H2"=>//.
  do 2 destruct val_of_content; try done.
  by iDestruct (mapsto_valid_2 with "H1 H2") as %[].
Qed.

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

(* Public lemmas about the representation predicate. *)

(* If [UF D R V] holds, then [R] is idempotent. *)

Theorem UF_idempotent : forall D R V,
  UF D R V -∗ ⌜ idempotent R ⌝.
Proof using.
  iDestruct 1 as (?????) "?". eauto 10 using idempotent_R.
Qed.

(* If [UF D R V] holds, then [R] preserves [D]. *)

Theorem UF_image : forall D R V x, x \in D →
  UF D R V -∗ ⌜ R x \in D ⌝.
Proof using.
  iDestruct 1 as (?????) "?". eauto 10 using sticky_R.
Qed.

(* If [UF D R V] holds, then [R] is the identity outside of [D]. *)

Theorem UF_identity : forall D R V x, x \notin D ->
  UF D R V -∗ ⌜ R x = x ⌝.
Proof using.
  iDestruct 1 as (?????) "?". eauto 10 using R_is_identity_outside_D.
Qed.

(* If [UF D R V] holds, then [V] is compatible with [R]. *)

Theorem UF_compatible : forall D R V x, x \in D ->
  UF D R V -∗ ⌜ V x = V (R x) ⌝.
Proof using.
  iDestruct 1 as (?????) "?". eauto.
Qed.

(* An empty instance of the Union-Find data structure can be created out of
   thin air. This is how the data structure is initialized. *)

Theorem UF_create : forall V,
  TCTR_invariant nmax ={⊤}=∗ UF \{} id V.
Proof using.
  unfold UF. iIntros (V) "#?".
  iExists (@LibRelation.empty elem), (λ _, 0%nat), ∅.
  repeat iSplitL.
  { iPureIntro. constructors.
    { apply is_rdsf_empty. }
    { intro x. eapply is_repr_empty. }
    { eauto. } }
  { iIntros "!%" (??). false. }
  { rewrite /mapsto_M. by auto. }
  { rewrite Phi_empty. by iApply zero_TC. }
  { rewrite card_empty. by iApply zero_TR. }
Qed.

(* Two separate instances of the UnionFind data structure can be merged, without
   actually doing anything at runtime. *)

(* In principle, we could also prove the converse property, [UF_split]. A UnionFind
   data structure can be split in two independent parts, provided the split respects
   the equivalence relation. Considering the amount of dreary work that went into
   establishing [UF_join], I leave this to future work. *)

Theorem UF_join : forall D1 R1 V1 D2 R2 V2,
  UF D1 R1 V1 -∗ UF D2 R2 V2 -∗
  UF
    (D1 \u D2)
    (fun x => If x \in D1 then R1 x else R2 x)
    (fun x => If x \in D1 then V1 x else V2 x)
  ∗ ⌜ D1 \# D2 ⌝.
Proof using.
  intros.
  iDestruct 1 as (F1 K1 M1 HI1 HM1) "(HM1 & HTC1 & TR1)".
  iDestruct 1 as (F2 K2 M2 HI2 HM2) "(HM2 & HTC2 & TR2)".
  sets D: (D1 \u D2).
  sets R: (fun x => If x \in D1 then R1 x else R2 x).
  sets V: (fun x => If x \in D1 then V1 x else V2 x).
  set (F := LibRelation.union F1 F2).
  set (K := fun x => If x \in D1 then K1 x else K2 x).
  set (M := M1 ∪ M2).

  (* Disjointness lemmas. Trivial and painful. *)

  iDestruct (mapsto_M_disjoint with "HM1 HM2") as %HM12.

  assert (forall x, x \in D1 -> x \in D2 -> False).
  { intros l Hl1%HM1 Hl2%HM2. specialize (HM12 l).
    destruct (M1!!l) eqn:HM1l=>//. destruct (M2!!l) eqn:HM2l=>//. }

  assert (D1 \# D2) by by rew_set.

  assert (forall x, x \in D2 -> x \notin D1).
  { intros. intro. eauto. }

  assert (forall x y, F1 x y -> x \in D1).
  { eauto with confined is_dsf. }

  assert (forall x y, F2 x y -> x \in D2).
  { eauto with confined is_dsf. }

  assert (forall x, x \in D1 -> F1 x = F x).
  { intros. subst F. extens; intros y.
    unfold LibRelation.union; split; intros; try branches; eauto; false; eauto. }

  assert (forall x, x \in D2 -> F2 x = F x).
  { intros. subst F. extens; intros y.
    unfold LibRelation.union; split; intros; try branches; eauto; false; eauto. }

  assert (forall x, x \in D1 -> K1 x = K x).
  { intros. subst K. simpl. cases_if~. }

  assert (forall x, x \in D2 -> K2 x = K x).
  { intros. subst K. simpl. cases_if~. false; eauto. }

  assert (forall x, x \in D1 -> R1 x = R x).
  { intros. subst R. simpl. cases_if~. }

  assert (forall x, x \in D2 -> R2 x = R x).
  { intros. subst R. simpl. cases_if~. false; eauto. }

  assert (forall x, x \in D1 -> V1 x = V x).
  { intros. subst V. simpl. cases_if~. }

  assert (forall x, x \in D2 -> V2 x = V x).
  { intros. subst V. simpl. cases_if~. false; eauto. }

  assert (forall x, x \in D1 -> M1!!x = M!!x).
  { intros x Hx%HM1. subst M. destruct (M1!!x) eqn:? =>//.
    symmetry. by apply lookup_union_Some_l. }

  assert (forall x, x \in D2 -> M2!!x = M!!x).
  { intros x Hx%HM2. subst M. destruct (M2!!x) eqn:? =>//.
    symmetry. by apply lookup_union_Some_r. }

  iSplit; last done. iExists F, K, M.

  iCombine "HTC1 HTC2" as "HTC".
  iCombine "TR1 TR2" as "HTR".
  rewrite -mapsto_M_union // -Nat.mul_add_distr_l (@Phi_join 1 _ D F K); eauto.
  rewrite -card_disjoint_union; eauto using is_rdsf_finite; [].
  iFrame. iPureIntro. split.

  (* Preservation of [Inv]. *)
  { destruct HI1, HI2. constructor.
    (* Preservation of [is_rdsf]. *)
    { subst D F K. eapply is_rdsf_join; eauto. }
    (* Preservation of the agreement between [R] and [F]. *)
    { intros x. subst F R. simpl. cases_if.
      (* Case: [x \in D1]. *)
      { eapply is_repr_join_direct_1; eauto. }
      (* Case: [x \notin D1]. *)
      { eapply is_repr_join_direct_2; eauto. }
    }
    (* Preservation of the compatibility of [V]. *)
    { intros x. subst V R. simpl. cases_if; [ | destruct (classic (x \in D2)) ].
      (* Case: [x \in D1]. *)
      { assert (R1 x \in D1). { eauto using sticky_R. }
        cases_if. intuition eauto. }
      (* Case: [x \in D2]. *)
      { assert (R2 x \in D2). { eauto using sticky_R. }
        cases_if. false; eauto. eauto. }
      (* Case: [x \notin D1 \u D2]. *)
      { assert (h: R2 x = x). { eapply R_is_identity_outside_D; eauto with is_dsf. }
        rewrite h. cases_if. reflexivity. }
    }
  }

  (* Preservation of [Mem]. *)
  { intros x Dx. subst D. rewrite in_union_eq in Dx.
    destruct Dx as [ Dx | Dx ].
    { forwards : HM1 Dx. destruct (M1!!x) as [c|] eqn:EQM1=>//.
      unfold is_root in *. rewrite (lookup_union_Some_l _ _ _ _ EQM1) //.
      repeat match goal with h: forall_ x \in D1, _ |- _ =>
        specializes h Dx; try rewrite <- h
      end. done. }
    { forwards : HM2 Dx. destruct (M2!!x) as [c|] eqn:EQM2=>//.
      unfold is_root in *. rewrite (lookup_union_Some_r _ _ _ _ HM12 EQM2) //.
      repeat match goal with h: forall_ x \in D2, _ |- _ =>
        specializes h Dx; try rewrite <- h
      end. done. } }
Qed.

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

(* Verification of [make]. *)

(* The function call [make v] requires [UF D R V] as well as O(1) time credits.
   It returns a new element [x], that is, [x] is not in [D]. It updates the
   data structure to [UF D' R' V'], where:
   1. [D'] is [D] extended with [x];
   2. [R'] is [R];
   3. [V'] is [V] extended with a mapping of [x] to [v]. *)

Theorem make_spec : forall D R V v,
  TCTR_invariant nmax -∗
  {{{ UF D R V ∗ TC 26 }}}
    «make v»
  {{{ (x : elem), RET #x;
      let D' := D \u \{x} in
      let V' := update1 V R x «v»%V in
      UF D' R V' ∗
      ⌜x \notin D /\
       R x = x⌝ }}}.
Proof using.
  iIntros "* #?" (Φ) "!# [HF TC] HΦ".
  wp_tick_rec. wp_tick_pair. wp_tick_inj.
  iMod zero_TR as "TR".
  wp_tick. wp_alloc x as "Hx". iApply "HΦ".
  iDestruct "HF" as (F K M HI HM) "(HM & TC' & TR')".

  iAssert ⌜M !! x = None⌝%I as %Mx.
  { case HMx: (M!!x)=>//.
    iDestruct (big_sepM_lookup with "HM") as "Hx'"=>//.
    destruct val_of_content; try done.
    by iDestruct (mapsto_valid_2 with "Hx Hx'") as %[]. }
  assert (x \notin D) as Dx.
  { intros Dx%HM. by rewrite Mx in Dx. }

  iSplit; [|by eauto 10 using R_is_identity_outside_D].
  iExists _, _, (<[x:=Root 0 _]>M).
  rewrite -Phi_extend 1?Nat.mul_add_distr_l; eauto; [].
  iCombine "TC' TC" as "$".

  rewrite card_disjoint_union; eauto using is_rdsf_finite, finite_single; last first.
  { by rewrite disjoint_single_r_eq. }
  rewrite card_single. iCombine "TR' TR" as "$".

  repeat iSplit; try iPureIntro.
  { applys* Inv_make. } { applys* Mem_make. }
  iApply mapsto_M_insert; [done| |by iFrame].
  rewrite /= /to_mach_int decide_True_pi /=; [by apply (proj2_sig mach_int_0)|].
  intros ?. by rewrite (exists_proj1_pi _ mach_int_0).
Qed.

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

(* Verification of [find]. *)

(* Because [find] is a recursive function, we must begin with a specification
   that is amenable to an inductive proof. It states that [find] essentially
   implements the mathematical predicate [bw_ipc]. If [bw_ipc F x d F'] holds,
   which means that path compression at [x] requires [d] steps and changes the
   graph from [F] to [F'], then [find] requires [d+1] time credits and changes
   the memory from [M] to some [M'] that agrees with [F']. Furthermore, the
   value [r] returned by [find] is the representative of [x]. *)

Lemma find_spec_inductive: forall d D R F K F' M V x,
  Inv D F K R V ->
  Mem D F K V M ->
  x \in D ->
  bw_ipc F x d F' ->
  TCTR_invariant nmax -∗
  {{{ mapsto_M M ∗ TC (11*d+11) }}}
    «find #x»
  {{{ M', RET #(R x); mapsto_M M' ∗ ⌜ Mem D F' K V M' ⌝ }}}.
Proof using.
  intros d. induction_wf IH: Wf_nat.lt_wf d. intros d.
  introv IH HI HM Dx HC. iIntros "#?" (Φ) "!# [HM TC] HΦ /=".
  iDestruct "TC" as "[TCd TC]". wp_tick_rec.
  assert (HV := HM _ Dx). destruct (M !! x) as [c|] eqn:? =>//.
  iDestruct (mapsto_M_acc_same with "HM") as (v Hv) "[Hx HM]"=>//. wp_tick_load.
  iDestruct ("HM" with "Hx") as "HM".
  destruct (val_of_content_Some _ _ Hv) as [(k1 & k2 & v' & -> & -> & ?)|(y & -> & ->)].
  (* Case: Root. *)
  { wp_tick_match. wp_tick_proj. wp_tick_seq. wp_tick_proj. wp_tick_seq.
    destruct HV as [HR HP]. forwards* EQ : is_root_R_self HR. rewrite EQ.
    iApply "HΦ". iFrame. iPureIntro.
    invert HC; intros. by subst. by false* a_root_has_no_parent HR.
  }
  (* Case: Link. *)
  { wp_tick_match. rename HV into HF. invert HC.
    { intros. subst F. subst. false* a_root_has_no_parent. }
    intros F'0 F'' x0 y0 z' d' HF' HR' HB' EF' Ex Ed EF''. subst F'' x0 d.
    lets* E: is_dsf_functional D HF HF'. subst y0. clear HF'.
    assert (y \in D). { eauto with confined is_dsf. }
    assert (z' = R y). { symmetry. eapply is_repr_incl_R; eauto. } subst z'.
    forwards IH' : IH HI HM HB'; [math|done|].
    iCombine "TCd TC" as "TC".
    math_rewrite (11 * S d' + 6 = 11 * d' + 11 + 6)%nat ; first by lia.
    iDestruct "TC" as "[TCd TC]".
    wp_apply (IH' with "[//] [$HM $TCd]").
    iIntros (M') "[HM' hM']". iDestruct "hM'" as %HM'. wp_tick_let.
    assert (HV := HM' _ Dx). destruct (M' !! x) as [c|] eqn:? =>//.
    iDestruct (mapsto_M_acc with "HM'") as (v' Hv') "[Hx HM']"=>//.
    wp_tick_inj. wp_tick_store. wp_tick_seq.
    iDestruct ("HM'" $! (Link (R y)) _ eq_refl with "Hx") as "HM'".
    assert (is_equiv F x y). { eauto using path_is_equiv with rtclosure. }
    assert (R x = R y) as ->. { eauto using is_equiv_incl_same_R. }
    iApply ("HΦ" with "[$HM']").
    iPureIntro. applys~ Mem_compress HM'. }
Qed.

(* The function call [find x] requires [UF D R V] as well as O(alpha(D)) time
   credits. It preserves [UF D R V] and returns the representative of [x]. *)

Theorem find_spec : forall D R V x, x \in D ->
  TCTR_invariant nmax -∗
  {{{ UF D R V ∗ TC (22 * alpha (card D) + 44) }}}
    «find #x»
  {{{ RET #(R x); UF D R V }}}.
Proof using.
  introv Dx. iIntros "#?" (Φ) "!# [UF TC1] HΦ".
  iDestruct "UF" as (F K M HI HM) "(HM & TC2 & TR)".
  forwards* (d&F'&HC&HP): amortized_cost_of_iterated_path_compression_simplified x.
  iCombine "TC1 TC2" as "TC".
  rewrite [TC (_ + _)](TC_weaken _ (11*Phi D F' K + (11 * d + 11))%nat); [|lia].
  iDestruct "TC" as "[TC1 TC2]".
  iApply (find_spec_inductive with "[//] [$TC2 $HM]")=>//.
  iIntros "!>" (M') "[HM' %]". iApply "HΦ".
  iExists _, _, _. iFrame. iPureIntro. split; [|done].
  split; eauto 10 using is_rdsf_bw_ipc, bw_ipc_preserves_RF_agreement.
Qed.

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

(* Verification of [get]. *)

(* The function call [get x] requires [UF D R V] as well as O(alpha(D)) time
   credits. It preserves [UF D R V] and returns the data stored at [x]. *)

Theorem get_spec : forall D R V x, x \in D ->
  TCTR_invariant nmax -∗
  {{{ UF D R V ∗ TC (22 * alpha (card D) + 57) }}}
    «get #x»
  {{{ RET V x; UF D R V }}}.
Proof using.
  introv Dx. iIntros "#?" (Φ) "!# [UF TC] HΦ".
  math_rewrite (22 * alpha (card D) + 57 = 22 * alpha (card D) + 44 + 13)%nat ;
    first by lia.
  iDestruct "TC" as "[TC1 TC2]".
  wp_tick_rec.
  wp_apply (find_spec with "[//] [$TC1 $UF]")=>//.
  iIntros "UF". wp_tick_let. iDestruct "UF" as (F K M HI HM) "[HM TC]".
  forwards* (Drx&Rrx): Inv_root x (R x).
  forwards* EM: Mem_root (R x).
  iDestruct (mapsto_M_acc_same with "HM") as (v Hv) "[Hx HM]"=>//. wp_tick_load.
  iDestruct ("HM" with "Hx") as "HM".
  destruct (val_of_content_Some_Root _ _ _ Hv) as (k1 & -> & _).
  wp_tick_match. wp_tick_proj. wp_tick_seq. wp_tick_proj. wp_tick_let.
  rewrite -(Inv_data _ _ _ _ _ HI). iApply "HΦ".
  iExists _, _, _. eauto with iFrame.
Qed.

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

(* Verification of [set]. *)

(* The function call [set x v] requires [UF D R V] as well as O(alpha(D)) time
   credits. It produces [UF D R V'], where [V'] is obtained from [V] by mapping
   the equivalence class of [x] to [v]. *)

Theorem set_spec : forall D R V x v,
  x \in D ->
  TCTR_invariant nmax -∗
  {{{ UF D R V ∗ TC (22 * alpha (card D) + 62) }}}
    «set #x v»
  {{{ RET #(); UF D R (update1 V R x «v»%V) }}}.
Proof using.
  introv Dx. iIntros "#?" (Φ) "!# [UF TC] HΦ".
  math_rewrite (22 * alpha (card D) + 62 = 22 * alpha (card D) + 44 + 18)%nat ;
    first by lia.
  iDestruct "TC" as "[TC1 TC2]".
  wp_tick_rec. wp_tick_let. wp_apply (find_spec with "[//] [$TC1 $UF]")=>//.
  iIntros "UF". wp_tick_let. iDestruct "UF" as (F K M HI HM) "[HM TC]".
  forwards* (Drx&Rrx): Inv_root x (R x).
  forwards* EM: Mem_root (R x).
  iDestruct (mapsto_M_acc with "HM") as (v' Hv') "[Hx HM]"=>//. wp_tick_load.
  destruct (val_of_content_Some_Root _ _ _ Hv') as (k1 & -> & _).
  wp_tick_match. wp_tick_proj. wp_tick_seq. wp_tick_proj. wp_tick_seq.
  wp_tick_pair. wp_tick_inj. wp_tick_store.
  iApply "HΦ". iExists _, _, _. iFrame.
  iSplit; [auto using Inv_update1|]. iSplit; [eauto using Mem_update1|].
  rewrite Rrx. iApply ("HM" with "[%] Hx").
  simpl in *. by destruct (to_mach_int (K (R x))); inversion Hv'.
Qed.

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

(* Verification of [eq]. *)

(* The function call [eq x y] requires [UF D R V] as well as O(alpha(D)) time
   credits. It preserves [UF D R V] and returns a Boolean outcome which
   indicates whether [x] and [y] are members of a common equivalence class. *)

Theorem eq_spec : forall D R V x y,
  x \in D -> y \in D ->
  TCTR_invariant nmax -∗
  {{{ UF D R V ∗ TC (44 * alpha (card D) + 92) }}}
    «eq #x #y»
  {{{ RET #(bool_decide (R x = R y)); UF D R V }}}.
Proof using.
  introv Dx Dy. iIntros "#?" (Φ) "!# [UF TC] HΦ".
  math_rewrite (44 * alpha (card D) + 92 =
                (22 * alpha (card D) + 44) + (22 * alpha (card D) + 44) + 4)%nat ;
    first by lia.
  iDestruct "TC" as "[[TC1 TC2] TC3]".
  wp_tick_rec. wp_tick_let.
  wp_apply (find_spec with "[//] [$TC1 $UF]")=>//. iIntros "UF".
  wp_apply (find_spec with "[//] [$TC2 $UF]")=>//. iIntros "UF".
  wp_tick_op.
  rewrite (bool_decide_iff (#(R x) = #(R y)) (R x = R y)); last (split; congruence).
  by iApply "HΦ".
Qed.

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

(* Verification of [link]. (This is an internal function.) *)

(* The function call [link x y] requires [UF D R V] as well as O(1) time credits.
   It requires [x] and [y] to be roots. It chooses the new representative [z] to
   be one of [x] or [y], and returns [z], together with [UF D' R' V'], where:
   1. [D'] is [D], i.e., the domain is unchanged;
   2. [R'] is [R], where the equivalence classes of [x] and [y] are mapped to [z];
   3. [V'] is [V], where the equivalence classes of [x] and [y] are mapped to [V z].
*)

Lemma link_spec : forall D R V x y,
  (log2 (log2 nmax) < word_size - 1)%nat ->
  x \in D ->
  y \in D ->
  R x = x ->
  R y = y ->
  TCTR_invariant nmax -∗
  {{{ UF D R V ∗ TC 61 }}}
    «link #x #y»
  {{{ z, RET #z; UF D (update2 R R x y z) (update2 V R x y (V z)) ∗
                   ⌜z = x \/ z = y⌝}}}.
Proof using.
  introv Hnmax Dx Dy Rx Ry. iIntros "#?" (Φ) "!# [UF TC] HΦ".
  wp_tick_rec. wp_tick_let.
  iDestruct "UF" as (F K M HI HM) "(HM & TC'TR)".
  wp_tick_op. case_bool_decide as Hxy.
  (* Case: [x == y]. *)
  { inversion Hxy. subst. wp_tick_if. iApply "HΦ".
    rewrite update2_R_self; [|by eauto]. erewrite update2_V_self; [|by eauto..].
    iSplit; [|by auto]. iExists _, _, _. auto with iFrame. }
  (* Case: [x != y]. *)
  wp_tick_if.
  forwards Hx: HM Dx. forwards Hy: HM Dy.
  destruct (M !! x) as [cx|] eqn:EQx, (M !! y) as [cy|] eqn:EQy=>//.
  iDestruct (mapsto_M_acc_same _ x with "HM") as (v Hv) "[Hx HM]"=>//.
  wp_tick_load. iDestruct ("HM" with "Hx") as "HM".
  destruct cx; last by false; eauto using a_root_has_no_parent, R_self_is_root.
  destruct (val_of_content_Some_Root _ _ _ Hv) as (k1 & -> & ?).
  wp_tick_match. wp_tick_proj. wp_tick_let. wp_tick_proj. wp_tick_let.
  iDestruct (mapsto_M_acc_same _ y with "HM") as (v' Hv') "[Hy HM]"=>//.
  wp_tick_load. iDestruct ("HM" with "Hy") as "HM".
  destruct cy; last by false; eauto using a_root_has_no_parent, R_self_is_root.
  destruct (val_of_content_Some_Root _ _ _ Hv') as (k1' & -> & ?).
  wp_tick_match. wp_tick_proj. wp_tick_let. wp_tick_proj. wp_tick_seq.
  destruct Hx as (HRx&Kx&Vx). substs. destruct Hy as (HRy&Ky&Vy). substs.
  wp_tick_op; case_bool_decide; wp_tick_if;
    [|wp_tick_op; case_bool_decide; wp_tick_if].
  (* Sub-case: [K x < K y]. *)
  { iDestruct (mapsto_M_acc _ _ _ EQx with "HM") as (? _) "[Hx HM]".
    wp_tick_inj. wp_tick_store. wp_tick_seq. iApply "HΦ". iSplit; [|by auto].
    Inv_link
    (* F' := *) (UnionFind03Link.link F x y)
    (* K' := *) K
    (* V' := *) (update2 V R x y (V y))
                x y
    (* z  := *) y.
    iDestruct "TC'TR" as "[TC' TR]". iCombine "TC' TC" as "TC".
    iExists _, _, (<[x:=Link y]>M). iFrame "% TR".
    rewrite TC_weaken; [iFrame "TC"|lia]. iSplit; [by eauto using Mem_link|].
    by iApply "HM". }
  (* Sub-case: [K x > K y]. *)
  { iDestruct (mapsto_M_acc _ _ _ EQy with "HM") as (? _) "[Hy HM]".
    wp_tick_inj. wp_tick_store. wp_tick_seq. iApply "HΦ".
    rewrite [update2 _ _ _ _ x]update2_sym. rewrite [update2 _ _ _ _ (V x)]update2_sym.
    iSplit; [|by auto].
    Inv_link
    (* F' := *) (UnionFind03Link.link F y x)
    (* K' := *) K
    (* V' := *) (update2 V R y x (V x))
                y x
    (* z  := *) x.
    iDestruct "TC'TR" as "[TC' TR]". iCombine "TC' TC" as "TC".
    iExists _, _, (<[y:=Link x]>M). iFrame "% TR".
    rewrite TC_weaken; [iFrame "TC"|lia]. iSplit; [by eauto using Mem_link|].
    by iApply "HM". }
  (* Sub-case: [K x = K y]. *)
  { iDestruct (mapsto_M_acc _ _ _ EQy with "HM") as (? _) "[Hy HM]"=>//.
    wp_tick_inj. wp_tick_store.
    iDestruct ("HM" $! (Link _) _ eq_refl with "Hy") as "HM".
    Inv_link
    (* F' := *) (UnionFind03Link.link F y x)
    (* K' := *) (fupdate K x (1 + K y)%nat)
    (* V' := *) (update2 V R x y (V x))
                x y
    (* z  := *) x.
    iDestruct "TC'TR" as "[TC' TR]".
    iMod (TR_lt_nmax with "[//] TR") as "[TR %]" ; first done.
    iCombine "TC' TR" as "TC'TR".
    iAssert (⌜card D ≤ nmax⌝)%I%nat as %HDnmax%Nat.log2_le_mono.
    { auto with lia. }
    assert (bool_decide (mach_int_bounded (`k1 + 1))).
    { assert (log2 nmax < 2 ^ (word_size - 1))%nat.
      { destruct (decide (0 < log2 nmax)%nat); [by eapply Nat.log2_lt_pow2|].
        assert (log2 nmax = 0%nat) as -> by lia. apply power_positive. lia. }
      forwards* Hklog: rank_is_logarithmic (fupdate K x (S (K y))) x.
      rewrite fupdate_same in Hklog.
      assert (S (K y) < 2 ^ (word_size - 1))%nat as HK%inj_lt by lia.
      rewrite Z2Nat_inj_pow -Z.shiftl_1_l Nat2Z.inj_sub in HK;
        [|pose proof word_size_gt_1; lia].
      apply bool_decide_pack. split.
      { destruct (bool_decide_unpack _ (proj2_sig k1)) as [? _]. lia. }
      assert (`k1 = `k1') as -> by lia. rewrite (_:`k1' = K y) //.
      rewrite Z.add_comm -(Nat2Z.inj_add 1). done. }
    wp_tick_seq. wp_tick_op.
    { by rewrite /bin_op_eval /= /to_mach_int decide_True_pi. }
    iDestruct (mapsto_M_acc _ x with "HM") as (v'' Hv'') "[Hx HM]".
    { rewrite lookup_insert_ne //. congruence. }
    wp_tick_pair. wp_tick_inj. wp_tick_store. wp_tick_seq.
    iApply "HΦ". iSplit; [|by auto].
    iDestruct "TC'TR" as "[TC' TR]".
    iExists _, _, _. iFrame "% TR".
    iCombine "TC' TC" as "TC". rewrite TC_weaken; [iFrame "TC"|lia].
    iSplit; last iApply ("HM" with "[%] Hx").
    { iPureIntro. applys* Mem_link_incr HM. congruence. applys update2_sym. }
    rewrite /= -(_:(`k1 + 1) = (K y + 1)%nat) //.
    { by rewrite /to_mach_int decide_True_pi /=. }
    assert (`k1 + 1 = K y + 1)%Z as -> by lia. by rewrite ->Nat2Z.inj_add. }
Qed.

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

(* Verification of [union]. *)

(* The function call [union x y] requires [UF D R V] as well as O(alpha(D)) time
   credits. It chooses the new representative [z] to be one of [x] or [y], and
   returns [z], together with [UF D' R' V'], where:
   1. [D'] is [D], i.e., the domain is unchanged;
   2. [R'] is [R], where the equivalence classes of [x] and [y] are mapped to [z];
   3. [V'] is [V], where the equivalence classes of [x] and [y] are mapped to [V z].
*)

Theorem union_spec : forall D R V x y,
  (log2 (log2 nmax) < word_size - 1)%nat ->
  x \in D ->
  y \in D ->
  TCTR_invariant nmax -∗
  {{{ UF D R V ∗ TC (44 * alpha (card D) + 152) }}}
    «union #x #y»
  {{{ z, RET #z; UF D (update2 R R x y z) (update2 V R x y (V z)) ∗
                 ⌜z = R x \/ z = R y⌝ }}}.
Proof using.
  introv Hnmax Dx Dy.
  math_rewrite (44 * alpha (card D) + 152 =
                (22 * alpha (card D) + 44) + (22 * alpha (card D) + 44) + 61 + 3)%nat ;
    first by lia.
  iIntros "#?" (Φ) "!# [UF [[[TC1 TC2] TC3] TC4]] HΦ".
  wp_tick_rec. wp_tick_let.
  wp_apply (find_spec with "[//] [$TC1 $UF]")=>//. iIntros "UF".
  wp_apply (find_spec with "[//] [$TC2 $UF]")=>//. iIntros "UF".
  iDestruct (UF_image _ _ _ x with "UF") as %? =>//.
  iDestruct (UF_image _ _ _ y with "UF") as %? =>//.
  iDestruct (UF_idempotent with "UF") as %Idem =>//.
  wp_apply (link_spec _ _ _ _ _ Hnmax with "[//] [$TC3 $UF]")=>//.
  iIntros (z). by rewrite !update2_root.
Qed.

End UnionFind.

Definition final_theorems :=
  (@UF_idempotent,
   @UF_image,
   @UF_identity,
   @UF_compatible,
   @UF_create,
   @UF_join,
   @make_spec,
   @find_spec,
   @get_spec,
   @set_spec,
   @eq_spec,
   @union_spec).
Print Assumptions final_theorems.


Require Export Omega.
Set Implicit Arguments.

Global Close Scope nat.
Global Open Scope Z.

Section ILP.

(* type of variables *)
Variable V : Type.

(* linear coefficients of variables *)
Definition VC : Type := (Z * V)%type.

(* A linear function is a bunch of variables with coefficients, and a constant *)
Definition Linear : Type
 := (list VC * Z)%type.

(* constraints *)
Inductive C : Type
  := Le : Linear -> Linear -> C.

(* We don't actually need a strictly less than, since we're operating on nats *)
(*   | Lt : L -> L -> C *)

(* A variable assignment is a mapping from variable to Z *)
Definition Assignment := V -> Z.

(* Find a linear function's value, for given assignment  *)
Fixpoint value_go (os : list VC) (a : Assignment) : Z
 := match os with
      | nil => 0
      | cons (n,v) os' => a v * n + value_go os' a
      end.

Definition value (l : Linear) (a : Assignment) : Z
 := match l with
     | (os, c) => value_go os a + c
     end.

(* An assignment is valid for a list of constraints iff all lhs values are less than or equal to rhs *)
Inductive Valid_go (a : Assignment) : list C -> Prop
 := Valid_go_nil : Valid_go a nil
   | Valid_go_cons :
      forall l1 l2 cs, value l1 a <= value l2 a -> Valid_go a cs -> Valid_go a (Le l1 l2 ::cs).

Variable Objective : Linear.
Variable Constraints : list C.

Definition Valid (a : Assignment) : Prop
 := Valid_go a Constraints.

Hypothesis Sat : Assignment.

Definition obj := value Objective.

Inductive Minimal
 := MinimalC : forall a, Valid a -> (forall b, Valid b -> obj a <= obj b)
              -> Minimal.

Axiom MinimalExists : Valid Sat -> Minimal.

Definition assignmentOfMinimal (m : Minimal) : Assignment :=
 match m with
  | MinimalC a _ _  => a
 end.

(* Actually, this ignores the fact that the minimal might be unbounded.
   I will need to think about this case some more.
   I don't think it's much of an issue. *)
End ILP.


Require Export CoqRecon.Syntax.Term CoqRecon.Util.EqDecInst
        CoqRecon.Semantics.TypEnv.

Open Scope op_scope.

Inductive op_typs : op -> typ -> typ -> Prop :=
| ot_and : op_typs ∧ TBool TBool
| ot_or  : op_typs ∨ TBool TBool
| ot_add : op_typs ⨥ TNat  TNat
| ot_sub : op_typs ⨪ TNat  TNat
| ot_eq  : op_typs ≅ TNat  TBool
| ot_lt  : op_typs ⋖ TNat  TBool.

Open Scope term_scope.
Open Scope env_scope.

Reserved Notation "g ⊨ e ∴ t" (at level 70).

Inductive typing (Γ : gamma) : term -> typ -> Prop :=
| t_bool (b : bool) :
    Γ ⊨ b ∴ TBool
| t_nat (n : nat) :
    Γ ⊨ n ∴ TNat
| t_var x τ :
    bound x τ Γ ->
    Γ ⊨ x ∴ τ
| t_abs x e τ τ' :
    (x ↦ τ;; Γ) ⊨ e ∴ τ' ->
    Γ ⊨ (λ x ⇒ e) ∴ (τ → τ')
| t_app e1 e2 τ τ' :
    Γ ⊨ e1 ∴ (τ → τ') ->
    Γ ⊨ e2 ∴ τ ->
    Γ ⊨ (e1 ⋅ e2) ∴ τ'
| t_cond e1 e2 e3 τ :
    Γ ⊨ e1 ∴ TBool ->
    Γ ⊨ e2 ∴ τ ->
    Γ ⊨ e3 ∴ τ ->
    Γ ⊨ Cond e1 e2 e3 ∴ τ
| t_op o e1 e2 τ τ' :
    op_typs o τ τ' ->
    Γ ⊨ e1 ∴ τ ->
    Γ ⊨ e2 ∴ τ ->
    Γ ⊨ Op o e1 e2 ∴ τ'
| t_let x e1 e2 τ τ' :
    Γ ⊨ e1 ∴ τ ->
    (x ↦ τ;; Γ) ⊨ e2 ∴ τ' ->
    Γ ⊨ LetIn x e1 e2 ∴ τ'
where "g ⊨ e ∴ t" := (typing g e t).

Section Prez.
  Local Hint Constructors op_typs : core.

  Lemma pres_op_typs : forall o τ τ',
      op_typs o τ τ' ->
      forall σ, op_typs o (σ † τ) (σ † τ').
  Proof.
    intros o t t' H s; inv H; simpl; auto.
  Qed.

  Local Hint Resolve pres_op_typs : core.
  Local Hint Constructors typing : core.

  Theorem preservation : forall Γ e τ,
      Γ ⊨ e ∴ τ -> forall σ,
        (σ × Γ)%env ⊨ e ∴ (σ † τ).
  Proof.
    intros g e t H;
      induction H; intros s; simpl in *; eauto.
    - constructor. unfold bound, env_map in *.
      rewrite H. reflexivity.
    - constructor.
      rewrite env_map_bind; auto.
    - econstructor; eauto.
      rewrite env_map_bind; auto.
  Qed.
End Prez.


From Coq Require Import Relations Lia.
From AlmostFull.PropBounded Require Import AlmostFull.
From AlmostFull.PropBounded Require Import AlmostFullInduction.
From AlmostFull.PropBounded Require Import AFConstructions.

Set Implicit Arguments.
Unset Strict Implicit.
Set Printing Implicit Defensive.
Set Transparent Obligations.

Section Lexicographic.

(* Lexicographic orders:
 * flex (Z,_) = 1
 * flex (_,Z) = 1
 * flex (S x, S y) = f(x,S (S y)) + f(S x, y)
 *)
Definition flex : forall (x:nat*nat), nat.
Proof.
pose (T x y := fst x < fst y \/ (fst x = fst y /\ snd x < snd y)).
pose (R x y := fst x <= fst y /\ snd x <= snd y).
eapply af_induction with (T := T) (R := R).
(* prove almost_full *)
apply af_product; repeat (apply leq_af).
(* prove intersection emptyness *)
intros x y (CT,H). induction CT. firstorder; lia.
assert (fst y <= fst z). clear H IHCT. induction CT; firstorder; lia.
firstorder; lia.
(* give the functional *)
refine (fun x => match x as w return (forall y, T y w -> nat) -> nat with
                   | (O,_) => fun frec => 1
                   | (_,O) => fun frec => 1
                   | (S a,S b) => fun frec => (@frec (a,S (S b)) _ + @frec (S a,b) _)%nat
                 end); unfold T in *; auto with arith.
Defined.

(* Slightly more complicated:
 *
 * grok (Z,_) = 1
 * grok (_,Z) = 1
 * grol (S x, S y) = grok (S y, y) + grok(x,x)
 *)
Definition grok : forall (x:nat*nat), nat.
Proof.
pose (T x y := (fst x <= snd y /\ snd x < snd y) \/
               (snd x < fst y /\ fst x < fst y)).
pose (R x y := fst x <= fst y /\ snd x <= snd y).
apply af_induction with (T := T) (R := R).
(* prove almost_full *)
apply af_product; repeat (apply leq_af).
(* prove intersection emptyness *)
intros x y (CT,H).
assert (T x y). clear H.
induction CT; unfold T in *; lia.
unfold T in *; unfold R in *; lia.
(* give the functional *)
refine (fun x => match x as w return (forall y, T y w -> nat) -> nat with
                   | (O,_) => fun frec => 1
                   | (_,O) => fun frec => 1
                   | (S a,S b) => fun frec => (@frec (S b,b) _ + @frec (a,a) _)%nat
                 end); unfold T in *; auto with arith.
Defined.

End Lexicographic.

Section Ranking.

(* Argument flipping by cheating (cofmap)
 *
 * flip (Z,_) = 1
 * flip (_,Z) = 1
 * flip (S x, S y) = flip (S y,x)
 *)

Definition flip1 : forall (x:nat*nat), nat.
Proof.
pose (T x y := fst x <= snd y /\ snd x < fst y).
pose (R x y := fst x + snd x <= fst y + snd y).
apply af_induction with (T := T) (R := R).
(* prove almost_full *)
apply af_cofmap with (f := fun z => (fst z + snd z)%nat). apply leq_af.
(* prove intersection emptyness *)
intros x y (CT,H).
assert (fst x + snd x < fst y + snd y). clear H.
induction CT. unfold T in *. lia. unfold T in *. lia.
unfold R in *. lia.
(* give the functional *)
refine (fun x => match x as w return (forall y, T y w -> nat) -> nat with
                   | (O,_) => fun frec => 1
                   | (_,O) => fun frec => 1
                   | (S a,S b) => fun frec => @frec (S b,a) _
                 end); unfold T in *; auto with arith.
Defined.

End Ranking.

Section ArgFlip.

(* Argument flipping with no cheating (no cofmap)
 *
 * flip (Z,_) = 1
 * flip (_,Z) = 1
 * flip (S x, S y) = flip (y,x)
 *)

Definition flip2 : forall (x:nat*nat), nat.
Proof.
pose (T x y := fst x < snd y /\ snd x < fst y).
pose (R x y := fst x <= fst y /\ snd x <= snd y).
eapply af_power_induction with (T := T) (R := R) (k := 2).
lia.
(* prove almost_full *)
apply af_intersection. apply af_cofmap. apply leq_af.
apply af_cofmap; apply leq_af.
(* prove (power 2) intersection emptyness *)
intros x y (CT,Ryx). induction CT.
  unfold T in *; unfold R in *. simpl in H. destruct H. destruct H.
  destruct H. destruct H0. destruct H0. destruct H0. destruct Ryx. subst x1. lia.
  assert (fst x < fst y /\ snd x < snd y). simpl in H. destruct H.
  unfold T in H. destruct H. destruct H0. destruct H0.
  clear CT. clear IHCT. subst x1. clear Ryx. destruct H; destruct H0. lia.
  unfold R in *. clear CT. lia.
(* give the functional *)
refine (fun x => match x as w
                 return (forall y, T y w -> nat) -> nat with
                 | (O,_) => fun frec => 1
                 | (_,O) => fun frec => 1
                 | (S x, S y) => fun frec => frec (y,x) _
                end).
unfold T in *. auto with arith.
Defined.

End ArgFlip.

Section SCT.

(* An example from size-change termination
 * [From Amir Ben-Amram's paper General Size-Change Termination and lexicographic descent]
 * gnlex (x,Z)     = 1
 * gnlex (Z,y)     = 1
 * gnlex (S x,S y) = gnlex (S y, y) + gnlex (S y, x)
 *******************************************************************************************)

(* GNLexRelations *)
Definition T x y := (fst x = snd y /\ snd x < snd y) \/
                    (fst x = snd y /\ snd x < fst y).

Definition R x y := fst x <= fst y /\ snd x <= snd y.

Lemma T2_invariant:
  forall x y, power 2 T x y ->
    fst x < fst y /\ snd x < fst y \/
    snd x < snd y /\ fst x < snd y \/
    fst x < fst y /\ snd x < snd y.
Proof.
intros x y T2.
destruct T2 as (z,(Txz,(z0,(Tzz0,Zeq)))). unfold T in *.
simpl in Zeq.
destruct Txz as [T1 | T2]; destruct Tzz0 as [S1 | S2]; subst z0.
right; left; lia.
left; lia.
right; left; lia.
right; right; lia.
Defined.

Lemma T2_ct_invariant:
  forall x y, clos_trans_1n _ (power 2 T) x y ->
    fst x < fst y /\ snd x < fst y \/
    snd x < snd y /\ fst x < snd y \/
    fst x < fst y /\ snd x < snd y.
Proof.
intros x y CT.
induction CT.
(* base case *)
apply T2_invariant; assumption.
(* inductive case *)
remember (T2_invariant H) as G; clear HeqG CT H.
destruct G as [G1 | [G2 | G3]]; destruct IHCT as [IH1 | [IH2 | IH3]].
(* a little combinatorial search *)
  left; lia.
  right; left; lia.
  left; lia.
  left; lia.
  right; left; lia.
  right; left; lia.
  left; lia.
  right; left; lia.
  right; right; lia.
Defined.

(* GNLex *)
Definition gnlex_pow2 : forall (x:nat*nat), nat.
Proof.
apply af_power_induction with (T:=T) (R:=R) (k:=2). lia.
(* prove almost_full *)
apply af_intersection;
   repeat (apply af_cofmap; apply leq_af).
(* prove intersection emptyness *)
intros x y (CT,HR).
destruct (T2_ct_invariant CT); firstorder; lia.
(* give the functional *)
refine (fun x => match x as w
         return (forall y, T y w -> nat) -> nat with
         | (O,_) => fun frec => 1
         | (_,O) => fun frec => 1
         | (S x, S y) => fun frec => (frec (S y, y) _ + frec (S y, x) _)%nat
                end).
unfold T in *. left. simpl; lia.
unfold T in *. right. simpl; lia.
Defined.

Lemma T_empty_intersect: forall x y, clos_trans_1n _ T x y -> R y x -> False.
Proof.
intros x y CT HR.
assert (T x y \/ clos_trans_1n (nat*nat) (power 2 T) x y \/
        exists z, T x z /\ clos_trans_1n _ (power 2 T) z y).
2: {
  destruct H.
  destruct H. destruct HR. lia.
  destruct HR. lia.
  destruct H.
  destruct (T2_ct_invariant H). destruct HR. lia.
  destruct HR. lia.
  destruct H. destruct H.
  destruct (T2_ct_invariant H0). firstorder; lia.
  firstorder; lia.
}
clear HR.
induction CT. left; auto.
destruct IHCT. right. left. constructor. exists y. auto. split. apply H.
exists z. split. auto. auto. unfold power. reflexivity.
destruct H0. right. right.
exists y. split. apply H. apply H0.
destruct H0. destruct H0.
right. left. constructor 2 with (y := x0).
exists y. split. apply H. exists x0. split. auto. simpl. reflexivity.
apply H1.
Defined.

(* GNLexSimple *)
Definition gnlex: forall (x:nat*nat), nat.
Proof.
apply af_induction with (T:=T) (R:=R).
(* prove almost_full *)
apply af_intersection;
   repeat (apply af_cofmap; apply leq_af).
(* prove intersection emptyness *)
intros x y (CT,HR).
apply (T_empty_intersect CT HR).
(* give the functional *)
refine (fun x => match x as w
         return (forall y, T y w -> nat) -> nat with
         | (O,_) => fun frec => 1
         | (_,O) => fun frec => 1
         | (S x, S y) => fun frec => (frec (S y, y) _ + frec (S y, x) _)%nat
                end).
unfold T in *. left. simpl; lia.
unfold T in *. right. simpl; lia.
Defined.

End SCT.

Section SumExample.

(* FSumRelations *)
Definition Tfsum := fun x y =>
   (exists x0, x = inr nat (x0+2)%nat /\ y = inl nat (S x0)) \/
   (exists x0, x = inl nat (x0-2) /\ y = inr nat x0).

Definition Rfsum := sum_lift le le.

Lemma fsum_pow2_empty: forall x y : nat + nat,
 clos_trans_1n (nat + nat) (power 2 Tfsum) x y /\ Rfsum y x -> False.
Proof.
intros.
destruct H.
induction H.
- destruct H. destruct H. destruct H1. destruct H1.
  destruct H. destruct H. destruct H. subst x. subst x0.
  destruct y. destruct H0.
  destruct H1. destruct H. destruct H. inversion H.
  destruct H. destruct H. inversion H1. unfold Rfsum in H0. unfold sum_lift in H0.
  inversion H.
  subst.
  inversion H2.
  subst.
  lia.
  unfold Rfsum in H0. unfold sum_lift in H0.
 destruct H1. destruct H. destruct H. destruct H1. subst.
 destruct y; auto.
 destruct H1.
 subst.
 inversion H.
 subst.
 simpl in H2.
 inversion H2.
 subst.
 lia.
 destruct H1.
 destruct H1.
 simpl in H2.
 destruct y.
 subst.
 inversion H2.
 destruct x; auto.
 subst.
 destruct H.
 destruct H.
 inversion H.
- unfold Rfsum in *. unfold sum_lift in *.
  clear H1.
  destruct z.
  * destruct x; auto.
    destruct y; subst.
    + inversion H.
      destruct H1.
      inversion H2.
      destruct H3.
      inversion H4.
      subst.
      clear H2 H4.
      inversion H3.
      destruct H2.
      destruct H2.
      subst.
      inversion H4.
      subst.
      inversion H1.
      destruct H2.
      destruct H2.
      inversion H5.
      destruct H2.
      destruct H2.
      inversion H5.
      subst.
      inversion H2.
      subst.
      lia.
      destruct H2.
      destruct H2.
      subst.
      inversion H4.
   + firstorder.
     subst.
     inversion H4.
     subst.
     inversion H4.
     subst.
     inversion H.
     subst.
     inversion H2.
     subst.
     inversion H4.
     inversion H.
     subst.
     inversion H.
     subst.
     inversion H4.
   * destruct x; auto.
     destruct y; subst.
    + inversion H.
      destruct H1.
      inversion H2.
      destruct H3.
      inversion H4.
      subst.
      clear H2 H4.
      inversion H3.
      destruct H2.
      destruct H2.
      subst.
      inversion H4.
      subst.
      inversion H1.
      destruct H2.
      destruct H2.
      inversion H5.
      destruct H2.
      destruct H2.
      inversion H5.
      subst.
      inversion H2.
      subst.
      destruct H2.
      destruct H2.
      subst.
      inversion H4.
   + destruct H.
     destruct H.
     inversion H1.
     destruct H2.
     inversion H3.
     subst.
     clear H1 H3.
     inversion H; clear H.
     destruct H1.
     destruct H.
     subst.
     inversion H.
     subst.
     clear H.
     inversion H2; clear H2.
     destruct H.
     destruct H.
     inversion H.
     destruct H.
     destruct H.
     inversion H.
     inversion H1.
     subst.
     lia.
     destruct H1.
     destruct H.
     inversion H.
Qed.

(* fsum (inl 0)     = 1
 * fsum (inl (S x)) = fsum (inr (x+2))
 * fsum (inr x)     = fsum (inl (x-2))
 ******************************************************)

(* FSum *)
Definition fsum: forall (x:nat+nat), nat.
Proof.
apply af_power_induction
  with (T := Tfsum) (R := Rfsum) (k := 2). lia.
(* prove almost_full *)
apply af_sum_lift. apply leq_af. apply leq_af.
(* prove intersection emptyness *)
apply fsum_pow2_empty.
(* give the functional *)
refine (fun x => match x as w
        return (forall y, Tfsum y w -> nat) -> nat with
        | inl O => fun frec => 1
        | inl (S x) => fun frec => frec (inr nat (x+2)%nat) _
        | inr x => fun frec => frec (inl nat (x-2)) _
        end).
left. exists x. intuition.
right. exists x. intuition.
Defined.

End SumExample.

Section MutualInduction.

(* Here is an interesting example of mutual induction
    f x = g (x+1) + f (x-1)
    g z = f (z-2)
 **********************************)
Definition TA := fun x y  => x < y.
Definition SB := fun x y  => x = S y.
Definition TB := fun (x:nat) (y:nat) => False.
Definition SA := fun x y  => y = S (S x).

Definition funny_compare := fun x y =>
  match (x,y) with
  | (inl x, inl y) => x < y
  | (inr x, inl y) => x <= y \/ x = (y+1)%nat
  | (inl x, inr y) => x + 2 <= y
  | (inr x, inr y) => x <= y
  end.

Lemma funny_compare_lemma:  forall x y,
  clos_trans_1n (nat+nat) (lift_rel_union TA TB SA SB) x y -> funny_compare x y.
Proof.
intros. induction H.
destruct x; destruct y; unfold funny_compare in *; simpl in *.
unfold TA in *; lia.
unfold SA in *; lia.
unfold SB in *; lia.
unfold TB in *; lia.
destruct x; destruct y; destruct z; unfold funny_compare in *; simpl in *.
unfold TA in *; lia.
unfold TA in *; lia.
unfold SA in *; lia.
unfold SA in *; lia.
unfold SB in *; lia.
unfold SB in *; lia.
unfold TB in *; lia.
unfold TB in *; lia.
Defined.

Definition f_and_g : (nat -> nat) * (nat -> nat).
Proof.
eapply af_mut_induction
  with (R := sum_lift le le)
       (TA := TA)
       (SA := SA)
       (TB := TB)
       (SB := SB).
(* prove almost_full *)
apply af_sum_lift; apply leq_af.
(* prove intersection emptyness *)
intros x y (CTxy,Ryx).
induction CTxy. destruct x; destruct y; unfold lift_rel_union in *; unfold sum_lift in *.
   unfold TA in *; lia. destruct Ryx. destruct Ryx.
   unfold TB in *; lia.
assert (funny_compare y z). apply funny_compare_lemma. apply CTxy; clear CTxy.
destruct x; destruct y; destruct z; unfold funny_compare in *; simpl in *.
unfold TA in *; firstorder.
unfold sum_lift in *; firstorder; lia.
unfold TA in *; firstorder.
unfold SA in *; firstorder.
unfold sum_lift in *; firstorder; lia.
unfold sum_lift in *; firstorder; lia.
unfold SA in *; firstorder; lia.
unfold SB in *; firstorder; lia.
unfold SB in *; firstorder.
unfold sum_lift in *; firstorder; lia.
unfold TB in *; firstorder; lia.
unfold TB in *; firstorder; lia.
(* give the functionals *)
  refine (fun x => match x as w return (forall y, TA y w -> nat) -> (forall y, SB y w -> nat) -> nat with
                    | O   => fun self_rec other_rec => 1
                    | S x => fun self_rec other_rec => (@self_rec x _ + @other_rec (S (S x)) _)%nat
                   end). unfold TA. lia. unfold SB. auto.
  refine (fun x => match x as w return (forall y, TB y w -> nat) -> (forall y, SA y w -> nat) -> nat with
                    | O       => fun self_rec other_rec => 1
                    | S O     => fun self_rec other_rec => 1
                    | S (S x) => fun self_rec other_rec => @other_rec x _
                   end). firstorder.
Defined.

End MutualInduction.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (y : natural) (x : natural) : natural := plus x y.


From Coq Require Import Arith.
Require Import Psatz.
Require Export Setoid Morphisms.
Set Implicit Arguments.

(* Definition of Directed sets for some order relation <=. D is directed if :
forall x y in D, there is a z in D such that x <= z and y <= z. *)

Notation set X := (X -> Prop).
Notation rel X := (X -> X -> Prop).
Definition Directed {X} `(leq : rel X) (D : set X) : Prop :=
  forall x y, D x -> D y -> exists z, D z /\ leq x z /\ leq y z.
Definition directed_set {X} (leq : rel X) := {Dbody : set X | Directed leq Dbody}.
Definition Dbody {X leq} (D : directed_set leq) : set X := proj1_sig D.
Coercion Dbody : directed_set >-> Funclass.

Class PO (X: Type) := {
    weq : relation X;
    leq: relation X;
    PreOrder_leq:> PreOrder leq;
    weq_spec: forall x y, weq x y <-> (leq x y /\ leq y x);
  }.

(* Definition of a CPO : Complete Partially Ordered set*)
Class CPO (X: Type) `(P' : PO X) := {
    sup: directed_set leq -> X;
    sup_spec: forall D z, (leq (sup D) z <-> forall (y:X), D y -> leq y z);
  }.

(* Definition of Lattice as a particular (stronger) CPO. *)
Class CompleteLattice (X : Type) `(L' : PO X) := {
    supL: (X -> Prop) -> X;
    sup_specL:  forall Y z, (leq (supL Y) z <-> forall y, Y y -> leq y z);
  }.

(* Scopes are a way to guide parsing when overloading a symbol.
   See: https://coq.inria.fr/distrib/current/refman/user-extensions/syntax-extensions.html#notation-scopes
 *)
Declare Scope CPO. (* I don't really understand there 2 lines. *)
Open Scope CPO.
Infix "==" := weq (at level 70): CPO.
Infix "<=" := leq: CPO.
#[global] Hint Extern 0 => reflexivity: core.

(** * Utilities  *)

(** any monotone function preserves equality  *)
Lemma op_leq_weq_1 {X Y} {LX: PO X} {LY: PO Y} {f: X -> Y}
      {Hf: Proper (leq ==> leq) f}: Proper (weq ==> weq) f.
Proof. intros x y. rewrite 2weq_spec. intro E; split; apply Hf; apply E. Qed.

Lemma op_leq_weq_2 {X Y Z} {LX: PO X} {LY: PO Y} {LZ: PO Z} {f: X -> Y -> Z}
      {Hf: Proper (leq ==> leq ==> leq) f}: Proper (weq ==> weq ==> weq) f.
Proof.
  intros x y E x' y' E'. rewrite weq_spec in E. rewrite weq_spec in E'.
  apply weq_spec. split; apply Hf; (apply E || apply E').
Qed.

(** * Sets general properties *)

Section Sets.

  Context {X} {P' : PO X}.

  Definition set_eq (f g : X -> Prop) := forall z, f z <-> g z. (*equality of sets*)

  Definition included (S T: set X) := forall x, S x -> T x.

  #[global] Instance Included_trans : Transitive included.
  Proof.
    intros Y1 Y2 Y3 H12 H13. intros x H. apply H13. now apply H12.
  Qed.

End Sets.
Infix "⊆" := included (at level 70).

(** * Directedness general properties *)

Section Directedness.

  Context {X} {P' : PO X}.

  Lemma directed_symmetry f g : (forall z, f z <-> g z) -> Directed leq f <-> Directed leq g.
  Proof. intro H. unfold Directed. setoid_rewrite H. tauto. Qed.

  #[global] Instance directed_eq : Proper (set_eq ==> iff) (Directed leq).
  Proof. intros f g. apply directed_symmetry. Qed.

  Lemma singleton_is_directed x : Directed leq (fun z => z=x).
  Proof. unfold Directed. intros y z Hyz. exists x. repeat split. now rewrite Hyz. now rewrite H. Qed.

  Definition is_Chain (Y : set X) := forall (x y : X), Y x -> Y y -> x <= y \/ y <= x.

  Lemma chain_is_directed : forall D, is_Chain D -> Directed leq D.
  Proof.
    intros D Hd x y Hx Hy. destruct (Hd x y); intuition.
    exists y. now split.
    exists x. now split.
  Qed.

End Directedness.

(** Partial Order general properties *)

Section Partial_order.

  Context {X} {P' : PO X}.

  #[global] Instance Equivalence_weq: Equivalence weq.
  Proof.
    constructor.
    intro x. now apply weq_spec.
    intros x y. rewrite 2weq_spec. tauto.
    intros x y z. rewrite 3weq_spec. split; transitivity y; tauto.
  Qed.

  #[global] Instance PartialOrder_weq_leq: PartialOrder weq leq.
  Proof.
    intros x y. simpl. now rewrite weq_spec.
  Qed.

  Lemma antisym x y: x <= y -> y <= x -> x == y.
  Proof. rewrite weq_spec. tauto. Qed.

  Lemma from_above x y: (forall z, x<=z <-> y<=z) -> x==y.
  Proof. intro E. apply antisym; apply E; reflexivity. Qed.

  Lemma from_below x y: (forall z, z<=x <-> z<=y) -> x==y.
  Proof. intro E. apply antisym; apply E; reflexivity. Qed.

End Partial_order.

(** * General properties of the sup operation. *)

Section sup.

  Context {X} {P' : PO X} {P: CPO P'} {L : CompleteLattice P'}.

  Lemma leq_xsup (D : directed_set _) y: D y -> y <= sup D.
  Proof. intro H. now apply (sup_spec D). Qed.

  Lemma leq_xsupL (Y:X->Prop) y : Y y -> y <= supL Y.
  Proof. intro H. now apply (sup_specL Y). Qed.

  Lemma sup_is_independent_of_proof : forall D_dir D_dir2,
      set_eq (Dbody D_dir) (Dbody D_dir2) ->
      sup D_dir == sup D_dir2.
  Proof.
    intros. apply weq_spec. split; apply sup_spec; intros; apply leq_xsup;
      now apply H.
  Qed.

  Program Definition empty : directed_set leq :=
    exist _ (fun _ => False) _.
  Next Obligation. unfold Directed. intros. contradict H. Defined.

  Definition bot := sup empty. (*Warning : with our current definition of directed,
 bottom exists since the empty set is directed. Later, we might want to change that to allow bottom to no exist*)

  Lemma bot_spec: forall x, bot <= x.
  Proof. intro. now apply sup_spec. Qed.

  Definition top_lat := supL (fun _ => True). (* Rmk : only exists in lattices, not just CPOs. *)

  Lemma top_spec_lat: forall x, x <= top_lat.
  Proof. intro. now apply leq_xsupL. Qed.

  (** Inf *)

  Definition inf_lat Y := supL (fun z => forall y, Y y -> z <= y).
  Lemma inf_spec_lat: forall Y z, z <= inf_lat Y <-> (forall y, Y y -> z <= y).
  Proof.
    intros. unfold sup. split.
    intros H y Yy. rewrite H; apply sup_specL. now auto.
    intro. now apply leq_xsupL.
  Qed.

  Lemma leq_xinf (D: X -> Prop) y:  D y -> inf_lat D <= y.
  Proof. intro H. now apply inf_spec_lat with D. Qed.

  (* --- Inclusion of sets and sup --- *)

  Definition included_body (S T : directed_set leq) := S ⊆ T.
  #[global] Instance sup_preserves_inclusion: Proper (included_body ==> leq) sup.
  Proof.
    intros S T HST. apply sup_spec. intros. apply leq_xsup.
    now apply HST.
  Qed.

  Definition set_eq_body (S T : directed_set leq) := set_eq S T.
  #[global] Instance sup_preserves_equality: Proper (set_eq_body ==> weq) sup.
  Proof.
    intros S T HST. apply weq_spec. split; apply sup_preserves_inclusion; intros x Hx; now apply HST.
  Qed.

End sup.

#[global] Hint Resolve bot_spec: core.

(** * Monotonous functions and other properties *)

Section functions.
  Context {X} `{P: CPO X}.

  Definition Fix F x := F x == x.
  Definition Post F x := x <= F x.
  Definition Pre F x := F x <= x.

  Lemma fix_is_post F : forall x, Fix F x -> Post F x.
  Proof. intros. apply weq_spec in H. apply H. Qed.
  Lemma fix_is_pre F : forall x, Fix F x -> Pre F x.
  Proof. intros. apply weq_spec in H. apply H. Qed.

  (* Monotonous functions *)

  Record mon := { body:> X -> X; Hbody: Proper (leq ==> leq) body }.

  #[global] Instance Hbody' (F:mon) : Proper (weq ==> weq) F.
  Proof. apply (op_leq_weq_1 (Hf:=(Hbody F))). Qed.

  Variant Image f (S : X -> Prop) : X -> Prop :=
  |from_image : forall x, S x -> Image f S (f x).

  Definition Continuous f :=
    forall (D : set X) (H : Directed leq D),
      {dir_im : Directed leq (Image f D) &
                f (sup (exist _ D H )) == sup (exist _ (Image f D) dir_im)}.

  Lemma mon_preserves_directedness_and_sup (F:mon) :
    forall (D : set X) (H : Directed leq D),
      {dir_im : Directed leq (Image F D) &
                  sup (exist _ (Image F D) dir_im) <= F (sup (exist _ D H ))}.
  Proof.
    intros. assert (Directed leq (Image F D)).
    + unfold Directed. intros. inversion H0. inversion H1.
      destruct (H x0 x1); try assumption. exists (F x2).
      repeat split; try apply Hbody; apply H6.
    + exists H0. apply sup_spec; cbn. intros.
      inversion H1. apply Hbody. now apply leq_xsup.
  Qed.

  (* Some basic monotonous functions *)

  Program Definition const x: mon := {| body y := x |}.
  Next Obligation. intros ? ? ?. reflexivity. Qed.

  Definition id: mon := {|
                         body x := x;
                         Hbody x y H := H
                       |}.

  Definition comp (f g: mon): mon :=
    {|
      body := fun x => f (g x);
      Hbody x y H := Hbody f _ _ (Hbody g _ _ H)
    |}.
  Infix "°" := comp (at level 20): CPO.

  (* Iterations of a function *)

  Fixpoint itere F n x0 : X :=
    match n with
    | 0 => x0
    | S m => F (itere F m x0)
    end. (*Indexed by n for simplicity on comparison properties.*)

  Lemma itere_monotony (F:mon) : forall n, Proper (leq ==> leq) (itere F n).
  Proof. intros n x y H. induction n. now cbn. cbn. now apply Hbody. Qed.

  Lemma chain_itere (F:mon) : forall (n : nat), itere F n bot <= itere F (S n) bot.
  Proof. intro n. induction n. now cbn. cbn. now apply Hbody. Qed.

  Lemma chain_increase (F:mon) : forall (m n : nat), le n m -> itere F n bot <= itere F m bot.
  Proof.
    intros m n H. induction m. now inversion H.
    inversion H. easy.
    rewrite <- chain_itere. now apply IHm.
  Qed.

  Lemma itere_preserves_fix (F:mon) : forall β n, Fix F β -> (itere F n β) == β.
  Proof.
    intros. induction n. now cbn. cbn. unfold Fix in H. rewrite <- H at 2.
    now apply Hbody'.
  Qed.

  Variant iteres F : X -> Prop :=
  | from_bot : forall n, iteres F (itere F n bot).

  Lemma iteres_directed (F:mon): Directed leq (iteres F).
  Proof.
    unfold Directed. intros. destruct H. destruct H0.
    destruct le_ge_dec with n n0.
    + exists (itere F n0 bot). repeat split. now apply chain_increase. reflexivity.
    + exists (itere F n bot). repeat split. reflexivity. now apply chain_increase.
  Qed.

  Variant iteres_from_1 F : X -> Prop :=
  | from_bot_from_1 : forall n, le 1 n -> iteres_from_1 F (itere F n bot).

  Lemma iteres_from_1_directed (F:mon): Directed leq (iteres_from_1 F).
  Proof.
    unfold Directed. intros. destruct H. destruct H0.
    destruct le_ge_dec with n n0.
    + exists (itere F n0 bot). repeat split. assumption. now apply chain_increase. reflexivity.
    + exists (itere F n bot). repeat split. assumption. reflexivity. now apply chain_increase.
  Qed.

  Lemma image_of_iteres F : set_eq (Image F (iteres F)) (iteres_from_1 F).
  Proof.
    intro. split; intro; inversion H. inversion H0.
    + assert (iteres_from_1 F (itere F (S n) bot)). apply from_bot_from_1. lia.
      apply H3.
    + induction n. contradict H0. lia.
      cbn. apply from_image. apply from_bot.
  Qed.

  Lemma from_1_included F : included (iteres_from_1 F) (iteres F).
  Proof. intros x H. inversion H. apply from_bot. Qed.

End functions.

Section Particular_CPOs.

  Context {X} {P' : PO X} {P: CPO P'}.

 Program Instance PO_mon : PO mon :=
    {|
      weq := pointwise_relation X weq;
      leq := pointwise_relation X leq;
    |}.
  Next Obligation.
  apply Build_PreOrder.
    + intro x. reflexivity.
    + intros f g h Hfg Hgh x. now transitivity (g x).
  Qed.
  Next Obligation.
    split; intros.
    + split; intro a; now apply weq_spec.
    + intro. now apply weq_spec.
  Qed.

  Program Instance CPO_mon : CPO PO_mon :=
    {|
      sup F := {| body a := sup (fun b => exists2 f, F f & b=f a) |};
    |}.
  Next Obligation.
    unfold Directed. intros. destruct F as [SF D]; cbn in *.
    destruct H as [fx Hfx]. destruct H0 as [fy Hfy].
    destruct (D fx fy) as [f [Hf1S [Hff1 Hff2]]]; try assumption.
    exists (f a). repeat split. now exists f.
                                 + rewrite H. apply Hff1.
                                 + rewrite H0. apply Hff2.
  Qed.
  Next Obligation.
    destruct F as [SF D]; cbn in *.
    intros x y H. apply sup_spec; cbn. intros.
    destruct H0 as [f Hf].
    transitivity (f y). rewrite H0. now apply Hbody.
    apply leq_xsup. cbn. now exists f.
  Qed.
  Next Obligation.
    destruct D as [SF D]; cbn in *. split.
    + intros H f Df x. rewrite <- (H x).
      eapply sup_spec. reflexivity. cbn. now exists f.
    + intros H x. apply sup_spec. intros. inversion H0. rewrite H2. now apply (H x0).
  Qed.

  Program Instance PO_parts: PO (set X) :=
    {|
      weq := set_eq;
      leq := included;
    |}.
  Next Obligation.
    apply Build_PreOrder.
    + intro Y. now intro x.
    + apply Included_trans.
  Qed.
  Next Obligation.
    repeat split; try intuition; intros a; intro H0; apply H; try apply H0.
  Qed.

  Program Instance CPO_parts: CPO PO_parts :=
    {|
      sup A := (fun x => exists Y, A Y /\ Y x);
    |}.

  Next Obligation.
    split; intros; intros a Ha.
    apply H. now exists y.
    destruct Ha. apply (H x). apply H0. apply H0.
  Qed.

  Program Instance Lattice_parts : CompleteLattice (PO_parts) :=
    {|
      supL A := (fun x => exists Y, A Y /\ Y x);
    |}.
  Next Obligation.
    split; intros; intros a Ha. apply H.
    now exists y.
    destruct Ha. apply (H x). apply H0. apply H0.
  Qed.

  (** * sub-CPO : Define a set (part of X) as being a CPO *)

  Definition is_subCPO (Y : set X) := forall (D : directed_set _),
      included D Y -> Y (sup D).

  Definition down (x:X) := (fun z => z <= x).

  Lemma down_is_subCPO : forall x, is_subCPO (down x).
  Proof. intros x D Hd. unfold down. apply sup_spec. intros. now apply Hd. Qed.

  Definition set_type (Y : set X) : Type := { x : X | Y x}.
  Definition element Y (y :set_type Y) := proj1_sig y.
  #[global] Coercion element : set_type >-> X.

  Definition complete_body {Y : set X} (D : set (set_type Y)) : set X :=
    (fun x => {is_in_Y : Y x & D (exist _ x is_in_Y)}).

  Program Instance subPO (Y:set X) : (PO (set_type Y)) :=
    {|
      weq x y := (@weq X P') x y;
      leq x y := (@leq X P') x y;
    |}.
  Next Obligation. apply Build_PreOrder; intro x. reflexivity. intros y z Hxy Hyz. now transitivity y. Qed.
  Next Obligation. apply weq_spec. Qed.

  Program Instance subCPO (Y:set X) (H : is_subCPO Y) : (CPO (subPO Y)) :=
    {|
      sup D := sup (exist (Directed leq) (complete_body D) _) ;
    |}.
  Next Obligation.
    destruct D as [D Hd]. cbn. intros x y Hx Hy. inversion Hx. inversion Hy.
    destruct (Hd (exist (fun x : X => Y x) x x0) (exist (fun x : X => Y x) y x1))
      as [[z Pz] [Hz [Hxz Hyz]]]; try assumption.
    exists z. split. now exists Pz. now split.
  Qed.
  Next Obligation.
    apply H. intros x Hx.
    destruct D as [D Hd]; cbn in Hx. now destruct Hx.
  Qed.
  Next Obligation.
    split.
    + intros. apply (sup_spec (exist (Directed leq) (complete_body D) (subCPO_obligation_1 D))); cbn.
      assumption. destruct y. cbn.
      now exists y.
      + intros. apply sup_spec. cbn. intros. destruct H1. now apply (H0 (exist (fun x : X => Y x) y x)).
  Qed.

  (* Some instances that can now be defined on CPO_parts and CPO_mon. *)

  Variable F : X -> X.

  #[global] Instance image_eq : Proper (weq ==> weq) (Image F).
  Proof. intros Y1 Y2 HY. split; intro H; inversion H; apply from_image; now apply HY. Qed.

  #[global] Instance set_incl : Proper (weq ==> weq ==> iff) included.
  Proof. intros Y1 Y2 H12 Y3 Y4 H34. split; intros Hi x Hx; apply H34; apply Hi; now apply H12. Qed.

  Lemma set_equivalent : forall (f g : set X), f == g -> (pointwise_relation X iff) f g.
  Proof.
    intros f g H x. split; intro Hh; apply weq_spec in H; destruct H.
    now apply H. now apply H0.
  Qed.

End Particular_CPOs.

Ltac rew H H' :=
  let eq := fresh in
  pose proof @set_equivalent _ _ H as eq;
  apply eq in H';
  clear eq.

Ltac rew_goal H :=
  let eq := fresh in
  pose proof @set_equivalent _ _ H as eq;
  apply eq;
  clear eq.

Tactic Notation "prew" hyp(H) "in" hyp(H') := rew H H'.
Tactic Notation "prew" constr(H) "in" hyp(H') := rew H H'.
Tactic Notation "prew" hyp(H)    := rew_goal H.
Tactic Notation "prew" constr(H) := rew_goal H.

(** * Common fixpoint of every monotonous increasing function *)

Section Increasing_fixpoint.
    Context {X} `{P: CPO X}.

  Definition Increasing F := forall x, x <= F x.

  Definition leq_mon := (@leq mon PO_mon).
  Definition weq_mon := (@weq mon PO_mon).

  Program Definition Increasing_functions := exist (Directed leq_mon) Increasing _.
  Next Obligation.
    unfold Directed. intros f g Hf Hg. exists (comp f g). repeat split.
    + intro x. transitivity (g x). apply Hg. apply Hf.
    + intro x. cbn. apply Hbody. apply Hg.
    + intro x. cbn. apply Hf.
  Defined.

  Definition H_sup := (sup (CPO := CPO_mon) Increasing_functions).

  Lemma H_sup_is_increasing : Increasing H_sup.
  Proof. intro. assert (leq_mon id H_sup). now apply (sup_spec (CPO := CPO_mon) Increasing_functions). apply H. Qed.

  Lemma H_sup_bot_is_fixpoint_of_all_Increasing (F:mon) :
    Increasing F -> Fix F (H_sup bot).
  Proof.
    intro. assert (weq_mon (comp F H_sup) H_sup).
    + apply weq_spec. split. apply (sup_spec (CPO := CPO_mon) Increasing_functions). reflexivity.
      intro x. transitivity (H_sup x). apply H_sup_is_increasing. apply H.
      intro. apply H.
    + unfold Fix. now setoid_rewrite (H0 bot).
  Qed.

  (* Lemma 8.21*)
  Lemma increasing_has_fix_point (F:mon) : Increasing F -> exists x, Fix F x.
  Proof.
    intro. exists (H_sup bot). now apply H_sup_bot_is_fixpoint_of_all_Increasing.
  Qed.

End Increasing_fixpoint.

(** * Invariant subCPOs *)

Section Invariant_subCPOs.

  Context {X} `{P: CPO X}.

  Definition Invariant (F : X -> X) Y := included (Image F Y) Y.

  Variable F : X -> X.

  Definition P0 :=  (*P0 is the smallest invariant subCPO : intersection of all invariant sub_CPOs.*)
    (fun x => forall Y, Invariant F Y -> is_subCPO Y -> Y x).

  Lemma P0_is_invariant_subCPO : Invariant F P0 /\ is_subCPO P0.
  Proof.
    split.
    + intros x H. inversion H. intros Y Hi Hs. apply Hi. apply from_image. now apply (H0 Y).
    + intros D H Y Hi Hs. apply Hs. rewrite H. intros x Hx. now apply Hx.
  Qed.

  Lemma P0_is_smallest_invariant_subCPO : forall Y, Invariant F Y -> is_subCPO Y -> included P0 Y.
  Proof. intros Y Hi Hs x Hx. now apply Hx. Qed.

End Invariant_subCPOs.

(* Knaster-Tarski Theorem on Lattices *)

Section lattice_results.
  Context {X} `{L: CompleteLattice X}.
  Variable b: mon.

  Definition gfp := supL (fun x => x <= b x).
  Definition lfp := inf_lat (fun x => b x <= x).

  Proposition leq_gfp: forall y, y <= b y -> y <= gfp.
  Proof. apply leq_xsupL. Qed.
  Proposition geq_lfp: forall y, b y <= y -> lfp <= y.
  Proof. apply leq_xinf. Qed.

  Lemma gfp_pfp: gfp <= b gfp.
  Proof.
    unfold gfp. apply sup_specL. intros y H. rewrite H. apply Hbody.
    apply leq_xsupL. apply H.
  Qed.
  Lemma lfp_pfp: b lfp <= lfp.
  Proof.
    unfold lfp. apply inf_spec_lat. intros y H. rewrite <- H. apply Hbody.
    apply leq_xinf. apply H.
  Qed.

  Lemma gfp_fp: gfp == b gfp.
  Proof.
    rewrite weq_spec. split.
    + apply gfp_pfp.
    + apply leq_xsupL. apply Hbody. apply gfp_pfp.
  Qed.
  Lemma lfp_fp: lfp == b lfp.
  Proof.
    rewrite weq_spec. split.
    + apply leq_xinf. apply Hbody. apply lfp_pfp.
    + apply lfp_pfp.
  Qed.

End lattice_results.

Section Using_Tarski.
  (* Remark : although this section is used in the proofs of the book, it is not used throughout this file.
It is enough to work with P0 as the smallest invariant subCPO, no need to use its properties of least fixpoint. *)

  Context {X} `{P: CPO X}.

  Program Definition Φ F' : @mon (set X) (PO_parts) :=  (*since def of mon is linked to that of POs, need a PO of parts*)
    {| body X := (fun x =>
                    (x = bot \/
                     (Image F' X) x \/
                       (exists (D : directed_set _), included (Dbody D) X /\ x = sup D)
                 ))
    |}.
  Next Obligation.
    intros Y1 Y2 H12 x Hx. destruct Hx; intuition.
    + right. left. inversion H0. apply from_image. now apply H12.
    + destruct H0 as [Hd [Hi Hs]]. right. right. exists Hd. split.
      intros y Hy. apply H12. now apply Hi. assumption.
  Qed.

  Definition P0' F' := lfp (L := Lattice_parts) (Φ F').

  Lemma P0_is_P0' F : set_eq (P0 F) (P0' F).
  Proof.
    split.
    + apply P0_is_smallest_invariant_subCPO.
    - unfold Invariant. unfold P0'. rewrite lfp_fp at 2.
      intros x H. right. now left.
    - unfold is_subCPO. unfold P0'. intros D H.
      apply (set_equivalent (lfp_fp (Φ F))). (* prew does not work *)
      right. right. now exists D.
                          + unfold P0'. apply (geq_lfp (L := Lattice_parts)). intros x H.
                            destruct (P0_is_invariant_subCPO F). destruct H. rewrite H.
                            apply (H1 empty). intros y Hy. contradict Hy.
                            destruct H. inversion H. apply H0. now apply from_image.
                            destruct H as [D [Hd Hs]]. rewrite Hs. now apply (H1 D).
  Qed.

End Using_Tarski.

(** * Fixpoint theorems ! *)

Section Fixpoints.
  Context {X} `{P: CPO X}.

  Definition is_least S x := S x /\ forall y, S y -> x <= y.
  Definition is_inf S x := forall z, (forall y, S y -> z <= y) <-> z <= x.
  Definition is_minimal S x := S x /\ forall y, S y -> y <= x -> y == x.
  Definition is_greatest S x := S x /\ forall y, S y -> y <= x.
  Definition is_sup S x := forall z, (forall y, S y -> y <= z) <-> x <= z.

  Lemma test_coherence1 : forall (D : directed_set _), is_sup D (sup D).
  Proof. intros D z. split; apply sup_spec. Qed.
  Lemma test_coherence2 : forall (D : directed_set _),
      D (sup D) ->
      is_greatest D (sup D).
  Proof. intros. split. assumption. now apply sup_spec. Qed.

  (** * Fixpoint theorems and proofs : first theorem. *)
  Variable F:mon.

  Program Definition α := (sup (exist _ (iteres F) (iteres_directed F))).

  Theorem Fixpoint_I_i : Fix F α -> is_least (Fix F) α.
  Proof.
    intro H. split; try assumption.
    intros. apply sup_spec; cbn. intros z Q.
    inversion Q. rewrite <- (itere_preserves_fix F y n).
    now apply itere_monotony. assumption.
  Qed.

  Program Definition α' := (sup (exist _ (iteres_from_1 F) _)).
  Next Obligation. apply iteres_from_1_directed. Qed.

  Lemma sup_from_1 : α == α'.
  Proof.
    apply weq_spec. split.
    + apply sup_spec; cbn. intros. inversion H.
      induction n. now cbn. apply leq_xsup.
      apply from_bot_from_1. lia.
    + apply sup_preserves_inclusion; cbn. apply from_1_included.
  Qed.

  Theorem Fixpoint_I_ii : Continuous F -> is_least (Fix F) α. (* Note that F is monotonous too. *)
  Proof.
    intro H.
    assert (Fix F α).
    + unfold Fix. destruct (H (iteres F) (iteres_directed F)) as [HD HS].
      transitivity α'; try now rewrite sup_from_1. rewrite HS.
      apply sup_is_independent_of_proof. cbn. unfold set_eq. apply image_of_iteres.
    + now apply Fixpoint_I_i.
  Qed.

  (** * Fixpoint theorems and proofs : second theorem. *)

  Lemma Induction_Rule : (exists µ0, is_least (Pre F) µ0)
                         -> exists µ, is_least (Fix F) µ /\ forall x, Pre F x -> µ <= x.
  Proof.
    intro H. destruct H as [µ0 Hmu0].
    exists µ0. repeat split.
    + apply weq_spec. split. apply Hmu0.
      apply Hmu0. unfold Pre. apply Hbody. apply Hmu0.
    + intros. apply Hmu0. now apply fix_is_pre.
    + apply Hmu0.
  Qed.

  Lemma P0_is_in_Post : included (P0 F) (Post F).
  Proof.
    assert (Invariant F (Post F) /\ is_subCPO (Post F)).
    + split.
    - intros x H. inversion H. apply Hbody. apply H0.
    - intros D H. apply sup_spec. intros. transitivity (F y). now apply H.
      apply Hbody. now apply leq_xsup.
      + now apply P0_is_smallest_invariant_subCPO.
  Qed.
  (* Note : contrarily to the book, here P0' was never used for now, neither was phi. *)

  Lemma P0_is_in_down x : Fix F x -> included (P0 F) (down x).
  Proof.
    intro. assert (Invariant F (down x) /\ is_subCPO (down x)).
    + split.
    - intros y Hy. inversion Hy. unfold down. rewrite <- H. apply Hbody. apply H0.
    - apply down_is_subCPO.
      + now apply P0_is_smallest_invariant_subCPO.
  Qed.

  Program Instance P0_PO : PO (set_type (P0 F)) := (subPO _).
  Program Instance P0_CPO : CPO P0_PO := (subCPO _).
  Next Obligation. apply P0_is_invariant_subCPO. Qed.

  Program Definition F_restricted_to_P0 : mon :=
    {| body := fun y => (exist _ (F y) _) |}.
  Next Obligation. destruct y as [x Hx]; cbn. apply P0_is_invariant_subCPO. now apply from_image. Qed.
  Next Obligation. intros y1 y2 H12; cbn. now apply Hbody. Qed.

  Lemma F_restricted_is_increasing : Increasing F_restricted_to_P0.
  Proof. intro y. destruct y as [x Hx]; cbn. now apply P0_is_in_Post. Qed.

  Theorem Fixpoint_II : exists x, Fix F x.
  Proof.
    destruct (increasing_has_fix_point F_restricted_to_P0 F_restricted_is_increasing).
    destruct x as [x Hx]. cbn in H. now exists x.
  Qed.

  (* Actually, we can go further. Since we constructively built the fixpoint of G as being (H_sup bot) for a well-chosen CPO.
 So we can define this fixpoint and add the results from Claim 3 of the theorem : it is both the top of P0 and the least fixpoint of F.*)

  Definition a := (H_sup bot). (*Here a is of type (set_type P0) since this was the last CPO to be defined.
 It's what we want, no need to specify implicit arguments. *)

  Lemma a_is_fixpoint_of_F : Fix F (element a).
  Proof.
    assert (Fix F_restricted_to_P0 a). apply H_sup_bot_is_fixpoint_of_all_Increasing. apply F_restricted_is_increasing.
    destruct a as [a Ha]. now cbn in *.
  Qed.

  Theorem a_is_top_of_P0_and_least_fixpoint_of_F :
    is_greatest (P0 F) (element a) /\ is_least (Fix F) (element a).
  Proof. split.
         + split. destruct a as [µ Hmu]. now cbn. apply P0_is_in_down.
           intros. apply a_is_fixpoint_of_F.
         + split. apply a_is_fixpoint_of_F. intros. apply (P0_is_in_down y).
           assumption. destruct a as [µ Hmu]. now cbn.
  Qed.

End Fixpoints.

(** * Theorem III : Bourbaki-Witt theorem. This theorem requires classic logic. *)

Section Bourbaki_Witt.

  Context {X} `{P: CPO X}.
  Definition classic_axiom := forall (P : Prop), P \/ ~ P.

  (* Now show that P0 is a chain, to prove that it has a sup (top). This is a fixpoint. *)

  Definition lt x y := x <= y /\ ~ (x == y).
  Infix "<" := lt.

  Lemma leq_is_lt_or_eq : classic_axiom -> forall x y, x <= y -> x==y \/ x < y. (* excluded middle ! *)
  Proof. intros EM x y Hxy. destruct (EM (x==y)). now left. now right. Qed.

  Lemma not_leq_and_gt : forall x y, ~ (x <= y /\ y < x). (* no need for EM *)
  Proof. intros x y. intro. destruct H. destruct H0. contradict H1. now apply weq_spec. Qed.

  Definition Extreme F' : set X :=
    (fun c => (P0 F') c /\ forall x, (P0 F') x -> x < c -> F' x <= c).

  Definition Mc F' c : set X :=
    (fun x => (P0 F') x /\ (x <= c \/ F' c <= x)).

  Lemma Mc_is_P0 F' : classic_axiom -> (Proper (weq ==> weq) F') -> Increasing F' -> forall c, Extreme F' c -> set_eq (P0 F') (Mc F' c).
  Proof.
    intros EM Fp HF c Ec. destruct Ec as [Pc Ec']. split.
    + apply P0_is_smallest_invariant_subCPO.
    - intros x Hx. inversion Hx. split. apply P0_is_invariant_subCPO. apply from_image. apply H.
      destruct H as [Px0 Hx0]. destruct Hx0.
      * apply leq_is_lt_or_eq in H. destruct H. right. apply weq_spec. now apply Fp.
        left. now apply Ec'. assumption.
      * right. transitivity x0. assumption. apply HF.
    - intros D Hi. split.
      apply P0_is_invariant_subCPO. rewrite Hi. intros x0 Hx0. apply Hx0.
      destruct (EM (exists y, D y /\ F' c <= y)). (* WARNING : excluded middle ! *)
      * right. destruct H as [y Hy]. transitivity y. apply Hy. now apply leq_xsup.
      * left. apply sup_spec. intros. destruct (Hi y). assumption.
        destruct H2. assumption. contradict H. now exists y.
                                                     + intro Hm. apply Hm.
  Qed.

  Lemma P0_is_extreme F' : classic_axiom -> (Proper (weq ==> weq) F') ->  Increasing F' -> forall x, P0 F' x -> Extreme F' x.
  Proof.
    intros EM Fp HF. apply P0_is_smallest_invariant_subCPO.
    + intros c Hc. inversion Hc. inversion H as [HPx HEx]. split.
    - apply P0_is_invariant_subCPO. now apply from_image.
    - intros. assert (set_eq (P0 F') (Mc F' x)). apply (Mc_is_P0 EM Fp HF H).
      assert (Mc F' x x0). now rewrite <- (set_equivalent H3 x0). destruct H4. destruct H5.
      * apply leq_is_lt_or_eq in H5; intuition.
        apply weq_spec. now apply Fp. transitivity x; intuition.
      * exfalso. eapply not_leq_and_gt. split. apply H5. apply H2.
      + intros D Ed. split. apply P0_is_invariant_subCPO. rewrite Ed. intros x Hx. apply Hx.
        intros x Px Hxd. destruct (EM (exists c, D c /\ x <= c)).
    - destruct H as [c [Hdc Hcx]]. apply leq_is_lt_or_eq in Hcx; intuition.
      * transitivity (F' c). apply weq_spec. now apply Fp.
        assert (Mc F' c (sup D)). apply Mc_is_P0; intuition. apply P0_is_invariant_subCPO.
        rewrite Ed. intros y Hy. apply Hy.
        destruct H0. destruct H1. exfalso. eapply not_leq_and_gt. split. rewrite <- H in H1.
        apply H1. apply Hxd. assumption.
      * transitivity c. apply Ed; intuition. now apply leq_xsup.
    - assert (sup D <= x).
      * apply sup_spec. intros. rewrite HF. assert (Mc F' y x). apply Mc_is_P0; intuition.
        destruct H1. destruct H2. contradict H. now exists y. assumption.
                                                      * exfalso. eapply not_leq_and_gt. split. apply H0. assumption.
  Qed.

  Lemma P0_is_Chain (F':X -> X) : classic_axiom -> (Proper (weq ==> weq) F') -> Increasing F' -> is_Chain (P0 F').
  Proof.
    intros EM Fp HF x y Hx Hy. assert (Mc F' x y).
    apply Mc_is_P0; intuition. apply P0_is_extreme; intuition.
    destruct H. destruct H0. now right. left. transitivity (F' x).
    apply HF. assumption.
  Qed.

  Lemma P0_is_directed (F':X -> X) : classic_axiom -> (Proper (weq ==> weq) F') -> Increasing F' -> Directed leq (P0 F').
  Proof. intros EM Fp HF. apply chain_is_directed. now apply P0_is_Chain. Qed.

  (* Note : since we put excluded middle and functional extensionality as hypothesis, we lose constructivity,
we can't just define our fixpoint as below :
Program Definition top_P0 (F':X -> X) (H : Increasing F') := (sup (exist _ (P0 F') _)).
Next Obligation. apply P0_is_directed; intuition. apply H. Qed. *)

  (* The book is wrong : the top of P0 is not necessarily minimal (cf counterexample on paper and in work_prop.v) *)
  Theorem Fixpoint_III (F' : X -> X) : classic_axiom -> (Proper (weq ==> weq) F') -> Increasing F' -> exists x, Fix F' x.
  Proof.
    intros EM Fp HF. exists (sup (exist _ (P0 F') (P0_is_directed EM Fp HF))).
    apply weq_spec. split. apply leq_xsup; cbn. apply P0_is_invariant_subCPO.
    apply from_image. apply P0_is_invariant_subCPO; cbn. intro. now intro.
    apply sup_spec; cbn. intros. rewrite <- HF. now apply leq_xsup.
  Qed.

End Bourbaki_Witt.

Section S_chain.

 Context {X} `{P: CPO X}.

 Inductive S F : X -> Prop :=
  | S_bot : S F bot
  | S_succ : forall x, S F x -> S F (F x)
  | S_sup : forall (D : directed_set leq), included D (S F) -> (S F) (sup D).

 Lemma S_is_P0 : forall F, @weq (set X) PO_parts (S F) (P0 F).
 Proof.
 intro F. apply antisym; cbn.
 + intros x HSx. induction HSx. apply P0_is_invariant_subCPO. intros x Fal. contradiction.
   apply P0_is_invariant_subCPO. now apply from_image.
   apply P0_is_invariant_subCPO. intro x. apply H0.
 + apply P0_is_smallest_invariant_subCPO. intros x HFx. inversion HFx. now apply S_succ.
   intros D HD. now apply S_sup.
Qed.

(* Increasing version *)
 Lemma Fixpoint_tool_inc F : is_Chain (S F) -> Increasing F -> exists x, Fix F x.
 Proof.
  intros HS HF . exists (sup (exist _ (S F) (chain_is_directed HS))). apply antisym.
  + apply leq_xsup. cbn. apply S_succ. apply S_sup. cbn. now intro.
  + apply HF.
 Qed.

(* monotonous version, that actually shows that F is Increasing on P0 via P0_is_in_Post*)
 Variable F : mon.

 Lemma Fixpoint_tool_mon : is_Chain (S F) -> exists x, Fix F x.
 Proof.
  intros HS. exists (sup (exist _ (S F) (chain_is_directed HS))). apply antisym.
  + apply leq_xsup. cbn. apply S_succ. apply S_sup. cbn. now intro.
  + apply P0_is_in_Post. apply S_is_P0. apply S_sup. now cbn.
 Qed.

 (* Note : it was proved that S ( = P0) is a chain when F is Increasing, using classical arguments. Cf Lemma P0_is_Chain.
  It was also non-intuitionastically proved in coinduction.v for a monotonous function.
  But it was not proved for a monotonous function without classical logic, since the intuitionistic proof does not use this.
 *)

End S_chain.

Section thm_no_subCPO.

 Context {X} `{P: CPO X}.

(* Adapt proof of theorem 2 with no use for dependent pair for subCPO or monotonous function *)
 Definition mon_fun_applied (Y : set X) (z : X) (* z = bot *) (x0 : X) := exists (h : X -> X), x0 = h z
                                              /\ (forall x y, Y x -> Y y -> leq x y -> leq (h x) (h y)) (* h monotonous *)
                                              /\ (forall x, Y x -> leq x (h x)) (* h increasing *)
                                              /\ (forall x, Y x -> Y (h x))  (* h well defined on Y *)
                                              /\ Y z. (* put the set to empty if we are looking at an element that is actually not in Y *)

(* Now to prove that top_on_set is directed to take its sup which is a sup of P2 by Thm II *)

 Lemma directed_set_of_fun (Y : set X) (z : X) :  Directed leq (mon_fun_applied Y z).
 Proof.
  intros x y Hx Hy. destruct Hx as [hx [Hhx [hxmon [hxinc [hxinv HYx]]]]].
  destruct Hy as [hy [Hhy [hymon [hyinc [hyinv HYy]]]]].
  exists (hx (hy z)). repeat split. exists (fun x => hx (hy x)).
  + repeat split.
  intros x0 y0 Hx0 Hy0 Hxy0. apply hxmon; try now apply hyinv. now apply hymon.
  intros x0 Hx0. transitivity (hy x0). now apply hyinc. apply hxinc. now apply hyinv.
  intros x0 Hx0. apply hxinv. now apply hyinv. assumption.
  + transitivity (hx z). now rewrite <- Hhx. apply hxmon. assumption. now apply hyinv. now apply hyinc.
  + rewrite <- Hhy. apply hxinc. rewrite Hhy. now apply hyinv.
 Qed.
 (*I'm actually surprised that we don't need Y to be a subCPO here...*)

 Program Definition fun_on_Y_subCPO (Y:set X) z (*(H : is_subCPO Y)*) (*(Hz : Y z)*) := exist (Directed leq) (mon_fun_applied Y z) _.
 Next Obligation. apply directed_set_of_fun. Defined.

 Lemma set_of_fun_is_subCPO Y (*(H : is_subCPO Y) *): is_subCPO Y ->
   mon_fun_applied Y bot (sup (fun_on_Y_subCPO Y bot (*H*) (*(subCPO_contains_bot H)*))).
 Proof. intro H.
  exists (fun x => sup (fun_on_Y_subCPO Y x)). repeat split.
  + intros x y HYx HYy Hxy. apply sup_spec. intros z Hz. destruct Hz as [hz [Hhz [hzmon [hzinc [hzinv HYz]]]]].
    transitivity (hz y). rewrite Hhz. apply hzmon; assumption. apply leq_xsup. now exists hz.
  + intros x HYx. apply leq_xsup. now exists id.
  + intros x HYx. apply H. intros z Hz. destruct Hz as [hz [Hhz [hzmon [hzinc [hzinv HYz]]]]].
  rewrite Hhz. now apply hzinv.
  + now apply H.
 Qed.

 Variable F : mon.

 Theorem Fixpoint_II_no_subCPO : exists x, Fix F x.
 Proof.
 exists (sup (fun_on_Y_subCPO (P0 F) bot)).
 assert ((P0 F) (sup (fun_on_Y_subCPO (P0 F) bot))). apply P0_is_invariant_subCPO.
 intros x Hx. destruct Hx as [hx [Hhx [hxmon [hxinc [hxinv HYx]]]]].
 rewrite Hhx. apply hxinv. now apply P0_is_invariant_subCPO.

 apply antisym.

 + assert (is_subCPO (P0 F)) as Hs. apply P0_is_invariant_subCPO.
 pose proof (set_of_fun_is_subCPO Hs) as HP. destruct HP as [hx [Hhx [hxmon [hxinc [hxinv HYx]]]]].
 rewrite Hhx at 1. apply leq_xsup. exists (fun x => F (hx x)). repeat split.
  - intros x y Hx Hy Hxy. apply Hbody. now apply hxmon.
  - intros x Hx. transitivity (hx x). now apply hxinc. apply P0_is_in_Post. now apply hxinv.
  - intros x Hx. apply P0_is_invariant_subCPO. apply from_image. now apply hxinv.
  - assumption.
 + now apply P0_is_in_Post.
 Qed.

End thm_no_subCPO.