(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** * Real riemannian integrals *)

Require Import Reals.
Require Import RiemannInt.
Require Import RIneq.
Require Import Fourier.
Require Import R_sqr.
Require Import MyRfunctions.
Open Local Scope R_scope.

(* begin hide *)

Lemma Rmin_def a b: a <= b -> Rmin a b = a.
Proof.
intros a b Hab.
unfold Rmin.
destruct (Rle_dec a b); tauto.
Qed.

Lemma Rmax_def a b: a <= b -> Rmax a b = b.
Proof.
intros a b Hab.
unfold Rmax.
destruct (Rle_dec a b); tauto.
Qed.

Lemma Rmax_le a b c : a <= c -> b <= c -> Rmax a b <= c.
intros a b c H1 H2.
unfold Rmax.
case (Rle_dec a b); intro H.
 apply H2.
apply H1.
Qed.

Lemma Rmax_lt a b c : a < c -> b < c -> Rmax a b < c.
Proof.
intros a b c H1 H2.
unfold Rmax.
case (Rle_dec a b); intro H.
 apply H2.
apply H1.
Qed.

Lemma Rmin_ge a b c : c <= a -> c <= b -> c <= Rmin a b.
intros a b c H1 H2.
unfold Rmin.
case (Rle_dec a b); intro H.
 apply H1.
apply H2.
Qed.

(* end hide *)

(** * Definition of the integral of f between a and b using Riemann_integrable *)

Definition Rint f a b I := exists pr : Riemann_integrable f a b, RiemannInt pr = I.

(** * Common results on integrals *)

Section Rint_facts.

(** The integral from a to b is the opposite of the integral from b to a *)

Lemma Rint_reverse f a b x : Rint f a b  x <-> Rint f b a (-x).
Proof.
intros f a b x. split; intros [pr H].
pose proof RiemannInt_P1 pr as pr2;
exists pr2;
assert(RiemannInt pr2 = - RiemannInt pr) as Hrew;
  [ apply RiemannInt_P8 | rewrite Hrew];
rewrite H; intuition.
pose proof RiemannInt_P1 pr as pr2;
exists pr2;
assert(RiemannInt pr2 = - RiemannInt pr) as Hrew;
  [ apply RiemannInt_P8 | rewrite Hrew];
rewrite H; intuition.
Qed.

Lemma Riemann_integrable_eq_compat f g a b :
  (forall x, Rmin a b <= x <= Rmax a b -> g x = f x) ->
    Riemann_integrable f a b ->
      Riemann_integrable g a b.
Proof.
intros f g a b Heq prf;
case(Rle_dec a b); intro Hab;
  [ | apply RiemannInt_P1 in prf;
     apply RiemannInt_P1];
  intro eps; destruct (prf eps) as [phi [psi Hpsi]];
  [ | rewrite Rmin_comm, Rmax_comm in Heq ];
  exists phi; exists psi.
  split; [
  intros t Ht; rewrite Heq; [ apply Hpsi | apply Ht] ;
    apply Ht |
    apply Hpsi ] .
  split; [
  intros t Ht; rewrite Heq; [ apply Hpsi | apply Ht] ;
    apply Ht |
    apply Hpsi ] .
Qed.

Lemma Rint_eq_compat f g a b x :
  (forall x, Rmin a b <= x <= Rmax a b -> g x = f x) ->
    Rint f a b x -> Rint g a b x.
Proof.
intros f g a b x Heq.
case(Rle_dec a b); intros Hab.
intros [prf Hf].
pose proof (Riemann_integrable_eq_compat f g a b Heq prf) as prg.
exists prg.
erewrite RiemannInt_P18.
  apply Hf.
 apply Hab.
 rewrite (Rmin_def _ _ Hab), (Rmax_def _ _ Hab) in Heq.
 intuition.
rewrite Rmin_comm, Rmax_comm in Heq.
intro RIf.
apply (proj2 (Rint_reverse _ _ _ _ )) .
apply Rint_reverse in RIf.
destruct RIf as [prf Hf].
pose proof (Riemann_integrable_eq_compat f g b a Heq prf) as prg.
exists prg.
apply Rnot_le_lt, Rlt_le in Hab.
erewrite RiemannInt_P18.
  apply Hf.
  apply Hab.
 rewrite (Rmin_def _ _ Hab), (Rmax_def _ _ Hab) in Heq.
 intuition.
Qed.

Lemma Rint_RiemannInt_link f a b (pr : Riemann_integrable f a b) :
  Rint f a b (RiemannInt pr).
Proof.
intros f a b pr.
exists pr.
reflexivity.
Qed.

(** * Continuous functions are integrable *)

Lemma Rint_continuity f a b :
  a <= b ->
    (forall x, a <= x <= b -> continuity_pt f x) ->
  exists x, Rint f a b x.
Proof.
intros f a b Hab f_cont.
exists(RiemannInt (continuity_implies_RiemannInt Hab f_cont)).
apply Rint_RiemannInt_link.
Qed.

(** * Chasles relation on integrals *)

Lemma Rint_Chasles f a b c x y :
  Rint f a b x -> Rint f b c y -> Rint f a c (x+y).
Proof.
intros f a b c x y [prab Hab] [prbc Hbc].
pose proof (RiemannInt_P24  prab prbc) as prac.
exists prac.
rewrite <- Hab, <- Hbc.
symmetry.
apply RiemannInt_P26.
Qed.

Lemma Rint_singleton f a : Rint f a a 0.
Proof.
intros f a.
pose proof RiemannInt_P7 f a as pr.
exists pr.
apply RiemannInt_P9.
Qed.

Lemma Rint_constant c a b : Rint (fct_cte c) a b (c*(b-a)).
Proof.
intros c a b.
pose proof RiemannInt_P14 a b c as pr.
exists pr.
apply RiemannInt_P15.
Qed.

(** The value of the integral is unique *)

Lemma Rint_uniqueness f a b x y : Rint f a b x -> Rint f a b y -> x = y.
Proof.
intros f a b x y [pr1 H1] [pr2 H2].
rewrite <- H1, <- H2.
apply RiemannInt_P5.
Qed.

Lemma Rint_subinterval f a b c x : (a <= b <= c) ->
  Rint f a c  x -> exists y, Rint f a b y /\ Rint f b c (x-y).
Proof.
intros f a b c x Hb [prac Hf].
pose proof RiemannInt_P22 prac Hb as prab.
exists (RiemannInt prab).
split.
  apply Rint_RiemannInt_link.
pose proof RiemannInt_P23 prac Hb as prbc.
exists prbc.
rewrite <- Hf.
rewrite <- RiemannInt_P26 with _ _ _ _ prab prbc prac.
ring.
Qed.

End Rint_facts.

(** * Compatibility of integrals with operations *)

Section Rint_operations.

Lemma Rint_plus f g a b x y : Rint f a b x -> Rint g a b y -> Rint (f + g)%F a b (x + y).
Proof.
intros f g a b x y [prf Hf] [prg Hg]; unfold plus_fct.
apply Rint_eq_compat with (fun u => f u + 1 * g u).
  intros; ring.
replace (x+y) with (x+1*y) by ring.
pose proof RiemannInt_P10 1 prf prg as prfg.
exists prfg.
rewrite RiemannInt_P13 with _ _ _ _ _ prf prg prfg.
rewrite Hf, Hg; reflexivity.
Qed.

Lemma Rint_minus f g a b x y : Rint f a b x -> Rint g a b y -> Rint (f - g)%F a b (x - y).
Proof.
intros f g a b x y [prf Hf] [prg Hg]; unfold minus_fct.
apply Rint_eq_compat with (fun u => f u + (-1) * g u).
  intros; ring.
replace (x - y) with (x+(-1)*y) by ring.
pose proof RiemannInt_P10 (-1) prf prg as prfg.
exists prfg.
rewrite RiemannInt_P13 with _ _ _ _ _ prf prg prfg.
rewrite Hf, Hg; reflexivity.
Qed.

Lemma Rint_opp f a b x : Rint f a b x <-> Rint (- f)%F a b (- x).
Proof.
intros f a b x; split; intros [prf Hf]; unfold opp_fct.
  apply Rint_eq_compat with (fun u => fct_cte 0 u + (-1) * f u).
    unfold fct_cte; intros; ring.
  replace (- x) with (0 + (-1)* x) by ring.
  pose proof Rint_constant 0 a b as [prg Hg].
  pose proof RiemannInt_P10 (-1) prg prf as prfg.
  exists prfg.
  rewrite RiemannInt_P13 with _ _ _ _ _ prg prf prfg.
  rewrite Hf, Hg; ring.
apply Rint_eq_compat with (fun u => fct_cte 0 u + (-1) *(- f)%F u).
  unfold fct_cte, opp_fct; intros; ring.
replace (x) with (0 + (-1)*(- x)) by ring.
pose proof Rint_constant 0 a b as [prg Hg].
pose proof RiemannInt_P10 (-1) prg prf as prfg.
exists prfg.
rewrite RiemannInt_P13 with _ _ _ _ _ prg prf prfg.
rewrite Hf, Hg; ring.
Qed.

Lemma Rint_scalar_mult_compat_l f a b x C : Rint f a b x -> Rint (fct_cte C * f)%F a b (C*x).
Proof.
intros f a b x C [prf Hf].
apply Rint_eq_compat with (fun u => fct_cte 0 u + C * f u).
    unfold fct_cte, mult_fct; intros; ring.
  replace (C * x) with (0 + C* x) by ring.
  pose proof Rint_constant 0 a b as [prg Hg].
  pose proof RiemannInt_P10 C prg prf as prfg.
  exists prfg.
  rewrite RiemannInt_P13 with _ _ _ _ _ prg prf prfg.
  rewrite Hf, Hg; ring.
Qed.

Lemma Rint_scalar_mult_compat_r f a b x C : Rint f a b x -> Rint (f * fct_cte C)%F a b (x * C).
Proof.
intros f a b x C [prf Hf].
apply Rint_eq_compat with (fun u => fct_cte 0 u + C * f u).
    unfold fct_cte, mult_fct; intros; ring.
  replace (C * x) with (0 + C* x) by ring.
  pose proof Rint_constant 0 a b as [prg Hg].
  pose proof RiemannInt_P10 C prg prf as prfg.
  exists prfg.
  rewrite RiemannInt_P13 with _ _ _ _ _ prg prf prfg.
  rewrite Hf, Hg; ring.
Qed.

End Rint_operations.

Create HintDb Rint.

Hint Resolve Rint_reverse : Rint.
Hint Resolve Rint_RiemannInt_link : Rint.
Hint Resolve Rint_Chasles : Rint.
Hint Resolve Rint_constant : Rint.
Hint Resolve Rint_plus : Rint.
Hint Resolve Rint_minus : Rint.
Hint Resolve Rint_opp : Rint.
Hint Resolve Rint_scalar_mult_compat_l : Rint.
Hint Resolve Rint_scalar_mult_compat_r : Rint.
Hint Resolve Rint_uniqueness : Rint.
Hint Resolve Rint_reverse : Rint.
Hint Resolve RiemannInt_P6 : Rint.
Hint Resolve RiemannInt_P7 : Rint.
Hint Resolve RiemannInt_P10 : Rint.
Hint Resolve RiemannInt_P14 : Rint.
Hint Resolve RiemannInt_P16 : Rint.

Section Rint_props.

(** * Inequalities involving integrals *)

Lemma Rint_le_compat f g a b x y :
  a <= b -> (forall u, a < u < b -> f u <= g u) ->
      Rint f a b x -> Rint g a b y ->  x <= y.
Proof.
intros f g a b x y Hab Heq [prh Hf] [prg Hg].
rewrite <-  Hf, <- Hg.
apply RiemannInt_P19.
  apply Hab.
apply Heq.
Qed.

(** A positive function has positive growing integral *)

Lemma Rint_pos f a b x :
  a <= b -> (forall u, a <= u <= b -> 0 <= f u) -> Rint f a b x -> 0 <= x.
Proof.
intros f a b x Hab Hpos Hf.
destruct(Rint_constant 0 a b) as [pr0 H0].
ring_simplify in H0.
apply Rint_le_compat with (fct_cte 0) f a b.
  apply Hab.
  intros u Hu; apply Hpos; intuition.
  exists pr0.
  apply H0.
apply Hf.
Qed.

(** Inequality between integral of the absolute value and
 absolute value of the integral *)

Lemma Rint_abs_le_int f a b x :
  a <= b -> Rint f a b x ->
    exists y, Rint (fun u => Rabs (f u)) a b y /\ Rabs x <= y.
Proof.
intros f a b x Hab [prf Hf].
pose proof RiemannInt_P16 prf as prabs.
exists (RiemannInt prabs).
split.
  exists prabs.
  reflexivity.
rewrite <- Hf.
apply RiemannInt_P17.
apply Hab.
Qed.

(** A non always null, non negative, continuous function on a non trivial segment has positive integral *)

Lemma Rint_continuous_gt_0 f a b u X :
  a < b ->
    a <= u <= b ->
      (forall x, a <= x <= b -> continuity_pt f x) ->
        (forall x, a <= x <= b -> 0 <= f x) ->
          f u <> 0 -> Rint f a b X -> 0 < X.
Proof.
intros f a b u X Hab Haub Hcont Hpos Hu HX.
destruct (continuous_neq_0 f u (Hcont u Haub) Hu) as [eps Heps].
assert(exists c, exists d, a <= c <= b /\ a <= d <= b /\ c < d /\ forall x, c <= x <= d -> 0 < f x).
  exists (Rmax a (u -eps/2)).
  exists (Rmin b (u+ eps/2)).
  assert(Heps2 : 0 < eps/2) .
    apply Rlt_mult_inv_pos.
      apply cond_pos.
      auto with *.
  repeat split.
    apply RmaxLess1.

    apply Rmax_le.
      left; apply Hab.

    apply Rle_trans with u; [fourier | intuition].

    apply Rmin_ge.
      left; apply Hab.
    apply Rle_trans with u;  [intuition | fourier].

    apply Rmin_l.

    case(Rle_lt_or_eq_dec a u(proj1 Haub)); intro Hau.
      apply Rlt_le_trans with u.
        apply Rmax_lt; [intuition | fourier].
    apply Rmin_ge; [intuition | fourier].
    subst.
    apply Rle_lt_trans with u.
      apply Rmax_le; fourier.
    apply Rmin_2; fourier.
  intros x Hx.
  rewrite <- Rabs_pos_eq.
    apply Rabs_pos_lt.
    replace x with (u+ (x-u)) by ring.
    apply (Heps (x-u)).
    assert( u - eps <  x < u + eps) as [ Hu1 Hu2].
    split.
      apply Rlt_le_trans with (Rmax a (u - eps/2)).
        apply Rlt_le_trans with (u-eps/2).
          fourier.
        apply RmaxLess2.
        apply Hx.
      apply Rle_lt_trans with (Rmin b (u + eps/2)).
        apply Hx.
      apply Rle_lt_trans with (u + eps/2).
        apply Rmin_r.
      fourier.
    apply Rabs_def1; fourier.
  apply Hpos.
  split.
    eapply Rle_trans.
      apply RmaxLess1.
      apply (proj1 Hx).
    eapply Rle_trans.
      apply (proj2 Hx).
      apply Rmin_l.
destruct H as [c [d [ Hacb [Hadb [Hcd Hstp]]]]].
destruct (Rint_subinterval _ _ _ _ _ Hacb HX) as [Y [HY HZ]].
assert(c <= d<=b) as Hcdb by intuition.
destruct (Rint_subinterval _ _ _ _ _ Hcdb HZ) as [T [HT HV]].
destruct (continuity_ab_min f c d) as [m Hm].
 apply Hcdb.

 intros x Hcxd.
 apply Hcont.
 split; eapply Rle_trans; [apply Hacb | apply Hcxd | apply Hcxd | apply Hadb].
