Require Export Topology.

(* framework *)
Definition C_0 Y := Y = ∅.
Definition C_1 Y := ⦿ Y.

Definition Inter_bb A B X cT := Bound A X cT ∩ Bound B X cT.
Definition Inter_ii A B X cT := Interior A X cT ∩ Interior B X cT.
Definition Inter_bi A B X cT := Bound A X cT ∩ Interior B X cT.
Definition Inter_ib A B X cT := Interior A X cT ∩ Bound B X cT.

Definition r0 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r1 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r2 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r3 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r4 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r5 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r6 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r7 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_0 (Inter_ib A B X cT).

Definition r8 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

Definition r9 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

Definition r10 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

Definition r11 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_0 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

Definition r12 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

Definition r13 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_0 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

Definition r14 A B X cT :=
  C_0 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

Definition r15 A B X cT :=
  C_1 (Inter_bb A B X cT) ∧ C_1 (Inter_ii A B X cT) ∧
  C_1 (Inter_bi A B X cT) ∧ C_1 (Inter_ib A B X cT).

(* regularly closed *)
Definition RegClo A X cT := A = Closure (Interior A X cT) X cT.

Lemma RegClo_P : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → RegClo A X cT → RegClo B X cT →
  C_1 (Inter_bi A B X cT) → C_1 (Inter_ii A B X cT).
Proof.
  intros * Hxe Ht Ha Hb Har Hbr [x Hp]. assert (Has: A ⊂ X). apply Ha.
  AppC Hp; andH. assert (Heq: Bound A X cT = Bound (Interior A X cT) X cT).
  { eapply bound_F2 in Has as Hac; eauto. apply closure_T in Ha; auto.
    rewrite <- Ha in Hac. pose proof (interiorP A X cT) as Hai.
    eapply bound_F2 in Hai; eauto. rewrite interior_T2a, <- Har in Hai; auto.
    rewrite Hai in Hac at 1; clear Hai. pose proof (bound_T A X cT).
    pose proof (bound_T (Interior A X cT) X cT).
    rewrite interior_T2a in H2; auto. eapply unEq_inEm_idEq; eauto. }
  rewrite Heq in H; clear Heq. AppC H; destruct H as [_ [_ [Hx H]]].
  rewrite <- interior_T2a in H0; auto; [|apply Hb]. AppC H0.
  apply H in H0 as [H0 _]. apply EmptyNE in H0 as [y]. exists y.
  rewrite CommuI in H0; auto.
Qed.

Theorem r_4 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → RegClo A X cT → RegClo B X cT → r4 A B X cT → False.
Proof.
  intros * Hxe Ht Ha Hb Har Hbr [_ [Hii [Hbi _]]].
  apply RegClo_P in Hbi as [x]; auto. rewrite Hii in H; exfalso0.
Qed.

Theorem r_5 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → RegClo A X cT → RegClo B X cT → r5 A B X cT → False.
Proof.
  intros * Hxe Ht Ha Hb Har Hbr [_ [Hii [Hbi _]]].
  apply RegClo_P in Hbi as [x]; auto. rewrite Hii in H; exfalso0.
Qed.

Theorem r_8 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → RegClo A X cT → RegClo B X cT → r8 A B X cT → False.
Proof.
  intros * Hxe Ht Ha Hb Har Hbr [_ [Hii [_ Hib]]].
  unfold Inter_ib in Hib; rewrite CommuI in Hib.
  apply RegClo_P in Hib as [x]; auto.
  unfold Inter_ii in Hii. rewrite CommuI in Hii.
  unfold Inter_ii in H. rewrite Hii in H; exfalso0.
Qed.

Theorem r_9 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → RegClo A X cT → RegClo B X cT → r9 A B X cT → False.
Proof.
  intros * Hxe Ht Ha Hb Har Hbr [_ [Hii [_ Hib]]].
  unfold Inter_ib in Hib; rewrite CommuI in Hib.
  apply RegClo_P in Hib as [x]; auto.
  unfold Inter_ii in Hii. rewrite CommuI in Hii.
  unfold Inter_ii in H. rewrite Hii in H; exfalso0.
Qed.

Theorem r_12 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → RegClo A X cT → RegClo B X cT → r12 A B X cT → False.
Proof.
  intros * Hxe Ht Ha Hb Har Hbr [_ [Hii [Hbi _]]].
  apply RegClo_P in Hbi as [x]; auto. rewrite Hii in H; exfalso0.
Qed.

Theorem r_13 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → RegClo A X cT → RegClo B X cT → r13 A B X cT → False.
Proof.
  intros * Hxe Ht Ha Hb Har Hbr [_ [Hii [Hbi _]]].
  apply RegClo_P in Hbi as [x]; auto. rewrite Hii in H; exfalso0.
Qed.

(* planar spatial region *)
Definition Spatial A X cT := ⦿ A ∧ A ⊊ X ∧
  RegClo A X cT ∧ subConnect (Interior A X cT) cT.

Fact spa_NEmpty : ∀ A X cT, Ensemble X → Topology X cT →
  Spatial A X cT → ⦿ Interior A X cT.
Proof.
  intros * Hxe Ht [[x Hx] [_ [Ha _]]].
  DC (Interior A X cT = ∅); [|apply EmptyNE; auto].
  red in Ha; rewrite H, closure_T1 in Ha; auto; subst; exfalso0.
Qed.

Fact spa_NX : ∀ A X cT, Topology X cT →
  Closed A X cT → Spatial A X cT → Closure A X cT ≠ X.
Proof.
  intros * Ht Hc [_ [[] _]]. apply closure_T in Hc; auto.
  rewrite <- Hc; auto.
Qed.

Fact spa_Connect : ∀ A X cT, Ensemble X → Topology X cT →
  Spatial A X cT → subConnect A cT.
Proof.
  intros * Hxe Ht [_ [_ [Heq Hic]]]. rewrite Heq.
  apply scon_T3C2; auto. split; andG; auto. eapply interiorP.
Qed.

Lemma Spatial_P1 : ∀ A X cT, Ensemble X → Connected X cT → Topology X cT →
  Closed A X cT → Spatial A X cT → Bound A X cT ≠ ∅.
Proof.
  intros * Hxe Hxc Ht Hc [Hae [Hap [Har Hac]]]. assert (Ha: A ⊂ X). apply Hc.
  DC (Bound A X cT = ∅); auto.
  assert (disSubConnect (X - (Bound A X cT)) cT).
  { apply scon_T4C; auto. split; andG; auto; eapply resFam; eauto.
    apply spa_NEmpty; auto. split; andG; auto. eapply closure_T in Hc; auto.
    rewrite <- Hc; apply Hap. } assert (cT|X = cT).
  { AppE; [AppC H1; destruct H1 as [B []]; subst x| AppCG; Ens; exists x;
    andG; auto]; rewrite IncI; auto; apply Ht in H1; pow H1. }
  rewrite H, SetminEm in H0. red in H0; rewrite H1 in H0; auto.
Qed.

Theorem r_2 : ∀ A B X cT, Ensemble X → Connected X cT → Topology X cT →
  Closed A X cT → Closed B X cT → Spatial A X cT → Spatial B X cT →
  r2 A B X cT → False.
