(* -*- mode: coq; mode: visual-line -*- *)
(** * Varieties of function extensionality *)

Require Import HoTT.Basics HoTT.Types EquivalenceVarieties.
Local Open Scope path_scope.

(** In the Overture, we defined function extensionality to be the assertion that the map [apD10] is an equivalence.   We now prove that this follows from a couple of weaker-looking forms of function extensionality.  We do require eta conversion, which Coq 8.4+ has judgmentally.

   This proof is originally due to Voevodsky; it has since been simplified by Peter Lumsdaine and Michael Shulman. *)

(** Naive funext is the simple assertion that pointwise equal functions are equal.  The domain and codomain could live in different universes; the third universe argument is essentially the max of [i] and [j] (and similarly for all subsequent axioms). *)

Definition NaiveFunext :=
  forall (A : Type@{i}) (P : A -> Type@{j}) (f g : forall x, P x),
    (forall x, f x = g x) -> (f = g).
Check NaiveFunext@{i j max}.

(** Naive non-dependent funext is the same, but only for non-dependent functions.  *)

Definition NaiveNondepFunext :=
  forall (A B : Type) (f g : A -> B),
    (forall x, f x = g x) -> (f = g).
Check NaiveNondepFunext@{i j max}.

(** Weak funext says that a product of contractible types is contractible. *)

Definition WeakFunext :=
  forall (A : Type) (P : A -> Type),
    (forall x, Contr (P x)) -> Contr (forall x, P x).
Check WeakFunext@{i j max}.

(** We define a variant of [Funext] which does not invoke an axiom. *)
Definition Funext_type :=
  forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g).
Check Funext_type@{i j max}.

(** The obvious implications are
   Funext -> NaiveFunext -> WeakFunext and NaiveFunext -> NaiveNondepFunext.
   None of these do anything fiddly with the universes either.
   *)

Definition Funext_implies_NaiveFunext@{i j max}
  : Funext_type@{i j max} -> NaiveFunext@{i j max}.
Proof.
  intros fe A P f g h.
  unfold Funext_type in *.
  exact ((@apD10 A P f g)^-1 h).
Defined.

Definition NaiveFunext_implies_WeakFunext@{i j max}
  : NaiveFunext@{i j max} -> WeakFunext@{i j max}.
Proof.
  intros nf A P Pc.
  exists (fun x => center (P x)).
  intros f; apply nf; intros x.
  apply contr.
Defined.

Definition NaiveFunext_implies_NaiveNondepFunext@{i j max}
  : NaiveFunext@{i j max} -> NaiveNondepFunext@{i j max}
  := fun nf A B f g => nf A (fun _ => B) f g.

(** The non-obvious directions are that WeakFunext implies Funext and that NaiveNondepFunext implies WeakFunext (and hence all four are logically equivalent). *)

(** ** Weak funext implies Funext *)

(** To show that WeakFunext implies Funext, the point is that under weak funext, the space of "pointwise homotopies" has the same universal property as the space of paths. *)