apply Rlt_le_trans with ((f m) * (d - c)).
 apply Rmult_lt_0_compat; [apply Hstp; apply Hm | fourier].
apply Rle_trans with T.
 apply Rint_le_compat with (fct_cte (f m)) f c d.
  apply Hcdb.

  intros; apply Hm; split; apply Rlt_le; apply H.

  apply Rint_constant.

  apply HT.
apply Rle_trans with (X - Y).
  assert(Hcbpos : forall x : R, c <= x <= b -> 0 <= f x).
    intros x [H1 H2]; apply Hpos; split;[apply Rle_trans with c| ]; intuition.
    pose proof (Rint_pos _ _ _ _ (proj2 Hacb) Hcbpos HZ) as H.
  assert(0 <= X - Y - T).
    assert(Hdbpos : forall x : R, d <= x <= b -> 0 <= f x).
      intros x [H1 H2]; apply Hpos; split;[apply Rle_trans with d| ]; intuition.
    apply (Rint_pos _ _ _ _ (proj2 Hadb) Hdbpos HV).
  fourier.
assert(Hacpos : forall x : R, a <= x <= c -> 0 <= f x).
  intros x [H1 H2]; apply Hpos; split; [ | apply Rle_trans with c]; intuition.
pose proof (Rint_pos _ _ _ _ (proj1 Hacb) Hacpos HY) as H.
  assert(0 <= X - Y - T).
    assert(Hdbpos : forall x : R, d <= x <= b -> 0 <= f x).
      intros x [H1 H2]; apply Hpos; split;[apply Rle_trans with d| ]; intuition.
    apply (Rint_pos _ _ _ _ (proj2 Hadb) Hdbpos HV).
  fourier.
Qed.

(** A non negative function with null integral in a non trivial segment is null on it *)

Lemma Rint_continuous_pos_eq_0 f a b :
  a < b ->
    (forall x, a <= x <= b -> continuity_pt f x) ->
      (forall x, a <= x <= b -> 0 <= f x) ->
      Rint f a b 0 -> (forall x, a <= x <= b -> f x = 0).
Proof.
intros f a b Hab Hcont Hpos Hint x Hx.
case (Req_dec (f x) 0); intro Hcase.
  apply Hcase.
pose proof Rint_continuous_gt_0 _ _ _ _ 0 Hab Hx Hcont Hpos Hcase Hint as pr.
exact (False_ind _ (Rlt_irrefl 0 pr)).
Qed.

(* begin hide *)
Lemma Rsqr_eq_0_reg : forall a, a * a = 0 -> a = 0.
Proof.
intros a Haa.
destruct (total_order_T a 0) as [[|]|]; subst; trivial;
 (cut (0 < a * a); [intro; apply False_ind; apply (Rlt_not_eq _ _ H); auto|]);
 [replace (a * a) with (- a * - a) by ring|];
 apply Rmult_lt_0_compat; fourier.
Qed.

(* end hide *)

