(** Adapted from "Elements of Set Theory" Chapter 7 **)
(** Coq coding by choukh, Nov 2020 **)

Require Export ZFC.Lib.Natural.
Require Import ZFC.Lib.FuncFacts.
Require Import ZFC.Lib.ChoiceFacts.

(*** EST第七章2：良序，超限归纳原理，超限递归定理，传递闭包 ***)

(* 良序结构 *)
Print woset.
(* Definition woset := λ A R, wellOrder R A. *)

(* Theorem 7J *)
Theorem subRel_woset : ∀ A R B, woset A R → B ⊆ A → woset B (R ⥏ B).
Proof with eauto.
  intros * [Hlo Hmin] Hsub.
  split. eapply subRel_loset...
  intros C Hne HsubC.
  pose proof (Hmin C Hne) as [m [Hm Hle]]. eapply sub_trans...
  exists m. split... intros x Hx.
  pose proof (Hle x Hx) as []; [left|right]...
  apply SepI... apply CPrdI; apply HsubC...
Qed.

Lemma nat_woset : ∀n ∈ ω, woset n (Lt ⥏ n).
Proof with auto.
  intros n Hn. eapply subRel_woset. apply Lt_wellOrder.
  apply trans_sub... apply ω_trans.
Qed.

Lemma empty_woset : woset ∅ ∅.
Proof with auto.
  split. apply empty_loset.
  intros B [b Hb] Hsub. apply Hsub in Hb. exfalso0.
Qed.

(* 无穷降链 *)
Definition descending_chain : set → set → set → Prop := λ f A R,
  f: ω ⇒ A ∧ ∀n ∈ ω, (f[n⁺] <ᵣ f[n]) R.

(* 良序结构不存在无穷降链 *)
Theorem woset_no_descending_chain : ∀ A R,
  woset A R → ¬ ∃ f, descending_chain f A R.
Proof with neauto.
  intros * [Hlo Hmin] [f [[Hf [Hd Hr]] Hlt]].
    assert (Hne: ⦿ ran f). {
      exists (f[0]). eapply ranI.
      apply func_correct... rewrite Hd...
    }
    apply Hmin in Hne as [m [Hm Hle]]...
    apply ranE in Hm as [x Hp].
    apply domI in Hp as Hx. rewrite Hd in Hx.
    apply func_ap in Hp as Hap... subst m.
    assert (Hfx: f[x⁺] ∈ ran f). {
      eapply ap_ran. split... apply ω_inductive...
    }
    apply Hlt in Hx. apply Hle in Hfx.
    eapply lo_not_le_gt...
Qed.

(* ==需要选择公理== *)
(* 非良序的关系存在无穷降链 *)
Lemma non_woset_ex_descending_chain : AC_I → ∀ A R, ⦿ A →
  (∀y ∈ A, ∃x ∈ A, (x <ᵣ y) R) →
  ∃ f, descending_chain f A R.