Proof.
  intros * Hxe Hxc Ht Hac Hbc Has Hbs [Hbb [Hii [Hbi Hib]]].
  assert (A ⊂ X ∧ B ⊂ X). { andG. apply Hac. apply Hbc. }
  destruct H as [Hax Hbx]. assert (A = Closure A X cT ∧ B = Closure B X cT).
  { andG; apply closure_T; auto. } destruct H as [Haeq Hbeq].
  assert (Hb: B ⊂ X - Bound A X cT).
  { intros x Hx. smG; auto. assert (Bound A X cT ∩ B = ∅).
    unfold C_0, Inter_bi in Hbi; unfold C_0, Inter_bb in Hbb. rewrite Hbeq,
      interior_Tb, Re4_ClInBo, DistribuLI, Hbi, Hbb, EmptyU; auto.
    DC (x ∈ Bound A X cT); auto. assert (x ∈Bound A X cT ∩ B); ens.
    rewrite H in H1; exfalso0. }
  assert (Habx: X - Bound A X cT ⊂ X). intros x Hx; smH; auto.
  assert (Hcbx: subConnect B (cT | (X - Bound A X cT))).
  { apply (scon_T1 B (X - Bound A X cT) X cT); auto.
    split; andG; auto. split; auto; eapply resFam; eauto.
    eapply spa_Connect; eauto. }
  assert (Hbso: B ⊂ Interior A X cT ∨ B ⊂ X - A).
  { rewrite Haeq at 2. apply (scon_T3 B (X - Bound A X cT)
      (cT | (X - Bound A X cT))); auto. eapply SubAxP; eauto. split; auto.
    eapply resFam; eauto. apply scon_T4; auto. split; auto.
    apply spa_NEmpty; auto. apply spa_NX; auto.
    rewrite subTop_T1; auto. split; auto. } orH.
  - assert (Bound B X cT ⊂ Interior A X cT).
    { eapply IncTran; eauto. rewrite Hbeq at 2. rewrite interior_Tb,
        Re4_ClInBo; auto. intros x Hx; apply UnionI'; auto. }
    apply Spatial_P1, EmptyNE in Hbs as [x]; auto.
    assert (x ∈ Interior A X cT ∩ Bound B X cT); ens.
    unfold C_0, Inter_ib in Hib. rewrite Hib in H2; exfalso0.
  - destruct Hii as [x Hx]. AppC Hx; andH.
    apply interior_F1, H in H1. smH. apply interior_F1 in H0; auto.
Qed.

Theorem r_0 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → r0 A B X cT → A ∩ B = ∅.
Proof.
  intros * Hxe Ht Hac Hbc [Hbb [Hii [Hbi Hib]]];
  unfold C_0, Inter_bb, Inter_ii, Inter_bi, Inter_ib in *.
  assert (A ⊂ X ∧ B ⊂ X). { andG. apply Hac. apply Hbc. } destruct H.
  apply closure_T in Hac; apply closure_T in Hbc; auto.
  rewrite Hac, Hbc, interior_Tb, Re4_ClInBo, interior_Tb,
    Re4_ClInBo, DistribuLI, DistribuI, DistribuI,
    Hbb, Hii, Hbi, Hib, EmptyU, EmptyU; auto.
Qed.

Theorem r_1 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → r1 A B X cT →
  A ∩ B = Bound A X cT ∩ Bound B X cT.
Proof.
  intros * Hxe Ht Hac Hbc [Hbb [Hii [Hbi Hib]]];
  unfold C_0, Inter_ii, Inter_bi, Inter_ib in *.
  assert (A ⊂ X ∧ B ⊂ X). { andG. apply Hac. apply Hbc. } destruct H.
  apply closure_T in Hac; apply closure_T in Hbc; auto.
  rewrite Hac, Hbc at 1. rewrite interior_Tb, Re4_ClInBo, interior_Tb,
    Re4_ClInBo, DistribuLI, DistribuI, DistribuI, Hii, Hbi, Hib, EmptyU,
    CommuU, EmptyU, CommuU, EmptyU; auto.
Qed.

Theorem r_14 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → r14 A B X cT →
  Interior A X cT ∩ Interior B X cT ≠ ∅ ∧ A ∩ B ≠ ∅.
Proof.
  intros * Hxe Ht Hac Hbc [Hbb [Hii [[x Hbi] [y Hib]]]].
  assert (A ⊂ X ∧ B ⊂ X). { andG. apply Hac. apply Hbc. } destruct H.
  apply closure_T in Hac; apply closure_T in Hbc; auto.
  AppC Hbi; AppC Hib; andH. andG. apply EmptyNE, Hii. apply EmptyNE.
  exists x. rewrite Hac, Hbc, interior_Tb,
    Re4_ClInBo, interior_Tb, Re4_ClInBo; ens.
Qed.

Theorem r_15 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → r15 A B X cT →
  Interior A X cT ∩ Interior B X cT ≠ ∅ ∧ A ∩ B ≠ ∅.
Proof.
  intros * Hxe Ht Hac Hbc [Hbb [Hii [[x Hbi] [y Hib]]]].
  assert (A ⊂ X ∧ B ⊂ X). { andG. apply Hac. apply Hbc. } destruct H.
  apply closure_T in Hac; apply closure_T in Hbc; auto.
  AppC Hbi; AppC Hib; andH. andG. apply EmptyNE, Hii. apply EmptyNE.
  exists x. rewrite Hac, Hbc, interior_Tb,
    Re4_ClInBo, interior_Tb, Re4_ClInBo; ens.
Qed.

Lemma Spatial_P2 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → Spatial A X cT → Spatial B X cT →
  C_1 (Inter_ii A B X cT) → C_0 (Inter_ib A B X cT) →
  Interior A X cT ⊂ Interior B X cT ∧ A ⊂ B.
Proof.
  intros * Hxe Ht Hac Hbc Has Hbs Hp1 Hp2. assert (A ⊂ X ∧ B ⊂ X).
  { andG. apply Hac. apply Hbc. } destruct H as [Hax Hbx].
  assert (A = Closure A X cT ∧ B = Closure B X cT).
  { andG; apply closure_T; auto. } destruct H as [Haeq Hbeq].
  assert (Hai: Interior A X cT ⊂ X). apply interiorP; auto.
  assert (Hbxs: Separation (Interior B X cT) (X - B) X cT).
  { assert (SubTop (X - Bound B X cT) X cT). split; auto. apply SetminSubI.
    rewrite Hbeq at 2. apply (separation_T (X - Bound B X cT) X cT Hxe H
      (Interior B X cT) (X - Closure B X cT)).
    rewrite bound_F3; auto; apply SetminSub1, closureP; auto.
    rewrite bound_F2; auto; apply SetminSub2; intros x Hx; ens.
    apply scon_T4; auto. split; auto. apply spa_NEmpty; auto.
    apply spa_NX; auto. }
  assert (Interior A X cT ⊂ Interior B X cT ∨ Interior A X cT ⊂ X - B).
  { eapply scon_T3; eauto. split; auto. apply Has. rewrite Hbeq at 2.
    rewrite subTop_T1; try split; auto. intros x Hx. smG.
    eapply interiorP; eauto. DC (x ∈ Bound B X cT); auto.
    assert (x ∈ Interior A X cT ∩ Bound B X cT). ens.
    unfold C_0, Inter_ib in Hp2. rewrite Hp2 in H0; exfalso0. } orH.
  - destruct Has as [_ [_ [Hra _]]]; destruct Hbs as [_ [_ [Hrb _]]].
    andG; auto. rewrite Hra, Hrb. apply closure_F2; auto. apply interiorP.
  - exfalso. destruct Hp1 as [x Hx]. AppC Hx; andH. apply H in H0; smH.
    apply interior_F1 in H1; auto.
Qed.

Theorem r_3 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → Spatial A X cT → Spatial B X cT →
  r3 A B X cT → A = B.
Proof.
  intros * Hxe Ht Hac Hbc Has Hbs [Hbb [Hii [Hbi Hib]]]. apply IncAsym.
  eapply Spatial_P2; eauto. eapply (Spatial_P2 B A); eauto;
  unfold C_0, C_1, Inter_ii, Inter_ib, Inter_bi in *; rewrite CommuI; auto.
Qed.

Theorem r_6 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → Spatial A X cT → Spatial B X cT →
  r6 A B X cT → A ⊂ Interior B X cT.
Proof.
  intros * Hxe Ht Hac Hbc Has Hbs [Hbb [Hii [Hbi Hib]]].
  assert (Hp: Interior A X cT ⊂ Interior B X cT ∧ A ⊂ B).
  apply Spatial_P2; auto. destruct Hp as [Hiab Hab]. assert (A ⊂ X ∧ B ⊂ X).
  andG. apply Hac. apply Hbc. destruct H as [Hax Hbx].
  assert (A = Closure A X cT ∧ B = Closure B X cT).
  andG; apply closure_T; auto. destruct H as [Haeq Hbeq].
  rewrite Haeq, bound_F2; auto. intros x Hx; unH; auto.
  assert (Bound A X cT ⊂ B).
  { eapply IncTran; eauto. rewrite Haeq at 2.
    rewrite bound_F2; auto. intros y Hy; ens. }
  rewrite Hbeq, bound_F2 in H0; auto. apply H0 in H as Hb; unH; auto.
  assert (x ∈ Bound A X cT ∩ Bound B X cT). ens.
  unfold C_0, Inter_bb in Hbb. rewrite Hbb in H2; exfalso0.
Qed.

Theorem r_7 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → Spatial A X cT → Spatial B X cT → r7 A B X cT → A ⊂ B.
Proof.
  intros. destruct H5 as [Hbb [Hii [Hbi Hib]]]. eapply Spatial_P2; eauto.
Qed.

Theorem r_10 : ∀ A B X cT, Ensemble X → Topology X cT →
  Closed A X cT → Closed B X cT → Spatial A X cT → Spatial B X cT →
  r10 A B X cT → B ⊂ Interior A X cT.
Proof.
  intros * Hxe Ht Hac Hbc Has Hbs [Hbb [Hii [Hbi Hib]]].
  assert (Hp: Interior B X cT ⊂ Interior A X cT ∧ B ⊂ A).
  eapply (Spatial_P2 B A); eauto; unfold C_0, C_1, Inter_ii, Inter_ib,
    Inter_bi in *; rewrite CommuI; auto. destruct Hp as [Hiba Hba].
  assert (A ⊂ X ∧ B ⊂ X). andG. apply Hac. apply Hbc. destruct H as [Hax Hbx].
  assert (A = Closure A X cT ∧ B = Closure B X cT).
  andG; apply closure_T; auto. destruct H as [Haeq Hbeq].
  rewrite Hbeq, bound_F2; auto. intros x Hx; unH; auto.
  assert (Bound B X cT ⊂ A).
  { eapply IncTran; eauto. rewrite Hbeq at 2.
    rewrite bound_F2; auto. intros y Hy; ens. }
  rewrite Haeq, bound_F2 in H0; auto. apply H0 in H as Hb; unH; auto.
  assert (x ∈ Bound A X cT ∩ Bound B X cT). ens.
  unfold C_0, Inter_bb in Hbb. rewrite Hbb in H2; exfalso0.
Qed.

Theorem r_11 : ∀ A B X cT, Ensemble X → Topology X cT → Closed A X cT →
  Closed B X cT → Spatial A X cT → Spatial B X cT → r11 A B X cT → B ⊂ A.
Proof.
  intros. destruct H5 as [Hbb [Hii [Hbi Hib]]]. eapply (Spatial_P2 B A); eauto;
  unfold C_0, C_1, Inter_ii, Inter_ib, Inter_bi in *; rewrite CommuI; auto.
Qed.


Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Logic.Eqdep.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Import Functors.
Require Import Containers.
Require Import Polynomial.

Section Equality.

  Class Eq (A : Set) :=
    { eq                     :  A -> A -> bool;
      eq_propositional_true  : forall (x y : A), eq x y = true  -> x = y;
      eq_propositional_false : forall (x y : A), eq x y = false -> x <> y
    }.

  Variable c : Code.

  Definition EQA := FixP c -> bool.
  Definition EQB (d : Code) := ExtP (FixP c) d -> bool.

  (*
  Fixpoint eqalg (d : Code) (x : ExtP EQA d) : EQB d.
  Proof.
    destruct x; intro y.
    apply true.
    inversion y.
    apply (e H).
    inversion y; subst.
    apply (eqalg _ _ H0).
    unfold
  *)

  Definition eqf (eq : EQB c) : EQA :=
    fun x => match x with
               | fixp e => eq e
             end.
  Definition equ (x : ExtP (FixP c) U) : bool := true.
  Definition eqi (f : EQA) : EQB I :=
    fun x => match x with
               | ei x => f x
               | _     => false
             end.
  Definition eql (c1 c2 : Code) (eq : EQB c1) : EQB (C c1 c2).
    intro x; inversion x; subst.
    apply (eq H0).
    apply false.
  Defined.
  Definition eqr (c1 c2 : Code) (eq : EQB c2) : EQB (C c1 c2).
    intro x; inversion x; subst.
    apply false.
    apply (eq H0).
  Defined.
  Definition eqp (c1 c2 : Code) (eq1 : EQB c1) (eq2 : EQB c2) : EQB (P c1 c2).
    intro x; inversion x; subst.
    apply (andb (eq1 H1) (eq2 H2)).
  Defined.

  Definition eqfix : FixP c -> FixP c -> bool :=
    fixpfold2 c EQA EQB eqf equ eqi eql eqr eqp.
  Definition eqext : forall d, ExtP (FixP c) d -> ExtP (FixP c) d -> bool :=
    extpfold2 c EQA EQB eqf equ eqi eql eqr eqp.

  Lemma eqfix_propositional_true :
    forall u v, eqfix u v = true -> u = v.
  Proof.
    apply (fixp_ind c
            (fun u   => forall v, eqfix u v = true -> u = v)
            (fun d u => forall v, eqext d u v = true -> u = v));
      intros;
      dependent destruction v;
      try (f_equal; apply (H _ H0));
      try discriminate.
    (* ep *)
    unfold eqext in H1.
    unfold extpfold2 in H1.
    simpl in H1.
    apply andb_true_iff in H1.
    destruct H1.
    f_equal.
    apply (H _ H1).
    apply (H0 _ H2).
  Qed.

  Lemma eqfix_propositional_false :
    forall u v, eqfix u v = false -> u <> v.
  Proof.
    apply (fixp_ind c
            (fun u   => forall v, eqfix u v = false -> u <> v)
            (fun d u => forall v, eqext d u v = false -> u <> v));
      intros;
      dependent destruction v;
      try discriminate;
      intro Heq; inversion Heq; subst.
    apply (H e); auto.
    apply (H f); auto.
    apply inj_pairT2 in H2.
    apply (H _ H0); auto.
    apply inj_pairT2 in H2.
    apply (H _ H0); auto.
    apply inj_pairT2 in H3.
    apply inj_pairT2 in H4.
    subst.
    unfold eqext in H1.
    unfold extpfold2 in H1.
    simpl in H1.
    apply andb_false_iff in H1.
    destruct H1.
    apply (H _ H1); auto.
    apply (H0 _ H1) ; auto.
  Qed.

  Global Instance Eq_FixP : Eq (FixP c) :=
    {| eq := eqfix;
       eq_propositional_true := eqfix_propositional_true;
       eq_propositional_false := eqfix_propositional_false |}.

End Equality.

Section Container.
  Variable (F : Set -> Set).
  Context {poly_F : Polynomial F}.
  Existing Instance PolynomialContainer.

  Global Instance Eq_Fix : Eq (Fix F) :=
    {| eq := fun x y => eq (toFixP _ x) (toFixP _ y) |}.
  Proof.
    intros; simpl.
    apply eq_propositional_true in H.
    apply f_equal with (f := fromFixP PCode) in H.
    repeat rewrite fromFixP_toFixP_inverse in H.
    auto.
    intros.
    apply eq_propositional_false in H.
    intro.
    apply H.
    f_equal.
    auto.
  Defined.

End Container.


Require Import Measures.
Require Import Coquelicot.Rbar.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
Require Import Coq.omega.Omega.
Require Import Coq.Logic.FunctionalExtensionality.

Import ListNotations.

Open Scope nat.
Open Scope list.

Arguments id {_} _ /.
Arguments flip {_ _ _} _ _ _ /.
Arguments Datatypes.id {_} _ /.
Arguments compose {_ _ _} _ _ _ /.

Notation πL := Entropy_π1.
Notation πR := Entropy_π2.
Infix "∘" := compose.

Definition Meas X := Measurable X -> Rbar.

Ltac spec1 H :=
  let H' := fresh "H" in
  lazymatch type of H with
  | ?A -> ?B =>
    assert (H' : A);
    [try clear H | specialize (H H'); try clear H']
  | forall x : ?A, ?B =>
    simple refine (let H' : A := _ in _);
      [try clear H | specialize (H H'); subst H']
  end.

(* show (∫ f dμ = ∫ g dμ) by showing pointwise equality *)
Ltac integrand_extensionality x :=
  match goal with
  | [ |- _ = _ :> Rbar ] => idtac
  | [ |- _ = _ :> Meas _ ] => let A := fresh "A" in extensionality A
  | [ |- _ = _ :> _ -> Rbar ] => let A := fresh "A" in extensionality A
  end;
  refine (f_equal2 integrate _ eq_refl);
  extensionality x.

Lemma split_entropy' : forall f,
    integrate (fun σ1 => integrate (fun σ2 => (f σ1 σ2)) μentropy) μentropy =
    integrate (fun σ => (f (Entropy_π1 σ) (Entropy_π2 σ))) μentropy.
Proof.
  intros.
  rewrite tonelli_μentropy.
  apply split_entropy.
Qed.

Axiom exists_entropy : Entropy.
Definition dummy_entropy := exists_entropy.

Inductive dir := L | R.
Definition πd (d : dir) := if d then πL else πR.

Definition path := list dir.

Lemma dir_eq_dec (d0 d1 : dir) : {d0 = d1} + {d0 <> d1}.
Proof.
  decide equality.
Qed.

Definition path_eq_dec : forall (p0 p1 : path), {p0 = p1} + {p0 <> p1}
  := list_eq_dec (dir_eq_dec).

(** "neither is a prefix of the other" *)
Inductive paths_disjoint : path -> path -> Prop :=
| disjoint_LR p0 p1 : paths_disjoint (L :: p0) (R :: p1)
| disjoint_RL p0 p1 : paths_disjoint (R :: p0) (L :: p1)
| disjoint_tail d p0 p1 : paths_disjoint p0 p1 -> paths_disjoint (d :: p0) (d :: p1)
.
Hint Constructors paths_disjoint.

Fixpoint apply_path (p : path) : Entropy -> Entropy :=
  match p with
  | [] => id
  | d :: p' => apply_path p' ∘ πd d
  end.

Inductive nondup : list path -> Prop :=
| nondup_nil : nondup []
| nondup_cons p ps :
    (forall p', In p' ps -> paths_disjoint p p') ->
    nondup ps ->
    nondup (p :: ps)
.
Hint Constructors nondup.

Ltac show_nondup := progress repeat (constructor; rewrite <- ?Forall_forall).

Lemma nondup_app (l0 l1 : list path) :
  (nondup l0 /\
   nondup l1 /\
   (forall p0 p1, In p0 l0 -> In p1 l1 -> paths_disjoint p0 p1)) <->
  nondup (l0 ++ l1).
Proof.
  induction l0. {
    cbn.
    intuition eauto.
  } {
    split; cbn; intros. {
      destruct IHl0 as [? _].
      intuition idtac.
      inject H1.
      intuition idtac.
      constructor; eauto.
      intros.
      rewrite in_app_iff in H1.
      intuition eauto.
    } {
      destruct IHl0 as [_ ?].
      inject H.
      setoid_rewrite in_app_iff in H3.
      intuition (subst; eauto).
    }
  }
Qed.

Definition apply_paths (ps : list path) (σ : Entropy) : list Entropy :=
  map (flip apply_path σ) ps.
Arguments apply_paths !_ _.

Fixpoint split (d : dir) (p : path) : list path :=
  match d, p with
  | L, L :: p' => [p']
  | R, R :: p' => [p']
  | _, _ => []
  end.

Definition splits := fun d => flat_map (split d).

Fixpoint integrate_by_entropies (g : list Entropy -> Rbar) (n : nat) : Rbar :=
  match n with
  | O => g []
  | S n' => integrate (fun σ => integrate_by_entropies (fun σs => g (σ :: σs)) n') μentropy
  end.

Fixpoint max_list_len {X} (l : list (list X)) :=
  match l with
  | [] => 0
  | b :: bs => max (length b) (max_list_len bs)
  end.

Lemma max_list_len_app {X} (l0 l1 : list (list X)) :
  max_list_len (l0 ++ l1) = max (max_list_len l0) (max_list_len l1).
Proof.
  induction l0; auto.
  cbn.
  rewrite IHl0.
  apply Nat.max_assoc.
Qed.

Lemma tonelli_entropies_and_entropy n (f : list Entropy -> Entropy -> Rbar) :
  integrate_by_entropies (fun σs => integrate (fun σ => f σs σ) μentropy) n =
  integrate (fun σ => integrate_by_entropies (fun σs => f σs σ) n) μentropy.
Proof.
  revert f.
  induction n; intros; auto.
  cbn.
  rewrite tonelli_μentropy; auto.
  setoid_rewrite IHn.
  reflexivity.
Qed.

Lemma splits_max_len {n Δ} :
  max_list_len Δ <= S n ->
  forall d,
    max_list_len (splits d Δ) <= n.
Proof.
  revert n.
  induction Δ; intros; cbn in *; try omega.
  rewrite @max_list_len_app.
  apply Max.max_lub; eauto using Max.max_lub_r.
  apply Max.max_lub_l in H.
  induction a as [| [|] ?];
    destruct d;
    cbn in *;
    try apply Max.max_lub;
    omega.
Qed.

Lemma splits_max_len' {Δ} :
  0 <> max_list_len Δ ->
  forall d,
    max_list_len (splits d Δ) < max_list_len Δ.
Proof.
  intros.
  unfold lt.
  remember (max_list_len Δ).
  destruct n; try omega.
  apply le_n_S.
  apply splits_max_len.
  rewrite Heqn.
  reflexivity.
Qed.

Lemma in_split {p p' d} :
  In p' (split d p) ->
  p = d :: p'.
Proof.
  intros.
  destruct d, p as [|[|]];
    cbn in *;
    intuition (subst; trivial).
Qed.

Lemma in_splits {Δ p d} :
  In p (splits d Δ) ->
  In (d :: p) Δ.
Proof.
  intros.
  induction Δ; auto.
  cbn in *.
  apply in_app_or in H.
  intuition idtac.
  left.
  apply in_split; auto.
Qed.

Lemma splits_nondup {Δ} :
  nondup Δ ->
  forall d,
    nondup (splits d Δ).
Proof.
  intros.
  induction Δ; intros; auto.
  inject H.
  cbn.
  apply nondup_app.
  intuition idtac. {
    destruct d, a as [|[|]]; show_nondup.
  } {
    apply in_split in H0.
    apply in_splits in H1.
    subst.
    specialize (H2 _ H1).
    inject H2.
    auto.
  }
Qed.

Lemma nil_in_nondup Δ :
  nondup Δ ->
  In [] Δ ->
  Δ = [[]].
Proof.
  intros.
  destruct Δ; try tauto.
  inject H.
  destruct p. {
    destruct Δ; auto.
    specialize (H3 p (in_eq _ _)).
    inject H3.
  }
  exfalso.
  inject H0; try discriminate.
  specialize (H3 _ H).
  inject H3.
Qed.

Fixpoint reinterleave (Δ : list path) (σls σrs : list Entropy) : list Entropy :=
  match Δ, σls, σrs with
  | (L :: _) :: Δ', σl :: σls', _ => σl :: reinterleave Δ' σls' σrs
  | (R :: _) :: Δ', _, σr :: σrs' => σr :: reinterleave Δ' σls σrs'
  | _, _, _ => []
  end.

Lemma reinterleave_splits Δ σ :
  ~ In [] Δ ->
  reinterleave Δ (apply_paths (splits L Δ) (πL σ)) (apply_paths (splits R Δ) (πR σ)) =
  apply_paths Δ σ.
Proof.
  revert σ.
  induction Δ; intros; auto.

  apply not_in_cons in H.
  inject H.
  destruct a; try contradiction.

  transitivity (apply_path a (πd d σ) :: apply_paths Δ σ); auto.
  rewrite <- IHΔ; auto.
  destruct d; reflexivity.
Qed.

Lemma split_and_reinterleave g Δ :
  ~ In [] Δ ->
  integrate_by_entropies g (length Δ) =
  integrate_by_entropies
    (fun σls =>
       integrate_by_entropies
         (fun σrs =>
            g (reinterleave Δ σls σrs)
         ) (length (splits R Δ))
    ) (length (splits L Δ)).
Proof.
  intros.

  revert g.
  induction Δ; intros; auto.

  apply not_in_cons in H.
  inject H.

  spec1 IHΔ; auto.

  destruct a as [|[|] ?]; cbn; try contradiction. {
    integrand_extensionality σ.
    rewrite IHΔ.
    reflexivity.
  } {
    rewrite tonelli_entropies_and_entropy.
    integrand_extensionality σ.
    rewrite IHΔ.
    reflexivity.
  }
Qed.

Theorem strong_nat_rect (P : nat -> Type) :
  (forall n, (forall m, m < n -> P m) -> P n) ->
  forall n, P n.
Proof.
  intros H n.
  apply H.
  induction n; intros. {
    omega.
  } {
    apply H.
    intros.
    apply IHn.
    omega.
  }
Qed.

Lemma integrate_by_entropies_unfold Δ g :
  nondup Δ ->
  integrate (g ∘ apply_paths Δ) μentropy =
  integrate_by_entropies g (length Δ).
Proof.
  intros.

  remember (max_list_len Δ) as m.
  revert Δ Heqm H g.
  induction m using strong_nat_rect.
  intros; subst.
  specialize (fun Δ' Hk => H _ Hk Δ' eq_refl).

  destruct (list_eq_dec path_eq_dec Δ []). {
    subst.
    unfold compose.
    cbn.
    apply integrate_entropy_const.
  }

  destruct (in_dec path_eq_dec [] Δ) as [?H | ?H]. {
    rewrite (nil_in_nondup Δ); try assumption.
    reflexivity.
  }

  rewrite split_and_reinterleave; auto.

  pose proof splits_nondup H0.
  pose proof @splits_max_len' Δ.

  spec1 H3. {
    destruct Δ as [|[|] Δ]; cbn in *; try tauto.
    destruct (max_list_len Δ); discriminate.
  }

  unfold compose in *.
  do 2 (setoid_rewrite <- H; auto).

  rewrite split_entropy'.
  integrand_extensionality σ.

  rewrite <- reinterleave_splits; auto.
Qed.

Lemma diagram (Δ Δ' : list path) (g : list Entropy -> Rbar) :
  nondup Δ ->
  nondup Δ' ->
  length Δ = length Δ' ->
  integrate (g ∘ apply_paths Δ) μentropy = integrate (g ∘ apply_paths Δ') μentropy.
Proof.
  intros.
  rewrite 2 integrate_by_entropies_unfold; try assumption.
  rewrite H1.
  reflexivity.
Qed.

Inductive FTF :=
| Leaf (l : path)
| Node (tL tR : FTF)
.

Infix ";;" := Node (at level 60, right associativity).

Fixpoint vars_of (f : FTF) : list path :=
  match f with
  | Leaf l => [l]
  | Node tL tR => vars_of tL ++ vars_of tR
  end.

Fixpoint apply_FTF (f : FTF) (σ : Entropy) : Entropy :=
  match f with
  | Leaf l => apply_path l σ
  | fL ;; fR => apply_FTF fL σ # apply_FTF fR σ
  end.

Fixpoint ftf_as_fn_of_vars (f : FTF) (σs : list Entropy) : Entropy :=
  match f with
  | Leaf l => match σs with
              | [σ] => σ
              | _ => dummy_entropy
              end
  | f0 ;; f1 =>
    (ftf_as_fn_of_vars f0 (firstn (length (vars_of f0)) σs))
      # (ftf_as_fn_of_vars f1 (skipn (length (vars_of f0)) σs))
  end.

Lemma apply_paths_app l0 l1 σ :
  apply_paths (l0 ++ l1) σ = apply_paths l0 σ ++ apply_paths l1 σ.
Proof.
  apply map_app.
Qed.

Lemma firstn_app_3 {X} n (l0 l1 : list X) :
  length l0 = n ->
  firstn n (l0 ++ l1) = l0.
Proof.
  intros.
  subst.
  replace (length l0) with (length l0 + O) by omega.
  rewrite firstn_app_2.
  cbn.
  apply app_nil_r.
Qed.

Lemma skipn_app {X} n (l0 l1 : list X) :
  length l0 = n ->
  skipn n (l0 ++ l1) = l1.
Proof.
  intros; subst.
  induction l0; auto.
Qed.

Lemma ftf_as_fn_of_vars_correct f :
  apply_FTF f =
  ftf_as_fn_of_vars f ∘ apply_paths (vars_of f).
Proof.
  induction f; intros; auto.
  extensionality σ.
  cbn.
  rewrite apply_paths_app.
  rewrite firstn_app_3; [| apply map_length].
  rewrite skipn_app; [| apply map_length].
  rewrite IHf1, IHf2.
  reflexivity.
Qed.

Definition nondup_ftf (f : FTF) := nondup (vars_of f).
Arguments nondup_ftf / !_.

Definition μentropy_preserving (f : FTF) :=
  forall g,
    integrate (g ∘ apply_FTF f) μentropy = integrate g μentropy.

Definition comm_FTF : FTF :=
  Leaf [R] ;; Leaf [L].
Definition let_comm_FTF : FTF :=
  Leaf [R; L] ;; Leaf [L] ;; Leaf [R; R].
Definition assoc_l_FTF : FTF :=
  (Leaf [L] ;; Leaf [R; L]) ;; Leaf [R; R].
Definition assoc_r_FTF : FTF :=
  Leaf [L; L] ;; Leaf [L; R] ;; Leaf [R].
Definition πR_FTF : FTF := Leaf [R].

Definition running_examples := [comm_FTF; let_comm_FTF; assoc_l_FTF; assoc_r_FTF; πR_FTF].

Lemma examples_nondup : Forall nondup_ftf running_examples.
Proof.
  show_nondup.
Qed.

Lemma integrate_by_entropies_nest g n n' :
  integrate_by_entropies g (n + n') =
  integrate_by_entropies
    (fun l =>
       integrate_by_entropies
         (fun l' => g (l ++ l')) n') n.
Proof.
  revert g.
  induction n; intros; cbn; auto.
  integrand_extensionality σ.
  apply IHn.
Qed.

Lemma integrate_by_entropies_n_ext f g n :
  (forall l, length l = n -> f l = g l) ->
  integrate_by_entropies f n = integrate_by_entropies g n.
Proof.
  revert f g.
  induction n; intros. {
    intros.
    cbn.
    rewrite H; auto.
  } {
    intros.
    cbn.
    integrand_extensionality σ.
    apply IHn.
    intros.
    apply H.
    subst.
    auto.
  }
Qed.

Lemma compose_assoc {A B C D} (f : A -> B) (g : B -> C) (h : C -> D) :
  h ∘ (g ∘ f) = (h ∘ g) ∘ f.
Proof.
  reflexivity.
Qed.

Lemma nondup_preserving f : nondup_ftf f -> μentropy_preserving f.
Proof.
  repeat intro.

  rewrite ftf_as_fn_of_vars_correct.
  rewrite compose_assoc.
  rewrite integrate_by_entropies_unfold; auto.

  revert g.
  induction f; cbn; intros. {
    reflexivity.
  } {
    unfold compose.
    rewrite app_length.
    rewrite integrate_by_entropies_nest.

    transitivity (
        integrate_by_entropies
          (fun σsL =>
             integrate_by_entropies
               (fun σsR =>
                  g ((ftf_as_fn_of_vars f1 σsL)
                       # (ftf_as_fn_of_vars f2 σsR)))
               (length (vars_of f2)))
          (length (vars_of f1))).
    {
      apply integrate_by_entropies_n_ext; intros.
      apply integrate_by_entropies_n_ext; intros.
      rewrite firstn_app_3; auto.
      rewrite skipn_app; auto.
    }

    simpl in H.
    apply nondup_app in H.
    intuition idtac.

    transitivity (integrate_by_entropies
                    (fun σsL =>
                       integrate
                         (fun σR =>
                            g (ftf_as_fn_of_vars f1 σsL # σR))
                         μentropy)
                    (length (vars_of f1))).
    {
      apply integrate_by_entropies_n_ext; intros.
      apply (H3 (fun σR => g (_ # σR))).
    }
    setoid_rewrite (H1 (fun σL => integrate (fun σR => g (σL # σR)) _)).
    rewrite split_entropy'.
    setoid_rewrite interpolate_join.
    reflexivity.
  }
Qed.

Lemma examples_preserving : Forall μentropy_preserving running_examples.
Proof.
  exact (Forall_impl _ nondup_preserving examples_nondup).
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* (C) Pierre Castéran , LaBRI, Universite Bordeaux 1,
                     Inria Futurs
Dictionaries (after Paulson : ML for the working programmer) *)

Require Import Relations.
Require Import List.

Set Asymmetric Patterns.
Unset Standard Proposition Elimination Names.

(* Dictionaries : a dictionary is roughly a partial maping from
   keys to values  *)

Module Type DICT.
 Parameter key : Set.
 Parameter data : Set. (* data associated with keys *)
 Parameter dict : Set. (* the type associated with dictionaries *)
 Parameter empty : dict. (* dictionary without any entry *)
 Parameter add : key -> data -> dict -> dict. (* add an entry to a dictionary *)
 Parameter find : key -> dict -> option data. (* get the value from the key  *)

 (* relationships between find, add and empty *)

 Axiom empty_def : forall k : key, find k empty = None.
 Axiom
   success :
     forall (d : dict) (k : key) (v : data), find k (add k v d) = Some v.
 Axiom
   diff_key :
     forall (d : dict) (k k' : key) (v : data),
     k <> k' -> find k (add k' v d) = find k d.
End DICT.

(* building a dictionary from a list of entries *)
Module Type DICT_PLUS.
 Declare Module Dict : DICT.
 Parameter build : list (Dict.key * Dict.data) -> Dict.dict.
End DICT_PLUS.

Module Dict_Plus (D: DICT) : DICT_PLUS with Module Dict := D.
 Module Dict := D.
 Definition key := D.key.
 Definition data := D.data.
 Definition dict := D.dict.
 Definition add := D.add.
 Definition empty := D.empty.

 Fixpoint addlist (l : list (key * data)) : dict -> dict :=
   fun d : dict =>
   match l with
   | nil => d
   | p :: l' => match p with
                | (k, v) => addlist l' (add k v d)
                end
   end.

 Definition build (l : list (key * data)) := addlist l empty.
End Dict_Plus.

(* keys for dictionaries
   We just need a data type on which Leibniz equality is decidable
*)

Module Type KEY.
 Parameter A : Set.
 Parameter eqdec : forall a b : A, {a = b} + {a <> b}.
End KEY.

Module LKey (K: KEY) : KEY with Definition A := list K.A.
 Definition A := list K.A.

 Definition eqdec : forall a b : A, {a = b} + {a <> b}.
  intro a; elim a.
  simple induction b; [ left; auto | right; red in |- *; discriminate 1 ].
  intros a0 k Ha; simple induction b.
  right; red in |- *; discriminate 1.
  intros a1 l0 s; case (K.eqdec a0 a1); intro H0.
  case (Ha l0); intro H1.
  left; rewrite H1; rewrite H0; auto.
  right; red in |- *; injection 1.
  intro H3; case (H1 H3).
  right; red in |- *; injection 1.
  intros H3 H4; case (H0 H4).
 Defined.
End LKey.

Require Import ZArith.
Module ZKey : KEY with Definition A := Z.
  Definition A := Z.
  Definition eqdec := Z_eq_dec.
End ZKey.

Module LZKey := LKey ZKey.

(*
Check (LZKey.eqdec (cons `7` (nil ?)) (cons `3+4` (nil ?))).
*)

(* pairs of keys *)

Module PairKey (K1: KEY) (K2: KEY) : KEY with Definition
  A := (K1.A * K2.A)%type.
 Definition A := (K1.A * K2.A)%type.

 Definition eqdec : forall a b : A, {a = b} + {a <> b}.
    simple destruct a.
    intros a0 a1; simple destruct b; intros b0 b1.
    case (K1.eqdec a0 b0); intro H; case (K2.eqdec a1 b1); intro H0;
     [ left | right | right | right ]; try (rewrite H; rewrite H0; trivial);
     red in |- *; intro H1; injection H1; tauto.
 Defined.
End PairKey.

(* Total decidable orders *)

Module Type DEC_ORDER.
 Parameter A : Set.
 Parameter le : A -> A -> Prop.
 Parameter lt : A -> A -> Prop.
 Axiom ordered : order A le.
 Axiom lt_le_weak : forall a b : A, lt a b -> le a b.
 Axiom lt_diff : forall a b : A, lt a b -> a <> b.
 Axiom le_lt_or_eq : forall a b : A, le a b -> lt a b \/ a = b.
 Parameter lt_eq_lt_dec : forall a b : A, {lt a b} + {a = b} + {lt b a}.
End DEC_ORDER.

(* some derived theorems on dec_orders *)

Module Type MORE_DEC_ORDERS.
  Parameter A : Set.
  Parameter le : A -> A -> Prop.
  Parameter lt : A -> A -> Prop.
  Axiom le_trans : transitive A le.
  Axiom le_refl : reflexive A le.
  Axiom le_antisym : antisymmetric A le.
  Axiom lt_irreflexive : forall a : A, ~ lt a a.
  Axiom lt_trans : transitive A lt.
  Axiom lt_not_le : forall a b : A, lt a b -> ~ le b a.
  Axiom le_not_lt : forall a b : A, le a b -> ~ lt b a.
  Axiom lt_intro : forall a b : A, le a b -> a <> b -> lt a b.
  Parameter le_lt_dec : forall a b : A, {le a b} + {lt b a}.
  Parameter le_lt_eq_dec : forall a b : A, le a b -> {lt a b} + {a = b}.
End MORE_DEC_ORDERS.

(* A functor for getting some useful derived properties on decidable
   orders *)

Module More_Dec_Orders (D: DEC_ORDER) : MORE_DEC_ORDERS with Definition
  A := D.A with Definition le := D.le with Definition lt := D.lt.

 Definition A := D.A.
 Definition le := D.le.
 Definition lt := D.lt.

 Theorem le_trans : transitive A le.
 Proof.
   case D.ordered; auto.
 Qed.

 Theorem le_refl : reflexive A le.
  Proof.
   case D.ordered; auto.
 Qed.

 Theorem le_antisym : antisymmetric A le.
 Proof.
   case D.ordered; auto.
 Qed.

 Theorem lt_intro : forall a b : A, le a b -> a <> b -> lt a b.
 Proof.
   intros a b H diff; case (D.le_lt_or_eq a b H); tauto.
 Qed.

 Theorem lt_irreflexive : forall a : A, ~ lt a a.
 Proof.
  intros a H.
  case (D.lt_diff _ _ H); trivial.
 Qed.

 Theorem lt_not_le : forall a b : A, lt a b -> ~ le b a.
 Proof.
  intros a b H H0.
  absurd (a = b).
  apply D.lt_diff; trivial.
  apply le_antisym; auto; apply D.lt_le_weak; assumption.
 Qed.

 Theorem le_not_lt : forall a b : A, le a b -> ~ lt b a.
 Proof.
   intros a b H H0; apply (lt_not_le b a); auto.
  Qed.

  Theorem lt_trans : transitive A lt.
  Proof.
   unfold A, transitive in |- *.
   intros x y z H H0.
   apply (lt_intro x z).
   apply le_trans with y; apply D.lt_le_weak; assumption.
   intro e; rewrite e in H.
   absurd (y = z).
   intro e'; rewrite e' in H.
   apply (lt_irreflexive _ H).
   apply le_antisym; apply D.lt_le_weak; trivial.
  Qed.

  Definition le_lt_dec : forall a b : A, {le a b} + {lt b a}.
   intros a b; case (D.lt_eq_lt_dec a b).
   intro d; case d; auto.
   left; apply D.lt_le_weak; trivial.
   simple induction 1; left; apply le_refl.
   right; trivial.
  Defined.

  Definition le_lt_eq_dec : forall a b : A, le a b -> {lt a b} + {a = b}.
   intros a b H.
   case (D.lt_eq_lt_dec a b).
   trivial.
   intro H0; case (le_not_lt a b H H0).
  Defined.

End More_Dec_Orders.

(* the forgetful functor ! *)
Module Forget_Order (D: DEC_ORDER) : KEY with Definition A := D.A.

 Module M := More_Dec_Orders D.

 Definition A := D.A.

 Definition eqdec : forall a b : A, {a = b} + {a <> b}.
  intros a b; case (D.lt_eq_lt_dec a b).
  intro H; case H.
  right; apply D.lt_diff; auto.
  left; trivial.
  intro d; right.
  intro e; rewrite e in d.
  apply (M.lt_irreflexive b); auto.
 Defined.
End Forget_Order.

(* Lexicographic ordering *)

Module Lexico (D1: DEC_ORDER) (D2: DEC_ORDER) <: DEC_ORDER with Definition
  A := (D1.A * D2.A)%type.

 Module M1 := More_Dec_Orders D1.
 Module M2 := More_Dec_Orders D2.

 Definition A := (D1.A * D2.A)%type.

 Definition le (a b : A) : Prop :=
   let (a1, a2) := a in
   let (b1, b2) := b in D1.lt a1 b1 \/ a1 = b1 /\ D2.le a2 b2.

 Definition lt (a b : A) : Prop :=
   let (a1, a2) := a in
   let (b1, b2) := b in D1.lt a1 b1 \/ a1 = b1 /\ D2.lt a2 b2.

 Theorem ordered : order A le.
 Proof.
  split.
  unfold reflexive in |- *; intros.
  unfold le in |- *; case x.
  right.
  split; [ trivial | apply M2.le_refl; auto ].
  unfold le, transitive in |- *.
  simple destruct x; simple destruct y; simple destruct z.
  simple destruct 1; intro H1.
  simple destruct 1.
  left.
  eapply M1.lt_trans.
  eexact H1.
  assumption.
  simple destruct 1.
  simple destruct 1.
  auto.
  simple destruct 1.
  intro.
  case H1; intros e H3; rewrite e; auto.
  case H1; intros e H3; rewrite e; auto.
  simple destruct 1.
  simple destruct 1.
  right.
  split; try auto.
  eapply M2.le_trans; eauto.
  unfold antisymmetric, A, le in |- *.
  simple destruct x; simple destruct y.
  simple destruct 1; simple destruct 2.
  intro.
  absurd (D1.lt a1 a1).
  apply M1.lt_irreflexive.
  eapply M1.lt_trans; eauto.
  simple destruct 1; intros e H3.
  rewrite e in H0.
  case (M1.lt_irreflexive a H0).
  case H0; intros e H3.
  rewrite e; intro H2.
  case (M1.lt_irreflexive a1 H2).
  simple destruct 1; intros e H3; rewrite e.
  case (M2.le_antisym a2 a0).
  auto.
  case H0; auto.
  auto.
 Qed.

 Theorem lt_le_weak : forall a b : A, lt a b -> le a b.
 Proof.
  unfold A, lt, le in |- *; intros a b; case a; case b.
  simple destruct 1; intros; auto.
  right; case H0; split; auto.
  apply D2.lt_le_weak; trivial.
 Qed.

 Theorem lt_diff : forall a b : A, lt a b -> a <> b.
 Proof.
  unfold A, lt, le in |- *; intros a b; case a; case b.
  simple destruct 1.
  intro H0; red in |- *; injection 1.
  intros e1 e2; rewrite e2 in H0.
  case (M1.lt_irreflexive a0 H0).
  simple destruct 1.
  simple destruct 1.
  intro H2; red in |- *; injection 1.
  intro e; rewrite e in H2; case (M2.lt_irreflexive _ H2).
 Qed.

 Theorem le_lt_or_eq : forall a b : A, le a b -> lt a b \/ a = b.
 Proof.
  unfold A, lt, le in |- *; intros a b; case a; case b.
  simple destruct 1; auto.
  simple destruct 1.
  simple destruct 1.
  intro H2; case (D2.le_lt_or_eq _ _ H2).
  auto.
  simple destruct 1.
  auto.
 Qed.

 Definition lt_eq_lt_dec : forall a b : A, {lt a b} + {a = b} + {lt b a}.
  Proof.
   unfold A, lt in |- *; intros.
   case a; case b.
   intros a0 a1 a2 a3.
   case (D1.lt_eq_lt_dec a0 a2).
   simple destruct 1.
   right.
   auto.
   simple destruct 1.
   case (D2.lt_eq_lt_dec a1 a3).
   simple destruct 1.
   right.
   auto.
   simple destruct 1.
   left; right; trivial.
   left; left; auto.
   left.
   left; auto.
  Defined.
End Lexico.

(* order on disjoint sums *)

Module Sum_Order (O1: DEC_ORDER) (O2: DEC_ORDER) <: DEC_ORDER with Definition
  A := (O1.A + O2.A)%type.

 Definition A := (O1.A + O2.A)%type.

 Definition le (a b : A) : Prop :=
   match a with
   | inl a' => match b with
               | inl b' => O1.le a' b'
               | _ => True
               end
   | inr a' => match b with
               | inr b' => O2.le a' b'
               | _ => False
               end
   end.

  Definition lt (a b : A) : Prop :=
    match a with
    | inl a' => match b with
                | inl b' => O1.lt a' b'
                | _ => True
                end
    | inr a' => match b with
                | inr b' => O2.lt a' b'
                | _ => False
                end
    end.

 Module M1 := More_Dec_Orders O1.
 Module M2 := More_Dec_Orders O2.

 Theorem ordered : order A le.
 Proof.
  split.
  unfold reflexive in |- *; intros.
  unfold le in |- *.
  case x.
  exact M1.le_refl.
  exact M2.le_refl.
  unfold le in |- *.
  unfold transitive in |- *.
  simple destruct x; simple destruct y; simple destruct z.
  intros; eapply M1.le_trans; eauto.
  auto.
  contradiction.
  auto.
  auto.
  contradiction.
  auto.
  intros; eapply M2.le_trans; eauto.
  unfold antisymmetric, A, le in |- *.
  simple destruct x; simple destruct y.
  intros a0 H0 H1; rewrite (M1.le_antisym _ _ H0 H1).
  trivial.
  contradiction.
  contradiction.
  intros a0 H0 H1; rewrite (M2.le_antisym _ _ H0 H1).
  trivial.
 Qed.

 Theorem lt_le_weak : forall a b : A, lt a b -> le a b.
 Proof.
   unfold A, lt, le in |- *; intros a b.
   case a; case b; auto.
   intros; apply O1.lt_le_weak; trivial.
   intros; apply O2.lt_le_weak; trivial.
 Qed.

 Theorem lt_diff : forall a b : A, lt a b -> a <> b.
 Proof.
    unfold lt in |- *; simple destruct a; simple destruct b.
    intros a1 H e; injection e; intro e'.
    case (O1.lt_diff _ _ H e').
    intros a1 H e; discriminate e.
    contradiction.
    intros a1 H e; injection e; intro e'.
    case (O2.lt_diff _ _ H e').
 Qed.

 Theorem le_lt_or_eq : forall a b : A, le a b -> lt a b \/ a = b.
 Proof.
   unfold A, lt, le in |- *; intros a b; case a; case b.
   intros a0 a1 H; case (O1.le_lt_or_eq a1 a0 H).
   auto.
   simple destruct 1; auto.
   auto.
   contradiction.
   intros a0 a1 H; case (O2.le_lt_or_eq a1 a0 H); auto.
   simple destruct 1; auto.
 Qed.

 Definition lt_eq_lt_dec : forall a b : A, {lt a b} + {a = b} + {lt b a}.
  unfold A, lt in |- *; intros.
  case a; case b.
  intros a0 a1.
  case (O1.lt_eq_lt_dec a0 a1).
  simple destruct 1.
  right.
  auto.
  simple destruct 1.
  left.
  right.
  trivial.
  left.
  left.
  trivial.
  left; trivial.
  left; trivial.
  right.
  auto.
  intros a0 a1.
  case (O2.lt_eq_lt_dec a0 a1).
  simple destruct 1.
  right.
  auto.
  simple destruct 1.
  left.
  right.
  trivial.
  left.
  left.
  trivial.
 Defined.

End Sum_Order.

Require Import Arith.

Module Nat_Order : DEC_ORDER with Definition A := nat with Definition
  le := le with Definition lt := lt.
  Definition A := nat.
  Definition le := le.
  Definition lt := lt.
  Theorem ordered : order A le.
  Proof.
    split.
    unfold A, le, reflexive in |- *; auto with arith.
    unfold A, le, transitive in |- *; eauto with arith.
    unfold A, le, antisymmetric in |- *; eauto with arith.
  Qed.

  Theorem lt_le_weak : forall a b : A, lt a b -> le a b.
  Proof.
   unfold A in |- *; exact lt_le_weak.
  Qed.

  Theorem lt_diff : forall a b : A, lt a b -> a <> b.
  Proof.
   unfold A, lt, le in |- *; intros a b H e.
   rewrite e in H.
   case (lt_irrefl b H).
  Qed.

  Theorem le_lt_or_eq : forall a b : A, le a b -> lt a b \/ a = b.
  Proof.
   unfold A, le, lt in |- *.
   exact le_lt_or_eq.
  Qed.

  Definition lt_eq_lt_dec : forall a b : A, {lt a b} + {a = b} + {lt b a} :=
    lt_eq_lt_dec.

End Nat_Order.

 (* the natural order on booleans ( false < true ) *)

 Definition bool_le (b b' : bool) :=
   if b then if b' then True else False else True.
 Definition bool_lt (b b' : bool) :=
   if b then False else if b' then True else False.

 Module Bool_Order : DEC_ORDER with Definition A := bool with Definition
   le := bool_le with Definition lt := bool_lt.
  Definition A := bool.
  Definition le := bool_le.
  Definition lt := bool_lt.

  Theorem ordered : order A le.
  Proof.
    split.
    unfold A, le, reflexive in |- *.
    intro x; case x; simpl in |- *; auto.
    unfold A, le, transitive in |- *; simple destruct x; simple destruct y;
     auto; simple destruct z; auto.
    unfold A, le, antisymmetric in |- *; simple destruct x; simple destruct y;
     simpl in |- *; auto; contradiction.
  Qed.

  Theorem lt_le_weak : forall a b : A, lt a b -> le a b.
  Proof.
   unfold A, lt, le in |- *; simple destruct a; simple destruct b;
    simpl in |- *; tauto.
  Qed.

  Theorem lt_diff : forall a b : A, lt a b -> a <> b.
  Proof.
    unfold A, lt, bool_lt in |- *; simple destruct a; simple destruct b; auto.
  Qed.

  Theorem le_lt_or_eq : forall a b : A, le a b -> lt a b \/ a = b.
  Proof.
   unfold A, le, lt, bool_lt in |- *; simple destruct a; simple destruct b;
    auto.
  Qed.

 Definition lt_eq_lt_dec : forall a b : A, {lt a b} + {a = b} + {lt b a}.
    unfold A, le, lt, bool_lt in |- *; simple destruct a; simple destruct b;
     auto.
 Defined.
End Bool_Order.

(* This module type specifies the domain of values returned by
   consulting a dictionary ; it is supposed to be an argument of
   any functor building an implementation for dictionaries *)

Module Type DATA.
 Parameter data : Set.
End DATA.

(* A simple implementation of dictionaries :
   the dictionary IS the (partial) function from keys to values
   This implementation is clearly inefficient, but since it is
   trivially correct ; during the building  of a modular program,
   such trivial correct implementations of module types  may be
   very useful during the development steps of an application  *)

Module TrivialDict (Key: KEY) (Val: DATA) : DICT with Definition key := Key.A
  with Definition data := Val.data.
 Definition key := Key.A.
 Definition data := Val.data.
 Definition dict := key -> option data.

 Definition empty (k : key) := None (A:=data).
 Definition find (k : key) (d : dict) := d k.
 Definition add (k : key) (v : data) (d : dict) : dict :=
   fun k' : key =>
   match Key.eqdec k' k with
   | left _ => Some v
   | right _ => d k'
   end.

 Theorem empty_def : forall k : key, find k empty = None.
 Proof.
  unfold find, empty in |- *; auto.
 Qed.

 Theorem success :
  forall (d : dict) (k : key) (v : data), find k (add k v d) = Some v.
 Proof.
  unfold find, add in |- *; intros d k v.
  case (Key.eqdec k k); simpl in |- *; tauto.
 Qed.

 Theorem diff_key :
  forall (d : dict) (k k' : key) (v : data),
  k <> k' -> find k (add k' v d) = find k d.
 Proof.
  unfold find, add in |- *; intros d k k' v.
  case (Key.eqdec k k'); simpl in |- *; tauto.
 Qed.

End TrivialDict.

(* dictionaries based on searchtrees
we require a total decidable order on keys *)

Module TDict (Key: DEC_ORDER) (Val: DATA) : DICT with Definition key := Key.A
  with Definition data := Val.data.
 Definition key := Key.A.
 Definition data := Val.data.

 Module M := More_Dec_Orders Key.

 (* search trees definitions and properties *)

 (* the underlying data structure : binary trees labeled
    with keys and associated values *)

 Inductive btree : Set :=
   | leaf : btree
   | bnode : key -> data -> btree -> btree -> btree.

 (* The entry with key k and value v occurs in the binary tree t *)

 Inductive occ (v : data) (k : key) : btree -> Prop :=
   | occ_root : forall t1 t2 : btree, occ v k (bnode k v t1 t2)
   | occ_l :
       forall (k' : key) (v' : data) (t1 t2 : btree),
       occ v k t1 -> occ v k (bnode k' v' t1 t2)
   | occ_r :
       forall (k' : key) (v' : data) (t1 t2 : btree),
       occ v k t2 -> occ v k (bnode k' v' t1 t2).

(*  key k is less than every key in t  *)
 Inductive min (k : key) (t : btree) : Prop :=
     min_intro :
       (forall (k' : key) (v : data), occ v k' t -> Key.lt k k') -> min k t.

 Hint Resolve min_intro: searchtrees.

(*  key k is gretaer than every key in t  *)
 Inductive maj (k : key) (t : btree) : Prop :=
     maj_intro :
       (forall (k' : key) (v : data), occ v k' t -> Key.lt k' k) -> maj k t.

 Hint Resolve maj_intro: searchtrees.

(* searchness predicate on binary trees *)
 Inductive search_tree : btree -> Prop :=
   | leaf_search_tree : search_tree leaf
   | bnode_search_tree :
       forall (k : key) (v : data) (t1 t2 : btree),
       search_tree t1 ->
       search_tree t2 ->
       maj k t1 -> min k t2 -> search_tree (bnode k v t1 t2).

 Inductive is_bnode : btree -> Prop :=
     is_bnode_intro :
       forall (k : key) (v : data) (t1 t2 : btree),
       is_bnode (bnode k v t1 t2).

 Hint Resolve is_bnode_intro: searchtrees.

 Hint Resolve occ_root occ_l occ_r: searchtrees.

 Derive Inversion_clear OCC_INV with
  (forall (k k' : key) (v v' : data) (t1 t2 : btree),
   occ v' k' (bnode k v t1 t2)).

 Lemma occ_inv :
  forall (k k' : key) (v v' : data) (t1 t2 : btree),
  occ v' k' (bnode k v t1 t2) ->
  k = k' /\ v = v' \/ occ v' k' t1 \/ occ v' k' t2.
 Proof.
  intros k k' v v' t1 t2 H.
  inversion H using OCC_INV; auto with searchtrees.
 Qed.

 Hint Resolve occ_inv: searchtrees.

 Lemma not_occ_Leaf : forall (k : key) (v : data), ~ occ v k leaf.
 Proof.
  unfold not in |- *; intros k v H.
  inversion_clear H.
 Qed.

 Hint Resolve not_occ_Leaf: searchtrees.

 Hint Resolve leaf_search_tree bnode_search_tree: searchtrees.

 Lemma min_leaf : forall k : key, min k leaf.
 Proof.
  intro k; apply min_intro.
  inversion_clear 1.
 Qed.

 Hint Resolve min_leaf: searchtrees.

 Lemma maj_leaf : forall k : key, maj k leaf.
 Proof.
  intro k; apply maj_intro; inversion_clear 1.
 Qed.

 Hint Resolve maj_leaf: searchtrees.

 Lemma maj_not_occ :
  forall (k : key) (v : data) (t : btree), maj k t -> ~ occ v k t.
 Proof.
  unfold not in |- *; intros k v t H H'.
  elim H; intros; absurd (Key.lt k k); auto.
  apply M.lt_irreflexive.
  eauto.
 Qed.

 Hint Resolve maj_not_occ: searchtrees.

 Lemma min_not_occ :
  forall (k : key) (v : data) (t : btree), min k t -> ~ occ v k t.
 Proof.
  unfold not in |- *; intros k v t H H'.
  elim H; intros; absurd (Key.lt k k); eauto.
  apply M.lt_irreflexive.
 Qed.

 Hint Resolve min_not_occ: searchtrees.

(* technical lemmas about some non-leaf search tree *)

 Section search_tree_basic_properties.

 Variables (n : key) (v : data) (t1 t2 : btree).

 Hypothesis se : search_tree (bnode n v t1 t2).

 Lemma search_tree_l : search_tree t1.
 Proof.
  inversion_clear se; auto with searchtrees.
 Qed.

 Hint Resolve search_tree_l: searchtrees.

 Lemma search_tree_r : search_tree t2.
 Proof.
  inversion_clear se; auto with searchtrees.
 Qed.
 Hint Resolve search_tree_r: searchtrees.

 Lemma maj_l : maj n t1.
 Proof.
  inversion_clear se; auto with searchtrees.
 Qed.
 Hint Resolve maj_l: searchtrees.

 Lemma min_r : min n t2.
 Proof.
  inversion_clear se; auto with searchtrees.
 Qed.

 Hint Resolve min_r: searchtrees.

 Lemma not_right : forall (p : key) (v' : data), Key.le p n -> ~ occ v' p t2.
 Proof.
  intros p v' H; elim min_r.
  unfold not in |- *; intros; absurd (Key.lt n p); eauto with searchtrees.
  apply M.le_not_lt; assumption.
 Qed.

 Hint Resolve not_right: searchtrees.

 Lemma not_left : forall (p : key) (v' : data), Key.le n p -> ~ occ v' p t1.
 Proof.
  intros p v' H; elim maj_l.
  unfold not in |- *; intros; absurd (Key.lt p n); eauto with searchtrees.
  apply M.le_not_lt; assumption.
 Qed.

 Hint Resolve not_left: searchtrees.

 Lemma go_left :
  forall (p : key) (v' : data),
  occ v' p (bnode n v t1 t2) -> Key.lt p n -> occ v' p t1.
 Proof.
  intros p v' H H0.
  case (occ_inv _ _ _ _ _ _ H).
  repeat simple destruct 1; absurd (Key.lt p n).
  rewrite H2; apply M.lt_irreflexive.
  assumption.
  simple destruct 1; trivial.
  intro H2; absurd (occ v' p t2).
  apply not_right.
  apply Key.lt_le_weak; assumption.
  auto.
 Qed.

 Lemma go_right :
  forall (p : key) (v' : data),
  occ v' p (bnode n v t1 t2) -> Key.lt n p -> occ v' p t2.
 Proof.
  intros p v' H H0.
  case (occ_inv _ _ _ _ _ _ H).
  repeat simple destruct 1; absurd (Key.lt n p).
  rewrite H2; apply M.lt_irreflexive.
  assumption.
  simple destruct 1; trivial.
  intro H2; absurd (occ v' p t1).
  apply not_left.
  apply Key.lt_le_weak; assumption.
  auto.
 Qed.

 End search_tree_basic_properties.

 Hint Resolve go_left go_right not_left not_right search_tree_l search_tree_r
   maj_l min_r: searchtrees.

(* each key occurs at most once *)

 Lemma occ_unicity :
  forall t : btree,
  search_tree t ->
  forall (k : key) (v v' : data), occ v k t -> occ v' k t -> v = v'.
 Proof. (* too long, but proofs are irrelevant, are'nt they ? *)
  simple induction t.
  inversion 2.
  intros.
  case (occ_inv _ _ _ _ _ _ H2).
  repeat simple destruct 1.
  case (occ_inv _ _ _ _ _ _ H3).
  tauto.
  simple destruct 1.
  intro.
  absurd (occ v' k0 b); auto.
  eapply not_left.
  eauto.
  rewrite H5; apply M.le_refl.
  intro.
  absurd (occ v' k0 b0); auto.
  eapply not_right; eauto.
  rewrite H5; apply M.le_refl.
  simple destruct 1; intro.
  case (occ_inv _ _ _ _ _ _ H3).
  repeat simple destruct 1.
  absurd (occ v k b); auto.
  eapply not_left; eauto.
  apply M.le_refl.
  rewrite H7; auto.
  simple destruct 1; intro.
  eapply H.
  eauto with searchtrees.
  eauto.
  assumption.
  absurd (occ v' k0 b0); auto.
  eapply not_right; eauto with searchtrees.
  case (maj_l _ _ _ _ H1).
  intro; apply Key.lt_le_weak.
  eauto.
  case (occ_inv _ _ _ _ _ _ H3).
  repeat simple destruct 1.
  absurd (occ v k0 b0); auto.
  case H7.
  eapply not_right; eauto with searchtrees.
  apply M.le_refl.
  simple destruct 1.
  intro.
  absurd (occ v' k0 b); auto.
  eapply not_left; eauto with searchtrees.
  case (min_r _ _ _ _ H1).
  intros.
  apply Key.lt_le_weak.
  eauto.
  intro.
  eapply H0.
  eauto with searchtrees.
  eauto.
  eauto.
 Qed.

(* given a key and a search tree, we return either an associated value
   or the proof of its non-existence *)

 Definition occ_dec_spec (k : key) (t : btree) :=
   search_tree t -> {v : data | occ v k t} + {(forall v : data, ~ occ v k t)}.

 Definition occ_dec : forall (k : key) (t : btree), occ_dec_spec k t.
  intro p; simple induction t.
  right.
  auto with searchtrees.
  intros n v t1 R1 t2 R2 H.
  case (M.le_lt_dec p n).
  intro H0; case (M.le_lt_eq_dec p n H0).
  intro H1; case R1.
  eauto with searchtrees.
  simple destruct 1; intros v' H'.
  left.
  exists v'; eauto with searchtrees.
  right.
  intros v0 H3.
  apply (n0 v0); eauto with searchtrees.
  simple destruct 1; left.
  exists v; eauto with searchtrees.
  intro H2; case R2.
  eauto with searchtrees.
  simple destruct 1; intros v' H'.
  left.
  exists v'; eauto with searchtrees.
  right.
  intros v0 H3.
  apply (n0 v0); eauto with searchtrees.
 Defined.

(* t' is obtained by inserting (n,v) into t *)

 Inductive INSERT (n : key) (v : data) (t t' : btree) : Prop :=
     insert_intro :
       (forall (p : key) (v' : data), occ v' p t -> p = n \/ occ v' p t') ->
       occ v n t' ->
       (forall (p : key) (v' : data),
        occ v' p t' -> occ v' p t \/ n = p /\ v = v') ->
       search_tree t' -> INSERT n v t t'.

 Hint Resolve insert_intro: searchtrees.

 Definition insert_spec (n : key) (v : data) (t : btree) : Set :=
   search_tree t -> {t' : btree | INSERT n v t t'}.

 Lemma insert_leaf :
  forall (n : key) (v : data), INSERT n v leaf (bnode n v leaf leaf).
 Proof.
  intro n; split; auto with searchtrees.
  intros p k H; inversion_clear H; auto with searchtrees.
 Qed.
 Hint Resolve insert_leaf: searchtrees.

(* Inserting in the left son *)

 Lemma insert_l :
  forall (n p : key) (v v' : data) (t1 t'1 t2 : btree),
  Key.lt n p ->
  search_tree (bnode p v' t1 t2) ->
  INSERT n v t1 t'1 -> INSERT n v (bnode p v' t1 t2) (bnode p v' t'1 t2).
 Proof.
  intros n p v v' t1 t'1 t2 H H0 H1; split.
  intros p0 v'0 H2; inversion_clear H2.
  auto with searchtrees.
  case H1; intros.
  case (H2 _ _ H3).
  auto.
  auto with searchtrees.
  auto with searchtrees.
  case H1; intros.
  eauto with searchtrees.
  intros p0 v'0 H2.
  inversion_clear H2.
  auto with searchtrees.
  case H1; intros.
  elim (H5 p0 v'0); auto with searchtrees.
  auto with searchtrees.
  case H1; constructor 2; auto with searchtrees.
  eapply search_tree_r; eauto with searchtrees.
  split; intros.
  elim (H4 _ _ H6).
  intro.
  cut (maj p t1).
  inversion_clear 1; eauto with searchtrees.
  eauto with searchtrees.
  repeat simple destruct 1.
  assumption.
  eauto with searchtrees.
 Qed.

(* inserting in the right son *)

 Lemma insert_r :
  forall (n p : key) (v v' : data) (t1 t2 t'2 : btree),
  Key.lt p n ->
  search_tree (bnode p v' t1 t2) ->
  INSERT n v t2 t'2 -> INSERT n v (bnode p v' t1 t2) (bnode p v' t1 t'2).

 Proof.
  intros n p v v' t1 t2 t'2 H H0 H1; split.
  intros p0 v'0 H2; inversion_clear H2.
  auto with searchtrees.
  auto with searchtrees.
  case H1; intros.
  case (H2 _ _ H3).
  auto.
  auto with searchtrees.
  case H1; intros.
  auto with searchtrees.
  intros p0 v'0 H2.
  inversion_clear H2.
  auto with searchtrees.
  auto with searchtrees.
  case H1; intros.
  elim (H5 p0 v'0 H3); auto with searchtrees.
  case H1; constructor 2; auto with searchtrees.
  eapply search_tree_l; eauto with searchtrees.
  eauto with searchtrees.
  split; intros.
  case (H4 _ _ H6).
  intro.
  cut (min p t2).
  inversion_clear 1; eauto with searchtrees.
  eauto with searchtrees.
  repeat simple destruct 1.
  assumption.
 Qed.

(* inserting at the root ;
  please notice that the most recent value is stored *)

 Lemma insert_eq :
  forall (n : key) (v v' : data) (t1 t2 : btree),
  search_tree (bnode n v t1 t2) ->
  INSERT n v' (bnode n v t1 t2) (bnode n v' t1 t2).
 Proof.
  split.
  inversion 1; eauto with searchtrees.
  eauto with searchtrees.
  inversion 1; eauto with searchtrees.
  inversion H; eauto with searchtrees.
 Qed.

 Hint Resolve insert_l insert_r insert_eq: searchtrees.

 Definition insert :
   forall (n : key) (v : data) (t : btree), insert_spec n v t.
  simple induction t.
  exists (bnode n v leaf leaf).
  auto with searchtrees.
  unfold insert_spec at 3 in |- *; intros p b t1 H1 t2 H2 H0.
  case (M.le_lt_dec n p).
  intro H; case (M.le_lt_eq_dec n p H).
  intro H'.
  case (H1 (search_tree_l _ _ _ _ H0)).
  intros t3; exists (bnode p b t3 t2).
  auto with searchtrees.
  intro e; rewrite e; exists (bnode p v t1 t2); auto with searchtrees.
  case (H2 (search_tree_r _ _ _ _ H0)).
  intros t3; exists (bnode p b t1 t3).
  auto with searchtrees.
 Defined.

(* realisation of the DICT  signature *)

(* dictionaries are represented as  certified binary search trees *)

 Definition dict : Set := sig search_tree.

 Definition empty : dict.
  unfold dict in |- *; exists leaf.
  left.
 Defined.

 Definition find (k : key) (d : dict) : option data :=
   let (t, Ht) := d in
   match occ_dec k t Ht with
   | inleft s => let (v, _) := s in Some v
   | inright _ => None (A:=data)
   end.

 Definition add : key -> data -> dict -> dict.
  refine
   (fun (k : key) (v : data) (d : dict) =>
    let (t, Ht) := d in
    let (x, Hx) := insert k v t Ht in exist search_tree x _).
  case Hx; auto.
 Defined.

  (* Now, we've got to prove the axioms *)

 Definition D_tree (d : dict) : btree := match d with
                                         | exist t Ht => t
                                         end.

 Lemma D_search : forall d : dict, search_tree (D_tree d).
 Proof.
   simple destruct d; simpl in |- *; auto.
 Qed.

 Lemma find_occ_dec :
  forall (k : key) (v : data) (d : dict),
  occ v k (D_tree d) -> find k d = Some v.

 Proof.
  unfold find in |- *; simple destruct d; simpl in |- *; intros.
  case (occ_dec k x s); simpl in |- *.
  simple destruct s0; simpl in |- *.
  intros x0 H0; case (occ_unicity x s _ _ _ H H0).
  auto.
  intros.
  case (n v H).
 Qed.

 Lemma not_find_occ_dec :
  forall (k : key) (d : dict),
  (forall v : data, ~ occ v k (D_tree d)) -> find k d = None.
 Proof.
  unfold find in |- *; simple destruct d; simpl in |- *; intros.
  case (occ_dec k x s); simpl in |- *.
  simple destruct s0; simpl in |- *.
  intros.
  case (H _ o).
  auto.
 Qed.

 Theorem empty_def : forall k : key, find k empty = None.
 Proof.
  unfold find, empty in |- *.
  intro k; case (occ_dec k leaf leaf_search_tree); simpl in |- *.
  simple destruct s.
  inversion 1.
  auto.
 Qed.

 Remark success2 :
  forall (d : dict) (k : key) (v : data), occ v k (D_tree (add k v d)).
 Proof.
  simple destruct d.
  simpl in |- *.
  intros x s k v; case (insert k v x s); simpl in |- *.
  simple destruct 1.
  eauto with searchtrees.
 Qed.

 Theorem success :
  forall (d : dict) (k : key) (v : data), find k (add k v d) = Some v.
 Proof.
  intros; apply find_occ_dec.
  apply success2.
 Qed.

 Remark diff_key1 :
  forall (d : dict) (k k' : key) (v v' : data),
  k <> k' -> occ v k (D_tree (add k' v' d)) -> occ v k (D_tree d).
 Proof.
  simple destruct d.
  simpl in |- *.
  intros x s k k' v v'; case (insert k' v' x s); simpl in |- *.
  simple destruct 1; intros.
  case (H1 _ _ H4).
  auto.
  simple destruct 1; absurd (k' = k); auto.
  case H5; auto.
 Qed.

 Remark diff_key2 :
  forall (d : dict) (k k' : key) (v v' : data),
  k <> k' -> occ v k (D_tree d) -> occ v k (D_tree (add k' v' d)).
 Proof.
  simple destruct d; simpl in |- *.
  intros x s k k' v v'; case (insert k' v' x s); simpl in |- *.
  simple destruct 1; intros.
  case (H _ _ H4).
  intro H5; case (H3 H5).
  auto.
 Qed.

 Theorem diff_key :
  forall (d : dict) (k k' : key) (v : data),
  k <> k' -> find k (add k' v d) = find k d.
 Proof.
  intros.
  case (occ_dec k (D_tree d)).
  apply D_search.
  simple destruct 1.
  intros x Hx.
  transitivity (Some x).
  apply find_occ_dec.
  apply diff_key2; auto.
  symmetry  in |- *; apply find_occ_dec; auto.
  intro; transitivity (None (A:=data)).
  apply not_find_occ_dec.
  intros v0 H0.
  apply (n v0).
  eapply diff_key1; eauto.
  symmetry  in |- *; apply not_find_occ_dec.
  auto.
 Qed.

End TDict.

(* Examples *)

Module BoolNat := Lexico Bool_Order Nat_Order.

Module MoreBoolNat := More_Dec_Orders BoolNat.

Module Nats <: DATA.
 Definition data := list nat.
End Nats.

Module NaiveDict := TrivialDict LZKey Nats.

Module MyDict : DICT := TDict BoolNat Nats.

Module Dict2 := Dict_Plus MyDict.

Module Dict1 := Dict_Plus NaiveDict.

(*
To get Ocaml code :

unix: coqc dict.

unix : coqtop

Coq < Require dict.
Coq < Recursive Extraction Library dict.

*)


Require Import HahnBase.
Require Import List.
Require Import Utf8.

Module Type Domains.
  Parameter Var: Type.
  Parameter Val: Type.
  Parameter val_plus: Val -> Val -> Val.
  Parameter val_unit : Val.

  Parameter var_eq_dec : forall x y: Var, { x = y } + { x <> y }.
  Parameter val_eq_dec : forall x y: Val, { x = y } + { x <> y }.
  Parameter val_inf : forall xs: list Val, exists v: Val, ~ In v xs.

  Lemma val_pair_eq_dec :
    forall x y : Val * Val, {x = y} + {x <> y}.
  Proof.
    decide equality; apply val_eq_dec.
  Qed.
End Domains.

Definition update {A B} (eq_dec: forall x y: A, { x = y } + { x <> y })(f: A -> B)(x: A)(v: B): A -> B :=
  fun y: A => if eq_dec x y then v else f y.

Definition disjoint {A} (X Y : A -> Prop) :=
  forall x, X x -> Y x -> False.

Definition disjoint_list {A} (xl yl : list A) :=
  forall x (IN1 : In x xl) (IN2 : In x yl), False.

Definition pred_of_list {A} (l : list A) (x : A) := In x l.

Coercion pred_of_list : list >-> Funclass.

Lemma disjoint_conv :
  forall A (l1 l2 : list A),
  disjoint l1 l2 -> disjoint_list l1 l2.
Proof.
  done.
Qed.

Lemma option_not_none {T} :
  forall x : option T,
  ~ x = None <-> exists v, x = Some v.
Proof.
  intros x. split; intro H1.
  - intuition. destruct x; vauto.
  - intro. desf.
Qed.

Lemma list_forall_notin {T} :
  forall xs: list T, (forall x, ~ In x xs) -> xs = nil.
Proof.
  induction xs; intros H1; auto.
  assert (H2: forall x: T, ~ In x xs). {
    intros x H2. apply H1 with x.
    simpl. by right. }
  apply IHxs in H2. vauto.
  simpl in H1. specialize H1 with a.
  apply not_or_and in H1. desf.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    Proof of Huffman algorithm: OrderedCover.v

    Definition of ordered cover and some properties

    Definition: ordered_cover

                                    Laurent.Thery@inria.fr (2003)
  **********************************************************************)

From Huffman Require Export Cover.

Section OrderedCover.
Variable A : Type.

(*
  An ordered cover is a cover where the positions of the elements in
  the list are fixed
*)
Inductive ordered_cover : list (btree A) -> btree A -> Prop :=
  | ordered_cover_one :
      forall (t : btree A) (l : list (btree A)), ordered_cover (t :: nil) t
  | ordered_cover_node :
      forall (t1 t2 : btree A) (l1 l2 l3 : list (btree A)),
      ordered_cover l1 t1 ->
      ordered_cover l2 t2 -> ordered_cover (l1 ++ l2) (node t1 t2).
Hint Resolve ordered_cover_one ordered_cover_node : core.

(* Ordered covers are special cases of covers *)
Theorem ordered_cover_cover :
 forall (l : list (btree A)) (t : btree A), ordered_cover l t -> cover l t.
intros l t H; elim H; auto.
intros t1 t2 l1 l2 l3 H0 H1 H2 H3.
Proof using.
apply cover_app; auto.
Qed.

(* It is always possible to get an ordered cover from a cover *)
Theorem cover_ordered_cover :
 forall (l1 : list (btree A)) (t : btree A),
 cover l1 t -> exists l2 : _, permutation l1 l2 /\ ordered_cover l2 t.
Proof using.
intros l1; elim l1 using list_length_ind.
intros l0 H t; case t.
intros a H1; rewrite cover_inv_leaf with (1 := H1).
exists (leaf a :: nil); auto.
intros t1 t2 H1; case cover_inv_app with (1 := H1).
intros H2; exists l0; split; auto; rewrite H2; auto.
intros (l2, (l3, ((HH1, HH2), HH3))).
case H with (2 := HH1); auto.
rewrite permutation_length with (1 := HH3).
generalize HH2; rewrite length_app; case l3; simpl in |- *; auto with arith.
intros HH4; case cover_not_nil with (1 := HH4); auto.
intros; rewrite plus_comm; simpl in |- *; auto with arith.
intros l4 (HP1, HP2).
case H with (2 := HH2); auto.
rewrite permutation_length with (1 := HH3).
generalize HH1; rewrite length_app; case l2; simpl in |- *; auto with arith.
intros HH4; case cover_not_nil with (1 := HH4); auto.
intros l5 (HP3, HP4).
exists (l4 ++ l5); split; auto.
apply permutation_trans with (1 := HH3); auto.
Qed.

(*
  If the ordered cover is composed of only leaves, they are the
  exact leaves of the tree
*)
Theorem ulist_ordered_cover :
 forall l1 l2 t,
 ordered_cover l1 t ->
 ulist l2 -> l1 = map (fun x : A => leaf x) l2 -> all_leaves t = l2.
Proof using.
intros l1 l2 t H; generalize l2; elim H; clear H l1 l2 t; simpl in |- *; auto.
intros t l l2; case l2; simpl in |- *; auto.
intros; discriminate.
intros a0 l0 H H0; injection H0; intros H1 H2; rewrite H2; auto.
generalize H1; case l0; simpl in |- *; auto.
intros; discriminate.
intros t1 t2 l1 l2 l3 H H0 H1 H2 l0 H3 H4.
cut
 ((exists l3 : list A, l1 = map (fun x : A => leaf x) l3) /\
  (exists l4 : list A, l2 = map (fun x : A => leaf x) l4)).
intros ((l4, HH1), (l5, HH2)).
cut (l0 = l4 ++ l5); [ intros HH3 | idtac ].
rewrite HH3.
apply f_equal2 with (f := app (A:=A)).
apply H0; auto.
apply ulist_app_inv_l with (l2 := l5); rewrite <- HH3; auto.
apply H2; auto.
apply ulist_app_inv_r with (l1 := l4); rewrite <- HH3; auto.
rewrite HH2 in H4; rewrite HH1 in H4.
rewrite <- map_app in H4.
generalize H4; generalize (l4 ++ l5); elim l0; simpl in |- *; auto.
intros l; case l; simpl in |- *; auto.
intros; discriminate.
intros a0 l H5 l6; case l6; simpl in |- *; auto.
intros; discriminate.
intros a1 l7 H6; apply f_equal2 with (f := cons (A:=A)); auto.
injection H6; auto.
injection H6; auto.
generalize H4; generalize l2 l0; elim l1; simpl in |- *; auto.
intros l4 l5 H5; split; [ exists (nil (A:=A)) | exists l5 ]; auto.
intros a0 l H5 l4 l5; case l5; simpl in |- *; auto.
intros; discriminate.
intros a1 l6 H6; case (H5 l4 l6); auto.
injection H6; auto.
intros (l7, HH5) (l8, HH6); split; [ exists (a1 :: l7) | exists l8 ];
 simpl in |- *; auto.
apply f_equal2 with (f := cons (A:=btree A)); auto.
injection H6; auto.
Qed.

End OrderedCover.
Arguments ordered_cover [A].
Hint Resolve ordered_cover_one ordered_cover_node : core.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import classical unit ideal.

Open Scope ring_scope.
Open Scope classical_set_scope.

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

(* This is a temporary fix; we probably need more infrastructure to work with this. *)
(* Definition pred_of_set {T} (p : set T) := asbool \o p.*)

Fact set_display : unit. Proof. by []. Qed.

Section maximal.
Definition is_maximal (R : ringType) (S : {pred R}) :=
  forall I, idealr I -> S <> I -> not (S `<=` I).

Structure maximal_idealr (R : ringType) (S : {pred R}) := MkMaximalIdeal
{
  maximal_idealr_ideal :> idealr S ;
  _ : is_maximal S ;
}.
End maximal.

Section maximal_equiv.
Import Quotient GRing.

Variables (R : comRingType) (I : {pred R})
          (idealI : idealr I) (kI : keyed_pred idealI).

Notation quotRI := (rquot_ringQuotType kI).

Lemma maximal_quot_field : maximal_idealr I -> Field.mixin_of quotRI.
Proof.
  move=> maximalI x x_neq_0. rewrite /in_mem //=.
Admitted.

Lemma quot_field_maximal : Field.mixin_of quotRI -> maximal_idealr I.
Proof.
  rewrite /Field.mixin_of /in_mem //= => quot_fieldAx.
Admitted.
End maximal_equiv.

Section krull.
Variables (R : unitRingType).

Structure ideal := MkIdeal { idealS : set R; _ : idealr (pred_of_set idealS) }.
Coercion idealS : ideal >-> set.

(* Section IdealOrder.
   Implicit Types (X Y : set ideal).

   Lemma setI_meet X Y : `[< X `<=` Y >] = (X `&` Y == X).
   Proof. by apply/asboolP/eqP; rewrite setIidPl. Qed.

   Fact SetOrder_joinKI (Y X : set ideal) : X `&` (X `|` Y) = X.
   Proof. Admitted.

   Fact SetOrder_meetKU (Y X : set ideal) : X `|` (X `&` Y) = X.
   Proof. Admitted.

   Fact SetOrder_ldist : left_distributive (@setI ideal) setU.
   Admitted.

   Definition orderMixin := @MeetJoinMixin _ _ _ setI setU setI_meet
   (fun _ _ => erefl) (@setIC _) (@setUC _) (@setIA _) (@setUA _)
   SetOrder_joinKI SetOrder_meetKU SetOrder_ldist setIid.

   Canonical idealSet_porderType := POrderType set_display _ orderMixin.
   End IdealOrder.
 *)

(* R := subset *)
Lemma ideal_incl_trans (I J S : ideal) : I `<=` J -> J `<=` S -> I `<=` S.
Proof. exact: subset_trans. Qed.

Lemma ideal_incl_antisym (I J : ideal) : I `<=` J -> J `<=` I -> I = J.
Proof.
  move: I J => [setI idI] [setJ idJ] //= setIJ setJI.
  have seqEq : setI = setJ by rewrite eqEsubset.
  subst; congr MkIdeal. apply: Prop_irrelevance.
Qed.

Lemma has_upper_bound (P : set ideal) :
  total_on P subset -> exists (S : ideal), forall (I : ideal), P I -> I `<=` S.
Proof.
  rewrite /total_on.
  move=> is_total.
Admitted.

Lemma pred_of_setE {T} (S : {pred T}) : pred_of_set S = S.
Proof. rewrite /pred_of_set funeqE => x //=. exact: asboolbK. Qed.

(* Krull's theorem: every non-trivial ring has a maximal ideal *)
Theorem has_maximal_ideal : exists I : {pred R}, maximal_idealr I.
Proof.
  have [M maximal_M] := (Zorn (fun _ _ => ssrfun.id) ideal_incl_trans ideal_incl_antisym has_upper_bound).
  exists (pred_of_set M). split => //. by move: M maximal_M => [setM ideal_M] _.
  rewrite /is_maximal.
  move => setI ideal_I.
  have ideal_sI : idealr (pred_of_set setI) by rewrite pred_of_setE.
  have := (maximal_M (MkIdeal ideal_sI)).
  (* forall I, idealr I -> not (S `<=` I). <-> forall I, I `<=` S -> I = S *)
Admitted.
End krull.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


(* Adapt xp, variable and path of nats from the thesis in the TLC style. *)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibReflect TLC.LibBool TLC.LibOperation TLC.LibRelation TLC.LibOrder  TLC.LibNat TLC.LibVar.

Require Export LibPath.

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

Definition varpath := (prod var Path).

(* Inhabited and comparable *)

Instance varpath_inhab : Inhab varpath.
Proof using.
 intros.
 lets P: (var_fresh \{}).
 inversion P.
 apply (prove_Inhab (x, (cons u_pe nil))).
Qed.

Fixpoint varpath_compare (x y : varpath) :=
  match x, y with
    | (x,xp), (y, yp) =>
      If x = y then
       (If xp = yp then true else false)
    else false
  end.

Instance varpath_comparable : Comparable varpath.
Proof using.
  applys (comparable_beq varpath_compare).
  induction x; destruct y; simpl; autos*; auto_false.
  destruct (classicT (a = v)); destruct (classicT (b = p)); split;
  intros; subst; try solve [auto | inversion H | congruence].
Qed.

(* I don't really care about sets of varpaths, only that I can get a var set from them.
(* Will I need these? *)
Lemma varpath_eq:
  forall (x x' : var) (p p': Path),
    x = x' ->
    p = p' ->
    (x,p) = (x',p').
Proof.
  intros.
  rewrite H.
  rewrite~ H0.
Qed.
*)

(* Varpath Automation *)

Ltac lvpe_case_if_eq_base_resolve_if E F H :=
  destruct (classicT (E = F)) as [H|H];
  [tryfalse; try subst E; try apply~ If_l | tryfalse; try apply~ If_r].

Tactic Notation "lvpe_case_if_eq_resolve_if" constr(E) constr(F) "as" ident(H) :=
  lvpe_case_if_eq_base_resolve_if E F H.
Tactic Notation "lvpe_case_if_eq_resolve_if" constr(E) constr(F) :=
  let C := fresh "C" in lvpe_case_if_eq_resolve_if E F as C.

Ltac lvpe_case_if_eq_resolve_if A B :=
  lvpe_case_if_eq_base_resolve_if A B.

Ltac lvpe_case_if_eq_varpath :=
  match goal with
    | H: context [classicT((?x,?y) = (?x',?y') :> varpath)] |- _ =>
      lvpe_case_if_eq_resolve_if (x,y) (x',y')
    | |- context [classicT((?x,?y) = (?x',?y') :> varpath)]      =>
      lvpe_case_if_eq_resolve_if (x,y) (x',y')
    | H: context [classicT(?x = ?y :> varpath)] |- _ =>
      lvpe_case_if_eq_resolve_if x y
  | |- context [classicT(?x = ?y :> varpath)]      =>
      lvpe_case_if_eq_resolve_if x y
  end.

Tactic Notation "case_varpath" := lvpe_case_if_eq_varpath; try solve [ notin_false ].
Tactic Notation "case_varpath" "~" := case_varpath; auto_tilde.
Tactic Notation "case_varpath" "*" := case_varpath; auto_star.

(*
Module LV.
Implicit Types x : varpath.

Lemma notin_singleton_r : forall x y,
  x \notin \{y} -> x <> y.
Proof using. intros. rewrite~ <- notin_singleton. Qed.

Lemma notin_singleton_l : forall x y,
  x <> y -> x \notin \{y}.
Proof using. intros. rewrite~ notin_singleton. Qed.

Lemma notin_singleton_swap : forall x y,
  x \notin \{y} -> y \notin \{x}.
Proof using.
  intros. apply notin_singleton_l.
  apply sym_not_eq. apply~ notin_singleton_r.
Qed.

Lemma notin_union_r : forall x E F,
  x \notin (E \u F) -> (x \notin E) /\ (x \notin F).
Proof using. intros. rewrite~ <- notin_union. Qed.

Lemma notin_union_r1 : forall x E F,
  x \notin (E \u F) -> (x \notin E).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_r2 : forall x E F,
  x \notin (E \u F) -> (x \notin F).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_l : forall x E F,
  x \notin E -> x \notin F -> x \notin (E \u F).
Proof using. intros. rewrite~ notin_union. Qed.

(* Not used. -bgm
Lemma notin_var_gen : forall E F,
  (forall x, x \notin E -> x \notin F) ->
  (var_gen E) \notin F.
Proof using. intros. autos~ var_gen_spec. Qed.
*)

Implicit Arguments notin_singleton_r    [x y].
Implicit Arguments notin_singleton_l    [x y].
Implicit Arguments notin_singleton_swap [x y].
Implicit Arguments notin_union_r  [x E F].
Implicit Arguments notin_union_r1 [x E F].
Implicit Arguments notin_union_r2 [x E F].
Implicit Arguments notin_union_l  [x E F].

(** Tactics to deal with notin.  *)

Ltac lvpe_notin_solve_target_from x E H :=
  match type of H with
  | x \notin E => constr:(H)
  | x \notin (?F \u ?G) =>
     let H' :=
        match F with
        | context [E] => constr:(notin_union_r1 H)
        | _ => match G with
          | context [E] => constr:(notin_union_r2 H)
          | _ => fail 20
          end
        end in
     notin_solve_target_from x E H'
  end.

Ltac lvpe_notin_solve_target x E :=
  match goal with
  | H: x \notin ?L |- _ =>
    match L with context[E] =>
      let F := lvpe_notin_solve_target_from x E H in
      apply F
    end
  | H: x <> ?y |- _ =>
     match E with \{y} =>
       apply (notin_singleton_l H)
     end
  end.

Ltac lvpe_notin_solve_one :=
  match goal with
  | |- ?x \notin \{?y} =>
     apply notin_singleton_swap;
     lvpe_notin_solve_target y (\{x})
  | |- ?x \notin ?E =>
    lvpe_notin_solve_target x E
  (* If x is an evar, tries to instantiate it.
     Problem: it might loop !
  | |- ?x \notin ?E =>
     match goal with y:var |- _ =>
       match y with
       | x => fail 1
       | _ =>
         let H := fresh in cuts H: (y \notin E);
         [ apply H | notin_solve_target y E ]
        end
     end
  *)
  end.

Ltac lvpe_notin_simpl :=
  match goal with
  | |- _ \notin (_ \u _) => apply notin_union_l; notin_simpl
  | |- _ \notin (\{}) => apply notin_empty; notin_simpl
  | |- ?x <> ?y => apply notin_singleton_r; notin_simpl
  | |- _ => idtac
  end.

Ltac lvpe_notin_solve_false :=
  match goal with
  | H: ?x \notin ?E |- _ =>
    match E with context[x] =>
      apply (@notin_same _ x);
      let F := lvpe_notin_solve_target_from x (\{x}) H in
      apply F
    end
  | H: ?x <> ?x |- _ => apply H; reflexivity
  end.

Ltac lvpe_notin_false :=
  match goal with
  | |- False => lvpe_notin_solve_false
  | _ => intros_all; false; lvpe_notin_solve_false
  end.

Ltac lvpe_notin_from_fresh_in_context :=
  repeat (match goal with H: fresh _ _ _ |- _ =>
    progress (simpl in H; destructs H) end).

Ltac lvpe_notin_solve :=
  lvpe_notin_from_fresh_in_context;
  first [ lvpe_notin_simpl; try lvpe_notin_solve_one
        | lvpe_notin_false ].

(*
Hint Extern 1 (_ \notin _) => lvpe_notin_solve.
Hint Extern 1 (_ <> _ :> var) => lvpe_notin_solve.
Hint Extern 1 ((_ \notin _) /\ _) => splits.
*)

(*
LATER:
  | |- ?x \notin ?E =>
	progress (unfold x); notin_simpl
  | |- (var_gen ?x) \notin _ =>
        apply notin_var_gen; intros; notin_simpl
 *)
End LV.
*)


From Coq Require Import OrderedType.
From mathcomp Require Import ssreflect ssrbool eqtype.
From Common Require Import Types.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Coq OrderedType with Boolean equality. *)

Module Type SsrOrderedTypeMinimal.
  Parameter t : eqType.
  Definition eq : t -> t -> bool := fun x y => x == y.
  Parameter lt : t -> t -> bool.
  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Axiom lt_not_eq : forall x y : t, lt x y -> x != y.
  Parameter compare : forall x y : t, Compare lt eq x y.
End SsrOrderedTypeMinimal.

Module Type SsrOrderedType <: OrderedType.
  Parameter T : eqType.
  Definition t : Type := T.
  Definition eq : t -> t -> Prop := fun x y => x == y.
  Parameter ltb : t -> t -> bool.
  Definition lt : t -> t -> Prop := fun x y => ltb x y.
  Axiom eq_refl : forall x : t, eq x x.
  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Parameter compare : forall x y : t, Compare lt eq x y.
  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
End SsrOrderedType.

Module MakeSsrOrderedType (M : SsrOrderedTypeMinimal) <: SsrOrderedType.
  Definition T : eqType := M.t.
  Definition t : Type := T.
  Definition eq : t -> t -> Prop := fun x y => x == y.
  Definition ltb : t -> t -> bool := M.lt.
  Definition lt : t -> t -> Prop := fun x y => ltb x y.
  Lemma eq_refl : forall x : t, eq x x.
  Proof.
    exact: eqxx.
  Qed.
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof.
    move=> x y H.
    rewrite /eq eq_sym.
    exact: H.
  Qed.
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof.
    move=> x y z Hxy Hyz.
    rewrite (eqP Hxy).
    exact: Hyz.
  Qed.
  Definition lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z :=
    M.lt_trans.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    move=> x y Hlt Heq.
    move/negP: (M.lt_not_eq Hlt).
    apply.
    assumption.
  Qed.
  Definition compare : forall x y : t, Compare lt eq x y := M.compare.
  Lemma eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
  Proof.
    move=> x y.
    case Hxy: (x == y).
    - left; exact: Hxy.
    - right; move=> Heq.
      apply/negPf: Hxy.
      exact: Heq.
  Qed.
End MakeSsrOrderedType.

(** Product of ordered types. *)

Module MakeProdOrderedMinimal (O1 O2 : SsrOrderedType) <: SsrOrderedTypeMinimal with Definition t := prod_eqType O1.T O2.T.

  Definition t : eqType := prod_eqType O1.T O2.T.

  Definition eq : t -> t -> bool := fun x y => x == y.

  Definition lt : t -> t -> bool :=
    fun x y =>
      if O1.ltb (fst x) (fst y) then true
      else if (fst x) == (fst y) then O2.ltb (snd x) (snd y)
           else false.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    move=> [] x1 x2 [] y1 y2 [] z1 z2.
    rewrite /lt /=.
    case Hx1y1: (O1.ltb x1 y1).
    - case Hy1z1: (O1.ltb y1 z1).
      + case Hx1z1: (O1.ltb x1 z1); [done | idtac].
        move: (O1.lt_trans Hx1y1 Hy1z1) => Hx1z1'.
        rewrite /O1.lt Hx1z1 in Hx1z1'.
        done.
      + case Ey1z1: (y1 == z1); [idtac | done].
        case Hy2z2: (O2.ltb y2 z2); [idtac | done].
        case Hx1z1: (O1.ltb x1 z1); [done | idtac].
        case Ex1z1: (x1 == z1).
        * rewrite (eqP Ex1z1) -(eqP Ey1z1) in Hx1y1.
          apply: False_ind.
          apply: (O1.lt_not_eq Hx1y1).
          exact: O1.eq_refl.
        * rewrite (eqP Ey1z1) in Hx1y1.
          rewrite Hx1y1 in Hx1z1.
          discriminate.
    - case Ex1y1: (x1 == y1); [idtac | done].
      case Hx2y2: (O2.ltb x2 y2); [idtac | done].
      case Hy1z1: (O1.ltb y1 z1).
      + case Hx1z1: (O1.ltb x1 z1); [done | idtac].
        rewrite (eqP Ex1y1) Hy1z1 in Hx1z1.
        discriminate.
      + case Ey1z1: (y1 == z1); [idtac | done].
        case Hy2z2: (O2.ltb y2 z2); [idtac | done].
        case Hx1z1: (O1.ltb x1 z1); [done | idtac].
        case Ex1z1: (x1 == z1).
        * move=> _ _; exact: (O2.lt_trans Hx2y2 Hy2z2).
        * move: (O1.eq_trans Ex1y1 Ey1z1).
          rewrite /O1.eq Ex1z1.
          done.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> x != y.
  Proof.
    move=> [] x1 x2 [] y1 y2.
    rewrite /lt /=.
    case Hx1y1: (O1.ltb x1 y1).
    - move=> _.
      apply/eqP => H.
      case: H => H1 _.
      apply: (O1.lt_not_eq Hx1y1).
      by apply/eqP.
    - case Ex1y1: (x1 == y1); [idtac | done].
      case Hx2y2: (O2.ltb x2 y2); [idtac | done].
      move=> _.
      apply/eqP => H.
      case: H => _ H2.
      apply: (O2.lt_not_eq Hx2y2).
      by apply/eqP.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    move=> [] x1 x2 [] y1 y2.
    move: (O1.compare x1 y1) (O2.compare x2 y2) => Hc1 Hc2.
    inversion_clear Hc1.
    - apply: LT.
      rewrite /lt /=.
      rewrite /O1.lt in H.
      by rewrite H.
    - inversion_clear Hc2.
      + apply: LT.
        rewrite /lt /=.
        case Hx1y1: (O1.ltb x1 y1); [done | idtac].
        rewrite H.
        exact: H0.
      + apply: EQ.
        rewrite /eq /=.
        by apply/andP; split; assumption.
      + apply: GT.
        rewrite /lt /=.
        case Hy1x1: (O1.ltb y1 x1); [done | idtac].
        rewrite (O1.eq_sym H).
        exact: H0.
    - apply: GT.
      rewrite /lt /=.
      by rewrite H.
  Defined.

End MakeProdOrderedMinimal.

Module MakeProdOrdered (O1 O2 : SsrOrderedType) <: SsrOrderedType with Definition T := prod_eqType O1.T O2.T.
  Module M := MakeProdOrderedMinimal O1 O2.
  Module P := MakeSsrOrderedType M.
  Include P.
End MakeProdOrdered.

(** Union of ordered types. *)

Module MakeUnionOrderedMinimal
       (V1 : SsrOrderedType) (V2 : SsrOrderedType) <: SsrOrderedTypeMinimal.

  Inductive ut : Type :=
  | C1 : V1.t -> ut
  | C2 : V2.t -> ut.

  Definition uo_eqb (x y : ut) : bool :=
    match x, y with
    | C1 x, C1 y => x == y
    | C2 x, C2 y => x == y
    | _, _ => false
    end.

  Lemma uo_eqP : Equality.axiom uo_eqb.
  Proof.
    move=> x y.
    case H: (uo_eqb x y).
    - apply: ReflectT.
      move: H; case: y; case: x => //=.
      + move=> x y H.
        rewrite (eqP H).
        reflexivity.
      + move=> x y H.
        rewrite (eqP H).
        reflexivity.
    - apply: ReflectF.
      move: H; case: y; case: x => //=.
      + move=> x y H1 [] H2.
        apply/negPf: H1.
        rewrite H2; exact: eqxx.
      + move=> x y H1 [] H2.
        apply/negPf: H1.
        rewrite H2; exact: eqxx.
  Qed.

  Canonical uo_eqMixin := EqMixin uo_eqP.
  Canonical uo_eqType := Eval hnf in EqType ut uo_eqMixin.

  Definition t : eqType := uo_eqType.

  Definition eq : t -> t -> bool := uo_eqb.

  Definition lt (x y : t) : bool :=
    match x, y with
    | C1 x, C1 y => V1.ltb x y
    | C1 _, C2 _ => true
    | C2 _, C1 _ => false
    | C2 x, C2 y => V2.ltb x y
    end.

  Lemma lt_trans :
    forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    move=> x y z.
    case: z; case: y; case: x => //=.
    - exact: V1.lt_trans.
    - exact: V2.lt_trans.
  Qed.

  Lemma lt_not_eq :
    forall x y : t, lt x y -> x != y.
  Proof.
    move=> x y; case: y; case: x => //=.
    - move=> x y H.
      apply/negP.
      exact: V1.lt_not_eq.
    - move=> x y H.
      apply/negP.
      exact: V2.lt_not_eq.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    move=> x y.
    case: y; case: x.
    - move=> x y.
      case H: (V1.compare x y).
      + apply: LT; assumption.
      + apply: EQ; assumption.
      + apply: GT; assumption.
    - move=> x y.
      by apply: GT.
    - move=> x y.
      by apply: LT.
    - move=> x y.
      case H: (V2.compare x y).
      + apply: LT; assumption.
      + apply: EQ; assumption.
      + apply: GT; assumption.
  Defined.

End MakeUnionOrderedMinimal.

Module MakeUnionOrdered
       (V1 : SsrOrderedType) (V2 : SsrOrderedType) <: SsrOrderedType.
  Module M := MakeUnionOrderedMinimal V1 V2.
  Module O := MakeSsrOrderedType M.
  Include O.
  Definition c1 (x : V1.t) : t := M.C1 x.
  Definition c2 (x : V2.t) : t := M.C2 x.
End MakeUnionOrdered.

(** A singleton ordered type. *)

Module UnitOrderedMinimal <: SsrOrderedTypeMinimal.

  Definition t : eqType := unit_eqType.

  Definition eq (x y : t) : bool := x == y.

  Definition lt (x y : t) : bool := false.

  Lemma lt_trans :
    forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    done.
  Qed.

  Lemma lt_not_eq :
    forall x y : t, lt x y -> x != y.
  Proof.
    done.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    move=> x y.
    by apply: EQ.
  Defined.

End UnitOrderedMinimal.

Module UnitOrdered <: SsrOrderedType.
  Module O := MakeSsrOrderedType UnitOrderedMinimal.
  Include O.
End UnitOrdered.