(** Cauchy-Schwarz's theorem for integrals *)

Lemma Rint_Cauchy_Schwarz f g a b x y z :
  a <= b ->
    (forall x, a <= x <= b -> continuity_pt f x) ->
      (forall x, a <= x <= b -> continuity_pt g x) ->
      Rint (f * f)%F a b x -> Rint (g * g)%F a b y -> Rint (f * g)%F a b z ->
      z^2 <= x * y.
Proof.
intros f g a b x y z Hle Hfc Hgc Hf Hg Hfg.
assert (H0 : {y = 0} + {y <> 0}).
  destruct (total_order_T y 0) as [[H|H]|H].
    right; apply Rlt_not_eq; assumption.
    left; assumption.
    right; apply Rgt_not_eq; assumption.
destruct H0 as [H0|H0].
assert (Hz : z = 0).
 destruct (Rle_lt_or_eq_dec a b Hle); [|
   subst; apply (Rint_uniqueness (f * g)%F b b z 0 Hfg
     (Rint_singleton (f * g)%F b))].
 eapply Rint_uniqueness; [apply Hfg|].
 eapply Rint_eq_compat with (fun _ => 0).
  intros.
  unfold mult_fct.
  apply Rmult_eq_0_compat_l.
  apply Rsqr_eq_0_reg.
  replace (g x0 * g x0) with ((g * g)%F x0) by auto.
  replace (Rmin a b) with a in * by (symmetry; apply Rmin_def; apply Hle).
  replace (Rmax a b) with b in * by (symmetry; apply Rmax_def; apply Hle).
  apply Rint_continuous_pos_eq_0 with a b; auto.
   intros; apply continuity_pt_mult; apply Hgc; assumption.
   intros; apply Rle_0_sqr.
   subst; assumption.
  pose (fun _:R => 0) as null; fold null.
  replace 0 with (0 * (b - a)) by ring.
  apply Rint_constant.
subst y; subst z.
  repeat rewrite Rmult_0_r.
  rewrite pow_ne_zero; auto with *.
assert (Hy : 0 <= y).
  eapply Rint_pos with (f := (g * g)%F).
    eexact Hle.
    intros u Hu; apply Rle_0_sqr.
    assumption.
pose (F k x := (f x - k * g x)²).
assert (Hpos : forall k i, Rint (F k) a b i -> 0 <= i).
  intros k i H.
  eapply Rint_pos with (f := F k).
    eexact Hle.
    intros u Hu; apply Rle_0_sqr.
    assumption.
assert (Heq : forall k, Rint (F k) a b (x - 2 * k * z + k² * y)).
  intros k.
    apply Rint_eq_compat with (f := ((f * f) - (fct_cte (2 * k)) * (f * g) + (fct_cte k² )* (g * g))%F).
    intros; unfold fct_cte, F, plus_fct, mult_fct, minus_fct, Rsqr; ring.
    auto with Rint.
assert (Hcs : 0 <= x - z² / y).
  eapply Hpos.
  replace (x - z² / y) with (x - 2 * (z / y) * z + (z / y)² * y).
  apply Heq.
  unfold Rsqr; field; assumption.
apply Rle_ge in Hcs; apply Rminus_ge in Hcs; apply Rge_le in Hcs.
apply Rmult_le_compat_r with (r := y) in Hcs; [|assumption].
replace (z² / y * y) with z² in Hcs by (field; assumption).
unfold Rsqr in Hcs.
ring_simplify in Hcs.
apply Hcs.
Qed.

(** Fundamental theorem of real analysis *)

Lemma Rint_derive f a b d :
  a <= b ->
  (forall x, a <= x <= b -> derivable_pt_abs f x (d x)) ->
  (forall x, a <= x <= b -> continuity_pt d x) ->
  Rint d a b (f b - f a).
Proof.
intros f a b d Hab Hder Hcont.
pose proof prolongement_C1_C1 f d a b Hab Hder Hcont as [g [Heq Hdeq]].
apply Rint_eq_compat with (derive g (diff0 g)).
  rewrite Rmin_def, Rmax_def; assumption.
exists (RiemannInt_P32 g a b).
rewrite RiemannInt_P33; intuition.
do 2 (rewrite Heq; intuition).
Qed.

Lemma Rint_derive2 f a b d :
  (forall x, Rmin a b <= x <= Rmax a b -> derivable_pt_abs f x (d x)) ->
  (forall x, Rmin a b <= x <= Rmax a b -> continuity_pt d x) ->
  Rint d a b (f b - f a).
Proof.
intros f a b d Hder Hcont.
destruct (Rle_dec a b) as [n|n].
 rewrite Rmin_def, Rmax_def in *; try assumption.
apply Rint_derive; assumption.
apply Rnot_le_lt, Rlt_le in n.
  rewrite Rmin_comm, Rmax_comm, Rmin_def, Rmax_def  in *; try assumption.
apply <- Rint_reverse; replace (- (f b - f a)) with (f a - f b) by ring.
apply Rint_derive; assumption.
Qed.

(** Integration by parts *)

Lemma Rint_parts f g a b f' g' Ifg' If'g :
a <= b ->
  (forall x : R, a <= x <= b -> derivable_pt_lim f x (f' x)) ->
  (forall x : R, a <= x <= b -> derivable_pt_lim g x (g' x)) ->
    (forall x : R, a <= x <= b -> continuity_pt f' x) ->
    (forall x : R, a <= x <= b -> continuity_pt g' x) ->
      Rint (f * g')%F a b Ifg' -> Rint (f' * g)%F a b If'g ->
        Ifg' = f b * g b - f a * g a - If'g.
Proof.
intros f g a b f' g' Ifg' If'g Hab Hderf Hderg Hcontf' Hcontg' Hfg' Hf'g.
assert (H : forall a b c, a + b = c -> a = c - b) by (intros; subst; ring);
apply H; clear H.
apply Rint_uniqueness with (f * g' + f' * g)%F a b.
  apply Rint_plus; assumption.
replace (f b * g b - f a * g a) with ((f * g)%F b - (f * g)%F a) by reflexivity.

apply Rint_derive.
  assumption.

  intros; unfold mult_fct, plus_fct; rewrite Rplus_comm;
  apply derivable_pt_lim_mult; intuition.

  intros; apply continuity_pt_plus;
  apply continuity_pt_mult; try intuition;
    apply derivable_continuous_pt.
    exists (f' x); apply Hderf; intuition.
    exists (g' x); apply Hderg; intuition.
Qed.

(** Variable change theorem *)

Lemma Rint_substitution f g g' a b I:
  a <= b -> (forall x, a <= x <= b -> g a <= g x <= g b) ->
  (forall x, g a <= x <= g b -> continuity_pt f x) ->
  (forall x, a <= x <= b -> derivable_pt_lim g x (g' x)) ->
  (forall x, a <= x <= b -> continuity_pt g' x) ->
  Rint (fun x => f (g x) * g' x) a b I ->
  Rint f (g a) (g b) I.
Proof.
intros f g g' a b I Hab Habgab Hcontf Hder Hcontg' HI.
 destruct (Habgab a) as [_ Hgab]; auto with *.

assert (Hpr : forall x : R, g a <= x -> x <= g b -> Riemann_integrable f (g a) x).
 intros.
 apply continuity_implies_RiemannInt; trivial.
 intros; apply Hcontf; split.
 tauto.
 apply Rle_trans with x; intuition; trivial.

pose (primitive Hgab (FTC_P1 Hgab Hcontf)) as F.

assert(Hfab : Riemann_integrable f (g a) (g b)).
 apply Hpr; auto with *.

assert(HF := RiemannInt_P20 Hgab (FTC_P1 Hgab Hcontf) Hfab).

assert(Heq : Rint f (g a) (g b) (F(g b) - (F(g a)))).
 unfold F; rewrite <- HF.
 apply Rint_RiemannInt_link.
replace I with (comp F g b - comp F g a).
apply Heq.

symmetry.
eapply Rint_uniqueness.
 apply HI.

 apply Rint_derive.
  trivial.
  intros.
  apply derivable_pt_lim_comp.
   auto.
   apply RiemannInt_P28; auto.

 intros.
 apply continuity_pt_mult.
  apply continuity_pt_comp.
   apply derivable_continuous_pt.
   exists (g' x); apply Hder; apply H.

  auto.

auto.
Qed.

End Rint_props.


Set Implicit Arguments.

Require Import LibTactics.
(* Require Import LibTactics_chargueraud. *)

Require Import LNameless_Meta.
Require Import LNameless_Isomorphism.
Require Import LNameless_Fsub_Iso.
Require Export LN_Template_Two_Sort.
Require Export LN_Fsub_adv_Infrastructure.

(* ************************************************************ *)
(** ** Fsub Part 1A and 2A *)

(** Reference: Chargueraud's POPL solution using Locally Nameless style
   and cofinite quantification *)

(* ********************************************************************** *)
(** * Properties of Subtyping *)

(* ********************************************************************** *)
(** Reflexivity *)

Lemma sub_reflexivity : forall E F T,
  M_yy.Ywf_env E ->
  M_yy.YTenvT E F T ->
  sub E F T T .
Proof.
  introv Ok WI. assert_concrete. poses W (M_yy.YenvT_YwfT WI).
  clear WI. assert_concrete. gen E.
  induction H0; intros E Hwf Hwft; auto; inversion Hwft; subst.
  apply sub_arrow; auto.

  apply sub_all with (L `union` dom E `union` L0); auto; intros;
    destruct_notin; subst.
  apply H1; auto.
  generalize (wft_YTenvT H6); intro.
  unfold M_yy.Ywf_env; simpl. simpl_alist; constructor; auto.
  to_gen; generalize (H7 X NotInTac0); intro.
  generalize (wft_YTenvT H3); intro.
  generalize (wft_YTenvT H6); intro.
  apply M_yy.YTenvT_narrow_left with V; auto.
  constructor; auto using uniq_from_Ywf_env.
Qed.

(* ********************************************************************** *)
(** Weakening *)

Lemma sub_weakening : forall E F G F0 S T,
   sub (E ++ G) F0 S T ->
   M_yy.Ywf_env (E ++ F ++ G) ->
   sub (E ++ F ++ G) F0 S T.
Proof.
  introv Typ. gen_eq (E ++ G) as H. gen E.
  induction Typ; introv EQ Ok; subst.
  (* sub_top *)
  constructor; auto using M_yy.TenvT_weaken, uniq_from_Ywf_env.
  (* sub_refl_var *)
  constructor 2; auto using M_yy.TenvT_weaken, uniq_from_Ywf_env.
  (* sub_trans_tvar *)
  apply sub_trans_tvar with U; auto.
  (* sub_arrow *)
  apply sub_arrow; auto.
  (* sub_all *)
  apply sub_all with (L `union` dom (E0 ++ F ++ G)); auto; intros; destruct_notin.
  do_rew <- app_assoc (apply H0); auto.
  apply Ywf_env_cons; auto.
  apply M_yy.TenvT_weaken; auto using uniq_from_Ywf_env.
  change (M_yy.YTenvT (E0 ++ G) F0 T1); auto.
Qed.

(* ********************************************************************** *)
(** Narrowing and transitivity *)

Section NarrowTrans.

  Definition transitivity_on Q := forall E F S T,
    sub E F S Q -> sub E F Q T -> sub E F S T.

  Hint Unfold transitivity_on.

  Hint Resolve M_yy.YTenvT_narrow.

  Lemma sub_narrowing_aux : forall Q F E Z P S T F0,
    transitivity_on Q ->
    sub (E ++ Z ~ Q ++ F) F0 S T ->
    sub F F0 P Q ->
    sub (E ++ Z ~ P ++ F) F0 S T.
  Proof.
    introv TransQ SsubT PsubQ.
    gen_eq (E ++ Z ~ Q ++ F) as G. gen E.
    induction SsubT; introv EQ; subst.
    (* sub_top *)
    apply* sub_top.
      apply Ywf_env_narrow with Q; auto.
    apply M_yy.YTenvT_narrow with Q; eauto using uniq_dom_only, uniq_from_Ywf_env.
    (* sub_refl_tvar *)
    apply* sub_refl_tvar.
      apply Ywf_env_narrow with Q; auto.
    apply M_yy.YTenvT_narrow with Q; eauto using uniq_dom_only, uniq_from_Ywf_env.
    (* sub_trans_var *)
    elim sub_regular with (E0 ++ [(Z, Q)] ++ F) F0 U T; intros; auto.
    inversion H1; clear H1.
    generalize (uniq_from_Ywf_env H0); intro.
    case (X == Z); intros EQ; subst.
      generalize (binds_mid_eq _ _ _ _ _ _ H H1); intro.
      apply* (@sub_trans_tvar P); auto.
      generalize (@sub_weakening nil); simpl; intro.
      apply* TransQ; simpl_alist in *.
        do_rew <- app_assoc (apply H5; auto).
        apply Ywf_env_narrow with Q; auto.
      subst.
      apply IHSsubT; auto.
    (* X <> Z *)
    analyze_binds H.
      apply* sub_trans_tvar; eauto using binds_app_2.
    apply* sub_trans_tvar; eauto using binds_app_3.
    (* sub_arrow *)
    apply sub_arrow; auto.
    (* sub_all *)
    apply sub_all with L; auto; intros; rewrite <- app_assoc; auto.
  Qed.

  Lemma sub_transitivity : forall Q,
    transitivity_on Q.
  Proof.
    intro Q; introv SsubQ QsubT.

    asserts W (type Q).
      to_gen. apply M_yy.YenvT_YwfT with E; auto.
    gen E F S T. gen_eq Q as Q' eq. gen Q' eq.
    induction W; intros Q' EQ E F S SsubQ;
      induction SsubQ; try discriminate; inversions EQ;
        intros T' QsubT; inversions QsubT;
          eauto 4 using sub_trans_tvar.

    apply sub_top; auto. clear H2. from_gen.
    apply wft_all with (L `union` L0 `union` dom E) T1; auto.
    intros; destruct_notin.
    generalize (H1 X NotInTac); intro.
    elim sub_regular with ([(X, T1)] ++ E) F (M_yy.M.Tbsubst S2 0%nat (typ_fvar X))
      (M_yy.M.Tbsubst T2 0%nat (typ_fvar X));tauto.

    clear H2 IHSsubQ.
    apply sub_all with (L `union` L0 `union` L1); auto*.
    intros; destruct_notin.
    apply H0 with (X:=X)(Q':=M_yy.M.Tbsubst T2 0 (typ_fvar X)); simpl_alist; auto.
    generalize (@sub_narrowing_aux T1 E nil X); simpl; intro.
    apply H3; simpl_alist; auto.
    unfold transitivity_on; intros; eauto 2 using IHW.
  Qed.

  Lemma sub_narrowing : forall Q E F Z P S T F0,
    sub F F0 P Q ->
    sub (E ++ Z ~ Q ++ F) F0 S T ->
    sub (E ++ Z ~ P ++ F) F0 S T.
  Proof.
    intros.
    apply sub_narrowing_aux with Q; auto.
    apply* sub_transitivity.
  Qed.

End NarrowTrans.

(* ********************************************************************** *)
(** Type substitution preserves subtyping *)

Lemma sub_through_subst_tt : forall Q E F Z S T P F0,
  sub (E  ++ Z ~ Q ++ F) F0 S T ->
  sub F F0 P Q ->
  sub (map (fun U => M_yy.M.Tfsubst U Z P) E ++ F) (map (fun U => M_yy.M.Tfsubst U Z P) F0)
  (M_yy.M.Tfsubst S Z P) (M_yy.M.Tfsubst T Z P).
Proof.
  introv SsubT PsubQ.
  generalize (sub_regular PsubQ); intro Hsub;
    inversion Hsub as [Hsub1 Hsub2]; inversion Hsub2; clear Hsub Hsub2.
  generalize (sub_regular SsubT); intro Hsub0;
    inversion Hsub0 as [Hsub10 Hsub20]; inversion Hsub20; clear Hsub0 Hsub20.
  generalize (wft_YTenvT H); intro.
  generalize (noRepr_Ywf_env_Yfsubst typ_noRepr E Q Z Hsub10 H3); intro Hokt.
  assert (uniq (map (fun U => M_yy.M.Tfsubst U Z P) E ++ F)).
  set (f := fun U0 => M_yy.M.Tfsubst U0 Z P).
  apply (map_uniq_5 typ f E F Z Q).
  apply uniq_from_Ywf_env; auto.
  set (f := fun U0 => M_yy.M.Tfsubst U0 Z P).
  gen_eq (E ++ Z ~ Q ++ F) as G. gen E.
  induction SsubT; introv Hok_env Huniq EQ; subst; gsimpl; simpl_alist in *.
  (* subtop *)
  unfold f; apply sub_top; eauto.
  (* sub_refl_tvar *)
  (* Z = X *)
  apply sub_reflexivity; auto.
  (* Z <> X *)
  apply sub_refl_tvar; auto.
  from_gen.
  clear H2 Hsub10.
  dependent destruction H1.
  analyze_binds H1.
  apply wft_var with (U:=f U); auto using binds_app_2, binds_map_2.
  apply wft_var with (U:=U); auto using binds_app_1.

  (* sub_trans_tvar *)
  (* Z = X *)
  subst X.
  generalize (binds_mid_eq _ _ _ _ _ _ H4 (uniq_from_Ywf_env Hsub10)); intro; subst U.
  apply* (@sub_transitivity Q).
    apply sub_typ_indep with F0; auto.
    generalize (@sub_weakening nil); simpl; intro; auto.
  pattern Q; rewrite (@M_yy.M.Tfsubst_no_occur Q Z P); auto.
  apply YTenvT_Yfv with F F0; auto.
  apply fresh_mid_tail with (a:=Q)(F:= E0).
  apply uniq_from_Ywf_env; auto.
  (* Z <> X *)
  replace (M_yy.M.Tfsubst T Z P) with (f T); auto.
  analyze_binds H4.
    apply sub_trans_tvar with (f U); auto using binds_app_2, binds_map_2.
  apply* (@sub_trans_tvar U); auto using binds_app_3.
  pattern U; rewrite (@M_yy.M.Tfsubst_no_occur U Z P); auto.
  puts (Ywf_env_binds X U Hsub1 BindsTac0).
  apply M_yy.envT_Yfv with F; auto.
  apply fresh_mid_tail with (a:=Q)(F:=E0).
  apply uniq_from_Ywf_env; auto.

  (* sub_all *)
  elim sub_regular with (E0 ++ Z ~ Q ++ F) F0 T1 S1; intros; auto.
  apply sub_all with (L `union` {{Z}} `union` dom (E0 ++ Z ~ Q ++ F)); intros; auto; destruct_notin.
  clear IHSsubT.
  replace (typ_fvar X) with (Iso_typ.To (Var Iso_typ.RR (inl X))); auto.
  repeat (rewrite Ybfsubst_permutation_var_wfT; auto); simpl.
  simpl_alist; rewrite <- app_assoc.
  puts (H4 X H8); simpl_alist in *.
  elim sub_regular with  ([(X, T1)] ++ E0 ++ [(Z, Q)] ++ F) F0
    (M_yy.M.Tbsubst S2 0%nat (typ_fvar X)) (M_yy.M.Tbsubst T2 0%nat (typ_fvar X));
    intros; auto.
  assert ([(X, M_yy.M.Tfsubst T1 Z P)] ++ map f E0
    = map f (X ~ T1 ++ E0)) as Hmap.
  unfold f; simpl; auto.
  rewrite <- app_assoc.
  Set Printing All.
  unfold elt, Iso_typ.TT in *.  (* Coq bug? *)
  rewrite Hmap.
  Unset Printing All.
  apply H5; auto; try tauto.
  apply noRepr_Ywf_env_Yfsubst with Q; auto.
  apply uniq_map_app_1.
  rewrite app_assoc; simpl.
  apply uniq_cons_3; try solve_uniq.
  simpl_alist in *; solve_notin.
Qed.

(* ********************************************************************** *)
(** * Properties of Typing *)

(* ********************************************************************** *)
(** Weakening *)

(** [typing_weakening_sub] needs to be divided. *)

Lemma typing_weakening_sub : forall E F G e T F0,
  typing (E ++ G) F0 e T ->
  YTwf_env (E ++ F ++ G) F0 ->
  typing (E ++ F ++ G) F0 e T.
Proof.
  introv Typ. gen_eq (E ++ G) as H. gen E.
  induction Typ; introv EQ Ok; subst.
  (* typing_var *)
  apply typing_var; auto.
  (* typing_abs *)
  apply typing_abs with (L `union` dom (E0 ++ F ++ G) `union` dom F0); auto.
  intros; destruct_notin; apply H0; auto.
  elim typing_regular with (E0 ++ G) ([(x, V)] ++ F0) (M_tt.M.Tbsubst e1 0%nat (trm_fvar x)) T1; intros; auto.
  constructor 3; auto.
  apply M_yy.YTenvT_weaken; auto.
  apply YTenvT_from_YTwf_env_2_left with x; auto.
  apply uniq_from_YTwf_env_1 with F0; auto.
  (* typing_app *)
  eapply typing_app; eauto.
  (* typing_tabs *)
  apply typing_tabs with (L `union` dom (E0 ++ F ++ G) `union` dom F0); auto.
  intros; destruct_notin.
  rewrite <- app_assoc.
  apply H0; auto.
  rewrite app_assoc.
  constructor 2; auto.
  puts (proj31 (typing_regular (H X H1))).
  apply M_yy.YTenvT_weaken; [idtac | apply uniq_from_YTwf_env_1 with F0; auto].
  apply YTenvT_from_YTwf_env_1_left with X; auto.
  (* typing_tapp *)
  eapply typing_tapp; eauto.
  apply sub_weakening; auto.
  eauto using Ywf_env_from_YTwf_env.
  (* typing_sub *)
  eapply typing_sub; eauto.
  eapply sub_weakening; eauto.
  eauto using Ywf_env_from_YTwf_env.
Qed.

Lemma typing_weakening_typ : forall E F G e T E0,
  typing E0 (E ++ G) e T ->
  YTwf_env E0 (E ++ F ++ G) ->
  typing E0 (E ++ F ++ G) e T.
Proof.
  introv Typ. gen_eq (E ++ G) as H. gen E.
  induction Typ; introv EQ Ok; subst.
  (* typing_var *)
  apply* typing_var; auto.
  (* typing_abs *)
  apply typing_abs with (L `union` dom (E0 ++ F ++ G) `union` dom E); auto.
  intros; destruct_notin.
  rewrite <- app_assoc.
  apply H0; auto.
  rewrite app_assoc; constructor 3; auto.
  apply M_yy.YTenvT_typ_var_indep with (E0 ++ G).
  puts (proj31 (typing_regular (H x H1))).
  apply YTenvT_from_YTwf_env_2_left with x; auto.
  (* typing_app *)
  eauto using typing_app.
  (* typing_tabs *)
  apply typing_tabs with (L `union` dom (E0 ++ F ++ G) `union` dom E); auto.
  intros; destruct_notin.
  apply H0; auto.
  apply YTwf_sub; auto.
  apply M_yy.YTenvT_typ_var_indep with (E0 ++ G).
  puts (proj31 (typing_regular (H X H1))).
  apply YTenvT_from_YTwf_env_1_left with X; auto.
  (* typing_tapp *)
  eapply typing_tapp; eauto.
  apply sub_typ_indep with (E0 ++ G); auto.
  (* typing_sub *)
  eapply typing_sub; eauto.
  apply sub_typ_indep with (E0 ++ G); auto.
Qed.

(* ********************************************************************** *)
(** Strengthening *)

Lemma sub_strengthening : forall x U E E0 F S T,
  sub E (E0 ++ x ~ U ++ F) S T ->
  sub E (E0 ++ F) S T.
Proof.
  intros.
  apply sub_typ_indep with (E0 ++ x ~ U ++ F); auto.
Qed.

(************************************************************************ *)
(** Preservation by Type Narrowing (7) *)

Lemma typing_narrowing : forall Q E F F0 X P e T,
  sub F F0 P Q ->
  typing (E ++ X ~ Q ++ F) F0 e T ->
  typing (E ++ X ~ P ++ F) F0 e T.
Proof.
  introv PsubQ Typ. gen_eq (E ++ X ~ Q ++ F) as E'. gen E.
  induction Typ; introv EQ; subst; elim sub_regular with F F0 P Q; intros; auto.
  (* typing_var *)
  apply typing_var; auto.
  apply YTwf_env_narrow with Q; auto; try tauto.
  (* typing_abs *)
  apply typing_abs with (L `union` dom F); intros.
  destruct_notin.
  apply H0; auto.
  apply sub_typ_indep with F0; auto.
  (* typing_app *)
  apply typing_app with T1; auto.
  (* typing_tabs *)
  apply typing_tabs with L.
  intros.
  rewrite <- app_assoc.
  apply H0; auto.
  (* typing_tapp *)
  apply typing_tapp with T1; auto.
  apply sub_narrowing with Q; auto.
  (* typing_sub *)
  eapply typing_sub; eauto. apply (@sub_narrowing Q); auto.
Qed.

(************************************************************************ *)
(** Preservation by Term Substitution *)

Lemma typing_through_subst_ee : forall U E0 E F x T e u,
  typing E (E0 ++ x ~ U ++ F) e T ->
  typing E F u U ->
  typing E (E0 ++ F) (M_tt.M.Tfsubst e x u) T.
Proof.
  introv TypT TypU. gen_eq (E0 ++ x ~ U ++ F) as E'. gen E0.
  induction TypT; introv EQ; subst; gsimpl; simpl_alist in *.
  (* typing_var *)
  (* eq *)
  generalize (binds_mid_eq _ _ _ _ _ _ H0 (uniq_from_YTwf_env_2 H)); intro; subst U.
  generalize (@typing_weakening_typ nil); simpl; intro.
  apply H1; eauto using YTwf_env_strengthening.
  (* x <> x0 *)
  apply typing_var; eauto; analyze_binds H0.
  (* typing_abs *)
  apply typing_abs with (L `union` {{x}}); auto; intros; destruct_notin.
  generalize (@Tbfsubst_permutation_var_wfT); simpl; intro.
  rewrite H2; auto; simpl_alist; eauto.
    rewrite <- app_assoc; auto.
  elim typing_regular with E F u U; intros; auto.
  inversion H4.
  generalize (term_TTwfT H5); intros.
  inversion H7; auto.
  (* typing_app *)
  apply typing_app with T1; auto.
  (* typing_tabs *)
  apply typing_tabs with L; intros.
  generalize (@H0 X H1); intro.
  generalize noRepr_THbfsubst_permutation_var_1; simpl; intro.
  puts (H X H1); simpl_alist in *.
  elim typing_regular with
    ([(X, V)] ++ E) (E0 ++ [(x, U)] ++ F)
    (M_yt.M.Tbsubst e1 0%nat (typ_fvar X)) (M_yy.M.Tbsubst T1 0%nat (typ_fvar X));
    intros; auto.
  elim typing_regular with E F u U; intros; auto.
  inversion H8. generalize (term_TTwfT H9); intro.
  inversion H11.
  rewrite H3; auto.
  apply H2; auto.
  generalize (@typing_weakening_sub nil); simpl; intro.
  simpl_alist.
  apply H14; auto.
  eauto using YTwf_env_strengthening_1.
  (* typing_tapp *)
  apply typing_tapp with T1; auto.
  apply sub_strengthening with x U; auto.
  (* typing_sub *)
  eauto using typing_sub, sub_strengthening.
Qed.

(************************************************************************ *)
(** Preservation by Type Substitution *)

Lemma typing_through_subst_te : forall Q E F F0 Z e T P,
  typing (E ++ Z ~ Q ++ F) F0 e T ->
  sub F F0 P Q ->
  typing (map (fun U => M_yy.M.Tfsubst U Z P) E ++ F) (map (fun U => M_yy.M.Tfsubst U Z P) F0)
  (M_yt.M.Tfsubst e Z P) (M_yy.M.Tfsubst T Z P).
Proof.
  introv Typ PsubQ. gen_eq (E ++ Z ~ Q ++ F) as G. gen E.
  induction Typ;
    set (f := fun U => M_yy.M.Tfsubst U Z P);
      introv EQ; subst; gsimpl; simpl_alist in *.
  (* typing_var *)
  apply typing_var; auto.
    apply noRepr_YTwf_env_Yfsubst with Q; auto.
  replace (M_yy.M.Tfsubst T Z P) with (f T); auto.
  (* typing_abs *)
  apply typing_abs with L; intros; destruct_notin; simpl in *; simpl_env in *.
  replace (trm_fvar x) with (Iso_trm.To (Var Iso_trm.RR (inl x))); auto.
  rewrite noRepr_THbfsubst_permutation_var; simpl; auto.
  apply H0; auto;  simpl_env in *.
  apply sub_typ_indep with F0; auto.
  (* typing_app *)
  apply typing_app with (M_yy.M.Tfsubst T1 Z P); auto.
  (* typing_tabs *)
  apply typing_tabs with (L `union` {{Z}}); intros; destruct_notin.
  replace (typ_fvar X) with (Iso_typ.To (Var Iso_typ.RR (inl X))); auto.
  rewrite THbfsubst_permutation_var with (E:=F); auto.
  rewrite Ybfsubst_permutation_var with (E:=F); simpl; auto.
  simpl_alist.
  assert (X ~ M_yy.M.Tfsubst V Z P = map f (X ~  V)) as Hmap; [try unfold f; auto | idtac].
  unfold elt, Iso_typ.TT in *.  (* Coq bug? *)
  rewrite Hmap.
  rewrite <- app_assoc; rewrite <- map_app.
  apply H0; auto.
  (* typing_tapp *)
  rewrite <- Ybfsubst_permutation_core; auto.
  apply typing_tapp with (M_yy.M.Tfsubst T1 Z P); auto.
  apply sub_through_subst_tt with Q; auto.
  (* typing_sub *)
  apply typing_sub with (M_yy.M.Tfsubst S Z P); auto.
  apply sub_through_subst_tt with Q; auto.
Qed.

(* ********************************************************************** *)
(** * Preservation *)

(* ********************************************************************** *)
(** Inversions for Typing *)

Lemma typing_inv_abs : forall E F S1 e1 T,
  typing E F (trm_abs S1 e1) T ->
  forall U1 U2,
    sub E F T (typ_arrow U1 U2) ->
    (sub E F U1 S1
      /\ exists S2, exists L, forall x,
        x `notin` L -> typing E (x ~ S1 ++ F) (M_tt.M.Tbsubst e1 0 (trm_fvar x)) S2
      /\ sub E F S2 U2).
Proof.
  introv Typ. gen_eq (trm_abs S1 e1) as e. gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub.
  use (@sub_transitivity T).
Qed.

Lemma typing_inv_tabs : forall E F S1 e1 T,
  typing E F (trm_tabs S1 e1) T ->
  forall U1 U2,
    sub E F T (typ_all U1 U2) ->
    (sub E F U1 S1
      /\ exists S2, exists L, forall X, X `notin` L ->
        typing (X ~ U1 ++ E) F (M_yt.M.Tbsubst e1 0 (typ_fvar X)) (M_yy.M.Tbsubst S2 0 (typ_fvar X))
        /\ sub (X ~ U1 ++ E) F (M_yy.M.Tbsubst S2 0 (typ_fvar X)) (M_yy.M.Tbsubst U2 0 (typ_fvar X))).
Proof.
  intros E F S1 e1 T H. gen_eq (trm_tabs S1 e1) as e. gen S1 e1.
  induction H; intros S1 b EQ U1 U2 Sub; inversion EQ.
  inversions Sub; splits; auto.
  exists T1; exists (L `union` L0); intros Y Fr; destruct_notin; splits; auto.
  generalize (@typing_narrowing S1 nil); simpl; intro.
  apply H1; simpl_alist; auto.
  use (@sub_transitivity T).
Qed.

(* ********************************************************************** *)
(** Preservation Result *)

(** some tactics from Metatheory_Env  *)

Ltac env_fix_core :=
  let go := try env_fix_core in
  match goal with
  | H: context [(?x,?a)::?E] |- _ =>
     (   (progress (change ((x,a)::E) with (x ~ a ++ E) in H))
      || (progress (unsimpl (x ~ a ++ E) in H))   ); go
  | |- context [(?x,?a)::?E] =>
    (   (progress (change ((x,a)::E) with (x ~ a ++ E)))
      || (progress (unsimpl (x ~ a ++ E)))  ); go
  |  H: context [@nil ((var * ?A)%type)] |- _ =>
      progress (change (@nil ((var * A)%type)) with (@empty A) in H); go
  | |- context [@nil ((var * ?A)%type)] =>
     progress (change (@nil ((var * A)%type)) with (@empty A)); go
  end.

Ltac env_fix := try env_fix_core.

Tactic Notation "apply_empty" constr(lemma) :=
  let H := fresh in poses H (@lemma empty);
  simpl in H; eapply H; env_fix; clear H.

Tactic Notation "apply_empty" "*" constr(lemma) :=
  apply_empty lemma; auto*.

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'.
  induction Typ; introv Red; try solve [ inversion Red ].
  (* case: app *)
  inversions Red; try solve [ eapply typing_app; eauto ].
  destructi (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply sub_reflexivity; auto.
    destructs (typing_regular Typ2).
    eauto using Ywf_env_from_YTwf_env.
  pick fresh X for (L `union` (M_tt.M.Tfv e0)); destruct_notin.
  forward~ (P2 X) as K. destruct K.
  rewrite* (@M_tt.M.Tbfsubst_var_intro e0 e2 X NotInTac); auto.
    generalize (@typing_through_subst_ee V nil); simpl; intro; auto.
    apply H2; simpl_alist; auto.
      apply* (@typing_sub S2); auto.
      apply sub_typ_indep with F; auto.
  apply typing_sub with T1; auto.
  (* case: tapp *)
  inversions Red; try solve [ eapply typing_tapp; eauto ].
  destructs (sub_regular H).
  destructi (typing_inv_tabs Typ (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply sub_reflexivity; auto.
  pick fresh X for (L `union` dom E `union` dom F `union` (M_yy.M.Tfv T2) `union` M_yt.M.Tfv e0);
  destruct_notin.
  forward~ (P2 X) as K. destruct K.
  rewrite (@M_yt.M.Tbfsubst_var_intro e0 T X); simpl ; auto.
  rewrite (@M_yy.M.Tbfsubst_var_intro T2 T X); simpl; auto.
  unsimpl (map (fun U => M_yy.M.Tfsubst U X T) nil ++ E).
  assert (map (fun U => M_yy.M.Tfsubst U X T) F = F).
  apply M_yy.M.env_fv_no_occur.
  apply YTwf_env_fv_2 with E; auto.
  apply (proj31 (typing_regular Typ)).
  rewrite <- H7.
  apply (@typing_through_subst_te T1); simpl; simpl_env in *; auto.
  eauto using typing_sub.
  (* case sub *)
  eauto using typing_sub.
Qed.

(* ********************************************************************** *)
(** * Progress *)

(* ********************************************************************** *)
(** Canonical Forms *)

Tactic Notation "gen_eq" constr(c) "as" ident(x) ident(H) "at" integer(n) :=
  set (x := c) at n ; assert (H : x = c) by reflexivity; clearbody x.

Lemma canonical_form_abs : forall T U1 U2,
  value T ->
  typing nil nil T (typ_arrow U1 U2) ->
  exists V, exists e1, T = trm_abs V e1.
Proof.
  introv Val.
  gen_eq (@nil (var * typ)) as E H at 1.
  gen_eq (@nil (var * typ)) as F H0.
  introv Typ.
  gen_eq (typ_arrow U1 U2) as U.
  gen U1 U2.  gen E F. do 5 intro.
  induction Typ; intros; try solve [ inversion Val | inversion EQT | eauto ];
    try discriminate.
  destructi (typing_regular Typ). inversion H4.
  subst. inversion H1; subst.
  inversion H.
  apply IHTyp with S1 S2; auto.
Qed.

Lemma canonical_form_tabs : forall t U1 U2,
  value t ->
  typing nil nil t (typ_all U1 U2) ->
  exists V, exists e1, t = trm_tabs V e1.
Proof.
  introv Val.
  gen_eq (@nil (var * typ)) as E H at 1.
  gen_eq (@nil (var * typ)) as F H0.
  intro Typ.
  gen_eq (typ_all U1 U2) as U.
  gen U1 U2.
  induction Typ; introv EQT;
    try solve [ inversion Val | inversion EQT | eauto ].
  subst. inversion H1. inversion H. auto*.
Qed.

(* ********************************************************************** *)
(** Progress Result *)

Lemma progress_result : progress.
Proof.
  do 2 intro.
  gen_eq (@empty_env typ) as E H at 1.
  gen_eq (@empty_env typ) as F H0.
  introv Typ.
  poses Typ' Typ.
  induction Typ; subst.
  (* case: var *)
  inversion H2.
  (* case: abs *)
  left*.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
  destruct* IHTyp2 as [Val2 | [e2' Rede2']].
  destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]]. subst.
  exists* (M_tt.M.Tbsubst e3 0 e2).
  (* case: tabs *)
  left*.
  (* case: tapp *)
  right.
  destruct* IHTyp as [Val1 | [e1' Rede1']].
  destruct (canonical_form_tabs Val1 Typ) as [S [e3 EQ]].
  subst.
  exists* (M_yt.M.Tbsubst e3 0 T).
  (* case: sub *)
  auto*.
Qed.


From Hammer Require Import Hammer.

Require Import FSetInterface.
Require FSetAVL.
From compcert Require Import Coqlib.

Module Make(X: OrderedType).

Include FSetAVL.Make(X).

Module Raw := MSet.Raw.

Section MEM_BETWEEN.

Variable above_low_bound: elt -> bool.
Variable below_high_bound: elt -> bool.

Fixpoint raw_mem_between (m: Raw.tree) : bool :=
match m with
| Raw.Leaf => false
| Raw.Node _ l x r =>
if above_low_bound x
then if below_high_bound x
then true
else raw_mem_between l
else raw_mem_between r
end.

Definition mem_between (m: t) : bool := raw_mem_between m.(MSet.this).

Hypothesis above_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x1 x2 -> above_low_bound x1 = true -> above_low_bound x2 = true.
Hypothesis below_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x2 x1 -> below_high_bound x1 = true -> below_high_bound x2 = true.

Lemma raw_mem_between_1:
forall m,
raw_mem_between m = true ->
exists x, Raw.In x m /\ above_low_bound x = true /\ below_high_bound x = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.raw_mem_between_1".
induction m; simpl; intros.
- discriminate.
- destruct (above_low_bound t1) eqn: LB; [destruct (below_high_bound t1) eqn: HB | idtac].
+
exists t1; split; auto.  apply Raw.IsRoot. auto.
+
exploit IHm1; auto. intros [x' [A B]]. exists x'; split; auto. apply Raw.InLeft; auto.
+
exploit IHm2; auto. intros [x' [A B]]. exists x'; split; auto. apply Raw.InRight; auto.
Qed.

Lemma raw_mem_between_2:
forall x m,
Raw.bst m ->
Raw.In x m -> above_low_bound x = true -> below_high_bound x = true ->
raw_mem_between m = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.raw_mem_between_2".
induction 1; simpl; intros.
- inv H.
- rewrite Raw.In_node_iff in H1.
destruct (above_low_bound x0) eqn: LB; [destruct (below_high_bound x0) eqn: HB | idtac].
+
auto.
+
assert (X.eq x x0 \/ X.lt x0 x -> False).
{ intros. exploit below_monotone; eauto. congruence. }
intuition.
+ assert (X.eq x x0 \/ X.lt x x0 -> False).
{ intros. exploit above_monotone; eauto. congruence. }
intuition.
Qed.

Theorem mem_between_1:
forall s,
mem_between s = true ->
exists x, In x s /\ above_low_bound x = true /\ below_high_bound x = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.mem_between_1".
intros. apply raw_mem_between_1. auto.
Qed.

Theorem mem_between_2:
forall x s,
In x s -> above_low_bound x = true -> below_high_bound x = true ->
mem_between s = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.mem_between_2".
unfold mem_between; intros. apply raw_mem_between_2 with x; auto. apply MSet.is_ok.
Qed.

End MEM_BETWEEN.

Section ELEMENTS_BETWEEN.

Variable above_low_bound: elt -> bool.
Variable below_high_bound: elt -> bool.

Fixpoint raw_elements_between (m: Raw.tree) : Raw.tree :=
match m with
| Raw.Leaf => Raw.Leaf
| Raw.Node _ l x r =>
if above_low_bound x then
if below_high_bound x then
Raw.join (raw_elements_between l) x (raw_elements_between r)
else
raw_elements_between l
else
raw_elements_between r
end.

Remark In_raw_elements_between_1:
forall x m,
Raw.In x (raw_elements_between m) -> Raw.In x m.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_elements_between_1".
induction m; simpl; intros.
- inv H.
- rewrite Raw.In_node_iff.
destruct (above_low_bound t1) eqn:LB; [destruct (below_high_bound t1) eqn: RB | idtac]; simpl in H.
+ rewrite Raw.join_spec in H. intuition.
+ left; apply IHm1; auto.
+ right; right; apply IHm2; auto.
Qed.

Lemma raw_elements_between_ok:
forall m, Raw.bst m -> Raw.bst (raw_elements_between m).
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.raw_elements_between_ok".
induction 1; simpl.
- constructor.
- destruct (above_low_bound x) eqn:LB; [destruct (below_high_bound x) eqn: RB | idtac]; simpl.
+ apply Raw.join_ok; auto.
red; intros. apply l0. apply In_raw_elements_between_1; auto.
red; intros. apply g. apply In_raw_elements_between_1; auto.
+ auto.
+ auto.
Qed.

Definition elements_between (s: t) : t :=
@MSet.Mkt (raw_elements_between s.(MSet.this)) (raw_elements_between_ok s.(MSet.this) s.(MSet.is_ok)).

Hypothesis above_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x1 x2 -> above_low_bound x1 = true -> above_low_bound x2 = true.
Hypothesis below_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x2 x1 -> below_high_bound x1 = true -> below_high_bound x2 = true.

Remark In_raw_elements_between_2:
forall x m,
Raw.In x (raw_elements_between m) -> above_low_bound x = true /\ below_high_bound x = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_elements_between_2".
induction m; simpl; intros.
- inv H.
- destruct (above_low_bound t1) eqn:LB; [destruct (below_high_bound t1) eqn: RB | idtac]; simpl in H.
+ rewrite Raw.join_spec in H. intuition.
apply above_monotone with t1; auto.
apply below_monotone with t1; auto.
+ auto.
+ auto.
Qed.

Remark In_raw_elements_between_3:
forall x m,
Raw.bst m ->
Raw.In x m -> above_low_bound x = true -> below_high_bound x = true ->
Raw.In x (raw_elements_between m).
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_elements_between_3".
induction 1; simpl; intros.
- auto.
- rewrite Raw.In_node_iff in H1.
destruct (above_low_bound x0) eqn:LB; [destruct (below_high_bound x0) eqn: RB | idtac].
+ rewrite Raw.join_spec. intuition.
+ assert (X.eq x x0 \/ X.lt x0 x -> False).
{ intros. exploit below_monotone; eauto. congruence. }
intuition. elim H7. apply g. auto.
+ assert (X.eq x x0 \/ X.lt x x0 -> False).
{ intros. exploit above_monotone; eauto. congruence. }
intuition. elim H7. apply l0. auto.
Qed.

Theorem elements_between_iff:
forall x s,
In x (elements_between s) <-> In x s /\ above_low_bound x = true /\ below_high_bound x = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.elements_between_iff".
intros. unfold elements_between, In; simpl. split.
intros. split. apply In_raw_elements_between_1; auto. eapply In_raw_elements_between_2; eauto.
intros [A [B C]]. apply In_raw_elements_between_3; auto. apply MSet.is_ok.
Qed.

End ELEMENTS_BETWEEN.

Section FOR_ALL_BETWEEN.

Variable pred: elt -> bool.
Variable above_low_bound: elt -> bool.
Variable below_high_bound: elt -> bool.

Fixpoint raw_for_all_between (m: Raw.tree) : bool :=
match m with
| Raw.Leaf => true
| Raw.Node _ l x r =>
if above_low_bound x
then if below_high_bound x
then raw_for_all_between l && pred x && raw_for_all_between r
else raw_for_all_between l
else raw_for_all_between r
end.

Definition for_all_between (m: t) : bool := raw_for_all_between m.(MSet.this).

Hypothesis pred_compat:
forall x1 x2, X.eq x1 x2 -> pred x1 = pred x2.
Hypothesis above_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x1 x2 -> above_low_bound x1 = true -> above_low_bound x2 = true.
Hypothesis below_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x2 x1 -> below_high_bound x1 = true -> below_high_bound x2 = true.

Lemma raw_for_all_between_1:
forall x m,
Raw.bst m ->
raw_for_all_between m = true ->
Raw.In x m ->
above_low_bound x = true ->
below_high_bound x = true ->
pred x = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.raw_for_all_between_1".
induction 1; simpl; intros.
- inv H0.
- destruct (above_low_bound x0) eqn: LB; [destruct (below_high_bound x0) eqn: HB | idtac].
+
destruct (andb_prop _ _ H1) as [P C]. destruct (andb_prop _ _ P) as [A B]. clear H1 P.
inv H2.
* erewrite pred_compat; eauto.
* apply IHbst1; auto.
* apply IHbst2; auto.
+
inv H2.
* assert (below_high_bound x0 = true) by (apply below_monotone with x; auto).
congruence.
* apply IHbst1; auto.
* assert (below_high_bound x0 = true) by (apply below_monotone with x; auto).
congruence.
+
inv H2.
* assert (above_low_bound x0 = true) by (apply above_monotone with x; auto).
congruence.
* assert (above_low_bound x0 = true) by (apply above_monotone with x; auto).
congruence.
* apply IHbst2; auto.
Qed.

Lemma raw_for_all_between_2:
forall m,
Raw.bst m ->
(forall x, Raw.In x m -> above_low_bound x = true -> below_high_bound x = true -> pred x = true) ->
raw_for_all_between m = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.raw_for_all_between_2".
induction 1; intros; simpl.
- auto.
- destruct (above_low_bound x) eqn: LB; [destruct (below_high_bound x) eqn: HB | idtac].
+
rewrite IHbst1. rewrite (H1 x). rewrite IHbst2. auto.
intros. apply H1; auto. apply Raw.InRight; auto.
apply Raw.IsRoot. reflexivity. auto. auto.
intros. apply H1; auto. apply Raw.InLeft; auto.
+
apply IHbst1. intros. apply H1; auto. apply Raw.InLeft; auto.
+
apply IHbst2. intros. apply H1; auto. apply Raw.InRight; auto.
Qed.

Theorem for_all_between_iff:
forall s,
for_all_between s = true <-> (forall x, In x s -> above_low_bound x = true -> below_high_bound x = true -> pred x = true).
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.for_all_between_iff".
unfold for_all_between; intros; split; intros.
- eapply raw_for_all_between_1; eauto. apply MSet.is_ok.
- apply raw_for_all_between_2; auto. apply MSet.is_ok.
Qed.

End FOR_ALL_BETWEEN.

Section PARTITION_BETWEEN.

Variable above_low_bound: elt -> bool.
Variable below_high_bound: elt -> bool.

Fixpoint raw_partition_between (m: Raw.tree) : Raw.tree * Raw.tree :=
match m with
| Raw.Leaf => (Raw.Leaf, Raw.Leaf)
| Raw.Node _ l x r =>
if above_low_bound x then
if below_high_bound x then
(let (l1, l2) := raw_partition_between l in
let (r1, r2) := raw_partition_between r in
(Raw.join l1 x r1, Raw.concat l2 r2))
else
(let (l1, l2) := raw_partition_between l in
(l1, Raw.join l2 x r))
else
(let (r1, r2) := raw_partition_between r in
(r1, Raw.join l x r2))
end.

Remark In_raw_partition_between_1:
forall x m,
Raw.In x (fst (raw_partition_between m)) -> Raw.In x m.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_partition_between_1".
induction m; simpl; intros.
- inv H.
- destruct (raw_partition_between m1) as [l1 l2] eqn:LEQ; simpl in *.
destruct (raw_partition_between m2) as [r1 r2] eqn:REQ; simpl in *.
destruct (above_low_bound t1) eqn:LB; [destruct (below_high_bound t1) eqn: RB | idtac]; simpl in H.
+ rewrite Raw.join_spec in H. rewrite Raw.In_node_iff. intuition.
+ rewrite Raw.In_node_iff. intuition.
+ rewrite Raw.In_node_iff. intuition.
Qed.

Remark In_raw_partition_between_2:
forall x m,
Raw.In x (snd (raw_partition_between m)) -> Raw.In x m.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_partition_between_2".
induction m; simpl; intros.
- inv H.
- destruct (raw_partition_between m1) as [l1 l2] eqn:LEQ; simpl in *.
destruct (raw_partition_between m2) as [r1 r2] eqn:REQ; simpl in *.
destruct (above_low_bound t1) eqn:LB; [destruct (below_high_bound t1) eqn: RB | idtac]; simpl in H.
+ rewrite Raw.concat_spec in H. rewrite Raw.In_node_iff. intuition.
+ rewrite Raw.join_spec in H. rewrite Raw.In_node_iff. intuition.
+ rewrite Raw.join_spec in H. rewrite Raw.In_node_iff. intuition.
Qed.

Lemma raw_partition_between_ok:
forall m, Raw.bst m -> Raw.bst (fst (raw_partition_between m)) /\ Raw.bst (snd (raw_partition_between m)).
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.raw_partition_between_ok".
induction 1; simpl.
- split; constructor.
- destruct IHbst1 as [L1 L2]. destruct IHbst2 as [R1 R2].
destruct (raw_partition_between l) as [l1 l2] eqn:LEQ; simpl in *.
destruct (raw_partition_between r) as [r1 r2] eqn:REQ; simpl in *.
destruct (above_low_bound x) eqn:LB; [destruct (below_high_bound x) eqn: RB | idtac]; simpl.
+ split.
apply Raw.join_ok; auto.
red; intros. apply l0. apply In_raw_partition_between_1. rewrite LEQ; auto.
red; intros. apply g. apply In_raw_partition_between_1. rewrite REQ; auto.
apply Raw.concat_ok; auto.
intros. transitivity x.
apply l0. apply In_raw_partition_between_2. rewrite LEQ; auto.
apply g. apply In_raw_partition_between_2. rewrite REQ; auto.
+ split.
auto.
apply Raw.join_ok; auto.
red; intros. apply l0. apply In_raw_partition_between_2. rewrite LEQ; auto.
+ split.
auto.
apply Raw.join_ok; auto.
red; intros. apply g. apply In_raw_partition_between_2. rewrite REQ; auto.
Qed.

Hypothesis above_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x1 x2 -> above_low_bound x1 = true -> above_low_bound x2 = true.
Hypothesis below_monotone:
forall x1 x2, X.eq x1 x2 \/ X.lt x2 x1 -> below_high_bound x1 = true -> below_high_bound x2 = true.

Remark In_raw_partition_between_3:
forall x m,
Raw.In x (fst (raw_partition_between m)) -> above_low_bound x = true /\ below_high_bound x = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_partition_between_3".
induction m; simpl; intros.
- inv H.
- destruct (raw_partition_between m1) as [l1 l2] eqn:LEQ; simpl in *.
destruct (raw_partition_between m2) as [r1 r2] eqn:REQ; simpl in *.
destruct (above_low_bound t1) eqn:LB; [destruct (below_high_bound t1) eqn: RB | idtac]; simpl in H.
+ rewrite Raw.join_spec in H. intuition.
apply above_monotone with t1; auto.
apply below_monotone with t1; auto.
+ auto.
+ auto.
Qed.

Remark In_raw_partition_between_4:
forall x m,
Raw.bst m ->
Raw.In x (snd (raw_partition_between m)) -> above_low_bound x = false \/ below_high_bound x = false.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_partition_between_4".
induction 1; simpl; intros.
- inv H.
- destruct (raw_partition_between l) as [l1 l2] eqn:LEQ; simpl in *.
destruct (raw_partition_between r) as [r1 r2] eqn:REQ; simpl in *.
destruct (above_low_bound x0) eqn:LB; [destruct (below_high_bound x0) eqn: RB | idtac]; simpl in H.
+ simpl in H1. rewrite Raw.concat_spec in H1. intuition.
+ assert (forall y, X.eq y x0 \/ X.lt x0 y -> below_high_bound y = false).
{ intros. destruct (below_high_bound y) eqn:E; auto.
assert (below_high_bound x0 = true) by (apply below_monotone with y; auto).
congruence. }
simpl in H1. rewrite Raw.join_spec in H1. intuition.
+ assert (forall y, X.eq y x0 \/ X.lt y x0 -> above_low_bound y = false).
{ intros. destruct (above_low_bound y) eqn:E; auto.
assert (above_low_bound x0 = true) by (apply above_monotone with y; auto).
congruence. }
simpl in H1. rewrite Raw.join_spec in H1. intuition.
Qed.

Remark In_raw_partition_between_5:
forall x m,
Raw.bst m ->
Raw.In x m -> above_low_bound x = true -> below_high_bound x = true ->
Raw.In x (fst (raw_partition_between m)).
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_partition_between_5".
induction 1; simpl; intros.
- inv H.
- destruct (raw_partition_between l) as [l1 l2] eqn:LEQ; simpl in *.
destruct (raw_partition_between r) as [r1 r2] eqn:REQ; simpl in *.
destruct (above_low_bound x0) eqn:LB; [destruct (below_high_bound x0) eqn: RB | idtac]; simpl in H.
+ simpl. rewrite Raw.join_spec. inv H1.
auto.
right; left; apply IHbst1; auto.
right; right; apply IHbst2; auto.
+ simpl. inv H1.
assert (below_high_bound x0 = true) by (apply below_monotone with x; auto).
congruence.
auto.
assert (below_high_bound x0 = true) by (apply below_monotone with x; auto).
congruence.
+ simpl. inv H1.
assert (above_low_bound x0 = true) by (apply above_monotone with x; auto).
congruence.
assert (above_low_bound x0 = true) by (apply above_monotone with x; auto).
congruence.
eauto.
Qed.

Remark In_raw_partition_between_6:
forall x m,
Raw.bst m ->
Raw.In x m -> above_low_bound x = false \/ below_high_bound x = false ->
Raw.In x (snd (raw_partition_between m)).
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.In_raw_partition_between_6".
induction 1; simpl; intros.
- inv H.
- destruct (raw_partition_between l) as [l1 l2] eqn:LEQ; simpl in *.
destruct (raw_partition_between r) as [r1 r2] eqn:REQ; simpl in *.
destruct (above_low_bound x0) eqn:LB; [destruct (below_high_bound x0) eqn: RB | idtac]; simpl in H.
+ simpl. rewrite Raw.concat_spec. inv H1.
assert (below_high_bound x = true) by (apply below_monotone with x0; auto; left; symmetry; auto).
assert (above_low_bound x = true) by (apply above_monotone with x0; auto; left; symmetry; auto).
destruct H2; congruence.
left; apply IHbst1; auto.
right; apply IHbst2; auto.
+ simpl. rewrite Raw.join_spec. inv H1.
auto.
right; left; apply IHbst1; auto.
auto.
+ simpl. rewrite Raw.join_spec. inv H1.
auto.
auto.
right; right; apply IHbst2; auto.
Qed.

Definition partition_between (s: t) : t * t :=
let p := raw_partition_between s.(MSet.this) in
(@MSet.Mkt (fst p) (proj1 (raw_partition_between_ok s.(MSet.this) s.(MSet.is_ok))),
@MSet.Mkt (snd p) (proj2 (raw_partition_between_ok s.(MSet.this) s.(MSet.is_ok)))).

Theorem partition_between_iff_1:
forall x s,
In x (fst (partition_between s)) <->
In x s /\ above_low_bound x = true /\ below_high_bound x = true.
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.partition_between_iff_1".
intros. unfold partition_between, In; simpl. split.
intros. split. apply In_raw_partition_between_1; auto. eapply In_raw_partition_between_3; eauto.
intros [A [B C]]. apply In_raw_partition_between_5; auto. apply MSet.is_ok.
Qed.

Theorem partition_between_iff_2:
forall x s,
In x (snd (partition_between s)) <->
In x s /\ (above_low_bound x = false \/ below_high_bound x = false).
Proof. hammer_hook "FSetAVLplus" "FSetAVLplus.Make.partition_between_iff_2".
intros. unfold partition_between, In; simpl. split.
intros. split. apply In_raw_partition_between_2; auto. eapply In_raw_partition_between_4; eauto. apply MSet.is_ok.
intros [A B]. apply In_raw_partition_between_6; auto. apply MSet.is_ok.
Qed.

End PARTITION_BETWEEN.

End Make.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require real.Real.
Require real.RealInfix.
Require real.FromInt.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Parameter pow2: Z -> Z.

Axiom Power_0 : ((pow2 0%Z) = 1%Z).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%Z * (pow2 n))%Z).

Axiom Power_1 : ((pow2 1%Z) = 2%Z).

Axiom Power_sum : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%Z).

Axiom pow2pos : forall (i:Z), (0%Z <= i)%Z -> (0%Z < (pow2 i))%Z.

Axiom pow2_0 : ((pow2 0%Z) = 1%Z).

Axiom pow2_1 : ((pow2 1%Z) = 2%Z).

Axiom pow2_2 : ((pow2 2%Z) = 4%Z).

Axiom pow2_3 : ((pow2 3%Z) = 8%Z).

Axiom pow2_4 : ((pow2 4%Z) = 16%Z).

Axiom pow2_5 : ((pow2 5%Z) = 32%Z).

Axiom pow2_6 : ((pow2 6%Z) = 64%Z).

Axiom pow2_7 : ((pow2 7%Z) = 128%Z).

Axiom pow2_8 : ((pow2 8%Z) = 256%Z).

Axiom pow2_9 : ((pow2 9%Z) = 512%Z).

Axiom pow2_10 : ((pow2 10%Z) = 1024%Z).

Axiom pow2_11 : ((pow2 11%Z) = 2048%Z).

Axiom pow2_12 : ((pow2 12%Z) = 4096%Z).

Axiom pow2_13 : ((pow2 13%Z) = 8192%Z).

Axiom pow2_14 : ((pow2 14%Z) = 16384%Z).

Axiom pow2_15 : ((pow2 15%Z) = 32768%Z).

Axiom pow2_16 : ((pow2 16%Z) = 65536%Z).

Axiom pow2_17 : ((pow2 17%Z) = 131072%Z).

Axiom pow2_18 : ((pow2 18%Z) = 262144%Z).

Axiom pow2_19 : ((pow2 19%Z) = 524288%Z).

Axiom pow2_20 : ((pow2 20%Z) = 1048576%Z).

Axiom pow2_21 : ((pow2 21%Z) = 2097152%Z).

Axiom pow2_22 : ((pow2 22%Z) = 4194304%Z).

Axiom pow2_23 : ((pow2 23%Z) = 8388608%Z).

Axiom pow2_24 : ((pow2 24%Z) = 16777216%Z).

Axiom pow2_25 : ((pow2 25%Z) = 33554432%Z).

Axiom pow2_26 : ((pow2 26%Z) = 67108864%Z).

Axiom pow2_27 : ((pow2 27%Z) = 134217728%Z).

Axiom pow2_28 : ((pow2 28%Z) = 268435456%Z).

Axiom pow2_29 : ((pow2 29%Z) = 536870912%Z).

Axiom pow2_30 : ((pow2 30%Z) = 1073741824%Z).

Axiom pow2_31 : ((pow2 31%Z) = 2147483648%Z).

Axiom pow2_32 : ((pow2 32%Z) = 4294967296%Z).

Axiom pow2_33 : ((pow2 33%Z) = 8589934592%Z).

Axiom pow2_34 : ((pow2 34%Z) = 17179869184%Z).

Axiom pow2_35 : ((pow2 35%Z) = 34359738368%Z).

Axiom pow2_36 : ((pow2 36%Z) = 68719476736%Z).

Axiom pow2_37 : ((pow2 37%Z) = 137438953472%Z).

Axiom pow2_38 : ((pow2 38%Z) = 274877906944%Z).

Axiom pow2_39 : ((pow2 39%Z) = 549755813888%Z).

Axiom pow2_40 : ((pow2 40%Z) = 1099511627776%Z).

Axiom pow2_41 : ((pow2 41%Z) = 2199023255552%Z).

Axiom pow2_42 : ((pow2 42%Z) = 4398046511104%Z).

Axiom pow2_43 : ((pow2 43%Z) = 8796093022208%Z).

Axiom pow2_44 : ((pow2 44%Z) = 17592186044416%Z).

Axiom pow2_45 : ((pow2 45%Z) = 35184372088832%Z).

Axiom pow2_46 : ((pow2 46%Z) = 70368744177664%Z).

Axiom pow2_47 : ((pow2 47%Z) = 140737488355328%Z).

Axiom pow2_48 : ((pow2 48%Z) = 281474976710656%Z).

Axiom pow2_49 : ((pow2 49%Z) = 562949953421312%Z).

Axiom pow2_50 : ((pow2 50%Z) = 1125899906842624%Z).

Axiom pow2_51 : ((pow2 51%Z) = 2251799813685248%Z).

Axiom pow2_52 : ((pow2 52%Z) = 4503599627370496%Z).

Axiom pow2_53 : ((pow2 53%Z) = 9007199254740992%Z).

Axiom pow2_54 : ((pow2 54%Z) = 18014398509481984%Z).

Axiom pow2_55 : ((pow2 55%Z) = 36028797018963968%Z).

Axiom pow2_56 : ((pow2 56%Z) = 72057594037927936%Z).

Axiom pow2_57 : ((pow2 57%Z) = 144115188075855872%Z).

Axiom pow2_58 : ((pow2 58%Z) = 288230376151711744%Z).

Axiom pow2_59 : ((pow2 59%Z) = 576460752303423488%Z).

Axiom pow2_60 : ((pow2 60%Z) = 1152921504606846976%Z).

Axiom pow2_61 : ((pow2 61%Z) = 2305843009213693952%Z).

Axiom pow2_62 : ((pow2 62%Z) = 4611686018427387904%Z).

Axiom pow2_63 : ((pow2 63%Z) = 9223372036854775808%Z).

Parameter pow21: Z -> R.

Axiom Power_01 : ((pow21 0%Z) = 1%R).

Axiom Power_s1 : forall (n:Z), (0%Z <= n)%Z ->
  ((pow21 (n + 1%Z)%Z) = (2%R * (pow21 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow21 (n - 1%Z)%Z) = ((05 / 10)%R * (pow21 n))%R).

Axiom Power_s_all : forall (n:Z),
  ((pow21 (n + 1%Z)%Z) = (2%R * (pow21 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow21 (n - 1%Z)%Z) = ((05 / 10)%R * (pow21 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_11 : ((pow21 1%Z) = 2%R).

Axiom Power_neg1 : ((pow21 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow21 n) = 0%R).

Axiom Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow21 (-n)%Z) = (Rdiv 1%R (pow21 n))%R).

Axiom Power_non_null : forall (n:Z), ~ ((pow21 n) = 0%R).

Axiom Power_neg : forall (n:Z), ((pow21 (-n)%Z) = (Rdiv 1%R (pow21 n))%R).

Axiom Power_sum_aux : forall (n:Z) (m:Z), (0%Z <= m)%Z ->
  ((pow21 (n + m)%Z) = ((pow21 n) * (pow21 m))%R).

Axiom Power_sum1 : forall (n:Z) (m:Z),
  ((pow21 (n + m)%Z) = ((pow21 n) * (pow21 m))%R).

Axiom Pow2_int_real : forall (x:Z), (0%Z <= x)%Z ->
  ((pow21 x) = (IZR (pow2 x))).

Axiom size_positive : (1%Z < 32%Z)%Z.

Parameter bv : Type.

Parameter nth: bv -> Z -> bool.

Parameter bvzero: bv.

Axiom Nth_zero : forall (n:Z), ((0%Z <= n)%Z /\ (n < 32%Z)%Z) -> ((nth bvzero
  n) = false).

Parameter bvone: bv.

Axiom Nth_one : forall (n:Z), ((0%Z <= n)%Z /\ (n < 32%Z)%Z) -> ((nth bvone
  n) = true).

(* Why3 assumption *)
Definition eq(v1:bv) (v2:bv): Prop := forall (n:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((nth v1 n) = (nth v2 n)).

Axiom extensionality : forall (v1:bv) (v2:bv), (eq v1 v2) -> (v1 = v2).

Parameter bw_and: bv -> bv -> bv.

Axiom Nth_bw_and : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((nth (bw_and v1 v2) n) = (andb (nth v1 n) (nth v2 n))).

Parameter bw_or: bv -> bv -> bv.

Axiom Nth_bw_or : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((nth (bw_or v1 v2) n) = (orb (nth v1 n) (nth v2 n))).

Parameter bw_xor: bv -> bv -> bv.

Axiom Nth_bw_xor : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((nth (bw_xor v1 v2) n) = (xorb (nth v1 n) (nth v2 n))).

Axiom Nth_bw_xor_v1true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < 32%Z)%Z) /\ ((nth v1 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v2 n))).

Axiom Nth_bw_xor_v1false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < 32%Z)%Z) /\ ((nth v1 n) = false)) -> ((nth (bw_xor v1 v2) n) = (nth v2
  n)).

Axiom Nth_bw_xor_v2true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < 32%Z)%Z) /\ ((nth v2 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v1 n))).

Axiom Nth_bw_xor_v2false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < 32%Z)%Z) /\ ((nth v2 n) = false)) -> ((nth (bw_xor v1 v2) n) = (nth v1
  n)).

Parameter bw_not: bv -> bv.

Axiom Nth_bw_not : forall (v:bv) (n:Z), ((0%Z <= n)%Z /\ (n < 32%Z)%Z) ->
  ((nth (bw_not v) n) = (negb (nth v n))).

Parameter lsr: bv -> Z -> bv.

Axiom lsr_nth_low : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n < 32%Z)%Z) /\ (((0%Z <= s)%Z /\ (s < 32%Z)%Z) /\
  ((n + s)%Z < 32%Z)%Z)) -> ((nth (lsr b s) n) = (nth b (n + s)%Z)).

Axiom lsr_nth_high : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n < 32%Z)%Z) /\ (((0%Z <= s)%Z /\ (s < 32%Z)%Z) /\
  (32%Z <= (n + s)%Z)%Z)) -> ((nth (lsr b s) n) = false).

Parameter asr: bv -> Z -> bv.

Axiom asr_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((0%Z <= s)%Z -> (((n + s)%Z < 32%Z)%Z -> ((nth (asr b s)
  n) = (nth b (n + s)%Z)))).

Axiom asr_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((0%Z <= s)%Z -> ((32%Z <= (n + s)%Z)%Z -> ((nth (asr b s)
  n) = (nth b (32%Z - 1%Z)%Z)))).

Parameter lsl: bv -> Z -> bv.

Axiom lsl_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((0%Z <= s)%Z -> ((0%Z <= (n - s)%Z)%Z -> ((nth (lsl b s)
  n) = (nth b (n - s)%Z)))).

Axiom lsl_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 32%Z)%Z) -> ((0%Z <= s)%Z -> (((n - s)%Z < 0%Z)%Z -> ((nth (lsl b s)
  n) = false))).

Parameter to_nat_sub: bv -> Z -> Z -> Z.

Axiom to_nat_sub_zero : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j < 32%Z)%Z) -> (((nth b j) = false) -> ((to_nat_sub b j
  i) = (to_nat_sub b (j - 1%Z)%Z i))).

