(* Set library utilities. Part of the CertiCoq project.
 * Author: Anonymized, 2016
 *)

From Coq Require Import PArith.PArith MSets.MSetRBT Classes.Morphisms Sets.Ensembles
     Relations.Relations Lists.List Lists.SetoidList Permutation micromega.Lia.
Require Import compcert.lib.Coqlib LambdaANF.tactics.
From CertiCoq.LambdaANF Require Import Ensembles_util List_util functions.

Module PS := MSetRBT.Make POrderedType.Positive_as_OT.

Import PS.

(** Some set lemmas that might be useful *)
Lemma Subset_add s s' e :
  Subset s s' ->
  Subset (add e s) (add e s').
Proof.
  intros H e' HIn. eapply add_spec in HIn.
  inv HIn; eapply add_spec; eauto.
Qed.

Lemma Subset_union_l s s' s'' :
  Subset s s' ->
  Subset (union s'' s) (union s'' s').
Proof.
  intros H e' HIn. eapply union_spec in HIn.
  inv HIn; eapply union_spec; eauto.
Qed.

Lemma Subset_union_r s s' s'' :
  Subset s s' ->
  Subset (union s s'') (union s' s'').
Proof.
  intros H e' HIn. eapply union_spec in HIn.
  inv HIn; eapply union_spec; eauto.
Qed.

Lemma Subset_refl s :
  Subset s s.
Proof.
  intros H e; eauto.
Qed.

Lemma Subset_union_mon_l s s' s'' :
  Subset s s' ->
  Subset s (union s' s'').
Proof.
  intros H e' HIn.
  eapply union_spec; eauto.
Qed.

Lemma Subset_union_mon_r s s' s'' :
  Subset s s' ->
  Subset s (union s'' s').
Proof.
  intros H e' HIn.
  eapply union_spec; eauto.
Qed.

Definition union_list (s : PS.t) (l : list elt) : PS.t :=
  List.fold_left (fun set e => add e set) l s.

Lemma union_list_spec (s : PS.t) (l : list elt) :
  forall (x : elt), In x (union_list s l) <->
                    In x s \/ List.In x l.
Proof.
  revert s; induction l as [| x xs IHxs ]; simpl;
  intros s e; split; intros H; eauto.
  - inv H; eauto. contradiction.
  - eapply IHxs in H. inversion H as [H1 | H2]; eauto.
    eapply add_spec in H1; inv H1; eauto.
  - inversion H as [H1 | [ H2 | H3 ]]; subst;
    eapply IHxs; solve [ left; eapply add_spec; eauto
                       | right; eauto ].
Qed.

Definition diff_list (s : PS.t) (l : list elt) : PS.t :=
  List.fold_left (fun set e => remove e set) l s.

Lemma diff_list_spec (s : PS.t) (l : list elt) :
  forall (x : elt), In x (diff_list s l) <->
                    In x s /\ ~ List.In x l.
Proof.
  revert s; induction l as [| x xs IHxs ]; simpl;
  intros s e; split; intros H; eauto.
  - inv H; eauto.
  - eapply IHxs in H. inversion H as [H1 H2]; eauto.
    eapply remove_spec in H1; inv H1; split; eauto.
    intros [Hc | Hc]; congruence.
  - eapply IHxs. inversion H as [H1 H2]. split.
    * eapply remove_spec. split; eauto.
    * intros Hc. eauto.
Qed.

Lemma Subset_union_list s s' l :
  Subset s s' ->
  Subset (union_list s l) (union_list s' l).
Proof.
  intros H e' HIn. eapply union_list_spec in HIn.
  inv HIn; eapply union_list_spec; eauto.
Qed.

Lemma eq_lists (l1 l2 : list elt) :
  Sorted.Sorted (fun x y : positive => (x ?= y)%positive = Lt) l1 ->
  Sorted.Sorted (fun x y : positive => (x ?= y)%positive = Lt) l2 ->
  SetoidList.NoDupA Logic.eq l1 ->
  SetoidList.NoDupA Logic.eq l2 ->
  (forall x, SetoidList.InA Logic.eq x l1 <-> SetoidList.InA Logic.eq x l2) ->
  l1 = l2.
Proof.
  revert l2. induction l1; intros l2  Hs1 Hs2 Hd1 Hd2 Helem.
  - destruct l2; eauto.
    exfalso. specialize (Helem e).
    assert (Hc : SetoidList.InA Logic.eq e nil)
      by (eapply Helem; constructor; eauto).
    inv Hc.
  - destruct l2; eauto.
    + exfalso. specialize (Helem a).
      assert (Hc : SetoidList.InA Logic.eq a nil)
        by (eapply Helem; constructor; eauto).
      inv Hc.
    + inv Hs1. inv Hs2. inv Hd1. inv Hd2.
      assert (Helem' :
                forall x, SetoidList.InA Logic.eq x l1 <->
                          SetoidList.InA Logic.eq x l2).
      { intros x. split; intros H.
        - assert (HIn : SetoidList.InA Logic.eq x (e :: l2))
            by (eapply Helem; constructor 2; eauto).
          inv HIn; eauto.
          assert (HIn' : SetoidList.InA Logic.eq a (e :: l2))
            by (eapply Helem; constructor; eauto).
          assert (Hlt : (a ?= e)%positive = Lt).
          { eapply SetoidList.SortA_InfA_InA
            with (ltA := fun x y : positive => (x ?= y)%positive = Lt).
            apply eq_equivalence. eapply E.lt_strorder.
            apply E.lt_compat.
            apply H1. eauto. eauto. }
          inv HIn'. exfalso. eapply E.lt_strorder; eauto.
          assert (Hlt' : (e ?= a)%positive = Lt).
          { eapply SetoidList.SortA_InfA_InA
            with (ltA := fun x y : positive => (x ?= y)%positive = Lt).
            apply eq_equivalence. eapply E.lt_strorder.
            apply E.lt_compat.
            apply H3. eauto. eauto. }
          rewrite (@PositiveOrder.le_antisym e a); eauto; congruence.
        - assert (HIn : SetoidList.InA Logic.eq x (a :: l1))
            by (eapply Helem; constructor 2; eauto).
          inv HIn; eauto.
          assert (HIn' : SetoidList.InA Logic.eq e (a :: l1))
            by (eapply Helem; constructor; eauto).
          assert (Hlt : (e ?= a)%positive = Lt).
          { eapply SetoidList.SortA_InfA_InA
            with (ltA := fun x y : positive => (x ?= y)%positive = Lt).
            apply eq_equivalence. eapply E.lt_strorder.
            apply E.lt_compat.
            apply H3. eauto. eauto. }
          inv HIn'. exfalso. eapply E.lt_strorder; eauto.
          assert (Hlt' : (a ?= e)%positive = Lt).
          { eapply SetoidList.SortA_InfA_InA
            with (ltA := fun x y : positive => (x ?= y)%positive = Lt).
            apply eq_equivalence. eapply E.lt_strorder.
            apply E.lt_compat.
            apply H1. eauto. eauto. }
          rewrite (@PositiveOrder.le_antisym a e); eauto; congruence. }
      f_equal; eauto.
      assert (HIn' : SetoidList.InA Logic.eq e (a :: l1)) by
          (eapply Helem; constructor; eauto).
      assert (HIn : SetoidList.InA Logic.eq a (e :: l2)) by
          (eapply Helem; constructor; eauto).
      inv HIn'; try now apply Heq. inv HIn; eauto.
      assert (Hlt : (a ?= e)%positive = Lt).
      { eapply SetoidList.SortA_InfA_InA
        with (ltA := fun x y : positive => (x ?= y)%positive = Lt).
        apply eq_equivalence. eapply E.lt_strorder.
        apply E.lt_compat.
        apply H1. eauto. eauto. }
      inv HIn; eauto.
      assert (Hlt' : (e ?= a)%positive = Lt).
      { eapply SetoidList.SortA_InfA_InA
        with (ltA := fun x y : positive => (x ?= y)%positive = Lt).
        apply eq_equivalence. eapply E.lt_strorder.
        apply E.lt_compat.
        apply H3. eauto. eauto. }
      rewrite (@PositiveOrder.le_antisym a e); eauto; congruence.
Qed.

Lemma elements_eq s1 s2 :
  Equal s1 s2 ->
  elements s1 = elements s2.
Proof.
  intros H. apply eq_lists.
  apply elements_spec2. apply elements_spec2.
  apply elements_spec2w. apply elements_spec2w.
  intros x'; split; intros H';
  eapply elements_spec1; eapply elements_spec1 in H';
  eapply H; eauto.
Qed.

Ltac apply_set_specs_ctx :=
  match goal with
    | [ H : In _ (add _ _) |- _ ] =>
      apply add_spec in H; inv H
    | [ H : In _ (remove _ _) |- _ ] =>
      apply remove_spec in H; inv H
    | [ H : In _  (singleton _ ) |- _ ] =>
      apply singleton_spec in H; subst
    | [ H : In _ (union _ _) |- _ ] =>
      apply union_spec in H; inv H
    | [ H : In _ (diff _ _) |- _ ] =>
      apply diff_spec in H; inv H
    | [ H : In _ (diff_list _ _) |- _ ] =>
      apply diff_list_spec in H; inv H
    | [ H : In _ (union_list _ _) |- _ ] =>
      apply union_list_spec in H; inv H
  end.

Ltac apply_set_specs :=
  match goal with
    | [ |- In _ (add _ _) ] =>
      apply add_spec
    | [ |- In _ (remove _ _) ] =>
      apply remove_spec; split
    | [ |- In _  (singleton _ ) ] =>
      apply singleton_spec
    | [ |- In _ (union _ _) ] =>
      apply union_spec
    | [ |- In _ (diff _ _) ] =>
      apply diff_spec; split
    | [ |- In _ (diff_list _ _) ] =>
      apply diff_list_spec; split
    | [ |- In _ (union_list _ _) ] =>
      apply union_list_spec
  end.

Lemma Subset_Equal s s' :
  Subset s s' ->
  Subset s' s ->
  Equal s s'.
Proof.
  intros H1 H2 x. split; eauto.
Qed.

Lemma Equal_Subset_l s s' :
  Equal s s' ->
  Subset s s'.
Proof.
  intros H1 x Hin. apply H1; eauto.
Qed.

Lemma Equal_Subset_r s s' :
  Equal s s' ->
  Subset s' s.
Proof.
  intros H1 x Hin. apply H1; eauto.
Qed.

Lemma union_assoc s1 s2 s3 :
  Equal (union (union s1 s2) s3) (union s1 (union s2 s3)).
Proof.
  split; intros HIn; repeat apply_set_specs_ctx; apply_set_specs; eauto;
  solve [ right; apply_set_specs; eauto | left; apply_set_specs; eauto ].
Qed.

Lemma union_sym s1 s2 :
  Equal (union s1 s2) (union s2 s1).
Proof.
  split; intros HIn; repeat apply_set_specs_ctx; apply_set_specs; eauto;
  solve [ right; apply_set_specs; eauto | left; apply_set_specs; eauto ].
Qed.

(* Equality morphisms *)

Instance Proper_In x :  Proper (Equal ==> iff) (In x).
Proof.
  constructor; intros Hin; eapply H; eauto.
Qed.

Instance Proper_union_r x :  Proper (Equal ==> Equal) (union x).
Proof.
  constructor; intros Hin; apply_set_specs_ctx; apply_set_specs; eauto;
  right; apply H; eauto.
Qed.

Instance Proper_union_l :  Proper (Equal ==> Logic.eq ==> Equal) union.
Proof.
  constructor; intros; apply_set_specs_ctx; apply_set_specs; eauto;
  left; apply H; eauto.
Qed.

Instance Proper_elements :  Proper (Equal ==> Logic.eq) elements.
Proof.
  intros x y Heq; eauto. eapply elements_eq. eassumption.
Qed.

Instance Proper_carinal :  Proper (Equal ==> Logic.eq) cardinal.
Proof.
  intros x y Heq; eauto. rewrite !cardinal_spec, Heq. reflexivity.
Qed.

Instance union_proper_l :  Proper (PS.Equal ==> eq ==> PS.Equal) PS.union.
Proof.
  intros x y Heq1 x' y' Heq2; subst.
  intros z; split; intros Hin; eapply PS.union_spec in Hin;
  inv Hin; eapply PS.union_spec; now firstorder.
Qed.

Instance diff_proper_l :  Proper (PS.Equal ==> eq ==> PS.Equal) PS.diff.
Proof.
  intros x y Heq1 x' y' Heq2; subst.
  intros z; split; intros Hin; eapply PS.diff_spec in Hin;
  inv Hin; eapply PS.diff_spec; now firstorder.
Qed.

Instance diff_proper_r :  Proper (eq ==> PS.Equal ==> PS.Equal) PS.diff.
Proof.
  intros x y Heq1 x' y' Heq2; subst.
  intros z; split; intros Hin; eapply PS.diff_spec in Hin;
  inv Hin; eapply PS.diff_spec; now firstorder.
Qed.

Lemma PS_nonempty_add (S : PS.t) :
  PS.cardinal S > 0 ->
  exists x S', ~ PS.In x S' /\ PS.Equal S (PS.add x S').
Proof.
  intros Hsize. destruct (PS.elements S) eqn:Helem.
  - rewrite PS.cardinal_spec, Helem in Hsize; eauto. simpl in *. lia.
  - eexists e, (PS.remove e S). split.

    intros Hin. eapply PS.remove_spec in Hin.
    inv Hin; eauto.

    intros x. split; intros Hin.
    destruct (Coqlib.peq x e); subst.
    + eapply PS.add_spec. now left.
    + eapply PS.add_spec. right.
      eapply PS.remove_spec. split; eauto.
    + eapply PS.add_spec in Hin. inv Hin; subst.
      eapply PS.elements_spec1. rewrite Helem.
      now constructor.
      eapply PS.remove_spec in H. inv H; eauto.
Qed.

Lemma PS_add_elements S x :
  ~ PS.In x S ->
  Permutation (x :: PS.elements S) (PS.elements (PS.add x S)).
Proof.
  intros Hnin.
  eapply NoDup_Permutation.
  - constructor. intros Hin. eapply Hnin.
    eapply PS.elements_spec1. eapply In_InA; try eassumption.
    now eauto with typeclass_instances.
    eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  - eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  - intros y. split.
    + intros Hin. inv Hin.

      assert (HinA : InA Logic.eq y (PS.elements (PS.add y S))).
      { eapply PS.elements_spec1. eapply PS.add_spec. now left. }
      edestruct InA_alt as [[z [Heq1 Hin]] _]. eassumption.
      subst. eassumption.

      eapply In_InA in H.
      assert (HinA : InA Logic.eq y (PS.elements (PS.add x S))).
      { eapply PS.elements_spec1. eapply PS.add_spec. right.
        eapply PS.elements_spec1 in H. eassumption. }

      edestruct InA_alt as [[z [Heq1 Hin]] _]. eassumption. subst.
      subst. eassumption.

      now eauto with typeclass_instances.
    + intros Hin.
      eapply In_InA in Hin.

      eapply PS.elements_spec1 in Hin.
      eapply PS.add_spec in Hin. inv Hin.
      now constructor.
      constructor 2.

      assert (HinA : InA Logic.eq y (PS.elements S)).
      { eapply PS.elements_spec1. eassumption. }

      edestruct InA_alt as [[z [Heq1 Hin]] _]. eassumption.
      subst. eassumption.

      now eauto with typeclass_instances.
Qed.

Lemma PS_cardinal_empty S :
  PS.cardinal S = 0 -> PS.Equal S PS.empty.
Proof.
  intros Heq x. rewrite PS.cardinal_spec in Heq.
  split; intros Hin.
  - eapply PS.elements_spec1 in Hin.
    destruct (PS.elements S) as [| x1 l1 ]. now inv Hin.
    now inv Heq.
  - inv Hin.
Qed.

Lemma PS_cardinal_add (S : PS.t) x :
  ~ PS.In x S ->
  1 + PS.cardinal S = PS.cardinal (PS.add x S).
Proof.
  intros Hnin. rewrite !PS.cardinal_spec.
  erewrite (@Permutation_length _ (PS.elements (PS.add x S)));
    [| symmetry; now apply PS_add_elements ].
  reflexivity.
Qed.

Lemma PS_ind (P : PS.t -> Prop) {_ : Proper (PS.Equal ==> iff) P} :
  P PS.empty ->
  (forall x S, ~ PS.In x S -> P S -> P (PS.add x S)) ->
  (forall S, P S).
Proof.
  intros Hemp IH S.
  assert (Hs: PS.cardinal S = PS.cardinal S) by reflexivity.
  revert Hs.
  generalize (PS.cardinal S) at 1. intros n.
  revert S. induction n; intros S Heq.
  - eapply H. eapply PS_cardinal_empty. now eauto. eassumption.
  - edestruct PS_nonempty_add as (e & S' & HninS & HeqS).
    rewrite <- Heq. lia.
    eapply H. eassumption. eapply IH.
    eassumption. eapply IHn.
    rewrite HeqS in Heq. simpl in Heq.
    rewrite <- PS_cardinal_add in Heq. lia.
    eassumption.
Qed.

(** * Coercion from set *)

Definition FromSet (s : PS.t) : Ensemble positive :=
  FromList (elements s).

Lemma FromSet_sound (S : Ensemble positive) (s : PS.t) x :
  S <--> FromSet s ->
  x \in S -> In x s.
Proof.
  intros Heq Hin. eapply Heq in Hin.
  unfold FromSet, FromList, Ensembles.In in Hin.
  eapply In_InA in Hin. eapply PS.elements_spec1 in Hin.
  eassumption.
  now eapply PS.E.eq_equiv.
Qed.

Lemma FromSet_complete (S : Ensemble positive) (s : PS.t) x :
  S <--> FromSet s ->
  In x s -> x \in S.
Proof.
  intros Heq Hin.
  eapply Heq. unfold FromSet, FromList, Ensembles.In.
  eapply PS.elements_spec1 in Hin. eapply InA_alt in Hin.
  edestruct Hin as [y [Heq' Hin']]. subst. eassumption.
Qed.

Lemma FromSet_union s1 s2 :
  FromSet (PS.union s1 s2) <--> FromSet s1 :|: FromSet s2.
Proof.
  unfold FromSet, FromList. split; intros x Hin; unfold Ensembles.In in *; simpl in *.
  - eapply In_InA with (eqA := Logic.eq) in Hin; eauto with typeclass_instances.
    eapply PS.elements_spec1 in Hin. eapply PS.union_spec in Hin.
    inv Hin; [ left | right ]; unfold In; simpl.
    + assert (HinA: InA Logic.eq x (PS.elements s1)).
      { eapply PS.elements_spec1. eassumption. }
      eapply InA_alt in HinA. destruct HinA as [y [Heq Hin]]. subst; eauto.
    + assert (HinA: InA Logic.eq x (PS.elements s2)).
      { eapply PS.elements_spec1. eassumption. }
      eapply InA_alt in HinA. destruct HinA as [y [Heq Hin]]. subst; eauto.
  - assert (HinA: InA Logic.eq x (PS.elements (PS.union s1 s2))).
    { eapply PS.elements_spec1. eapply PS.union_spec.
      inv Hin; unfold Ensembles.In in *; simpl in *.
      + eapply In_InA with (eqA := Logic.eq) in H; eauto with typeclass_instances.
        eapply PS.elements_spec1 in H. now left.
      + eapply In_InA with (eqA := Logic.eq) in H; eauto with typeclass_instances.
        eapply PS.elements_spec1 in H. now right. }
    eapply InA_alt in HinA. destruct HinA as [y [Heq Hin']]. subst; eauto.
Qed.

Lemma FromSet_diff s1 s2 :
  FromSet (PS.diff s1 s2) <--> FromSet s1 \\ FromSet s2.
Proof.
  unfold FromSet, FromList. split; intros x Hin; unfold Ensembles.In in *; simpl in *.
  - eapply In_InA with (eqA := Logic.eq) in Hin; eauto with typeclass_instances.
    eapply PS.elements_spec1 in Hin. eapply PS.diff_spec in Hin.
    inv Hin. constructor.
    + assert (HinA: InA Logic.eq x (PS.elements s1)).
      { eapply PS.elements_spec1. eassumption. }
      eapply InA_alt in HinA. destruct HinA as [y [Heq Hin]]. subst; eauto.
    + intros Hin. simpl in Hin. unfold Ensembles.In in Hin.
      eapply In_InA with (eqA := Logic.eq) in Hin; eauto with typeclass_instances.
      eapply PS.elements_spec1 in Hin; eauto.
  - assert (HinA: InA Logic.eq x (PS.elements (PS.diff s1 s2))).
    { eapply PS.elements_spec1. eapply PS.diff_spec.
      inv Hin; unfold Ensembles.In in *; simpl in *. split.
      + eapply In_InA with (eqA := Logic.eq) in H; eauto with typeclass_instances.
        eapply PS.elements_spec1 in H. eassumption.
      + intros Hin. eapply PS.elements_spec1 in Hin.
        eapply InA_alt in Hin. destruct Hin as [y [Heq Hin]].
        subst; eauto. }
    eapply InA_alt in HinA. destruct HinA as [y [Heq Hin']]. subst; eauto.
Qed.

Lemma FromSet_add x s :
  FromSet (PS.add x s) <-->  x |: FromSet s.
Proof.
  unfold FromSet, FromList. split; intros z Hin; unfold Ensembles.In in *; simpl in *.
  - eapply In_InA with (eqA := Logic.eq) in Hin; eauto with typeclass_instances.
    eapply PS.elements_spec1 in Hin. eapply PS.add_spec in Hin.
    inv Hin; [ left | right ]; unfold In; simpl.
    + reflexivity.
    + assert (HinA: InA Logic.eq z (PS.elements s)).
      { eapply PS.elements_spec1. eassumption. }
      eapply InA_alt in HinA. destruct HinA as [y [Heq Hin]]. subst; eauto.
  - assert (HinA: InA Logic.eq z (PS.elements (PS.add x s))).
    { eapply PS.elements_spec1. eapply PS.add_spec.
      inv Hin; unfold Ensembles.In in *; simpl in *.
      + left. inv H. reflexivity.
      + eapply In_InA with (eqA := Logic.eq) in H; eauto with typeclass_instances.
        eapply PS.elements_spec1 in H. now right. }
    eapply InA_alt in HinA. destruct HinA as [y [Heq Hin']]. subst; eauto.
Qed.

Lemma FromSet_union_list s l:
  FromSet (union_list s l) <--> FromSet s :|: FromList l.
Proof.
  revert s; induction l; intros s; simpl.
  - rewrite FromList_nil, Union_Empty_set_neut_r.
    reflexivity.
  - rewrite IHl, FromSet_add, FromList_cons, Union_assoc, (Union_commut (FromSet s) [set a]).
    reflexivity.
Qed.

Lemma FromSet_empty :
  FromSet PS.empty <--> Empty_set _.
Proof.
  split; intros x Hin; now inv Hin.
Qed.

Lemma FromSet_singleton x :
  FromSet (PS.singleton x) <--> [set x].
Proof.
  split; intros z Hin; unfold FromSet, FromList, Ensembles.In in *.
  - eapply In_InA in Hin. eapply PS.elements_spec1 in Hin.
    eapply PS.singleton_spec in Hin. subst. reflexivity.
    now eauto with typeclass_instances.
  - inv Hin. eapply InA_In.  eapply PS.elements_spec1.
    eapply PS.singleton_spec. reflexivity.
Qed.

Lemma FromSet_cardinal_empty s :
  PS.cardinal s = 0 -> FromSet s <--> Empty_set _.
Proof.
  rewrite PS.cardinal_spec. intros Hc.
  split; intros x Hin; try now inv Hin.
  unfold FromSet, Ensembles.In, FromList in Hin.
  eapply In_InA with (eqA := Logic.eq) in Hin;
    eauto with typeclass_instances.
  destruct (PS.elements s); try congruence.
  now inv Hin. now inv Hc.
Qed.

Instance Decidable_FromSet (s : PS.t) : Decidable (FromSet s).
Proof.
  unfold FromSet.
  eapply Ensembles_util.Decidable_FromList.
Qed.

Instance Proper_From_set : Proper (PS.Equal ==> Same_set _) FromSet.
Proof.
  constructor.
  - intros z Hin. eapply FromSet_sound in Hin; [| reflexivity ].
    eapply FromSet_complete. reflexivity. eapply H. eassumption.
  - intros z Hin. eapply FromSet_sound in Hin; [| reflexivity ].
    eapply FromSet_complete. reflexivity. eapply H. eassumption.
Qed.

Lemma Same_set_From_set (s1 s2 : PS.t) :
  FromSet s1 <--> FromSet s2 -> PS.Equal s1 s2.
Proof.
  intros Heq z. split.
  - intros Hin. eapply FromSet_complete in Hin; [| reflexivity ].
    eapply FromSet_sound. reflexivity. eapply Heq. eassumption.
  - intros Hin. eapply FromSet_complete in Hin; [| reflexivity ].
    eapply FromSet_sound. reflexivity. eapply Heq. eassumption.
Qed.

(** Coercion from Ensemble to PS.t *)

Class ToMSet (S : Ensemble positive) :=
  {
    mset : PS.t;
    mset_eq : S <--> FromSet mset
  }.

Instance ToMSet_EmptySet : ToMSet (Empty_set _).
Proof.
  econstructor.
  symmetry. eapply FromSet_empty.
Defined.

Instance ToMSet_Singleton x : ToMSet [set x].
Proof.
  econstructor.
  symmetry. eapply FromSet_singleton.
Defined.

Instance ToMSet_Same_set (S1 S2 : Ensemble positive) :
  S1 <--> S2 ->
  ToMSet S1 ->
  ToMSet S2.
Proof.
  intros Heq [mset mset_eq]. rewrite Heq in mset_eq.
  econstructor. eassumption.
Qed.

Instance ToMSet_image'_Singleton {A} (f : A -> option positive) (x : A) :
  ToMSet (image' f [set x]).
Proof.
  destruct (f x) eqn:Heq.
  econstructor. rewrite image'_Singleton_Some; eauto.
  symmetry. eapply FromSet_singleton.
  econstructor. rewrite image'_Singleton_None; eauto.
  symmetry. eapply FromSet_empty.
Defined.

Instance ToMSet_Union S1 {H1 : ToMSet S1} S2 {H2 : ToMSet S2} : ToMSet (S1 :|: S2).
Proof.
  destruct H1 as [m1 Heq1]. destruct H2 as [m2 Heq2].
  econstructor. symmetry. rewrite FromSet_union.
  rewrite Heq1, Heq2. reflexivity.
Qed.

Instance ToMSet_Setminus S1 {H1 : ToMSet S1} S2 {H2 : ToMSet S2} : ToMSet (S1 \\ S2).
Proof.
  destruct H1 as [m1 Heq1]. destruct H2 as [m2 Heq2].
  econstructor. symmetry. rewrite FromSet_diff.
  rewrite Heq1, Heq2. reflexivity.
Qed.

Instance ToMSet_Intersection (S1 : Ensemble positive) `{ToMSet S1}
         (S2 : Ensemble positive) `{ToMSet S2} : ToMSet (S1 :&: S2).
Proof.
  destruct H as [m1 Hm1]; destruct H0 as [m2 Hm2].
  eexists (PS.inter m1 m2).
  split.
  - intros x H. destruct H as [y Hs1 Hs2].
    eapply FromSet_complete. reflexivity.
    eapply PS.inter_spec. split.
    eapply FromSet_sound. eapply Hm1; eauto. eassumption.
    eapply FromSet_sound. eapply Hm2; eauto. eassumption.
  - intros x H.
    eapply FromSet_sound in H; [| reflexivity ].
    eapply PS.inter_spec in H. inv H. constructor.
    eapply FromSet_complete. eapply Hm1; eauto. eassumption.
    eapply FromSet_complete. eapply Hm2; eauto. eassumption.
Qed.

Instance ToMSetFromList l : ToMSet (FromList l).
Proof.
  eexists (union_list PS.empty l).
  rewrite FromSet_union_list. rewrite FromSet_empty.
  rewrite Union_Empty_set_neut_l. reflexivity.
Defined.

Instance Decidable_ToMSet S {HM : ToMSet S} : Decidable S.
Proof.
  constructor. intros x.
  destruct HM as [m Heq].
  destruct (PS.mem x m) eqn:Hin.
  - eapply PS.mem_spec in Hin.
    left. eapply Heq. unfold FromSet, FromList, In.
    eapply InA_In. eapply PS.elements_spec1. eassumption.
  - right. intros Hc.
    eapply Heq in Hc.
    unfold FromSet, FromList, Ensembles.In in Hc.
    eapply In_InA with (eqA := Logic.eq)in Hc;
      eauto with typeclass_instances.
    eapply PS.elements_spec1 in Hc.
    eapply PS.mem_spec in Hc. congruence.
Qed.

Lemma ToMSet_add x S :
  ToMSet (x |: S) ->
  ~ x \in S ->
  ToMSet S.
Proof.
  intros [m Hm] Hnin.
  eapply Build_ToMSet with (mset := PS.remove x m).
  split; intros y Hin.
  - unfold FromSet, FromList, In in *. simpl.
    eapply InA_In. eapply PS.elements_spec1.
    eapply PS.remove_spec. split.
    + unfold FromSet, FromList, In. simpl.
      eapply PS.elements_spec1. eapply In_InA.
      now eauto with typeclass_instances.
      eapply Hm. now right.
    + intros Hc; subst; eauto.
  - unfold FromSet, FromList, Ensembles.In in *. simpl in *.
    eapply In_InA with (eqA := Logic.eq) in Hin; eauto with typeclass_instances.
    eapply PS.elements_spec1 in Hin. eapply PS.remove_spec in Hin.
    inv Hin.
    eapply PS.elements_spec1 in H. eapply InA_In in H.
    eapply Hm in H. inv H; eauto.
    inv H1. exfalso; eauto.
Qed.

Lemma Ensemble_ind (P : Ensemble positive -> Prop) {_ : Proper (Same_set _ ==> iff) P} :
  P (Empty_set _) ->
  (forall x S {_ : ToMSet S}, ~ x \in S -> P S -> P (x |: S)) ->
  (forall S {_ : ToMSet S}, P S).
Proof.
  intros Hbase IH S HS.
  eapply H. eapply HS.
  eapply PS_ind with (S := mset).
  - intros x y Heq. eapply H.
    unfold FromSet. rewrite Heq. reflexivity.
  - rewrite FromSet_empty. eassumption.
  - intros z S1 Hnin HP.
    rewrite FromSet_add. eapply IH; try eassumption.
    econstructor. reflexivity.
    intros Hc. eapply Hnin. unfold FromSet, FromList, Ensembles.In in Hc.
    simpl in Hc. eapply In_InA in Hc. eapply PS.elements_spec1 in Hc.
    eassumption. eauto with typeclass_instances.
Qed.

Definition PS_map f s :=
  PS.fold (fun x s => PS.add (f x) s) s PS.empty.

Definition PS_map_opt f s :=
  PS.fold (fun x s => match f x with
                     | Some y => PS.add y s
                     | None => s
                   end) s PS.empty.

Lemma FromSet_elements m :
  FromSet m <--> FromList (PS.elements m).
Proof.
  split.
  - intros x H.
    eapply FromSet_sound in H; try eassumption; [| reflexivity ].
    unfold In, FromList.
    eapply InA_In. eapply PS.elements_spec1. eassumption.
  - intros x H.
    unfold Ensembles.In, FromList in H.
    eapply In_InA in H. eapply PS.elements_spec1 in H.
    eapply FromSet_complete. reflexivity. eassumption.
    tci.
Qed.

Lemma PS_cardinal_empty_l s :
  FromSet s <--> Empty_set _ ->
  PS.cardinal s = 0.
Proof.
  intros Heq.
  replace 0 with (@List.length elt nil) by reflexivity.
  rewrite !PS.cardinal_spec. eapply Same_set_FromList_length'.
  eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  constructor; eauto.
  rewrite <- !FromSet_elements. rewrite Heq. repeat normalize_sets.
  reflexivity.
Qed.

Lemma PS_cardinal_singleton s x :
  FromSet s <--> [set x] ->
  PS.cardinal s = 1.
Proof.
  intros Heq.
  replace 1 with (List.length (cons x nil)) by reflexivity.
  rewrite !PS.cardinal_spec. eapply Same_set_FromList_length'.
  eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  constructor; eauto. now constructor.
  rewrite <- !FromSet_elements. rewrite Heq. repeat normalize_sets.
  reflexivity.
Qed.

Lemma PS_fold_left_map s l b :
  image b (FromList l) :|: FromSet s <-->
        FromSet
        (fold_left (fun (a : PS.t) (e : PS.elt) => PS.add (b e) a) l s).
Proof with (now eauto with Ensembles_DB).
  revert s; induction l; intros s; eauto.
  - rewrite FromList_nil, image_Empty_set...
  - rewrite FromList_cons. simpl.
    rewrite image_Union, (Union_commut (image _ _ )), <- Union_assoc.
    rewrite image_Singleton. rewrite <- FromSet_add.
    now apply IHl.
Qed.

Lemma PS_fold_left_map_opt s l (b : positive -> option positive) :
  image' b (FromList l) :|: FromSet s <-->
         FromSet
         (fold_left (fun s x  => match b x with
                                | Some y => PS.add y s
                                | None => s
                              end)  l s).
Proof with (now eauto with Ensembles_DB).
  revert s; induction l; intros s; eauto.
  - rewrite FromList_nil, image'_Empty_set...
  - rewrite FromList_cons. simpl.
    rewrite image'_Union, (Union_commut (image' _ _ )), <- Union_assoc.
    destruct (b a) eqn:Hbs.
    + rewrite image'_Singleton_Some; eauto.
      rewrite <- FromSet_add.
      now apply IHl.
    + rewrite image'_Singleton_None; eauto.
      rewrite Union_Empty_set_neut_l.
      eapply IHl.
Qed.

Instance ImageToMSet b S `{_: ToMSet S} : ToMSet (image b S).
Proof.
  destruct H as [m Hm].
  exists (PS_map b m).  rewrite Hm. unfold PS_map.
  rewrite FromSet_elements.
  rewrite PS.fold_spec.
  rewrite FromSet_elements in Hm.
  generalize (PS.elements m) Hm. clear Hm.
  intros l Heq.
  rewrite <- PS_fold_left_map. rewrite FromSet_empty.
  now eauto with Ensembles_DB.
Qed.

Instance Image'ToMSet b S `{_: ToMSet S} : ToMSet (image' b S).
Proof.
  destruct H as [m Hm].
  exists (PS_map_opt b m).  rewrite Hm. unfold PS_map_opt.
  rewrite FromSet_elements.
  rewrite PS.fold_spec.
  rewrite FromSet_elements in Hm.
  generalize (PS.elements m) Hm. clear Hm.
  intros l Heq.
  rewrite <- PS_fold_left_map_opt. rewrite FromSet_empty.
  now eauto with Ensembles_DB.
Qed.

Lemma PS_elements_subset S1 {HS1 : ToMSet S1} S2 {HS2 : ToMSet S2} :
  S1 \subset S2 ->
  (PS.cardinal (@mset S1 _)) <= (PS.cardinal (@mset S2 _)).
Proof.
  rewrite !PS.cardinal_spec. intros Hin.
  eapply Same_set_FromList_length.
  eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  rewrite <- !FromSet_elements. unfold mset.
  destruct HS1 as [m1 HS1].
  destruct HS2 as [m2 HS2].
  rewrite <- HS1, <- HS2. eassumption.
Qed.

Definition disjoint (s1 s2 : PS.t) : Prop :=
  PS.Equal (PS.inter s1 s2) PS.empty.

Lemma disjoint_spec (s1 s2 : PS.t) x :
  disjoint s1 s2 ->
  PS.In x s1->
  ~ PS.In x s2.
Proof.
  intros Hd Hin1 Hin2.
  assert (Hin3 : PS.In x (PS.inter s1 s2)).
  { eapply PS.inter_spec; eauto. }
  unfold disjoint in Hd. rewrite Hd in Hin3.
  inv Hin3.
Qed.

Lemma disjoint_spec' (s1 s2 : PS.t) x :
  disjoint s1 s2 ->
  PS.In x s2 ->
  ~ PS.In x s1.
Proof.
  intros Hd Hin1 Hin2.
  assert (Hin3 : PS.In x (PS.inter s1 s2)).
  { eapply PS.inter_spec; eauto. }
  unfold disjoint in Hd. rewrite Hd in Hin3.
  inv Hin3.
Qed.

Lemma FromSet_intersection (s1 s2 : PS.t) :
  FromSet (PS.inter s1 s2) <--> FromSet s1 :&: FromSet s2.
Proof.
  split; intros x Hin.
  eapply FromSet_sound in Hin; [| reflexivity ].
  eapply PS.inter_spec in Hin. destruct Hin as [Hin1 Hin2].
  constructor; (eapply FromSet_complete; [ reflexivity | eassumption ]).
  inv Hin.
  eapply FromSet_complete. reflexivity.
  eapply PS.inter_spec.
  split; (eapply FromSet_sound; [ reflexivity | eassumption ]).
Qed.

Lemma FromSet_disjoint (s1 s2 : PS.t) :
  disjoint s1 s2 <-> Disjoint _ (FromSet s1) (FromSet s2).
Proof.
  split; intros Hd.
  - constructor. intros x Hin.
    eapply FromSet_intersection in Hin.
    unfold disjoint in Hd. rewrite Hd in Hin.
    eapply FromSet_empty in Hin. inv Hin.
  - inv Hd. unfold disjoint. intros y.
    specialize (H y). split; intros Hin; [| now inv Hin ].
    exfalso. eapply H.
    eapply FromSet_intersection.
    eapply FromSet_complete; [| eassumption ].
    reflexivity.
Qed.

Lemma PS_union_elements s1 s2 :
  disjoint s1 s2 ->
  Permutation (PS.elements s1 ++ PS.elements s2) (PS.elements (PS.union s1 s2)).
Proof.
  intros Hnin.
  eapply NoDup_Permutation.
  - eapply NoDup_app.
    eapply NoDupA_NoDup. now eapply PS.elements_spec2w.
    eapply NoDupA_NoDup. now eapply PS.elements_spec2w.
    eapply FromSet_disjoint. eassumption.
  - eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  - intros y. split.
    + intros Hin.
      eapply InA_In.
      eapply PS.elements_spec1. eapply PS.union_spec.
      eapply Coqlib.in_app in Hin.
      inv Hin.
      * left. eapply PS.elements_spec1.
        eapply In_InA. eauto with typeclass_instances.
        eassumption.
      * right. eapply PS.elements_spec1.
        eapply In_InA. eauto with typeclass_instances.
        eassumption.
    + intros HIn.
      eapply In_InA in HIn.
      eapply PS.elements_spec1 in HIn.
      eapply PS.union_spec in HIn.
      eapply Coqlib.in_app.
      inv HIn.
      * left. eapply InA_In. eapply PS.elements_spec1.
        eassumption.
      * right. eapply InA_In. eapply PS.elements_spec1.
        eassumption.
      * eauto with typeclass_instances.
Qed.

Lemma PS_cardinal_union s1 s2 :
  disjoint s1 s2 ->
  PS.cardinal s1 + PS.cardinal s2 = PS.cardinal (PS.union s1 s2).
Proof.
  intros Hd.
  rewrite !PS.cardinal_spec.
  erewrite (@Permutation_length _ (PS.elements (PS.union s1 s2))).
  rewrite <- app_length. reflexivity.
  symmetry. eapply PS_union_elements. eassumption.
Qed.

(** Existence of function inverse -- requires [ToMSet] *)

Lemma inverse_exists S {Hs : ToMSet S} (b : positive -> positive) :
  injective_subdomain S b ->
  exists b', injective_subdomain (image b S) b' /\
        inverse_subdomain S b b'.
Proof.
  pose (P := fun S => forall (_ : ToMSet S),
                 injective_subdomain S b ->
                 exists b', injective_subdomain (image b S) b' /\
                       inverse_subdomain S b b').
  assert (Hs' := Hs). revert Hs.
  eapply Ensemble_ind with (P := P).
  - intros S1 S2 Heq. unfold P; split.
    intros Hs1 Hinj. setoid_rewrite <- Heq.
    eapply Hs1. eapply ToMSet_Same_set. symmetry. eassumption.
    eassumption.
    intros Hs1 Hinj. setoid_rewrite Heq.
    eapply Hs1. eapply ToMSet_Same_set. eassumption.
    eassumption.
  - unfold P. intros _.
    intros _. eexists id.
    split.

    rewrite image_Empty_set. clear. now firstorder.

    split.
    rewrite image_Empty_set. clear. now firstorder.
    clear; now firstorder.

  - intros x S0 Hs0 Hnin IH Hs Hinj. edestruct IH as [b' [Hinj' [Hfeq1 Hfeq2]]].
    eassumption. eapply injective_subdomain_antimon. eassumption. now eauto with Ensembles_DB.

    eexists (b' {(b x) ~> x}). split.

    + rewrite image_Union, image_Singleton.
      eapply injective_subdomain_extend. eassumption.
      intros [y [Hc Heqcy]]; subst. inv Hc.
      destruct H as [z [Hc Heqcz]]. subst.
      eapply H0.

      replace (b' (b z)) with z. reflexivity.

      replace (b' (b z)) with ((b' ∘ b) z) by reflexivity.
      rewrite Hfeq2. reflexivity. eassumption.
    + assert (Hfeq : f_eq id (id { b x ~> b x } )).
      { clear. intros y.
        destruct (peq y (b x)).
        - subst. rewrite extend_gss. reflexivity.
        - rewrite extend_gso; eauto. }

      assert (Hfeq' : f_eq id (id { x ~> x } )).
      { clear. intros y.
        destruct (peq y x).
        - subst. rewrite extend_gss. reflexivity.
        - rewrite extend_gso; eauto. }
      split.
      * rewrite compose_extend.
        rewrite Hfeq.
        rewrite image_Union, image_Singleton.
        eapply f_eq_subdomain_extend. eassumption.
      * eapply transitivity.
        eapply compose_extend_l. eassumption. now left.
        rewrite Hfeq'.
        eapply f_eq_subdomain_extend. eassumption.
  - eassumption.
Qed.

Lemma PS_add_elements_in S x :
  PS.In x S ->
  Permutation (PS.elements S) (PS.elements (PS.add x S)).
Proof.
  intros Hnin.
  eapply NoDup_Permutation.
  - eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  - eapply NoDupA_NoDup. eapply PS.elements_spec2w.
  - intros y. split.
    + intros Hin.
      assert (HinA : InA Logic.eq y (PS.elements (PS.add x S))).
      { eapply PS.elements_spec1. eapply PS.add_spec. right.
        eapply PS.elements_spec1. eapply In_InA; tci. }
      eapply InA_In; eauto.
    + intros Hin. eapply In_InA in Hin; tci.

      eapply PS.elements_spec1 in Hin.
      eapply PS.add_spec in Hin. inv Hin.
      eapply InA_In.
      eapply PS.elements_spec1. eassumption.
      eapply InA_In.
      eapply PS.elements_spec1. eassumption.
Qed.

Lemma PS_cardinal_add_in x s:
  PS.In x s ->
  PS.cardinal (PS.add x s) = PS.cardinal s.
Proof.
  intros Hnin. rewrite !PS.cardinal_spec.
  erewrite (@Permutation_length _ (PS.elements (PS.add x s)));
    [| symmetry; now apply PS_add_elements_in ].
  reflexivity.
Qed.

Lemma PS_union_list f l s1 s2 :
  PS.cardinal s1 <= PS.cardinal s2 ->
  (forall x, PS.In x s2 -> PS.In (f x) s1) ->
  PS.cardinal (union_list s1 (map f l)) <= PS.cardinal (union_list s2 l).
Proof.
  revert s1 s2. induction l; intros s1 s2 Hleq Hin.
  - eassumption.
  - simpl. eapply IHl.
    destruct (PS.mem a s2) eqn:Heq.
    + eapply mem_spec in Heq.
      rewrite PS_cardinal_add_in with (x := a); eauto.
      eapply Hin in Heq.
      rewrite PS_cardinal_add_in with (x := f a); eauto.
    + rewrite <- PS_cardinal_add with (x := a); eauto.
      destruct (PS.mem (f a) s1) eqn:Heq'.
      eapply mem_spec in Heq'. rewrite PS_cardinal_add_in with (x := f a); eauto.
      rewrite <- PS_cardinal_add with (x := f a); eauto.
      lia.
      intros Hc. eapply mem_spec in Hc. congruence.
      intros Hc. eapply mem_spec in Hc. congruence.
    + intros x Hina. eapply add_spec in Hina. inv Hina.

      eapply add_spec. now left.

      eapply Hin in H.
      eapply add_spec. now right.
Qed.

Lemma PS_union_list_corr f l  :
  PS.cardinal (union_list PS.empty (map f l)) <= PS.cardinal (union_list PS.empty l).
Proof.
  eapply PS_union_list.
  reflexivity.

  intros x Hin. inv Hin.
Qed.

Lemma PS_cardinal_map f l :
  PS.cardinal (@mset (FromList (map f l)) _) <= PS.cardinal (@mset (FromList l) _).
Proof.
  unfold mset. unfold ToMSetFromList. simpl.
  eapply PS_union_list_corr.
Qed.

Lemma PS_union_list_eq f l s1 s2 :
  injective_subdomain (FromList l :|: FromSet s2) f ->
  PS.cardinal s1 = PS.cardinal s2 ->
  (FromSet s1 <--> image f (FromSet s2)) ->
  PS.cardinal (union_list s1 (map f l)) = PS.cardinal (union_list s2 l).
Proof.
  revert s1 s2. induction l; intros s1 s2 Hinj Heq Hin.
  - eassumption.
  - simpl. eapply IHl.
    + eapply injective_subdomain_antimon. eassumption. normalize_sets; sets.
      rewrite FromSet_add. sets.
    + destruct (PS.mem a s2) eqn:Heq'.
      * eapply mem_spec in Heq'.
        rewrite PS_cardinal_add_in with (x := a); eauto.

        eapply (FromSet_complete (FromSet s2) s2 a) in Heq'; [| reflexivity ].
        eapply In_image in Heq'. eapply Hin in Heq'.
        eapply FromSet_sound in Heq'; [| reflexivity ].
        rewrite PS_cardinal_add_in with (x := f a); eauto.
      * rewrite <- PS_cardinal_add with (x := a); eauto.
        destruct (PS.mem (f a) s1) eqn:Heq''.
        { exfalso. eapply mem_spec in Heq''.
          eapply FromSet_complete in Heq''; [| symmetry; eassumption ].
          edestruct Heq'' as [z' [Hin1 Heq2]].
          assert (Heq1 : z' = a).
          { eapply Hinj. right. eassumption. left. normalize_sets; sets.
            eassumption. }
          subst. eapply FromSet_sound in Hin1; [| reflexivity ].
          eapply mem_spec in Hin1. congruence. }
        rewrite <- PS_cardinal_add with (x := f a); eauto.
        intros Hc. eapply mem_spec in Hc. congruence.
        intros Hc. eapply mem_spec in Hc. congruence.
    + rewrite ! FromSet_add. rewrite image_Union, image_Singleton, Hin.
      reflexivity.
Qed.

Lemma PS_union_list_eq_corr f l  :
  injective_subdomain (FromList l) f ->
  PS.cardinal (union_list PS.empty (map f l)) = PS.cardinal (union_list PS.empty l).
Proof.
  intros Hinj.
  eapply PS_union_list_eq.
  rewrite FromSet_empty, Union_Empty_set_neut_r. eassumption.
  reflexivity. rewrite FromSet_empty, image_Empty_set. reflexivity.
Qed.

Lemma PS_cardinal_map_eq f l :
  injective_subdomain (FromList l) f ->
  PS.cardinal (@mset (FromList (map f l)) _) = PS.cardinal (@mset (FromList l) _).
Proof.
  unfold mset. unfold ToMSetFromList. simpl.
  eapply PS_union_list_eq_corr.
Qed.

Lemma FromList_length_cardinal l S {Hs : ToMSet S} :
  FromList l \subset S ->
  NoDup l ->
  length l <= PS.cardinal mset.
Proof.
  intros Hyp1 Hyp2. rewrite (@mset_eq S) in Hyp1.
  rewrite FromSet_elements in Hyp1. rewrite PS.cardinal_spec.
  eapply Same_set_FromList_length; eauto.
Qed.

Lemma FromList_length_cardinal' l m :
  FromList l \subset (FromSet m) ->
  NoDup l ->
  length l <= PS.cardinal m.
Proof.
  intros Hyp1 Hyp2.
  rewrite FromSet_elements in Hyp1. rewrite PS.cardinal_spec.
  eapply Same_set_FromList_length; eauto.
Qed.


(** * Strong induction principles

Authors:
    - Jim Portegies

This file is part of Waterproof-lib.

Waterproof-lib is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Waterproof-lib 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 General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)

(* Require Import Reals.
Require Import ZArith. *)
Require Import Lia.
(*Require Import Classical.
Require Import Classical_Pred_Type.
Require Import ClassicalChoice.

Require Import Waterproof.AllTactics.
Require Import Waterproof.load_database.RealsAndIntegers.
Require Import Waterproof.notations.notations.
Require Import Waterproof.set_search_depth.To_5.
Require Import Waterproof.set_intuition.Disabled.
Require Import Waterproof.load_database.DisableWildcard*).

(* #[export] Hint Resolve Rabs_Rabsolu.*)
(** ## Creating a subsequence of elements satisfying a certain property

The purpose of this section is to provide a somewhat general strategy to construct subsequences of elements satisfying a certain property. *)
(** ### From existence of a next element to a function producing this element

The next lemma is quite technical, and is usually not so visible in classical analysis. We rely here on a version of the axiom of choice.*)
(*Lemma existence_next_el_to_fun :
    ∀ (a : ℕ → ℝ) (P : ℕ → ℝ → Prop),
    (∀ (m : ℕ) (N : ℕ), ∃ k : ℕ, (N ≤ k)%nat ∧ (P m (a k))) ⇒
      ∃ f : ℕ → ℕ → ℕ, ∀ (m : ℕ) (N : ℕ), (N ≤ f m N)%nat ∧ P m (a (f m N)).
Proof.
    Take a : (ℕ → ℝ).
    Take P : (ℕ → ℝ → Prop).
    Assume that (for all m N : ℕ, there exists k : ℕ , (N ≤ k)%nat ∧ P m (a k)).
    We claim that (∀ (m : ℕ),  ∃ g : ℕ → ℕ, ∀ N : ℕ, (N ≤ g N)%nat ∧ (P m (a (g N)))).
    {
        Take m : ℕ.
        apply choice with (R := fun (k : ℕ) (l : ℕ) ↦ ((k ≤ l)%nat ∧ P m (a l))).
        We conclude that (for all x : ℕ, there exists y : ℕ, (x ≤ y)%nat ∧ P m (a y)).
    }
    apply choice with (R := fun (m : ℕ) (h : ℕ → ℕ) ↦ ( ∀ N : ℕ, (N ≤ h N)%nat ∧ P m (a (h N)) ) ).
    We conclude that (for all x : ℕ, there exists y : ℕ ⇨ ℕ , for all N : ℕ, (N ≤ y N)%nat ∧ P x (a (y N))).
Qed.*)

Definition create_seq_from_vec_0 (A : Type) (a : A) :=
    fun (n : nat) => a.

Definition create_seq_from_vec (A : Type)
              (k : ℕ) (g : ℕ → A) (a : A) (n : ℕ) :=
    if lt_dec n (k)%nat (* if n < k *)
      then (g n)
      else a.

Local Parameter Q : nat -> Prop.
Definition Z := fun (n : nat) => True.

Definition test00 := fun (n0 : nat) => Q.
Locate "{".

(* Definition test000 : forall A : Type,  { n  | (n >= 5)%nat}%type.*)
(*Definition test0000 : forall A : Type,  @sig nat (fun (n : nat) => True).*)
(**

*)
Definition complete_induction_help (A : Type) (a : A)
  (Su : (ℕ → A) → ℕ → A): ℕ → (ℕ → A).
Proof.
  intro m.
  induction m as [|m prev_func].
  * exact (fun n : ℕ => a).
  * exact (fun n : ℕ => if lt_dec n (S m) then (prev_func n) else
      Su prev_func m).
Defined.

Lemma le0_impl_0 : forall k : nat, (k <= 0)%nat -> k = O.
Proof.
  intro k.
  auto with zarith.
Defined.

(* Definition complete_induction_type_family_help (A : Type) (a : A)
  (Su : (ℕ → A) → ℕ → A): ℕ → (ℕ → A).
Proof.
  intro m.
  induction m as [|m prev_func].
  * exact (fun n : ℕ => a).
  * exact (fun n : ℕ => if le_lt_dec n m then (prev_func n) else
      Su prev_func n).
Defined.*)

Definition complete_induction (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): (ℕ → A).
Proof.
  exact (fun n : ℕ => (complete_induction_help A a Su) n n).
Defined.

Lemma complete_induction_help_compare_3 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): forall k : nat,
  complete_induction_help A a Su (S k)=
  (fun n : ℕ => if lt_dec n (S k) then
  ((complete_induction_help A a Su k) n) else
      Su (complete_induction_help A a Su k) k).
Proof.
  intro k.
  reflexivity.
Qed.

Lemma complete_induction_help_compare_4 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A) (prev_func : nat -> A): forall k : nat,
  (fun n : ℕ => if lt_dec n (S k) then
  (prev_func n) else
      Su prev_func k) (S k) = Su prev_func k.
Proof.
  intro k.
  change ((if lt_dec (S k) (S k) then prev_func (S k)
  else Su prev_func k) = Su prev_func k).
  destruct (lt_dec (S k) (S k)).
  assert (con : False) by auto with zarith.
  destruct con.
  reflexivity.
Qed.

Lemma complete_induction_help_compare_5 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A) (prev_func : nat -> A): forall k : nat,
  (fun n : ℕ => if lt_dec n (S k) then
  (prev_func n) else
      Su prev_func k) =
      create_seq_from_vec A (S k) prev_func (Su prev_func k).
Proof.
  intro k.
  unfold create_seq_from_vec.
  reflexivity.
Qed.

Lemma complete_induction_help_compare_6 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): forall k : nat,
  complete_induction_help A a Su (S k) =
    create_seq_from_vec A (S k)
      (complete_induction_help A a Su k)
      (Su (complete_induction_help A a Su k) k).
Proof.
  intro k.
  unfold create_seq_from_vec.
  reflexivity.
Qed.

(*Lemma complete_induction_help_compare_6 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): forall l : nat,
  complete_induction_help A a Su l =
    create_seq_from_vec A l
      (complete_induction_help A a Su l)
      (Su (complete_induction_help A a Su l) k).
Proof.
  intro k.
  unfold create_seq_from_vec.
  reflexivity.
Qed.*)

(*Lemma complete_induction_help_compare_3 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): forall k : nat,
  complete_induction_help A a Su (S k) (S k)=
  create_seq_from_vec A k (complete_induction_help A a Su k)
  (Su (complete_induction_help A a Su k) k) (S k).
Proof.
  intro k.
  unfold create_seq_from_vec.
  destruct (le_lt_dec (S k ) k) as [Z1 | Z2].
  assert (H: False) by auto with zarith.
  destruct H.
  Print complete_induction_help.
  simpl.
  destruct k.
  reflexivity.
  simpl.
  destruct k.
  simpl.
  auto.
  destruct (le_lt_dec k (S k)).
  cbn.
  unfold complete_induction_help.
  destruct (le_lt_dec k (S k)) as [Z3 | Z4].

  simpl. cbn.v*)

Definition complete_induction_prop_help (P : nat -> Prop) :
  P O -> (forall k : nat, (forall l : nat, (l <= k)%nat -> P(l)) -> forall l : nat,
    (l <= S k)%nat -> P(l) ) -> forall k : nat, forall l : nat, (l <= k)%nat -> P l.
intros H1 H2.
induction k as [| k IHk].
* intro l.
  intro l_le_0.
  pose (e := le0_impl_0 l l_le_0).
  rewrite e.
  exact H1.
* apply H2.
  apply IHk.
Defined.

Definition from_small_to_large_ind (P : nat -> Prop) :
(forall k : nat, (forall l : nat, (l <= k)%nat -> P(l)) ->
  P (S k) ) -> (forall k : nat, (forall l : nat, (l <= k)%nat -> P(l)) -> forall l : nat,
(l <= S k)%nat -> P(l) ).
Proof.
  intro H.
  intro k.
  intro H1.
  intro l.
  intro H2.
  destruct (lt_eq_lt_dec l (S k)) as [H3 | H4].
  destruct H3 as [H5 | H6].
  assert (H7 : (l <=k)%nat ) by (auto with zarith).
  auto.
  rewrite H6.
  apply H.
  assumption.
  auto with zarith.
Defined.

Definition complete_induction_prop (P : nat -> Prop) :
  P O -> (forall k : nat,
  (forall l : nat, (l <= k)%nat -> P(l)) ->
  P(S k) ) -> forall k : nat, P k.
Proof.
intros H1 H2.
intro k.
apply (complete_induction_prop_help P H1 (from_small_to_large_ind P H2)
  k k).
  trivial.
Defined.
Require Import Arith.Wf_nat.

Lemma complete_induction_help_compare_1 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): forall k : nat,
      (complete_induction_help A a Su (S k) k =
      complete_induction_help A a Su (k) k).
Proof.
  intro k.
  simpl.
  destruct (lt_dec k (S k)).
  * reflexivity.
  * assert (H: False) by auto with zarith.
    destruct H.
Defined.

Lemma complete_induction_help_compare_2 (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): forall k : nat, forall l : nat, (l <= k)%nat ->
      (complete_induction_help A a Su (S k) l =
      complete_induction_help A a Su (l) l).
      Proof.
  intro k.
  intro l.
  induction k as [|k IHk].
  intro l_le_0.
  assert (l_eq_0 : (l = 0)%nat) by auto with zarith.
  rewrite l_eq_0.
  simpl.
  reflexivity.
  intro l_le_Sk.
  destruct (lt_dec l (S k)).
  rewrite <- IHk.
  simpl.
  destruct (lt_dec l (S (S k))).
  destruct (lt_dec l (S k)).
  reflexivity.
  reflexivity.
  assert (H : False) by auto with zarith.
  destruct H.
  auto with zarith.
  assert (H1 : l = S k) by auto with zarith.
  rewrite H1.
  apply complete_induction_help_compare_1.
Qed.

Lemma complete_induction_help_compare (A : Type) (a : A)
(Su : (ℕ → A) → ℕ → A): forall k : nat, forall l : nat,
    (l <= k)%nat ->
      (complete_induction_help A a Su k l =
      complete_induction A a Su l).
Proof.
  unfold complete_induction.
  intro k. intro l. intro l_le_k.
  destruct (lt_eq_lt_dec l k) as [Z1 | Z2].
  destruct Z1 as [Z3 | Z4].
  set (m := (k - 1)%nat).
  assert (H : k = S m) by auto with zarith.
  rewrite H.
  apply complete_induction_help_compare_2.
  auto with zarith.
  rewrite Z4.
  reflexivity.
  assert (H : False) by auto with zarith.
  destruct H.
Defined.

Lemma new_induction_principle :  forall A : Type,
  forall P : (nat -> A) -> nat -> Prop,
  (forall f g : nat -> A, forall k : nat, (forall l : nat, (l <= k)%nat -> f l = g l) -> P f k -> P g k) ->
  forall Su : (nat -> A) -> nat -> A,
  forall a : A, forall w : P (fun n : nat => a) 0%nat,
  (forall k : nat,
    (forall l : nat, (l <= k)%nat -> P ((complete_induction_help A a Su) l) l)
    -> P ((complete_induction_help A a Su) (S k)) (S k))
  -> forall k : nat, P (complete_induction A a Su) k.
Proof.
  intros A P H_ext Su a w H_ind.
  intro k.
  apply (H_ext (complete_induction_help A a Su (k))
    (complete_induction A a Su)).
  unfold complete_induction.
  apply complete_induction_help_compare.
  induction k as [|k IHk] using complete_induction_prop.
  simpl.
  exact w.
  apply H_ind.
  apply IHk.
Qed.

(*Goal forall A : Type,
  forall P : (nat -> A) -> nat -> Prop,
  forall Su : (nat -> A) -> nat -> A,
  forall a : A, forall w : P (fun n : nat => a) 0%nat,
  (forall k : nat,
    (forall l : nat, (l <= k)%nat -> P ((complete_induction_help A a Su) l) l)
    -> P ((complete_induction_help A a Su) (S k)) (S k))
  -> forall k : nat, P (complete_induction A a Su) k.
Proof.
  intros A P Su a w H_ind.
  intro k.
  unfold complete_induction.
  apply (H_ext (complete_induction_help A a Su (k))
    (complete_induction A a Su)).
  unfold complete_induction.
  apply complete_induction_help_compare.
  induction k as [|k IHk] using complete_induction_prop.
  simpl.
  exact w.
  apply H_ind.
  apply IHk.
Qed.*)

(*Definition test : ∀ A : Type, ∀ (P : (ℕ → A) → ℕ → Prop),
  (∀ f g : (ℕ → A), ∀ l : ℕ, (∀ k : ℕ, (k ≤ l)%nat ⇒ f k = g k )⇒ P f l ⇒ P g l) ⇒
  {n_0 | P (create_seq_from_vec_0 A n_0) 0%nat} ⇒
  (∀ n : ℕ → A, ∀ k : ℕ,
  { n_k_plus_1 | (∀ l : ℕ, (l ≤ k)%nat ⇒ P n l) ⇒ P (create_seq_from_vec A k n n_k_plus_1) (S k) }%type)
  ⇒ { h | ∀ k : ℕ, P h k}.*)

  (*Definition test : ∀ A : Type, ∀ (P : (ℕ → A) → ℕ → Prop),
  (∀ f g : (ℕ → A), ∀ l : ℕ, (∀ k : ℕ, (k ≤ l)%nat ⇒ f k = g k )⇒ P f l ⇒ P g l) ⇒
  {n_0 | P (create_seq_from_vec_0 A n_0) 0%nat} ⇒
  (∀ n : ℕ → A, ∀ k : ℕ,
  { n_k_plus_1 | (∀ l : ℕ, (l ≤ k)%nat ⇒ P n l) ⇒ P (create_seq_from_vec A k n n_k_plus_1) (S k) }%type)
  ⇒ { h | ∀ k : ℕ, P h k}.*)

(*
We need that for all k, all l <=S k
complete_induction_help A n_0 Su (l) =
  (create_seq_from_vec A k (complete_induction_help A n_0 Su k) n_k_plus_1) (l)
*)

Definition test : ∀ A : Type, ∀ (P : (ℕ → A) → ℕ → Prop),
  (∀ f g : (ℕ → A), ∀ l : ℕ, (∀ k : ℕ, (k ≤ l)%nat ⇒ f k = g k )⇒ P f l ⇒ P g l) ⇒
  {n_0 | P (create_seq_from_vec_0 A n_0) 0%nat} ⇒
  (∀ n : ℕ → A, ∀ k : ℕ,
  { n_k_plus_1 | (∀ l : ℕ, (l ≤ k)%nat ⇒ P n l) ⇒ P (create_seq_from_vec A (S k) n n_k_plus_1) (S k) }%type)
  ⇒ { h | ∀ k : ℕ, P h k}.
Proof.
intros A P H_ext n_0_w_proof Su_full.
set (Su := (fun (n : ℕ → A) (k : ℕ) => @proj1_sig _ _ (Su_full n k))).
set (h_help := (complete_induction_help A (proj1_sig n_0_w_proof)
Su)).
set (h := (complete_induction A (proj1_sig n_0_w_proof)
  Su)).
exists h.
apply new_induction_principle.
assumption.
destruct n_0_w_proof as [n_0 w_n_0].
simpl.
exact w_n_0.
destruct n_0_w_proof as [n_0 w_n_0].
simpl.
intro k.
intro H1.
set (n_k_plus_1 := @proj1_sig _ _ (Su_full (complete_induction_help A n_0 Su k) k)).
assert (H0 : n_k_plus_1 = Su (complete_induction_help A n_0 Su k) k) by trivial.
destruct (Su_full (complete_induction_help A n_0 Su k) k) as
  [p_n_k_plus_1 w_Su_full].
assert (H3 : n_k_plus_1 = p_n_k_plus_1).
trivial.
rewrite <- H0.

unfold create_seq_from_vec in w_Su_full.
rewrite H3.
apply w_Su_full.
intro l.
intro l_le_k.
apply (H_ext (complete_induction_help A n_0 Su l)).
intro q.
intro q_le_l.
assert (q_le_k : (q <= k)%nat) by auto with zarith.
rewrite (complete_induction_help_compare A n_0 Su l q).
rewrite (complete_induction_help_compare A n_0 Su k q).
reflexivity.
assumption.
assumption.
apply H1.
assumption.
Defined.

Definition test2 : ∀ A : Type, ∀ (P : (ℕ → A) → ℕ → Prop),
  (∀ f g : (ℕ → A), ∀ l : ℕ, (∀ k : ℕ, (k ≤ l)%nat ⇒ f k = g k )⇒ P f l ⇒ P g l) ⇒
  forall n_0 : A, P (create_seq_from_vec_0 A n_0) 0%nat ⇒
  (∀ n : ℕ → A, ∀ k : ℕ,
  { n_k_plus_1 | (∀ l : ℕ, (l ≤ k)%nat ⇒ P n l) ⇒ P (create_seq_from_vec A (S k) n n_k_plus_1) (S k) }%type)
  ⇒ { h | ∀ k : ℕ, P h k}.
Proof.
intros A P H_ext n_0 w_n_0 Su_full.
set (Su := (fun (n : ℕ → A) (k : ℕ) => @proj1_sig _ _ (Su_full n k))).
set (h_help := (complete_induction_help A n_0
Su)).
set (h := (complete_induction A n_0
  Su)).
exists h.
apply new_induction_principle.
assumption.
(*destruct n_0_w_proof as [n_0 w_n_0].*)
simpl.
exact w_n_0.
(*destruct n_0_w_proof as [n_0 w_n_0].*)
simpl.
intro k.
intro H1.
set (n_k_plus_1 := @proj1_sig _ _ (Su_full (complete_induction_help A n_0 Su k) k)).
assert (H0 : n_k_plus_1 = Su (complete_induction_help A n_0 Su k) k) by trivial.
destruct (Su_full (complete_induction_help A n_0 Su k) k) as
  [p_n_k_plus_1 w_Su_full].
assert (H3 : n_k_plus_1 = p_n_k_plus_1).
trivial.
rewrite <- H0.

unfold create_seq_from_vec in w_Su_full.
rewrite H3.
apply w_Su_full.
intro l.
intro l_le_k.
apply (H_ext (complete_induction_help A n_0 Su l)).
intro q.
intro q_le_l.
assert (q_le_k : (q <= k)%nat) by auto with zarith.
rewrite (complete_induction_help_compare A n_0 Su l q).
rewrite (complete_induction_help_compare A n_0 Su k q).
reflexivity.
assumption.
assumption.
apply H1.
assumption.
Defined.

(* Construct a subsequence with a certain property ... *)

Definition myP (myQ: nat->nat->Prop) (n : nat -> nat) k : Prop :=
  match k with
  | O => myQ (n O) O
  | S m => ((n k) > n (Nat.pred k))%nat /\ (myQ (n k) k)
  end.

Lemma help_test_1 : forall (myQ: nat->nat->Prop),
forall (f g : ℕ ⇨ ℕ)(l : ℕ),
(for all k : ℕ,
   (k ≤ l)%nat ⇨ f (k) = g (k)) ⇨ myP myQ f l ⇨ myP myQ g l.
Proof.
  intros myQ f g l.
  intro H.
  unfold myP.
  intro myPf.
  destruct l.
  rewrite <- H.
  apply myPf.
  trivial.
  rewrite <- H.
  rewrite <- (H (Nat.pred (S l))).
  apply myPf.
  auto with zarith.
  auto with zarith.
Qed.

Definition test3 : ∀ (myQ : nat->nat->Prop),
  { n_0 | myQ n_0 O } ⇒
  (∀ n : ℕ → nat, ∀ k : ℕ,
  { n_k_plus_1 | (∀ l : ℕ, (l ≤ k)%nat ⇒ myP myQ n l) ⇒ myP myQ (create_seq_from_vec nat (S k) n n_k_plus_1) (S k) }%type)
  ⇒ { h | ∀ k : ℕ, myP myQ h k}.
Proof.
  intros myQ n_0_w_proof H_ind.
  apply test.
  apply help_test_1.
  destruct n_0_w_proof as [n_0 w_n_0].
  exists n_0.
  unfold create_seq_from_vec_0.
  exact w_n_0.
  exact H_ind.
Defined.

Lemma test1:
  { h | ∀ k : ℕ, myP h k }.
Proof.
  apply test.
  admit.
  admit.
  destruct.
  exists.

intro m.
induction m as [|m IHm].
destruct X as [x prop_x].
exact x.

exact match n with
| O => n_0
| S k => n_k_plus_1

(** The next definition captures what it means to be an index sequence.*)
Definition is_index_seq (n : ℕ → ℕ) :=
    ∀ k : ℕ, (n k < n (S k))%nat.
(** Given the function that produces 'good' elements, we can use it to construct a subsequence by induction.*)
Fixpoint create_seq
  (f : ℕ → ℕ → ℕ) (l : ℕ) :=
  match l with
  | O => f O O
  | S k => f l (S (create_seq f k))
  end.

(** If the function that produces 'good' elements is such that the produced elements are far enough in the sequence, it is certain that the produced sequence is an index sequence.*)
Lemma created_seq_is_index_seq :
  ∀ (g : ℕ → ℕ → ℕ),
    (∀ (m N : ℕ), (g m N ≥ N)%nat ) ⇒
      is_index_seq (create_seq g).
Proof.
    Take g : (ℕ → ℕ → ℕ).
    Assume that (∀ (m N : ℕ), (g m N ≥ N)%nat) (i).
    Expand the definition of is_index_seq.
    That is, write the goal as (for all k : ℕ, (create_seq g k < create_seq g (S k))%nat).
    Take k : ℕ.
    By (i) it holds that (g (S k) (S (create_seq g k)) ≥ S(create_seq g k))%nat.
    We conclude that (& create_seq g k < g (S k) (S (create_seq g k)) = create_seq g (S k))%nat.
Qed.

(**
The next lemma records that indeed the elements in the subsequence satisfy the desired property.*)
Lemma subseq_sat_rel :
  ∀ (a : ℕ → ℝ) (g : ℕ → ℕ → ℕ) (P : ℕ → ℝ → Prop),
    (∀ m N : ℕ, P m (a (g m N)) ) ⇒
      ∀ k : ℕ, P k (a (create_seq g k)).
Proof.
    Take a : (ℕ → ℝ).
    Take g : (ℕ → ℕ → ℕ).
    Take P : (ℕ → ℝ → Prop).
    Assume that (∀ m N : ℕ, P m (a (g m N))) (i).
    induction k. (*TODO: if we use 'We use induction on k.'-tacftic, then we cannot directly match on k + 1 *)
    - We need to show that (P 0%nat (a (g 0%nat 0%nat))).
      By (i) we conclude that (P 0%nat (a (g 0%nat 0%nat))).
    - We need to show that (P (S k) (a (g (S k) (S (create_seq g k))))).
      By (i) we conclude that (P (S k) (a (g (S k) (S (create_seq g k))))).
Qed.

Lemma exists_good_subseq :
  ∀ (a : ℕ → ℝ) (P : ℕ → ℝ → Prop),
    (∀ (m : ℕ) (N : ℕ), ∃ k : ℕ, (N ≤ k)%nat ∧ (P m (a k))) ⇒
      ∃ n : ℕ → ℕ, is_index_seq n ∧ ∀ k : ℕ, P k (a (n k)).
Proof.
    Take a : (ℕ → ℝ).
    Take P : (ℕ → ℝ → Prop).
    Assume that (for all m N : ℕ, there exists k : ℕ , (N ≤ k)%nat ∧ P m (a k)).
    By existence_next_el_to_fun it holds that
      (∃ g : ℕ → ℕ → ℕ, ∀ (m : ℕ) (N : ℕ), (N ≤ g m N)%nat ∧ P m (a (g m N))) (i).
    Obtain g according to (i), so for g : ℕ → ℕ → ℕ it holds that
      (∀ (m : ℕ) (N : ℕ), (N ≤ g m N)%nat ∧ P m (a (g m N))) (ii).
    Choose n := (create_seq g).
    We show both statements.
    - We need to show that (is_index_seq n).
      We need to show that (is_index_seq (create_seq g)).
      By created_seq_is_index_seq it suffices to show that
        (for all m N : ℕ, (g m N ≥ N)%nat).
      Take m, M : nat.
      By (ii) it holds that ((M ≤ g m M)%nat ∧ P m (a (g m M))).
      We conclude that (M <= g m M)%nat.
    - We need to show that (for all k : ℕ, P k (a (n k))).
      We need to show that (for all k : ℕ, P k (a ((create_seq g) k))).
      Fail By subseq_sat_rel it suffices to show that (for all m N : ℕ, P m (a (g m N))). (*TODO: fix*)
      apply subseq_sat_rel.
      Take m : ℕ.
      Take M : ℕ.
      By (ii) it holds that ((M ≤ g m M)%nat ∧ P m (a (g m M))) (iii).
      Because (iii) both (M ≤ g m M)%nat and (P m (a (g m M))) hold.
      We conclude that (P m (a (g m M))).
Qed.

Definition is_increasing (f : ℕ → ℕ) :=
  ∀ k : ℕ, (f k ≤ f (S k))%nat.
Lemma incr_loc_to_glob :
  ∀ g : ℕ → ℕ,
    is_increasing g
      ⇒ (∀ k l : ℕ, (k ≤ l)%nat ⇒ (g k ≤ g l)%nat).
Proof.
    Take g : (ℕ → ℕ).
    Expand the definition of is_increasing.
    That is, write the goal as ((for all k : ℕ, (g k ≤ g (S k))%nat)
      ⇨ for all k l : ℕ, (k ≤ l)%nat ⇨ (g k ≤ g l)%nat).
    Assume that (∀ k : ℕ, (g k ≤ g (S k))%nat).
    Take k : ℕ.
    induction l as [|l IH_l].

    (** We first need to show that if $k \leq 0$ then $(f (k) \leq f(0))$.*)
    Assume that (k ≤ 0)%nat.
    It holds that (k = 0)%nat.
    We conclude that (& g k = g 0 <= g 0)%nat.

    (** Next, we need to show that if $k \leq S (l)$ then $f(k) \leq f(S (l))$.*)
    Assume that (k ≤ S l)%nat.
    destruct (lt_eq_lt_dec k (S l)) as [temp | k_gt_Sl].
    destruct temp as [k_lt_Sl | k_eq_Sl].
    (** We first consider the case that $k < S(l)$.*)
    It holds that (k ≤ l)%nat.
    By IH_l it holds that (g k ≤ g l)%nat.
    It holds that (g l ≤ g (S l))%nat.
    We conclude that (g k <= g (S l))%nat.
    (** We now consider the case $k = S(l)$. We need to show that $f(k) \leq f(S(l))$. *)
    We conclude that (& g k = g (S l) <= g (S l))%nat.
    (** Finally we consider the case $k > S(l)$. However, this case is in contradiction with $k \leq S(l)$. *)
    It holds that (¬(S l < k)%nat).
    Contradiction.
Qed.

Lemma index_seq_strictly_incr :
  ∀ n : ℕ → ℕ, is_index_seq n ⇒ (is_increasing (fun (k : ℕ) ↦ (n k - k)%nat)).
Proof.
    Take n : (ℕ → ℕ); such that (is_index_seq n) (i).
    Expand the definition of is_increasing.
    That is, write the goal as (for all k : ℕ, (n k - k ≤ n (S k) - S k)%nat).
    Take k : ℕ.
    Expand the definition of is_index_seq in (i).
    That is, write (i) as (for all k0 : ℕ, (n k0 < n (S k0))%nat).
    It holds that (n k < n (S k))%nat.
    We conclude that (n k - k ≤ n (S k) - S k)%nat.
Qed.

Lemma index_seq_grows_0 :
  ∀ n : ℕ → ℕ, is_index_seq n ⇒ ∀ k : ℕ, (n k ≥ k)%nat.
Proof.
    Take n : (ℕ → ℕ); such that (is_index_seq n) (i).
    induction k as [|k IH].
    - We conclude that (n 0 >= 0)%nat.
    - Expand the definition of is_index_seq in (i).
      That is, write (i) as (for all k0 : ℕ, (n k0 < n (S k0))%nat).
      It holds that (n k < n (S k))%nat.
      We conclude that (n (S k) ≥ S k)%nat.
Qed.

Lemma index_seq_grows :
  ∀ n : ℕ → ℕ, is_index_seq n ⇒ (∀ k l : ℕ, (k ≤ l)%nat ⇒ (n k - k ≤ n l - l)%nat).
Proof.
    Take n : (ℕ → ℕ); such that (is_index_seq n).
    Define g := (fun (k : ℕ) ↦ (n k - k)%nat).
    By index_seq_strictly_incr it holds that (is_increasing g).
    By incr_loc_to_glob it holds that (∀ k l : ℕ, (k ≤ l)%nat ⇒ (g k ≤ g l)%nat).
    Take k : ℕ and l : ℕ; such that(k ≤ l)%nat.
    We need to show that (g k <= g l)%nat.
    We conclude that (g k <= g l)%nat.
Qed.

(** ## Constructing a subsequence with elements satisfying a particular property

Given a property $P : \mathbb{N} → \mathbb{R} → \mathrm{Prop}$, and given that it holds for infinitely many elements in the sequence, we want to find a subsequence with all elements satisfying the property. *)
(** ### Finding the smallest element satisfying the property

This seems to require some decidability on the property*)
Fixpoint first_satisfying_element_helper
  (rel : ℕ → ℕ → bool)
  (k : ℕ)
  (N : ℕ) :=
  match k with
  | O => N
  | S l => if (rel (N-k)%nat (N-k)%nat)
                then k
                else (first_satisfying_element_helper rel l N)
  end.
Definition first_satisfying_element
  (rel : ℕ → ℕ → bool)
  (l : ℕ)
  (N : ℕ)
  := first_satisfying_element_helper rel (N-l) N.
(** ### From infinitely many elements to a function producing those elements*)
Lemma inf_el_to_fun :
  ∀ (a : ℕ → ℝ) (P : ℕ → ℝ → Prop),
    (∀ N : ℕ, ∃ k : ℕ, (N ≤ k)%nat ∧ (P N (a k))) ⇒
      ∃ f : ℕ → ℕ, ∀ l : ℕ, (l ≤ f l)%nat ∧ P l (a (f l)).
Proof.
    Take a : (ℕ → ℝ).
    Take P : (ℕ → ℝ → Prop).
    apply choice with (R := fun (k : ℕ) (l : ℕ) ↦ ((k ≤ l)%nat ∧ P k (a l))).
Qed.

Fixpoint seq_of_max (f : ℕ → ℕ) (l : ℕ) :=
  match l with
  | O => f O
  | S k => Nat.max (f l) (seq_of_max f k)
  end.

(** ### The sequence of maxima is increasing*)
Lemma seq_of_max_is_increasing :
  ∀ g : ℕ → ℕ, is_increasing (seq_of_max g).
Proof.
    Take g : (ℕ → ℕ).
    Expand the definition of is_increasing.
    That is, write the goal as (for all k : ℕ, (seq_of_max g k ≤ seq_of_max g (S k))%nat).
    Take k : ℕ.
    We need to show that (seq_of_max g k ≤ Nat.max (g (S k)) (seq_of_max g k))%nat.
    We conclude that (seq_of_max g k ≤ Nat.max (g (S k)) (seq_of_max g k))%nat.
Qed.

Lemma elements_le_seq_of_max_pre :
  ∀ (g : ℕ → ℕ) (n : ℕ),
    (g n ≤ seq_of_max g n)%nat.
Proof.
    Take g : (ℕ → ℕ).
    induction n as [|n IH_n].
    (** We first consider the base case $n=0$.*)
    Expand the definition of seq_of_max.
    That is, write the goal as ((g 0 ≤ g 0)%nat).
    (** We need to show that $f( 0 ) \leq f( 0)$.*)
    We conclude that (g 0 ≤ g 0)%nat.
    (** Next we consider the general case. We need to show that $f(S(n))\leq \mathsf{seqofmax}(f, S(n))$. *)
    Expand the definition of seq_of_max.
    That is, write the goal as ((g (S n) ≤ Nat.max (g (S n))
     ((fix seq_of_max (f : ℕ ⇨ ℕ) (l : ℕ) {struct l} : ℕ :=
         match l with
         | 0 => f 0
         | S k => Nat.max (f l) (seq_of_max f k)
         end) g n))%nat).
    (** By the definition of $\mathsf{seqofmax}(f,S(n))$ as the maximum of $f(S(n))$ and another number, this*)
    We conclude that (g (S n) ≤ Nat.max (g (S n))
     ((fix seq_of_max (f : ℕ ⇨ ℕ) (l : ℕ) {struct l} : ℕ :=
         match l with
         | 0 => f 0
         | S k => Nat.max (f l) (seq_of_max f k)
         end) g n))%nat.
Qed.

Lemma elements_le_seq_of_max :
  ∀ (g : ℕ → ℕ) (n : ℕ) (k : ℕ),
    (k ≤ n)%nat ⇒ (g k ≤ seq_of_max g n)%nat.
Proof.
    Take g : (ℕ → ℕ).
    Take n : ℕ and k : ℕ; such that (k ≤ n)%nat.
    By elements_le_seq_of_max_pre it holds that (g k ≤ seq_of_max g k)%nat.
    We claim that (seq_of_max g k ≤ seq_of_max g n)%nat.
    { By incr_loc_to_glob it suffices to show that (is_increasing (seq_of_max g)).
      By seq_of_max_is_increasing we conclude that (is_increasing (seq_of_max g)).
    }
    We conclude that (& g k <= seq_of_max g k <= seq_of_max g n)%nat.
Qed.

(** ### From a function producing the correct elements to an index sequence*)
Fixpoint build_seq
  (f : ℕ → ℕ)
  (k : ℕ) :=
  match k with
  | O => f O
  | S m => f (S (seq_of_max f (build_seq f m)))
  end.
Lemma built_seq_is_index_seq :
  ∀ g : ℕ → ℕ,
    (∀ k : ℕ, (g k ≥ k)%nat) ⇒
      is_index_seq (build_seq g).
Proof.
    Take g : (ℕ → ℕ).
    Assume that (for all k : ℕ, (g k ≥ k)%nat).
    Expand the definition of is_index_seq.
    That is, write the goal as (for all k : ℕ, (build_seq g k < build_seq g (S k))%nat).
    Take k : ℕ.
    We need to show that (build_seq g k < g (S (seq_of_max g (build_seq g k))))%nat.
    It holds that (g( S(seq_of_max g (build_seq g k)))≥ S(seq_of_max g (build_seq g k)))%nat.
    It holds that (g( S(seq_of_max g (build_seq g k)))> seq_of_max g (build_seq g k))%nat.
    By elements_le_seq_of_max_pre it holds that (seq_of_max g (build_seq g k) ≥ g(build_seq g k))%nat.
    It holds that (g(build_seq g k) ≥ build_seq g k)%nat.
    We conclude that (& build_seq g k <= g(build_seq g k)
                                      <= seq_of_max g (build_seq g k)
                                      <  g( S(seq_of_max g (build_seq g k))))%nat.
Qed.
(** ### Subsequence satisfies relation*)


From SepLogic Require Import SepSet.

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

Require Import tree.

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

Require Import freefresh.

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

Require Import fresh.

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

Definition ident := nat.

(****************************************************************)
(* Raisonnement pour gensym avec la SL sur liste minimaliste *)

Section WP.

Variable (X: Type).

Fixpoint wp (m: Free Fresh X)(Q: X -> iProp): iProp :=
  match m with
  | ret v => Q v
  | op (gensymOp _) k => ∀ (v: nat), & v -∗ wp (k v) Q
  end.

End WP.

Arguments wp [_] m Q.

Local Open Scope free_monad_scope.

Lemma wp_bind {X Y} (e : Free Fresh X) (f :  X → Free Fresh Y) (Q : Y -> iProp) (Q' : X -> iProp) :
  wp e Q' ⊢
  (∀ v,  Q' v -∗ wp (f v) Q ) -∗
  wp (do v <- e; f v) Q %I.
Proof.
iIntros "HA HB". revert e. fix e 1.
destruct e0.
- iApply "HB". iApply "HA".
- destruct f0; simpl.
  iIntros (l) "HC".
  iDestruct ("HA" with "HC") as "HA".
  iPoseProof "HB" as "HB".
  apply e.
Qed.

Lemma wp_consequence {X} (P Q : X -> iProp) (f : Free Fresh X) :
  ⊢ wp f P -∗
    (∀ x, P x -∗ Q x) -∗
    wp f Q.
Proof.
induction f as [v | Y [] k]; simpl; intros; auto.
- iIntros "HA HB". iApply ("HB" with "HA").
- iIntros "HA HB * HC". iDestruct ("HA" with "HC") as "HA".
  iApply (H with "HA HB").
Qed.

Notation "{{ P }} m {{ v ; Q }}" := (P ⊢ wp m (fun v => Q))
                                      (at level 20,
                                        format "'[hv' {{  P  }}  '/  ' m  '/'  {{  v ;  Q  }} ']'").

Lemma ret_spec {X} (v : X) H (Q : X -> iProp) :
  (H ⊢ Q v) -> {{ H }} (ret v : Free Fresh X) {{ v'; Q v' }}.
Proof. simpl; iIntros. iApply H0; auto. Qed.

Lemma bind_spec {X Y} (e : Free Fresh X) (f : X -> Free Fresh Y) Q Q' (H : iProp) :
  ({{ H }} e {{ v; Q' v }}) ->
  (∀ v, {{ Q' v }} f v {{ v'; Q v' }}) ->
  {{ H }} do v <- e; f v {{ v; Q v}}.
Proof.
  intros. iIntros "HA".
  iApply (wp_bind e f _ Q' with "[HA]").
  - iApply (H0 with "[HA]"); auto.
  - iIntros (v) "HC". iApply (H1 with "[HC]"); auto.
Qed.

Section Rules.

Variable X: Type.
Implicit Type P: iProp.
Implicit Type Q: X -> iProp.

Lemma rule_consequence: forall P P' Q Q' m,

  ({{ P' }} m {{ v; Q' v }}) ->
  (P ⊢ P') ->
  (forall v, Q' v ⊢ Q v) ->
 (*-----------------------*)
  {{ P }} m {{ v; Q v }}.
Proof.
  intros. iIntros "HA". iDestruct (H0 with "HA") as "HA".
  iDestruct (H with "HA") as "HA". iApply (wp_consequence with "HA").
  iIntros "*". iApply H1.
Qed.

Lemma frame_bind : forall (P : iProp), ⊢ P -∗ emp ∗ P.
Proof. iIntros "* $". Qed.

Lemma frame: forall P Q P' m,

  ({{ P }} m {{ v; Q v }}) ->
  (*----------------------------*)
  {{ P ∗ P' }} m {{ v; Q v ∗ P' }}.
Proof.
  intros. iIntros "[HA HC]". iApply (wp_consequence with "[HA]").
  iApply H; auto. iIntros; iFrame.
Qed.

End Rules.

Lemma intro_true_r {X} (H : iProp) Q (e : Free Fresh X) :
  ({{ emp ∗ H }} e {{ v; Q v }}) ->
  {{ H }} e {{ v; Q v }}.
Proof.
  intro P. iIntros "HA". iApply (P with "[HA]"). iFrame.
Qed.

Lemma rule_gensym : {{ emp }} gensym tt {{ ident; & ident }}.
Proof. simpl.  iIntros "H" (v) "H2". iFrame. Qed.

Ltac Frame := eapply intro_true_r; eapply frame.
Ltac iRet := eapply ret_spec; auto.
Ltac iBind := eapply bind_spec; [idtac | intro; idtac].

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

Fixpoint inject n : gset positive :=
  match n with
  | 0 => ∅
  | S m => {[ encode m ]} ∪ (inject m)
  end.

Lemma ord_disjoint : forall n v, v >= n -> encode v ∉ inject n.
Proof.
  induction n; simpl.
  - intros. intro P. inversion P.
  - intros. destruct (Nat.eq_dec v n). subst. lia.
    intro P. apply elem_of_union in P. destruct P as [P | P].
    + inversion P. rewrite lookup_singleton_ne in H1; auto. inversion H1.
      intro. eapply encode_inj in H0. subst. auto.
    + eapply IHn. 2 : eauto. lia.
Qed.

Lemma next_disjoint : forall n, inject n ## {[ encode n ]}.
Proof.
  intro. apply disjoint_singleton_r. apply ord_disjoint. auto.
Qed.

Lemma soundness {X} : forall (e : Free Fresh X) (Q : X -> iProp) n n' v,
    {{ && (inject n) }} e {{ v; Q v }} ->
    eval e n = (v, n') ->
    && (inject n') ⊢ Q v .
Proof.
  fix e 1.
  destruct e0 as [v | Y [] k]; intros.
  - inversion H0; subst. iApply H.
  - simpl in *. eapply e.
    2 : apply H0.
    + iIntros "HA". simpl.
      iDestruct (heap_ctx_split_sing with "HA") as "[HA HB]". apply next_disjoint.
      iDestruct (H with "HA") as "HA".
      iApply ("HA" with "HB").
Qed.

Lemma adequacy : forall {X} {m: Free Fresh X} {Q},
    {{ emp }} m {{ v; ⌜Q v⌝ }} ->
    Q (run m).
Proof.
intros. unfold run.
apply (soundness_pure (inject (eval m 0).2)).
eapply (soundness m (fun v => ⌜Q v⌝) 0).
iIntros "_"; iApply H; auto.
apply surjective_pairing.
Qed.

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

Fixpoint flatten {X} (t: Tree X) : list X :=
  match t with
  | Leaf v => cons v nil
  | Node l r => flatten l ++ flatten r
  end.

Fixpoint sameShape {X Y} (t1 : Tree X) (t2 : Tree Y) : Prop :=
  match t1,t2 with
  | Leaf _, Leaf _ => True
  | Node l r, Node l_res r_res  => sameShape l l_res /\ sameShape r r_res
  | _, _ => False
  end.

Section Label_spec_aux.

Variable X: Type.
Implicit Type t: Tree X.

Lemma label_spec_aux : forall t,
    {{ emp }}
      label t
    {{ ft; ([∗ list] x ∈ flatten ft, & x) ∗ ⌜sameShape t ft⌝ }}.
Proof.
  induction t.
  - iBind. eapply rule_gensym. iRet. simpl; auto.
  - simpl label. iBind. eapply IHt1. iBind. Frame. eapply IHt2. iRet.
    iIntros "[[HA %] [HB %]]". iSplitL; auto.
    simpl. iApply big_sepL_app. iFrame.
Qed.

End Label_spec_aux.

Lemma sep_list_fold : forall (a : nat) l, ⊢ (& a -∗ ([∗ list] x ∈ l, & x) -∗ ⌜a ∉ l⌝ : iProp).
Proof.
  induction l; iIntros "* HA HB".
  - iPureIntro. intro. inversion H.
  - iDestruct "HB" as "[HA' HB]".
    iDestruct (singleton_neq with "HA HA'") as "%".
    iDestruct (IHl with "HA HB") as "%". iPureIntro.
    intro. inversion H1; subst; auto.
Qed.

Lemma fold_nodup :
  forall idents, ⊢ ([∗ list] i ∈ idents, & (i: ident)) -∗ ⌜NoDup idents⌝.
Proof.
  induction idents; simpl; iIntros "HA".
  - iPureIntro. apply NoDup_nil_2.
  - iDestruct "HA" as "[HA HB]". iDestruct (IHidents with "HB") as "%".
    iDestruct (sep_list_fold with "HA HB") as "%".
    iPureIntro. constructor; auto.
Qed.

Section Relabel_spec.

Variable X: Type.
Implicit Type t: Tree X.
Implicit Type ft: Tree nat.

Lemma label_spec: forall t,
    {{ emp }} label t {{ ft; ⌜NoDup (flatten ft) /\ sameShape t ft⌝ }}.
Proof.
intros.
iApply rule_consequence.
- apply label_spec_aux.
- auto.
- iIntros (v) "H".
  iDestruct "H" as "[H1 H2]".
  iDestruct (fold_nodup with "H1") as "H1".
  iSplit; auto.
Qed.

Lemma relabel_spec : forall t ft,
    relabel t = ft -> NoDup (flatten ft) /\ sameShape t ft.
Proof.
  intros. unfold relabel in H. subst.
  eapply (adequacy (label_spec _)).
Qed.

End Relabel_spec.

Print Assumptions relabel_spec.


From iris.algebra Require Export sts.
From iris.base_logic Require Import lib.own.
From stdpp Require Export gmap.
Set Default Proof Using "Type".

(** The STS describing the main barrier protocol. Every state has an index-set
    associated with it. These indices are actually [gname], because we use them
    with saved propositions. *)
Inductive phase := Low | High.
Record state := State { state_phase : phase; state_I : gset gname }.
Add Printing Constructor state.
Inductive token := Change (i : gname) | Send.

Global Instance stateT_inhabited: Inhabited state := populate (State Low ∅).
Global Instance Change_inj : Inj (=) (=) Change.
Proof. by injection 1. Qed.

Inductive prim_step : relation state :=
  | ChangeI p I2 I1 : prim_step (State p I1) (State p I2)
  | ChangePhase I : prim_step (State Low I) (State High I).

Definition tok (s : state) : set token :=
  {[ t | ∃ i, t = Change i ∧ i ∉ state_I s ]} ∪
  (if state_phase s is High then {[ Send ]} else ∅).
Global Arguments tok !_ /.

Canonical Structure sts := sts.STS prim_step tok.

(* The set of states containing some particular i *)
Definition i_states (i : gname) : set state := {[ s | i ∈ state_I s ]}.

(* The set of low states *)
Definition low_states : set state := {[ s | state_phase s = Low ]}.

Lemma i_states_closed i : sts.closed (i_states i) {[ Change i ]}.
Proof.
  split; first (intros [[] I]; set_solver).
  (* If we do the destruct of the states early, and then inversion
     on the proof of a transition, it doesn't work - we do not obtain
     the equalities we need. So we destruct the states late, because this
     means we can use "destruct" instead of "inversion". *)
  intros s1 s2 Hs1 [T1 T2 Hdisj Hstep'].
  inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
  destruct Htrans as [[] ??|]; done || set_solver.
Qed.

Lemma low_states_closed : sts.closed low_states {[ Send ]}.
Proof.
  split; first (intros [??]; set_solver).
  intros s1 s2 Hs1 [T1 T2 Hdisj Hstep'].
  inversion_clear Hstep' as [? ? ? ? Htrans _ _ Htok].
  destruct Htrans as [[] ??|]; done || set_solver.
Qed.

(* Proof that we can take the steps we need. *)
Lemma signal_step I : sts.steps (State Low I, {[Send]}) (State High I, ∅).
Proof. apply rtc_once. constructor; first constructor; set_solver. Qed.

Lemma wait_step i I :
  i ∈ I →
  sts.steps (State High I, {[ Change i ]}) (State High (I ∖ {[ i ]}), ∅).
Proof.
  intros. apply rtc_once.
  constructor; first constructor; [set_solver..|].
  apply elem_of_equiv=>-[j|]; last set_solver.
  destruct (decide (i = j)); set_solver.
Qed.

Lemma split_step p i i1 i2 I :
  i ∈ I → i1 ∉ I → i2 ∉ I → i1 ≠ i2 →
  sts.steps
    (State p I, {[ Change i ]})
    (State p ({[i1; i2]} ∪ I ∖ {[i]}), {[ Change i1; Change i2 ]}).
Proof.
  intros. apply rtc_once. constructor; first constructor.
  - destruct p; set_solver.
  - destruct p; set_solver.
  - apply elem_of_equiv=> /= -[j|]; last set_solver.
    set_unfold; rewrite !(inj_iff Change).
    assert (Change j ∈ match p with Low => ∅ | High => {[Send]} end ↔ False)
      as -> by (destruct p; set_solver).
    destruct (decide (i1 = j)) as [->|]; first naive_solver.
    destruct (decide (i2 = j)) as [->|]; first naive_solver.
    destruct (decide (i = j)) as [->|]; naive_solver.
Qed.


From Hammer Require Import Hammer.

Require Import Coq.Setoids.Setoid.
Require Import ExtLib.Structures.Proper.

Set Universe Polymorphism.

Class type@{t} (T : Type@{t}) : Type :=
{ equal : T -> T -> Prop
; proper : T -> Prop
}.

Definition type_from_equal@{t} {T : Type@{t}} (r : T -> T -> Prop) : type@{t} T :=
{| equal := r
; proper := fun x => r x x
|}.

Definition type_libniz@{t} (T : Type@{t}) : type@{t} T :=
{| equal := @eq T
; proper := fun _ => True
|}.

Existing Class proper.

Section type.
Universe u.
Context {T : Type@{u}}.
Variable tT : type T.

Class typeOk@{} :=
{ only_proper : forall x y, equal x y -> proper x /\ proper y
; equiv_prefl :> PReflexive proper equal
; equiv_sym :> Symmetric equal
; equiv_trans :> Transitive equal
}.

Global Instance proper_left@{} :
typeOk ->
forall x y : T, equal x y -> proper x.
Proof. hammer_hook "Type" "Type.proper_left".
clear. intros.
match goal with
| H : equal _ _ |- _ => eapply only_proper in H
end; intuition.
Qed.
Global Instance proper_right@{} :
typeOk ->
forall x y : T, equal x y -> proper y.
Proof. hammer_hook "Type" "Type.proper_right".
clear. intros.
match goal with
| H : equal _ _ |- _ => eapply only_proper in H
end; intuition.
Qed.

End type.

Definition type1@{d r z} (F : Type@{d} -> Type@{r}) : Type@{z} :=
forall {T:Type@{d}}, type@{d} T -> type@{r} (F T).

Definition type2@{t u v z} (F : Type@{t} -> Type@{u} -> Type@{v}) : Type@{z} :=
forall {T:Type@{t}}, type T -> forall {U:Type@{u}}, type U -> type (F T U).

Definition type3@{t u v w z} (F : Type@{t} -> Type@{u} -> Type@{v} -> Type@{w}) : Type@{z} :=
forall {T:Type@{t}}, type T -> forall {U:Type@{u}}, type U -> forall {V:Type@{w}}, type V ->  type (F T U V).

Definition typeOk1@{d r z} (F : Type@{d} -> Type@{r}) (tF : type1@{d r z} F) : Type@{z} :=
forall (T : Type@{d}) tT, @typeOk T tT -> typeOk (tF _ tT).

Definition typeOk2@{t u v z}
(F : Type@{t} -> Type@{u} -> Type@{v}) (tF : type2@{t u v z} F)
: Type@{z} :=
forall (T : Type@{t}) (tT : type@{t} T), @typeOk@{t} T tT -> typeOk1@{u v z} _ (tF _ tT).

Definition typeOk3@{t u v w z} F (tF : type3 F) : Type@{z} :=
forall (T : Type@{t}) (tT : type T), @typeOk@{t} T tT -> typeOk2@{u v w z} _ (tF _ tT).

Existing Class type1.
Existing Class type2.
Existing Class type3.

Global Instance type_type1 F (tF : type1 F) T (tT : type T) : type (F T) :=
tF _ tT.

Global Instance type1_type2 F (tF : type2 F) T (tT : type T) : type1 (F T) :=
tF _ tT.

Global Instance type2_type3 F (tF : type3 F) T (tT : type T) : type2 (F T) :=
tF _ tT.

Class Oktype T : Type :=
{ the_type :> type T
; the_proof :> typeOk the_type
}.

Coercion the_type : Oktype >-> type.

Global Instance typeOk_typeOk1 F (tF : type1 F) T (tT : type T) : type (F T) :=
tF _ tT.

Global Instance typeOk1_typeOk2 F (tF : type2 F) T (tT : type T) : type1 (F T) :=
tF _ tT.

Global Instance typeOk2_typeOk3 F (tF : type3 F) T (tT : type T) : type2 (F T) :=
tF _ tT.

Section typeOk_from_equal.
Universe u.
Context {T : Type@{u}} (r : relation T).
Hypothesis p : forall x y, r x y -> r x x /\ r y y.
Hypothesis sym : Symmetric r.
Hypothesis trans : Transitive r.

Theorem typeOk_from_equal@{} : typeOk (type_from_equal r).
Proof. hammer_hook "Type" "Type.typeOk_from_equal".
constructor; auto.
{ simpl. red. auto. }
Qed.
End typeOk_from_equal.

Theorem typeOk_libniz@{u} (T : Type@{u}) : typeOk (type_libniz T).
Proof. hammer_hook "Type" "Type.typeOk_libniz".
constructor; unfold equal, type_libniz; auto with typeclass_instances.
{ split; exact I. }
Qed.