(** MathClasses-style operational & structural classes for a Russell-style metric space (i.e. MetricSpace).
  We don't put this in MathClasses because for reasons of interoperability with the existing MetricSpace
  it is still bound to stdlib Q rather than an abstract Rationals implementation. *)

Require Import CoRN.algebra.RSetoid.
Require Import
 Arith List
 CoRN.model.totalorder.QposMinMax
 CSetoids Qmetric Qring Qinf QnnInf QnonNeg
 ProductMetric QposInf Qposclasses (* defines Equiv on Qpos *)
 UniformContinuity MathClasses.implementations.stdlib_rationals
 stdlib_omissions.Pair stdlib_omissions.Q PointFree
 MathClasses.interfaces.abstract_algebra
 MathClasses.theory.setoids MathClasses.theory.products.

Import Qinf.notations QnonNeg.coercions.

Require Vector.

Section MetricSpaceClass.

  Variable X: Type.

  Class MetricSpaceBall: Type := mspc_ball: Qinf → relation X.
Hint Unfold relation : type_classes.
  (** We used to have mspc_ball take a Qpos instead of a Qinf. Because it is sometimes convenient
   to speak in terms of a generalized notion of balls that can have infinite or negative radius, we used
   a separate derived definition for that (which return False for negative radii, True for an infinite radius,
   and reduced to setoid equality for a radius equal to 0). This kinda worked, but had a big downside.
   The derived generalized ball relation (let's call it "gball") was defined using case distinctions on the
   finiteness and sign of the radius. These case distinctions routinely got in the way, because it
   meant that e.g. gball for the product metric space did not reduce to the composition of gballs derived
   for the constituent metrics spaces. Consequently, both the basic ball and the generalized ball
   relation were used side-by-side, and converting between the two was a constant annoyance.

   Because of this, we now use the generalized type for the "basic" ball. Now the product metric space's
   (generalized) ball relation is defined directly in terms of the constituent metric spaces' balls, and
   so reduces nicely. It also means that there is now a _single_ ball relation that is used everywhere.

   Of course, when defining the ball relation for a concrete metric space, the generalization to a Qinf
   parameter implies "more work". Fortunately, the additional work can be factored out into a smart
   constructor (defined later in this module) that takes the version with a Qpos parameter and extends
   it to Qinf in the way described above. All the ball's properties can be lifted along with this extension. *)

  Context `{!MetricSpaceBall}.

  Class MetricSpaceClass: Prop :=
    { mspc_ball_proper:> forall (e1 e2 : Qinf) (x y : X),
          equiv e1 e2 -> (mspc_ball e1 x y <-> mspc_ball e2 x y)
    ; mspc_ball_inf: ∀ x y, mspc_ball Qinf.infinite x y
    ; mspc_ball_negative: ∀ (e: Q), (e < 0)%Q → ∀ x y, ~ mspc_ball e x y
    ; mspc_refl:> ∀ e, (0 <= e)%Qinf → Reflexive (mspc_ball e)
    ; mspc_sym:> ∀ e, Symmetric (mspc_ball e)
    ; mspc_triangle: ∀ (e1 e2: Qinf) (a b c: X),
         mspc_ball e1 a b → mspc_ball e2 b c → mspc_ball (e1 + e2) a c
    ; mspc_closed: ∀ (e: Qinf) (a b: X),
         (∀ d: Qpos, mspc_ball (e + d) a b) → mspc_ball e a b
    ; mspc_stable: ∀ (e: Q) (a b: X),
         (~~mspc_ball e a b) → mspc_ball e a b }.

  Context `{MetricSpaceClass}.

  Local Instance mspc_equiv : Equiv X :=
    fun x y => mspc_ball 0 x y.

  (** Two simple derived properties: *)
  Lemma mspc_eq a b: (∀ e: Qpos, mspc_ball e a b) → a = b.
  Proof with auto.
   intros.
   apply mspc_closed.
   intros.
   rewrite (mspc_ball_proper (0+d)%Qinf d).
   apply H1.
   change (0 + d == d). ring.
  Qed.

  Lemma mspc_ball_weak_le (q q': Qinf): (q <= q')%Qinf → ∀ x y: X, mspc_ball q x y → mspc_ball q' x y.
  Proof with auto.
   destruct q, q'; simpl; intros...
     assert (q0 == q + (q0 - q))%Q as E by ring.
     rewrite (mspc_ball_proper q0 (q+(q0-q)) x y E).
     change (mspc_ball (Qinf.finite q + Qinf.finite (q0 - q)%Q) x y).
     apply mspc_triangle with y...
     apply mspc_refl.
     simpl.
     apply QArith_base.Qplus_le_r with q.
     ring_simplify...
    apply mspc_ball_inf.
   intuition.
  Qed.

  Lemma mspc_ball_e_wd : ∀ (e d : Q) (x y : X),
      e == d → mspc_ball e x y ↔ mspc_ball d x y.
  Proof.
    intros. apply mspc_ball_proper, H1.
  Qed.

  Lemma mspc_ball_wd : forall (e d : Qinf) x1 x2 y1 y2,
      e = d -> x1 = x2 -> y1 = y2
      -> (mspc_ball e x1 y1 <-> mspc_ball d x2 y2).
  Proof.
    unfold equiv, mspc_equiv. split.
    - intros.
      destruct d as [d|]. 2: apply mspc_ball_inf.
      destruct e as [e|]. 2: inversion H1. simpl in H1.
    assert (0+(e+0) == d).
    { rewrite Qplus_0_r, Qplus_0_l. exact H1. }
    apply (mspc_ball_e_wd _ _ x2 y2 H5).
    clear H5 H1 d.
    pose proof (mspc_triangle 0 (e+0) x2 x1 y2).
    apply H1. clear H1.
    apply mspc_sym, H2.
    pose proof (mspc_triangle e 0 x1 y1 y2).
    apply H5. exact H4. exact H3.
  - intros.
    destruct e as [e|]. 2: apply mspc_ball_inf.
    destruct d as [d|]. 2: inversion H1. simpl in H1.
    assert (0+(d+0) == e).
    { rewrite Qplus_0_r, Qplus_0_l. rewrite H1. reflexivity. }
    apply (mspc_ball_e_wd _ _ x1 y1 H5).
    clear H5 H1 e.
    pose proof (mspc_triangle 0 (d+0) x1 x2 y1).
    apply H1. exact H2. clear H1.
    pose proof (mspc_triangle d 0 x2 y2 y1).
    apply H1. exact H4.
    apply mspc_sym, H3.
  Qed.

  (** Instances can be bundled to yield MetricSpaces: *)
  Program Definition bundle_MetricSpace: MetricSpace :=
    Build_MetricSpace mspc_ball_e_wd _.

  Next Obligation. Proof with auto.
   constructor.
   - intros e epos. apply mspc_refl, epos.
   - intros. apply mspc_sym.
   - intros. apply (mspc_triangle e1 e2 a b c)...
   - intros. apply mspc_closed...
     intros. apply H1. apply Qpos_ispos.
   - intros. apply Qnot_lt_le. intro abs.
     destruct H0. exact (mspc_ball_negative0 e abs a b H1).
   - intros. apply mspc_stable, H1.
  Qed.

  (** .. which obviously have the same carrier: *)

  Goal X ≡ bundle_MetricSpace.
  Proof. reflexivity. Qed.

End MetricSpaceClass.

#[global]
Instance: Params (@mspc_ball) 2 := {}.

#[global]
Hint Resolve Qlt_le_weak Qplus_lt_le_0_compat.
  (* Todo: Move. *)

(** We now define the smart constructor that builds a MetricSpace from a ball relation with positive radius. *)

Section genball.

  Context
    `{Setoid X}
    (R: Qpos → relation X) `{!Proper (QposEq ==> (=)) R}  `{∀ e, Reflexive (R e)} `{∀ e, Symmetric (R e)}
    (Rtriangle: ∀ (e1 e2: Qpos) (a b c: X), R e1 a b → R e2 b c → R (e1 + e2)%Qpos a c)
    (Req: ∀ (a b: X), (∀ d: Qpos, R d a b) → a = b)
    (Rclosed: ∀ (e: Qpos) (a b: X), (∀ d: Qpos, R (e + d)%Qpos a b) → R e a b)
    (Rstable: ∀ (e: Qpos) (a b: X), (~~R e a b) → R e a b).

  Definition genball: MetricSpaceBall X := λ (oe: Qinf),
    match oe with
    | Qinf.infinite => λ _ _, True
    | Qinf.finite e =>
      match Qdec_sign e with
      | inl (inl _) => λ _ _ , False
      | inl (inr p) => R (exist (Qlt 0) e p)
      | inr _ => equiv
      end
    end.

  Definition ball_genball (q: Qpos) (a b: X): genball q a b ↔ R q a b.
  Proof.
   unfold genball; simpl.
   destruct Qdec_sign as [[|]|U].
     exfalso.
     destruct q.
     apply (Qlt_is_antisymmetric_unfolded 0 x); assumption.
    apply Proper0; reflexivity.
   exfalso.
   destruct q.
   simpl in U.
   revert q.
   rewrite U.
   apply Qlt_irrefl.
  Qed.

  Lemma genball_alt (q: Q) (x y: X):
    genball q x y <->
        match Qdec_sign q with
        | inl (inl _) => False
        | inl (inr p) => genball q x y
        | inr _ => x=y
        end.
  Proof.
   unfold genball. simpl.
   split; destruct Qdec_sign as [[|]|]; auto.
  Qed.

  Instance genball_Proper: Proper ((=) ==> (=) ==> (=) ==> iff) genball.
  Proof with auto; intuition.
   unfold genball.
   intros u e' E.
   destruct u, e'.
      change (q = q0) in E.
      destruct Qdec_sign as [[|]|]; destruct Qdec_sign as [[|]|].
              repeat intro...
             exfalso. revert q1. apply Qlt_is_antisymmetric_unfolded. rewrite E...
            exfalso. revert q1. rewrite E. rewrite q2. apply Qlt_irrefl.
           exfalso. revert q1. rewrite E. apply Qlt_is_antisymmetric_unfolded...
          apply Proper0...
         exfalso. revert q1. rewrite E, q2. apply Qlt_irrefl.
        exfalso. revert q2. rewrite <- E, q1. apply Qlt_irrefl.
       exfalso. revert q2. rewrite <- E, q1. apply Qlt_irrefl.
      intros ?? A ?? B. rewrite A, B...
     repeat intro...
    intuition.
   repeat intro.
   reflexivity.
  Qed.

Instance: ∀ e, Proper ((=) ==> (=) ==> iff) (genball e).
Proof. intros; now apply genball_Proper. Qed.

  Lemma genball_negative (q: Q): (q < 0)%Q → ∀ x y: X, ~ genball q x y.
  Proof with auto.
   unfold genball.
   intros E ??.
   destruct Qdec_sign as [[|]|U]; intro...
    apply (Qlt_is_antisymmetric_unfolded 0 q)...
   revert E.
   rewrite U.
   apply Qlt_irrefl.
  Qed.

  Lemma genball_Reflexive (q: Qinf): (0 <= q)%Qinf → Reflexive (genball q).
  Proof with auto.
   repeat intro.
   unfold genball.
   destruct q...
   destruct Qdec_sign as [[|]|]; intuition...
   apply (Qlt_not_le q 0)...
  Qed.

  Global Instance genball_Symmetric: ∀ e, Symmetric (genball e).
  Proof with auto.
   intros [q|]... simpl. destruct Qdec_sign as [[|]|]; try apply _...
  Qed.

  Lemma genball_triangle (e1 e2: Qinf) (a b c: X): genball e1 a b → genball e2 b c → genball (e1 + e2) a c.
  Proof with auto.
   intros U V.
   destruct e1 as [e1|]...
   destruct e2 as [e2|]...
   apply genball_alt.
   apply genball_alt in U.
   apply genball_alt in V.
   destruct (Qdec_sign (e1 + e2)) as [[G | I] | J];
   destruct (Qdec_sign e1) as [[A | B] | C];
   destruct (Qdec_sign e2) as [[D | E] | F]; intuition.
   revert G. apply (Qlt_is_antisymmetric_unfolded _ _)...
   revert G. rewrite F, Qplus_0_r. apply (Qlt_is_antisymmetric_unfolded _ _ B)...
   revert G. rewrite C, Qplus_0_l. apply (Qlt_is_antisymmetric_unfolded _ _ E)...
   revert G. rewrite C, F. apply Qlt_irrefl.
   change (genball (exist _ e1 B + exist _ e2 E )%Qpos a c).
   apply ball_genball.
   apply Rtriangle with b; apply ball_genball...
   rewrite <- V.
   assert (e1 + e2 == e1) by (rewrite F, Qplus_0_r; reflexivity).
   apply (genball_Proper (e1+e2) e1 H2 a a (reflexivity _) b b (reflexivity _)), U.
   rewrite U.
   assert (e1 + e2 == e2) by (rewrite C, Qplus_0_l; reflexivity).
   apply (genball_Proper (e1+e2) e2 H2 b b (reflexivity _) c c (reflexivity _)), V.
   rewrite U, V.
   apply genball_Reflexive.
   apply Qlt_le_weak, I.
   exfalso.
   apply Qlt_le_weak in E.
   apply (Qplus_lt_le_compat _ _ _ _ B) in E.
   rewrite J in E. apply (Qlt_irrefl 0 E).
   exfalso. rewrite F, Qplus_0_r in J.
   rewrite J in B. exact (Qlt_irrefl 0 B).
   exfalso. rewrite C, Qplus_0_l in J.
   rewrite J in E. exact (Qlt_irrefl 0 E).
  Qed.

  Lemma genball_closed :
    (∀ (e: Qinf) (a b: X), (∀ d: Qpos, genball (e + d) a b) → genball e a b).
  Proof with auto with *.
   intros.
   unfold genball.
   destruct e...
   destruct Qdec_sign as [[|]|].
     assert (0 < (1#2) * -q)%Q.
      apply Qmult_lt_0_compat...
      apply Qopp_Qlt_0_l...
     pose proof (H2 (exist _ _ H3)).
     refine (genball_negative _ _ _ _ H4).
     simpl.
     ring_simplify.
     apply Qopp_Qlt_0_l...
     setoid_replace (- ((1 # 2) * q))%Q with (-q * (1#2))%Q by (simpl; ring).
     apply Qmult_lt_0_compat...
     apply Qopp_Qlt_0_l...
    apply Rclosed.
    intros.
    apply ball_genball.
    apply (H2 d).
   apply Req.
   intros.
   apply ball_genball.
   assert (d == q + d) by (rewrite q0, Qplus_0_l; reflexivity).
   apply (genball_Proper d (q+d) H3 a a (reflexivity _) b b (reflexivity _)), H2.
  Qed.

  Lemma genball_stable :
    (∀ (e: Q) (a b: X), (~~genball e a b) → genball e a b).
  Proof.
    intros. unfold genball.
    unfold genball in H2.
    destruct (Qdec_sign e). destruct s.
    - contradict H2. intro H2. contradiction.
    - apply Rstable, H2.
    - apply Req. unfold equiv in H2.
      intro d. apply Rstable.
      intro abs. contradict H2; intro H2.
      contradict abs.
      rewrite H2.
      apply H0.
  Qed.

  Instance genball_MetricSpace: @MetricSpaceClass X genball.
  Proof.
   constructor; try apply _.
   - unfold mspc_ball. intros. rewrite H2. reflexivity.
   - reflexivity.
   - apply genball_negative.
   - apply genball_Reflexive.
   - apply genball_triangle.
   - apply genball_closed.
   - apply genball_stable.
  Qed.

End genball.

(** Bundled MetricSpaces immediately yield instances of the classes: *)

#[global]
Instance: ∀ X: MetricSpace, MetricSpaceBall X := λ X, @genball X _ (@ball X).

#[global]
Instance class_from_MetricSpace (X: MetricSpace): MetricSpaceClass X.
Proof.
 apply genball_MetricSpace.
 - intros q r H x y H0 z t H1.
   apply ball_wd; assumption.
 - intros e. apply msp_refl. exact (msp X).
   apply Qpos_nonneg.
 - intro e. apply msp_sym, (msp X).
 - intros e1 e2. apply msp_triangle, X.
 - intros x y H.
   apply ball_closed.
   intros. rewrite Qplus_0_l. apply (H (exist _ _ H0)).
 - intros e x y H. apply msp_closed.
   exact (msp X). intros. apply (H (exist _ _ H0)).
 - intros. apply (msp_stable (msp X)), H.
Qed.

Section products.

  Context `{MetricSpaceClass X} `{MetricSpaceClass Y}.

  Global Instance: MetricSpaceBall (X * Y)
    := λ e a b, mspc_ball X e (fst a) (fst b) ∧ mspc_ball Y e (snd a) (snd b).

  (* We do not reuse ProductMS here because to do so we'd need to go through genball,
   resulting in the problems described earlier. *)

  Global Instance: MetricSpaceClass (X * Y).
  Proof with auto.
   constructor.
   - intros. split. intros. destruct H4. split.
     rewrite <- (mspc_ball_proper X e1 e2 (fst x) (fst y) H3). exact H4.
     rewrite <- (mspc_ball_proper Y e1 e2 (snd x) (snd y) H3). exact H5.
     intros. destruct H4. split.
     rewrite (mspc_ball_proper X e1 e2 (fst x) (fst y) H3). exact H4.
     rewrite (mspc_ball_proper Y e1 e2 (snd x) (snd y) H3). exact H5.
   - split. apply (mspc_ball_inf X).
     apply (mspc_ball_inf Y).
   - repeat intro.
        destruct H4.
        apply (mspc_ball_negative X _ H3 _ _ H4).
   - intros e H3 x. split; apply mspc_refl.
     exact H0. exact H3. exact H2. exact H3.
   - split; apply (@symmetry _ _ ); try apply _; apply H3. (* just using [symmetry] here causes evar anomalies.. *)
   - split.
     apply (mspc_triangle X) with (fst b).
      apply H3.
     apply H4.
    apply (mspc_triangle Y) with (snd b).
     apply H3.
    apply H4.
   - split.
    apply (mspc_closed X). apply H3.
   apply (mspc_closed Y). apply H3.
   - split.
   apply (mspc_stable X).
   intro abs. contradict H3; intro H3.
   destruct H3. contradiction.
   apply (mspc_stable Y).
   intro abs. contradict H3; intro H3.
   destruct H3. contradiction.
  Qed.

End products.

(* Workaround Vector.Forall2, which is hard to destruct. *)
Fixpoint Vector_Forall2 {X : Type} {n : nat} (P : X -> X -> Prop)
         (x y : Vector.t X n) { struct x } : Prop.
Proof.
  destruct x as [|xh n xt].
  - exact True.
  - exact (P xh (Vector.hd y) /\ Vector_Forall2 X n P xt (Vector.tl y)).
Defined.

Section vector_setoid.

  Context `{Setoid X} (n: nat).

  Global Instance: Equiv (Vector.t X n) := Vector_Forall2 equiv.

  Global Instance vector_setoid: Setoid (Vector.t X n).
  Proof.
   constructor.
   - intro x.
     unfold equiv, Equiv_instance_0.
     induction x; simpl; constructor.
     reflexivity. exact IHx.
   - intros x y H0.
     unfold equiv, Equiv_instance_0, equiv.
     unfold equiv, Equiv_instance_0, equiv in H0.
     induction x.
     + apply (Vector.case0 (fun y => Vector_Forall2 Ae y (Vector.nil X))).
       simpl. trivial.
     + simpl in H0.
       revert H0.
       apply (Vector.caseS' y). clear y.
       intros. destruct H0.
       split. simpl. symmetry. exact H0.
       apply IHx, H1.
   - intros x y z H1 H2.
     unfold Transitive, equiv, Equiv_instance_0, equiv.
     unfold Transitive, equiv, Equiv_instance_0, equiv in H1.
     unfold Transitive, equiv, Equiv_instance_0, equiv in H2.
     induction x.
     + simpl. trivial.
     + revert H2.
       apply (Vector.caseS' z).
       clear z. intros zh zt.
       revert H1.
       apply (Vector.caseS' y).
       clear y. intros yh yt H0 H1.
       simpl in H0. simpl in H1.
       destruct H0, H1.
       split. simpl.
       transitivity yh; assumption.
       simpl. apply (IHx yt); assumption.
  Qed.

End vector_setoid. (* Todo: Move. *)

Section vectors.

  Context `{MetricSpaceClass X} (n: nat).

  Global Instance: MetricSpaceBall (Vector.t X n) :=
    λ e, Vector_Forall2 (mspc_ball X e).

End vectors.

(** I decided to experiment with a class used strictly to declare a metric space's
 components in a section using [Context] without also declaring the metric space structure
 itself, and risking accidental parameterization of the section context on the proof of that
 metric space structure if such parametrization is unneeded (for instance because there is
 already a UniformContinuous constraint which incorporates the metric space proof. *)

Class MetricSpaceComponents X `{MetricSpaceBall X}: Prop.

(** Next, we introduce classes for uniform continuity (which is what we're really after, since
 we will use these to automatically derive uniform continuity for various forms of function
 composition). *)

Arguments mspc_ball {X MetricSpaceBall}.

Class Canonical (T: Type): Type := canonical: T.
  (* Todo: Move. *)

#[global]
Instance: ∀ {T: Type}, Canonical (T → T) := @Datatypes.id.

#[global]
Instance: Canonical (Qpos → Qinf) := Qinf.finite ∘ QposAsQ.

#[global]
Instance composed_Proper `{Equiv A} `{Equiv B} `{Equiv C} (f: B → C) (g: A → B):
  Proper (=) f → Proper (=) g → Proper (=) (f ∘ g).
Proof with auto.
 repeat intro.
 unfold Basics.compose.
 apply H2.
 apply H3.
 assumption.
Qed.

#[global]
Instance: Proper (QposEq ==> (=)) QposAsQ.
Proof. repeat intro. assumption. Qed.

Require Import util.Container.

Definition Ball X R := prod X R.
#[global]
Hint Extern 0 (Equiv (Ball _ _)) => eapply @prod_equiv : typeclass_instances.

Section Ball.
  Context X `{MetricSpaceBall X} (R: Type) `{Canonical (R → Qinf)}.

  Global Instance ball_contains: Container X (Ball X R) := fun b => mspc_ball (canonical (snd b)) (fst b).

  Context `{Equiv R} `{!MetricSpaceClass X} `{!Proper (=) (canonical: R → Qinf)}.

  Local Instance : Equiv X :=
    fun x y => mspc_ball 0 x y.

  Global Instance ball_contains_Proper: Proper (=) (In: Ball X R → X → Prop).
  Proof with auto.
   repeat intro.
   unfold In, ball_contains.
   unfold canonical. unfold canonical in Proper0.
   apply mspc_ball_wd...
    apply Proper0.
    apply H2.
    apply H2.
  Qed. (* Todo: Clean up. *)

End Ball.

(*Instance: Params (@contains) 4.

Implicit Arguments contains [[X] [H] [H0] [R]].*)

Section sig_metricspace.

  Context `{MetricSpaceClass X} (P: X → Prop).

  Global Instance sig_mspc_ball: MetricSpaceBall (sig P) := λ e x y, mspc_ball e (` x) (` y).

  Global Instance sig_mspc: MetricSpaceClass (sig P).
  Proof with auto.
   constructor.
   - intros. destruct x, y.
     unfold mspc_ball, sig_mspc_ball. simpl.
     apply mspc_ball_wd. exact H0. exact H1.
     apply mspc_refl. exact H0. apply Qle_refl.
     apply mspc_refl. exact H0. apply Qle_refl.
   - intros.
     change (mspc_ball Qinf.infinite (` x) (` y)).
     apply (mspc_ball_inf X).
   - intros. destruct x, y.
     unfold mspc_ball, sig_mspc_ball. simpl.
     apply mspc_ball_negative. exact H0. exact H1.
   - intros d H1 x. destruct x.
     unfold mspc_ball, sig_mspc_ball. simpl.
     apply mspc_refl. exact H0. exact H1.
   - repeat intro.
     change (mspc_ball e (` y) (` x)).
     symmetry...
   - repeat intro.
    apply (mspc_triangle X e1 e2 (` a) (` b))...
   - intros.
   apply (mspc_closed X e (` a) (` b))...
   - intros. apply (mspc_stable X e (` a) (` b))...
  Qed.

End sig_metricspace.

#[global]
Instance Qpos_mspc_ball: MetricSpaceBall Qpos
  := @sig_mspc_ball Q_as_MetricSpace _ (Qlt 0).
#[global]
Instance Qpos_mspc: MetricSpaceClass Qpos
  := @sig_mspc Q_as_MetricSpace _ _ (Qlt 0).

#[global]
Instance: Cast QnnInf.T Qinf :=
  λ x, match x with
    | QnnInf.Infinite => Qinf.infinite
    | QnnInf.Finite q => Qinf.finite (proj1_sig q)
    end.

Section uniform_continuity.

  Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y}.

  Class UniformlyContinuous_mu (f: X → Y): Type := { uc_mu: Qpos → QposInf }.
    (* Note: If we omit the {} around the uc_mu field and let the class become a definitional class,
     instance resolution will often find the wrong instance because the type of uc_mu is the same for
     different instantiations of X and Y. This solution is not ideal. *)

  Context (f: X → Y) `{!UniformlyContinuous_mu f}.

  Class UniformlyContinuous: Prop :=
    { uc_from: MetricSpaceClass X
    ; uc_to: MetricSpaceClass Y
    ; uniformlyContinuous: ∀ (e: Qpos) (a b: X), mspc_ball (uc_mu e) a b → mspc_ball e (f a) (f b) }.

  (** If we have a function with this constraint, then we can bundle it into a UniformlyContinuousFunction: *)

  Context `{uc: UniformlyContinuous}.

  Let hint := uc_from.
  Let hint' := uc_to.

(*  Program Definition wrap_uc_fun
    : UniformlyContinuousFunction (bundle_MetricSpace X) (bundle_MetricSpace Y)
    := @Build_UniformlyContinuousFunction (bundle_MetricSpace X) (bundle_MetricSpace Y) f uc_mu _.

  Next Obligation. Proof with auto.
   repeat intro.
   unfold ball. simpl.
   apply uniformlyContinuous.
   destruct uc_mu...
   apply (mspc_ball_inf X).
  Qed.*)

  (** Note that wrap_uc_fun _also_ bundles the source and target metric spaces, because
   UniformlyContinuousFunction is expressed in terms of the bundled data type for metric spaces. *)

End uniform_continuity.

Arguments uc_mu {X Y} f {UniformlyContinuous_mu}.

(** Local uniform continuity just means that the function restricted to any finite balls
 is uniformly continuous: *)

Section local_uniform_continuity.

  Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y}.

  Definition restrict (b: Ball X Qpos) (f: X → Y): sig ((∈ b)) → Y
    := f ∘ @proj1_sig _ _.

  Class LocallyUniformlyContinuous_mu (f: X → Y): Type :=
    luc_mu (b: Ball X Qpos):> UniformlyContinuous_mu (restrict b f).

  Context (f: X → Y) {mu: LocallyUniformlyContinuous_mu f}.

  Class LocallyUniformlyContinuous: Prop :=
    { luc_from: MetricSpaceClass X
    ; luc_to: MetricSpaceClass Y
    ; luc_uc (b: Ball X Qpos): UniformlyContinuous (restrict b f) }.

  Context `{LocallyUniformlyContinuous}.

  Local Instance : Equiv (X -> Y) :=
    fun x y => forall a : X, mspc_ball 0 (x a) (y a).

  Instance luc_Proper: Proper (=) f.
  Proof with simpl; intuition.
   repeat intro.
   pose proof luc_to.
   apply (mspc_eq Y).
   intros. apply mspc_refl.
   exact H4.
   apply Qpos_nonneg.
  Qed.

End local_uniform_continuity.

Section local_from_global_continuity.

  Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y}.

  Context (f: X → Y) {mu: UniformlyContinuous_mu f} {uc: UniformlyContinuous f}.

  Instance local_from_global_uc_mu: LocallyUniformlyContinuous_mu f
    := λ _, Build_UniformlyContinuous_mu _ (uc_mu f).

  Instance local_from_global_uc: LocallyUniformlyContinuous f.
  Proof with auto.
   constructor.
     apply uc.
    apply uc.
   intro.
   pose proof (uc_from f).
   pose proof (uc_to f).
   constructor; try apply _.
   intros.
   apply (uniformlyContinuous f).
   assumption.
  Qed.

End local_from_global_continuity.

(** Normally, we would like to use the type class constraints whenever we need uniform continuity of
 functions, including in the types for higher order functions. For instance, we would like to assign
 an integration function for uniformly continuous functions a type along the lines of:
   ∀ (f: sig (∈ r) → CR) `{!UniformlyContinuous f}, CR
 However, dependent types like these get in the way when we subsequently want to express continuity
 of this higher order function itself. Hence, a modicum of bundling is hard to avoid. However, we
 only need to bundle the components of the uniformly continuous function itself---there is no need to
 also start bundling source and target metric spaces the way UniformlyContinuousFunction and
 wrap_uc_fun do. Hence, we now introduce a record for uniformly continuous functions that does not
 needlessly bundle the source and target metric spaces. *)

Section shallowly_wrapped_ucfuns.

  Context `{@MetricSpaceComponents X Xb} `{@MetricSpaceComponents Y Yb}.
    (* We must name Xe/Xb/Ye/Yb here so that we can repeat them in the implicit argument
     specification later on. This could have been avoided if Coq offered more flexible
     commands for implicit argument specification that would let one reset implicit-ness for
     individual parameters without restating the whole list. *)

  Record UCFunction: Type := ucFunction
    { ucFun_itself:> X → Y
    ; ucFun_mu: UniformlyContinuous_mu ucFun_itself
    ; ucFun_uc: UniformlyContinuous ucFun_itself }.

  Local Instance : Equiv (X -> Y) :=
    fun x y => forall a : X, mspc_ball 0 (x a) (y a).

  Global Instance: ∀ (f: UCFunction), Proper (=) (f: X → Y).
  Proof. intros. destruct f.
   simpl.
   set (local_from_global_uc_mu ucFun_itself0).
   apply (@luc_Proper X _ Y _ ucFun_itself0 l).
   apply (local_from_global_uc _).
  Qed.

End shallowly_wrapped_ucfuns.

#[global]
Existing Instance ucFun_mu.
#[global]
Existing Instance ucFun_uc.

Arguments UCFunction X {Xb} Y {Yb}.
Arguments ucFunction {X Xb Y Yb} _ {ucFun_mu ucFun_uc}.

Section proper_functions.

  (* Todo: This is bad. Make instances for (@sig (A → B) (Proper equiv)) instead and delegate to it for UCFunction. *)

  Context `{Setoid A} `{MetricSpaceClass B}.

  Local Instance : Equiv (A -> B) :=
    fun x y => forall a : A, mspc_ball 0 (x a) (y a).

  Let T := (@sig (A → B) (Proper equiv)).

  (* The equivalence on functions is ext_equiv, ie equivalence of images
     for each equivalent arguments. *)
  Global Instance: Equiv T := λ x y, proj1_sig x = proj1_sig y.

  Global Instance: Setoid T.
  Proof.
   constructor.
   - intros [f fproper] x. simpl.
     apply mspc_refl. exact H1. apply Qle_refl.
   - intros [f fproper] [g gproper] fgeq x. simpl.
     apply mspc_sym. exact H1. apply fgeq.
   - intros [f fproper] [g gproper] [h hproper]
            fgeq gheq x.
     simpl.
     rewrite (mspc_ball_e_wd B 0 (0+0) (f x) (h x) eq_refl).
     pose proof (@mspc_triangle B H0 H1 0 0 (f x) (g x) (h x)).
     apply H2. apply fgeq. apply gheq.
  Qed.

  Global Instance: MetricSpaceBall T := λ e f g, Qinf.le 0 e ∧ ∀ a, mspc_ball e (` f a) (` g a).
    (* The 0<=e condition is needed because otherwise if A is empty, we cannot deduce
     False from a premise of two functions being inside a negative ball of eachother.
     If this turns out to be annoying, we can make a separate higher-priority metric space instance
     for functions from a known-nonempty type (registered with a NonEmpty type class). *)

End proper_functions.

Section uc_functions.

  (* Todo: Just delegate to proper_functions. *)

  Context `{MetricSpaceClass A} `{MetricSpaceClass B}.

  Local Instance : Equiv (A -> B) :=
    fun x y => forall a : A, mspc_ball 0 (x a) (y a).

  Global Instance: Equiv (UCFunction A B) := equiv: relation (A→B).

  Global Instance: Setoid (UCFunction A B).
  Proof.
   constructor.
   - intros f x. apply mspc_refl. exact H2. apply Qle_refl.
   - intros f g H3 x. apply mspc_sym. exact H2. apply H3.
   - intros f g h fgeq gheq x.
     rewrite (mspc_ball_e_wd B 0 (0+0) (f x) (h x) eq_refl).
     pose proof (@mspc_triangle B H1 H2 0 0 (f x) (g x) (h x)).
     apply H3. apply fgeq. apply gheq.
  Qed.

  Global Instance: MetricSpaceBall (UCFunction A B) := λ e f g, Qinf.le 0 e ∧ ∀ a, mspc_ball e (f a) (g a).
    (* The 0<=e condition is needed because otherwise if A is empty, we cannot deduce
     False from a premise of two functions being inside a negative ball of eachother.
     If this turns out to be annoying, we can make a separate higher-priority metric space instance
     for functions from a known-nonempty type (registered with a NonEmpty type class). *)

  Lemma Proper_uc_ball : Proper equiv mspc_ball.
  Proof.
    intros d e deeq f g fgeq h k hkeq.
    split.
    - intros [dpos H3].
      split. rewrite <- deeq. exact dpos.
      intro x. specialize (H3 x).
      specialize (fgeq x).
      specialize (hkeq x).
      rewrite <- (@mspc_ball_wd B _ H2 d e (f x) (g x) (h x) (k x)
                               deeq fgeq hkeq).
      exact H3.
    - intros [dpos H3].
      split. rewrite deeq. exact dpos.
      intro x. specialize (H3 x).
      specialize (fgeq x).
      specialize (hkeq x).
      symmetry in deeq.
      apply mspc_sym in fgeq.
      apply mspc_sym in hkeq.
      rewrite <- (@mspc_ball_wd B _ H2 e d (g x) (f x) (k x) (h x)
                               deeq fgeq hkeq).
      exact H3. exact H2. exact H2.
  Qed.

  Global Instance UCFunction_MetricSpace: MetricSpaceClass (UCFunction A B).
  Proof.
   constructor.
   - split.
     + intros. destruct H4. split.
       rewrite <- H3. exact H4. intro a.
       destruct e2 as [e2|]. 2: apply mspc_ball_inf, H2.
       destruct e1 as [e1|].
       rewrite (@mspc_ball_e_wd B _ H2 e2 e1). apply H5.
       symmetry. exact H3. inversion H3.
     + intros. destruct H4. split.
       rewrite H3. exact H4. intro a.
       destruct e1 as [e1|]. 2: apply mspc_ball_inf, H2.
       destruct e2 as [e2|].
       rewrite (@mspc_ball_e_wd B _ H2 e1 e2). apply H5.
       exact H3. inversion H3.
   - intros f g. split. simpl. trivial.
     intro x. apply (mspc_ball_inf B).
   - intros. intros [H4 _].
     exact (Qlt_not_le _ _ H3 H4).
   - intros e epos f. split. exact epos.
     intros x. apply (mspc_refl B _ epos).
   - intros e f g [epos H3].
     split. exact epos. intro x.
     apply (mspc_sym B), (H3 x).
   - intros. destruct H3, H4. split.
     apply Qinf.le_0_plus_compat; assumption.
     intros x. specialize (H5 x). specialize (H6 x).
     apply (mspc_triangle B) with (b x); assumption.
   - intros. split.
     + destruct e as [e|]. 2: simpl; auto.
       simpl. destruct (Qlt_le_dec e 0). 2: exact q.
       exfalso.
       assert (0 < (1#2) * -e)%Q.
       apply Qmult_lt_0_compat. reflexivity.
       apply Qopp_Qlt_0_l, q.
       destruct (H3 (exist _ _ H4)) as [H5 _].
       simpl in H5. clear q.
       apply (Qlt_not_le _ _ H4). clear H4.
       apply (Qplus_le_l ((1#2)*e)).
       ring_simplify.
       ring_simplify in H5.
       setoid_replace (0#4) with 0%Q by reflexivity.
       exact H5.
     + intros x.
       apply (mspc_closed B).
       intros. apply H3.
   - intros e f g H3. split.
     + apply Qnot_lt_le. intro H4.
       contradict H3; intro H3.
       destruct H3 as [H3 _].
       exact (Qlt_not_le _ _ H4 H3).
     + intro x.
       apply (mspc_stable B). intro abs.
       contradict H3; intro H3.
       destruct H3 as [epos H3].
       exact (abs (H3 x)).
  Qed.

End uc_functions.

(** If source and target are /already/ bundled, then we don't need to rebundle them when bundling
 a uniformly continuous function: *)

Program Definition wrap_uc_fun' {X Y: MetricSpace} (f: X → Y)
  `{!UniformlyContinuous_mu f}
  `{@UniformlyContinuous X _ Y _ f _}:
    UniformlyContinuousFunction X Y :=
  @Build_UniformlyContinuousFunction X Y f (uc_mu f) _.

Next Obligation. Proof with auto.
 intros ????.
 assert (mspc_ball (uc_mu f e) a b).
  revert H0.
  set (uc_mu f e).
  intros.
  destruct q...
  apply <- (ball_genball (@ball X) q)...
 pose proof (uniformlyContinuous f e a b H1).
 apply (@ball_genball Y (@msp_eq Y) _
                      (fun q => ball (proj1_sig q))).
 2: auto.
 intros x y H4 z t H5 u v H6.
 unfold QposEq in H4. rewrite H4.
 rewrite H5, H6. reflexivity.
Qed.

(** Conversely, if we have a UniformlyContinuousFunction (between bundled metric spaces) and project
 the real function out of it, instances of the classes can easily be derived. *)

Open Scope uc_scope.

Section unwrap_uc.

  Context {X Y: MetricSpace} (f: X --> Y).

  Global Instance unwrap_mu: UniformlyContinuous_mu f := { uc_mu := mu f }.

  Global Instance unwrap_uc_fun: UniformlyContinuous f.
  Proof with auto.
   constructor; try apply _.
   unfold uc_mu, unwrap_mu.
   destruct f.
   simpl. intros.
   unfold mspc_ball.
   unfold MetricSpaceBall_instance_0.
   apply ball_genball.
    apply _.
   apply uc_prf.
   set (mu e) in *.
   destruct q...
   simpl.
   apply (@ball_genball X (@msp_eq X) _
                      (fun q => ball (proj1_sig q))).
   2: auto.
   intros x y H4 z t H5 u v H6.
   unfold QposEq in H4. rewrite H4.
   rewrite H5, H6. reflexivity.
  Qed.

End unwrap_uc.

(** Extentionally equal functions are obviously equally uniformly continuous (with extensionally equal mu's): *)

Lemma UniformlyContinuous_proper `{MetricSpaceClass X} `{MetricSpaceClass Y} (f g: X → Y)
  `{!UniformlyContinuous_mu f} `{!UniformlyContinuous_mu g}:
  (∀ x, mspc_equiv Y (f x) (g x)) → (∀ e, uc_mu f e ≡ uc_mu g e) →
    UniformlyContinuous f → UniformlyContinuous g.
      (* Todo: Stronger versions of this statement can be proved with a little effort. *)
Proof.
 constructor; try apply _.
 intros ????.
 pose proof (mspc_ball_proper Y) as H7.
 rewrite <- (mspc_ball_wd Y e e (f a) (g a) (f b) (g b)).
 apply (uniformlyContinuous f).
 rewrite H4. auto.
 reflexivity. apply H3. apply H3.
Qed.

(** We now show that a couple of basic functions are continuous: *)

(** The identity function is uniformly continuous: *)

Section id_uc. Context `{MetricSpaceClass X}.
  Global Instance: UniformlyContinuous_mu (@Datatypes.id X) := { uc_mu := Qpos2QposInf }.
  Global Instance: UniformlyContinuous (@Datatypes.id X).
  Proof. constructor; try apply _. intros. assumption. Qed.
End id_uc.
  (* Note: We don't need a separate instance for the [id] constant. If such an instance
   is needed, we can use [Hint Unfold id: typeclass_instances.] *)

(** Constant functions are uniformly continuous: *)

Section const_uc. Context `{MetricSpaceClass X} `{MetricSpaceClass Y} (y: Y).
  Global Instance: UniformlyContinuous_mu (@Basics.const Y X y) := { uc_mu := λ _, QposInfinity }.
  Global Instance: UniformlyContinuous (@Basics.const Y X y).
  Proof. repeat intro. constructor; try apply _. intros. apply (mspc_refl Y e). simpl. auto. Qed.
End const_uc.

(** Mapping both of a pair's components by uniformly continuous functions
 is uniformly continuous: *)

Section exist_uc.
  Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y} (P: Y → Prop)
    (f: X → Y) (g: ∀ x, P (f x)) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}.

  Global Instance exist_mu: UniformlyContinuous_mu (λ x: X, exist P (f x) (g x)) := { uc_mu := uc_mu f }.

  Global Instance exist_uc: UniformlyContinuous (λ x: X, exist P (f x) (g x)).
  Proof with auto.
   constructor.
     apply (uc_from f).
    pose proof (uc_to f).
    apply _.
   intros.
   apply (uniformlyContinuous f).
   assumption.
  Qed.
End exist_uc.

Section map_pair_uc.
  Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y}
    `{MetricSpaceComponents A} `{MetricSpaceComponents B}
    (f: X → Y) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}
    (g: A → B) `{!UniformlyContinuous_mu g} `{!UniformlyContinuous g}.

  Global Instance: UniformlyContinuous_mu (map_pair f g) :=
    { uc_mu := λ x, QposInf_min (uc_mu f x) (uc_mu g x) }.

  Let hint := uc_from g.
  Let hint' := uc_to g.
  Let hint'' := uc_from f.
  Let hint''' := uc_to f.

End map_pair_uc.

(** The diagonal function is uniformly continuous: *)

Section diagonal_uc.
  Context `{MetricSpaceClass X}.

  Global Instance: UniformlyContinuous_mu (@diagonal X) := { uc_mu := Qpos2QposInf }.

  Global Instance: UniformlyContinuous (@diagonal X).
  Proof. constructor; try apply _. intros ??? E. split; auto. Qed.
End diagonal_uc.

(** fst/snd/pair are uniformly continuous: *)

Section pairops_uc.
  Context `{MetricSpaceClass A} `{MetricSpaceClass B}.

  Global Instance: UniformlyContinuous_mu (@fst A B) := { uc_mu := Qpos2QposInf }.
  Global Instance: UniformlyContinuous_mu (@snd A B) := { uc_mu := Qpos2QposInf }.
  Global Instance: UniformlyContinuous_mu (uncurry (@pair A B)) := { uc_mu := Qpos2QposInf }.
  Global Instance: ∀ a, UniformlyContinuous_mu (@pair A B a) := { uc_mu := Qpos2QposInf }.

  Global Instance: UniformlyContinuous (@fst A B).
  Proof. constructor; try apply _. intros ??? P. apply P. Qed.
  Global Instance: UniformlyContinuous (@snd A B).
  Proof. constructor; try apply _. intros ??? P. apply P. Qed.
  Global Instance: UniformlyContinuous (uncurry (@pair A B)).
  Proof. constructor; try apply _. intros ??? P. apply P. Qed.
  Global Instance: ∀ a, UniformlyContinuous (@pair A B a).
  Proof. constructor; try apply _. intros ??? P.  split. apply (mspc_refl A). simpl. auto. apply P. Qed.
End pairops_uc.

Section compose_uc.
  Context `{MetricSpaceComponents X}  `{MetricSpaceComponents Y} `{MetricSpaceComponents Z'}
   (f: Y → Z') `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}
   (g: X → Y) `{!UniformlyContinuous_mu g} `{!UniformlyContinuous g}.

  Global Instance compose_mu: UniformlyContinuous_mu (f ∘ g)%prg :=
    { uc_mu := λ e, QposInf_bind (uc_mu g) (uc_mu f e) }.

  Let hint := uc_from g.
  Let hint' := uc_to g.
  Let hint'' := uc_to f.

End compose_uc.

Section curried_uc.
  Context `{MetricSpaceClass X} `{MetricSpaceClass Y} `{MetricSpaceClass Z'} (f: X → Y → Z')
   `{fmu1: ∀ x: X, UniformlyContinuous_mu (f x)}
   `{fuc1: ∀ x: X, UniformlyContinuous (f x)}
   `{fmu: !UniformlyContinuous_mu (λ p, f (fst p) (snd p))}
   `{fuc: !UniformlyContinuous (λ p, f (fst p) (snd p))}.

  Local Notation F := (λ x: X, {| ucFun_itself := λ y: Y, f x y; ucFun_mu := fmu1 x; ucFun_uc := fuc1 x |}).

  Global Instance curried_mu: UniformlyContinuous_mu F := { uc_mu := uc_mu (λ p, f (fst p) (snd p)) }.

  Global Instance curried_uc: UniformlyContinuous F.
  Proof with simpl; auto.
   constructor; try apply _.
   split...
   simpl in *.
   destruct fuc.
   intros.
   apply (@uniformlyContinuous0 e (a, a0) (b, a0)).
   simpl.
   set (q := uc_mu (λ p, f (fst p) (snd p)) e) in *.
   destruct q...
    split...
    apply (mspc_refl Y)...
   apply (mspc_ball_inf _).
  Qed.
End curried_uc.

Class HasLambda `{X: Type} (x: X): Prop.

#[global]
Instance lambda_has_lambda `(f: A → B): HasLambda (λ x, f x) := {}.
#[global]
Instance application_has_lambda_left: ∀ `(f: A → B) (x: A), HasLambda f → HasLambda (f x) := {}.
#[global]
Instance application_has_lambda_right: ∀ `(f: A → B) (x: A), HasLambda x → HasLambda (f x) := {}.

Section lambda_uc.

  Context `{MetricSpaceComponents A} `{MetricSpaceComponents B}  (f: A → B).

  Global Instance lambda_mu `{!HasLambda f} {free_f: A → B} `{!PointFree f free_f} `{!UniformlyContinuous_mu free_f}: UniformlyContinuous_mu f.
    (* Note: The HasLambda and PointFree constraints cannot be added to the Context declaration
     above because the definition of this mu needs to depend on them /despite/ not using them.
     Without the dependency, lambda_mu would be allowed to find a random free_f of the right signature
     for which it happens to have a mu already, and use that one.
     We do not factor out the mu constraint either, because for (dubious) efficiency reasons it is critical
     that it appear /after/ the PointFree constraint.*)
  Proof. constructor. apply UniformlyContinuous_mu0. Defined.

  Context `{!HasLambda f} {free_f: A → B} `{!PointFree f free_f} `{!UniformlyContinuous_mu free_f} `{!UniformlyContinuous free_f}.

  Global Instance lambda_uc: UniformlyContinuous f.
  Proof.
   destruct UniformlyContinuous0.
   constructor.
     apply _.
    apply _.
   destruct uc_from0.
   destruct uc_to0.
   intros.
   unfold PointFree in PointFree0.
   rewrite PointFree0.
   apply uniformlyContinuous0.
   unfold uc_mu in H3.
   simpl in H3.
   assumption.
  Qed. (* Todo: Clean up. *)

End lambda_uc.

(*
Module test.
Section test.

  Context
    `{MetricSpaceClass A}
    (f: A → A → A)
    `{!UniformlyContinuous_mu (uncurry f)} `{!UniformlyContinuous (uncurry f)}
    `{!Proper (=) f}.

  Definition t0: UniformlyContinuous_mu (λ (x: A), f (f x x) (f x (f x x))) := _.

End test.
End test.
*)


From mathcomp Require Import ssreflect.
From Coq Require Import Program.Equality NArith ZArith_base List Floats.
Import ListNotations.

Notation " P ** Q " := (prod P Q) (at level 95, right associativity).

Inductive value : Set :=
  | val_i32: nat -> value
  | val_f32: float -> value
.

Inductive term : Set :=
  | term_const: value -> term
  | term_addi32
  | term_SEQ: term -> term -> term
.

Inductive value_type : Type :=
  | t_i32
  | t_f32
.

Inductive function_type : Type :=
  | Tf (t1s : list value_type) (t2s : list value_type)
.

Definition typeof (v : value) : value_type :=
  match v with
  | val_i32 _ => t_i32
  | val_f32 _ => t_f32
  end.

Inductive value_typing : value -> value_type -> Prop :=
  | vt: forall v, value_typing v (typeof v)
.

Inductive typing : term -> function_type -> Prop :=
  | typing_term_const : forall v vt,
      value_typing v vt -> typing (term_const v) (Tf [] [vt])
  | typing_term_addi32 : typing term_addi32 (Tf [t_i32; t_i32] [t_i32])
  | typing_weaken : forall t t1s t2s ts,
      typing t (Tf t1s t2s) -> typing t (Tf (ts ++ t1s) (ts ++ t2s))
  | typing_composition : forall t1 t2 t1s t2s t3s,
      typing t1 (Tf t1s t3s) ->
      typing t2 (Tf t3s t2s) ->
      typing (term_SEQ t1 t2) (Tf t1s t2s)
.

(* append induction on lists
 * the stdlib version uses Prop instead of Type *)
Lemma rev_list_ind_T :
  forall (A : Type) (P : list A -> Type),
  P [] ->
  (forall (a : A) (l : list A), P (rev l) -> P (rev (a :: l))) ->
  forall (l : list A), P (rev l).
Proof.
  intros A P Hemp Happ l.
  induction l as [|?? IHl].
  - apply Hemp.
  - apply Happ. apply IHl.
Qed.

Theorem rev_ind_T :
  forall (A : Type) (P : list A -> Type),
  P [] ->
  (forall (x : A) (l : list A), P l -> P (l ++ [x])) ->
  forall (l : list A), P l.
Proof.
  intros A P Hemp Happ l.
  induction l.
  - by apply Hemp.
  - assert (Hrev : a :: l = (rev (rev l ++ [a]))).
    { rewrite rev_unit. rewrite rev_involutive. by reflexivity. }
    rewrite Hrev.
    apply rev_list_ind_T.
    * by apply Hemp.
    * intros a' l' Hrevl'.
      simpl. apply Happ. by apply Hrevl'.
Qed.

(* Equality decidability lemmas *)
Lemma value_type_eq_dec : forall t1 t2 : value_type,
  {t1 = t2} + {t1 <> t2}.
Proof. decide equality. Qed.

Lemma value_type_list_eq_dec : forall l1 l2 : list value_type,
  {l1 = l2} + {l1 <> l2}.
Proof. apply List.list_eq_dec. apply value_type_eq_dec. Qed.

Lemma value_typing_deterministic : forall v vt1 vt2,
  value_typing v vt1 -> value_typing v vt2 -> vt1 = vt2.
Proof.
  intros ??? Hvt1 Hvt2.
  inversion Hvt1; inversion Hvt2; subst; try reflexivity; discriminate.
Qed.

(* Typing inversion lemmas *)
Lemma value_typing_inversion : forall v vt,
  value_typing v vt -> vt = typeof v.
Proof. intros v vt Hvtype. inversion Hvtype. reflexivity. Qed.

Lemma value_typing_inversion_i32 : forall v,
  value_typing v t_i32 -> {n & v = val_i32 n}.
Proof.
  intros v Hvtype. apply value_typing_inversion in Hvtype.
  destruct v; inversion Hvtype. exists n. reflexivity.
Defined.

Lemma value_typing_inversion_f32 : forall v,
  value_typing v t_f32 -> {f & v = val_f32 f}.
Proof.
  intros v Hvtype. apply value_typing_inversion in Hvtype.
  destruct v; inversion Hvtype. exists f. reflexivity.
Qed.

Lemma term_const_typing_inv : forall t v t1s t2s,
  t = (term_const v) ->
  typing t (Tf t1s t2s) ->
  {ts & t1s = ts /\ t2s = ts ++ [typeof v]}.
Proof.
  intros t v t1s t2s Hterm Htype. subst t.
  exists t1s; split => //.
  dependent induction Htype.
  - assert (Heqvt : vt0 = typeof v). { by apply value_typing_inversion. }
    rewrite Heqvt. by reflexivity.
  - rewrite <- app_assoc; f_equal.
    by apply IHHtype; reflexivity.
Qed.

Lemma term_addi32_typing_inv_nonempty : forall t1s t2s,
  typing term_addi32 (Tf t1s t2s) -> t2s <> [].
Proof.
  intros t1s' t2s' Htype'.
  dependent induction Htype'.
  - discriminate.
  - intros Hcontr. apply app_eq_nil in Hcontr as [_ Hcontr].
    apply IHHtype' with (t1s' := t1s) in Hcontr; try assumption; reflexivity.
Qed.

(* NOTE: had to do induction over Htype BEFORE splitting,
 * otherwise IH was useless *)
Lemma term_addi32_typing_inv : forall t1s t2s,
  typing term_addi32 (Tf t1s t2s) ->
  {ts & t1s = ts ++ [t_i32; t_i32] /\ t2s = ts ++ [t_i32]}.
Proof.
  intros t1s t2s Htype. exists (removelast t2s).
  dependent induction Htype => //.
  assert (IHHtype' :
    t1s0 = removelast t2s0 ++ [t_i32; t_i32] /\
    t2s0 = removelast t2s0 ++ [t_i32]
  ).
  { apply IHHtype with (t1s := t1s0); by reflexivity. }
  induction ts => //.
  assert (Ht2s0 : t2s0 <> []).
  { by apply (term_addi32_typing_inv_nonempty _ _ Htype). }
  assert (Hassoc : removelast ((a :: ts) ++ t2s0) = removelast ([a] ++ ts ++ t2s0)) => //.
  rewrite Hassoc. rewrite removelast_app. simpl.
  destruct IHts as [IHts1 IHts2].
  split; apply f_equal; by assumption.
  intros Hcontr.
  apply app_eq_nil in Hcontr as [_ Hcontr].
  apply Ht2s0 => //.
Defined.

(* We beed a type checker for the remaining lemmas *)

Definition type_checker_seq (t1 t2: term) (tf1 tf2: function_type): function_type :=
  (* TODO need to actually verify the types after the first n types
   * are correct *)
  match (tf1, tf2) with
  | (Tf t1_in t1_out, Tf t2_in t2_out) =>
      if length t1_out <=? length t2_in
      (* t2 consumes all or more than just the output of t1 *)
      then let ts := firstn (length t2_in - length t1_out) t2_in
      in Tf (ts ++ t1_in) (t2_out)
      (* t2 consumes some of the output of t1 *)
      else let ts := firstn (length t1_out - length t2_in) t1_out
      in Tf t1_in (ts ++ t2_out)
  end
.

Fixpoint type_checker (t: term): function_type :=
  match t with
  | term_const (val_i32 _) => Tf [] [t_i32]
  | term_const (val_f32 _) => Tf [] [t_f32]
  | term_addi32 => Tf [t_i32; t_i32] [t_i32]
  | term_SEQ t1 t2 =>
      type_checker_seq t1 t2 (type_checker t1) (type_checker t2)
  end.

Let i_17 := term_const (val_i32 17).
Let f_3_75 := term_const (val_f32 3.75).

Compute (type_checker i_17).
Compute (type_checker f_3_75).
Compute (type_checker (term_SEQ i_17 f_3_75)).
Compute (type_checker (term_SEQ (term_SEQ i_17 i_17) term_addi32)).
Compute (type_checker (term_SEQ i_17 (term_SEQ i_17 term_addi32))).

Axiom type_checker_implies_typing: forall t tf,
  type_checker t = tf ->
  typing t tf.

(* The weakenable relation needs to describe that the first function type
   can be weakened to the second. *)
Parameter weakenable: function_type -> function_type -> Prop.

Axiom typing_implies_type_checker_prefix: forall t tf,
  typing t tf ->
  weakenable (type_checker t) tf.

Axiom term_SEQ_typing_inv_ax : forall t1 t2 ts' t1s t2s longer_inner_type,
  typing t1 (Tf t1s (ts' ++ longer_inner_type)) /\
  typing t2 (Tf (ts' ++ longer_inner_type) t2s).

Lemma term_SEQ_typing_inv : forall t t1 t2 t1s t2s,
  t = term_SEQ t1 t2 ->
  typing t (Tf t1s t2s) ->
  {t3s & typing t1 (Tf t1s t3s) /\ typing t2 (Tf t3s t2s)}.
Proof.
  intros t t1 t2 t1s t2s Heqt Htype.
  destruct (type_checker t1) as [t1s' t1_t3s].
  destruct (type_checker t2) as [t2_t3s t2s'].

  (* note that t1_t3s is not necessarily equal to t2_t3s
   * (one of them may have an extra prefix) *)
  remember (length t2_t3s <=? length t1_t3s) as t1_t3s_longer.

  (* we can use the outer type (t1s'/t2s')
   * of the term with the longer 'inner' type (t1_t3s or t2_t3s)
   * to find out what prefix (ts') we need to put on our t3s
   * so that t1s/t2s match up with t1s'/t2s' *)

  remember (if t1_t3s_longer then t1s else t2s) as outer_type_expected.
  remember (if t1_t3s_longer then t1s' else t2s') as outer_type_minimal.
  remember (length outer_type_expected - length outer_type_minimal) as ts'_len.
  remember (firstn ts'_len outer_type_expected) as ts'.
  remember (if t1_t3s_longer then t1_t3s else t2_t3s) as longer_inner_type.
  exists (ts' ++ longer_inner_type).

  by apply term_SEQ_typing_inv_ax.
Qed.

  (* TODO
  subst t.
  destruct t1_t3s_longer; subst longer_inner_type.
  - (* t1_t3s longer than t2_t3s *)
    dependent induction Htype => //.
    * (* weakening case *)
      give_up.
      (* eapply IHHtype. *)
      (* the IH here seems useless - it requires
       * t1s = t1s0, t2s = t2s0
       * is it maybe the case that ts = [] always? *)
    * (* composition case *)
      (* need to show ts' = [] *)
      subst outer_type_expected outer_type_minimal.
      (* assert (Ht1s : t1s = t1s'). { give_up. } *)
      assert (Hts' : ts' = []). { give_up. }
      rewrite Hts'. simpl.
      give_up.

  (* NOTE:
   * t1s    = t1s'   (modulo some prefix)
   * t2s    = t2s'   (modulo some prefix)
   * t1_t3s = t2_t3s (modulo some prefix) *)

  (* so we need to consider the two cases where
   * either t1_t3s is longer or t2_t3s is longer:
   *
   * - ts + t1_t3s = t2_t3s (t1_t3s shorter than t2_t3s)
   *
   *   so we can make the 'middle' types line up
   *   by weakening the left function type:
   *   (Tf (ts + t1s') (ts + t1_t3s)) . (Tf t2_t3s t2s')
   *
   *   so the minimal type for the composition is
   *   Tf (ts + t1s') t2s'
   *
   *   however, we may be dealing with a weakened version of that:
   *   Tf (ts' + ts + t1s') (ts' + t2s')
   *   and so the t3s we need is (ts' + t2_t3s)
   *
   * - t1_t3s = ts + t2_t3s (t1_t3s longer than t2_t3s)
   *
   *   so we can make the 'middle' types line up
   *   by weakening the right function type:
   *   (Tf t1s' t1_t3s) . (Tf (ts + t2_t3s) (ts + t2s'))
   *
   *   so the minimal type for the composition is
   *   Tf t1s' (ts + t2s')
   *
   *   however, we may be dealing with a weakened version of that:
   *   Tf (ts' + t1s') (ts' + ts + t2s')
   *   and so the t3s we need is (ts' + t1_t3s)
   *
   *
   *   so we have:
   *   exists ts ts',
   *     t1s = ts' + ts + t1s' /\ t2s = ts' + t2s' \/
   *     t1s = ts' + t1s' /\ t2s = ts' + ts + t2s'
   *   (and we can tell in which \/ branch we are based on lengths of
   *   t1_t3s/t2_t3s)
   *
   *)

  (* XXX need type checker correctness proof here *)
  (* XXX need to use the fact that the type checker's result is the
   * smallest/'strongest' possible type (?) *)
  (* XXX what is needed to show that t3s' = t3s'' (modulo a prefix on either)
   * may be able to use the internals of the type checker somehow? *)
  (* actually probably can just invert Htype for that,
   * it can be inverted once the goal is a Prop
   * (i.e. once we provide a value for t3s)
   *)
Admitted.
*)

(* The value stack *)
Definition stack := list value.

Inductive stack_typing : stack -> list value_type -> Prop :=
  | stack_typing_nil : stack_typing [] []
  | stack_typing_cons : forall s st t vt,
      stack_typing s st ->
      value_typing t vt ->
      stack_typing (t :: s) (vt :: st)
.

Lemma nil_stack_typing_inv : forall s, stack_typing s [] -> s = [].
Proof. intros s Hstype. inversion Hstype. by reflexivity. Qed.

Lemma cons_stack_typing_inv : forall s st t vt,
  stack_typing (t :: s) (vt :: st) ->
  stack_typing s st /\ value_typing t vt.
Proof. intros s st t tt Hstype. inversion Hstype; auto. Qed.

Lemma rcons_stack_typing_inv : forall s st t vt,
  stack_typing (s ++ [t]) (st ++ [vt]) <->
  stack_typing s st /\ value_typing t vt.
Proof.
  intros s st t tt.
  induction s.
  (* TODO this is admitted but is not used in extracted code *)
Admitted.

Lemma stack_typing_length : forall s st,
  stack_typing s st -> length s = length st.
Proof.
  intros s st Hstype.
  induction Hstype => //.
  simpl. rewrite IHHstype. reflexivity.
Qed.

Lemma rcons_stack_typing_inv' : forall s st vt,
  stack_typing s (st ++ [vt]) ->
  {s' & {t & s = s' ++ [t] /\ stack_typing s' st /\ value_typing t vt}}.
Proof.
  intros s st vt Hstype.
  (* XXX did Hlens / Hlenst end up necessary? *)
  assert (Hlens : length s = length (st ++ [vt])).
  { apply (stack_typing_length _ _ Hstype). }
  assert (Hlenst : length (st ++ [vt]) = length st + 1).
  { rewrite app_length. reflexivity. }
  rewrite Hlenst in Hlens.
  induction s as [|t s'] using rev_ind_T.
  - exfalso. rewrite plus_comm in Hlens. by discriminate Hlens.
  - exists s', t. apply rcons_stack_typing_inv in Hstype as [Hstype Hvtype].
    repeat split; by assumption.
Qed.

(* Note: the stack given to the interpreter
 * must contain the right type values *)
Fixpoint interpret_one_step
  t tf_in tf_out s
  (Htype : typing t (Tf tf_in tf_out)) (Hstype : stack_typing s tf_in)
  : {t' : term & {s' : stack & stack_typing s' tf_out}}.
Proof.
  destruct t as [| |t1 t2] eqn:Heqt.

  - (* term_const *)
    (* TODO need to consume evaluated instrs - noop instr? *)
    exists t, (s ++ [v]).
    rewrite <- Heqt in Htype.
    destruct (term_const_typing_inv t v tf_in tf_out Heqt Htype) as [tf_in' [? Htf_out]].
    subst tf_in'. rewrite Htf_out.
    apply rcons_stack_typing_inv. split.
    * by assumption.
    * by apply vt.

  - (* term_addi32 *)
    (* use Hstype to discover that the stack has at least two values on it *)
    apply (term_addi32_typing_inv) in Htype as [ts [Hts1 Hts2]].
    subst tf_in.
    assert (Hlist : ts ++ [t_i32; t_i32] = (ts ++ [t_i32]) ++ [t_i32]).
    { rewrite <- app_assoc. by reflexivity. }
    rewrite Hlist in Hstype.
    apply (rcons_stack_typing_inv' s (ts ++ [t_i32])) in Hstype.
    destruct Hstype as [s' [v1 [Hseq [Hstype Hvtype1]]]].
    apply rcons_stack_typing_inv' in Hstype.
    destruct Hstype as [s'' [v2 [Hseq1 [Hstype Hvtype2]]]].
    subst s'.

    (* now deduce t1 and t2 are both (term_const (val_i32 _)) *)
    apply value_typing_inversion_i32 in Hvtype1 as [n1].
    apply value_typing_inversion_i32 in Hvtype2 as [n2].
    exists t, (s'' ++ [val_i32 (n1 + n2)]). subst.

    apply rcons_stack_typing_inv. split.
    * by assumption.
    * by apply vt.

  - (* term_SEQ *)
    apply (term_SEQ_typing_inv (term_SEQ t1 t2) _ _ _ _ eq_refl) in Htype
    as [ts [Htype1 Htype2]].

    destruct (interpret_one_step _ _ _ s Htype1 Hstype) as [t1' [s' Hstype']].
    destruct (interpret_one_step _ _ _ s' Htype2 Hstype') as [t2' [s'' Hstype'']].

    exists (term_SEQ t1' t2'), s''.
    by apply Hstype''.
Defined.

(* Testing the interpreter *)

(* TODO replace term_SEQ with lists -- closer to wasmcert and easier to use *)
Definition term_add_2_6 : term :=
  term_SEQ
    (term_SEQ (term_const (val_i32 2)) (term_const (val_i32 6)))
    term_addi32.
Definition stack_emp : stack := [].
Definition t_in : list value_type := [].
Definition t_out : list value_type := [t_i32].

Definition term_add_2_6_typing : typing term_add_2_6 (Tf [] [t_i32]).
Proof.
  apply typing_composition with (t3s := [t_i32; t_i32]).
  - apply typing_composition with (t3s := [t_i32]).
    * apply typing_term_const. by apply vt.
    * apply typing_weaken with (ts := [t_i32]).
      apply typing_term_const. by apply vt.
  - by apply typing_term_addi32.
Qed.

Check (
  interpret_one_step
  term_add_2_6
  t_in
  t_out
  stack_emp
  term_add_2_6_typing
  stack_typing_nil
).

(* Extraction *)

From Coq Require Import Extraction.
Extraction Language Haskell.
Extraction "interpret.hs"
  interpret_one_step
  term_add_2_6
  t_in
  t_out
  stack_emp
.

(* NOTE: we don't even need to extract stack_typing_nil and term_add_2_6_typing *)


(* Tipo de tries binarios *)
Inductive binTrie3: Type :=
| empty3 : binTrie3
| leaf3: N -> nat -> binTrie3
| trie3: N -> binTrie3 -> binTrie3 -> binTrie3.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                                                                                *)
(************************************************************************************)

Set Implicit Arguments.

Require Import List Recdef Sorted Arith SetoidList Bool.

Require Import BasicFacts ListFacts OrderedSet ListPermut.

Lemma Sorted_incl :
  forall (A : Type) (o1 o2 : relation A) (l : list A),
    (forall a1 a2, In a1 l -> In a2 l -> o1 a1 a2 -> o2 a1 a2) ->
    Sorted o1 l -> Sorted o2 l.
Proof.
intros A o1 o2 l; induction l as [ | a l]; intros Hl HS.
- constructor 1.
- inversion HS; clear HS; subst.
  constructor 2.
  + apply IHl; [ | assumption].
    do 4 intro; apply Hl; right; assumption.
  + destruct l as [ | a1 l].
    * constructor 1.
    * constructor 2.
      apply Hl; [left | right; left | inversion H2]; trivial.
Qed.

Lemma sorted_list_eq :
  forall (A : Type) (OA : Oset.Rcd A) l1 l2,
    (forall e : A, Oset.mem_bool OA e l1 = Oset.mem_bool OA e l2) ->
    Sorted (fun x y : A => Oset.compare OA x y = Lt) l1 ->
    Sorted (fun x y : A => Oset.compare OA x y = Lt) l2 ->
    l1 = l2.
Proof.
intros A OA l1; induction l1 as [ | a1 l1]; intros l2 H H1 H2.
- case_eq l2.
  + exact (fun _ => refl_equal _).
  + intros a2 k2 Hl2.
    assert (Ha2 := H a2).
    rewrite Hl2, 2 Oset.mem_bool_unfold, Oset.compare_eq_refl in Ha2.
    discriminate Ha2.
- case_eq l2.
  + intro Hl2.
    assert (Ha2 := H a1).
    rewrite Hl2, Oset.mem_bool_unfold, Oset.compare_eq_refl in Ha2.
    discriminate Ha2.
  + assert (Heq : Equivalence (fun x y : A => Oset.compare OA x y = Eq)).
    {
      split.
      - intro b1; apply Oset.compare_eq_refl.
      - intros b1 b2 Hb; rewrite Oset.compare_lt_gt, Hb; apply refl_equal.
      - intros b1 b2 b3; apply Oset.compare_eq_trans.
    }
    assert (Hlt : StrictOrder (fun x y : A => Oset.compare OA x y = Lt)).
    {
      split.
      - intros b1.
        unfold complement.
        rewrite Oset.compare_eq_refl; discriminate.
      - intros b1 b2 b3; apply Oset.compare_lt_trans.
    }
    assert (Heqlt :
              Proper
                ((fun x y : A => Oset.compare OA x y = Eq) ==>
                   (fun x y : A => Oset.compare OA x y = Eq) ==> iff)
                (fun x y : A => Oset.compare OA x y = Lt)).
    {
      intros b1 b2 Hb c1 c2 Hc; split; intro Hbc.
      - rewrite Oset.compare_lt_gt, CompOpp_iff in Hb.
        apply Oset.compare_eq_lt_trans with b1; [assumption | ].
        apply Oset.compare_lt_eq_trans with c1; assumption.
      - apply Oset.compare_eq_lt_trans with b2; [assumption | ].
        apply Oset.compare_lt_eq_trans with c2; [assumption | ].
        rewrite Oset.compare_lt_gt, Hc; apply refl_equal.
    }
    intros a2 k2 Hl2; subst l2.
    assert (Aux1 :
              let ltA := (fun x y : A => Oset.compare OA x y = Lt) in
              forall (l : list A) (x : A), Sorted ltA l ->
              (HdRel ltA x l <->
               (forall y, InA  (fun x y => Oset.compare OA x y = Eq) y l -> ltA x y))).
    {
      apply InfA_alt; assumption.
    }
    assert (Aux2 := SortA_InfA_InA Heq Hlt Heqlt).
    assert (K : a1 = a2 /\ (forall e : A, Oset.mem_bool OA e l1 = Oset.mem_bool OA e k2)).
    {
      inversion H1; clear H1.
      subst a l.
      inversion H2; clear H2.
      subst a l.
      assert (Ha1 := H a1).
      rewrite Oset.mem_bool_unfold, Oset.compare_eq_refl, Bool.orb_true_l in Ha1.
      generalize (sym_eq Ha1); clear Ha1; intro Ha1.
      rewrite Oset.mem_bool_unfold, Bool.orb_true_iff in Ha1.
      destruct Ha1 as [Ha1 | Ha1].
      - rewrite compare_eq_true in Ha1.
        generalize (Oset.eq_bool_ok OA a1 a2); rewrite Ha1; clear Ha1; intro; subst a2.
        split; [apply refl_equal | ].
        intros e.
        generalize (H e).
        rewrite Oset.mem_bool_unfold.
        case_eq (Oset.compare OA e a1).
        + intros He _.
          generalize (Oset.eq_bool_ok OA e a1); rewrite He; clear He; intro; subst a1.
          apply eq_trans with false; [ | apply sym_eq].
          * case_eq (Oset.mem_bool OA e l1); intro Ke; [ | apply refl_equal].
            rewrite (Aux1 l1 e H4) in H5.
            assert (Abs : Oset.compare OA e e = Lt).
            {
              apply (H5 e).
              rewrite InA_alt.
              exists e; split.
              - apply Oset.compare_eq_refl.
              - rewrite Oset.mem_bool_true_iff in Ke; apply Ke.
            }
            rewrite Oset.compare_eq_refl in Abs; discriminate Abs.
          * case_eq (Oset.mem_bool OA e k2); intro Ke; [ | apply refl_equal].
            rewrite (Aux1 k2 e H3) in H6.
            assert (Abs : Oset.compare OA e e = Lt).
            {
              apply (H6 e).
              rewrite InA_alt.
              exists e; split.
              - apply Oset.compare_eq_refl.
              - rewrite Oset.mem_bool_true_iff in Ke; apply Ke.
            }
            rewrite Oset.compare_eq_refl in Abs; discriminate Abs.
        + intros He Ke; simpl in Ke.
          rewrite Ke; unfold Oset.eq_bool.
          rewrite He; apply refl_equal.
        + intros He Ke; simpl in Ke.
          rewrite Ke; unfold Oset.eq_bool.
          rewrite He; apply refl_equal.
      - assert (Abs1 : Oset.compare OA a2 a1 = Lt).
        {
          apply (Aux2 k2 a1 a2 H3 H6).
          rewrite InA_alt.
          exists a1; split.
          - apply Oset.compare_eq_refl.
          - rewrite Oset.mem_bool_true_iff in Ha1; apply Ha1.
        }
        assert (Abs2 : Oset.compare OA a1 a2 = Lt).
        {
          rewrite (Aux1 _ _ H4) in H5; apply H5.
          rewrite InA_alt.
          exists a2; split.
          - rewrite Oset.compare_eq_refl; apply refl_equal.
          - rewrite <- (Oset.mem_bool_true_iff OA).
            generalize (H a2).
            rewrite Oset.mem_bool_unfold, Abs1, Bool.orb_false_l.
            rewrite (Oset.mem_bool_unfold OA a2 (_ :: _)), Oset.compare_eq_refl.
            exact (fun h => h).
        }
        rewrite Oset.compare_lt_gt, Abs2 in Abs1.
        discriminate Abs1.
    }
    apply f_equal2; [apply (proj1 K) | ].
    apply IHl1.
    * apply (proj2 K).
    * inversion H1; subst; assumption.
    * inversion H2; subst; assumption.
Qed.

Lemma all_elements_equal :
  forall (A : Type) (OA : Oset.Rcd A) a l,
    (forall x : A, In x l -> x = a) ->
    Sorted (fun x y : A => Oset.compare OA x y = Lt) l ->
    (l = nil \/ l = a :: nil).
Proof.
intros A OA a l1 H1 H2.
destruct l1 as [ | a1 l1]; [left; apply refl_equal | ].
right.
assert (Ha1 := H1 a1 (or_introl _ (refl_equal _))); subst a1.
apply f_equal.
destruct l1 as [ | a1 l1]; [apply refl_equal | ].
assert (Ha1 := H1 a1 (or_intror _ (or_introl _ (refl_equal _)))); subst a1.
inversion H2; clear H2; subst.
inversion H4; clear H4; subst.
rewrite Oset.compare_eq_refl in H0; discriminate H0.
Qed.

Section Sec.

Hypothesis A : Type.
Hypothesis OA : Oeset.Rcd A.

Lemma cardinal_subset_list :
  forall l1 l2,
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) l1 ->
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) l2 ->
    (forall e : A, Oeset.mem_bool OA e l1 = true -> Oeset.mem_bool OA e l2 = true) ->
    length l1 <= length l2.
Proof.
intros l1.
induction l1 as [ | a1 l1]; intros [ | a2 l2] Hs1 Hs2 H.
- apply le_n.
- apply le_O_n.
- assert (Ha1 := H a1).
  rewrite Oeset.mem_bool_unfold, Oeset.compare_eq_refl, Bool.orb_true_l in Ha1.
  generalize (Ha1 (refl_equal _)); clear Ha1; intro Ha1.
  discriminate Ha1.
- assert (Ha1 := H a1).
  rewrite Oeset.mem_bool_unfold, Oeset.compare_eq_refl, Bool.orb_true_l in Ha1.
  generalize (Ha1 (refl_equal _)); clear Ha1; intro Ha1.
  rewrite Oeset.mem_bool_unfold, Bool.orb_true_iff in Ha1.
  destruct Ha1 as [Ha1 | Ha1].
  + rewrite compare_eq_true in Ha1.
    simpl; apply le_n_S.
    apply IHl1.
    * inversion Hs1; subst; assumption.
    * inversion Hs2; subst; assumption.
    * intros e He.
      generalize (H e).
      rewrite Oeset.mem_bool_unfold, He, Bool.orb_true_r.
      intro Ke; generalize (Ke (refl_equal _)); clear Ke; intro Ke.
      rewrite Oeset.mem_bool_unfold, Bool.orb_true_iff in Ke.
      destruct Ke as [Ke | Ke]; [ | assumption].
      rewrite compare_eq_true in Ke.
      assert (Abs : Oeset.mem_bool OA a1 l1 = true).
      {
        rewrite (Oeset.mem_bool_eq_1 OA a1 a2).
        - rewrite (Oeset.mem_bool_eq_1 OA a2 e).
          + assumption.
          + rewrite Oeset.compare_lt_gt, Ke; apply refl_equal.
        - assumption.
      }
      apply False_rec; clear a2 l2 e He Ke Ha1 H Hs2 IHl1.
      induction l1 as [ | a l1]; [discriminate Abs | ].
      inversion Hs1; clear Hs1; subst.
      {
        rewrite Oeset.mem_bool_unfold, Bool.orb_true_iff in Abs;
        destruct Abs as [Abs | Abs].
        - rewrite compare_eq_true in Abs.
          inversion H2; clear H2; subst.
          rewrite Abs in H0; discriminate H0.
        - apply IHl1; [ | assumption].
          inversion H1; clear H1; subst.
          constructor 2; [assumption | ].
          destruct l1 as [ | b l1].
          + constructor 1.
          + constructor 2.
            apply Oeset.compare_lt_trans with a.
            * inversion H2; intros; subst; assumption.
            * inversion H4; intros; subst; assumption.
      }
  + simpl; apply le_n_S.
    apply IHl1.
    * inversion Hs1; intros; subst; assumption.
    * inversion Hs2; intros; subst; assumption.
    * intros e He.
      assert (Ke := H e); rewrite Oeset.mem_bool_unfold, He, Bool.orb_true_r in Ke.
      generalize (Ke (refl_equal _)); clear Ke; intro Ke.
      rewrite Oeset.mem_bool_unfold, Bool.orb_true_iff in Ke.
      destruct Ke as [Ke | Ke]; [ | assumption].
      rewrite compare_eq_true in Ke.
      assert (K : let ltA := (fun x y : A => Oeset.compare OA x y = Lt) in
                  forall (l : list A) (x a : A),
                    Sorted ltA l ->
                    HdRel ltA a l ->
                    InA (fun a1 a2 : A => Oeset.compare OA a1 a2 = Eq) x l ->
                    ltA a x).
      {
        intro; subst ltA; apply SortA_InfA_InA.
        - split.
          + intro b1; apply Oeset.compare_eq_refl.
          + intros b1 b2 Hb; rewrite Oeset.compare_lt_gt, Hb.
            apply refl_equal.
          + intros b1 b2 b3; apply Oeset.compare_eq_trans.
        - split.
          + intro b1.
            unfold complement.
            rewrite Oeset.compare_eq_refl; discriminate.
          + intros b1 b2 b3; apply Oeset.compare_lt_trans.
        - intros b1 b2 Hb c1 c2 Hc.
          split; intro Hbc.
          + rewrite Oeset.compare_lt_gt, CompOpp_iff in Hb.
            apply Oeset.compare_eq_lt_trans with b1; [assumption | ].
            apply Oeset.compare_lt_eq_trans with c1; assumption.
          + apply Oeset.compare_eq_lt_trans with b2; [assumption | ].
            apply Oeset.compare_lt_eq_trans with c2; [assumption | ].
            rewrite Oeset.compare_lt_gt, Hc; apply refl_equal.
      }
      inversion Hs1; clear Hs1.
      subst a l.
      inversion Hs2; clear Hs2.
      subst a l.
      assert (Kl1 : Oeset.compare OA a2 a1 = Lt).
      {
        apply (K l2 a1 a2 H4 H5).
        rewrite InA_alt.
        rewrite Oeset.mem_bool_true_iff in Ha1.
        apply Ha1.
      }
      assert (Kl2 : Oeset.compare OA a1 a2 = Lt).
      {
        apply (K l1 a2 a1 H2 H3).
        rewrite InA_alt.
        rewrite Oeset.mem_bool_true_iff in He.
        destruct He as [e' [He He']].
        exists e'; split; [ | assumption].
        apply Oeset.compare_eq_trans with e; [ | assumption].
        rewrite Oeset.compare_lt_gt, Ke; apply refl_equal.
      }
      rewrite Oeset.compare_lt_gt, Kl1 in Kl2.
      discriminate Kl2.
Qed.

Fixpoint fold_inter_ (acc : list A) (l1 l2 : list A) :=
  match l2 with
    | nil => acc
    | a2 :: l2 =>
      if Oeset.mem_bool OA a2 l1
      then fold_inter_ (acc ++ a2 :: nil) l1 l2
      else fold_inter_ acc l1 l2
  end.

Lemma fold_inter_is_sorted_ :
  forall acc l1 l2,
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) l1 ->
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) (acc ++ l2) ->
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) (fold_inter_ acc l1 l2).
Proof.
intros acc l1 l2; revert acc l1;
induction l2 as [ | a2 l2]; intros acc l1; simpl.
- intros _; rewrite <- app_nil_end; exact (fun h => h).
- intros Sl1 H; case (Oeset.mem_bool OA a2 l1); apply IHl2.
  + assumption.
  + rewrite <- ass_app; apply H.
  + assumption.
  + revert H; clear; revert a2 l2; induction acc as [ | a1 acc]; intros a2 l2 H.
    * simpl in H; simpl; inversion H; assumption.
    * {
        simpl; constructor.
        - simpl in H.
          apply IHacc with a2.
          inversion H; assumption.
        - simpl in H; inversion H; subst.
          destruct acc as [ | a acc]; simpl in H, H2, H3; simpl.
          + destruct l2 as [ | a3 l2]; simpl in H, H2, H3; simpl.
            * constructor 1.
            * constructor 2.
              {
                apply Oeset.compare_lt_trans with a2.
                - inversion H3; assumption.
                - inversion H2; inversion H5; assumption.
              }
          + constructor 2; inversion H3; assumption.
      }
Qed.

Lemma length_fold_inter_ :
   forall acc l1 l2, length (fold_inter_ acc l1 l2) = (length acc + length (fold_inter_ nil l1 l2))%nat.
Proof.
fix h 3.
intros acc l1 l2; case l2; clear l2; simpl.
rewrite <- plus_n_O; reflexivity.
intros a2 l2; case (Oeset.mem_bool OA a2 l1).
rewrite (h (acc ++ a2 :: nil) l1 l2).
rewrite (h (a2 :: nil) l1 l2); simpl.
rewrite app_length; simpl.
rewrite <- plus_assoc; simpl; apply refl_equal.
apply h.
Qed.

Lemma fold_inter_is_inter_list :
  forall e l1 l2 acc,
    (Oeset.mem_bool OA e l1 && Oeset.mem_bool OA e l2) || Oeset.mem_bool OA e acc =
    Oeset.mem_bool OA e (fold_inter_ acc l1 l2).
Proof.
intros e l1 l2; revert e l1.
induction l2 as [ | a2 l2]; intros e l1 acc; simpl.
- rewrite Bool.andb_false_r; apply refl_equal.
- case_eq (Oeset.mem_bool OA a2 l1); intro Ha2.
  + rewrite <- IHl2, Oeset.mem_bool_app; simpl.
    rewrite Bool.orb_false_r.
    case_eq (Oeset.mem_bool OA e l1); intro He.
    * {
        unfold Oeset.eq_bool; case_eq (Oeset.compare OA e a2); intro Ke.
        - rewrite 2 Bool.orb_true_r; apply refl_equal.
        - rewrite Bool.orb_false_r; apply refl_equal.
        - rewrite Bool.orb_false_r; apply refl_equal.
      }
    * {
        unfold Oeset.eq_bool; case_eq (Oeset.compare OA e a2); intro Ke.
        - rewrite (Oeset.mem_bool_eq_1 _ _ _ _ Ke) in He.
          rewrite He in Ha2; discriminate Ha2.
        - simpl; rewrite Bool.orb_false_r; apply refl_equal.
        - simpl; rewrite Bool.orb_false_r; apply refl_equal.
      }
  + rewrite <- IHl2.
    unfold Oeset.eq_bool; case_eq (Oeset.compare OA e a2); intro Ke.
    * rewrite <- (Oeset.mem_bool_eq_1 _ _ _ _ Ke) in Ha2.
      rewrite Ha2; apply refl_equal.
    * simpl; apply refl_equal.
    * simpl; apply refl_equal.
Qed.

Fixpoint insert_ a (l : list A) :=
  match l with
    | nil => a :: nil
    | a1 :: l1 =>
      match Oeset.compare OA a a1 with
          | Lt | Eq => a :: l
          | Gt => a1 :: (insert_ a l1)
      end
  end.

Lemma mem_insert_ :
  forall x a l, Oeset.mem_bool OA x (insert_ a l) =
                (match Oeset.compare OA x a with Eq => true | _ => false end)
                  || Oeset.mem_bool OA x l.
Proof.
intros x a l; induction l as [ | a1 l]; simpl.
- apply refl_equal.
- case_eq (Oeset.compare OA a a1); intro Ha; simpl.
  + apply refl_equal.
  + apply refl_equal.
  + rewrite IHl.
    unfold Oeset.eq_bool; case_eq (Oeset.compare OA x a1); intro Hx; simpl.
    * rewrite Bool.orb_true_r; apply refl_equal.
    * apply refl_equal.
    * apply refl_equal.
Qed.

Lemma length_insert_ :
  forall a l, length (insert_ a l) = S (length l).
Proof.
intros a l; induction l as [ | a1 l]; simpl.
- apply refl_equal.
- case (Oeset.compare OA a a1); simpl.
  + apply refl_equal.
  + apply refl_equal.
  + rewrite IHl; apply refl_equal.
Qed.

Fixpoint fold_union_ (l1 l2 : list A) :=
  match l2 with
    | nil => l1
    | a2 :: l2 =>
      if Oeset.mem_bool OA a2 l1
      then fold_union_ l1 l2
      else fold_union_ (insert_ a2 l1) l2
  end.

Lemma fold_union_is_sorted_ :
  forall l1 l2,
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) l1 ->
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) l2 ->
    Sorted (fun x y : A => Oeset.compare OA x y = Lt) (fold_union_ l1 l2).
Proof.
intros l1 l2; revert l1; induction l2 as [ | a2 l2]; intros l1 Sl1 Sl2; simpl.
- assumption.
- case_eq (Oeset.mem_bool OA a2 l1); intro Ha2.
  + apply (IHl2 _ Sl1).
    inversion Sl2; assumption.
  + apply IHl2.
    clear l2 IHl2 Sl2.
    induction l1 as [ | a1 l1]; simpl.
    * constructor 2; constructor 1.
    * simpl in Ha2; rewrite Bool.orb_false_iff in Ha2; destruct Ha2 as [Ha2 Ka2].
      {
        revert Ha2; unfold Oeset.eq_bool; case_eq (Oeset.compare OA a2 a1).
        - intros _ Abs; discriminate Abs.
        - intros Ha2 _; constructor 2.
          + assumption.
          + constructor 2; assumption.
        - intros Ha2 _; constructor 2.
          + apply IHl1.
            * inversion Sl1; assumption.
            * assumption.
          + destruct l1 as [ | a l1]; simpl.
            * constructor 2; rewrite Oeset.compare_lt_gt, Ha2; apply refl_equal.
            * {
                case_eq (Oeset.compare OA a2 a); intro Ha.
                - constructor 2; rewrite Oeset.compare_lt_gt, Ha2; apply refl_equal.
                - constructor 2; rewrite Oeset.compare_lt_gt, Ha2; apply refl_equal.
                - constructor 2.
                  inversion Sl1; subst.
                  inversion H2; assumption.
              }
      }
    * inversion Sl2; assumption.
Qed.

Lemma fold_union_is_union_list :
 forall e l1 l2,
   Oeset.mem_bool OA e l1 || Oeset.mem_bool OA e l2 = Oeset.mem_bool OA e (fold_union_ l1 l2).
Proof.
intros e l1 l2; revert e l1.
induction l2 as [ | a2 l2]; intros e l1; simpl.
- rewrite Bool.orb_false_r; apply refl_equal.
- case_eq (Oeset.mem_bool OA a2 l1); intro Ha2; rewrite <- IHl2.
  + case_eq (Oeset.mem_bool OA e l1); simpl.
    * exact (fun _ => refl_equal _).
    * {
        unfold Oeset.eq_bool; intro He; case_eq (Oeset.compare OA e a2); intro Ke.
        - rewrite (Oeset.mem_bool_eq_1 _ _ _ _ Ke) in He.
          rewrite He in Ha2; discriminate Ha2.
        - apply refl_equal.
        - apply refl_equal.
      }
  + rewrite mem_insert_.
    case (Oeset.mem_bool OA e l1); simpl.
    * rewrite Bool.orb_true_r; apply refl_equal.
    * unfold Oeset.eq_bool; case (Oeset.compare OA e a2); apply refl_equal.
Qed.

(** *** Definition of a sorted list. *)
Inductive is_sorted : list A -> Prop :=
  | is_sorted_nil : is_sorted nil
  | is_sorted_cons1 : forall t, is_sorted (t :: nil)
  | is_sorted_cons2 :
      forall t1 t2 l, Oeset.compare OA t1 t2 <> Gt -> is_sorted (t2 :: l) -> is_sorted (t1 :: t2 :: l).

Lemma is_sorted_Sorted :
  forall l, is_sorted l <-> Sorted (fun x y => Oeset.compare OA x y <> Gt) l.
Proof.
intro l; induction l as [ | a1 l].
- split; intro; constructor 1.
- split; intro H; inversion H; clear H; subst.
  + constructor 2; constructor 1.
  + constructor 2.
    * rewrite <- IHl; assumption.
    * constructor 2; assumption.
  + case_eq l.
    * intro; constructor 2.
    * intros a2 k H; subst l.
      inversion H3; clear H3; subst.
      constructor 3; [assumption | ].
      rewrite IHl; assumption.
Qed.

(** *** Decomposition of the list wrt a pivot. *)
Function partition (pivot : A) (l : list A) {struct l} : (list A) * (list A) :=
  match l with
  | nil => (nil, nil)
  | a :: l' =>
	match partition pivot l' with (l1,l2) =>
	 match Oeset.compare OA a pivot with
         | Lt => (a :: l1, l2)
         | _ => (l1, a :: l2)
         end
        end
end.

Function quicksort (l : list A) { measure (@length A) l} : list A :=
   match l with
	| nil => nil
	| h :: tl =>
             match partition h tl with (l1, l2) =>
             quicksort l1 ++ h :: quicksort l2
        end
    end.
Proof.
- (* 1 Second recursive call *)
  intros _l a l H; subst _l.
  induction l as [ | a1 l]; intros l1 l2 H; simpl in H.
  + injection H; clear H; intros; subst.
    apply le_n.
  + case_eq (partition a l); intros k1 k2 K; rewrite K in H.
    case_eq (Oeset.compare OA a1 a);
      intro Ha; rewrite Ha in H; injection H; clear H; intros; subst.
    * simpl; apply le_n_S; apply (IHl _ _ K).
    * simpl; apply le_S; apply (IHl _ _ K).
    * simpl; apply le_n_S; apply (IHl _ _ K).
- intros _l a l H; subst _l.
  induction l as [ | a1 l]; intros l1 l2 H; simpl in H.
  + injection H; clear H; intros; subst.
    apply le_n.
  + case_eq (partition a l); intros k1 k2 K; rewrite K in H.
    case_eq (Oeset.compare OA a1 a);
      intro Ha; rewrite Ha in H; injection H; clear H; intros; subst.
    * simpl; apply le_S; apply (IHl _ _ K).
    * simpl; apply le_n_S; apply (IHl _ _ K).
    * simpl; apply le_S; apply (IHl _ _ K).
Defined.

(** *** The result of quicksort is a permutation of the original list. *)

Notation permut := (_permut (fun x y => Oeset.compare OA x y = Eq)).

Lemma partition_list_permut1 :
 forall e l, let (l1,l2) := partition e l in permut (l1 ++ l2) l.
Proof.
intros e l; functional induction (partition e l)
   as [ | H1 e' l' H2 IH l1 l2 rec_res e'_lt_e _ | H1 e' l' H2 IH l1 l2 rec_res H3].
- apply Pnil.
- simpl app; rewrite rec_res in IH; apply (@Pcons _ _ _ e' e' (l1 ++ l2) nil l').
  + apply Oeset.compare_eq_refl.
  + assumption.
- simpl app; rewrite rec_res in IH.
  apply _permut_sym.
  + intros a b _ _ H; rewrite Oeset.compare_lt_gt; rewrite H; apply refl_equal.
  + apply (@Pcons _ _ _ e' e' l' l1 l2).
    * apply Oeset.compare_eq_refl.
    * apply _permut_sym; [ | assumption].
      intros a b _ _ H; rewrite Oeset.compare_lt_gt; rewrite H; apply refl_equal.
Qed.

Theorem quick_permut : forall l, permut l (quicksort l).
Proof.
intros l; functional induction (quicksort l)
   as [ | l a' l' l_eq_a'_l' l1 l2 H S1 S2]; auto.
- apply Pnil.
- apply Pcons.
  + apply Oeset.compare_eq_refl.
  + assert (P := partition_list_permut1 a' l'); rewrite H in P.
    apply _permut_trans with (l1 ++ l2).
    * do 6 intro; apply Oeset.compare_eq_trans.
    * apply _permut_sym; [ | assumption].
      intros a b _ _ K; rewrite Oeset.compare_lt_gt; rewrite K; apply refl_equal.
    * apply _permut_app; assumption.
Qed.

Theorem quick_permut_bis :
 forall l1 l2, permut l1 l2 -> permut (quicksort l1) l2.
Proof.
intros l1 l2 P; apply _permut_trans with l1.
- do 6 intro; apply Oeset.compare_eq_trans.
- apply _permut_sym.
  + intros a b _ _ H; rewrite Oeset.compare_lt_gt; rewrite H; apply refl_equal.
  + apply quick_permut.
- assumption.
Qed.

(** *** The result of quicksort is a sorted list. *)
Lemma sorted_tl_sorted :
  forall e l, is_sorted (e :: l) -> is_sorted l.
Proof.
intros e l S; inversion S; subst.
apply is_sorted_nil.
assumption.
Qed.

Lemma quick_sorted_aux1 :
  forall l1 l2 e, is_sorted l1 -> is_sorted l2 ->
  (forall a, In a l1 -> Oeset.compare OA a e <> Gt) ->
  (forall a, In a l2 -> Oeset.compare OA e a <> Gt) ->
  is_sorted (l1 ++ e :: l2).
Proof.
induction l1 as [ | e1 l1 ]; intros l2 e S1 S2 L1 L2.
simpl; destruct l2 as [ | e2 l2]; intros;
[apply is_sorted_cons1 | apply is_sorted_cons2 ]; trivial;
apply (L2 e2); simpl; left; apply refl_equal.
destruct l1 as [ | e1' l1] ; simpl; intros; apply is_sorted_cons2.
apply L1; left; apply refl_equal.
simpl in IHl1; apply IHl1; trivial.
apply is_sorted_nil.
contradiction.
inversion S1; trivial.
rewrite app_comm_cons; apply IHl1; trivial.
inversion S1; trivial.
intros; apply L1; trivial; right; trivial.
Qed.

Lemma quick_sorted_aux3 :
  forall l e, let (l1,_) := partition e l in forall a, In a l1 -> Oeset.compare OA a e <> Gt.
Proof.
intros l e;
functional induction (partition e l)
    as [ | l a' l' l_eq_a'_l' IH l1' l2' H a'_lt_e _ | l a' l' l_eq_a'_l' IH l1' l2' H _H _ ].
contradiction.
intros a [a_eq_a' | a_in_l1']; [idtac | rewrite H in IH; apply IH; trivial].
subst a'; rewrite a'_lt_e; discriminate.
intros; rewrite H in IH; apply IH; trivial.
Qed.

Lemma quick_sorted_aux4 :
  forall l e, let (_,l2) := partition e l in forall a, In a l2 -> Oeset.compare OA e a <> Gt.
Proof.
fix h 1.
intro l; case l; clear l.
intros e a H; contradiction H.
intros a1 l e; simpl.
case_eq (partition e l); intros l1 l2 Hl.
case_eq (Oeset.compare OA a1 e); intro He.
simpl; intros a [Ha | Ha]; [subst a1; rewrite Oeset.compare_lt_gt, He; discriminate | ].
assert (IH := h l e); rewrite Hl in IH; apply (IH a Ha).
assert (IH := h l e); rewrite Hl in IH; apply IH.
simpl; intros a [Ha | Ha]; [subst a1; rewrite Oeset.compare_lt_gt, He; discriminate | ].
assert (IH := h l e); rewrite Hl in IH; apply (IH a Ha).
Qed.

Theorem quick_sorted : forall l, is_sorted (quicksort l).
Proof.
intros l;
functional induction (quicksort l)
   as [ | l a' l' l_eq_a'_l' l1 l2 H S1 S2].
- apply is_sorted_nil.
- apply quick_sorted_aux1; trivial.
  + intros a a_in_ql1.
    assert (H1 := quick_sorted_aux3 l' a'); rewrite H in H1.
    assert (K : Oeset.mem_bool OA a l1 = true).
    {
      rewrite (mem_permut_mem OA a (quick_permut l1)).
      rewrite Oeset.mem_bool_true_iff.
      exists a; split; [apply Oeset.compare_eq_refl | assumption].
    }
    rewrite Oeset.mem_bool_true_iff in K.
    destruct K as [_a [K1 K2]].
    assert (Ha := H1 _ K2).
    intro Ka; apply Ha.
    rewrite Oeset.compare_lt_gt, CompOpp_iff in Ka.
    rewrite Oeset.compare_lt_gt, (Oeset.compare_lt_eq_trans _ _ _ _ Ka K1).
    apply refl_equal.
  + intros a a_in_ql2.
    assert (H1 := quick_sorted_aux4 l' a'); rewrite H in H1.
    assert (K : Oeset.mem_bool OA a l2 = true).
    {
      rewrite (mem_permut_mem OA a (quick_permut l2)).
      rewrite Oeset.mem_bool_true_iff.
      exists a; split; [apply Oeset.compare_eq_refl | assumption].
    }
    rewrite Oeset.mem_bool_true_iff in K.
    destruct K as [_a [K1 K2]].
    assert (Ha := H1 _ K2).
    intro Ka; apply Ha.
    rewrite Oeset.compare_lt_gt, CompOpp_iff in K1, Ka.
    rewrite Oeset.compare_lt_gt, (Oeset.compare_eq_lt_trans _ _ _ _ K1 Ka).
    apply refl_equal.
Qed.

(** ***  There is a unique sorted list equivalent up to a permutation to a given list.*)
Lemma sorted_cons_min :
 forall l e, is_sorted (e :: l) -> (forall e', In e' (e :: l) -> Oeset.compare OA e e' <> Gt).
Proof.
simpl; intros l e S e' [e'_eq_e | e'_in_l].
- subst e'; rewrite Oeset.compare_eq_refl; discriminate.
- revert e S e' e'_in_l; induction l as [ | a l ].
  + intros e _ e' e'_in_nil; elim e'_in_nil.
  + simpl; intros e S e' [e'_eq_a | e'_in_l].
    * subst; inversion S; assumption.
    * inversion S; subst.
      assert (IH := IHl _ H3 _ e'_in_l).
      {
        case_eq (Oeset.compare OA e a); intro Hea.
        - apply IHl; [ | assumption].
          inversion H3; subst.
          + contradiction e'_in_l.
          + constructor 3; [ | assumption].
            intro H; rewrite Oeset.compare_lt_gt, CompOpp_iff in H.
            apply H2.
            rewrite Oeset.compare_lt_gt.
            rewrite (Oeset.compare_lt_eq_trans _ _ _ _ H Hea).
            apply refl_equal.
        - intro H; rewrite Oeset.compare_lt_gt, CompOpp_iff in H.
          apply IH.
          rewrite Oeset.compare_lt_gt.
          rewrite (Oeset.compare_lt_trans _ _ _ _ H Hea).
          apply refl_equal.
        - intro H.
          apply H1; assumption.
      }
Qed.

Theorem sort_is_unique :
  forall l1 l2,
    is_sorted l1 -> is_sorted l2 -> permut l1 l2 ->
    Oeset.compare (mk_oelists OA) l1 l2 = Eq.
Proof.
intros l1; induction l1 as [ | e1 l1 ]; intros l2 S1 S2 P.
- inversion P; trivial.
- inversion P as [ | a b l k1 k2 a_eq_b P' H1 H'];
  destruct k1 as [ | a1 k1]; subst.
  + simpl; rewrite a_eq_b.
    assert (IH := IHl1 k2); simpl in IH; apply IH.
    * apply sorted_tl_sorted with e1; assumption.
    * apply sorted_tl_sorted with b; assumption.
    * refine (_permut_cons_inside _ _ _ _ _ P); [ | assumption].
      intros a1 b1 a2 b2 _ _ _ _ H1 H2 H3.
      apply Oeset.compare_eq_trans with b1; [assumption | ].
      apply Oeset.compare_eq_trans with a2; [ | assumption].
      rewrite Oeset.compare_lt_gt, H2; apply refl_equal.
  + assert (e1_eq_a1 : Oeset.compare OA e1 a1 = Eq).
    {
      assert (Ha1 : Oeset.mem_bool OA a1 (e1 :: l1) = true).
      {
        rewrite (mem_permut_mem OA _ P).
        simpl; unfold Oeset.eq_bool; rewrite Oeset.compare_eq_refl; apply refl_equal.
      }
      rewrite Oeset.mem_bool_true_iff in Ha1.
      destruct Ha1 as [a1' [Ha1 Ha1']].
      assert (Ka1 := sorted_cons_min S1 Ha1').
      assert (He1 : Oeset.mem_bool OA e1 ((a1 :: k1) ++ b :: k2) = true).
      {
        rewrite <- (mem_permut_mem OA _ P).
        simpl; unfold Oeset.eq_bool; rewrite Oeset.compare_eq_refl; apply refl_equal.
      }
      rewrite Oeset.mem_bool_true_iff in He1.
      destruct He1 as [e1' [He1 He1']].
      assert (Ke1 := sorted_cons_min S2 He1').
      {
        case_eq (Oeset.compare OA e1 a1'); intro H1; rewrite H1 in Ka1.
        - rewrite Oeset.compare_lt_gt, CompOpp_iff in Ha1.
          rewrite (Oeset.compare_eq_trans _ _ _ _ H1 Ha1).
          apply refl_equal.
        - rewrite Oeset.compare_lt_gt in Ke1.
          rewrite Oeset.compare_lt_gt, CompOpp_iff in Ha1, He1.
          rewrite (Oeset.compare_eq_lt_trans
                     _ _ _ _ He1
                     (Oeset.compare_lt_eq_trans _ _ _ _ H1 Ha1)) in Ke1.
          apply False_rec; apply Ke1; apply refl_equal.
        - apply False_rec; apply Ka1; apply refl_equal.
      }
    }
    assert (IH := IHl1 (k1 ++ b :: k2)); simpl in IH.
    simpl; rewrite e1_eq_a1, IH.
    * apply refl_equal.
    * apply sorted_tl_sorted with e1; assumption.
    * apply sorted_tl_sorted with a1; assumption.
    * simpl in P.
      apply (@_permut_cons_inside _ _ _ e1 a1 l1 nil (k1 ++ b :: k2));
        [ | assumption | assumption].
      intros _a1 b1 a2 b2 _ _ _ _ H1 H2 H3.
      apply Oeset.compare_eq_trans with b1; [assumption | ].
      apply Oeset.compare_eq_trans with a2; [ | assumption].
      rewrite Oeset.compare_lt_gt, H2; apply refl_equal.
Qed.

(** Some usefull properties on the result of quicksort. *)
Lemma length_quicksort : forall l, length (quicksort l) = length l.
Proof.
intro l; apply sym_eq.
apply (_permut_length (R:= fun x y => Oeset.compare OA x y = Eq)).
apply quick_permut.
Qed.

Lemma mem_quick_mem : forall a l, Oeset.mem_bool OA a l = Oeset.mem_bool OA a (quicksort l).
Proof.
intros; apply mem_permut_mem.
apply quick_permut.
Qed.

Lemma mem_quicksort_cons : forall a l, Oeset.mem_bool OA a (quicksort (a :: l)) = true.
Proof.
intros a l; rewrite <- mem_quick_mem; simpl.
unfold Oeset.eq_bool; rewrite Oeset.compare_eq_refl; apply refl_equal.
Qed.

(** What happens when a sorted list is removed from another one.*)
Function remove_list (eq_bool : A -> A -> bool) (la l : list A) {struct l} : option (list A) :=
  match la with
  | nil => Some l
  | a :: la' =>
	match l with
	| nil => None
	| b :: l' =>
	   if eq_bool a b
	   then remove_list eq_bool la' l'
	   else
	     match remove_list eq_bool la l' with
	     | None => None
	     | Some rmv => Some (b :: rmv)
	     end
        end
  end.

(*
Lemma in_remove_list :
  forall (eq_bool : A -> A -> bool), (forall a b, if eq_bool a b then a = b else a <> b) ->
  forall l la, is_sorted la -> is_sorted l ->
  match remove_list eq_bool la l with
  | None => forall rmv, ~ (permut (la ++ rmv) l)
  | Some rmv => permut (la ++ rmv) l
  end.
Proof.
intros eq_bool eq_bool_ok.
fix 1.
intro l; case l; clear l.
(* l = [] *)
intro la; simpl; case la; clear la.
intros _ _; apply Pnil.
intros a la Sla _ rmv P; assert (H := _permut_length P); discriminate.
(* l = _ :: _ *)
intros e l la; simpl; case la; clear la.
intros _ _; apply _permut_refl; intros; apply refl_equal.
intros a la Sala Sel ; assert (Sl := sorted_tl_sorted Sel).
assert (Sla := sorted_tl_sorted Sala).
generalize (eq_bool_ok a e); case (eq_bool a e).
intros a_eq_e; generalize (in_remove_list l la Sla Sl); case (remove_list eq_bool la l).
intros rmv P; simpl; refine (Pcons a e nil l _ _); assumption.
intros H rmv P; apply (H rmv); simpl in P.
apply (_permut_cons_inside (a := a) e nil l).
intros; subst; trivial.
assumption.
assumption.
intros a_diff_e; generalize (in_remove_list l (a :: la) Sala Sl); case (remove_list eq_bool (a :: la) l).
intros rmv P; apply _permut_sym.
intros; apply sym_eq; assumption.
apply Pcons.
apply refl_equal.
apply _permut_sym.
intros; apply sym_eq; assumption.
assumption.
intros H rmv P.
assert (e_in_larm : In e ((a :: la) ++ rmv)).
rewrite (in_permut_in P); left; reflexivity.
simpl in e_in_larm; case e_in_larm; clear e_in_larm.
intro e_eq_a; apply a_diff_e; assumption.
intro e_in_larmv; destruct (in_app_or _ _ _ e_in_larmv) as [e_in_la | e_in_rmv]; clear e_in_larmv.
apply a_diff_e.
assert (H1 : Oset.compare DOS a e <> Gt).
apply (sorted_cons_min Sala (or_intror _ e_in_la)).
assert (H2 : In a (e :: l)).
rewrite <- (in_permut_in P); simpl; left; apply refl_equal.
assert (H3 := sorted_cons_min Sel H2).
rewrite Oset.compare_lt_gt in H3.
revert H1 H3; generalize (Oset.eq_bool_ok DOS a e); case (Oset.compare DOS a e).
exact (fun h _ _ => h).
intros _ _ Abs; apply False_rec; apply Abs; apply refl_equal.
intros _ Abs; apply False_rec; apply Abs; apply refl_equal.
generalize (in_split_set DOS _ _ e_in_rmv).
intros [l1 M]; case M; clear M.
intros l2 M; subst rmv.
apply (H (l1 ++ l2)).
rewrite ass_app; apply (_permut_add_inside (R := @eq A) e e (a :: la ++ l1) l2 nil l).
intros; subst; trivial.
apply refl_equal.
simpl; rewrite <- ass_app; simpl; assumption.
Qed.
*)

End Sec.

Section Strong.

Lemma quick_permut_strong :
  forall (A : Type) (OA : Oeset.Rcd A) l, _permut (@eq A) l (quicksort OA l).
Proof.
intros A OA l; functional induction (quicksort OA l)
   as [ | l a' l' l_eq_a'_l' l1 l2 H S1 S2]; auto.
- apply Pnil.
- apply Pcons; [apply refl_equal | ].
  apply _permut_trans with (l1 ++ l2).
  + intros; subst; trivial.
  + clear S1 S2; revert l1 l2 H.
    induction l' as [ | a1 l']; intros l1 l2 H; simpl in H.
    * injection H; clear H; intros; subst l1 l2; apply _permut_refl; intros; trivial.
    * case_eq (partition OA a' l'); intros k1 k2 Hk.
      assert (IH := IHl' _ _ Hk).
      rewrite Hk in H.
      {
        case_eq (Oeset.compare OA a1 a'); intro Ha1; rewrite Ha1 in H.
        - injection H; clear H; intros H1 H2; subst l1 l2.
          apply Pcons; trivial.
        - injection H; clear H; intros H1 H2; subst l1 l2; simpl.
          apply (Pcons (B := A) (R := @eq A) a1 a1 (l := l') nil _ (refl_equal _) IH).
        - injection H; clear H; intros H1 H2; subst l1 l2.
          apply Pcons; trivial.
      }
  + apply _permut_app; assumption.
Qed.

Lemma In_quicksort :
  forall (A : Type) (OA : Oeset.Rcd A) l a, In a l <-> In a (quicksort OA l).
Proof.
intros A OA l; functional induction (quicksort OA l)
   as [ | l a' l' l_eq_a'_l' l1 l2 H S1 S2]; auto.
- intro; split; exact (fun h => h).
- intros a.
  assert (Ka : In a l' <-> In a (l1 ++ l2)).
  {
    clear S1 S2.
    revert l1 l2 H; induction l' as [ | a1 l']; intros l1 l2 H.
    - simpl in H; injection H; clear H; do 2 intro; subst l1 l2.
      split; exact (fun h => h).
    - simpl in H.
      case_eq (partition OA a' l'); intros k1 k2 Hk; rewrite Hk in H.
      assert (IH := IHl' _ _ Hk).
      simpl; rewrite IH.
      revert H; case (Oeset.compare OA a1 a');
      intro H; injection H; clear H; do 2 intro; subst l1 l2.
      + rewrite 2 In_app; simpl; intuition.
      + rewrite 2 In_app; simpl; intuition.
      + rewrite 2 In_app; simpl; intuition.
  }
  simpl; rewrite Ka, 2 In_app; simpl; rewrite <- S1, <- S2.
  intuition.
Qed.

End Strong.

Section Cardinal.

  Hypothesis A B : Type.
  Hypothesis OA : Oeset.Rcd A.
  Hypothesis OB : Oeset.Rcd B.
  Hypothesis f : A -> B.

  Lemma inject_sorted :
    forall l,
      Sorted (fun x y => Oeset.compare OA x y = Lt) l ->
      (forall a1 a2, In a1 l -> In a2 l -> Oeset.compare OB (f a1) (f a2) = Eq -> Oeset.compare OA a1 a2 = Eq) ->
      exists fl, _permut (fun x y => Oeset.compare OB x y = Eq) fl (List.map f l) /\
                 Sorted (fun x y =>  Oeset.compare OB x y = Lt) fl.
  Proof.
    intros l HS Hf.
    exists (quicksort OB (map f l)); split.
    + apply permut_sym; apply quick_permut.
    + assert (H := quick_sorted OB (map f l)).
      rewrite is_sorted_Sorted in H.
      revert H.
      assert (H : forall fl1 fl2 fl3 b1 b2, map f l = fl1 ++ b1 :: fl2 ++ b2 :: fl3 -> Oeset.compare OB b1 b2 <> Eq).
      {
        intro fl1; revert l HS Hf.
        induction fl1 as [ | c1 fl1]; intros l HS Hf fl2 fl3 b1 b2 H.
        - simpl in H.
          destruct l as [ | a1 l]; [discriminate H | ].
          rewrite map_unfold in H; injection H; clear H.
          intro H; intro; subst b1.
          revert a1 l HS Hf fl3 b2 H.
          induction fl2 as [ | c2 fl2]; intros a1 l HS Hf fl3 b2 H.
          + destruct l as [ | a2 l]; [discriminate H | ].
            rewrite map_unfold in H; injection H; clear H.
            intro H; intro; subst b2.
            intro K.
            assert (Kf := Hf a1 a2
                             (or_introl _ (refl_equal _))
                             (or_intror _ (or_introl _ (refl_equal _))) K).
            inversion HS; clear HS; subst.
            inversion H3; clear H3; subst.
            rewrite Kf in H0; discriminate H0.
          + destruct l as [ | a2 l]; [discriminate H | ].
            rewrite map_unfold in H; injection H; clear H.
            intro H; intro; subst c2.
            revert H; apply IHfl2.
            * inversion HS; clear HS; subst.
              inversion H1; clear H1; subst.
              inversion H2; clear H2; subst.
              constructor 2; [assumption | ].
              destruct l as [ | a3 l]; [constructor 1 | ].
              constructor 2.
              inversion H4; clear H4; subst.
              apply Oeset.compare_lt_trans with a2; assumption.
            * intros x y Hx Hy; apply Hf.
              destruct Hx as [Hx | Hx]; [left | right; right]; assumption.
              destruct Hy as [Hy | Hy]; [left | right; right]; assumption.
        - destruct l as [ | a1 l]; [discriminate H | ].
          rewrite map_unfold in H; injection H; clear H.
          intro H; intro; subst c1.
          revert H; apply IHfl1.
          + inversion HS; clear HS; subst; assumption.
          + do 4 intro; apply Hf; right; assumption.
      }
      set (fl := map f l) in *; clearbody fl.
      clear l HS Hf.
      assert (K : forall (fl1 fl2 fl3 : list B) (b1 b2 : B),
      quicksort OB fl = fl1 ++ b1 :: fl2 ++ b2 :: fl3 -> Oeset.compare OB b1 b2 <> Eq).
      {
        intros fl1 fl2 fl3 b1 b2 K.
        assert (J := quick_permut OB fl).
        rewrite K in J.
        destruct (_permut_inv_right_strong _ _ _ J) as [_b1 [fl' [fl'' [H1 [H2 H3]]]]].
        rewrite ass_app in H3.
        destruct (_permut_inv_right_strong _ _ _ H3) as [_b2 [fl1' [fl1'' [K1 [K2 K3]]]]].
        destruct (split_list _ _ _ _ K2) as [l [[J1 J2] | [J1 J2]]]; subst.
        - intro Hb1b2.
          apply (H fl' l fl1'' _b1 _b2 (refl_equal _)).
          apply Oeset.compare_eq_trans with b1; [assumption | ].
          apply Oeset.compare_eq_trans with b2; [assumption | ].
          rewrite Oeset.compare_lt_gt, K1; apply refl_equal.
        - intro Hb1b2.
          destruct l as [ | __b2 l].
          + simpl in J2; subst fl''.
            rewrite <- app_nil_end in H.
            apply (H fl1' nil fl1'' _b1 _b2 (refl_equal _)).
            apply Oeset.compare_eq_trans with b1; [assumption | ].
            apply Oeset.compare_eq_trans with b2; [assumption | ].
            rewrite Oeset.compare_lt_gt, K1; apply refl_equal.
          + simpl in J2; injection J2; clear J2.
            intro J2; intro; subst fl1'' __b2.
            rewrite <- ass_app in H.
            apply (H fl1' l fl'' _b2 _b1 (refl_equal _)).
            rewrite Oeset.compare_lt_gt, CompOpp_iff.
            apply Oeset.compare_eq_trans with b1; [assumption | ].
            apply Oeset.compare_eq_trans with b2; [assumption | ].
            rewrite Oeset.compare_lt_gt, K1; apply refl_equal.
      }
      set (qfl := quicksort OB fl) in *; clearbody qfl.
      clear fl H.
      induction qfl as [ | b1 l].
      * intros _; constructor 1.
      * intro HS; inversion HS; clear HS; subst.
        {
          constructor 2.
          - apply IHl.
            + intros fl1 fl2 fl3 c1 c2 H; apply (K (b1 :: fl1) fl2 fl3 c1 c2 (f_equal _ H)).
            + assumption.
          - destruct l as [ | b2 l].
            + constructor 1.
            + constructor 2.
              inversion H2; clear H2; subst.
              assert (Kb1b2 := K nil nil l b1 b2 (refl_equal _)).
              destruct (Oeset.compare OB b1 b2).
              * apply False_rec; apply Kb1b2; apply refl_equal.
              * apply refl_equal.
              * apply False_rec; apply H0; apply refl_equal.
        }
  Qed.

End Cardinal.

Require Import NArith.

Section NbOcc.

Hypothesis A : Type.
Hypothesis OA : Oeset.Rcd A.

Lemma nb_occ_quicksort : forall x l, Oeset.nb_occ OA x (quicksort OA l) = Oeset.nb_occ OA x l.
Proof.
intros x l1; apply sym_eq; apply permut_nb_occ; apply quick_permut.
Qed.

Lemma nb_occ_sorted :
  forall l x a, Oeset.compare OA x a = Lt -> is_sorted OA (a :: l) -> Oeset.nb_occ OA x l = 0%N.
Proof.
intro l; induction l as [ | a1 l]; intros x a Hx Hl; [apply refl_equal | ].
rewrite Oeset.nb_occ_unfold.
inversion Hl; clear Hl; subst.
case_eq (Oeset.compare OA a a1); intro Ha.
- rewrite (Oeset.compare_lt_eq_trans _ _ _ _ Hx Ha), (IHl x a); trivial.
  inversion H3; clear H3; subst.
  + constructor 2.
  + constructor 3; [ | trivial].
    intro H; apply H2.
    apply (Oeset.compare_eq_gt_trans _ _ a); [ | assumption].
    apply Oeset.compare_eq_sym; apply Ha.
- rewrite (Oeset.compare_lt_trans _ _ _ _ Hx Ha), (IHl x a); trivial.
  inversion H3; clear H3; subst.
  + constructor 2.
  + constructor 3; [ | trivial].
    intro H; apply H2.
    apply (Oeset.compare_gt_trans _ _ a); [ | assumption].
    rewrite Oeset.compare_lt_gt, Ha; apply refl_equal.
- rewrite Ha in H1; apply False_rec; apply H1; apply refl_equal.
Qed.

Lemma nb_occ_sorted_lt :
  forall x l a, Oeset.compare OA x a = Lt ->
                Sorted (fun x y =>  Oeset.compare OA x y = Lt) (a :: l) ->
                Oeset.nb_occ OA x (a :: l) = 0%N.
Proof.
intros x l;  induction l as [ | a1 l]; intros a Ha Hl.
- simpl; rewrite Ha; apply refl_equal.
- rewrite Oeset.nb_occ_unfold, Ha, IHl.
  + apply refl_equal.
  + inversion Hl; subst.
    refine (Oeset.compare_lt_trans _ _ _ _ Ha _).
    inversion H2; subst; trivial.
  + inversion Hl; subst; trivial.
Qed.

End NbOcc.