Axiom to_nat_sub_one : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j < 32%Z)%Z) -> (((nth b j) = true) -> ((to_nat_sub b j
  i) = ((pow2 (j - i)%Z) + (to_nat_sub b (j - 1%Z)%Z i))%Z)).

Axiom to_nat_sub_high : forall (b:bv) (j:Z) (i:Z), (j < i)%Z ->
  ((to_nat_sub b j i) = 0%Z).

Axiom to_nat_of_zero2 : forall (b:bv) (i:Z) (j:Z), (((j < 32%Z)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i < k)%Z) -> ((nth b k) = false)) -> ((to_nat_sub b j 0%Z) = (to_nat_sub b
  i 0%Z))).

Axiom to_nat_of_zero : forall (b:bv) (i:Z) (j:Z), ((j < 32%Z)%Z /\
  (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\ (i <= k)%Z) -> ((nth b
  k) = false)) -> ((to_nat_sub b j i) = 0%Z)).

Axiom to_nat_of_one : forall (b:bv) (i:Z) (j:Z), (((j < 32%Z)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <= k)%Z) -> ((nth b k) = true)) -> ((to_nat_sub b j
  i) = ((pow2 ((j - i)%Z + 1%Z)%Z) - 1%Z)%Z)).

Axiom to_nat_sub_footprint : forall (b1:bv) (b2:bv) (j:Z) (i:Z),
  ((j < 32%Z)%Z /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((i <= k)%Z /\
  (k <= j)%Z) -> ((nth b1 k) = (nth b2 k))) -> ((to_nat_sub b1 j
  i) = (to_nat_sub b2 j i))).