Section Homotopies.

  Context (wf : WeakFunext).
  Context {A:Type} {B : A -> Type}.

  Context (f : forall x, B x).

  (* Recall that [f == g] is the type of pointwise paths (or "homotopies") from [f] to [g]. *)
  Let idhtpy : f == f := fun x => idpath (f x).

  (** Weak funext implies that the "based homotopy space" of the Pi-type is contractible, just like the based path space. *)
  (** Use priority 1, so we don't override [Contr Unit]. *)
  Global Instance contr_basedhtpy : Contr {g : forall x, B x & f == g } | 1.
  Proof.
    unfold WeakFunext in wf.    (* Allow typeclass inference to find it *)
    exists (f;idhtpy). intros [g h].
    (* The trick is to show that the type [{g : forall x, B x & f == g }] is a retract of [forall x, {y : B x & f x = y}], which is contractible due to J and weak funext.  Here are the retraction and its section. *)
    pose (r := fun k => existT (fun g => f == g)
      (fun x => (k x).1) (fun x => (k x).2)).
    pose (s := fun (g : forall x, B x) (h : f == g) x => (g x ; h x)).
    (* Because of judgemental eta-conversion, the retraction is actually definitional, so we can just replace the goal. *)
    change (r (fun x => (f x ; idpath (f x))) = r (s g h)).
    apply ap; serapply path_contr.
  Defined.

  (** This enables us to prove that pointwise homotopies have the same elimination rule as the identity type. *)

  Context (Q : forall g (h : f == g), Type).
  Context (d : Q f idhtpy).

  Definition htpy_ind g h : Q g h
    := @transport _ (fun gh => Q gh.1 gh.2) (f;idhtpy) (g;h)
         (@path_contr _ _ _ _) d.

  (** The computation rule, of course, is only propositional. *)
  Definition htpy_ind_beta : htpy_ind f idhtpy = d
    := transport (fun p : (f;idhtpy) = (f;idhtpy) =>
                    transport (fun gh => Q gh.1 gh.2) p d = d)
         (@path2_contr _ _ _ _
           (path_contr (f;idhtpy) (f;idhtpy)) (idpath _))^
         (idpath _).

End Homotopies.

(** Now the proof is fairly easy; we can just use the same induction principle on both sides.  This proof also preserves all the universes. *)
Theorem WeakFunext_implies_Funext@{i j max}
  : WeakFunext@{i j max} -> Funext_type@{i j max}.
Proof.
  intros wf; hnf; intros A B f g.
  refine (isequiv_adjointify (@apD10 A B f g)
    (htpy_ind wf f (fun g' _ => f = g') idpath g) _ _).
  - revert g; refine (htpy_ind wf _ _ _).
    refine (ap _ (htpy_ind_beta wf _ _ _)).
  - intros h; destruct h.
    refine (htpy_ind_beta wf _ _ _).
Defined.

(** We add some hints to the typeclass database, so if we happen to have hypotheses of [WeakFunext] or [NaiveFunext] floating around, we get [Funext] automatically. *)
Definition NaiveFunext_implies_Funext : NaiveFunext -> Funext_type
  := WeakFunext_implies_Funext o NaiveFunext_implies_WeakFunext.

(** ** Naive non-dependent funext implies weak funext  *)

(** First we show that naive non-dependent funext suffices to show that postcomposition with an equivalence is an equivalence. *)
Definition equiv_postcompose_from_NaiveNondepFunext
           (nf : NaiveNondepFunext) {A B C : Type} (f : B <~> C)
  : (A -> B) <~> (A -> C)
  := Build_Equiv
       _ _ (fun (g:A->B) => f o g)
       (isequiv_adjointify
          (fun (g:A->B) => f o g)
          (fun h => f^-1 o h)
          (fun h => nf _ _ _ _ (fun x => eisretr f (h x)))
          (fun g => nf _ _ _ _ (fun y => eissect f (g y)))).

(** Now, if each [P x] is contractible, the projection [pr1 : {x:X & P x} -> X] is an equivalence (this requires no funext).  Thus, postcomposition with it is also an equivalence, and hence the fiber of postcomposition over [idmap X] is contractible.  But this fiber is "the type of sections of [pr1]" and hence equivalent to [forall x:X, P x].  The latter equivalence requires full funext to prove, but without any funext we can show that [forall x:X, P x] is a *retract* of the type of sections, hence also contractible. *)
Theorem NaiveNondepFunext_implies_WeakFunext
  : NaiveNondepFunext -> WeakFunext.
Proof.
  intros nf X P H.
  pose (T := (hfiber (equiv_postcompose_from_NaiveNondepFunext nf (equiv_pr1 P)) idmap)).
  assert (X1 : Contr T).
  { apply fcontr_isequiv; exact _. }
  exact (@contr_retract T _ _
           (fun fp x => transport P (ap10 fp.2 x) (fp.1 x).2)
           (fun f => ((fun x => (x ; f x)) ; 1)) (fun f => 1)).
Defined.

(** Therefore, naive nondependent funext also implies full funext.  Interestingly, this requires the universe of the assumption codomain to be not just that of the conclusion codomain, but the max of that universe with the domain universe (which is unchanged). *)
Definition NaiveNondepFunext_implies_Funext@{i j max}
  : NaiveNondepFunext@{i max max} -> Funext_type@{i j max}
  := WeakFunext_implies_Funext o NaiveNondepFunext_implies_WeakFunext.

(** ** Functional extensionality is downward closed *)

(** If universe [U_i] is functionally extensional, then so are universes [U_j] for [j ≤ i]. *)
Lemma Funext_downward_closed `{H : Funext_type} : Funext_type.
Proof.
  apply @NaiveFunext_implies_Funext.
  apply Funext_implies_NaiveFunext in H.
  hnf in *.
  intros A P f g H'.
  (** We want to just use [H] here.  But we need to adjust the universe level in four places: for [A], for [P], for the input path, and for the output path. *)
  case (H (Lift A) (fun x => Lift (P x)) f g (fun x => ap lift (H' x))).
  exact idpath.
Defined.

(** We re-declare this instance depending on the global [Funext] typeclass, since it is useful on its own. *)
Global Instance contr_basedhomotopy `{Funext}
       {A:Type} {B : A -> Type} (f : forall x, B x)
: Contr {g : forall x, B x & f == g }.
Proof.
  apply contr_basedhtpy.
  apply NaiveFunext_implies_WeakFunext.
  apply Funext_implies_NaiveFunext.
  unfold Funext_type; exact _.
Defined.


Require Export GeoCoq.Elements.OriginalProofs.proposition_02.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_extension :
   forall A B P Q,
   neq A B -> neq P Q ->
   exists X, BetS A B X /\ Cong B X P Q.
Proof.
intros.
assert (eq B B) by (conclude cn_equalityreflexive).
assert (exists D, Cong B D P Q).
by cases on (eq B P \/ neq B P).
{
 assert (neq Q P) by (conclude lemma_inequalitysymmetric).
 assert (neq Q B) by (conclude cn_equalitysub).
 assert (neq B Q) by (conclude lemma_inequalitysymmetric).
 let Tf:=fresh in
 assert (Tf:exists D, Cong B D Q P) by (conclude proposition_02);destruct Tf as [D];spliter.
 assert (Cong B D P Q) by (forward_using lemma_congruenceflip).
 close.
 }
{
 let Tf:=fresh in
 assert (Tf:exists D, Cong B D P Q) by (conclude proposition_02);destruct Tf as [D];spliter.
 exists D;auto.
 }
destruct H2 as [D];spliter.
(* cases *)

assert (Cong P Q B D) by (conclude lemma_congruencesymmetric).
assert (neq B D) by (conclude axiom_nocollapse).
let Tf:=fresh in
assert (Tf:exists J, CI J B B D) by (conclude postulate_Euclid3);destruct Tf as [J];spliter.
assert (InCirc B J) by (conclude_def InCirc ).
let Tf:=fresh in
assert (Tf:exists C E, (Col A B C /\ BetS A B E /\ OnCirc C J /\ OnCirc E J /\ BetS C B E)) by (conclude postulate_line_circle);destruct Tf as [C[E]];spliter.
assert (Cong B E B D) by (conclude axiom_circle_center_radius).
assert (Cong B E P Q) by (conclude lemma_congruencetransitive).
close.
Unshelve.
exact A.
exact A.
Qed.

End Euclid.


Require Export Coq.Classes.RelationClasses.
Require Export RelDefinitions.

(** * More classes for relation properties *)

(** In the following we introduce more typeclasses for characterizing
  properties of relations, in the spirit of the [RelationClasses]
  standard library. *)

(** ** Coreflexive relations *)

Class Coreflexive {A} (R: relation A) :=
  coreflexivity: forall x y, R x y -> x = y.

Global Instance eq_corefl {A}:
  Coreflexive (@eq A).
Proof.
  firstorder.
Qed.

Global Instance subrel_eq {A} (R: relation A):
  Coreflexive R ->
  Related R eq subrel.
Proof.
  firstorder.
Qed.

(** ** Composition *)

Class RCompose {A B C} (RAB : rel A B) (RBC : rel B C) (RAC : rel A C) :=
  rcompose : forall x y z, RAB x y -> RBC y z -> RAC x z.

Ltac rcompose b :=
  lazymatch goal with
    | |- ?R ?a ?c =>
      apply (rcompose a b c)
  end.

Ltac ercompose :=
  eapply rcompose.

(** [Transitive] is a special case of [RCompose]. The following makes
  it possible for the [transitivity] tactic to use [RCompose]
  instances. *)

Global Instance rcompose_transitive {A} (R : relation A) :
  RCompose R R R -> Transitive R.
Proof.
  firstorder.
Qed.

(** Conversely, we will want to use declared [Transitive] instances to
  satisfy [RCompose] queries. To avoid loops in the resolution process
  this is only declared as an immediate hint --- we expect all derived
  instances to be formulated in terms of [RCompose] rather than
  [Transitive]. *)

Lemma transitive_rcompose `(Transitive) :
  RCompose R R R.
Proof.
  assumption.
Qed.

Hint Immediate transitive_rcompose : typeclass_instances.

(** ** Decomposition *)

(** The converse of [RCompose] is the following "decomposition" property. *)

Class RDecompose {A B C} (RAB : rel A B) (RBC : rel B C) (RAC : rel A C) :=
  rdecompose : forall x z, RAC x z -> exists y, RAB x y /\ RBC y z.

Tactic Notation "rdecompose" constr(H) "as" simple_intropattern(p) :=
  lazymatch type of H with
    | ?R ?a ?b =>
      destruct (rdecompose a b H) as p
    | _ =>
      fail "Not an applied relation"
  end.

Tactic Notation "rdecompose" hyp(H) "as" simple_intropattern(p) :=
  lazymatch type of H with
    | ?R ?a ?b =>
      apply rdecompose in H; destruct H as p
    | _ =>
      fail "Not an applied relation"
  end.

Tactic Notation "rdecompose" constr(H) :=
  rdecompose H as (? & ? & ?).

Tactic Notation "rdecompose" hyp(H) :=
  rdecompose H as (? & ? & ?).

(** * Instances for core relators *)

(** ** [arrow_rel] *)

Global Instance arrow_refl {A B} (RA : relation A) (RB : relation B) :
  Coreflexive RA ->
  Reflexive RB ->
  Reflexive (RA ++> RB).
Proof.
  intros HA HB f a b Hab.
  apply coreflexivity in Hab. subst.
  reflexivity.
Qed.

Global Instance arrow_corefl {A B} (RA : relation A) (RB : relation B) :
  Reflexive RA ->
  Coreflexive RB ->
  Coreflexive (RA ++> RB).
Proof.
  (* This requires an extensionality axiom *)
Abort.

Section ARROW_REL_COMPOSE.
  Context {A1 A2 A3} (RA12 : rel A1 A2) (RA23 : rel A2 A3) (RA13 : rel A1 A3).
  Context {B1 B2 B3} (RB12 : rel B1 B2) (RB23 : rel B2 B3) (RB13 : rel B1 B3).

  Global Instance arrow_rcompose :
    RDecompose RA12 RA23 RA13 ->
    RCompose RB12 RB23 RB13 ->
    RCompose (RA12 ++> RB12) (RA23 ++> RB23) (RA13 ++> RB13).
  Proof.
    intros HA HB f g h Hfg Hgh a1 a3 Ha.
    rdecompose Ha as (a2 & Ha12 & Ha23).
    firstorder.
  Qed.

  Global Instance arrow_rdecompose :
    RCompose RA12 RA23 RA13 ->
    RDecompose RB12 RB23 RB13 ->
    RDecompose (RA12 ++> RB12) (RA23 ++> RB23) (RA13 ++> RB13).
  Proof.
    (* This requires a choice axiom. *)
  Abort.
End ARROW_REL_COMPOSE.


Require Import Category.Lib.
Require Import Category.Lib.TList.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Adjunction.
Require Import Category.Instance.Sets.

Generalizable All Variables.

Section Free.

Universes o h p.
Context {C : Category@{o h p}}.

(* Wikipedia: "In mathematics, the free category or path category generated by
   a directed graph or quiver is the category that results from freely
   concatenating arrows together, whenever the target of one arrow is the
   source of the next."

   "More precisely, the objects of the category are the vertices of the
   quiver, and the morphisms are paths between objects. Here, a path is
   defined as a finite sequence " *)

Program Definition Free@{fo fh fp} : Category@{fo fh fp} := {|
  obj     := C;
  hom     := tlist hom;
  homset  := fun _ _ => {| equiv := eq |};
  id      := fun _ => tnil;
  compose := fun _ _ _ f g => g +++ f
|}.
Next Obligation. equivalence; congruence. Qed.
Next Obligation. now apply tlist_app_tnil_r. Qed.
Next Obligation. now apply tlist_app_assoc. Qed.
Next Obligation. now symmetry; apply tlist_app_assoc. Qed.

Definition composition {x y : C} : tlist hom x y → x ~{C}~> y.
Proof.
  intros.
  induction X.
  - exact id.
  - exact (compose IHX b).
Defined.

Definition composition_tnil {x : C} : composition tnil ≈ id[x].
Proof. now cat. Qed.

Definition composition_tapp {x y z : C}
  (g : tlist hom y z) (f : tlist hom x y) :
  composition (f +++ g) ≈ composition g ∘ composition f.
Proof.
  induction f; simpl.
  - rewrite tlist_app_tnil_l.
    now cat.
  - rewrite <- tlist_app_comm_cons.
    simpl.
    rewrite IHf.
    now cat.
Qed.

#[local] Obligation Tactic := cat_simpl; try reflexivity.

Program Definition FreeFunctor : Free ⟶ C := {|
  fobj := fun x => x;
  fmap := fun _ _ f => composition f;
  fmap_id := fun _ => composition_tnil;
  fmap_comp := fun _ _ _ => composition_tapp
|}.

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

Inductive Mor : C → C → Type :=
  | Ident {x} : Mor x x
  | Morph {x y} (f : x ~> y) : Mor x y
  | Comp  {x y z} (f : Mor y z) (g : Mor x y) : Mor x z.

Fixpoint morD `(t : Mor x y) : x ~> y :=
  match t with
  | Ident => id
  | Morph f => f
  | Comp f g => morD f ∘ morD g
  end.

Fixpoint morDA `(t : Mor x y) : tlist hom x y :=
  match t with
  | Ident => tnil
  | Morph f => tcons _ f tnil
  | Comp f g => morDA g +++ morDA f
  end.

Program Instance Mor_Setoid {x y} : Setoid (Mor x y) := {
  equiv f g := morDA f = morDA g
}.

Lemma morD_sound `{t : Mor x y} :
  morD t ≈ composition (morDA t).
Proof.
  induction t; simpl; cat.
  rewrite IHt1, IHt2; simpl.
  now rewrite composition_tapp.
Qed.

Fixpoint tlistDA `(t : tlist hom x y) : Mor x y :=
  match t with
  | tnil => Ident
  | tcons _ f fs => Comp (tlistDA fs) (Morph f)
  end.

(* Note that this yields an equality. *)
Lemma morDA_tlistDA `{f : tlist hom x y} :
  morDA (tlistDA f) = f.
Proof.
  induction f; simpl; auto.
  rewrite <- tlist_app_cons.
  now rewrite IHf.
Qed.

(* While this is merely an equivalence. Such is the essence of adjointness
   between pseudocategories. *)
Lemma tlistDA_morDA `{f : Mor x y} :
  tlistDA (morDA f) ≈ f.
Proof.
  induction f; simpl; auto.
  rewrite <- IHf1, <- IHf2.
  now rewrite morDA_tlistDA.
Qed.

Program Definition FreeSyntax : Category := {|
  obj     := C;
  hom     := Mor;
  homset  := @Mor_Setoid;
  id      := fun _ => Ident;
  compose := fun _ _ _ => Comp
|}.
Next Obligation. now apply tlist_app_tnil_r. Qed.
Next Obligation. now apply tlist_app_assoc. Qed.
Next Obligation. now symmetry; apply tlist_app_assoc. Qed.

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

Program Instance ForgetSyntax : FreeSyntax ⟶ Free := {
  fobj := λ x, x;
  fmap := λ x y f, morDA f;
}.

Program Instance CanonicalMap : Free ⟶ FreeSyntax := {
  fobj := λ x, x;
  fmap := λ x y f, tlistDA f;
}.
Next Obligation.
  generalize dependent f.
  generalize dependent z.
  induction g; simpl; intros.
  - now rewrite !tlist_app_tnil_l.
  - rewrite <- tlist_app_cons.
    rewrite <- !tlist_app_comm_cons.
    simpl.
    rewrite <- tlist_app_cons.
    now rewrite <- IHg.
Qed.

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

Program Instance ForgetSyntax_CanonicalMap :
  ForgetSyntax ⊣ CanonicalMap := {
  adj := λ x y,
    {| to   := {| morphism := tlistDA |}
     ; from := {| morphism := morDA |} |}
}.
Next Obligation.
  simpl; intros;
  now rewrite tlistDA_morDA.
Qed.
Next Obligation.
  simpl; intros;
  now rewrite morDA_tlistDA.
Qed.
Next Obligation.
  now rewrite !morDA_tlistDA.
Qed.
Next Obligation.
  now rewrite !morDA_tlistDA.
Qed.
Next Obligation.
  now rewrite !morDA_tlistDA.
Qed.

End Free.


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

(*i $Id: Heap.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** This file is deprecated, for a tree on list, use [Mergesort.v]. *)

(** A development of Treesort on Heap trees. It has an average
    complexity of O(n.log n) but of O(n²) in the worst case (e.g. if
    the list is already sorted) *)

(* G. Huet 1-9-95 uses Multiset *)

Require Import List Multiset PermutSetoid Relations Sorting.

Section defs.

  (** * Trees and heap trees *)

  (** ** Definition of trees over an ordered set *)

  Variable A : Type.
  Variable leA : relation A.
  Variable eqA : relation A.

  Let gtA (x y:A) := ~ leA x y.

  Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
  Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
  Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
  Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.

  Hint Resolve leA_refl.
  Hint Immediate eqA_dec leA_dec leA_antisym.

  Let emptyBag := EmptyBag A.
  Let singletonBag := SingletonBag _ eqA_dec.

  Inductive Tree :=
    | Tree_Leaf : Tree
    | Tree_Node : A -> Tree -> Tree -> Tree.

  (** [a] is lower than a Tree [T] if [T] is a Leaf
      or [T] is a Node holding [b>a] *)

  Definition leA_Tree (a:A) (t:Tree) :=
    match t with
      | Tree_Leaf => True
      | Tree_Node b T1 T2 => leA a b
    end.

  Lemma leA_Tree_Leaf : forall a:A, leA_Tree a Tree_Leaf.
  Proof.
    simpl in |- *; auto with datatypes.
  Qed.

  Lemma leA_Tree_Node :
    forall (a b:A) (G D:Tree), leA a b -> leA_Tree a (Tree_Node b G D).
  Proof.
    simpl in |- *; auto with datatypes.
  Qed.

  (** ** The heap property *)

  Inductive is_heap : Tree -> Prop :=
    | nil_is_heap : is_heap Tree_Leaf
    | node_is_heap :
      forall (a:A) (T1 T2:Tree),
        leA_Tree a T1 ->
        leA_Tree a T2 ->
        is_heap T1 -> is_heap T2 -> is_heap (Tree_Node a T1 T2).

  Lemma invert_heap :
    forall (a:A) (T1 T2:Tree),
      is_heap (Tree_Node a T1 T2) ->
      leA_Tree a T1 /\ leA_Tree a T2 /\ is_heap T1 /\ is_heap T2.
  Proof.
    intros; inversion H; auto with datatypes.
  Qed.

  (* This lemma ought to be generated automatically by the Inversion tools *)
  Lemma is_heap_rect :
    forall P:Tree -> Type,
      P Tree_Leaf ->
      (forall (a:A) (T1 T2:Tree),
	leA_Tree a T1 ->
	leA_Tree a T2 ->
	is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) ->
      forall T:Tree, is_heap T -> P T.
  Proof.
    simple induction T; auto with datatypes.
    intros a G PG D PD PN.
    elim (invert_heap a G D); auto with datatypes.
    intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
    apply X0; auto with datatypes.
  Qed.

  (* This lemma ought to be generated automatically by the Inversion tools *)
  Lemma is_heap_rec :
    forall P:Tree -> Set,
      P Tree_Leaf ->
      (forall (a:A) (T1 T2:Tree),
	leA_Tree a T1 ->
	leA_Tree a T2 ->
	is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) ->
      forall T:Tree, is_heap T -> P T.
  Proof.
    simple induction T; auto with datatypes.
    intros a G PG D PD PN.
    elim (invert_heap a G D); auto with datatypes.
    intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
    apply X; auto with datatypes.
  Qed.

  Lemma low_trans :
    forall (T:Tree) (a b:A), leA a b -> leA_Tree b T -> leA_Tree a T.
  Proof.
    simple induction T; auto with datatypes.
    intros; simpl in |- *; apply leA_trans with b; auto with datatypes.
  Qed.

  (** ** Merging two sorted lists *)

  Inductive merge_lem (l1 l2:list A) : Type :=
    merge_exist :
    forall l:list A,
      Sorted leA l ->
      meq (list_contents _ eqA_dec l)
      (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
      (forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) ->
      merge_lem l1 l2.
  Require Import Morphisms.

  Instance: Equivalence (@meq A).
  Proof. constructor; auto with datatypes. red. apply meq_trans. Defined.

  Instance: Proper (@meq A ++> @meq _ ++> @meq _) (@munion A).
  Proof. intros x y H x' y' H'. now apply meq_congr. Qed.

  Lemma merge :
    forall l1:list A, Sorted leA l1 ->
    forall l2:list A, Sorted leA l2 -> merge_lem l1 l2.
  Proof.
    fix 1; intros; destruct l1.
    apply merge_exist with l2; auto with datatypes.
    rename l1 into l.
    revert l2 H0. fix 1. intros.
    destruct l2 as [|a0 l0].
    apply merge_exist with (a :: l); simpl; auto with datatypes.
    elim (leA_dec a a0); intros.

    (* 1 (leA a a0) *)
    apply Sorted_inv in H. destruct H.
    destruct (merge l H (a0 :: l0) H0).
    apply merge_exist with (a :: l1). clear merge merge0.
      auto using cons_sort, cons_leA with datatypes.
    simpl. rewrite m. now rewrite munion_ass.
    intros. apply cons_leA.
    apply (@HdRel_inv _ leA) with l; trivial with datatypes.

    (* 2 (leA a0 a) *)
    apply Sorted_inv in H0. destruct H0.
    destruct (merge0 l0 H0). clear merge merge0.
    apply merge_exist with (a0 :: l1);
      auto using cons_sort, cons_leA with datatypes.
    simpl; rewrite m. simpl. setoid_rewrite munion_ass at 1. rewrite munion_comm.
    repeat rewrite munion_ass. setoid_rewrite munion_comm at 3. reflexivity.
    intros. apply cons_leA.
    apply (@HdRel_inv _ leA) with l0; trivial with datatypes.
  Qed.

  (** ** From trees to multisets *)

  (** contents of a tree as a multiset *)

  (** Nota Bene : In what follows the definition of SingletonBag
      in not used. Actually, we could just take as postulate:
      [Parameter SingletonBag : A->multiset].  *)

  Fixpoint contents (t:Tree) : multiset A :=
    match t with
      | Tree_Leaf => emptyBag
      | Tree_Node a t1 t2 =>
	munion (contents t1) (munion (contents t2) (singletonBag a))
    end.

  (** equivalence of two trees is equality of corresponding multisets *)
  Definition equiv_Tree (t1 t2:Tree) := meq (contents t1) (contents t2).

  (** * From lists to sorted lists *)

  (** ** Specification of heap insertion *)

  Inductive insert_spec (a:A) (T:Tree) : Type :=
    insert_exist :
    forall T1:Tree,
      is_heap T1 ->
      meq (contents T1) (munion (contents T) (singletonBag a)) ->
      (forall b:A, leA b a -> leA_Tree b T -> leA_Tree b T1) ->
      insert_spec a T.

  Lemma insert : forall T:Tree, is_heap T -> forall a:A, insert_spec a T.
  Proof.
    simple induction 1; intros.
    apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf);
      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    simpl in |- *; unfold meq, munion in |- *; auto using node_is_heap with datatypes.
    elim (leA_dec a a0); intros.
    elim (X a0); intros.
    apply insert_exist with (Tree_Node a T2 T0);
      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    simpl in |- *; apply treesort_twist1; trivial with datatypes.
    elim (X a); intros T3 HeapT3 ConT3 LeA.
    apply insert_exist with (Tree_Node a0 T2 T3);
      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    apply low_trans with a; auto with datatypes.
    apply LeA; auto with datatypes.
    apply low_trans with a; auto with datatypes.
    simpl in |- *; apply treesort_twist2; trivial with datatypes.
  Qed.

  (** ** Building a heap from a list *)

  Inductive build_heap (l:list A) : Type :=
    heap_exist :
    forall T:Tree,
      is_heap T ->
      meq (list_contents _ eqA_dec l) (contents T) -> build_heap l.

  Lemma list_to_heap : forall l:list A, build_heap l.
  Proof.
    simple induction l.
    apply (heap_exist nil Tree_Leaf); auto with datatypes.
    simpl in |- *; unfold meq in |- *; exact nil_is_heap.
    simple induction 1.
    intros T i m; elim (insert T i a).
    intros; apply heap_exist with T1; simpl in |- *; auto with datatypes.
    apply meq_trans with (munion (contents T) (singletonBag a)).
    apply meq_trans with (munion (singletonBag a) (contents T)).
    apply meq_right; trivial with datatypes.
    apply munion_comm.
    apply meq_sym; trivial with datatypes.
  Qed.

  (** ** Building the sorted list *)

  Inductive flat_spec (T:Tree) : Type :=
    flat_exist :
    forall l:list A,
      Sorted leA l ->
      (forall a:A, leA_Tree a T -> HdRel leA a l) ->
      meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T.

  Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T.
  Proof.
    intros T h; elim h; intros.
    apply flat_exist with (nil (A:=A)); auto with datatypes.
    elim X; intros l1 s1 i1 m1; elim X0; intros l2 s2 i2 m2.
    elim (merge _ s1 _ s2); intros.
    apply flat_exist with (a :: l); simpl in |- *; auto with datatypes.
    apply meq_trans with
      (munion (list_contents _ eqA_dec l1)
	(munion (list_contents _ eqA_dec l2) (singletonBag a))).
    apply meq_congr; auto with datatypes.
    apply meq_trans with
      (munion (singletonBag a)
	(munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2))).
    apply munion_rotate.
    apply meq_right; apply meq_sym; trivial with datatypes.
  Qed.

  (** * Specification of treesort *)

  Theorem treesort :
    forall l:list A,
    {m : list A | Sorted leA m & permutation _ eqA_dec l m}.
  Proof.
    intro l; unfold permutation in |- *.
    elim (list_to_heap l).
    intros.
    elim (heap_to_list T); auto with datatypes.
    intros.
    exists l0; auto with datatypes.
    apply meq_trans with (contents T); trivial with datatypes.
  Qed.

End defs.


(** This file defines a high level interface for lists with no
    duplicates of types with decidable equality. They form a retract
    of lists. *)

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import FinSet.Lib.DProp.
Require Import FinSet.Lib.ListSet.
Require Import FinSet.Quotients.Retract.
Require Import FinSet.Quotients.Countable.

Definition UList (A:Type) (R:A->A->DProp) : Type :=
  { l:list A | Canonize (nodup R l) }.
Arguments UList : simpl never.

Program Definition ulist {A} {R:A->A->DProp} :
 Retract (list A) (UList A R) := {|
  inj l := l;
  proj l := deduplicate R l
|}.
Next Obligation.
  intros **. rewrite canonize_spec.
  apply deduplicate_nodup.
Qed.
Next Obligation.
  intros A R [l hl]. cbn.
  apply dsigma_ext. cbn. rewrite canonize_spec in hl.
  induction l as [|a l ihl].
  { easy. }
  cbn -[DNot]. f_equal.
  cbn -[mem_list] in hl. destruct hl as [hl₁ hl₂].
  rewrite ihl; cycle 1.
  { assumption. }
  clear ihl.
  induction l as [|b l ihl].
  { easy. }
  cbn -[DNot]. destruct dec as [hr|hr];cycle 1.
  { cbn -[mem_list] in hr.
    rewrite mem_list_cons in hl₂. cbn in hl₂.
    destruct hl₂ as [hl₂ _].
    contradictory. }
  f_equal.
  apply ihl.
  + apply hl₁.
  + rewrite mem_list_cons in hl₂. apply hl₂.
Qed.

Lemma ulist_ext A R :
  forall l₁ l₂:UList A R, ulist.(inj) l₁ = ulist.(inj) l₂ -> l₁ = l₂.
Proof. apply dsigma_ext. Qed.

Lemma ulist_nodup A R : forall l:UList A R, nodup R (ulist.(inj) l).
Proof.
  intros [l hl]. cbn.
  now (rewrite canonize_spec in hl).
Qed.

Lemma ulist_eq_set A (R:A->A->DProp) (e:Equivalence R) :
  forall l:list A, eq_set_list R ((ulist (R:=R)).(inj) (ulist.(proj) l)) l.
Proof.
  intros l. cbn [inj proj ulist proj1_sig].
  now rewrite <- deduplicate_eq_set_list.
Qed.

(** * Set equality *)

Definition eq_set_ulist {A} R (l₁ l₂:UList A R) : DProp :=
  eq_set_list R (ulist.(inj) l₁) (ulist.(inj) l₂).

Instance eq_set_eq A (R:A->A->DProp) :
  Equivalence R -> Equivalence (eq_set_ulist R).
Proof.
  intros e. split. all:unfold Reflexive,Symmetric,Transitive,eq_set_ulist.
  + intros **. reflexivity.
  + intros **. symmetry. assumption.
  + intros **. etransitivity. all:eassumption.
Qed.

Instance ulist_proper A (R:A->A->DProp) (e:Equivalence R) :
  Proper (eq_set_ulist R ==> eq_set_list R) ulist.(inj).
Proof.
  unfold Proper, respectful, eq_set_ulist.
  easy.
Qed.

(** * Instances *)

Instance ulist_countable A R (_:Countable A) : Countable (UList A R) :=
  countable_of_retract ulist.

Instance ulist_inhabited A R : Inhabited (UList A R) := ulist.(proj) nil.


Require Import ZArith.
Require Import Psatz.
Require Import Coq.Classes.RelationClasses.
Require Import TLC.LibTactics TLC.LibIntTactics.
Require Import TLC.LibOrder TLC.LibLogic.
Require Import LibFunOrd LibZExtra Cumul.
Require Import Filter.

(* todo: move *)
Lemma preorder_of_PreOrder A (R : A -> A -> Prop) :
  PreOrder R ->
  preorder R.
Proof.
  intros (HR & HT). constructor.
  - apply HR.
  - intros y x z H1 H2. apply HT with (y := y); assumption.
Qed.

Section General_facts.
Context {A} (leA : A -> A -> Prop) {OA : preorder leA}.
Context {B} (leB : B -> B -> Prop) {OB : preorder leB}.
Context {C} (leC : C -> C -> Prop) {OC : preorder leC}.

Lemma monotonic_eq : forall f g,
  monotonic leA leB f ->
  (forall a, f a = g a) ->
  monotonic leA leB g.
Proof.
  introv M E.
  intros a1 a2 H. rewrite <-!E. apply M. auto.
Qed.

Lemma monotonic_id :
  monotonic leA leA (fun (x: A) => x).
Proof. intros a1 a2. auto. Qed.

Lemma monotonic_comp : forall (f : B -> C) (g : A -> B),
  monotonic leB leC f ->
  monotonic leA leB g ->
  monotonic leA leC (fun x => f (g x)).
Proof. introv Hf Hg. intros a1 a2 ?. auto. Qed.

Lemma monotonic_cst : forall b,
  monotonic leA leB (fun (_ : A) => b).
Proof. intros b a1 a2 ?. applys OB. Qed.

Lemma monotonic_after_of_monotonic : forall (f : A -> B),
  monotonic leA leB f ->
  (forall (a : A), monotonic (le_after a leA) leB f).
Proof.
  intros f fmon a.
  intros a1 a2 H. apply fmon. apply H.
Qed.

Lemma monotonic_of_monotonic_after : forall (f : A -> B),
  (forall a, monotonic (le_after a leA) leB f) ->
  monotonic leA leB f.
Proof.
  intros f fmon.
  intros a1 a2 H. eapply fmon.
  splits; try (apply preorder_refl; typeclass); assumption.
Qed.

Lemma monotonic_after_weaken : forall (f : A -> B) (a1 a2 : A),
  leA a1 a2 ->
  monotonic (le_after a1 leA) leB f ->
  monotonic (le_after a2 leA) leB f.
Proof.
  intros f a1 a2 H fmon.
  intros x y Hxy. apply fmon.
  splits; try apply Hxy;
  eapply (preorder_trans a2); first [apply H | apply Hxy].
  Unshelve. typeclass. typeclass.
Qed.

End General_facts.

Lemma ultimately_monotonic_of_monotonic :
  forall (A : filterType) B
         (leA : A -> A -> Prop) (leB : B -> B -> Prop)
         (f : A -> B),
  monotonic leA leB f ->
  ultimately A (fun a => monotonic (le_after a leA) leB f).
Proof.
  introv fmon. applys filter_universe_alt.
  eapply monotonic_after_of_monotonic. apply fmon.
Qed.

Section Z_facts.
Local Open Scope Z.

Context {A} (leA: A -> A -> Prop) {OA: preorder leA}.

Lemma monotonic_sum : forall (f g : A -> Z),
  monotonic leA Z.le f ->
  monotonic leA Z.le g ->
  monotonic leA Z.le (fun x => f x + g x).
Proof.
  introv Hf Hg. intros a1 a2 ?.
  forwards~: Hf a1 a2. forwards~: Hg a1 a2. lia.
Qed.

Lemma monotonic_max : forall (f g : A -> Z),
  monotonic leA Z.le f ->
  monotonic leA Z.le g ->
  monotonic leA Z.le (fun x => Z.max (f x) (g x)).
Proof.
  introv Hf Hg. intros a1 a2 ?.
  forwards~: Hf a1 a2. forwards~: Hg a1 a2. lia.
Qed.

Lemma monotonic_mul : forall (f g : A -> Z),
  (forall x, 0 <= f x) ->
  (forall x, 0 <= g x) ->
  monotonic leA Z.le f ->
  monotonic leA Z.le g ->
  monotonic leA Z.le (fun x => f x * g x).
Proof.
  introv Pf Pg Hf Hg. intros a1 a2 ?.
  forwards~: Pf a1. forwards~: Pf a2. forwards~: Pg a1. forwards~: Pg a2.
  forwards~: Hf a1 a2. forwards~: Hg a1 a2. nia.
Qed.

Lemma monotonic_mul_cst_l : forall (f : A -> Z) (c : Z),
  0 <= c ->
  monotonic leA Z.le f ->
  monotonic leA Z.le (fun x => c * f x).
Proof.
  introv cpos Hf. intros a1 a2 H.
  forwards~: Hf a1 a2. nia.
Qed.

Lemma monotonic_mul_cst_r : forall (f : A -> Z) (c : Z),
  0 <= c ->
  monotonic leA Z.le f ->
  monotonic leA Z.le (fun x => f x * c).
Proof.
  introv cpos Hf.
  intros a1 a2 H. forwards~: Hf a1 a2. nia.
Qed.

Lemma monotonic_log2 : monotonic Z.le Z.le Z.log2.
Proof.
  intros a1 a2 H. apply~ Z.log2_le_mono.
Qed.

Lemma monotonic_pow_l : forall e,
  monotonic (le_after 0 Z.le) Z.le (fun b => b ^ e).
Proof.
  intros e a1 a2 H. apply~ Z.pow_le_mono_l. splits; apply H.
Qed.

Lemma monotonic_pow_r : forall b,
  0 < b ->
  monotonic Z.le Z.le (Z.pow b).
Proof.
  intros b a1 a2 H. apply~ Z.pow_le_mono_r.
Qed.

Lemma monotonic_Z_to_ZZ : forall f g,
  monotonic Z.le Z.le f ->
  monotonic Z.le Z.le g ->
  monotonic Z.le ZZle (fun x => (f x, g x)).
Proof.
  intros f g Hf Hg x y H. unfold ZZle. auto.
Qed.

Lemma monotonic_cumul_Z : forall (f : Z -> Z) (lo : Z),
  (forall x, lo <= x -> 0 <= f x) ->
  monotonic Z.le Z.le (fun n => cumul lo n f).
Proof.
  intros * Hf x1 x2 ?.
  tests: (lo <= x1); cycle 1.
  { rewrite cumulP at 1. rewrite interval_empty. 2: math. cbn.
    apply cumul_nonneg. intros. apply~ Hf. }
  rewrite~ (@cumul_split x1 lo x2).
  rewrite <-(@cumul_nonneg x1 x2 f). math.
  intros. apply~ Hf. math.
Qed.

End Z_facts.

Section Ultimately_Z_facts.
Local Open Scope Z.

Lemma ultimately_monotonic_mul :
  forall (A : filterType) (leA : A -> A -> Prop)
         {OA: preorder leA}
         (f g : A -> Z),
  ultimately A (fun x => 0 <= f x) ->
  ultimately A (fun x => 0 <= g x) ->
  ultimately A (fun a => monotonic (le_after a leA) Z.le f) ->
  ultimately A (fun a => monotonic (le_after a leA) Z.le g) ->
  ultimately A (fun a => monotonic (le_after a leA) Z.le (fun x => f x * g x)).
Proof.
  introv OA. introv. filter_closed_under_intersection.
  introv (Pf & Pg & Hf & Hg). intros a1 a2 (a_le_a1 & a_le_a2 & a1_le_a2).
  forwards~: Hf a a1; forwards~: Hg a a1;
  forwards~: Hf a1 a2; forwards~: Hg a1 a2;
  try (repeat split; first [apply OA | assumption]).
  nia.
Qed.

End Ultimately_Z_facts.

(******************************************************************************)
(* Add lemmas to a [monotonic] hint base. *)

Hint Resolve monotonic_cst : monotonic.
Hint Resolve monotonic_id : monotonic.
Hint Resolve monotonic_sum : monotonic.
Hint Extern 1 (monotonic _ _ (fun _ => Z.sub _ ?y)) =>
  apply monotonic_sum : monotonic.
Hint Extern 1 (monotonic _ _ (Z.sub ?y)) =>
  apply monotonic_sum : monotonic.
Hint Resolve monotonic_max : monotonic.
Hint Resolve monotonic_mul : monotonic.
Hint Resolve monotonic_mul_cst_l : monotonic.
Hint Resolve monotonic_mul_cst_r : monotonic.
Hint Resolve monotonic_log2 : monotonic.
Hint Resolve monotonic_pow_l : monotonic.
Hint Resolve monotonic_pow_r : monotonic.
Hint Extern 1 (monotonic _ _ (fun _ => Z.log2 _)) =>
  apply monotonic_comp with (leB := Z.le);
  [ apply monotonic_log2 | ] : monotonic.
Hint Extern 2 (monotonic _ _ (fun _ => Z.pow ?b _)) =>
  apply monotonic_comp with (leB := Z.le);
  [ apply monotonic_pow_r | ].
Hint Extern 2 (monotonic _ _ (Z.pow ?b)) =>
  apply monotonic_comp with (leB := Z.le);
  [ apply monotonic_pow_r | ].
(* todo: Z.pow _ ?e *)
Hint Resolve monotonic_Z_to_ZZ : monotonic.
Hint Resolve monotonic_cumul_Z : monotonic.

Hint Extern 1 (monotonic _ _ (fun _ => ?f _)) =>
  match goal with
  | H: monotonic ?le _ f |- _ =>
    apply monotonic_comp with (leB := le); [ apply H | ]
  end : monotonic.

Hint Extern 0 (preorder _) =>
  first [ typeclass
        | apply preorder_of_PreOrder; typeclass ]
  : monotonic.

Hint Extern 100 => try (intros; omega) : monotonic_sidegoals.

Hint Extern 999 (monotonic _ _ _) => shelve : monotonic_fallback.
Hint Extern 999 (preorder _) => shelve : monotonic_fallback.

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

(* TODO: make the search depth customisable *)

Ltac monotonic :=
  unshelve (auto 20 with zarith typeclass_instances
                         monotonic
                         monotonic_sidegoals
                         monotonic_fallback).

Ltac monotonic_trysolve :=
  auto 20 with zarith typeclass_instances
               monotonic_sidegoals
               monotonic.

(* TODO: extend monotonic_Z to handle monotonic (le_after ..) .., and ultimately
   (fun a => monotonic (le_after a ..) ..) *)

(* Ltac monotonic_Z_auto_step := *)
(*   match goal with *)
(*   | |- @monotonic _ _ _ _ _ => *)
(*     let a := fresh "a" in *)
(*     apply monotonic_of_monotonic_after; [ *)
(*         eauto; typeclass *)
(*       | intro a; *)
(*         monotonic_after_Z_auto; *)
(*         try apply monotonic_after_of_monotonic ] *)
(*   | |- @monotonic_after _ _ _ _ _ _ => *)
(*     eapply monotonic_after_of_monotonic; eauto *)
(*   | |- context [ @monotonic_after _ _ _ _ _ ] => *)
(*     eapply ultimately_monotonic_of_monotonic; *)
(*     eauto; try typeclass *)
(*   end. *)