Proof with eauto.
  intros AC1 * [a Ha] Hpr.
  set {p ∊ R | π1 p ∈ A ∧ π2 p ∈ A} as R'.
  pose proof (inv_rel R') as Hrel'.
  apply AC1 in Hrel' as [F [HfF [HsF HdF]]].
  assert (HF: F: A ⇒ A). {
    split; [|split]...
    - rewrite HdF. rewrite inv_dom.
      ext y Hy.
      + apply ranE in Hy as [x Hp].
        apply SepE in Hp as [_ [_ Hy]]. zfc_simple.
      + pose proof (Hpr _ Hy) as [x [Hx Hp]].
        eapply ranI. apply SepI. apply Hp. zfc_simple...
    - intros y Hy. apply ranE in Hy as [x Hp].
      apply HsF in Hp. apply inv_op in Hp.
      apply SepE in Hp as [_ [Hx _]]. zfc_simple.
  }
  pose proof (ω_recursion _ _ _ HF Ha) as [f [Hf [Hf0 Heq]]].
  exists f. split... intros n Hn. rewrite Heq...
  assert (HsR: R' ⊆ R). { intros p Hp. apply SepE1 in Hp... }
  apply HsR. rewrite inv_op. apply HsF. apply func_correct...
  destruct HF as [_ [Hd _]]. rewrite Hd. eapply ap_ran...
Qed.

(* ==需要选择公理== *)
(* 全序是良序当且仅当其上不存在无穷降链 *)
Theorem woset_iff_no_descending_chain :
  AC_I → ∀ A R, loset A R →
  woset A R ↔ ¬ ∃ f, descending_chain f A R.
Proof with neauto.
  intros AC1 * Hlo. split.
  - intros Hwo. apply woset_no_descending_chain...
  - intros Hndc. split... intros B Hne Hsub.
    destruct (classic (∃ m, minimum m B R))...
    pose proof (non_woset_ex_descending_chain AC1 B R Hne) as [f Hdc]. {
      intros y Hy. eapply not_ex_all_not in H.
      apply not_and_or in H as []. exfalso...
      apply set_not_all_ex_not in H as [x [Hx H]].
      apply not_or_and in H as []. exists x. split...
      apply Hsub in Hy. apply Hsub in Hx.
      eapply lo_connected in H0 as []... exfalso...
    }
    exfalso. apply Hndc. exists f.
    destruct Hdc as [[Hf [Hd Hr]] Hdc].
    split... split... split... eapply sub_trans...
Qed.

(* 前节 *)
(* initial segment *)
Definition seg := λ t R, {x ∊ dom R | (x <ᵣ t) R}.
Definition head := λ t A R, {x ∊ A | (x ≤ᵣ t) R}.
Definition tail := λ t A R, {x ∊ A | (t <ᵣ x) R}.

Lemma segI : ∀ x t R, (x <ᵣ t) R → x ∈ seg t R.
Proof with eauto.
  intros. apply SepI... eapply domI...
Qed.

Lemma seg_0_Lt : seg 0 Lt = ∅.
Proof.
  apply ExtAx; split; intros Hx.
  apply SepE in Hx as [_ Hx0].
  apply binRelE3 in Hx0. exfalso0. exfalso0.
Qed.

Lemma seg_injective : ∀ A R, loset A R → ∀ a b ∈ A,
  seg a R = seg b R → a = b.
Proof with eauto.
  intros A R Hlo a Ha b Hb Heq.
  contra.
  eapply lo_connected in H as []...
  - assert (a ∈ seg b R). apply segI...
    rewrite <- Heq in H0. apply SepE2 in H0. eapply lo_irrefl...
  - assert (b ∈ seg a R). apply segI...
    rewrite Heq in H0. apply SepE2 in H0. eapply lo_irrefl...
Qed.

Lemma seg_with_single_eq_head : ∀ t A R, t ∈ A → is_binRel R A →
  seg t R ∪ {t,} = head t A R.
Proof with eauto.
  intros * Ht Hbr. ext Hx.
  - apply BUnionE in Hx as [].
    + apply SepE in H as [Hx Hxt].
      apply SepI. eapply dom_binRel... left...
    + apply SingE in H; subst. apply SepI... right...
  - apply SepE in Hx as [Hx [Hlt|Heq]].
    + apply BUnionI1. apply segI...
    + apply BUnionI2. subst...
Qed.

(* 自然数的前节等于自身 *)
Example seg_of_nat : ∀n ∈ ω, seg n Lt = n.
Proof with eauto.
  intros n Hn. ext Hx.
  - apply SepE in Hx as [_ Hp].
    apply SepE in Hp as [_ H]. zfc_simple.
  - assert (Hxw: x ∈ ω). { eapply ω_trans... }
    apply SepI. eapply domI. apply (binRelI _ _ x Hxw (x⁺))...
    apply ω_inductive... apply binRelI...
Qed.

(* 归纳子集 *)
Definition inductive_subset : set → set → set → Prop := λ B A R,
  B ⊆ A ∧ ∀t ∈ A, seg t R ⊆ B → t ∈ B.

(* 超限归纳原理：良序集的归纳子集与自身相等 *)
Theorem transfinite_induction : ∀ A R, woset A R →
  ∀ B, inductive_subset B A R → B = A.
Proof with auto.
  intros A R [[Hbr [Htr Htri]] Hwo] B [Hsub Hind].
  contra as Hnq.
  assert (Hne: ⦿ (A - B)) by (apply comp_nonempty; split; auto).
  apply Hwo in Hne as [m [Hm Hmin]]...
  apply SepE in Hm as [Hm Hm']. apply Hm'. apply Hind...
  intros x Hx. apply SepE in Hx as [_ Hp].
  apply Hbr in Hp as Hx. apply CPrdE2 in Hx as [Hx _].
  contra as Hx'.
  assert (x ∈ A - B) by (apply SepI; auto).
  apply Hmin in H as []; firstorder.
Qed.

(* 线序集良序当且仅当其归纳子集与自身相等 *)
Theorem woset_iff_inductive : ∀ A R, loset A R →
  woset A R ↔ ∀ B, inductive_subset B A R → B = A.
Proof with eauto; try congruence.
  intros A R Hlo.
  split. { apply transfinite_induction. }
  intros Hind. split... intros C [c Hc] Hsub.
  (* strict lower bounds of C *)
  set {t ∊ A | ∀x ∈ C, (t <ᵣ x) R} as B.
  destruct (classic (inductive_subset B A R)).
  - exfalso. apply Hsub in Hc as Hc'.
    apply Hind in H. rewrite <- H in Hc'.
    apply SepE in Hc' as [_ Hp]. apply Hp in Hc.
    eapply lo_irrefl...
  - apply not_and_or in H as []. {
      exfalso. apply H. intros x Hx. apply SepE1 in Hx...
    }
    apply set_not_all_ex_not in H as [t [Hta H]].
    apply imply_to_and in H as [Hseg Htb].
    cut (∀x ∈ C, (t ≤ᵣ x) R). {
      intros H. exists t. split...
      destruct (classic (t ∈ C)) as [|Htc]...
      exfalso. apply Htb. apply SepI...
      intros x Hx. pose proof (H x Hx) as []...
    }
    intros x Hxc. apply Hsub in Hxc as Hxa.
    destruct (classic (t = x)). right...
    eapply lo_connected in H as [|Hxt]... left...
    exfalso. assert (Hxb: x ∈ B). {
      apply Hseg. apply segI...
    }
    apply SepE in Hxb as [_ H]. apply H in Hxc.
    eapply lo_irrefl...
Qed.

(* 以前节为定义域的所有函数 *)
Definition SegFuncs : set → set → set → set := λ A R B,
  {f ∊ 𝒫 (A × B) | ∃ t ∈ A, f: seg t R ⇒ B}.

(* 超限递归定理初级表述 *)
Definition transfinite_recursion_preliminary_form :=
  ∀ A R B G, woset A R → G: SegFuncs A R B ⇒ B →
  ∃! F, F: A ⇒ B ∧ ∀t ∈ A, F[t] = G[F ↾ seg t R].

(* 超限递归定理模式 *)
Definition transfinite_recursion_schema :=
  ∀ A R γ, woset A R → (∀ f, ∃! y, γ f y) →
  ∃! F, is_function F ∧ dom F = A ∧ ∀t ∈ A, γ (F ↾ seg t R) F[t].

(* 超限递归定理模式蕴含其初级表述 *)
Fact transfinite_recursion_schema_to_preliminary_form :
  transfinite_recursion_schema →
  transfinite_recursion_preliminary_form.
Proof with eauto; try congruence.
  intros Schema A R B G Hwo HG.
  set (λ f y, y = G[f]) as γ.
  pose proof (Schema A R γ Hwo) as [F [[HF [Hd Hrec]] Hu]]. {
    intros f. rewrite <- unique_existence.
    split. exists (G[f])... intros...
  }
  set {x ∊ A | F[x] ∈ B} as A'.
  replace A with A' in *. {
    assert (Hr: ran F ⊆ B). {
      intros y Hy. apply ranE in Hy as [x Hp].
      apply domI in Hp as Hx. rewrite Hd in Hx.
      apply func_ap in Hp... apply SepE2 in Hx...
    }
    rewrite <- unique_existence. split.
    exists F. split. split... intros t Ht. rewrite Hrec...
    intros f1 f2 [[Hf1 [Hd1 Hr1]] H1] [[Hf2 [Hd2 Hr2]] H2].
    rewrite <- Hu... rewrite <- Hu at 1...
  }
  eapply transfinite_induction... split.
  - intros x Hx. apply SepE1 in Hx...
  - intros t Ht Hsub. apply SepI...
    rewrite Hrec... eapply ap_ran... apply SepI.
    + apply PowerAx. intros p Hp.
      apply restrE1 in Hp as [a [b [Ha [Hp Heq]]]]. subst p.
      apply Hsub in Ha. apply SepE in Ha as [Ha HFa].
      apply func_ap in Hp... apply CPrdI...
    + exists t. split... split; [|split].
      * apply restr_func...
      * apply restr_dom... eapply sub_trans. apply Hsub.
        rewrite Hd. intros x Hx. apply SepE1 in Hx...
      * intros y Hy. apply ranE in Hy as [x Hp].
        apply restrE2 in Hp as [Hp Hx]. apply func_ap in Hp...
        apply Hsub in Hx. apply SepE2 in Hx...
Qed.

(* 替代公理再考 *)
Local Fact sometimes_replacement_is_simpler_than_separation : ∀ A,
  {𝒫 a | a ∊ A} = {x ∊ 𝒫 𝒫 ⋃A | ∃a ∈ A, x = 𝒫 a}.
Proof with auto.
  intro. ext Hx.
  - apply ReplAx in Hx as [a [Ha Heq]]. subst x.
    apply SepI. apply ex2_10... exists a. split...
  - apply SepE in Hx as [_ [a [Ha Heq]]]. subst x.
    apply ReplI...
Qed.

(* 超限递归定理模式的证明 *)
Theorem transfinite_recursion : transfinite_recursion_schema.
Proof with eauto; try congruence.
  intros A R γ Hwo Hu.
  assert (H := Hwo). destruct H as [Hlo Hmin].
  assert (H := Hlo). destruct H as [Hbr [Htr _]].
  set (λ t, seg t R) as seg.
  set (λ t, head t A R) as head.
  set (λ t ν, dom ν = head t ∧ ∀x ∈ dom ν, γ (ν ↾ seg x) ν[x]) as γ_constr.
  assert (HL1: ∀ ν₁ ν₂, ∀ t₁ t₂ ∈ A, (t₁ ≤ᵣ t₂) R →
    is_function ν₁ → is_function ν₂ → γ_constr t₁ ν₁ → γ_constr t₂ ν₂ →
    ∀x ∈ A, (x ≤ᵣ t₁) R → ν₁[x] = ν₂[x]
  ). {
    intros ν₁ ν₂ t₁ Ht₁ t₂ Ht₂ Htle Hf₁ Hf₂ [Hd₁ Hr₁] [Hd₂ Hr₂].
    destruct (classic (∀x ∈ A, (x ≤ᵣ t₁) R → ν₁[x] = ν₂[x]))...
    exfalso. apply set_not_all_ex_not in H as [s [Hs H]].
    apply imply_to_and in H as [Hst1 Hnqt].
    set {x ∊ A | ν₁ [x] ≠ ν₂ [x]} as B.
    specialize Hmin with B as [m [Hm Hmin]].
      { exists s. apply SepI... }
      { intros x Hx. apply SepE1 in Hx... }
    apply SepE in Hm as [Hm Hnqm]. apply Hnqm.
    assert (Hms: (m ≤ᵣ s) R) by (apply Hmin; apply SepI; auto).
    assert (Hmt₁: (m ≤ᵣ t₁) R) by (apply (relLe_trans m s t₁ R); auto).
    assert (Hmt₂: (m ≤ᵣ t₂) R) by (apply (relLe_trans m t₁ t₂ R); auto).
    assert (Hmd₁: m ∈ head t₁) by (apply SepI; auto).
    assert (Hmd₂: m ∈ head t₂) by (apply SepI; auto).
    eapply unique_existence. eapply Hu. apply Hr₁...
    replace (ν₁ ↾ seg m) with (ν₂ ↾ seg m). apply Hr₂...
    ext Hx.
    - apply restrE1 in Hx as [a [b [Ha [Hp Heqx]]]].
      subst x. apply restrI...
      apply SepE in Ha as [Ha Ham]. eapply dom_binRel in Ha...
      apply func_ap in Hp... apply func_point...
      rewrite Hd₁. apply SepI... apply (relLe_trans a m t₁ R)... left...
      destruct (classic (ν₁[a] = ν₂[a])) as [|Hnq]... exfalso.
      assert (a ∈ B) by (apply SepI; auto).
      apply Hmin in H. eapply lo_not_le_gt...
    - apply restrE1 in Hx as [a [b [Ha [Hp Heqx]]]].
      subst x. apply restrI...
      apply SepE in Ha as [Ha Ham]. eapply dom_binRel in Ha...
      apply func_ap in Hp... apply func_point...
      rewrite Hd₂. apply SepI... apply (relLe_trans a m t₂ R)... left...
      destruct (classic (ν₁[a] = ν₂[a])) as [|Hnq]... exfalso.
      assert (a ∈ B) by (apply SepI; auto).
      apply Hmin in H. eapply lo_not_le_gt...
  }
  assert (HL1_1: ∀ ν₁ ν₂, ∀ t ∈ A, is_function ν₁ → is_function ν₂ →
    γ_constr t ν₁ → γ_constr t ν₂ → ∀x ∈ A, (x ≤ᵣ t) R → ν₁[x] = ν₂[x]
  ). {
    intros ν₁ ν₂ t Ht Hf₁ Hf₂ Hγ₁ Hγ₂.
    eapply HL1... right...
  }
  assert (HL1_2: ∀ ν₁ ν₂, ∀ t ∈ A, is_function ν₁ → is_function ν₂ →
    γ_constr t ν₁ → γ_constr t ν₂ → ν₁ = ν₂
  ). {
    intros ν₁ ν₂ t Ht Hf₁ Hf₂ Hγ₁ Hγ₂.
    assert (H := Hγ₁). destruct H as [Hd₁ _].
    assert (H := Hγ₂). destruct H as [Hd₂ _].
    apply func_ext_intro... intros x Hx. rewrite Hd₁ in Hx.
    eapply HL1_1... apply SepE1 in Hx... apply SepE2 in Hx...
  }
  set (λ t ν, is_function ν ∧ γ_constr t ν) as ϕ.
  set {t ∊ A | ∃ ν, ϕ t ν} as A'.
  (* first time that ϕ_Repl is a must *)
  set (ϕ_Repl ϕ A') as ℋ.
  set (⋃ ℋ) as F.
  assert (Hϕ: ∀t ∈ A', ∃! ν, ϕ t ν). {
    intros t Ht. apply SepE in Ht as [Ht H].
    rewrite <- unique_existence. split...
    intros ν μ [] []. eapply HL1_2...
  }
  assert (Hrepl: ∀ ν, ν ∈ ℋ ↔ is_function ν ∧ ∃t ∈ A, γ_constr t ν). {
    intros. split.
    - intros Hν. apply ϕ_ReplAx in Hν as [t [Ht [Hfν Hγ]]]; [|apply Hϕ].
      split... exists t. split... apply SepE1 in Ht...
    - intros [Hfν [t [Ht Hγ]]]. apply ϕ_ReplAx. apply Hϕ.
      exists t. split. apply SepI... exists ν. split... split...
  }
  assert (Hstar: ∀ x y, <x, y> ∈ F ↔ ∃ν ∈ ℋ, <x, y> ∈ ν). {
    intros. split.
    - intros Hp. apply UnionAx in Hp as [ν [Hν Hp]].
      exists ν. split...
    - intros [ν [Hν Hap]]. apply UnionAx.
      exists ν. split...
  }
  assert (Hhd: ∀ ν t x y, γ_constr t ν → <x, y> ∈ ν → x ∈ A ∧ (x ≤ᵣ t) R). {
    intros * [Hd _] Hp. apply domI in Hp as Hx.
    rewrite Hd in Hx. apply SepE in Hx...
  }
  assert (HfF: is_function F). {
    repeat split.
    - intros p Hp. apply UnionAx in Hp as [ν [Hν Hp]].
      apply Hrepl in Hν as [[Hrel _] _]. apply Hrel...
    - intros x H. rewrite <- unique_existence.
      split. apply domE in H...
      intros y₁ y₂ Hp₁ Hp₂.
      apply Hstar in Hp₁ as [ν₁ [Hν₁ Hp₁]].
      apply Hstar in Hp₂ as [ν₂ [Hν₂ Hp₂]].
      apply Hrepl in Hν₁ as [Hf₁ [t₁ [Ht₁ Hγ₁]]].
      apply Hrepl in Hν₂ as [Hf₂ [t₂ [Ht₂ Hγ₂]]].
      apply func_ap in Hp₁ as Hν₁... eapply Hhd in Hp₁ as [Hx Hhd₁]...
      apply func_ap in Hp₂ as Hν₂... eapply Hhd in Hp₂ as [_ Hhd₂]...
      destruct (classic (t₁ = t₂)) as [Heq|Hnq].
      + rewrite (HL1_1 ν₁ ν₂ t₁ Ht₁) in Hν₁...
      + eapply lo_connected in Hnq as []...
        * rewrite (HL1 ν₁ ν₂ t₁ Ht₁ t₂ Ht₂) in Hν₁... left...
        * rewrite (HL1 ν₂ ν₁ t₂ Ht₂ t₁ Ht₁) in Hν₂... left...
  }
  assert (HL2: ∀x ∈ dom F, γ (F ↾ seg x) F[x]). {
    intros x Hx. apply domE in Hx as [y Hp].
    apply Hstar in Hp as [ν [Hν Hpν]]. assert (Hν' := Hν).
    apply Hrepl in Hν' as [Hfν [t [Ht Hγν]]].
    apply domI in Hpν as Hx. apply Hγν in Hx as Hνx.
    assert (Heq1: F[x] = ν[x]). {
      apply func_ap... apply Hstar.
      exists ν. split... apply func_correct...
    }
    assert (Heq2: ν ↾ seg x = F ↾ seg x). {
      ext p Hp.
      - apply restrE1 in Hp as [a [b [Ha [Hp Heq]]]]. subst p.
        apply restrI... apply Hstar. exists ν. split...
      - apply restrE1 in Hp as [a [b [Ha [Hp Heq]]]]. subst p.
        apply restrI... apply Hstar in Hp as [μ [Hμ Hp]].
        apply Hrepl in Hμ as [Hfμ [s [Hs Hγμ]]].
        assert (H := Hγμ). destruct H as [Hdμ _].
        assert (H := Hγν). destruct H as [Hdν _].
        apply domI in Hp as Hadμ. rewrite Hdμ in Hadμ.
        apply SepE in Hadμ as [HaA Has].
        assert (Hat: (a ≤ᵣ t) R). {
          rewrite Hdν in Hx. apply SepE in Hx as [Hx Hxt].
          apply SepE in Ha as [_ Hax]. left. eapply relLt_le_trans...
        }
        apply func_ap in Hp... apply func_point...
        rewrite Hdν. apply SepI... subst b.
        destruct (classic (t = s)).
        + apply (HL1 ν μ t Ht s Hs)... right...
        + eapply lo_connected in H as []...
          * apply (HL1 ν μ t Ht s Hs)... left...
          * symmetry. apply (HL1 μ ν s Hs t Ht)... left...
    }
    congruence.
  }
  assert (HL3: dom F = A). {
    contra as Hnq.
    assert (Hps: dom F ⊂ A). {
      split... intros x Hx. apply domE in Hx as [y Hp].
      apply Hstar in Hp as [ν [Hν Hp]].
      apply Hrepl in Hν as [_ [t [_ Hγ]]]. eapply Hhd...
    }
    set {x ∊ A | x ∉ dom F} as B.
    specialize Hmin with B as [t [Ht Hmin]]. {
      apply comp_nonempty in Hps as [a Ha].
      apply SepE in Ha as [Ha Ha']. exists a. apply SepI...
    } {
      intros x Hx. apply SepE1 in Hx...
    }
    apply SepE in Ht as [Ht Ht']. apply Ht'.
    assert (Hseg: seg t = dom F). {
      ext Hx.
      - apply SepE in Hx as [Hx Hxt].
        apply (dom_binRel R A) in Hx...
        contra.
        assert (Hxb: x ∈ B) by (apply SepI; auto).
        apply Hmin in Hxb. eapply lo_not_le_gt...
      - apply Hps in Hx as Hxa. apply segI...
        destruct (classic (x = t))...
        eapply lo_connected in H as []... exfalso.
        apply domE in Hx as [y Hp]. apply Hstar in Hp as [ν [Hν Hp]].
        apply Ht'. eapply domI. apply Hstar. exists ν. split...
        apply Hrepl in Hν as [Hfν [s [Hs [Hdν Hγ]]]].
        apply func_point... rewrite Hdν. apply SepI...
        apply domI in Hp as Hx. rewrite Hdν in Hx.
        apply SepE in Hx as [_ Hxs]. left. eapply relLt_le_trans...
    }
    specialize Hu with F as [y [Hγ _]].
    set (F ∪ {<t, y>,}) as ν.
    assert (Hfs : is_function {<t, y>,})
      by apply single_pair_is_func.
    assert (Hfν: is_function ν). {
      apply bunion_is_func...
      intros x Hx. apply BInterE in Hx as [H1 H2].
      rewrite dom_of_single_pair in H2. apply SingE in H2; subst...
    }
    assert (Hdν: dom ν = head t). {
      unfold ν. rewrite dom_of_bunion_func...
      rewrite dom_of_single_pair, <- Hseg.
      apply seg_with_single_eq_head...
    }
    eapply domI. apply Hstar. exists ν. split; revgoals.
    apply func_point... rewrite Hdν. apply SepI... right...
    apply Hrepl. split... exists t. split... split...
    intros x Hx. rewrite Hdν in Hx.
    apply SepE in Hx as [Hx [Hxt|Heqx]].
    - assert (Hxs: x ∈ seg t) by (apply segI; auto).
      rewrite Hseg in Hxs. apply HL2 in Hxs.
      assert (Heq1: ν ↾ seg x = F ↾ seg x). {
        ext p Hp.
        - apply restrE1 in Hp as [a [b [Ha [Hp Heq]]]]. subst p.
          apply restrI... apply BUnionE in Hp as []...
          exfalso. apply SingE in H. apply op_iff in H as []; subst.
          apply SepE in Ha as [_ Htx]. eapply lo_irrefl...
        - apply restrE1 in Hp as [a [b [Ha [Hp Heq]]]]. subst p.
          apply restrI... apply BUnionI1...
      }
      assert (Heq2: ν[x] = F[x]). {
        apply func_ap... apply BUnionI1. apply func_correct...
        rewrite <- Hseg. apply segI...
      }
      congruence.
    - assert (Heq1: ν ↾ seg t = F). {
        ext p Hp.
        - apply restrE1 in Hp as [a [b [Ha [Hp Heq]]]]. subst p.
          apply BUnionE in Hp as []...
          exfalso. apply SingE in H. apply op_iff in H as []; subst.
          apply SepE in Ha as [_ Htx]. eapply lo_irrefl...
        - apply func_pair in Hp as Heqp... rewrite Heqp in *.
          apply restrI. apply domI in Hp... apply BUnionI1...
      }
      assert (Heq2: ν[t] = y). {
        apply func_ap... apply BUnionI2...
      }
      congruence.
  }
  rewrite HL3 in HL2.
  rewrite <- unique_existence. split. exists F. split...
  (* uniqueness *)
  intros F₁ F₂ [HfF₁ [HdF₁ Hγ₁]] [HfF₂ [HdF₂ Hγ₂]].
  apply func_ext_intro...
  intros x Hx. rewrite HdF₁ in Hx.
  set {t ∊ A | F₁[t] = F₂[t]} as B.
  replace A with B in Hx. apply SepE2 in Hx...
  eapply transfinite_induction...
  split. intros t Ht. apply SepE1 in Ht...
  intros t Ht Hsub. apply SepI...
  apply Hγ₁ in Ht as H1. apply Hγ₂ in Ht as H2.
  replace (F₂ ↾ EST7_2.seg t R) with (F₁ ↾ EST7_2.seg t R) in H2.
  eapply unique_existence. eapply Hu. apply H1. apply H2.
  ext w Hw.
  - apply restrE1 in Hw as [a [b [Ha [Hp Hw]]]]. subst w.
    apply restrI... apply Hsub in Ha. apply SepE in Ha as [Ha Heq].
    apply func_ap in Hp... apply func_point...
  - apply restrE1 in Hw as [a [b [Ha [Hp Hw]]]]. subst w.
    apply restrI... apply Hsub in Ha. apply SepE in Ha as [Ha Heq].
    apply func_ap in Hp... apply func_point...
Qed.

Theorem transfinite_recursion_pre : transfinite_recursion_preliminary_form.
Proof.
  apply transfinite_recursion_schema_to_preliminary_form.
  apply transfinite_recursion.
Qed.

Module Import TransfiniteRecursion.

Definition recursion_spec :=
  λ A R (γ : set → set → Prop) F,
  is_function F ∧ dom F = A ∧ ∀t ∈ A, γ (F ↾ seg t R) F[t].

Definition Recursion :=
  λ A R γ, describe (recursion_spec A R γ).

Lemma recursion_spec_intro :
  ∀ A R γ, woset A R → (∀ x, ∃! y, γ x y) →
  recursion_spec A R γ (Recursion A R γ).
Proof.
  intros. apply (desc_spec (recursion_spec A R γ)).
  apply transfinite_recursion; auto.
Qed.

End TransfiniteRecursion.

(** 传递闭包 **)
Module Import TransitiveClosureDef.

Definition γ := λ A x y, y = A ∪ ⋃ ⋃ (ran x).

Definition F := λ A, Recursion ω Lt (γ A).

Lemma f_spec : ∀ A, recursion_spec ω Lt (γ A) (F A).
Proof.
  intros. apply recursion_spec_intro. apply Lt_wellOrder.
  intros f. rewrite <- unique_existence.
  split. exists (A ∪ ⋃ ⋃ (ran f)). congruence. congruence.
Qed.

Fact f_0 : ∀ A, (F A)[0] = A.
Proof with nauto.
  intros. destruct (f_spec A) as [Hf [Hd Hγ]].
  rewrite Hγ, seg_0_Lt, restr_to_empty, ran_of_empty,
    union_empty, union_empty, bunion_empty...
Qed.

Fact f_1 : ∀ A, (F A)[1] = A ∪ ⋃ A.
Proof with nauto.
  intros. destruct (f_spec A) as [Hf [Hd Hγ]].
  rewrite Hγ... replace (ran (F A ↾ seg 1 Lt)) with {A,}.
  rewrite union_single...
  apply ExtAx; intros y; split; intros Hy.
  - apply SingE in Hy; subst.
    apply (ranI _ 0). apply restrI.
    + apply segI. apply binRelI... apply suc_has_n.
    + apply func_point... rewrite Hd... apply f_0.
  - apply ranE in Hy as [].
    apply restrE2 in H as [Hp Hx].
    apply SepE in Hx as [_ Hx1].
    apply binRelE3 in Hx1.
    apply BUnionE in Hx1 as []. exfalso0.
    apply SingE in H; subst. apply func_ap in Hp...
    rewrite f_0 in Hp; subst...
Qed.

Lemma f_ap_preserve_lt : ∀ A, ∀ n m ∈ ω,
  n ∈ m → (F A)[n] ⊆ (F A)[m].
Proof with auto.
  intros A n Hn m Hm Hnm.
  destruct (f_spec A) as [Hf [Hd Hγ]].
  rewrite Hγ, Hγ... intros y Hy.
  apply BUnionE in Hy as [|Hy]; [apply BUnionI1|apply BUnionI2]...
  apply UnionAx in Hy as [a [Ha Hy]].
  apply UnionAx in Ha as [b [Hb Ha]].
  apply UnionAx. exists a. split...
  apply UnionAx. exists b. split...
  apply ranE in Hb as [x Hp].
  apply restrE2 in Hp as [Hp Hx].
  apply (ranI _ x). apply restrI...
  apply segI. apply SepE in Hx as [_ Hxn].
  eapply Lt_trans; eauto. apply binRelI...
Qed.

Lemma f_n : ∀ A, ∀n ∈ ω, (F A)[n⁺] = A ∪ ⋃ (F A)[n].
Proof with auto; try congruence.
  intros A n Hn.
  destruct (f_spec A) as [Hf [Hd Hγ]].
  assert (Hnp: n⁺ ∈ ω) by (apply ω_inductive; auto).
  rewrite Hγ...
  apply ExtAx; intros y; split; intros Hy;
  (apply BUnionE in Hy as [|Hy]; [apply BUnionI1|apply BUnionI2])...
  - apply UnionAx in Hy as [a [Ha Hy]].
    apply UnionAx in Ha as [b [Hb Ha]].
    apply ranE in Hb as [c Hp].
    apply restrE2 in Hp as [Hp Hc].
    apply func_ap in Hp... subst.
    apply SepE in Hc as [_ Hc].
    apply binRelE2 in Hc as [Hc [_ Hcn]].
    apply UnionAx. exists a. split...
    apply le_iff_lt_suc in Hcn as []...
    apply (f_ap_preserve_lt _ c)...
  - apply UnionAx in Hy as [a [Ha Hy]].
    apply UnionAx. exists a. split...
    apply UnionAx. exists ((F A)[n]). split...
    apply (ranI _ n). apply restrI.
    apply segI. apply binRelI...
    apply func_correct...
Qed.

Lemma f_inclusion : ∀ A, ∀n ∈ ω, ∀a ∈ (F A)[n], a ⊆ (F A)[n⁺].
Proof with neauto.
  intros A n Hn.
  ω_induction n; intros a Ha x Hx.
  - rewrite f_0 in Ha. rewrite f_1.
    apply BUnionI2. apply UnionAx. exists a. split...
  - rewrite f_n in Ha...
    rewrite f_n, f_n; [..|apply ω_inductive]...
    apply BUnionE in Ha as []; apply BUnionI2.
    + apply UnionAx. exists a. split... apply BUnionI1...
    + apply UnionAx. exists a. split... apply BUnionI2...
Qed.

End TransitiveClosureDef.

Definition TransitiveClosure := λ A, ⋃ (ran (F A)).
Notation 𝗧𝗖 := TransitiveClosure.

(* 传递闭包是传递集 *)
Theorem tc_trans : ∀ A, trans (𝗧𝗖 A).
Proof with auto; try congruence.
  intros A x y Hxy Hy.
  destruct (f_spec A) as [Hf [Hd _]].
  apply UnionAx in Hy as [a [Ha Hy]].
  apply ranE in Ha as [n Hp]. apply domI in Hp as Hn.
  apply func_ap in Hp... subst a.
  apply f_inclusion in Hy... apply Hy in Hxy.
  apply UnionAx. exists ((F A)[n⁺]). split...
  eapply ranI. apply func_point...
  rewrite Hd. apply ω_inductive...
Qed.

(* 传递闭包包含原集合 *)
Theorem tc_contains : ∀ A, A ⊆ 𝗧𝗖 A.
Proof with nauto.
  intros A x Hx.
  destruct (f_spec A) as [Hf [Hd _]].
  apply UnionAx. exists A. split...
  apply (ranI _ 0). apply func_point...
  rewrite Hd... apply f_0.
Qed.


(** Prove that, for any ordinal [0 < alpha < epsilon0], [alpha] is a limit
  if and only if forall ordinal [beta < alpha], there exists an infinite
  number of ordinals betawee [beta] and [alpha]
 *)

From hydras Require Import Epsilon0 T1.
Open Scope t1_scope.
From Coq Require Import Ensembles Image Compare_dec.

Definition Infinite {A: Type} (E: Ensemble A) :=
  exists s: nat -> A, injective nat A s /\ forall i, In  E (s i).

Section On_alpha.

  Variable alpha: T1.
  Hypothesis Halpha : nf alpha.
  Hypothesis HnonZero : alpha <> zero.

  Theorem Limit_Infinity :
    limitb alpha <->
    (forall beta,
        beta t1< alpha ->
        Infinite (fun gamma =>  beta t1< gamma t1< alpha)).
  Admitted.

End On_alpha.


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

Require Import ZArith Zquot.
Require Import BigNumPrelude.
Require Import NSig.
Require Import ZSig.

Open Scope Z_scope.

(** * ZMake

  A generic transformation from a structure of natural numbers
  [NSig.NType] to a structure of integers [ZSig.ZType].
*)

Module Make (N:NType) <: ZType.

 Inductive t_ :=
  | Pos : N.t -> t_
  | Neg : N.t -> t_.

 Definition t := t_.

 Bind Scope abstract_scope with t t_.

 Definition zero := Pos N.zero.
 Definition one  := Pos N.one.
 Definition two := Pos N.two.
 Definition minus_one := Neg N.one.

 Definition of_Z x :=
  match x with
  | Zpos x => Pos (N.of_N (Npos x))
  | Z0 => zero
  | Zneg x => Neg (N.of_N (Npos x))
  end.

 Definition to_Z x :=
  match x with
  | Pos nx => N.to_Z nx
  | Neg nx => Zopp (N.to_Z nx)
  end.

 Theorem spec_of_Z: forall x, to_Z (of_Z x) = x.
 Proof.
 intros x; case x; unfold to_Z, of_Z, zero.
   exact N.spec_0.
   intros; rewrite N.spec_of_N; auto.
   intros; rewrite N.spec_of_N; auto.
 Qed.

 Definition eq x y := (to_Z x = to_Z y).

 Theorem spec_0: to_Z zero = 0.
 exact N.spec_0.
 Qed.

 Theorem spec_1: to_Z one = 1.
 exact N.spec_1.
 Qed.

 Theorem spec_2: to_Z two = 2.
 exact N.spec_2.
 Qed.

 Theorem spec_m1: to_Z minus_one = -1.
 simpl; rewrite N.spec_1; auto.
 Qed.

 Definition compare x y :=
  match x, y with
  | Pos nx, Pos ny => N.compare nx ny
  | Pos nx, Neg ny =>
    match N.compare nx N.zero with
    | Gt => Gt
    | _ => N.compare ny N.zero
    end
  | Neg nx, Pos ny =>
    match N.compare N.zero nx with
    | Lt => Lt
    | _ => N.compare N.zero ny
    end
  | Neg nx, Neg ny => N.compare ny nx
  end.

 Theorem spec_compare :
  forall x y, compare x y = Zcompare (to_Z x) (to_Z y).
 Proof.
 unfold compare, to_Z.
 destruct x as [x|x], y as [y|y];
 rewrite ?N.spec_compare, ?N.spec_0, <-?Zcompare_opp; auto;
 assert (Hx:=N.spec_pos x); assert (Hy:=N.spec_pos y);
 set (X:=N.to_Z x) in *; set (Y:=N.to_Z y) in *; clearbody X Y.
 destruct (Zcompare_spec X 0) as [EQ|LT|GT].
  rewrite EQ. rewrite <- Zopp_0 at 2. apply Zcompare_opp.
  exfalso. omega.
  symmetry. change (X > -Y). omega.
 destruct (Zcompare_spec 0 X) as [EQ|LT|GT].
  rewrite <- EQ. rewrite Zopp_0; auto.
  symmetry. change (-X < Y). omega.
  exfalso. omega.
 Qed.

 Definition eq_bool x y :=
  match compare x y with
  | Eq => true
  | _ => false
  end.

 Theorem spec_eq_bool:
  forall x y, eq_bool x y = Zeq_bool (to_Z x) (to_Z y).
 Proof.
 unfold eq_bool, Zeq_bool; intros; rewrite spec_compare; reflexivity.
 Qed.

 Definition lt n m := to_Z n < to_Z m.
 Definition le n m := to_Z n <= to_Z m.

 Definition min n m := match compare n m with Gt => m | _ => n end.
 Definition max n m := match compare n m with Lt => m | _ => n end.

 Theorem spec_min : forall n m, to_Z (min n m) = Zmin (to_Z n) (to_Z m).
 Proof.
 unfold min, Zmin. intros. rewrite spec_compare. destruct Zcompare; auto.
 Qed.

 Theorem spec_max : forall n m, to_Z (max n m) = Zmax (to_Z n) (to_Z m).
 Proof.
 unfold max, Zmax. intros. rewrite spec_compare. destruct Zcompare; auto.
 Qed.

 Definition to_N x :=
  match x with
  | Pos nx => nx
  | Neg nx => nx
  end.

 Definition abs x := Pos (to_N x).

 Theorem spec_abs: forall x, to_Z (abs x) = Zabs (to_Z x).
 Proof.
 intros x; case x; clear x; intros x; assert (F:=N.spec_pos x).
    simpl; rewrite Zabs_eq; auto.
 simpl; rewrite Zabs_non_eq; simpl; auto with zarith.
 Qed.

 Definition opp x :=
  match x with
  | Pos nx => Neg nx
  | Neg nx => Pos nx
  end.

 Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x.
 Proof.
 intros x; case x; simpl; auto with zarith.
 Qed.

 Definition succ x :=
  match x with
  | Pos n => Pos (N.succ n)
  | Neg n =>
    match N.compare N.zero n with
    | Lt => Neg (N.pred n)
    | _ => one
    end
  end.

 Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1.
 Proof.
 intros x; case x; clear x; intros x.
   exact (N.spec_succ x).
 simpl. rewrite N.spec_compare. case Zcompare_spec; rewrite ?N.spec_0; simpl.
  intros HH; rewrite <- HH; rewrite N.spec_1; ring.
  intros HH; rewrite N.spec_pred, Zmax_r; auto with zarith.
 generalize (N.spec_pos x); auto with zarith.
 Qed.

 Definition add x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (N.add nx ny)
  | Pos nx, Neg ny =>
    match N.compare nx ny with
    | Gt => Pos (N.sub nx ny)
    | Eq => zero
    | Lt => Neg (N.sub ny nx)
    end
  | Neg nx, Pos ny =>
    match N.compare nx ny with
    | Gt => Neg (N.sub nx ny)
    | Eq => zero
    | Lt => Pos (N.sub ny nx)
    end
  | Neg nx, Neg ny => Neg (N.add nx ny)
  end.

 Theorem spec_add: forall x y, to_Z (add x y) = to_Z x +  to_Z y.
 Proof.
 unfold add, to_Z; intros [x | x] [y | y];
   try (rewrite N.spec_add; auto with zarith);
 rewrite N.spec_compare; case Zcompare_spec;
  unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *.
 Qed.

 Definition pred x :=
  match x with
  | Pos nx =>
    match N.compare N.zero nx with
    | Lt => Pos (N.pred nx)
    | _ => minus_one
    end
  | Neg nx => Neg (N.succ nx)
  end.

 Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1.
 Proof.
 unfold pred, to_Z, minus_one; intros [x | x];
   try (rewrite N.spec_succ; ring).
 rewrite N.spec_compare; case Zcompare_spec;
  rewrite ?N.spec_0, ?N.spec_1, ?N.spec_pred;
  generalize (N.spec_pos x); omega with *.
 Qed.

 Definition sub x y :=
  match x, y with
  | Pos nx, Pos ny =>
    match N.compare nx ny with
    | Gt => Pos (N.sub nx ny)
    | Eq => zero
    | Lt => Neg (N.sub ny nx)
    end
  | Pos nx, Neg ny => Pos (N.add nx ny)
  | Neg nx, Pos ny => Neg (N.add nx ny)
  | Neg nx, Neg ny =>
    match N.compare nx ny with
    | Gt => Neg (N.sub nx ny)
    | Eq => zero
    | Lt => Pos (N.sub ny nx)
    end
  end.

 Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y.
 Proof.
 unfold sub, to_Z; intros [x | x] [y | y];
  try (rewrite N.spec_add; auto with zarith);
 rewrite N.spec_compare; case Zcompare_spec;
  unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *.
 Qed.

 Definition mul x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (N.mul nx ny)
  | Pos nx, Neg ny => Neg (N.mul nx ny)
  | Neg nx, Pos ny => Neg (N.mul nx ny)
  | Neg nx, Neg ny => Pos (N.mul nx ny)
  end.

 Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y.
 Proof.
 unfold mul, to_Z; intros [x | x] [y | y]; rewrite N.spec_mul; ring.
 Qed.

 Definition square x :=
  match x with
  | Pos nx => Pos (N.square nx)
  | Neg nx => Pos (N.square nx)
  end.

 Theorem spec_square: forall x, to_Z (square x) = to_Z x *  to_Z x.
 Proof.
 unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring.
 Qed.

 Definition pow_pos x p :=
  match x with
  | Pos nx => Pos (N.pow_pos nx p)
  | Neg nx =>
    match p with
    | xH => x
    | xO _ => Pos (N.pow_pos nx p)
    | xI _ => Neg (N.pow_pos nx p)
    end
  end.

 Theorem spec_pow_pos: forall x n, to_Z (pow_pos x n) = to_Z x ^ Zpos n.
 Proof.
 assert (F0: forall x, (-x)^2 = x^2).
   intros x; rewrite Zpower_2; ring.
 unfold pow_pos, to_Z; intros [x | x] [p | p |];
   try rewrite N.spec_pow_pos; try ring.
 assert (F: 0 <= 2 * Zpos p).
  assert (0 <= Zpos p); auto with zarith.
 rewrite Zpos_xI; repeat rewrite Zpower_exp; auto with zarith.
 repeat rewrite Zpower_mult; auto with zarith.
 rewrite F0; ring.
 assert (F: 0 <= 2 * Zpos p).
  assert (0 <= Zpos p); auto with zarith.
 rewrite Zpos_xO; repeat rewrite Zpower_exp; auto with zarith.
 repeat rewrite Zpower_mult; auto with zarith.
 rewrite F0; ring.
 Qed.

 Definition pow_N x n :=
  match n with
  | N0 => one
  | Npos p => pow_pos x p
  end.

 Theorem spec_pow_N: forall x n, to_Z (pow_N x n) = to_Z x ^ Z_of_N n.
 Proof.
 destruct n; simpl. apply N.spec_1.
 apply spec_pow_pos.
 Qed.

 Definition pow x y :=
  match to_Z y with
  | Z0 => one
  | Zpos p => pow_pos x p
  | Zneg p => zero
  end.

 Theorem spec_pow: forall x y, to_Z (pow x y) = to_Z x ^ to_Z y.
 Proof.
 intros. unfold pow. destruct (to_Z y); simpl.
 apply N.spec_1.
 apply spec_pow_pos.
 apply N.spec_0.
 Qed.

 Definition log2 x :=
  match x with
  | Pos nx => Pos (N.log2 nx)
  | Neg nx => zero
  end.

 Theorem spec_log2: forall x, to_Z (log2 x) = Zlog2 (to_Z x).
 Proof.
  intros. destruct x as [p|p]; simpl. apply N.spec_log2.
  rewrite N.spec_0.
  destruct (Z_le_lt_eq_dec _ _ (N.spec_pos p)) as [LT|EQ].
  rewrite Zlog2_nonpos; auto with zarith.
  now rewrite <- EQ.
 Qed.

 Definition sqrt x :=
  match x with
  | Pos nx => Pos (N.sqrt nx)
  | Neg nx => Neg N.zero
  end.

 Theorem spec_sqrt: forall x, to_Z (sqrt x) = Zsqrt (to_Z x).
 Proof.
  destruct x as [p|p]; simpl.
  apply N.spec_sqrt.
  rewrite N.spec_0.
  destruct (Z_le_lt_eq_dec _ _ (N.spec_pos p)) as [LT|EQ].
  rewrite Zsqrt_neg; auto with zarith.
  now rewrite <- EQ.
 Qed.

 Definition div_eucl x y :=
  match x, y with
  | Pos nx, Pos ny =>
    let (q, r) := N.div_eucl nx ny in
    (Pos q, Pos r)
  | Pos nx, Neg ny =>
    let (q, r) := N.div_eucl nx ny in
    if N.eq_bool N.zero r
    then (Neg q, zero)
    else (Neg (N.succ q), Neg (N.sub ny r))
  | Neg nx, Pos ny =>
    let (q, r) := N.div_eucl nx ny in
    if N.eq_bool N.zero r
    then (Neg q, zero)
    else (Neg (N.succ q), Pos (N.sub ny r))
  | Neg nx, Neg ny =>
    let (q, r) := N.div_eucl nx ny in
    (Pos q, Neg r)
  end.

 Ltac break_nonneg x px EQx :=
  let H := fresh "H" in
  assert (H:=N.spec_pos x);
  destruct (N.to_Z x) as [|px|px]_eqn:EQx;
   [clear H|clear H|elim H; reflexivity].

 Theorem spec_div_eucl: forall x y,
   let (q,r) := div_eucl x y in
   (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y).
 Proof.
 unfold div_eucl, to_Z. intros [x | x] [y | y].
 (* Pos Pos *)
 generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y); auto.
 (* Pos Neg *)
 generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r).
 break_nonneg x px EQx; break_nonneg y py EQy;
 try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr;
      simpl; rewrite Hq, N.spec_0; auto).
 change (- Zpos py) with (Zneg py).
 assert (GT : Zpos py > 0) by (compute; auto).
 generalize (Z_div_mod (Zpos px) (Zpos py) GT).
 unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r').
 intros (EQ,MOD). injection 1. intros Hr' Hq'.
 rewrite N.spec_eq_bool, N.spec_0, Hr'.
 break_nonneg r pr EQr.
 subst; simpl. rewrite N.spec_0; auto.
 subst. lazy iota beta delta [Zeq_bool Zcompare].
 rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *.
 (* Neg Pos *)
 generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r).
 break_nonneg x px EQx; break_nonneg y py EQy;
 try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr;
      simpl; rewrite Hq, N.spec_0; auto).
 change (- Zpos px) with (Zneg px).
 assert (GT : Zpos py > 0) by (compute; auto).
 generalize (Z_div_mod (Zpos px) (Zpos py) GT).
 unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r').
 intros (EQ,MOD). injection 1. intros Hr' Hq'.
 rewrite N.spec_eq_bool, N.spec_0, Hr'.
 break_nonneg r pr EQr.
 subst; simpl. rewrite N.spec_0; auto.
 subst. lazy iota beta delta [Zeq_bool Zcompare].
 rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *.
 (* Neg Neg *)
 generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r).
 break_nonneg x px EQx; break_nonneg y py EQy;
 try (injection 1; intros Hr Hq; rewrite Hr, Hq; auto).
 simpl. intros <-; auto.
 Qed.

 Definition div x y := fst (div_eucl x y).

 Definition spec_div: forall x y,
     to_Z (div x y) = to_Z x / to_Z y.
 Proof.
 intros x y; generalize (spec_div_eucl x y); unfold div, Zdiv.
 case div_eucl; case Zdiv_eucl; simpl; auto.
 intros q r q11 r1 H; injection H; auto.
 Qed.

 Definition modulo x y := snd (div_eucl x y).

 Theorem spec_modulo:
   forall x y, to_Z (modulo x y) = to_Z x mod to_Z y.
 Proof.
 intros x y; generalize (spec_div_eucl x y); unfold modulo, Zmod.
 case div_eucl; case Zdiv_eucl; simpl; auto.
 intros q r q11 r1 H; injection H; auto.
 Qed.

 Definition quot x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (N.div nx ny)
  | Pos nx, Neg ny => Neg (N.div nx ny)
  | Neg nx, Pos ny => Neg (N.div nx ny)
  | Neg nx, Neg ny => Pos (N.div nx ny)
  end.

 Definition rem x y :=
  if eq_bool y zero then x
  else
    match x, y with
      | Pos nx, Pos ny => Pos (N.modulo nx ny)
      | Pos nx, Neg ny => Pos (N.modulo nx ny)
      | Neg nx, Pos ny => Neg (N.modulo nx ny)
      | Neg nx, Neg ny => Neg (N.modulo nx ny)
    end.

 Lemma spec_quot : forall x y, to_Z (quot x y) = (to_Z x) ÷ (to_Z y).
 Proof.
  intros [x|x] [y|y]; simpl; symmetry;
   rewrite N.spec_div, ?Zquot_opp_r, ?Zquot_opp_l, ?Zopp_involutive;
   rewrite Zquot_Zdiv_pos; trivial using N.spec_pos.
 Qed.

 Lemma spec_rem : forall x y,
   to_Z (rem x y) = Zrem (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold rem. rewrite spec_eq_bool, spec_0.
  assert (Hy := Zeq_bool_if (to_Z y) 0). destruct Zeq_bool.
  now rewrite Hy, Zrem_0_r.
  destruct x as [x|x], y as [y|y]; simpl in *; symmetry;
   rewrite N.spec_modulo, ?Zrem_opp_r, ?Zrem_opp_l, ?Zopp_involutive;
   try rewrite Z.eq_opp_l, Z.opp_0 in Hy;
   rewrite Zrem_Zmod_pos; generalize (N.spec_pos x) (N.spec_pos y);
   z_order.
 Qed.

 Definition gcd x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (N.gcd nx ny)
  | Pos nx, Neg ny => Pos (N.gcd nx ny)
  | Neg nx, Pos ny => Pos (N.gcd nx ny)
  | Neg nx, Neg ny => Pos (N.gcd nx ny)
  end.

 Theorem spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b).
 Proof.
 unfold gcd, Zgcd, to_Z; intros [x | x] [y | y]; rewrite N.spec_gcd; unfold Zgcd;
  auto; case N.to_Z; simpl; auto with zarith;
  try rewrite Zabs_Zopp; auto;
  case N.to_Z; simpl; auto with zarith.
 Qed.

 Definition sgn x :=
  match compare zero x with
   | Lt => one
   | Eq => zero
   | Gt => minus_one
  end.

 Lemma spec_sgn : forall x, to_Z (sgn x) = Zsgn (to_Z x).
 Proof.
 intros. unfold sgn. rewrite spec_compare. case Zcompare_spec.
 rewrite spec_0. intros <-; auto.
 rewrite spec_0, spec_1. symmetry. rewrite Zsgn_pos; auto.
 rewrite spec_0, spec_m1. symmetry. rewrite Zsgn_neg; auto with zarith.
 Qed.

 Definition even z :=
  match z with
   | Pos n => N.even n
   | Neg n => N.even n
  end.

 Definition odd z :=
  match z with
   | Pos n => N.odd n
   | Neg n => N.odd n
  end.

 Lemma spec_even : forall z, even z = Zeven_bool (to_Z z).
 Proof.
  intros [n|n]; simpl; rewrite N.spec_even; trivial.
  destruct (N.to_Z n) as [|p|p]; now try destruct p.
 Qed.

 Lemma spec_odd : forall z, odd z = Zodd_bool (to_Z z).
 Proof.
  intros [n|n]; simpl; rewrite N.spec_odd; trivial.
  destruct (N.to_Z n) as [|p|p]; now try destruct p.
 Qed.

 Definition norm_pos z :=
   match z with
     | Pos _ => z
     | Neg n => if N.eq_bool n N.zero then Pos n else z
   end.

 Definition testbit a n :=
   match norm_pos n, norm_pos a with
     | Pos p, Pos a => N.testbit a p
     | Pos p, Neg a => negb (N.testbit (N.pred a) p)
     | Neg p, _ => false
   end.

 Definition shiftl a n :=
   match norm_pos a, n with
     | Pos a, Pos n => Pos (N.shiftl a n)
     | Pos a, Neg n => Pos (N.shiftr a n)
     | Neg a, Pos n => Neg (N.shiftl a n)
     | Neg a, Neg n => Neg (N.succ (N.shiftr (N.pred a) n))
   end.

 Definition shiftr a n := shiftl a (opp n).

 Definition lor a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (N.lor a b)
     | Neg a, Pos b => Neg (N.succ (N.ldiff (N.pred a) b))
     | Pos a, Neg b => Neg (N.succ (N.ldiff (N.pred b) a))
     | Neg a, Neg b => Neg (N.succ (N.land (N.pred a) (N.pred b)))
   end.

 Definition land a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (N.land a b)
     | Neg a, Pos b => Pos (N.ldiff b (N.pred a))
     | Pos a, Neg b => Pos (N.ldiff a (N.pred b))
     | Neg a, Neg b => Neg (N.succ (N.lor (N.pred a) (N.pred b)))
   end.

 Definition ldiff a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (N.ldiff a b)
     | Neg a, Pos b => Neg (N.succ (N.lor (N.pred a) b))
     | Pos a, Neg b => Pos (N.land a (N.pred b))
     | Neg a, Neg b => Pos (N.ldiff (N.pred b) (N.pred a))
   end.

 Definition lxor a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (N.lxor a b)
     | Neg a, Pos b => Neg (N.succ (N.lxor (N.pred a) b))
     | Pos a, Neg b => Neg (N.succ (N.lxor a (N.pred b)))
     | Neg a, Neg b => Pos (N.lxor (N.pred a) (N.pred b))
   end.

 Definition div2 x := shiftr x one.

 Lemma Zlnot_alt1 : forall x, -(x+1) = Z.lnot x.
 Proof.
  unfold Z.lnot, Zpred; auto with zarith.
 Qed.

 Lemma Zlnot_alt2 : forall x, Z.lnot (x-1) = -x.
 Proof.
  unfold Z.lnot, Zpred; auto with zarith.
 Qed.

 Lemma Zlnot_alt3 : forall x, Z.lnot (-x) = x-1.
 Proof.
  unfold Z.lnot, Zpred; auto with zarith.
 Qed.

 Lemma spec_norm_pos : forall x, to_Z (norm_pos x) = to_Z x.
 Proof.
  intros [x|x]; simpl; trivial.
  rewrite N.spec_eq_bool, N.spec_0.
  assert (H := Zeq_bool_if (N.to_Z x) 0).
  destruct Zeq_bool; simpl; auto with zarith.
 Qed.

 Lemma spec_norm_pos_pos : forall x y, norm_pos x = Neg y ->
  0 < N.to_Z y.
 Proof.
  intros [x|x] y; simpl; try easy.
  rewrite N.spec_eq_bool, N.spec_0.
  assert (H := Zeq_bool_if (N.to_Z x) 0).
  destruct Zeq_bool; simpl; try easy.
  inversion 1; subst. generalize (N.spec_pos y); auto with zarith.
 Qed.

 Ltac destr_norm_pos x :=
  rewrite <- (spec_norm_pos x);
  let H := fresh in
  let x' := fresh x in
  assert (H := spec_norm_pos_pos x);
  destruct (norm_pos x) as [x'|x'];
   specialize (H x' (eq_refl _)) || clear H.

 Lemma spec_testbit: forall x p, testbit x p = Ztestbit (to_Z x) (to_Z p).
 Proof.
  intros x p. unfold testbit.
  destr_norm_pos p; simpl. destr_norm_pos x; simpl.
  apply N.spec_testbit.
  rewrite N.spec_testbit, N.spec_pred, Zmax_r by auto with zarith.
  symmetry. apply Z.bits_opp. apply N.spec_pos.
  symmetry. apply Ztestbit_neg_r; auto with zarith.
 Qed.

 Lemma spec_shiftl: forall x p, to_Z (shiftl x p) = Zshiftl (to_Z x) (to_Z p).
 Proof.
  intros x p. unfold shiftl.
  destr_norm_pos x; destruct p as [p|p]; simpl;
   assert (Hp := N.spec_pos p).
  apply N.spec_shiftl.
  rewrite Z.shiftl_opp_r. apply N.spec_shiftr.
  rewrite !N.spec_shiftl.
  rewrite !Z.shiftl_mul_pow2 by apply N.spec_pos.
  apply Zopp_mult_distr_l.
  rewrite Z.shiftl_opp_r, N.spec_succ, N.spec_shiftr, N.spec_pred, Zmax_r
   by auto with zarith.
  now rewrite Zlnot_alt1, Z.lnot_shiftr, Zlnot_alt2.
 Qed.

 Lemma spec_shiftr: forall x p, to_Z (shiftr x p) = Zshiftr (to_Z x) (to_Z p).
 Proof.
  intros. unfold shiftr. rewrite spec_shiftl, spec_opp.
  apply Z.shiftl_opp_r.
 Qed.

 Lemma spec_land: forall x y, to_Z (land x y) = Zand (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold land.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor,
    ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith.
  now rewrite Z.ldiff_land, Zlnot_alt2.
  now rewrite Z.ldiff_land, Z.land_comm, Zlnot_alt2.
  now rewrite Z.lnot_lor, !Zlnot_alt2.
 Qed.

 Lemma spec_lor: forall x y, to_Z (lor x y) = Zor (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold lor.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor,
    ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith.
  now rewrite Z.lnot_ldiff, Z.lor_comm, Zlnot_alt2.
  now rewrite Z.lnot_ldiff, Zlnot_alt2.
  now rewrite Z.lnot_land, !Zlnot_alt2.
 Qed.

 Lemma spec_ldiff: forall x y, to_Z (ldiff x y) = Zdiff (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold ldiff.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor,
    ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith.
  now rewrite Z.ldiff_land, Zlnot_alt3.
  now rewrite Z.lnot_lor, Z.ldiff_land, <- Zlnot_alt2.
  now rewrite 2 Z.ldiff_land, Zlnot_alt2, Z.land_comm, Zlnot_alt3.
 Qed.

 Lemma spec_lxor: forall x y, to_Z (lxor x y) = Zxor (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold lxor.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?N.spec_succ, ?N.spec_lxor, ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1;
   auto with zarith.
  now rewrite !Z.lnot_lxor_r, Zlnot_alt2.
  now rewrite !Z.lnot_lxor_l, Zlnot_alt2.
  now rewrite <- Z.lxor_lnot_lnot, !Zlnot_alt2.
 Qed.

 Lemma spec_div2: forall x, to_Z (div2 x) = Zdiv2 (to_Z x).
 Proof.
  intros x. unfold div2. now rewrite spec_shiftr, Zdiv2_spec, spec_1.
 Qed.

End Make.


Require Import Coq.Lists.List Coq.Lists.SetoidList Fiat.Common.
Require Import Coq.Arith.Arith.

Unset Implicit Arguments.

Section FlattenList.
  Definition flatten {A} seq := List.fold_right (@app A) [] seq.

  Lemma flat_map_flatten :
    forall {A B: Type},
    forall comp seq,
      @flat_map A B comp seq = flatten (map comp seq).
  Proof.
    intros; induction seq; simpl; try rewrite IHseq; reflexivity.
  Qed.

  Lemma in_flatten_iff :
    forall {A} x seqs,
      @List.In A x (flatten seqs) <->
      exists seq, List.In x seq /\ List.In seq seqs.
  Proof.
    intros; unfold flatten.
    induction seqs; simpl.

    firstorder.
    rewrite in_app_iff.
    rewrite IHseqs.

    split.
    intros [ in_head | [seq (in_seqs & in_seq) ] ]; eauto.
    intros [ seq ( in_seq & [ eq_head | in_seqs ] ) ]; subst; eauto.
  Qed.

  Lemma flatten_filter :
    forall {A} (seq: list (list A)) pred,
      List.filter pred (flatten seq) =
      flatten (List.map (List.filter pred) seq).
  Proof.
    intros; induction seq; trivial.
    unfold flatten; simpl.
    induction a; trivial.
    simpl;
      destruct (pred a); simpl; rewrite IHa; trivial.
  Qed.

  Lemma map_flatten :
    forall {B C} (f: B -> C) (xs: list (list B)),
      map f (flatten xs) = flatten (map (fun x => map f x) xs).
  Proof.
    induction xs; simpl;
    [ | rewrite map_app, IHxs ]; reflexivity.
  Qed.

  Lemma map_flat_map :
    forall {A B C} (f: B -> C) (g: A -> list B) (xs: list A),
      map f (flat_map g xs) = flat_map (fun x : A => map f (g x)) xs.
  Proof.
    intros;
    rewrite flat_map_flatten, map_flatten, map_map, <- flat_map_flatten;
    reflexivity.
  Qed.

  Lemma flatten_nils :
    forall {A} (seq: list (list A)),
      flatten (List.map (fun _ => []) seq) = @nil A.
  Proof.
    induction seq; intuition.
  Qed.

  Lemma flatten_app :
    forall {A} (seq1 seq2: list (list A)),
      flatten (seq1 ++ seq2) = flatten seq1 ++ flatten seq2.
  Proof.
    unfold flatten; induction seq1; simpl; trivial.
    intros; rewrite IHseq1; rewrite app_assoc; trivial.
  Qed.

  Lemma flatten_head :
    forall {A} head tail,
      @flatten A (head :: tail) = head ++ flatten tail.
  Proof.
    intuition.
  Qed.

  Lemma length_flatten_aux :
    forall {A} seq,
    forall n,
      n + List.length (flatten seq) = List.fold_right (compose plus (@List.length A)) n seq.
  Proof.
    induction seq; simpl; intros.

    - auto with arith.
    - unfold compose;
      rewrite app_length, <- IHseq.
      rewrite plus_comm, <- plus_assoc; auto with arith.
  Qed.

  Lemma length_flatten :
    forall {A} seq,
      List.length (flatten seq) = List.fold_right (compose plus (@List.length A)) 0 seq.
  Proof.
    intros.
    pose proof (length_flatten_aux seq 0) as H; simpl in H; eauto.
  Qed.

  Lemma filter_flat_map :
    forall {A B} g (f: B -> bool) xs,
      filter f (flat_map g xs) =
      flat_map (fun x : A => filter f (g x)) xs.
  Proof.
    intros; rewrite !flat_map_flatten.
    rewrite flatten_filter, map_map; reflexivity.
  Qed.

End FlattenList.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


Require Import ssreflect ssrfun ssrbool eqtype choice seq.
Require Import generic_quotient.
Require Import program instr.

Local Open Scope quotient_scope.

(**

 * Equality of [program]s is defined by [progEq], which captures the
 * monoidal sequencing of operations (unit: [prog_skip], composition:
 * [prog_seq]) (and scope extrusion, not treated here).
 *
 * This module quotients away these identities by reflecting [program]
 * onto the [program -> program] function space: identity is thus
 * (function) identity and composition is then (function) composition.
 *
 * Through lemma [program_equal], we can reduce the problem of
 * deciding whether two programs [p1] and [p2] are equivalent by
 * comparing there normal forms.
 *
 *)

(* TODO: retrofit into http://perso.crans.org/cohen/work/quotients/? *)

Fixpoint quote (p: program): program -> program :=
  match p with
  | prog_instr c => fun p => prog_instr c ;; p
  | prog_skip => fun p => p
  | prog_seq p1 p2 =>
    fun p => quote p1 (quote p2 p)
  | prog_declabel body =>
    fun p => prog_declabel body ;; p
  | prog_label l =>
    fun p => prog_label l ;; p
  | prog_data T R W RT v =>
    fun p => prog_data RT v ;; p
  end.

Definition reify (q: program -> program): program :=
  q prog_skip.

Definition norm (p: program): program := reify (quote p).

Lemma quote_hom (p: program)(xs : program) : progEq (quote p xs) (p ;; xs).
Proof.
  elim: p xs.
  * (* CASE: p ~ prog_instr c *)
    by move=> c xs;
       apply progEqRefl.
  * (* CASE: p ~ prog_skip *)
    by move=> xs;
       apply progEqSym ;
       apply progEqSkipSeq.
  * (* CASE: p ~ prog_seq p1 p2 *)
    move=> p1 IH1 p2 IH2 xs /=.
    apply progEqTrans with (p2 := (p1;; p2;; xs));
      last by apply progEqSeqAssoc.
    apply progEqTrans with (p2 := p1 ;; quote p2 xs).
    - by apply IH1 with (xs := quote p2 xs).
    - apply progEqSeq; first by apply progEqRefl.
      by apply IH2 with (xs := xs).
  * (* CASE: p ~ prog_declabel body *)
    by move=> body IH1 xs /=;
       apply progEqRefl.
  * (* CASE: p ~ prog_label l *)
    by move=> l xs /=;
       apply progEqRefl.
  * (* CASE: p ~ prog_data RT v *)
    by move=> T R W RT v xs /=;
       apply progEqRefl.
Qed.

Lemma soundness (p: program): progEq (norm p) p.
Proof.
  apply progEqTrans with (p2 := p ;; prog_skip);
    last by apply progEqSeqSkip.
  apply: quote_hom.
Qed.

Lemma program_equal (p1 p2: program):
  progEq (norm p1) (norm p2) -> progEq p1 p2.
Proof.
  move=> H.
  apply progEqTrans with (p2 := norm p1);
    first by apply progEqSym;
             apply soundness.
  apply progEqTrans with (p2 := norm p2);
    first by exact: H.
  apply soundness.
Qed.


(** ** Definition of Tarski Semantics *)

From FOL Require Import GenTarski FullFOL.

(* *** Tarki Models **)

Section Tarski.
  Context {Sigma : Signature}.

  (* **** Semantic notions *)

  Section Semantics.

    Variable domain : Type.

    Context {I : interp domain }.

    Fixpoint sat (rho : env domain) (phi : form) : Prop :=
      match phi with
      | Pred P v => i_P (Vector.map (eval rho) v)
      | Fal => @i_F _ _ I
      | Impl phi psi => sat rho phi -> sat rho psi
      | Conj phi psi => sat rho phi /\ sat rho psi
      | Disj phi psi => sat rho phi \/ sat rho psi
      | Ex phi => exists d : domain, sat (d .: rho) phi
      | All phi => forall d : domain, sat (d .: rho) phi
      end.

  End Semantics.

  Arguments sat  {_ _} _ _, _ _ _ _.

  Notation "rho ⊨ phi" := (sat rho phi) (at level 20).

  Fixpoint list_or (A : list form) : form :=
    match A with
    | nil => ⊥
    | phi::A => phi ∨ list_or A
    end.

  Definition constraint := forall D, interp D -> Prop.
  Definition con_subs (C C' : constraint) := (forall D (I : interp D), C' D I -> C D I).
  Definition classical D (I : interp D) :=
    forall rho phi psi, rho ⊨ (((phi --> psi) --> phi) --> phi).
  Definition exploding D (I : interp D) := forall rho phi, rho ⊨ (⊥ --> phi).
  Definition standard D (I : interp D ) := classical I /\ ((@i_F _ D I) -> False).
  Definition exp D (I : interp D) := classical I /\ exploding I.

  Definition has_model (C : constraint) (T : theory) :=
    exists D (I : interp D) rho, (forall phi, phi ∈ T -> rho ⊨ phi) /\ C D I.
  Definition valid_T (C : constraint) (T : theory) (phi : form) :=
    forall D (I : interp D), C D I -> forall rho, (forall psi, psi ∈ T -> rho ⊨ psi) -> rho ⊨ phi.
  Definition valid_L (C : constraint) A phi :=
    forall D (I : interp D), C D I -> forall rho, (forall psi, psi el A -> rho ⊨ psi) -> rho ⊨ phi.

  Notation "T '⊫<' C '>' phi" := (valid_T C T phi) (at level 50).

  Lemma list_or_spec A D (I : interp D) rho :
    standard I -> (rho ⊨ list_or A <-> exists phi, phi el A /\ rho ⊨ phi).
  Proof.
    intros [_ Hstand]. induction A; cbn; split; auto.
    - firstorder.
    - firstorder.
    - intros [H|H].
      + exists a. tauto.
      + apply IHA in H as [phi[H1 H2]]. exists phi. tauto.
    - intros [phi [[->|H1] H]]; auto.
      right. apply IHA. now exists phi.
  Qed.

  (*Lemma sat_and_iff D (I : interp D) rho phi psi :
    classical I -> sat rho phi /\ sat rho psi <-> sat rho (phi ∧ psi).
  Proof.
    cbn. repeat split. intuition. specialize (H rho phi ⊥). cbn in H. tauto. intuition. tauto. firstorder.
  Qed.*)

  (* **** Model relationships **)

  Lemma valid_T_subsumption (C C' : constraint) T phi :
    con_subs C C' -> valid_T C T phi -> valid_T C' T phi.
  Proof.
    firstorder.
  Qed.

  (* **** Substitution properties **)

  Section Substs.
    Variable D : Type.
    Variable I : interp D.

    Hint Unfold funcomp.

    Lemma eval_ext rho xi t :
      (forall x, rho x = xi x) -> eval rho t = eval xi t.
    Proof.
      intros H; induction t using strong_term_ind; comp; try congruence.
      f_equal. now apply vec_map_ext.
    Qed.

    Lemma eval_comp rho xi t :
      eval rho (subst_term xi t) = eval (xi >> eval rho) t.
    Proof.
      induction t using strong_term_ind; comp; try congruence.
      f_equal. erewrite vec_comp. 2: reflexivity. now apply vec_map_ext.
    Qed.

    Lemma sat_ext rho xi phi :
      (forall x, rho x = xi x) -> rho ⊨ phi <-> xi ⊨ phi.
    Proof.
      induction phi in rho, xi |-*; intros Hext; comp.
      - tauto.
      - now rewrite (vec_ext (fun x => eval_ext x Hext)).
      - now erewrite IHphi1, IHphi2.
      - now erewrite IHphi1, IHphi2.
      - now erewrite IHphi1, IHphi2.
      - split; intros H' d; eapply (IHphi (d .: rho) (d .: xi) _), H'.
        Unshelve. all: (intros []; cbn; congruence).
      - split; intros [d H']; exists d; eapply (IHphi (d .: rho) (d .: xi) _), H'.
        Unshelve. all: (intros []; cbn; congruence).
    Qed.

    Lemma sat_comp rho xi phi :
      rho ⊨ (subst_form xi phi) <-> (xi >> eval rho) ⊨ phi.
    Proof.
      induction phi in rho, xi |-*; comp.
      - tauto.
      - erewrite vec_comp. 2: reflexivity. now rewrite (vec_ext (fun x => eval_comp rho xi x)).
      - now rewrite IHphi1, IHphi2.
      - now rewrite IHphi1, IHphi2.
      - now rewrite IHphi1, IHphi2.
      - setoid_rewrite IHphi. split; intros H d; eapply sat_ext. 2, 4: apply (H d).
        all: intros []; comp; rewrite? eval_comp; now comp.
      - setoid_rewrite IHphi. split; intros [d H]; exists d; eapply sat_ext. 2, 4: apply H.
        all: intros []; comp; rewrite? eval_comp; now comp.
    Qed.

    Lemma sat_subst rho rho' sigma phi :
      (forall x, eval rho (sigma x) = rho' x) -> rho' ⊨ phi <-> rho ⊨ (subst_form sigma phi).
    Proof.
      intros Hsigma. rewrite sat_comp. apply sat_ext. now comp.
    Qed.
  End Substs.

End Tarski.

Arguments sat  {_ _ _} _ _, _ _ _ _ _.
Notation "rho ⊨ phi" := (sat rho phi) (at level 20).

Arguments valid_T {_} _ _ _.
Notation "T '⊫<' C '>' phi" := (valid_T C T phi) (at level 50).


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Module SfLibmod.

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem false_beq_nat: forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Implicit Arguments multi [[X]].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  (* FILL IN HERE *) Admitted.

(**  Identifiers and polymorphic partial maps. *)

Inductive id : Type :=
  Id : nat -> id.

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  (* FILL IN HERE *) Admitted.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Notation "'\empty'" := empty.

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id; auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (eq_id_dec x2 x1)...
Qed.

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

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.

(*Sepehr: additional*)

Inductive fid : Type :=
  FId : nat -> fid.

Theorem eq_fid_dec : forall fid1 fid2 : fid, {fid1 = fid2} + {fid1 <> fid2}.
Proof.
   intros fid1 fid2.
   destruct fid1 as [n1]. destruct fid2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_fid : forall (T:Type) x (p q:T),
              (if eq_fid_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_fid_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_fid : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  (* FILL IN HERE *) Admitted.

(*Owners: a set of owners*)
Inductive ow: Type :=
  OId : nat -> ow.

(* being a memebr of list defined as a proposition *)
Inductive inlist {A: Type} : A -> list A -> Prop :=
  | in_head: forall (x: A) (xs: list A),
             inlist x (x::xs)
  | in_tail: forall (x: A) (y: A) (xs: list A),
             inlist x xs ->
             inlist x (y::xs).

Definition sublist {A: Type} (l1: list A) (l2: list A) : Prop :=
  forall (x: A), inlist x l1 -> inlist x l2.

Lemma sublist_identity:
  forall {A: Type} (l: list A),
  sublist l l.

Proof.
  intros.
  unfold sublist.
  intros.
  assumption.
  Qed.

Lemma sublist_cons:
  forall {A: Type} (x: A) (l1 l2: list A),
  sublist l1 l2 ->
  sublist (x::l1) (x::l2).

Proof.
  intros.
  unfold sublist.
  intros.
  remember (x::l1) as L.
  generalize dependent l1.
  generalize dependent l2.
  generalize dependent x.
  destruct H0.
  intros.
  inversion HeqL.
  subst.
  apply in_head.
  intros.
  inversion HeqL.
  subst.
  apply in_tail.
  apply H.
  assumption.
  Qed.

Lemma sublist_cons2:
  forall {A: Type} (x: A) (l: list A),
  sublist l (x::l).

Proof.
  intros.
  unfold sublist.
  intros.
  inversion H.
  apply in_tail.
  apply in_head.
  apply in_tail.
  apply in_tail.
  assumption.
  Qed.

Lemma sublist_transitive:
  forall {A:Type} (l1 l2 l3: list A),
  sublist l1 l2 ->
  sublist l2 l3 ->
  sublist l1 l3.

Proof.
  Admitted.

Lemma cons_not_eq_list:
  forall {A: Type} (x: A) (l: list A),
  ~ (l = x::l).

Proof.
  Admitted.

Definition inlist_subtract {A: Type} (x: A) (l1: list A) (l2: list A) :=
  inlist x l1 /\ ~(inlist x l2).

Lemma sublist_subtract:
  forall {A: Type} (x: A) (l0 l1 l2: list A),
  sublist l0 l1 ->
  sublist l1 l2 ->
  inlist_subtract x l2 l0 ->
  ~(inlist_subtract x l2 l1) ->
  inlist_subtract x l1 l0.

Proof.
  Admitted.

Lemma inlist_subtract_cons:
  forall {A: Type} (x y: A) (l: list A),
  inlist_subtract x (y::l) l ->
  x= y.

Proof. Admitted.

Definition subtract_sublist {A: Type} (l1 l2 l3: list A) :=
  forall (x: A), inlist_subtract x l1 l2 -> inlist x l3.

Lemma sublists_append:
  forall {A: Type} (l1 l2 l3 L L': list A),
  sublist l1 l2 ->
  sublist l2 l3 ->
  subtract_sublist l3 l2 L ->
  subtract_sublist l2 l1 L' ->
  subtract_sublist l3 l1 (L' ++ L).

Proof. Admitted.

Lemma inlist_subtract_head:
  forall {A: Type} (x: A) (l: list A),
  inlist_subtract x (x::l) l.

Proof. Admitted.

Lemma inlist_append:
  forall {A: Type} (x: A) (l1 l2: list A),
  inlist x (l1 ++ l2) ->
  inlist x l1 \/ inlist x l2.

Proof. Admitted.

Lemma inlist_subtract_inlist_bigger:
  forall {A: Type} (x: A) (l1 l2 l3: list A),
  sublist l1 l2 ->
  sublist l2 l3 ->
  inlist_subtract x l2 l1 ->
  inlist_subtract x l3 l1.

Proof. Admitted.

Lemma inlist_subtract_inlist_bigger2:
  forall {A: Type} (x: A) (l1 l2 l3: list A),
  sublist l1 l2 ->
  sublist l2 l3 ->
  inlist_subtract x l3 l2 ->
  inlist_subtract x l3 l1.

Proof. Admitted.

Lemma inlist_bigger:
  forall {A: Type} (x: A) (l1 l2: list A),
  inlist x l2 ->
  inlist x (l1 ++ l2).

Proof. Admitted.

Lemma not_inlist_neq:
  forall {A: Type} (x y: A) (l: list A),
  ~ inlist x (y::l) ->
  x <> y.

Proof. Admitted.

Definition list_equality {A: Type} (l1 l2: list A): Prop :=
  forall (x: A), inlist x l1 <-> inlist x l2.

Lemma inlist_subtract_sublist:
  forall {A: Type} (x: A) (l1 l2 l3: list A),
  inlist_subtract x l2 l1 ->
  sublist l2 l3 ->
  inlist x l3.

Proof. Admitted.

(* being a member of list of fid's, defined as a function *)
Fixpoint in_fid_list (g: fid) (gs: list fid) : bool :=
  match gs with
  | nil => false
  | cons h t => if eq_fid_dec g h then true else in_fid_list g t
  end.

Axiom excluded_middle:
  forall P: Prop, P \/ ~P.

Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y},
    (forall(x: X), f x = g x) -> f = g.

Lemma func_ext_inv:
  forall (X Y: Type) (f g: X -> Y),
  f = g -> forall (x: X), f x = g x.

Proof.
  intros.
  subst.
  reflexivity.
  Qed.

Fixpoint blt_nat (n m : nat) : bool :=
  match (n, m) with
  | (O, S _) => true
  | (S n', S m') => blt_nat n' m'
  | (_, _) => false
  end.

Lemma dummy:
  forall (n: nat),
  n + 1 - 1 = n.

Proof. Admitted.

End SfLibmod.


Set Implicit Arguments.

Require Import
        Finite.FinType
        Tactics.Tactics.

Import ListNotations.

Fixpoint to_subtype_list
         (A : Type)
         (xs : list A)
         (p : A -> Prop) (D : forall x, dec (p x)) : list (subtype p) :=
  match xs with
  | nil => nil
  | x :: xs' => match decision (p x) with
               | left px => (exist  _ x (purify px)) :: to_subtype_list xs' D
               | right _ => to_subtype_list xs' _
               end
  end.

Arguments to_subtype_list {A} xs p {D}.

Lemma to_subtype_list_count
      (A : discType) (p: A -> Prop) (xs : list A) (D : forall x, dec (p x)) x
  : count (to_subtype_list xs p) x = count xs (proj1_sig x).
Proof.
  induction xs as [| x' xs] ; crush.
  -
    decide (p x').
    +
      simpl. dec ; crush.
      * now rewrite <- subtype_extensionality in *.
    + destruct x.
      cbn.
      dec ; crush ;  now impurify p0.
Qed.

Lemma subtype_enum_sound (A : finType)(p : A -> Prop) (D : forall x, dec (p x)) x
  : count (to_subtype_list (elem A) p) x = 1.
Proof.
  rewrite to_subtype_list_count. apply enum_sound.
Qed.

Instance FinTypeC_subtype
         (A : finType)
         (p : A -> Prop) (D : forall x, dec (p x)) : FinTypeC (DiscSubtype p).
Proof.
  econstructor. apply subtype_enum_sound.
Defined.

Canonical Structure FinType_subtype
          (A : finType)
          (p : A -> Prop) (D : forall x, dec (p x)) := FinType (DiscSubtype p).

Arguments FinType_subtype {A} p {_}.

Lemma in_undup (A : discType) (xs : list A) x : x el xs <-> x el (undup xs).
Proof.
  now rewrite undup_id_equiv.
Qed.

Lemma enum_sound_from_list (A : discType) (xs : list A) x
  : count (undup (to_subtype_list xs (fun x => x el xs))) x = 1.
Proof.
  apply count_in_dupfree.
  -
    apply dup_free_undup.
  -
    rewrite <- in_undup.
    apply count_in_gt_zero. rewrite to_subtype_list_count.
    destruct x as [x p]. cbn. apply count_in_gt_zero. now impurify p.
Qed.

Instance FromListC (A : discType) (xs : list A)
  : FinTypeC (DiscSubtype (fun x => x el xs)).
Proof.
  econstructor. intros [x p]. apply enum_sound_from_list.
Defined.

Canonical Structure FinType_from_list (A : discType) (xs : list A)
  := FinType (DiscSubtype (fun x => x el xs)).

Lemma finType_from_list_correct (A : discType) (xs : list A)
  : map (@proj1_sig _ _) (elem (FinType_from_list xs)) === xs.
Proof.
  cbn. split.
  -
    intros x H.
    destruct (In_map_iff (undup (to_subtype_list xs (fun x => x el xs)))
                         (@proj1_sig _ _)
                         x) as [Hl Hr].
    crush. destruct x0.
    now impurify p.
  -
    intros x H.
    specialize (In_map_iff (undup (to_subtype_list xs (fun x => x el xs)))
                         (@proj1_sig _ _)
                         x) ; intros Hiff.
    destruct Hiff as [Hl Hr].
    apply Hr.
    eexists. Unshelve.
    2:{
      exists x. unfold pure. now dec.
    }
    + cbn. split; auto.
      apply count_in_gt_zero with (xs0 := undup (to_subtype_list xs _)).
      rewrite enum_sound_from_list. omega.
Qed.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Hopcroft and Karp algorithm for checking the equivalence of two DFAs. *)

Require Import Common.
Require Import Classes.
Require Import Graph.
Require Import Monoid.
Require Import SemiLattice.
Require Import SemiRing.
Require Import KleeneAlgebra.
Require Import MxGraph.
Require Import MxSemiLattice.
Require Import MxSemiRing.
Require Import MxKleeneAlgebra.

Require Import DKA_Definitions.
Require Import DKA_StateSetSets.
Require        DKA_DFA_Language.

Require Import Utils_WF.
Require Import Relations.
Require Import List.

Import DSUtils.Notations.

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

Section e.
  Import Numbers.Positive.

  Variable A : DFA.t.
  Let f := DFA.finaux A.
  Let d := DFA.delta A.

  (* TOTHINK: m := peanoView (DFA.max_label A) ? *)
  Let m := DFA.max_label A.
  Let final s := StateSet.mem s f.

  Fixpoint loop n (w: list label) tarjan (x y: state) : DS.UF + bool * list num :=
    match n with
      | Datatypes.S n =>
        let '(b,tarjan) := DS.test_and_unify tarjan x y in
        if b then inl tarjan else
        let fx := final x in
        let fy := final y in
        if eq_bool_bool fx fy
        then fold_num_sum (fun a tarjan => loop n (a::w) tarjan (d a x) (d a y)) m tarjan
        else inr (fx, rev w)
      (* this last case is never reached *)
      | O => inl tarjan
    end.

End e.

Import DFA.

Definition equiv A x y :=
  match loop A (Datatypes.S (size A)) nil DS.empty x y with
    | inl _ => None
    | inr e => Some e
  end.

Lemma bounded_change_initial: forall A i, bounded A -> belong i A -> bounded (change_initial A i).
Proof.
  intros A i HA Hi. constructor; trivial; apply HA.
Qed.

Section comb.

  Local Hint Resolve DS.union_WF DS.empty_WF: typeclass_instances.

  Inductive combine_no_length X Y : list X -> list Y -> Type :=
  |cnl_nil : combine_no_length nil nil
  |cnl_cons : forall lx ly x y, combine_no_length lx ly -> combine_no_length (x::lx) (y::ly).

  Program Definition build_combine X Y : forall lx ly (H : List.length lx = List.length ly),
                                           @combine_no_length X Y lx ly.
  Proof.
    induction lx.
    intros [|y ly] Hl; (constructor || discriminate).
    intros[|y ly] Hl ; (constructor || discriminate).
    apply IHlx. simpl in Hl. injection Hl.
    tauto.
  Qed.

  Fixpoint complete (tarjan : DS.T) (l : list (state * state)) : DS.T :=
    match l with
      | nil => tarjan
      | (x,y)::l => complete (DS.union tarjan x y) l
    end.
  Notation "t +++ l" := (complete t l) (at level 60).

  Fixpoint comb_aux l r acc : list (state * state):= match l,r with |x::l,y::r => comb_aux l r ((x,y)::acc) | _,_ => acc end.
  Definition comb l r := comb_aux l r nil.

  Lemma add_incr : forall {tar} `{DS.WF tar} l, tar <T= (tar +++ l).
  Proof.
    intros tar Hwf l; revert tar Hwf.
    induction l as [ | [x y] l IH].  intros; reflexivity. intros; simpl.
    transitivity (DS.union tar x y).  apply DSUtils.le_union.  apply IH. ti_auto.
  Qed.

  Lemma le_proxy : forall t t' x y,  {{t}} x y -> t <T= t' -> {{t'}} x y.
  Proof. intuition. Qed.

  Lemma complete_incr : forall {tar} `{DS.WF tar} l x y, {{tar}} x y -> {{tar +++ l}} x y.
  Proof.
    intros; eauto using le_proxy, add_incr.
  Qed.

  Lemma complete_incr_left : forall {tar} `{DS.WF tar} {tar'} `{DS.WF tar'} l,
    tar <T= tar' ->
    tar +++l <T= tar' +++ l.
  Proof.
    intros tar Hwf tar' Hwf' l; revert tar Hwf tar' Hwf'.
    induction l as [|[x y] l  IHl]; intros tar Hwf tar' Hwf' Hle; [ apply Hle|].
    simpl. apply IHl; ti_auto. apply DSUtils.le_incr, Hle.
  Qed.

  Lemma complete_compat_left : forall {tar} `{DS.WF tar} {tar'} `{DS.WF tar'} l,
    tar [=T=] tar' ->
    tar +++l [=T=] tar' +++ l.
  Proof.
    intros ? ? ? ? ? H. split; apply complete_incr_left; apply H.
  Qed.

  Instance complete_WF : forall {tar} `{DS.WF tar} l, DS.WF (tar +++ l).
  Proof.
    intros tar Hwf l; revert tar Hwf.
    induction l; simpl; intuition.
  Qed.

End comb.
Notation "t +++ l" := (complete t l) (at level 60).

Section correctness.

  Variable A: DFA.t.
  Hypothesis Hbounds: bounded A.

  Notation delta := (delta A).
  Notation size := (size A).
  Notation ml := (max_label A).
  Notation final x := (StateSet.mem x (finaux A)).
  Notation kt := (list label -> DS.UF -> state -> state -> DS.UF + bool*list label)%type.
  Notation measure := (measure size).

  Definition diag (R S : relation state) :=
    forall a x y, below x size -> below y size -> a < ml ->
      R x y -> S (delta a x) (delta a y).

  Definition prog (t t' : DS.T) := forall R, diag {{t}} {{t +++ R}} -> diag {{t'}} {{t' +++ R}}.

  Local Hint Resolve DS.union_WF DS.empty_WF: typeclass_instances.
  Existing Instance complete_WF.

  Instance preorder_prog : PreOrder prog.
  Proof.
    unfold prog.
    constructor. intros tar l. tauto.
    intros x y z Hxy Hyz.
    intuition.
  Qed.

  Instance diag_compat: Proper (same_relation _ ==> same_relation _ ==> iff) diag.
  Proof.
    intros R R' HR T T' HT. unfold diag. split; intros H a x y Hx Hy Ha Hxy;
     apply HT, H; auto; apply HR; assumption.
  Qed.

  Class invariant tarjan : Prop :=
    {
      i_wf_tarjan :> DS.WF tarjan ;
      i_final : forall x y, {{tarjan}} x y -> final x = final y
    }.

  Record correct_ind tarjan tarjan' (x y : state) : Prop :=
    {
      ci_prog : prog tarjan tarjan';
      ci_le : tarjan <T= tarjan';
      ci_measure : measure tarjan' <= measure tarjan;
      ci_sameclass : {{tarjan'}} x y
    }.

  Fixpoint add_lists x y a l :=
    match a with O => l | Datatypes.S a => (delta a x, delta a y)::add_lists x y a l end.

  Record correct_fold_ind tarjan tarjan' x y ml :=
    {
      cfi_prog : forall l, diag {{tarjan}} {{tarjan +++ add_lists x y ml l}} -> diag {{tarjan'}} {{tarjan' +++ l}};
      cfi_le : tarjan <T= tarjan';
      cfi_measure : measure tarjan' <= measure tarjan
    }.

  Lemma diag_compat_left : forall {tar} `{DS.WF tar} {tar'} `{DS.WF tar'},
    tar [=T=] tar' ->
    forall l,
      diag {{tar}} {{tar +++ l}} ->
      diag {{tar' }} {{tar'+++l}}.
  Proof.
    intros tar Hwf tar' Hwf' Heq l H a x y Hx Hy Ha Htar.
    rewrite <- Heq in Htar.
    specialize (H a x y Hx Hy Ha Htar).
    refine (complete_incr_left _ H). apply Heq.
  Qed.

  Lemma correct_ind_idem : forall x y tarjan,
     {{tarjan}} x y ->
     invariant tarjan ->
     correct_ind tarjan ( DS.union tarjan x y ) x y.
  Proof.
    intros x y tarjan Hxy Hstat.
    constructor.

     assert (heq : tarjan [=T=] DS.union tarjan x y).
       apply DSUtils.eq_union, Hxy.
     unfold prog. intros. exact (diag_compat_left heq H).

     apply DSUtils.le_union.
     rewrite measure_union_idem; trivial.
     rewrite DS.sameclass_union. auto.
  Qed.

  Lemma invariant_idem : forall tarjan x y,
    invariant tarjan ->
    {{tarjan}} x y ->
    invariant (DS.union tarjan x y).
  Proof.
    intros tarjan x y H Hxy.
    assert (Hprog : forall np nq, {{DS.union tarjan x y}} np nq -> {{tarjan}} np nq).
      intros np nq H'.
      rewrite DS.sameclass_union in H'. intuition; symmetry.
      rewrite H0, Hxy. assumption.
      rewrite H2, <- Hxy. assumption.

    constructor.
     ti_auto.
     intros np nq H'. apply Hprog in H'. apply H; auto.
  Qed.

  Lemma tarjan_equiv_true : forall {tarjan} `{DS.WF tarjan} x y u,
    DS.equiv tarjan x y = (true, u) -> {{tarjan}} x y.
  Proof.
    intros T Hwf x y u H .
    rewrite <- DS.sameclass_equiv.
    rewrite H; reflexivity.
  Qed.
  Hint Resolve tarjan_equiv_true : core.

  Lemma invariant_prog : forall tarjan x y,
    invariant tarjan ->
    final x = final y ->
    invariant (DS.union tarjan x y).
  Proof.
    intros tarjan x y H Hxy.
    constructor. ti_auto.
    intros np nq H'.
    rewrite DS.sameclass_union in H'.
    assert (wlog : forall P Q : relation state,
      (forall x y, Q x y <-> Q y x) -> (forall x y, P x y -> Q x y) -> forall u v, (P u v \/ P v u) -> Q u v).
    clear.
    intros.
    destruct H1.
    apply H0. auto.
    rewrite H. apply H0. auto.

    destruct H' as [H' | H'].
    apply H. auto.
    revert H'.
    generalize np nq.  clear np nq. apply wlog.
    intros. intuition.
    intros. destruct H0. apply H in H0. apply H in H1. eauto.
  Qed.

  Lemma in_union: forall {tar} `{DS.WF tar} x y, {{DS.union tar x y}} x y.
  Proof.
    intros. rewrite DS.sameclass_union.
    right. left. split; reflexivity.
  Qed.

  Lemma add_lists_S: forall {tar} `{DS.WF tar} x y a l,
    {{tar}} (delta a x) (delta a y) -> tar+++add_lists x y (Datatypes.S a) l [=T=] tar+++add_lists x y a l.
  Proof.
    intros tarjan Hwf x y a l H.
    simpl complete at 1.
    apply complete_compat_left.
    split; intros u v Huv.
    rewrite DS.sameclass_union in Huv.
    num_simpl.
    destruct Huv as [Huv | [[Hu Hv]|[Hu Hv]]]; auto.
    rewrite Hu, Hv; assumption.
    rewrite Hu, Hv; symmetry; assumption.
    apply DSUtils.le_union, Huv.
  Qed.

  Lemma add_lists_sameclass: forall {tar} `{DS.WF tar} ml a x y l, a < ml ->
    {{tar +++ add_lists x y ml l}} (delta a x) (delta a y).
  Proof.
    intros tar Hwf ml; revert tar Hwf.
    induction ml; intros.
     lia_false.
     simpl.
      destruct (eq_nat_dec a ml). subst. apply complete_incr. apply in_union.
      apply IHml; ti_auto. lia.
  Qed.

  Lemma diag_ok : forall {tarjan} `{DS.WF tarjan} x y l,
      below x size ->
      below y size ->
      diag {{tarjan}} {{tarjan +++ l}} ->
      diag  {{DS.union tarjan x y}} {{DS.union tarjan x y +++ add_lists x y ml l}}.
  Proof.
    intros tar Hwf x y l Hx Hy Hl.
    intros a v w Hv Hw Ha H.
    rewrite DS.sameclass_union in H.
    assert (Hle : tar+++l <T= DS.union tar x y +++ add_lists x y ml l).
     clear - Hwf. induction ml using num_peano_rec; simpl.
     apply complete_incr_left. auto using DSUtils.le_union.
      num_simpl. simpl.
      rewrite IHn. apply complete_incr_left. apply DSUtils.le_union.

       destruct H as [H | [[Hv' Hw' ] | [Hw' Hv']]].
       eapply (Hl a) in H; auto.

       eapply (Hl a) in Hv'; auto.
       eapply (Hl a) in Hw'; auto.
         apply Hle in Hv'.
         apply Hle in Hw'.
         rewrite Hv', Hw'.
         apply add_lists_sameclass, Ha.

       eapply (Hl a) in Hv'; auto.
       eapply (Hl a) in Hw'; auto.
         apply Hle in Hv'.
         apply Hle in Hw'.
         rewrite Hv', Hw'.
         symmetry.
         apply add_lists_sameclass, Ha.
  Qed.

  Import Numbers.Positive.
  Lemma loop_correct : forall n w t t' x y,
    measure t < n ->
    invariant t -> below x size -> below y size -> loop A n w t x y = inl t' ->
    correct_ind t t' x y /\ invariant t'.
  Proof.
    induction n. intros. lia_false.
    intros w tarjan tar' x y Hsize Hstat Hx Hy. simpl loop.
    rewrite DS.test_and_unify_eq.
    case_eq (DS.equiv tarjan x y). intros [|] u Hn; simpl.

    (** first case, nothing is done*)
    intro H'; injection H'; intros; subst; clear H'.
    split. apply correct_ind_idem; trivial. rewrite <- DS.sameclass_equiv, Hn. reflexivity.
    apply invariant_idem; trivial. rewrite <- DS.sameclass_equiv, Hn. reflexivity.

    (** second case, we make a fold_labels*)
    bool_analyse. 2: discriminate.
    assert (IH: forall tar,
      fold_num_sum (fun a tar => loop A n (a :: w) tar (delta a x) (delta a y)) ml tar = inl tar' ->
      {{tar}} x y ->
      measure tar < n ->
      invariant tar -> correct_fold_ind tar tar' x y ml /\ invariant tar').
    clear u Hn tarjan Hstat Hsize.
    induction ml as [|a IHa] using num_peano_rec; [setoid_rewrite fold_num_sum_O|setoid_rewrite fold_num_sum_S];
      simpl; intros tar Htar Hxy Hsize Htar'.
     dependent destruction Htar. split; auto. constructor; auto. reflexivity.
     revert Htar. num_simpl. simpl. num_simpl.
     case_eq (loop A n (a :: w) tar (delta a x) (delta a y)); intros tar'' Htar'' Htar. 2: discriminate.
     apply IHn in Htar''; auto using bounded_delta. destruct Htar'' as [Htar'' Htar''i]. clear IHn.
     apply IHa in Htar; auto. clear IHa.
      split.
       constructor.
        intros l Hl. apply Htar. rewrite <- add_lists_S. apply Htar''. assumption.
        apply (ci_sameclass Htar'').
        transitivity tar''. apply Htar''. apply Htar.
        apply le_trans with (measure tar''). apply Htar. apply Htar''.
       apply Htar.
      apply Htar'', Hxy.
      eapply le_lt_trans. apply Htar''. apply Hsize.

    clear IHn. intro Hr.
    destruct (IH _ Hr) as [IH1 IH2]; clear Hr IH.
     apply in_union.
     apply (measure_union_strict (size:=size)) in Hn; auto; num_lia.
     apply invariant_prog; assumption.
    split; auto. constructor.
     intros l Hl. simpl; simpl in Hl.
     apply IH1. apply diag_ok; ti_auto.

     transitivity (DS.union tarjan x y). apply DSUtils.le_union. apply IH1.
     apply le_trans with (measure (DS.union tarjan x y)).
     apply IH1. apply (measure_union_strict (size:=size)) in Hn; auto using lt_le_weak; num_lia.
     apply IH1. apply in_union.
  Qed.

  Section Correction.

    Variables i' j' : state.
    Hypothesis Hi' : below i' size.
    Hypothesis Hj' : below j' size.
    Variable tarjan : DS.T.
    Hypothesis _H : (loop A (Datatypes.S size) nil DS.empty i' j') = inl tarjan.

    Lemma invariant_empty : invariant DS.empty.
    Proof.
      constructor. ti_auto. intros x y Hxy.
      apply DS.sameclass_empty in Hxy; subst. reflexivity.
    Qed.

    Lemma tarjan_correct : correct_ind DS.empty tarjan i' j' /\ invariant tarjan.
    Proof.
      apply loop_correct in _H; auto.
      rewrite measure_empty. auto with arith.
      apply invariant_empty.
    Qed.

    Instance tarjan_wf : DS.WF tarjan.
    Proof. apply tarjan_correct. Qed.

    Definition equivalent x y := (fst (DS.equiv tarjan x y)).

    Notation "A =&&= B" := (eq_state_bool A B) (at level 75).
    Notation "A =T= B" := (equivalent A B) (at level 75).

    Ltac xif_simpl :=
      repeat match goal with
               | |- context [xif true ?x ?y] => change (xif true x y) with x
               | |- context [xif false ?x ?y] => change (xif false x y) with y
             end.

    Ltac xif_destruct :=
      match goal with
        | |- context [xif ?b ?x ?y] => case_eq b; intros; xif_simpl
      end.

    Lemma T_true : forall a b, (a =T= b) = true <-> {{tarjan}} a b.
    Proof. intros. rewrite <- DS.sameclass_equiv. reflexivity. Qed.

    Lemma T_finaux : forall x y, (x =T= y) = true -> StateSet.mem x (finaux A) = StateSet.mem y (finaux A).
    Proof.
      intros.
      rewrite T_true in H.
      destruct tarjan_correct as [_ H']. apply i_final, H.
    Qed.

    Lemma T_refl : forall x, (x =T= x) = true.
    Proof.
      intros.
      rewrite T_true.
      reflexivity.
    Qed.
    Hint Rewrite T_refl : bool_simpl.

    Lemma zero_leq : forall x, 0 <= x. Proof. trivial with arith. Qed.
    Lemma leq_zero_plus : forall a b, a < b -> a < 0 + b. Proof. auto with arith. Qed.
    Hint Resolve zero_leq leq_zero_plus: size.

    Ltac leq_sum n := apply leq_sum; exists n; split ; [ auto with size | split; [ auto with size |]].

    Lemma diag_empty :  diag {{DS.empty}} {{DS.empty +++ nil}}.
    Proof.
      intros l ? ? ? ? ? Hxy. apply DS.sameclass_empty in Hxy. subst. reflexivity.
    Qed.

    Lemma simulation: forall i j, (i =T= j) = true -> belong i A -> belong j A ->
      forall a, a < max_label A -> (delta a i =T= delta a j) = true.
    Proof.
      intros. rewrite T_true in *.
      destruct tarjan_correct as [[H' _ _ _] _].
      eapply (H' nil diag_empty); trivial.
    Qed.

    Lemma eval_change_initial : eval (change_initial A i') == eval (change_initial A j').
    Proof.
      apply mx_to_scal_compat.

      pose (y := box _ _
        (fun np rp => xif (state_of_nat np =T= state_of_nat rp) 1 0): KMX (nat_of_num size) (nat_of_num size)).
      pose (m := MAUT.delta (to_MAUT (change_initial A j'))).
      pose (v :=  MAUT.final (to_MAUT (change_initial A j'))).
      apply (equiv_filter (y := y) (m := m) (v := v)).

      (* ia * y == ib * y *)
      simpl MAUT.initial. fold_regex.
      setoid_rewrite (mx_point_one_left (n:=1) (m:=size) (p:=size)).
      mx_intros a b Ha Hb. simpl. fold_regex.
      apply xif_compat; auto.
      rewrite 2 id_num. apply <- bool_prop_iff. rewrite 2 T_true.
      destruct tarjan_correct as [[ _ _ _ H] _]. rewrite H. tauto.
      num_lia.
      num_lia.

      (* y * m <== m * y *)
      mx_intros i k Hi Hk. simpl; fold_regex.
       apply sum_leq; intros j _ Hj.
       xif_destruct; [semiring_normalize|semiring_reflexivity].
       unfold labelling.
       setoid_rewrite sum_distr_left. rewrite sum_inversion. (* BUG setoid_rewrite/rewrite: très long... *)
       apply sum_incr; intros a Ha. simpl; fold_regex. fold_leq.
       xif_destruct; unfold xif at 1; trivial with algebra.
       leq_sum (delta a i). pose proof (bounded_delta Hbounds a i). num_lia.
       bool_simpl. num_prop. rewrite H0.
       rewrite (simulation H); trivial.
        unfold xif. semiring_reflexivity.
        num_lia.
        num_lia.

      (* y * v == v *)
      mx_intros i j Hi Hj. clear - Hi Hbounds i' Hi' Hj' _H. simpl; fold_regex.
      apply leq_antisym.
       apply sum_leq.
       intros n Hn Hn'.
       xif_destruct; [semiring_normalize|semiring_reflexivity].
       apply T_finaux in H. unfold statesetelt_of_nat, statemapelt_of_nat in *.
       rewrite H. reflexivity.

       xif_destruct; trivial with algebra.
       leq_sum i. rewrite T_refl, H. xif_simpl. semiring_reflexivity.

      (* 1 <== y *)
      mx_intros i j Hi Hj. simpl; fold_regex.
       nat_analyse; auto with algebra.
       rewrite T_refl. xif_simpl. trivial with algebra.

      (* y * y <== y*)
      mx_intros i j Hi Hj. simpl; fold_regex.
       apply sum_leq. intros k Hk Hk'.
       xif_destruct; [semiring_normalize|semiring_reflexivity].
       xif_destruct; [semiring_normalize|semiring_reflexivity].
       rewrite T_true in *. rewrite H0 in H. rewrite <- T_true in H.
       rewrite H. reflexivity.
    Qed.
  End Correction.

  Theorem valid i j: belong i A -> belong j A -> equiv A i j = None ->
    eval (change_initial A i) == eval (change_initial A j).
  Proof.
    intros Hi Hj H'.
    unfold equiv in H'.
    case_eq (loop A (Datatypes.S size) nil DS.empty i j); intros R HR; rewrite HR in H'.
    apply (eval_change_initial Hi Hj HR).
    discriminate.
  Qed.

End correctness.

Import DKA_DFA_Language.

Section completeness.

  Variable A: DFA.t.
  Hypothesis HA: bounded A.
  Variables i j: state.
  Hypothesis Hi: belong i A.
  Hypothesis Hj: belong j A.

  Definition select (b: bool) (i j: state) := if b then i else j.

  Lemma counter_exemple_loop: forall b w n v t,
    bounded_word A v ->
    loop A n v t (read A (rev v) i) (read A (rev v) j) = inr (b,w) ->
    DFA_language (change_initial A (select b i j)) w
    /\ ~ DFA_language (change_initial A (select b j i)) w.
  Proof.
    induction n; intros v tar Hv.
     intro. discriminate.
     simpl. case DS.test_and_unify. intros [|] tar'.
      intro. discriminate.
      bool_analyse.
       clear e tar. revert v Hv tar'. generalize (le_n (max_label A)).
       generalize (max_label A) at 1 3 as a.
       induction a using num_peano_rec; [setoid_rewrite fold_num_sum_O|setoid_rewrite fold_num_sum_S];
         intros Ha v Hv tar; simpl.
        intro. discriminate.
        num_simpl. simpl. num_simpl.
        generalize (IHn (a::v) tar). simpl. rewrite 2 read_app. simpl.
        case loop.
         intros tar' _ H. apply IHa in H; auto with arith.
         intros p H H'. dependent destruction H'. apply H; auto.
          intros c [->|Hc]; auto with arith. num_lia.

       clear IHn. intro H'; injection H'; intros; subst; clear H'.
       StateSetProps.mem_analyse; StateSetProps.mem_analyse;
        (elim H; reflexivity) || (unfold DFA_language, bounded_word; setoid_rewrite <- In_rev; tauto).
  Qed.

  Lemma counter_exemple_equiv: forall b w,
    equiv A i j = Some (b,w) ->
    DFA_language (change_initial A (select b i j)) w
    /\ ~ DFA_language (change_initial A (select b j i)) w.
  Proof.
    intros b w. unfold equiv.
    case_eq (loop A (Datatypes.S (size A)) nil DS.empty i j). intros; discriminate.
    intros [b' w'] H H'. injection H'; intros; subst.   clear H'.
    apply (@counter_exemple_loop b w _ nil) in H. assumption.
    intro. simpl. tauto.
  Qed.

Opaque equal.
  Theorem completeness: equiv A i j <> None -> ~ eval (change_initial A i) == eval (change_initial A j).
  Proof.
    remember (equiv A i j) as r. destruct r as [[b w]|]. 2: rewrite Heqr; firstorder.
    intros _ H. symmetry in Heqr. apply counter_exemple_equiv in Heqr; auto.
    apply regex_language_graph_functor in H. simpl in H.
    rewrite 2 language_DFA_eval in H by auto using bounded_change_initial.
    specialize (H w). destruct b; simpl in Heqr; tauto.
  Qed.
Transparent equal.

End completeness.

Theorem correct: forall A i j, bounded A -> belong i A -> belong j A ->
  (equiv A i j = None <-> eval (change_initial A i) == eval (change_initial A j)).
Proof.
  intros A i j HA Hi Hj. split.
   apply valid; assumption.
   case_eq (equiv A i j); auto.
   intros c Hc H. exfalso. apply (completeness HA Hi Hj). rewrite Hc. intro. discriminate. assumption.
Qed.