Parameter from_int: Z -> bv.

Axiom nth_from_int_high_even : forall (n:Z) (i:Z), (((i < 32%Z)%Z /\
  (0%Z <= i)%Z) /\ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n
  (pow2 i)) 2%Z) = 0%Z)) -> ((nth (from_int n) i) = false).

Axiom nth_from_int_high_odd : forall (n:Z) (i:Z), (((i < 32%Z)%Z /\
  (0%Z <= i)%Z) /\
  ~ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth (from_int n) i) = true).

Axiom nth_from_int_low_even : forall (n:Z), ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z) -> ((nth (from_int n) 0%Z) = false).

Axiom nth_from_int_low_odd : forall (n:Z), (~ ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z)) -> ((nth (from_int n) 0%Z) = true).

Axiom nth_from_int_0 : forall (i:Z), ((i < 32%Z)%Z /\ (0%Z <= i)%Z) ->
  ((nth (from_int 0%Z) i) = false).

Parameter from_int2c: Z -> bv.

Axiom nth_sign_positive : forall (n:Z), (0%Z <= n)%Z -> ((nth (from_int2c n)
  (32%Z - 1%Z)%Z) = false).

Axiom nth_sign_negative : forall (n:Z), (n < 0%Z)%Z -> ((nth (from_int2c n)
  (32%Z - 1%Z)%Z) = true).

Axiom nth_from_int2c_high_even : forall (n:Z) (i:Z),
  (((i < (32%Z - 1%Z)%Z)%Z /\ (0%Z <= i)%Z) /\
  ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth (from_int2c n) i) = false).

Axiom nth_from_int2c_high_odd : forall (n:Z) (i:Z),
  (((i < (32%Z - 1%Z)%Z)%Z /\ (0%Z <= i)%Z) /\
  ~ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth (from_int2c n) i) = true).

Axiom nth_from_int2c_low_even : forall (n:Z), ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z) -> ((nth (from_int2c n) 0%Z) = false).

Axiom nth_from_int2c_low_odd : forall (n:Z),
  (~ ((int.EuclideanDivision.mod1 n 2%Z) = 0%Z)) -> ((nth (from_int2c n)
  0%Z) = true).

Axiom nth_from_int2c_0 : forall (i:Z), ((i < 32%Z)%Z /\ (0%Z <= i)%Z) ->
  ((nth (from_int2c 0%Z) i) = false).

Axiom nth_from_int2c_plus_pow2 : forall (x:Z) (k:Z) (i:Z), ((0%Z <= k)%Z /\
  (k < i)%Z) -> ((nth (from_int2c (x + (pow2 i))%Z) k) = (nth (from_int2c x)
  k)).

Axiom size_positive1 : (1%Z < 64%Z)%Z.

Parameter bv1 : Type.

Parameter nth1: bv1 -> Z -> bool.

Parameter bvzero1: bv1.

Axiom Nth_zero1 : forall (n:Z), ((0%Z <= n)%Z /\ (n < 64%Z)%Z) ->
  ((nth1 bvzero1 n) = false).

Parameter bvone1: bv1.

Axiom Nth_one1 : forall (n:Z), ((0%Z <= n)%Z /\ (n < 64%Z)%Z) ->
  ((nth1 bvone1 n) = true).

(* Why3 assumption *)
Definition eq1(v1:bv1) (v2:bv1): Prop := forall (n:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((nth1 v1 n) = (nth1 v2 n)).

Axiom extensionality1 : forall (v1:bv1) (v2:bv1), (eq1 v1 v2) -> (v1 = v2).

Parameter bw_and1: bv1 -> bv1 -> bv1.

Axiom Nth_bw_and1 : forall (v1:bv1) (v2:bv1) (n:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((nth1 (bw_and1 v1 v2) n) = (andb (nth1 v1 n) (nth1 v2
  n))).

Parameter bw_or1: bv1 -> bv1 -> bv1.

Axiom Nth_bw_or1 : forall (v1:bv1) (v2:bv1) (n:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((nth1 (bw_or1 v1 v2) n) = (orb (nth1 v1 n) (nth1 v2 n))).

Parameter bw_xor1: bv1 -> bv1 -> bv1.

Axiom Nth_bw_xor1 : forall (v1:bv1) (v2:bv1) (n:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((nth1 (bw_xor1 v1 v2) n) = (xorb (nth1 v1 n) (nth1 v2
  n))).

Axiom Nth_bw_xor_v1true1 : forall (v1:bv1) (v2:bv1) (n:Z), (((0%Z <= n)%Z /\
  (n < 64%Z)%Z) /\ ((nth1 v1 n) = true)) -> ((nth1 (bw_xor1 v1 v2)
  n) = (negb (nth1 v2 n))).

Axiom Nth_bw_xor_v1false1 : forall (v1:bv1) (v2:bv1) (n:Z), (((0%Z <= n)%Z /\
  (n < 64%Z)%Z) /\ ((nth1 v1 n) = false)) -> ((nth1 (bw_xor1 v1 v2)
  n) = (nth1 v2 n)).

Axiom Nth_bw_xor_v2true1 : forall (v1:bv1) (v2:bv1) (n:Z), (((0%Z <= n)%Z /\
  (n < 64%Z)%Z) /\ ((nth1 v2 n) = true)) -> ((nth1 (bw_xor1 v1 v2)
  n) = (negb (nth1 v1 n))).

Axiom Nth_bw_xor_v2false1 : forall (v1:bv1) (v2:bv1) (n:Z), (((0%Z <= n)%Z /\
  (n < 64%Z)%Z) /\ ((nth1 v2 n) = false)) -> ((nth1 (bw_xor1 v1 v2)
  n) = (nth1 v1 n)).

Parameter bw_not1: bv1 -> bv1.

Axiom Nth_bw_not1 : forall (v:bv1) (n:Z), ((0%Z <= n)%Z /\ (n < 64%Z)%Z) ->
  ((nth1 (bw_not1 v) n) = (negb (nth1 v n))).

Parameter lsr1: bv1 -> Z -> bv1.

Axiom lsr_nth_low1 : forall (b:bv1) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n < 64%Z)%Z) /\ (((0%Z <= s)%Z /\ (s < 64%Z)%Z) /\
  ((n + s)%Z < 64%Z)%Z)) -> ((nth1 (lsr1 b s) n) = (nth1 b (n + s)%Z)).

Axiom lsr_nth_high1 : forall (b:bv1) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n < 64%Z)%Z) /\ (((0%Z <= s)%Z /\ (s < 64%Z)%Z) /\
  (64%Z <= (n + s)%Z)%Z)) -> ((nth1 (lsr1 b s) n) = false).

Parameter asr1: bv1 -> Z -> bv1.

Axiom asr_nth_low1 : forall (b:bv1) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((0%Z <= s)%Z -> (((n + s)%Z < 64%Z)%Z -> ((nth1 (asr1 b
  s) n) = (nth1 b (n + s)%Z)))).

Axiom asr_nth_high1 : forall (b:bv1) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((0%Z <= s)%Z -> ((64%Z <= (n + s)%Z)%Z -> ((nth1 (asr1 b
  s) n) = (nth1 b (64%Z - 1%Z)%Z)))).

Parameter lsl1: bv1 -> Z -> bv1.

Axiom lsl_nth_high1 : forall (b:bv1) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((0%Z <= s)%Z -> ((0%Z <= (n - s)%Z)%Z -> ((nth1 (lsl1 b
  s) n) = (nth1 b (n - s)%Z)))).

Axiom lsl_nth_low1 : forall (b:bv1) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < 64%Z)%Z) -> ((0%Z <= s)%Z -> (((n - s)%Z < 0%Z)%Z -> ((nth1 (lsl1 b s)
  n) = false))).

Parameter to_nat_sub1: bv1 -> Z -> Z -> Z.

Axiom to_nat_sub_zero1 : forall (b:bv1) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j < 64%Z)%Z) -> (((nth1 b j) = false) -> ((to_nat_sub1 b j
  i) = (to_nat_sub1 b (j - 1%Z)%Z i))).

Axiom to_nat_sub_one1 : forall (b:bv1) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j < 64%Z)%Z) -> (((nth1 b j) = true) -> ((to_nat_sub1 b j
  i) = ((pow2 (j - i)%Z) + (to_nat_sub1 b (j - 1%Z)%Z i))%Z)).

Axiom to_nat_sub_high1 : forall (b:bv1) (j:Z) (i:Z), (j < i)%Z ->
  ((to_nat_sub1 b j i) = 0%Z).

Axiom to_nat_of_zero21 : forall (b:bv1) (i:Z) (j:Z), (((j < 64%Z)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i < k)%Z) -> ((nth1 b k) = false)) -> ((to_nat_sub1 b j
  0%Z) = (to_nat_sub1 b i 0%Z))).

Axiom to_nat_of_zero1 : forall (b:bv1) (i:Z) (j:Z), ((j < 64%Z)%Z /\
  (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\ (i <= k)%Z) -> ((nth1 b
  k) = false)) -> ((to_nat_sub1 b j i) = 0%Z)).

Axiom to_nat_of_one1 : forall (b:bv1) (i:Z) (j:Z), (((j < 64%Z)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <= k)%Z) -> ((nth1 b k) = true)) -> ((to_nat_sub1 b j
  i) = ((pow2 ((j - i)%Z + 1%Z)%Z) - 1%Z)%Z)).

Axiom to_nat_sub_footprint1 : forall (b1:bv1) (b2:bv1) (j:Z) (i:Z),
  ((j < 64%Z)%Z /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((i <= k)%Z /\
  (k <= j)%Z) -> ((nth1 b1 k) = (nth1 b2 k))) -> ((to_nat_sub1 b1 j
  i) = (to_nat_sub1 b2 j i))).

Parameter from_int1: Z -> bv1.

Axiom nth_from_int_high_even1 : forall (n:Z) (i:Z), (((i < 64%Z)%Z /\
  (0%Z <= i)%Z) /\ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n
  (pow2 i)) 2%Z) = 0%Z)) -> ((nth1 (from_int1 n) i) = false).

Axiom nth_from_int_high_odd1 : forall (n:Z) (i:Z), (((i < 64%Z)%Z /\
  (0%Z <= i)%Z) /\
  ~ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth1 (from_int1 n) i) = true).

Axiom nth_from_int_low_even1 : forall (n:Z), ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z) -> ((nth1 (from_int1 n) 0%Z) = false).

Axiom nth_from_int_low_odd1 : forall (n:Z), (~ ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z)) -> ((nth1 (from_int1 n) 0%Z) = true).

Axiom nth_from_int_01 : forall (i:Z), ((i < 64%Z)%Z /\ (0%Z <= i)%Z) ->
  ((nth1 (from_int1 0%Z) i) = false).

Parameter from_int2c1: Z -> bv1.

Axiom nth_sign_positive1 : forall (n:Z), (0%Z <= n)%Z ->
  ((nth1 (from_int2c1 n) (64%Z - 1%Z)%Z) = false).

Axiom nth_sign_negative1 : forall (n:Z), (n < 0%Z)%Z ->
  ((nth1 (from_int2c1 n) (64%Z - 1%Z)%Z) = true).

Axiom nth_from_int2c_high_even1 : forall (n:Z) (i:Z),
  (((i < (64%Z - 1%Z)%Z)%Z /\ (0%Z <= i)%Z) /\
  ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth1 (from_int2c1 n) i) = false).

Axiom nth_from_int2c_high_odd1 : forall (n:Z) (i:Z),
  (((i < (64%Z - 1%Z)%Z)%Z /\ (0%Z <= i)%Z) /\
  ~ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth1 (from_int2c1 n) i) = true).

Axiom nth_from_int2c_low_even1 : forall (n:Z), ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z) -> ((nth1 (from_int2c1 n) 0%Z) = false).

Axiom nth_from_int2c_low_odd1 : forall (n:Z),
  (~ ((int.EuclideanDivision.mod1 n 2%Z) = 0%Z)) -> ((nth1 (from_int2c1 n)
  0%Z) = true).

Axiom nth_from_int2c_01 : forall (i:Z), ((i < 64%Z)%Z /\ (0%Z <= i)%Z) ->
  ((nth1 (from_int2c1 0%Z) i) = false).

Axiom nth_from_int2c_plus_pow21 : forall (x:Z) (k:Z) (i:Z), ((0%Z <= k)%Z /\
  (k < i)%Z) -> ((nth1 (from_int2c1 (x + (pow2 i))%Z)
  k) = (nth1 (from_int2c1 x) k)).

Parameter concat: bv -> bv -> bv1.

Axiom concat_low : forall (b1:bv) (b2:bv), forall (i:Z), ((0%Z <= i)%Z /\
  (i < 32%Z)%Z) -> ((nth1 (concat b1 b2) i) = (nth b2 i)).

Axiom concat_high : forall (b1:bv) (b2:bv), forall (i:Z), ((32%Z <= i)%Z /\
  (i < 64%Z)%Z) -> ((nth1 (concat b1 b2) i) = (nth b1 (i - 32%Z)%Z)).

Parameter double_of_bv64: bv1 -> R.

Parameter sign_value: bool -> R.

Axiom sign_value_false : ((sign_value false) = 1%R).

Axiom sign_value_true : ((sign_value true) = (-1%R)%R).

Axiom zero : forall (b:bv1), (((to_nat_sub1 b 62%Z 52%Z) = 0%Z) /\
  ((to_nat_sub1 b 51%Z 0%Z) = 0%Z)) -> ((double_of_bv64 b) = 0%R).

Axiom sign_of_double_positive : forall (b:bv1), ((nth1 b 63%Z) = false) ->
  (0%R <= (double_of_bv64 b))%R.

Axiom sign_of_double_negative : forall (b:bv1), ((nth1 b 63%Z) = true) ->
  ((double_of_bv64 b) <= 0%R)%R.

Axiom double_of_bv64_value : forall (b:bv1), ((0%Z < (to_nat_sub1 b 62%Z
  52%Z))%Z /\ ((to_nat_sub1 b 62%Z 52%Z) < 2047%Z)%Z) ->
  ((double_of_bv64 b) = (((sign_value (nth1 b 63%Z)) * (pow21 ((to_nat_sub1 b
  62%Z 52%Z) - 1023%Z)%Z))%R * (1%R + ((IZR (to_nat_sub1 b 51%Z
  0%Z)) * (pow21 (-52%Z)%Z))%R)%R)%R).

Axiom jp0_30 : forall (i:Z), ((0%Z <= i)%Z /\ (i < 30%Z)%Z) ->
  ((nth (from_int 2147483648%Z) i) = false).

Axiom nth_const1 : forall (i:Z), ((0%Z <= i)%Z /\ (i <= 30%Z)%Z) ->
  ((nth1 (concat (from_int 1127219200%Z) (from_int 2147483648%Z))
  i) = false).

Axiom nth_const2 : ((nth1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 31%Z) = true).

Axiom nth_const3 : forall (i:Z), ((32%Z <= i)%Z /\ (i <= 51%Z)%Z) ->
  ((nth1 (concat (from_int 1127219200%Z) (from_int 2147483648%Z))
  i) = false).

Axiom nth_const4 : forall (i:Z), ((52%Z <= i)%Z /\ (i <= 53%Z)%Z) ->
  ((nth1 (concat (from_int 1127219200%Z) (from_int 2147483648%Z)) i) = true).

Axiom nth_const5 : forall (i:Z), ((54%Z <= i)%Z /\ (i <= 55%Z)%Z) ->
  ((nth1 (concat (from_int 1127219200%Z) (from_int 2147483648%Z))
  i) = false).

Axiom nth_const6 : forall (i:Z), ((56%Z <= i)%Z /\ (i <= 57%Z)%Z) ->
  ((nth1 (concat (from_int 1127219200%Z) (from_int 2147483648%Z)) i) = true).

Axiom nth_const7 : forall (i:Z), ((58%Z <= i)%Z /\ (i <= 61%Z)%Z) ->
  ((nth1 (concat (from_int 1127219200%Z) (from_int 2147483648%Z))
  i) = false).

Axiom nth_const8 : ((nth1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 62%Z) = true).

Axiom nth_const9 : ((nth1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 63%Z) = false).

Axiom sign_const : ((nth1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 63%Z) = false).

Axiom exp_const : ((to_nat_sub1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 62%Z 52%Z) = 1075%Z).

Axiom to_nat_mantissa_1 : ((to_nat_sub1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 30%Z 0%Z) = 0%Z).

Axiom mantissa_const_nth2 : forall (i:Z), ((32%Z <= i)%Z /\ (i <= 51%Z)%Z) ->
  ((nth1 (concat (from_int 1127219200%Z) (from_int 2147483648%Z))
  i) = false).

Axiom mantissa_const_to_nat51 : ((to_nat_sub1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 51%Z
  0%Z) = (to_nat_sub1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 31%Z 0%Z)).

Axiom mantissa_const : ((to_nat_sub1 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z)) 51%Z 0%Z) = (pow2 31%Z)).

Axiom real1075m1023 : ((IZR (1075%Z - 1023%Z)%Z) = 52%R).

Axiom real1075m1023_2 : ((1075%R - 1023%R)%R = 52%R).

Axiom real52_a_m52 : ((((pow21 (1075%Z - 1023%Z)%Z) * (pow21 31%Z))%R * (pow21 (-52%Z)%Z))%R = (pow21 31%Z)).

Axiom const_value0 : ((double_of_bv64 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z))) = ((1%R * (pow21 (1075%Z - 1023%Z)%Z))%R * (1%R + ((pow21 31%Z) * (pow21 (-52%Z)%Z))%R)%R)%R).

Axiom const_value : ((double_of_bv64 (concat (from_int 1127219200%Z)
  (from_int 2147483648%Z))) = ((pow21 52%Z) + (pow21 31%Z))%R).

(* Why3 assumption *)
Definition jpxor(i:Z): bv := (bw_xor (from_int 2147483648%Z) (from_int2c i)).

(* Why3 assumption *)
Definition var(i:Z): bv1 := (concat (from_int 1127219200%Z) (jpxor i)).

(* Why3 assumption *)
Definition var_as_double(x:Z): R := (double_of_bv64 (var x)).

(* Why3 assumption *)
Definition is_int32(x:Z): Prop := ((-(pow2 31%Z))%Z <= x)%Z /\
  (x < (pow2 31%Z))%Z.

Axiom nth_0_30 : forall (x:Z), forall (i:Z), ((is_int32 x) /\
  ((0%Z <= i)%Z /\ (i <= 30%Z)%Z)) -> ((nth (bw_xor (from_int 2147483648%Z)
  (from_int2c x)) i) = (nth (from_int2c x) i)).

Axiom nth_jpxor_0_30 : forall (x:Z), forall (i:Z), ((is_int32 x) /\
  ((0%Z <= i)%Z /\ (i <= 30%Z)%Z)) -> ((nth (jpxor x)
  i) = (nth (from_int2c x) i)).

Axiom nth_var31 : forall (x:Z), ((nth (jpxor x)
  31%Z) = (negb (nth (from_int2c x) 31%Z))).

Axiom to_nat_sub_0_30 : forall (x:Z), (is_int32 x) ->
  ((to_nat_sub (bw_xor (from_int 2147483648%Z) (from_int2c x)) 30%Z
  0%Z) = (to_nat_sub (from_int2c x) 30%Z 0%Z)).

Axiom jpxorx_pos : forall (x:Z), (0%Z <= x)%Z ->
  ((nth (bw_xor (from_int 2147483648%Z) (from_int2c x)) 31%Z) = true).

Open Scope Z_scope.
Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 3.

(* Why3 goal *)
Theorem from_int2c_to_nat_sub_pos : forall (i:Z), ((0%Z <= i)%Z /\
  (i <= 31%Z)%Z) -> forall (x:Z), ((0%Z <= x)%Z /\ (x < (pow2 i))%Z) ->
  ((to_nat_sub (from_int2c x) (i - 1%Z)%Z 0%Z) = x).
intros i (h1 & h2).
generalize h1 h2.
pattern i.
apply Z_lt_induction; auto.
clear i h1 h2.
intros i Hind Hi_pos Hi j Hj.
assert (h:(i=0 \/ 0 < i)) by omega.
destruct h.

(* case i = 0 *)
ae.

(* case i > 0 *)

assert (h:(0 <= j < pow2 (i-1) \/
           pow2 (i-1) <= j < pow2 i)) by omega.
destruct h.

(* sub-case j < 2^(i-1) *)

rewrite to_nat_sub_zero; auto with zarith.
apply nth_from_int2c_high_even;
   split; auto with zarith.
rewrite EuclideanDivision.Div_inf; auto.

(* sub-case 2^(i-1) <= j < 2^i *)

rewrite to_nat_sub_one; auto with zarith.
rewrite to_nat_sub_footprint with
  (b2 := (from_int2c (j - pow2 (i-1)))); auto with zarith.
rewrite Hind; auto with zarith.
ae.
ae.
intros k Hk.
replace j with (j - pow2 (i - 1) + pow2 (i - 1)) by omega.
replace (j - pow2 (i - 1) + pow2 (i - 1) - pow2 (i - 1))
            with (j - pow2 (i - 1)) by omega.
ae.

rewrite nth_from_int2c_high_odd;auto.
split.
split;auto with zarith.
rewrite Div_pow; auto with zarith.
rewrite EuclideanDivision.Mod_1_left;omega.

Qed.


(* File: Derivable_Def.v  (last edited on 1/11/2000) (c) Klaus Weich  *)

From IPC Require Export Derivations.

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

Inductive Derivable (context : flist) (a : form) : Prop :=
    Derivable_Intro :
      forall t : proof_term, derives context t a -> Derivable context a.

Inductive Derivable2 (context : flist) (a b : form) : Prop :=
    Derivable2_Intro :
      Derivable context a -> Derivable context b -> Derivable2 context a b.


(** Interface file to the package SubstitutionSystems *)

(**
  The purpose of this file is to provide a stable interface to
  the formalization of heterogeneous substitution systems as
  defined by Matthes and Uustalu

  PLEASE DO NOT RENAME THIS FILE - its name is referenced in
  an article about this formalization

  TODO: provide reference to the article/preprint

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.PointedFunctorsComposition.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.BinSumOfSignatures.
Require Import UniMath.SubstitutionSystems.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration.
Require Import UniMath.CategoryTheory.RightKanExtension.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration.
Require Import UniMath.SubstitutionSystems.LiftingInitial.
Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.LamSignature.
Require Import UniMath.SubstitutionSystems.Lam.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.

Notation "⦃ f ⦄" := (fbracket _ f)(at level 0).
Notation "G • F" := (functor_composite F G).

(** * Generalized Iteration in Mendler-style and fusion law *)

(** Lemma 8 *)

Definition GenMendlerIteration :
   ∏ (C : category) (F : functor C C)
   (μF_Initial : Initial (FunctorAlg F)) (C' : category)
   (X : C') (L : functor C C'),
   is_left_adjoint L
   → ∏ ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L,
     ∃! h : C' ⟦ L ` (InitialObject μF_Initial), X ⟧,
     # L (alg_map F (InitialObject μF_Initial)) · h =
     ψ ` (InitialObject μF_Initial) h.
Proof.
  simpl.
  apply GenMendlerIteration.
Defined.

Arguments It {_ _} _ {_} _ _ _ _.

(** Lemma 9 *)

Theorem fusion_law
     : ∏ (C : category)
       (F : functor C C)
       (μF_Initial : Initial (category_FunctorAlg F))
       (C' : category)
       (X X' : C') (L : functor C C')
       (is_left_adj_L : is_left_adjoint L)
       (ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L)
       (L' : functor C C')
       (is_left_adj_L' : is_left_adjoint L')
       (ψ' : ψ_source C C' X' L' ⟹ ψ_target C F C' X' L')
       (Φ : yoneda_objects C' X • functor_opp L
              ⟹
            yoneda_objects C' X' • functor_opp L'),
       let T:= (` (InitialObject μF_Initial)) in
       ψ T · Φ (F T) = Φ T · ψ' T
       →
       Φ T (It μF_Initial X L is_left_adj_L ψ) =
       It μF_Initial X' L' is_left_adj_L' ψ'.
Proof.
  apply fusion_law.
Qed.

(** * Heterogeneous Substitution Systems *)

(** Lemma 15 *)

Lemma fbracket_natural
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Presignature C C C) (T : hss CP H) (Z Z' : category_Ptd C)
       (f : category_Ptd C ⟦ Z, Z' ⟧)
       (g : category_Ptd C ⟦ Z', ptd_from_alg T ⟧),
       (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U Z' ⟧) · ⦃ g ⦄ = ⦃ f · g ⦄ .
Proof.
  apply fbracket_natural.
Qed.

Lemma compute_fbracket
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Presignature C C C) (T : hss CP H) (Z : category_Ptd C)
       (f : category_Ptd C ⟦ Z, ptd_from_alg T ⟧),
       ⦃ f ⦄ = (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U _ ⟧) · ⦃ identity (ptd_from_alg T) ⦄.
Proof.
  apply compute_fbracket.
Qed.

(** * Monads from hss *)

(** Theorem 24 *)

Definition Monad_from_hss
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Signature C C C), hss CP H → Monad C.
Proof.
  apply Monad_from_hss.
Defined.

(** Theorem 25 *)

Definition hss_to_monad_functor
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Signature C C C),
       functor (hss_precategory CP H) (category_Monad C).
Proof.
  apply hss_to_monad_functor.
Defined.

(** Lemma 26 *)

Lemma faithful_hss_to_monad
     : ∏ (C : category) (CP : BinCoproducts C)
       (H : Signature C C C), faithful (hss_to_monad_functor C CP H).
Proof.
  apply faithful_hss_to_monad.
Defined.

(** * Lifting initiality *)

(** Theorem 28 in three steps:
    - the operation itself
    - its compatibility with variables
    - its compatibility with signature-dependent constructions
*)

Definition bracket_for_initial_algebra
 : ∏ (C : category) (CP : BinCoproducts C),
     (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
       → ∏ (H : Presignature C C C)
           (IA : Initial (FunctorAlg (Id_H C CP H)))
           (Z : category_Ptd C),
           category_Ptd C ⟦ Z, ptd_from_alg (InitAlg C CP H IA) ⟧
           →
           [C, C] ⟦ ℓ (U Z) ` (InitialObject IA), ` (InitAlg C CP H IA) ⟧.
Proof.
  apply bracket_Thm15.
Defined.

Lemma bracket_Thm15_ok_η
     : ∏ (C : category) (CP : BinCoproducts C)
       (KanExt : ∏ Z : category_Ptd C,
                 GlobalRightKanExtensionExists C C (U Z) C)
       (H : Presignature C C C)
       (IA : Initial (FunctorAlg (Id_H C CP H)))
       (Z : category_Ptd C)
       (f : category_Ptd C ⟦ Z, ptd_from_alg (InitAlg C CP H IA)⟧),
       # U f =
       # (pr1 (ℓ (U Z))) (η (InitAlg C CP H IA)) ·
       bracket_Thm15 C CP KanExt H IA Z f.
Proof.
  apply bracket_Thm15_ok_part1.
Qed.

Lemma bracket_Thm15_ok_τ
  : ∏ (C : category) (CP : BinCoproducts C)
      (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
      (H : Presignature C C C)
      (IA : Initial (FunctorAlg (Id_H C CP H)))
      (Z : category_Ptd C)
      (f : category_Ptd C ⟦ Z, ptd_from_alg (InitAlg C CP H IA) ⟧),
    (theta H) (` (InitAlg C CP H IA) ⊗ Z) ·
    # H (bracket_Thm15 C CP KanExt H IA Z f) ·
    τ (InitAlg C CP H IA)
    =
    # (pr1 (ℓ (U Z))) (τ (InitAlg C CP H IA)) ·
      bracket_Thm15 C CP KanExt H IA Z f.
Proof.
  apply bracket_Thm15_ok_part2.
Qed.

(** Theorem 29 *)

Definition Initial_HSS :
   ∏ (C : category) (CP : BinCoproducts C),
     (∏ Z : category_Ptd C,
         GlobalRightKanExtensionExists C C (U Z) C)
     → ∏ H : Presignature C C C,
       Initial (FunctorAlg (Id_H C CP H))
       → Initial (hss_category CP H).
Proof.
  apply InitialHSS.
Defined.

(** * Sum of signatures *)

(** Lemma 30 *)

Definition Sum_of_Signatures
  : ∏ (C D D': category),
       BinCoproducts D → Signature C D D' → Signature C D D' → Signature C D D'.
Proof.
  apply BinSum_of_Signatures.
Defined.

(** * Arities of signatures for lambda calculus *)

(** Definition 31 *)

Definition App_Sig
  : ∏ (C : category), BinProducts C → Signature C C C.
Proof.
  apply App_Sig.
Defined.

(** Definition 32 *)

Definition Lam_Sig
  : ∏ (C : category),
    Terminal C → BinCoproducts C → BinProducts C → Signature C C C.
Proof.
  apply Lam_Sig.
Defined.

(** Definition 33 *)

Definition Flat_Sig
  : ∏ (C : category), Signature C C C.
Proof.
  apply Flat_Sig.
Defined.

(** * Evaluation of explicit substitution as initial morphism *)

(** Definition 36 *)

Definition Lam_Flatten
  :  ∏ (C : category) (terminal : Terminal C)
       (CC : BinCoproducts C) (CP : BinProducts C),
    (∏ Z : category_Ptd C,
        GlobalRightKanExtensionExists C C (U Z) C)
    → ∏ Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP))),
  [C, C] ⟦ (Flat_H C) ` (InitialObject Lam_Initial), ` (InitialObject Lam_Initial) ⟧.
Proof.
  apply Lam_Flatten.
Defined.

(** Lemma 37, construction of the bracket *)

Definition fbracket_for_LamE_algebra_on_Lam
  : ∏ (C : category) (terminal : Terminal C)
      (CC : BinCoproducts C) (CP : BinProducts C)
      (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
      (Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP))))
      (Z : category_Ptd C),
    category_Ptd C ⟦ Z ,
                           (ptd_from_alg_functor CC (LamE_Sig C terminal CC CP))
                             (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧
    → [C, C]
             ⟦ functor_composite (U Z)
                                 ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial),
               ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧.
Proof.
  apply fbracket_for_LamE_algebra_on_Lam.
Defined.

(** Morphism from initial hss to construed hss, consequence of Lemma 37 *)

Definition EVAL
  : ∏ (C : category) (terminal : Terminal C)
      (CC : BinCoproducts C) (CP : BinProducts C)
      (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C)
       (Lam_Initial : Initial
                        (FunctorAlg
                           (Id_H C CC
                              (LamSignature.Lam_Sig C terminal CC CP))))
       (LamE_Initial : Initial
                         (FunctorAlg
                            (Id_H C CC (LamE_Sig C terminal CC CP)))),
       hss_category CC (LamE_Sig C terminal CC CP)
                       ⟦ InitialObject
                           (LamEHSS_Initial C terminal CC CP KanExt LamE_Initial),
                         LamE_model_on_Lam C terminal CC CP KanExt Lam_Initial ⟧.
Proof.
  apply FLATTEN.
Defined.


Require Import String.
Require Import ZArith.

Inductive pseudocode : Type :=
| pseudocode_intro : string -> pseudocode.

Inductive arithmetic_operator : Type :=
| ao_plus
| ao_minus
| ao_minus_unary
| ao_mult
| ao_div
| ao_mod.

Inductive logical_operator : Type :=
| lo_and
| lo_or
| lo_not.

Inductive relational_operator : Type :=
| ro_gt
| ro_ge
| ro_lt
| ro_le
| ro_eq
| ro_neq.

Inductive bitwise_operator : Type :=
| bo_and
| bo_or
| bo_xor
| bo_neg
| bo_rshift
| bo_lshift.

Inductive assignment_operator : Type :=
| aso_assign
| aso_postinc
| aso_postdec
| aso_addassign
| aso_subassign
| aso_mulassign
| aso_divassign
| aso_borassign
| aso_bandassign
| aso_xorassign.

Inductive special_operator : Type :=
| so_function_call
| so_subscript
| so_turnary.

Inductive any_operator :=
| ano_ao : arithmetic_operator -> any_operator
| ano_lo : logical_operator -> any_operator
| ano_ro : relational_operator -> any_operator
| ano_bo : bitwise_operator -> any_operator
| ano_aso : assignment_operator -> any_operator
| ano_so : special_operator -> any_operator.

Inductive expression : Type :=
| expr_number : Z -> expression
| expr_variable : string -> expression
| expr_op1 : any_operator -> expression -> expression
| expr_op2 : any_operator -> expression -> expression -> expression
| expr_op1n : any_operator -> expression -> list expression -> expression.

Inductive parsing_descriptor : Type :=
| pd_fixed : expression -> parsing_descriptor
| pd_little_endian : expression -> parsing_descriptor
| pd_signed : expression -> parsing_descriptor
| pd_ae_literal : expression -> parsing_descriptor
| pd_ae_alphabet : parsing_descriptor
| pd_ae_unsigned : expression -> parsing_descriptor.

Inductive statement : Type :=
| stmt_expression : expression -> statement
| stmt_syntax_element : expression -> parsing_descriptor -> statement
| stmt_group : list statement -> statement
| stmt_while : expression -> statement -> statement
| stmt_do_while : statement -> expression -> statement
| stmt_if : expression -> statement -> statement
| stmt_if_else : expression -> statement -> statement -> statement
| stmt_for : expression -> expression -> expression -> statement -> statement
| stmt_return : expression -> statement
| stmt_empty : statement.

Inductive declaration : Type :=
| decl_constant : string -> expression -> declaration
| decl_constant_array :
  string -> list expression -> list expression -> declaration
| decl_function : string -> list string -> statement -> declaration.


Require Import HoTT.

Fail Check Type0 : Type0.
Check Susp nat : Type0.
Fail Check Susp Type0 : Type0.

Fail Check (fun (P : interval -> Type) (a : P Interval.zero) (b : P Interval.one)
                (p p' : seg # a = b)
            => idpath : interval_ind P a b p = interval_rect P a b p').

Local Open Scope nat_scope.
Fail Check Lift nat : Type0.
Check 1 : Lift nat.

Check lift'@{i j}.
Check lower'@{i j}.
Check isequiv_lift'@{i j}.

(** Check that [ispointed_susp] doesn't require just a [Set] *)
Check (fun A : Type => _ : IsPointed (Susp A)).
Check (@ispointed_susp Type).
Check (@ispointed_susp Set).

(** Check that nested sigma-type notation didn't get clobbered by surreal cuts *)
Check ({ l : Unit & { n : Unit & Unit }}).

(** Regression check issue #744 *)
Module Foo (Os : ReflectiveSubuniverses).
  Module Import Os_Theory := ReflectiveSubuniverses_Theory Os.
  Goal Unit.
    let lem' := preconcat_any @to_O_natural_compose in
    pose proof lem' as H.
    let test := left_associate_concat_in H in
    pose test.
  Admitted.
End Foo.

(** Test 1 from issue #754 *)
Module Issue754_1.
  Inductive nat : Type1 :=
  | O : nat
  | S : nat -> nat.
  Fixpoint code_nat (m n : nat) {struct m} : DProp.DHProp :=
    match m with
      | O => match n with
               | O => DProp.True
               | S _ => DProp.False
             end
      | S m' => match n with
                  | O => DProp.False
                  | S n' => code_nat m' n'
                end
    end.

  Local Set Warnings Append "-notation-overridden".
  Notation "x =n y" := (code_nat x y) : nat_scope.
  Local Set Warnings Append "notation-overridden".
  Bind Scope nat_scope with nat.
  Axiom equiv_path_nat :
    forall n m : nat,
      Trunc.trunctype_type (DProp.dhprop_hprop (n =n m)) <~> n = m.

  Definition nat_discr `{Funext} {n: nat}: O <> S n.
  Proof.
    intro H'.
    equiv_induction (@equiv_path_nat O (S n)).
    assumption.
  Qed.
End Issue754_1.