(* No points will be awarded for Theorems/Lemmas using previous Admitted
* Theorems/Lemmas *)

Require Import Frap Pset8Sig.

Set Implicit Arguments.

Hint Constructors subtype.
Check "$<:".
(* 10 points *)
Lemma subtype_refl : forall t1, t1 $<: t1.
Proof.
  simplify.
  induct t1.
  - apply StFun. assumption. assumption.
  - apply StTupleNilNil.
  - apply StTupleCons. assumption. assumption.
Qed.

Lemma subtype_trans_strong: forall t1 t2 t3, (t1 $<: t2 -> t2 $<: t3 -> t1 $<: t3) /\ (t3$<: t2 -> t2$<:t1 -> t3$<:t1).
Proof.
    induct t1. simplify.
      - simpl. split. simplify. invert H. invert H0. apply StFun. destruct IHt1_1 with (t2:=t1) (t3:=t2). apply H0. assumption. assumption.
      destruct IHt1_2 with (t2:=t0) (t3:=t4). apply H. assumption. assumption.
      simplify. invert H0. invert H. apply StFun. destruct IHt1_1 with (t2:=t1') (t3:=t1'0). apply H. assumption. assumption.
      destruct IHt1_2 with (t2:=t2') (t3:=t2'0). apply H0. assumption. assumption.
    -   simplify. split. simplify. invert H. assumption. simplify. invert H0. assumption. invert H. apply StTupeNilCons.
    -   simplify.
         split.
         simplify.
        invert H.
        invert H0.
        apply StTupeNilCons.
        invert H0.  apply StTupeNilCons. apply StTupleCons. destruct IHt1_1 with (t2:=t1) (t3:=t2). apply H. assumption. assumption.
        destruct IHt1_2 with (t2:=t0) (t3:=t4). apply H. assumption. assumption.

        simplify. invert H0. invert H.  apply StTupleCons. destruct IHt1_1 with (t2:=t1') (t3:=t1'0). apply H0. assumption. assumption.
        destruct IHt1_2 with (t2:=t2') (t3:=t2'0). apply H0. assumption. assumption.
Qed.

(* 10 points *)
Lemma subtype_trans : forall t1 t2 t3, t1 $<: t2 -> t2 $<: t3 -> t1 $<: t3.
Proof.
   apply subtype_trans_strong.
Qed.

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

(* canonical forms of well-typed values *)

Lemma canonical_Fun_util t1 t2 t': hasty $0 TupleNil t' -> t' $<: Fun t1 t2 -> False.
Proof.
  induct 1; simplify.
  invert H.
  apply IHhasty.
  apply subtype_trans with (t2:=t). assumption. assumption.
Qed.

Lemma canonical_Fun_util_2 e1 e2 t1 t2 t': hasty $0 (TupleCons e1 e2) t' -> t' $<: Fun t1 t2 -> False.
Proof.
  induct 1;simplify.
  invert H1.
apply IHhasty.
  apply subtype_trans with (t2:=t). assumption. assumption.
Qed.

(* 10 points *)
Lemma canonical_Fun v t1 t2 :
  hasty $0 v (Fun t1 t2) ->
  value v ->
  exists x e',
    v = Abs x e'.
Proof.
  simplify.
  invert H.
  - simplify. invert H1.
  - exists (x). exists(e1). trivial.
  - invert H0.
  - invert H0.
  - invert H0.
     + eexists. eexists. auto.
     + apply canonical_Fun_util in H2. invert H2. assumption.
     +apply canonical_Fun_util_2 with (e1:=e1) (e2:=e2) in H2. invert H2. assumption.
Qed.

Lemma util_3_1 t1 t2 t': hasty $0 TupleNil t' -> t' $<: TupleTypeCons t1 t2 -> False.
Proof.
  induct 1;simplify.
  invert H.
  apply IHhasty.
  apply subtype_trans with (t2:=t). assumption. assumption.
Qed.

Lemma util_3_2 t1 t2 t' x v: hasty $0 (Abs x v) t' -> t' $<: TupleTypeCons t1 t2 -> False.
Proof.
  induct 1;simplify.
  invert H0.
  apply IHhasty.
  apply subtype_trans with (t2:=t). assumption. assumption.
Qed.

(* 10 points *)
Lemma canonical_TupleCons v t1 t2 :
  hasty $0 v (TupleTypeCons t1 t2) ->
  value v ->
  exists v1 v2,
    v = TupleCons v1 v2 /\
    value v1 /\
    value v2.
Proof.
  simplify.
  invert H.
  - simplify. invert H1.
  - invert H0.
  - invert H0. exists(e1). exists(e2). split. trivial. propositional.
  - invert H0.
  - invert H0.
    + apply util_3_2 with (x:=x) (v:=e1) in H2. invert H2. assumption.
    + apply util_3_1 in H2. invert H2. assumption.
    + exists e1. exists e2. propositional.
Qed.

Hint Constructors plug step0.
Hint Resolve subtype_refl subtype_trans canonical_Fun canonical_TupleCons.

Lemma util_4_1 e1 e2:exists x e', e1 = Abs x e' -> value e2 -> exists p, step0 (App e1 e2) p.
Proof.
  eexists.
  eexists.
  simplify.
  rewrite H.
  eexists.
  econstructor.
  assumption.
  Unshelve.
  exact "a".
  exact TupleNil.
Qed.

Ltac t0 := match goal with
           | [ H : ex _ |- _ ] => invert H
           | [ H : _ /\ _ |- _ ] => invert H
           | [ |- context[_ $+ (?x, _) $? ?y] ] => cases (x ==v y); simplify
           | [ |- context[?x ==v ?y] ] => cases (x ==v y); simplify

           | [ H : step _ _ |- _ ] => invert H
           | [ H : step0 _ _ |- _ ] => invert1 H
           | [ H : hasty _ _ _ |- _ ] => invert1 H
           | [ H : proj_t _ _ _ |- _ ] => invert1 H
           | [ H : plug _ _ _ |- _ ] => invert1 H
           | [ H : subtype _ _ |- _ ] => invert1 H
           | [ H : Some _ = Some _ |- _ ] => invert H
           end; subst.

Ltac t := simplify; subst; propositional; repeat (t0; simplify); try equality.

Lemma util_4_2_1 t t' t0 n : hasty $0 TupleNil t' ->  t' $<: t0 ->   proj_t t0 n t -> False.
Proof.
  induct 1; simplify.

  invert H.
  invert H0.

  apply IHhasty.
  eauto. assumption.
Qed.

Lemma util_4_2 e t t' n:  hasty $0 e t' ->  proj_t t' n t ->  value e -> value (Proj e n) \/ (exists e' : exp, step (Proj e n) e').
Proof.
  induct 1; simplify.
  t.
  t.
  t.
  invert H2.
  t.
  invert H2.  invert H1.
  right. eexists. eauto.
  eauto.

  invert H2.

  invert H2.
  invert H1.
  apply util_3_2 with (t1:=t) (t2:=t2) in H.
  equality.
  assumption.

    apply util_3_2 with (t1:=t1) (t2:=t2) in H.
    equality.
  assumption.

  apply util_4_2_1 with (t':=t') in H1.
  equality.
  assumption.
  assumption.

  induct n; simplify; eauto.
Qed.

(* 10 points *)
Lemma progress : forall e t,
    hasty $0 e t
    -> value e
      \/ (exists e' : exp, step e e').
Proof.
  induct 1; simplify; try equality.

  left. constructor.

  propositional. right.
  destruct util_4_1 with (e1:=e1) (e2:=e2) in H.
  apply canonical_Fun in H.
  invert H.
  invert H4.
  econstructor.
  econstructor. econstructor. econstructor.
  eapply Beta.
  assumption.
  assumption.

  invert H3.
  invert H2.
  right.
  eauto.

  invert H1.
  invert H2.
  right. eauto.

  right.
  invert H3.
  invert H2.
  eauto.

  left. constructor.

  first_order.
  left. eauto.
  invert H2. right. eauto.
  invert H1. right. eauto.
  invert H1. right. eauto.

  first_order.
  apply util_4_2 with (t:=t) (t':=t').
  assumption.   assumption.   assumption.
  right. invert H1. eauto.
Qed.

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

(* 10 points *)
Lemma weakening_override : forall V G G' (x : var) (t : V),
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                -> G' $+ (x, t) $? x' = Some t').
Proof.
    simplify.
    cases(x==vx').
    simplify. assumption.
    simplify. apply H. assumption.
Qed.

(* 10 points *)
Lemma weakening : forall G e t,
    hasty G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
            -> hasty G' e t.
Proof.
  induct 1; simplify.

    constructor.
    apply H0.
    assumption.

    econstructor.
    apply IHhasty.
    simplify.
    apply weakening_override with (G:=G).
    assumption.
    assumption.

    econstructor.
    apply IHhasty1.
    assumption.
    apply IHhasty2.
    assumption.

    econstructor.
    econstructor.
    apply IHhasty1.
    assumption.
    apply IHhasty2.
    assumption.

    econstructor.
    apply IHhasty.
    assumption.
    assumption.

    econstructor.
    eapply IHhasty.
    assumption.
    assumption.
Qed.

(* 10 points *)
Lemma substitution : forall G x t' e t,
    hasty (G $+ (x, t')) e t ->
    forall e',
      hasty $0 e' t' ->
      hasty G (subst e' x e) t.
Proof.
  induct 1; simplify.

  cases (x0 ==v x).

    simplify.
    invert H.
    eapply weakening.
    eassumption.
    simplify.
    equality.

    simplify.
    constructor.
    assumption.

    cases (x0 ==v x).

    constructor.
    invert e.
    eapply weakening.
    eassumption.
    simplify.
    cases (x0 ==v x).

    simplify.
    assumption.

    simplify.
    assumption.

    constructor.
    eapply IHhasty.
    maps_equal.
    assumption.

    econstructor.
    eapply IHhasty1; equality.
    eapply IHhasty2; equality.

    econstructor.

    econstructor.
    econstructor.
    eauto.
    apply subtype_refl.
    econstructor.
    eauto.
    apply subtype_refl.

    econstructor.
    eauto. assumption.

    econstructor.
    eauto. assumption.
Qed.

Hint Resolve substitution.

Lemma util_6_1 v t1 t t' x e: hasty $0 v t1 -> hasty $0 (Abs x e) t' -> t' $<: Fun t1 t -> hasty $0 (subst v x e) t.
Proof.
  simplify.
  induct H0.
  invert H1.
  eapply HtSub with (t':=t2).
  eapply substitution.
  eassumption.

  eapply HtSub with (t':=t1).
  assumption.
  assumption.
  assumption.

  apply IHhasty.
  assumption.
  trivial.
  trivial.
  apply subtype_trans with (t2:=t0).
  assumption.
  assumption.
Qed.

Lemma util_6_2 x e v t :  hasty $0 (App (Abs x e) v) t ->hasty $0 (subst v x e) t.
Proof.
  simplify.

  induct H.
  invert H.
  eapply substitution.
  eassumption.
  assumption.

  eapply util_6_1.
  eassumption.
  eassumption.
 assumption.
    eapply HtSub.
  eassumption. assumption.
Qed.

Lemma util_6_3 v1 v2 t t' t2:  hasty $0 (TupleCons v1 v2) t' -> t' $<: TupleTypeCons t t2 -> hasty $0 v1 t.
Proof.

  simplify.
  induct H.
  invert H1.
  eapply HtSub with (t':=t1).
  eassumption.
  assumption.

  apply IHhasty with (v4:=v2).
  trivial.
  trivial.
  apply subtype_trans with (t2:=t0).
  assumption.
  assumption.
Qed.

Lemma util_6_4 v1 v2 t: hasty $0 (Proj (TupleCons v1 v2) 0) t -> hasty $0 v1 t.
Proof.

  simplify.
  induct H.
  invert H0.
  invert H. assumption.

  eapply util_6_3.
  eassumption.
  eassumption.

  eapply HtSub with (t':=t').
  eapply IHhasty.
  trivial.
Qed.

Lemma util_6_5 v1 v2 t t' t2:  hasty $0 (TupleCons v1 v2) t' -> t' $<: TupleTypeCons t t2 -> hasty $0 v2 t2.
Proof.

  simplify.
  induct H.
  invert H1.
  eapply HtSub with (t':=t0).
  eassumption.
  assumption.

  apply IHhasty with (v3:=v1).
  trivial.
  trivial.
  apply subtype_trans with (t2:=t0).
  assumption.
  assumption.
Qed.

Lemma util_6_6 v1 v2 n t: hasty $0 (Proj (TupleCons v1 v2) (S n)) t -> hasty $0 (Proj v2 n) t.
Proof.

  simplify.
  induct H.
  invert H0.
  invert H.
  eapply HtProj.
  eassumption.
  assumption.

  eapply HtProj.
  eapply util_6_5.
  eassumption.
  eassumption.
  assumption.

  eapply HtSub.
  eapply IHhasty.
  trivial.
Qed.

(* 10 points *)
Lemma preservation0 : forall e1 e2,
    step0 e1 e2
    -> forall t, hasty $0 e1 t
           -> hasty $0 e2 t.
Proof.
  invert 1; simplify.

  apply util_6_2.
  assumption.

  apply util_6_4 with (v2:=v2).
  assumption.

   apply util_6_6 with (v1:=v1).
    assumption.
Qed.

(* 10 points *)
Lemma generalize_plug : forall e1 C e1',
    plug C e1 e1'
    -> forall e2 e2', plug C e2 e2'
                -> (forall t, hasty $0 e1 t -> hasty $0 e2 t)
                -> (forall t, hasty $0 e1' t -> hasty $0 e2' t).
Proof.

  induct 1; simplify.

    invert H.
    apply H0.
    assumption.

    invert H0.
    induct H2.
    econstructor.
    eapply IHplug.
    eassumption.
    assumption.
    eassumption.
    assumption.

    eapply HtSub with (t':=t').
    eapply IHhasty.
    eassumption.
  eassumption.
  eassumption.
  trivial.
  trivial.
  assumption.
  assumption.

  invert H1.
    induct H3.
    econstructor.
    eassumption.
    eapply IHplug.
    eassumption.
    assumption.
    eassumption.

    eapply HtSub with (t':=t').
    eapply IHhasty.
    eassumption.
  eassumption.
  eassumption.
  trivial.
  trivial.
  trivial.
  assumption.
  assumption.
  assumption.

  invert H0.
    induct H2.
    constructor.
    eapply IHplug.
    eassumption.
    assumption.
    assumption.
    assumption.

  eapply HtSub with (t':=t').
    eapply IHhasty.
    eassumption.
  eassumption.
  eassumption.
  trivial.
  trivial.
  assumption.
  assumption.

  invert H1.
    induct H3.
    constructor.
    assumption.
    eapply IHplug.
    eassumption.
    assumption.
    assumption.

  eapply HtSub with (t':=t').
    eapply IHhasty.
    eassumption.
  eassumption.
  eassumption.
  trivial.
  trivial.
  trivial.
  assumption.
  assumption.
  assumption.

  invert H0.
    induct H2.
    econstructor.
    eapply IHplug.
    eassumption.
    assumption.
    eassumption.
    assumption.

    eapply HtSub with (t':=t').
    eapply IHhasty.
    eassumption.
  eassumption.
  eassumption.
  trivial.
  trivial.
  assumption.
  assumption.
Qed.

(* 10 points *)
Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, hasty $0 e1 t
           -> hasty $0 e2 t.
Proof.
    invert 1; simplify.

    eapply generalize_plug with (e1' := e1).
    eassumption.
    eassumption.
    simplify.
    eapply preservation0.
    eassumption.
    assumption.
    assumption.
Qed.

(******************************************************************************)
(** Safety *)
(******************************************************************************)

(* 10 points *)
Theorem safety :
  forall e t,
    hasty $0 e t -> invariantFor (trsys_of e)
                                 (fun e' => value e'
                                            \/ exists e'', step e' e'').
Proof.
   simplify.

    apply invariant_weaken with (invariant1 := fun e' => hasty $0 e' t).

    apply invariant_induction; simplify.
    equality.

    eapply preservation.
    eassumption.
    assumption.

    simplify.
    eapply progress.
    eassumption.
Qed.


(*
(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.
*)

Require Import Reals.
Require Import Rsequence_def.
Require Import Rpser_def Rpser_def_simpl Rpser_base_facts Rsequence_facts.
Require Import Rsequence_sums_facts Rsequence_rewrite_facts.
Require Import Rpow_facts.
Require Import Lra.

Require Import Max Min.
Require Import MyRIneq MyNeq.
Require Import Rinterval.
Require Import RFsequence RFsequence_facts.

Require Import Tactics.

Open Scope Rseq_scope.
Open Scope R_scope.

(** * Abel's lemma : convergence of the power serie inside the cv-disc *)

Lemma Cauchy_crit_Rseq_pps : forall An r, Cv_radius_weak An r ->
  forall x, Rabs x < r -> Cauchy_crit (Rseq_pps An x).
Proof.
intros An r rho x x_ub eps eps_pos.
assert (r_pos : 0 < r).
 apply Rle_lt_trans with (Rabs x) ; [apply Rabs_pos | assumption].
assert (r_neq : 0 <> r) by (apply Rlt_not_eq ; assumption).
assert (Hrew_abs : Rabs (x / r) = Rabs x / r).
 unfold Rdiv ; rewrite Rabs_mult ; apply Rmult_eq_compat_l ; apply Rabs_right ;
 apply Rgt_ge ; apply Rlt_gt ; apply Rinv_0_lt_compat ; apply Rle_lt_trans with (Rabs x) ;
 [apply Rabs_pos | assumption].
assert (Rabsx_r_lt_1 : Rabs x / r < 1).
 rewrite <- (Rinv_r r) ; [| symmetry ; assumption] ; unfold Rdiv ;
 apply Rmult_lt_compat_r ; [apply Rinv_0_lt_compat |] ; assumption.
destruct (Req_or_neq x) as [x_eq | x_neq].
 exists O ; intros ; subst ; do 2 rewrite Rseq_pps_0_simpl ; rewrite R_dist_eq ;
  assumption.
 assert (Temp : forall m n, (m < n)%nat -> R_dist (Rseq_pps An x n) (Rseq_pps An x m)
  = Rabs (Rseq_sum (Rseq_shifts (gt_pser An x) (S (min m n))) ((max m n) - S (min m n)))).
  intros m n m_neq_n ; unfold R_dist ; apply Rabs_eq_compat ;
   replace (max m n) with n. replace (min m n) with m.
   rewrite Rseq_sum_shifts_compat ; unfold Rseq_shifts ;
   replace (S m + (n - S m))%nat with n by lia ; reflexivity.
   symmetry ; apply min_l ; intuition.
   symmetry ; apply max_r ; intuition.
 assert (Hrew : forall m n, m <> n -> R_dist (Rseq_pps An x n) (Rseq_pps An x m)
  = Rabs (Rseq_sum (Rseq_shifts (gt_pser An x) (S (min m n))) ((max m n) - S (min m n)))).
  intros m n m_neq_n ; unfold R_dist ; destruct (le_lt_dec m n) as [mlen | nltm].
   assert (mltn : (m < n)%nat) by (clear -m_neq_n mlen ; lia) ;
    apply Temp ; assumption.
   rewrite Rabs_minus_sym, min_comm, max_comm ; apply Temp ; assumption.
 clear Temp.
 assert (Hineq : exists M, forall m n, m <> n ->
  R_dist (Rseq_pps An x n) (Rseq_pps An x m) <= M *
  Rseq_sum (Rseq_shifts (pow (Rabs x / r)) (S (min m n))) ((max m n) - S (min m n))).
  destruct rho as [B HB] ; exists B ; intros m n m_neq_n ;
   rewrite Hrew ; [| assumption].
   assert (Temp : forall k n, Rabs (Rseq_sum (Rseq_shifts (gt_pser An x) k) n) <=
    B * Rseq_sum (Rseq_shifts (pow (Rabs x / r)) k) n).
    clear - r_neq r_pos Hrew_abs HB; intros k n ; induction n.
    simpl ; do 2 rewrite Rseq_shifts_O ; rewrite <- (Rmult_1_r (gt_pser An x k)),
    <- (Rinv_r (r ^ k)), <- Rmult_assoc, Rabs_mult, Rinv_pow ;
    [| symmetry ; assumption | apply pow_nonzero ; symmetry ; assumption].
    apply Rle_trans with (Rabs (gt_pser An r k) * Rabs (x ^ k) * Rabs ((/ r) ^ k)).
    right ; repeat rewrite <- Rabs_mult ; apply Rabs_eq_compat ;
    unfold gt_pser, Rseq_mult ; ring.
    apply Rle_trans with ((gt_abs_pser An r k) * (Rabs x / r) ^ k).
    right ; rewrite Rmult_assoc ; apply Rmult_eq_compat_l ;
    rewrite <- Hrew_abs, <- Rabs_mult, <- Rpow_mult_distr, RPow_abs ;
    reflexivity.
    apply Rmult_le_compat_r ; [| apply HB ; exists k ; reflexivity].
    apply pow_le ; unfold Rdiv ; apply Rle_mult_inv_pos ; [apply Rabs_pos | assumption].
    apply Rle_trans with (Rabs (Rseq_sum (Rseq_shifts (gt_pser An x) k) n)
      + Rabs (Rseq_shifts (gt_pser An x) k (S n))).
    simpl ; apply Rabs_triang.
    apply Rle_trans with (B * Rseq_sum (Rseq_shifts (pow (Rabs x / r)) k) n
     + B * (Rseq_shifts (pow (Rabs x / r)) k) (S n)).
    apply Rplus_le_compat ; [apply IHn |].
    apply Rle_trans with (gt_abs_pser An r (k + S n) * ((Rabs x / r) ^ (k + S n))).
    right ; unfold Rseq_shifts, gt_abs_pser, gt_pser, Rseq_mult, Rseq_abs.
    repeat rewrite Rabs_mult ; repeat rewrite Rmult_assoc ; apply Rmult_eq_compat_l ;
    rewrite <- Hrew_abs, RPow_abs, <- Rabs_mult ; apply Rabs_eq_compat ; unfold Rdiv ;
    rewrite Rpow_mult_distr, <- Rinv_pow ; [field |] ; [apply pow_nonzero |] ;
    symmetry ; assumption.
    apply Rmult_le_compat_r ; [| apply HB ; exists (k + S n)%nat ; reflexivity].
    unfold Rseq_shifts, Rdiv ; apply pow_le ; apply Rle_mult_inv_pos ;
    [apply Rabs_pos | assumption].
    right ; simpl ; symmetry ; apply Rmult_plus_distr_l.
  apply Temp.
  assert (Main :  exists M : R, forall m n : nat, m <> n ->
        R_dist (Rseq_pps An x n) (Rseq_pps An x m) <=
        M * ((Rabs x / r) ^ (S (min m n)) * (1 - (Rabs x / r)
        ^ (S (max m n - S (min m n)))) / (1 - (Rabs x / r)))).
   destruct Hineq as [B HB] ; exists B ; intros m n m_neq_n.
   specialize (HB m n m_neq_n) ; unfold Rseq_shifts in HB ; rewrite sum_pow in HB ;
   [apply HB | apply Rlt_not_eq ; assumption].
 clear Hineq Hrew.
  assert (Final : exists M : R, 0 < M /\ forall m n : nat, m <> n ->
       R_dist (Rseq_pps An x n) (Rseq_pps An x m) <=
       (Rabs x / r) ^ S (min m n) * (M * 2 / (1 - Rabs x / r))).
   destruct Main as [B HB] ; exists (Rmax B 1) ; split ;
   [apply Rlt_le_trans with 1 ; [lra | apply RmaxLess2] | intros m n m_neq_n].
    assert (Temp : (1 - (Rabs x / r) ^ S (max m n - S (min m n))) <= 2).
    apply Rle_trans with (Rabs (1 - (Rabs x / r) ^ S (max m n - S (min m n)))) ;
    [apply RRle_abs |].
    apply Rle_trans with (Rabs 1 + Rabs (- (Rabs x / r) ^ S (max m n - S (min m n)))) ;
    [apply Rabs_triang | rewrite Rabs_R1 ; apply Rplus_le_compat_l].
    rewrite Rabs_Ropp ; rewrite <- RPow_abs ; rewrite <- Hrew_abs ; rewrite Rabs_Rabsolu ;
    replace R1 with (1 ^  S (max m n - S (min m n))) ; [apply pow_le_compat | apply pow1].
    apply Rabs_pos.
    apply Rlt_le ; rewrite Hrew_abs ; assumption.
   apply Rle_trans with (B * ((Rabs x / r) ^ S (min m n) *
      (1 - (Rabs x / r) ^ S (max m n - S (min m n))) / (1 - Rabs x / r))) ; [apply HB ; assumption |].
  clear HB ; rewrite Rmult_comm ; unfold Rdiv ; repeat (rewrite Rmult_assoc) ;
  apply Rmult_le_compat_l ; [ unfold Rdiv in Hrew_abs ; rewrite <- Hrew_abs ;
  rewrite RPow_abs ; apply Rabs_pos |].
  apply Rle_trans with ((1 - (Rabs x * / r) ^ S (max m n - S (min m n))) * (/ (1 - Rabs x * / r) * (Rmax B 1))).
  apply Rmult_le_compat_l.
  unfold Rdiv in Hrew_abs ; rewrite <- Hrew_abs, RPow_abs.
  apply Rlt_le ; apply Rgt_minus.
  rewrite <- RPow_abs.
  case (Req_or_neq x) ; intro H.
  rewrite H ; rewrite Rmult_0_l ; rewrite Rabs_R0 ; rewrite pow_i ; intuition.
  replace 1 with (1 ^ S (max m n - S (min m n))).
  apply pow_lt_compat.
  apply Rabs_pos.
  unfold Rdiv in Rabsx_r_lt_1 ; rewrite Hrew_abs ; assumption.
  intuition.
  apply pow1.
  apply Rmult_le_compat_l.
  apply Rlt_le ; apply Rinv_0_lt_compat.
  apply Rgt_minus ; intuition.
  apply RmaxLess1.
  rewrite <- Rmult_assoc.
  rewrite Rmult_comm.
  apply Rmult_le_compat_l ; [apply Rle_trans with 1 ; [intuition | apply RmaxLess2] |].
  apply Rmult_le_compat_r.
  apply Rlt_le ; apply Rinv_0_lt_compat.
  apply Rgt_minus ; intuition.
  assumption.
  elim Final ; intros M HM ; destruct HM as (M_pos, HM).
  rewrite <- Hrew_abs in Rabsx_r_lt_1.
  assert (y_pos : 0 < eps / (4 * M) * (1 - Rabs x / r)).
  apply Rmult_lt_0_compat.
  unfold Rdiv ; apply Rmult_lt_0_compat.
  assumption.
  apply Rinv_0_lt_compat ; lra.
  apply Rgt_minus ; rewrite <- Hrew_abs ; assumption.
  elim (pow_lt_1_zero (x/r) Rabsx_r_lt_1 (eps / (4 * M) * (1 - (Rabs x / r))) y_pos) ; intros N HN ;
  exists N ; intros n m n_lb m_lb.
  case (eq_nat_dec m n); intro s.
  rewrite s ; rewrite R_dist_eq ; assumption.
  apply Rle_lt_trans with ((Rabs x / r) ^ S (min m n) * (M * 2 / (1 - Rabs x / r))).
  apply HM ; intuition.
  assert (Temp : (S (min m n) >= N)%nat).
   destruct N.
   intuition.
   apply le_n_S.
   case (min_dec m n) ; intro H ; rewrite H ; apply le_trans with (S N) ; intuition.
   apply Rlt_trans with ((eps / (4 * M) * (1 - Rabs x / r)) * ((M * 2 / (1 - Rabs x / r)))).
   apply Rmult_lt_compat_r.
   apply Rmult_lt_0_compat.
   lra.
   apply Rinv_0_lt_compat.
   apply Rgt_minus ; rewrite <- Hrew_abs ; assumption.
   rewrite <- Hrew_abs ; rewrite RPow_abs ; rewrite Hrew_abs ; apply HN ; assumption.
   replace (eps / (4 * M) * (1 - Rabs x / r) * (M * 2 / (1 - Rabs x / r))) with
       (eps * (/2 * (/(2*M) * (2*M) * ((1 - Rabs x / r) / (1 - Rabs x / r))))).
   replace (/ (2 * M) * (2 * M)) with 1.
   rewrite Rmult_1_l ; unfold Rdiv ; rewrite Rinv_r.
   lra.
   apply Rgt_not_eq ; apply Rgt_minus ; unfold Rdiv in Hrew_abs ; rewrite <- Hrew_abs ; assumption.
   symmetry ; apply Rinv_l ; apply Rgt_not_eq ; lra.
   field ; split ; [|split].
   apply Rgt_not_eq ; apply Rle_lt_trans with (Rabs x) ; [apply Rabs_pos | assumption].
   apply Rgt_not_eq ; apply Rgt_minus ; assumption.
   apply Rgt_not_eq ; assumption.
Qed.

Lemma Rpser_abel : forall (An : nat -> R) (r : R),
     Cv_radius_weak An r -> forall x, Rabs x < r -> {l | Rpser An x l}.
Proof.
intros An r Rho x x_ub.
  apply R_complete ; apply Cauchy_crit_Rseq_pps with r ; assumption.
Qed.

(** * D'Alembert's criterion *)

Lemma Rpser_alembert_prelim : forall (An : nat -> R) (M : R),
       0 < M -> (forall n : nat, An n <> 0) ->
       Rseq_bound (fun n => (An (S n) / An n)) M -> forall r,
       Rabs r < / M -> Cv_radius_weak An r.
Proof.
intros An M M_pos An_neq An_frac_ub r r_bd.
 assert (r_lb := Rabs_pos r) ; case r_lb ; clear r_lb ; intro rabs_lb.
 assert (my_lam : 0 < /Rabs r - M).
 apply Rgt_minus ; rewrite <- Rinv_involutive.
 apply Rinv_lt_contravar.
 apply Rmult_lt_0_compat ; [| apply Rlt_trans with (Rabs r)] ; assumption.
 assumption.
 apply Rgt_not_eq ; assumption.
 exists (Rabs (An 0%nat)) ; intros x Hyp ;
  elim Hyp ; intros n Hn ; rewrite Hn ;
  unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult ; rewrite Rabs_mult.
  clear Hn ; induction n.
  simpl ; rewrite Rabs_R1 ; rewrite Rmult_1_r ; right ; reflexivity.
  apply Rle_trans with (Rabs (An (S n) / (An n)) * Rabs (An n) * Rabs (r ^ S n)).
  right ; repeat rewrite <- Rabs_mult ; apply Rabs_eq_compat ;
  field ; apply An_neq.
  apply Rle_trans with (M * Rabs (An n) * Rabs (r ^ S n)).
  repeat apply Rmult_le_compat_r ; [| | apply An_frac_ub] ; apply Rabs_pos.
  simpl ; rewrite Rabs_mult.
  apply Rle_trans with (M * Rabs (An n) * (/M * Rabs (r ^ n))).
  repeat rewrite <- Rmult_assoc ; apply Rmult_le_compat_r ; [apply Rabs_pos |
  repeat rewrite Rmult_assoc ; repeat apply Rmult_le_compat_l].
  left ; assumption.
  apply Rabs_pos.
  left ; assumption.
  apply Rle_trans with (Rabs (An n) * Rabs (r ^ n))%R ; [right ; field ;
  apply Rgt_not_eq |] ; assumption.
 exists (Rabs (An 0%nat)).
  intros x Hx ; destruct Hx as (n,Hn) ; rewrite Hn ; destruct n.
  apply gt_abs_pser_0_ub.
  destruct (Req_dec r 0) as [Hr | Hf].
  rewrite Hr ; apply gt_abs_pser_0_ub.
  apply False_ind ; assert (T := Rabs_no_R0 _ Hf) ;
  apply T ; symmetry ; assumption.
Qed.

Lemma Rseq_cv_bounded : forall Un l, l <> 0 ->
  Rseq_cv Un l -> forall k, 1 < k ->
  Rseq_eventually (fun un => forall n, (Rabs l) / k < Rabs (un n)) Un.
Proof.
intros Un l l_neq Hl k k_lb.
pose (eps := (k - 1) / k * Rabs l).
assert (eps_pos : 0 < eps).
 unfold eps ; apply Rmult_lt_0_compat ;
 [unfold Rdiv ; apply Rlt_mult_inv_pos ;
 [ | apply Rlt_trans with 1] | apply Rabs_pos_lt] ;
 intuition ; lra.
destruct (Hl _ eps_pos) as [N HN] ; exists N ; intros n.
apply Rle_lt_trans with (Rabs l - eps).
unfold eps, Rdiv ; right ; field ; apply Rgt_not_eq ;
 apply Rlt_trans with 1 ; lra.
apply R_dist_gt_r ; apply HN ; intuition.
Qed.

(* TODO: move *)
Lemma Rseq_cv_pos_infty_le_compat : forall Un Vn,
  (forall n, Un n <= Vn n) -> Rseq_cv_pos_infty Un ->
  Rseq_cv_pos_infty Vn.
Proof.
intros Un Vn Hle Un_inf M ; destruct (Un_inf M) as [N HN] ; exists N ;
 intros n n_lb ; apply Rlt_le_trans with (Un n) ;
 [apply HN | apply Hle] ; assumption.
Qed.

Lemma Rpser_alembert_prelim2 : forall (An : nat -> R) (M : R),
       0 < M -> (forall n : nat, An n <> 0) ->
       Rseq_eventually (fun Un => Rseq_bound Un M) (fun n => (An (S n) / An n)) ->
       forall r, Rabs r < / M -> Cv_radius_weak An r.
Proof.
intros An M M_pos An_neq An_frac_event r r_bd.
destruct An_frac_event as [N HN].
 assert (Rho : Cv_radius_weak (Rseq_shifts An N) r).
  apply Rpser_alembert_prelim with M.
  assumption.
  intro n ; apply An_neq.
  intro n ; unfold Rseq_shifts ; replace (N + S n)%nat
   with (S (N + n)) by intuition ; apply HN.
  assumption.
  rewrite Cv_radius_weak_shifts_compat.
 destruct Rho as [T HT] ; exists T ; intros u Hu ; destruct Hu as [n Hn] ;
 rewrite Hn ; apply HT ; exists n ; reflexivity.
Qed.

Lemma Rpser_alembert_weak : forall (An : Rseq) (lambda : R),
  lambda <> 0 -> (forall n : nat, An n <> 0) ->
  Rseq_cv (fun n : nat => Rabs (An (S n) / An n)) lambda -> forall r,
  Rabs r < / lambda -> Cv_radius_weak An r.
Proof.
intros An lam lam_neq An_neq An_frac_cv r r_bd.
 assert (lam_pos : 0 < lam).
  apply Rle_neq_lt ; [| symmetry ; exact lam_neq].
  eapply Rseq_positive_limit ; [| eassumption] ; intro n ; compute ;
  (* TODO: BUG? [; simpl] does not reduce [(fun n0 => ...) n] but [. simpl.]
  does. Using [compute] to avoid the problem. *)
  apply Rabs_pos.
 assert (middle_lb := proj1 (middle_is_in_the_middle _ _ r_bd)).
 assert (middle_ub := proj2 (middle_is_in_the_middle _ _ r_bd)).
 assert (middle_pos : 0 < middle (Rabs r) (/ lam)).
  apply Rle_lt_trans with (Rabs r) ; [apply Rabs_pos | assumption].
 pose (eps := (/ (middle (Rabs r) (/ lam)) - lam)%R).
 assert (eps_pos : 0 < eps).
  apply Rgt_minus ; rewrite <- Rinv_involutive.
  apply Rinv_lt_contravar.
  apply Rmult_lt_0_compat ; [| apply Rinv_0_lt_compat] ; assumption.
  assumption.
  apply Rgt_not_eq ; assumption.
 apply Rpser_alembert_prelim2 with (lam + eps)%R.
 lra.
 apply An_neq.
 destruct (An_frac_cv (/ (middle (Rabs r) (/ lam)) - lam))%R as [N HN].
 assumption.
 exists N ; intro n ; unfold Rseq_shifts.
 transitivity (lam + (Rabs (An (S (N + n)) / An (N + n)%nat) - lam))%R.
 right ; ring.
 apply Rplus_le_compat_l ; apply Rle_trans with
   (R_dist (Rabs (An (S (N + n)) / An (N + n)%nat)) lam)%R.
 apply RRle_abs.
 left ; apply HN ; intuition.
 replace (lam + eps)%R with (/ (middle (Rabs r) (/ lam)))%R.
 rewrite Rinv_involutive ; [| apply Rgt_not_eq] ; assumption.
 unfold eps ; ring.
Qed.

Lemma Rpser_alembert_weak_reciprocal : forall (An : nat -> R) (lambda : R),
       lambda <> 0 -> (forall n : nat, An n <> 0) ->
       Rseq_cv (fun n => Rabs (An (S n) / An n)) lambda -> forall r,
       / lambda < Rabs r -> ~ Cv_radius_weak An r.
Proof.
intros An lam lam_neq An_neq An_frac_ub r r_ld Hf ;
pose (l' := middle 1 (Rabs r * lam)).
assert (lam_pos : 0 < lam).
 apply Rle_neq_lt ; [| symmetry ; exact lam_neq].
 eapply Rseq_positive_limit ; [| eassumption] ; intro n ; compute ;
  (* TODO: BUG? [; simpl] does not reduce [(fun n0 => ...) n] but [. simpl.]
  does. Using [compute] to avoid the problem. *)
 apply Rabs_pos.
assert (rlam_lb : 1 < Rabs r * lam).
 apply Rle_lt_trans with (/ lam * lam).
 right ; field ; apply Rgt_not_eq ; assumption.
 apply Rmult_lt_compat_r ; assumption.
assert (lam_l'_pos : 0 <= lam / l').
 apply Rle_mult_inv_pos ; [| apply Rlt_trans with 1;
 [| apply middle_is_in_the_middle]] ; lra.
destruct (Rseq_cv_bounded _ _ lam_neq An_frac_ub l') as [N H].
 apply middle_is_in_the_middle ; assumption.
assert (HN : forall n, Rabs (An N) * (lam / l') ^ n <= Rabs (An (N + n)%nat)).
 clear -H lam_pos lam_l'_pos An_neq ; intro n ; induction n.
  simpl ; rewrite plus_0_r, Rmult_1_r ; reflexivity.
  apply Rle_trans with (Rabs (An N) * (lam / l') ^ n * (lam / l')).
  right ; simpl ; ring.
  apply Rle_trans with (Rabs (An (N + n)%nat) * (lam / l')).
  apply Rmult_le_compat_r ; assumption.
  apply Rle_trans with (Rabs (An (N + n)%nat) *
   Rabs (An (N + S n)%nat) * / Rabs (An (N + n)%nat)).
  rewrite Rmult_assoc ; apply Rmult_le_compat_l ; [apply Rabs_pos |].
  rewrite <- Rabs_Rinv, <- Rabs_mult ; [| apply An_neq].
  rewrite <- (Rabs_pos_eq lam), <- (Rabs_Rabsolu ((An (N + S n)%nat)
   * / An (N + n)%nat)), <-plus_n_Sm ; left ; [apply H | assumption].
  right ; field ; apply Rabs_no_R0 ; apply An_neq.
clear H.
assert (r_gt_1: 1 < (lam / l') * Rabs r).
 apply Rlt_le_trans with (Rabs r * lam * / l') ; [| right ; unfold Rdiv ; ring].
 apply Rlt_1_mult_inv ; [apply Rlt_trans with 1 ; [lra |]|] ;
 apply middle_is_in_the_middle ; assumption.
assert (Hinfty : Rseq_cv_pos_infty (gt_abs_pser An r)).
 apply Rseq_cv_pos_infty_shifts_compat with N.
 apply Rseq_cv_pos_infty_le_compat with (Rseq_mult (Rseq_constant (Rabs (An N) * Rabs r ^ N))
  (Rseq_pow (lam / l' * Rabs r))).
 intro n ; unfold Rseq_pow, Rseq_shifts, Rseq_mult, Rseq_constant,
 gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
 apply Rle_trans with ((Rabs (An N) * (lam / l') ^ n) * Rabs r ^ (n + N)).
 right; repeat rewrite Rmult_assoc ; apply Rmult_eq_compat_l.
 rewrite Rpow_mult_distr, pow_add ; ring.
 rewrite Rabs_mult, RPow_abs ; rewrite plus_comm ; apply Rmult_le_compat_r ;
 [apply Rabs_pos |] ; apply HN.
 apply Rseq_cv_finite_pos_mult_pos_infty_r with (Rabs (An N) * Rabs r ^ N).
 rewrite RPow_abs, <- Rabs_mult ; apply Rabs_pos_lt ;
 apply Rmult_integral_contrapositive_currified ; [apply An_neq | apply pow_nonzero].
 intro r_eq ; rewrite r_eq, Rabs_R0, Rmult_0_l in rlam_lb ; clear -rlam_lb ; lra.
 apply Rseq_constant_cv.
 apply Rseq_pow_gt_1_cv ; assumption.
destruct Hf as [B HB].
destruct (Hinfty B) as [M HM].
apply (Rlt_irrefl (gt_abs_pser An r M)).
apply Rle_lt_trans with B ; [apply HB ; exists M | apply HM] ; auto.
Qed.

Theorem Rpser_alembert_weak_eventually : forall (An : Rseq) (lambda : R),
  lambda <> 0 -> Rseq_eventually (fun un => forall n : nat, un n <> 0) An ->
  Rseq_cv (fun n : nat => Rabs (An (S n) / An n)) lambda -> forall r,
  Rabs r < / lambda -> Cv_radius_weak An r.
Proof.
intros An lam lam_neq [N An_neq] An_frac_cv r r_bd.
 rewrite Cv_radius_weak_shifts_compat ;
 apply Rpser_alembert_weak with lam ; try (assumption || apply An_neq).
 apply Rseq_cv_eq_compat with (Rseq_shifts (fun n => Rabs (An (S n) / An n)) N).
 intro n ; unfold Rseq_shifts ; rewrite plus_n_Sm ; reflexivity.
 apply Rseq_cv_shifts_compat_reciprocal ; assumption.
Qed.

Theorem Rpser_alembert_weak_reciprocal_eventually : forall (An : Rseq) (lambda : R),
  lambda <> 0 -> Rseq_eventually (fun un => forall n : nat, un n <> 0) An ->
  Rseq_cv (fun n : nat => Rabs (An (S n) / An n)) lambda -> forall r,
  / lambda < Rabs r -> ~ Cv_radius_weak An r.
Proof.
intros An lam lam_neq [N An_neq] An_frac_cv r r_bd Hf.
 assert (H := proj1 (Cv_radius_weak_shifts_compat _ _ N) Hf).
 revert H.
 apply Rpser_alembert_weak_reciprocal with lam ; try assumption.
 apply Rseq_cv_eq_compat with (Rseq_shifts (fun n => Rabs (An (S n) / An n)) N).
 intro n ; unfold Rseq_shifts ; rewrite plus_n_Sm ; reflexivity.
 apply Rseq_cv_shifts_compat_reciprocal ; assumption.
Qed.

Lemma Rpser_alembert_finite : forall (An : Rseq) (lambda : R),
  lambda <> 0 -> (forall n, An n <> 0) ->
  Rseq_cv (| (Rseq_shift An / An) |) lambda ->
  finite_cv_radius An (/ lambda).
Proof.
intros An lam lam_neq An_neq An_l.
assert (lam_pos : 0 < / lam).
 apply Rinv_0_lt_compat ; apply Rle_neq_lt ; [| symmetry ; exact lam_neq].
 eapply Rseq_positive_limit ; [| eassumption] ; intro n ; compute ;
  (* TODO: BUG? [; simpl] does not reduce [(fun n0 => ...) n] but [. simpl.]
  does. Using [compute] to avoid the problem. *)
 apply Rabs_pos.
split.
 intros r' [r'_pos r'_bd] ; apply Rpser_alembert_weak with lam ;
  [| | | rewrite Rabs_pos_eq] ; assumption.
 intros r' r'_lb ; apply Rpser_alembert_weak_reciprocal with lam ;
  [| | | rewrite Rabs_pos_eq ; [| left ; apply Rlt_trans with (/ lam)] ] ; assumption.
Qed.

Lemma Rpser_alembert_finite_eventually : forall (An : Rseq) (lambda : R),
  lambda <> 0 -> Rseq_eventually (fun un => forall n, un n <> 0) An ->
  Rseq_cv (fun n => Rabs (An (S n) / An n)) lambda ->
  finite_cv_radius An (/ lambda).
Proof.
intros An lam lam_neq An_neq An_l.
assert (lam_pos : 0 < / lam).
 apply Rinv_0_lt_compat ; apply Rle_neq_lt ; [| symmetry ; exact lam_neq].
 eapply Rseq_positive_limit ; [| eassumption] ; intro n ; compute ;
  (* TODO: BUG? [; simpl] does not reduce [(fun n0 => ...) n] but [. simpl.]
  does. Using [compute] to avoid the problem. *)
 apply Rabs_pos.
split.
 intros r' [r'_pos r'_bd] ; apply Rpser_alembert_weak_eventually with lam ;
  [| | | rewrite Rabs_pos_eq] ; assumption.
 intros r' r'_lb ; apply Rpser_alembert_weak_reciprocal_eventually with lam ;
  [| | | rewrite Rabs_pos_eq ; [| left ; apply Rlt_trans with (/ lam)] ] ; assumption.
Qed.

(* TODO: move *)
Lemma max_explicit : forall m n, { p | max m n = (m + p)%nat}.
Proof.
intros m n ; destruct (lt_dec m n) ;
 [exists (n - m)%nat | exists 0%nat] ;
 destruct (max_spec m n) ; lia.
Qed.

Lemma Rpser_alembert_infinite : forall (An : Rseq),
       Rseq_eventually (fun un => forall n, un n <> 0) An ->
       Rseq_cv (fun n : nat => Rabs (An (S n) / An n)) R0 ->
       infinite_cv_radius An.
Proof.
intros An [N1 HN1] An_frac_0 r.
assert (eps_pos : 0 < /(Rabs r + 1)).
 apply Rinv_0_lt_compat ; apply Rplus_le_lt_0_compat ; [apply Rabs_pos |
 apply Rlt_0_1].
destruct (An_frac_0 (/ (Rabs r + 1))%R eps_pos) as [N2 HN2].
rewrite (Cv_radius_weak_shifts_compat _ _ (max N1 N2)).
apply Rpser_alembert_prelim with (/ (Rabs r + 1)).
assumption.
intro n ; unfold Rseq_shifts.
destruct (max_explicit N1 N2) as [p Hp] ; rewrite Hp, <- plus_assoc ; apply HN1.
intro n ; unfold Rseq_shifts ; rewrite max_comm ;
 destruct (max_explicit N2 N1) as [p Hp] ; rewrite Hp, <- Rabs_Rabsolu ;
 replace (N2 + p + S n)%nat with (S (N2 + p + n)) by ring ;
 assert (Hyp := HN2 (N2 + p + n)%nat) ; unfold R_dist, Rminus in Hyp ;
 change R0 with (IZR 0) in Hyp;
 rewrite Ropp_0, Rplus_0_r in Hyp ; left ; apply Hyp.
lia.
rewrite Rinv_involutive ; [intuition |].
apply Rgt_not_eq ; apply Rlt_le_trans with (0 + 1) ;
 [| apply Rplus_le_compat_r ; apply Rabs_pos] ; intuition.
Qed.

(** A kind of reciprocal for the Abel's lemma*)
Lemma Rpser_bound_criteria : forall (An : nat -> R) (x l : R),
    Rpser An x l -> Cv_radius_weak An x.
Proof.
intros An x l Hxl.
 destruct (Hxl 1) as [N HN] ; [lra |] ; unfold R_dist in HN.
 assert (H1: forall n, (S N <= n)%nat -> gt_abs_pser An x n <= Rmax 2 (Rabs (An O))).
  intros n n_lb ; destruct n ; unfold gt_abs_pser, Rseq_abs.
   unfold gt_pser, Rseq_mult ; simpl ; rewrite Rmult_1_r ; apply RmaxLess2.
   transitivity (Rabs ((Rseq_pps An x (S n) - l) - (Rseq_pps An x n - l))).
    right ; rewrite Rseq_pps_simpl ; apply Rabs_eq_compat ;
    unfold gt_pser, Rseq_mult ; ring.
   transitivity (Rabs (Rseq_pps An x (S n) - l) + Rabs (- (Rseq_pps An x n - l))).
    apply Rabs_triang.
   transitivity 2 ; [| apply RmaxLess1] ; rewrite Rabs_Ropp.
    apply Rplus_le_compat ; left ; apply HN ; lia.
   destruct (Rseq_partial_bound (gt_pser An x) (S N)) as (B,HB).
   exists (Rmax B (Rmax 2 (Rabs (An O)))).
   intros y [i Hi] ; subst ; destruct (le_lt_dec i (S N)) as [Hi_b | Hi_b].
   apply Rle_trans with B ; [apply HB | apply RmaxLess1] ; intuition.
   apply Rle_trans with (Rmax 2 (Rabs (An O))) ; [apply H1 | apply RmaxLess2] ; intuition.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

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

Require Import Ensembles.

Section Ensembles_finis.
  Variable U : Type.

  Inductive Finite : Ensemble U -> Prop :=
    | Empty_is_finite : Finite (Empty_set U)
    | Union_is_finite :
      forall A:Ensemble U,
        Finite A -> forall x:U, ~ In U A x -> Finite (Add U A x).

  Inductive cardinal : Ensemble U -> nat -> Prop :=
    | card_empty : cardinal (Empty_set U) 0
    | card_add :
      forall (A:Ensemble U) (n:nat),
        cardinal A n -> forall x:U, ~ In U A x -> cardinal (Add U A x) (S n).

End Ensembles_finis.

Hint Resolve Empty_is_finite Union_is_finite: sets v62.
Hint Resolve card_empty card_add: sets v62.

Require Import Constructive_sets.

Section Ensembles_finis_facts.
  Variable U : Type.

  Lemma cardinal_invert :
    forall (X:Ensemble U) (p:nat),
      cardinal U X p ->
      match p with
	| O => X = Empty_set U
	| S n =>
          exists A : _,
            (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n)
      end.
  Proof.
    induction 1; simpl in |- *; auto.
    exists A; exists x; auto.
  Qed.

  Lemma cardinal_elim :
    forall (X:Ensemble U) (p:nat),
      cardinal U X p ->
      match p with
	| O => X = Empty_set U
	| S n => Inhabited U X
      end.
  Proof.
    intros X p C; elim C; simpl in |- *; trivial with sets.
  Qed.

End Ensembles_finis_facts.


Require Import Category.Lib.
Require Import Category.Theory.Category.

Generalizable All Variables.

Import EqNotations.

(* A discrete category has no arrows except for identity morphisms. *)

Definition Discrete (C : Category) :=
  (* jww (2017-06-02): Equality is too much here. *)
  ∀ x y (f : x ~> y), ∃ H : x = y, f ≈ rew H in id.


(***************************************************************************
 * Tracing sharing in an imperative pure calculus: garbage elimination
 *
 ***************************************************************************)

From Equations Require Import Equations.
Set Equations Transparent.
Unset Equations WithK.
Require Import Equations.Subterm.
Require Import PeanoNat.
Require Import NatMisc.
Require Import Fin.
Require Import Metatheory.
Require Import TypedLanguageSimpl.
Require Import List.

(* Require Import TestConnectedP. *)

(*
  First define the predicate [connectedDecs] such that:
      [connectedDecs ds e] if [(EBlk ann ds e)] does not
      contain unreachable local variables
*)
(* [connectedVar ds xs x] asserts that the variable [x] is connected
   to [xs] via the definitions [ds], meaning that either [x] in [xs]
   or there is a declaration [Dec dt y e] in [ds] such that
   [connectedVar ds xs y] and [x] is free variables of [e]
*)

Inductive connectedVar: (list dec) -> (list var) -> var -> Prop :=
  | is_def      : forall (ds : list dec)
                         (xs  : list var)
                         (x   : var),
                         (In x xs) ->
                         (connectedVar ds xs x)
  | is_free_def : forall (ds : list dec)
                         (xs  : list var)
                         (x y : var)
                         (dt : decTy)
                         (e   : exp),
                         (* if there is a declaration [Dec dt x e] in [ds]*)
                         (In (Dec dt x e) ds) ->
                         (* such that [y] is in the free variables of [e] *)
                         (In y (free_var e)) ->
                         (* and [x] is connected to [xs] via [ds]*)
                         (connectedVar ds xs x) ->
                         (* then [y] is connected to [xs] via [ds] *)
                         (connectedVar ds xs y).

(* we have to show decidability of connected
Lemma connectedDecidable (dvs : list dec) (xs : list var) (x: var)
      {connectedVar dvs xs x} + {~(connectedVar dvs xs x)}.
Proof.
  (* we have decidability of In, so first split by
    In x xs *)
  induction (In_atom_list_dec x xs).
  - left. exact (is_def dvs xs x a).
  - admit. (* won't work ... *)
Admitted.
*)

(* [connectedDecs ds e] asserts that for all [Dec dt x ex] in [ds]
   [x] is connected to the free variables of [e] via the
   definitions on [ds]
*)

Inductive connectedDecs:(list dec) -> (list var) -> Prop :=
  | is_conn : forall  (ds : list dec)
              (x: var)
              (xs  : list var),
              (ok_decs ds) ->
              (In x (dec_vars ds) ) ->
              (connectedVar ds xs x) ->
              (connectedDecs ds xs).

(* [noGarbageBlock e] asserts that [e] is a block [(EBlk ann decs eb)]
   and all the variable declared in [decs] are connected to the result of the
   block
*)
Inductive noGarbage: exp -> Prop :=
  | no_garbage : forall (ann: blAnnotation)
              (eb: exp)
              (ds  : list dec),
              (connectedDecs ds (free_var eb) ) ->
              (noGarbage (EBlk ann ds eb)).

Fixpoint dec_FVes (ds:list dec): list (var * (list var)) :=
   match ds with
   | nil              => nil
   | (Dec dt x e)::tl => (x,(free_var e))::(dec_FVes tl)
   end.

Instance wf_lexprod_nat : WellFounded (lexprod nat nat lt lt) :=
         wellfounded_lexprod nat nat lt lt lt_wf lt_wf.

Equations removeNth {A : Type} {n : nat}
                   (x : Fin.t (S n)) (v : Vector.t A (S n)) : Vector.t
A n :=
 removeNth {n:=0}     _      _  := Vector.nil;
 removeNth {n:=(S _)} F1     vs := Vector.tl vs;
 removeNth {n:=(S _)} (FS x) vs := Vector.cons (Vector.hd vs) (removeNth x (Vector.tl vs)).

Obligation Tactic := idtac.

Equations connected' (dl n : nat)
                     (ds : Vector.t (var * (list var)) dl)
                     (Y : list var) : (list (var * list var)) :=
  connected' dl n ds Y by rec (dl, n) (lexprod nat nat lt lt) :=
  connected' 0  _ _ _ := [];
  connected' _ 0 _ _  := [];
  connected' (S dl) (S n) ds Y with (leDicho n dl) := {
                 | (inr dlLtn) := connected' (S dl) (S dl) ds Y;
                 | (inl nLeDl (* n <= dl *))
           with (List.in_dec eq_atom_dec (fst (Vector.nth_order ds (leNS nLeDl))) Y) := {
                 | (left  inY ) :=
                    List.cons (Vector.nth_order ds (leNS nLeDl))
                       (connected' dl dl (removeNth (Fin.of_nat_lt (leNS nLeDl)) ds)
                                         ((snd (Vector.nth_order ds (leNS nLeDl)) ++ Y))) ;
                 | (right nInY) :=
                              (connected' (S dl) n ds Y) }}.
Next Obligation.
  constructor 2.
  apply leNS.
  exact dlLtn.
Defined.

Definition connected (ds : list (var * (list var))) (Y : list var) : list var :=
  (dom (connected' (length ds) (length ds) (Vector.of_list ds) Y)).

Fixpoint split_decs (ds:list dec)(X : list var) {struct ds}:((list dec)*(list dec)) :=
  let Y:= ( connected (dec_FVes ds) X) in
   match ds with
   | nil              => (nil,nil)
   | (Dec dt x e)::tl =>
   (let (conn_decs,garb_decs):=(split_decs tl X) in
      (if (is_in x Y) then ((Dec dt x e)::conn_decs,garb_decs)
      else (conn_decs,(Dec dt x e)::garb_decs)
      )
      )
   end.

Definition remove_Garbage e:=
  match e with
   | (EBlk ann ds eb) =>
         (let (ds1,ds2):=(split_decs ds (free_var eb))
          in
          (EBlk ann ds1 eb)
         )
   | _ => e
   end.

Lemma split_dec_Ok:
   (forall ds X x ds1 ds2,
     (split_decs ds X =(ds1,ds2)) -> (
       ((In x (dec_vars ds1))->(connectedVar ds X x) )
        /\

       ((In x (dec_vars ds2))->~(connectedVar ds X x) )
       )
   ).
Proof.
Admitted.

Theorem garbage_elim:
   (forall e ann ds eb,
     (e=(EBlk ann ds eb))->(noGarbage (remove_Garbage e))
   ).
Proof.
Admitted.


Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.
Require Import Logic.lib.PTree.

Section StructOfCancel.
Context {Texpr : Type}
        {f1 : Texpr -> Texpr -> Texpr}
        {f2 : Texpr -> Texpr -> Texpr}
        {e : Texpr}.

Inductive expr_deep : Type :=
  | impp_deep : expr_deep -> expr_deep -> expr_deep
  | sepcon_deep : expr_deep -> expr_deep -> expr_deep
  | emp_deep : expr_deep
  | varp_deep : nat -> expr_deep.

Fixpoint beq e1 e2 :=
  match e1, e2 with
  | emp_deep, emp_deep => true
  | varp_deep x, varp_deep y => EqNat.beq_nat x y
  | sepcon_deep p11 p12, sepcon_deep p21 p22 => andb (beq p11 p21) (beq p12 p22)
  | impp_deep p11 p12, impp_deep p21 p22 => andb (beq p11 p21) (beq p12 p22)
  | _, _ => false
  end.

Inductive tree_pos : Type :=
  | var_pos : Texpr -> option positive -> tree_pos
  | sepcon_pos : tree_pos -> tree_pos -> tree_pos.

Fixpoint cancel_mark_context dep q tep key : tree_pos * bool:=
  match dep, tep with
  | sepcon_deep dp dq, sepcon_pos tp tq =>
    match cancel_mark_context dp q tp key with
    | (tp', true) => ((sepcon_pos tp' tq), true)
    | (tp', false) =>
      match cancel_mark_context dq q tq key with
      | (tq', true) => ((sepcon_pos tp tq'), true)
      | (tq', false) => (tep, false)
      end
    end
  | p, (var_pos sp o) =>
    match (beq p q) with
    | true =>
      match o with
      | None => ((var_pos sp (Some key)), true)
      | _ => (tep, false)
      end
    | false => (tep, false)
    end
  | _, _ => (tep, false)
  end.

Fixpoint cancel_mark' dep deq tep teq key : tree_pos * tree_pos * positive :=
  match deq, teq with
  | sepcon_deep dp dq, sepcon_pos tp tq =>
    match (cancel_mark' dep dp tep tp key) with
    | (tep', tp', key') =>
      match (cancel_mark' dep dq tep' tq key') with
      | (tep'', tq', key'') => (tep'', sepcon_pos tp' tq', key'')
      end
    end
  | q, (var_pos sq o) =>
    match (cancel_mark_context dep q tep key) with
    | (tep', true) => (tep', (var_pos sq (Some key)), Pos.succ key)
    | (tep', false) => (tep', var_pos sq None, key)
    end
  | _, _ => (tep, teq, key)
  end.

Definition cancel_mark dep deq tep teq : tree_pos * tree_pos :=
  match (cancel_mark' dep deq tep teq xH) with
  | (tep', teq', key') => (tep', teq')
  end.

Fixpoint unmark_sort' tep : option Texpr :=
  match tep with
  | sepcon_pos tp tq =>
    match unmark_sort' tp with
    | None => unmark_sort' tq
    | Some sp =>
      match unmark_sort' tq with
      | None => Some sp
      | Some sq => Some (f1 sp sq)
      end
    end
  | var_pos sq o =>
    match o with
    | None => Some sq
    | _ => None
    end
  end.
Definition unmark_sort tep : Texpr :=
  match unmark_sort' tep with
  | Some sp => sp
  | None => e
  end.

Definition cancel_different tep teq : Texpr :=
  f2 (unmark_sort tep) (unmark_sort teq).

Fixpoint mark_sort' tep m : PTree.tree Texpr :=
  match tep with
  | sepcon_pos tp tq =>
    match mark_sort' tp m with
    | m' => mark_sort' tq m'
    end
  | var_pos sq o =>
    match o with
    | None => m
    | Some pos =>
      match PTree.get_rec Texpr pos m with
      | None => PTree.set_rec Texpr pos sq m
      | Some sp => PTree.set_rec Texpr pos (f1 sp sq) m
      end
    end
  end.
Definition mark_sort tep : PTree.tree Texpr :=
  mark_sort' tep PTree.empty.

Definition cancel_same tep teq : Prop :=
  mark_sort tep = mark_sort teq.

Fixpoint restore' tep : Texpr :=
  match tep with
  | sepcon_pos tp tq => f1 (restore' tp) (restore' tq)
  | var_pos sp o => sp
  end.
Definition restore tep teq : Texpr :=
  f2 (restore' tep ) (restore' teq ).

End StructOfCancel.


Require Export Db.Spec.
Require Export Db.WellScoping.

Require Import Coq.micromega.Lia.
Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.Contraction.

(** ** Simply typed terms. *)
Inductive Tm : Set :=
  | var (i: Ix)
  | abs (τ: Ty) (t: Tm)
  | app (t₁ t₂: Tm)
  | unit
  | true
  | false
  | ite (t₁ t₂ t₃: Tm)
  | pair (t₁ t₂: Tm)
  | proj₁ (t: Tm)
  | proj₂ (t: Tm)
  | inl (t: Tm)
  | inr (t: Tm)
  | caseof (t₁ t₂ t₃: Tm)
  | seq (t₁ t₂: Tm).

Section WellScoping.

  (* Keep this in a section so that the notation for the ws type-class is only
     locally overwritten. *)
  Inductive wsTm (γ: Dom) : Tm → Prop :=
    | WsVar {i}           : γ ∋ i → ⟨ γ ⊢ var i ⟩
    | WsAbs {τ t}         : ⟨ S γ ⊢ t ⟩ → ⟨ γ ⊢ abs τ t ⟩
    | WsApp {t₁ t₂}       : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ app t₁ t₂ ⟩
    | WsUnit              : ⟨ γ ⊢ unit ⟩
    | WsTrue              : ⟨ γ ⊢ true ⟩
    | WsFalse             : ⟨ γ ⊢ false ⟩
    | WsIte {t₁ t₂ t₃}    : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ →
                            ⟨ γ ⊢ t₃ ⟩ → ⟨ γ ⊢ ite t₁ t₂ t₃ ⟩
    | WsProj1 {t}         : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ proj₁ t ⟩
    | WsProj2 {t}         : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ proj₂ t ⟩
    | WsPair {t₁ t₂}      : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ pair t₁ t₂ ⟩
    | WsInj₁ {t}          : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ inl t ⟩
    | WsInj₂ {t}          : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ inr t ⟩
    | WsCaseof {t₁ t₂ t₃} : ⟨ γ ⊢ t₁ ⟩ → ⟨ S γ ⊢ t₂ ⟩ →
                            ⟨ S γ ⊢ t₃ ⟩ → ⟨ γ ⊢ caseof t₁ t₂ t₃ ⟩
    | WsSeq {t₁ t₂}       : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ seq t₁ t₂ ⟩
  where "⟨ γ ⊢ t ⟩" := (wsTm γ t).

End WellScoping.
#[export]
Instance WsTm : Ws Tm := wsTm.

(** ** Program contexts *)

Inductive PCtx : Set :=
  | phole
  | pabs (T: Ty) (C: PCtx)
  | papp₁ (C: PCtx) (t: Tm)
  | papp₂ (t: Tm) (C: PCtx)
  | pite₁ (C: PCtx) (t₂ t₃: Tm)
  | pite₂ (t₁: Tm) (C: PCtx) (t₃: Tm)
  | pite₃ (t₁ t₂: Tm) (C: PCtx)
  | ppair₁ (C: PCtx) (t: Tm)
  | ppair₂ (t: Tm) (C: PCtx)
  | pproj₁ (C: PCtx)
  | pproj₂ (C: PCtx)
  | pinl (C: PCtx)
  | pinr (C: PCtx)
  | pcaseof₁ (C: PCtx) (t₂ t₃: Tm)
  | pcaseof₂ (t₁: Tm) (C: PCtx) (t₃: Tm)
  | pcaseof₃ (t₁ t₂: Tm) (C: PCtx)
  | pseq₁ (C: PCtx) (t: Tm)
  | pseq₂ (t: Tm) (C: PCtx).

Fixpoint pctx_app (t₀: Tm) (C: PCtx) {struct C} : Tm :=
  match C with
    | phole            => t₀
    | pabs T C         => abs T (pctx_app t₀ C)
    | papp₁ C t        => app (pctx_app t₀ C) t
    | papp₂ t C        => app t (pctx_app t₀ C)
    | pite₁ C t₂ t₃    => ite (pctx_app t₀ C) t₂ t₃
    | pite₂ t₁ C t₃    => ite t₁ (pctx_app t₀ C) t₃
    | pite₃ t₁ t₂ C    => ite t₁ t₂ (pctx_app t₀ C)
    | ppair₁ C t       => pair (pctx_app t₀ C) t
    | ppair₂ t C       => pair t (pctx_app t₀ C)
    | pproj₁ C         => proj₁ (pctx_app t₀ C)
    | pproj₂ C         => proj₂ (pctx_app t₀ C)
    | pinl C           => inl (pctx_app t₀ C)
    | pinr C           => inr (pctx_app t₀ C)
    | pcaseof₁ C t₁ t₂ => caseof (pctx_app t₀ C) t₁ t₂
    | pcaseof₂ t₁ C t₂ => caseof t₁ (pctx_app t₀ C) t₂
    | pcaseof₃ t₁ t₂ C => caseof t₁ t₂ (pctx_app t₀ C)
    (* | pfold C => fold_ (pctx_app t₀ C) *)
    (* | punfold C => unfold_ (pctx_app t₀ C) *)
    | pseq₁ C t        => seq (pctx_app t₀ C) t
    | pseq₂ t C        => seq t (pctx_app t₀ C)
  end.

Fixpoint pctx_cat (C₀ C: PCtx) {struct C} : PCtx :=
  match C with
    | phole            => C₀
    | pabs T C         => pabs T (pctx_cat C₀ C)
    | papp₁ C t        => papp₁ (pctx_cat C₀ C) t
    | papp₂ t C        => papp₂ t (pctx_cat C₀ C)
    | pite₁ C t₂ t₃    => pite₁ (pctx_cat C₀ C) t₂ t₃
    | pite₂ t₁ C t₃    => pite₂ t₁ (pctx_cat C₀ C) t₃
    | pite₃ t₁ t₂ C    => pite₃ t₁ t₂ (pctx_cat C₀ C)
    | ppair₁ C t       => ppair₁ (pctx_cat C₀ C) t
    | ppair₂ t C       => ppair₂ t (pctx_cat C₀ C)
    | pproj₁ C         => pproj₁ (pctx_cat C₀ C)
    | pproj₂ C         => pproj₂ (pctx_cat C₀ C)
    | pinl C           => pinl (pctx_cat C₀ C)
    | pinr C           => pinr (pctx_cat C₀ C)
    | pcaseof₁ C t₁ t₂ => pcaseof₁ (pctx_cat C₀ C) t₁ t₂
    | pcaseof₂ t₁ C t₂ => pcaseof₂ t₁ (pctx_cat C₀ C) t₂
    | pcaseof₃ t₁ t₂ C => pcaseof₃ t₁ t₂ (pctx_cat C₀ C)
    | pseq₁ C t        => pseq₁ (pctx_cat C₀ C) t
    | pseq₂ t C        => pseq₂ t (pctx_cat C₀ C)
  end.

Section Application.

  Context {Y: Type}.
  Context {vrY: Vr Y}.
  Context {wkY: Wk Y}.
  Context {vrTm: Vr Tm}.
  Context {liftYTm: Lift Y Tm}.

  Fixpoint apTm (ζ: Sub Y) (t: Tm) {struct t} : Tm :=
    match t with
      | var x           => lift (ζ x)
      | abs T t₂        => abs T (apTm (ζ↑) t₂)
      | app t₁ t₂       => app (apTm ζ t₁) (apTm ζ t₂)
      | unit            => unit
      | true            => true
      | false           => false
      | ite t₁ t₂ t₃    => ite (apTm ζ t₁) (apTm ζ t₂) (apTm ζ t₃)
      | pair t₁ t₂      => pair (apTm ζ t₁) (apTm ζ t₂)
      | proj₁ t         => proj₁ (apTm ζ t)
      | proj₂ t         => proj₂ (apTm ζ t)
      | inl t           => inl (apTm ζ t)
      | inr t           => inr (apTm ζ t)
      | caseof t₁ t₂ t₃ => caseof (apTm ζ t₁) (apTm (ζ↑) t₂) (apTm (ζ↑) t₃)
      | seq t₁ t₂       => seq (apTm ζ t₁) (apTm ζ t₂)
    end.

  Global Arguments apTm ζ !t.

End Application.

Ltac crushStlcSyntaxMatchH :=
  match goal with
    | [ H: S _ = S _             |- _ ] => apply eq_add_S in H

    | [ H: var _        = var _        |- _ ] => inversion H; clear H
    | [ H: abs _ _      = abs _ _      |- _ ] => inversion H; clear H
    | [ H: app _ _      = app _ _      |- _ ] => inversion H; clear H
    | [ H: pair _ _     = pair _ _     |- _ ] => inversion H; clear H
    | [ H: ite _ _ _    = ite _ _ _    |- _ ] => inversion H; clear H
    | [ H: proj₁ _      = proj₁ _      |- _ ] => inversion H; clear H
    | [ H: proj₂ _      = proj₂ _      |- _ ] => inversion H; clear H
    | [ H: inl _        = inl _        |- _ ] => inversion H; clear H
    | [ H: inr _        = inr _        |- _ ] => inversion H; clear H
    | [ H: caseof _ _ _ = caseof _ _ _ |- _ ] => inversion H; clear H
    | [ H: seq _ _      = seq _ _      |- _ ] => inversion H; clear H

    | [ H: inl _       = inr _         |- _ ] => inversion H
    | [ H: inr _       = inl _         |- _ ] => inversion H

    | [ H: unit        = abs _ _       |- _ ] => inversion H
    | [ H: true        = abs _ _       |- _ ] => inversion H
    | [ H: false       = abs _ _       |- _ ] => inversion H
    | [ H: pair _ _    = abs _ _       |- _ ] => inversion H
    | [ H: inl _       = abs _ _       |- _ ] => inversion H
    | [ H: inr _       = abs _ _       |- _ ] => inversion H

    | [ |- S _          = S _          ] => f_equal
    | [ |- var _        = var _        ] => f_equal
    | [ |- abs _ _      = abs _ _      ] => f_equal
    | [ |- app _ _      = app _ _      ] => f_equal
    | [ |- unit         = unit         ] => reflexivity
    | [ |- true         = true         ] => reflexivity
    | [ |- false        = false        ] => reflexivity
    | [ |- ite _ _ _    = ite _ _ _    ] => f_equal
    | [ |- pair _ _     = pair _ _     ] => f_equal
    | [ |- proj₁ _      = proj₁ _      ] => f_equal
    | [ |- proj₂ _      = proj₂ _      ] => f_equal
    | [ |- inl _        = inl _        ] => f_equal
    | [ |- inr _        = inr _        ] => f_equal
    | [ |- caseof _ _ _ = caseof _ _ _ ] => f_equal

    | [ |- seq _ _      = seq _ _      ] => f_equal
    | [ |- context[apTm ?ξ ?t] ] =>
      change (apTm ξ t) with t[ξ]
  end.


(* This totally not necessary, LC is what we want. *)

(* And well formedness of types and terms. *)
(* Bug on notation. *)

Notation "t ^ x" := (open_tau x t).
Inductive type : Tau -> Prop :=
 | type_btvar  : forall x, type (btvar x)
 | type_ftvar  : forall x, type (ftvar x)
 | type_cint   : type cint
 | type_cross  : forall t0 t1, type t0 -> type t1 -> type (cross t0 t1)
 | type_arrow  : forall t0 t1, type t0 -> type t1 -> type (arrow t0 t1)
 | type_ptype  : forall t, type t -> type (ptype t)
 | type_utype  : forall L k t,
                   (forall alpha, alpha \notin L -> type (t ^ alpha)) ->
                   type (utype k t)
 | type_etype  : forall L p k t,
                   (forall alpha, alpha \notin L -> type (t ^ alpha)) ->
                   type (etype p k t).

Notation "t ^tt x" := (open_tau_term x t) (at level 67).
Notation "t ^t x" := (open_term x t) (at level 67).

Inductive term_V : V -> Prop :=
 | term_V_bevar   : forall n, term_V (bevar n)
 | term_V_fevar   : forall v, term_V (fevar v).

Inductive term_St : St -> Prop :=
 | term_St_e_s       : forall e, term_E e -> term_St (e_s e)
 | term_St_retn      : forall e, term_E e -> term_St (retn e)
 | term_St_seq       : forall s0 s1, term_St s0 -> term_St s1 -> term_St (seq s0 s1)
 | term_St_if_s      : forall e s0 s1, term_E e -> term_St s0 -> term_St s1 -> term_St (if_s e s0 s1)
 | term_St_while     : forall e s, term_E e -> term_St s -> term_St (while e s)
 | term_St_letx      : forall L e s, term_E e -> term_St s ->
                                   (forall x, x \notin L -> term_St (open_rec_term_st 0 x s)) ->
                                   term_St (letx e s)
 | term_St_open      : forall L e s, term_E e -> term_St s ->
                                     (forall x, x \notin L -> term_St (open_rec_term_st 0 x s)) ->
                                     term_St (open e s)
 | term_St_openstar  : forall L e s, term_E e -> term_St s ->
                                     (forall x, x \notin L -> term_St (open_rec_term_st 0 x s)) ->
                                     term_St (openstar e s)
with term_E       : E  -> Prop :=
 | term_E_v_e     : forall v, term_V v -> term_E (v_e v)
 | term_E_i_e     : forall i, term_E (i_e i)
 | term_E_p_e     : forall v p, term_E (p_e v p)
 | term_E_f_e     : forall f, term_F f -> term_E (f_e f)
 | term_E_amp     : forall e, term_E e -> term_E (amp e)
 | term_E_star    : forall e, term_E e -> term_E (star e)
 | term_E_cpair   : forall e0 e1, term_E e0 -> term_E e0 -> term_E (cpair e0 e1)
 | term_E_dot     : forall e ipe, term_E e -> term_E (dot e ipe)
 | term_E_assign  : forall e0 e1, term_E e0 -> term_E e1 -> term_E (assign e0 e1)
 | term_E_appl    : forall e0 e1, term_E e0 -> term_E e1 -> term_E (appl e0 e1)
 | term_E_call    : forall s, term_St s -> term_E (call s)
 | term_E_inst    : forall e t, term_E e -> type t -> term_E (inst e t)
 | term_E_pack    : forall t0 e t1, type t0 -> term_E e -> type t1 -> term_E (pack t0 e t1)
with term_F       : F  -> Prop :=
 | term_F_dfun    : forall t0 t1 s, type t0 -> type t1 -> term_F (dfun t0 t1 s)
 | term_F_ufun    : forall k f, term_F f -> term_F (ufun k f).

Inductive term : Term -> Prop :=
  | term_term_st : forall s, term_St s -> term (term_st s)
  | term_term_e  : forall e, term_E e  -> term (term_e e)
  | term_term_f  : forall f, term_F f  -> term (term_f f).


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.DeepEmbedded.Parameter.
Require Logic.SeparationLogic.DeepEmbedded.SeparationLanguage.
Require Logic.SeparationLogic.DeepEmbedded.SeparationEmpLanguage.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Module ReynoldsLogic.
Section ReynoldsLogic.

Context {Sigma: SeparationLanguage.PropositionalVariables}.

Existing Instances SeparationLanguage.L SeparationLanguage.minL SeparationLanguage.pL SeparationLanguage.sL.

Inductive provable: SeparationLanguage.expr Sigma -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| sepcon_comm: forall x y, provable (x * y --> y * x)
| sepcon_assoc: forall x y z, provable (x * (y * z) <--> (x * y) * z)
| wand_sepcon_adjoint1: forall x y z, provable (x * y --> z) -> provable (x --> (y -* z))
| wand_sepcon_adjoint2: forall x y z, provable (x --> (y -* z)) -> provable (x * y --> z)
| sepcon_elim1: forall x y, provable (x * y --> x).

Instance G: ProofTheory SeparationLanguage.L := Build_AxiomaticProofTheory provable.

Instance AX: NormalAxiomatization SeparationLanguage.L G := Build_AxiomaticProofTheory_AX provable.

Instance minAX: MinimunAxiomatization SeparationLanguage.L G.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance ipG: IntuitionisticPropositionalLogic SeparationLanguage.L G.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
  + apply falsep_elim.
Qed.

Instance sG: SeparationLogic SeparationLanguage.L G.
Proof.
  constructor.
  + apply sepcon_comm.
  + apply sepcon_assoc.
  + intros; split.
    - apply wand_sepcon_adjoint1.
    - apply wand_sepcon_adjoint2.
Qed.

Instance gcsG: GarbageCollectSeparationLogic SeparationLanguage.L G.
Proof.
  constructor.
  apply sepcon_elim1.
Qed.

End ReynoldsLogic.
End ReynoldsLogic.

Module OHearnLogic.
Section OHearnLogic.

Context {Sigma: SeparationEmpLanguage.PropositionalVariables}.

Existing Instances SeparationEmpLanguage.L SeparationEmpLanguage.minL SeparationEmpLanguage.pL SeparationEmpLanguage.sL SeparationEmpLanguage.s'L.

Inductive provable: SeparationEmpLanguage.expr Sigma -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| excluded_middle: forall x, provable (x || ~~ x)
| sepcon_comm: forall x y, provable (x * y --> y * x)
| sepcon_assoc: forall x y z, provable (x * (y * z) <--> (x * y) * z)
| wand_sepcon_adjoint1: forall x y z, provable (x * y --> z) -> provable (x --> (y -* z))
| wand_sepcon_adjoint2: forall x y z, provable (x --> (y -* z)) -> provable (x * y --> z)
| sepcon_emp: forall x, provable (x * emp <--> x).

Instance G: ProofTheory SeparationEmpLanguage.L := Build_AxiomaticProofTheory provable.

Instance AX: NormalAxiomatization SeparationEmpLanguage.L G := Build_AxiomaticProofTheory_AX provable.

Instance minAX: MinimunAxiomatization SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance ipG: IntuitionisticPropositionalLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
  + apply falsep_elim.
Qed.

Instance cpG: ClassicalPropositionalLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  apply excluded_middle.
Qed.

Instance sG: SeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply sepcon_comm.
  + apply sepcon_assoc.
  + intros; split.
    - apply wand_sepcon_adjoint1.
    - apply wand_sepcon_adjoint2.
Qed.

Instance EmpsG: EmpSeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  apply sepcon_emp.
Qed.

End OHearnLogic.
End OHearnLogic.

Module LogicOnModuResModel.
Section LogicOnModuResModel.

Context {Sigma: SeparationEmpLanguage.PropositionalVariables}.

Existing Instances SeparationEmpLanguage.L SeparationEmpLanguage.minL SeparationEmpLanguage.pL SeparationEmpLanguage.sL SeparationEmpLanguage.s'L.

Inductive provable: SeparationEmpLanguage.expr Sigma -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| sepcon_comm: forall x y, provable (x * y --> y * x)
| sepcon_assoc: forall x y z, provable (x * (y * z) <--> (x * y) * z)
| wand_sepcon_adjoint1: forall x y z, provable (x * y --> z) -> provable (x --> (y -* z))
| wand_sepcon_adjoint2: forall x y z, provable (x --> (y -* z)) -> provable (x * y --> z)
| sepcon_emp: forall x, provable (x * emp <--> x)
| sepcon_elim1: forall x y, provable (x * y --> x).

Instance G: ProofTheory SeparationEmpLanguage.L := Build_AxiomaticProofTheory provable.

Instance AX: NormalAxiomatization SeparationEmpLanguage.L G := Build_AxiomaticProofTheory_AX provable.

Instance minAX: MinimunAxiomatization SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance ipG: IntuitionisticPropositionalLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
  + apply falsep_elim.
Qed.

Instance sG: SeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply sepcon_comm.
  + apply sepcon_assoc.
  + intros; split.
    - apply wand_sepcon_adjoint1.
    - apply wand_sepcon_adjoint2.
Qed.

Instance EmpsG: EmpSeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  apply sepcon_emp.
Qed.

Instance gcsG: GarbageCollectSeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  apply sepcon_elim1.
Qed.

End LogicOnModuResModel.
End LogicOnModuResModel.

Module LogicOnMSL.
Section LogicOnMSL.

Context {Sigma: SeparationEmpLanguage.PropositionalVariables}.

Existing Instances SeparationEmpLanguage.L SeparationEmpLanguage.minL SeparationEmpLanguage.pL SeparationEmpLanguage.sL SeparationEmpLanguage.s'L.

Inductive provable: SeparationEmpLanguage.expr Sigma -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| impp_choice: forall x y, provable ((x --> y) || (y --> x))
| sepcon_comm: forall x y, provable (x * y --> y * x)
| sepcon_assoc: forall x y z, provable (x * (y * z) <--> (x * y) * z)
| wand_sepcon_adjoint1: forall x y z, provable (x * y --> z) -> provable (x --> (y -* z))
| wand_sepcon_adjoint2: forall x y z, provable (x --> (y -* z)) -> provable (x * y --> z)
| sepcon_emp: forall x, provable (x * emp <--> x).

Instance G: ProofTheory SeparationEmpLanguage.L := Build_AxiomaticProofTheory provable.

Instance AX: NormalAxiomatization SeparationEmpLanguage.L G := Build_AxiomaticProofTheory_AX provable.

Instance minAX: MinimunAxiomatization SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance ipG: IntuitionisticPropositionalLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
  + apply falsep_elim.
Qed.

Instance sG: SeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply sepcon_comm.
  + apply sepcon_assoc.
  + intros; split.
    - apply wand_sepcon_adjoint1.
    - apply wand_sepcon_adjoint2.
Qed.

Instance EmpsG: EmpSeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  apply sepcon_emp.
Qed.

End LogicOnMSL.
End LogicOnMSL.


(* ------------------------------------------------------------------------- *)
(** Displayed pseudofunctors.
    Marco Maggesi, Niccolò Veltri, Niels van der Weide
    July 2019

    Contents:
      - Definition of displayed pseudofunctors.
      - Identity and composition of displayed pseudofunctors.                *)
(* ------------------------------------------------------------------------- *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.Initial.
Require Import UniMath.Bicategories.Core.Examples.Final.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Import PseudoFunctor.Notations.

Local Open Scope cat.

(** ** Definition of displayed pseudofunctor *)

Section DispPseudofunctor.

Context {B₁ : bicat} (D₁ : disp_bicat B₁)
        {B₂ : bicat} (D₂ : disp_bicat B₂)
        (F : psfunctor B₁ B₂).

(** *** Data *)

Definition disp_psfunctor_data : UU
  :=
    ∑ (obFF : ∏ x:B₁, D₁ x → D₂ (F x))
      (morFF : ∏ (x y : B₁) (f : B₁⟦x,y⟧) (xx : D₁ x) (yy : D₁ y),
               (xx -->[f] yy) →
               (obFF x xx -->[#F f] obFF y yy))
      (cellFF : ∏ (x y : B₁) (f g : B₁⟦x,y⟧) (α : f ==> g) (xx : D₁ x) (yy : D₁ y)
                  (ff : xx -->[f] yy) (gg : xx -->[g] yy),
                (ff ==>[α] gg) → (morFF x y f xx yy ff ==>[##F α] morFF x y g xx yy gg))
      (disp_psfunctor_id : ∏ (x : B₁) (xx : D₁ x),
                           disp_invertible_2cell
                             (psfunctor_id F x)
                             (id_disp (obFF x xx))
                             (morFF x x (id₁ x) xx xx (id_disp xx))),
    (∏ (x y z : B₁) (f : x --> y) (g : y --> z)
       (xx : D₁ x) (yy : D₁ y) (zz : D₁ z)
       (ff : xx -->[f] yy) (gg : yy -->[g] zz),
     disp_invertible_2cell
       (psfunctor_comp F f g)
       (comp_disp (morFF x y f xx yy ff) (morFF y z g yy zz gg))
       (morFF x z (f · g) xx zz (comp_disp ff gg))).

Definition make_disp_psfunctor_data
           (obFF : ∏ x:B₁, D₁ x → D₂ (F x))
           (morFF : ∏ (x y : B₁) (f : B₁⟦x,y⟧) (xx : D₁ x) (yy : D₁ y),
                    (xx -->[f] yy) →
                    (obFF x xx -->[#F f] obFF y yy))
           (cellFF : ∏ (x y : B₁) (f g : B₁⟦x,y⟧) (α : f ==> g) (xx : D₁ x) (yy : D₁ y)
                       (ff : xx -->[f] yy) (gg : xx -->[g] yy),
                     (ff ==>[α] gg) → (morFF x y f xx yy ff ==>[##F α] morFF x y g xx yy gg))
           (disp_psfunctor_id : ∏ (x : B₁) (xx : D₁ x),
                                disp_invertible_2cell
                                  (psfunctor_id F x)
                                  (id_disp (obFF x xx))
                                  (morFF x x (id₁ x) xx xx (id_disp xx)))
           (disp_psfunctor_comp : ∏ (x y z : B₁) (f : x --> y) (g : y --> z)
                                    (xx : D₁ x) (yy : D₁ y) (zz : D₁ z)
                                    (ff : xx -->[f] yy) (gg : yy -->[g] zz),
                                  disp_invertible_2cell
                                    (psfunctor_comp F f g)
                                    (comp_disp (morFF x y f xx yy ff) (morFF y z g yy zz gg))
                                    (morFF x z (f · g) xx zz (comp_disp ff gg)))
  : disp_psfunctor_data
  := (obFF,, morFF,, cellFF,, disp_psfunctor_id,, disp_psfunctor_comp).

Definition disp_psfunctor_ob (FFdata : disp_psfunctor_data)
           {x : B₁}
           (xx : D₁ x)
  : D₂ (F x)
  := pr1 FFdata x xx.

Coercion disp_psfunctor_ob : disp_psfunctor_data >-> Funclass.

Section Projections.

Variable (FFdata : disp_psfunctor_data).

Definition disp_psfunctor_mor
           {x y : B₁} {f : B₁⟦x,y⟧} {xx : D₁ x} {yy : D₁ y}
           (ff : xx -->[f] yy)
  : FFdata x xx -->[#F f] FFdata y yy
  := pr12 FFdata x y f xx yy ff.

Definition disp_psfunctor_cell {x y : B₁} {f g : B₁⟦x,y⟧} {α : f ==> g}
           {xx : D₁ x} {yy : D₁ y}
           {ff : xx -->[f] yy} {gg : xx -->[g] yy}
           (αα : ff ==>[α] gg)
  : disp_psfunctor_mor ff ==>[##F α] disp_psfunctor_mor gg
  := pr122 FFdata x y f g α xx yy ff gg αα.

Definition disp_psfunctor_id {x : B₁} (xx : D₁ x)
  : disp_invertible_2cell (psfunctor_id F x)
                          (id_disp (FFdata x xx))
                          (disp_psfunctor_mor (id_disp xx))
  := pr122 (pr2 FFdata) x xx.

Definition disp_psfunctor_comp
           {x y z : B₁} {f : x --> y} {g : y --> z}
           {xx : D₁ x} {yy : D₁ y} {zz : D₁ z}
           (ff : xx -->[f] yy) (gg : yy -->[g] zz)
  : disp_invertible_2cell (psfunctor_comp F f g)
                          (comp_disp (disp_psfunctor_mor ff) (disp_psfunctor_mor gg))
                          (disp_psfunctor_mor (comp_disp ff gg))
  := pr222 (pr2 FFdata) x y z f g xx yy zz ff gg.

End Projections.

Definition total_psfunctor_data (FFdata : disp_psfunctor_data)
  : psfunctor_data (total_bicat D₁) (total_bicat D₂).
Proof.
  use make_psfunctor_data.
  - exact (λ x, (F (pr1 x),, FFdata _ (pr2 x))).
  - exact (λ x y f, (#F (pr1 f) ,, disp_psfunctor_mor FFdata (pr2 f))).
  - exact (λ x y f g α, (##F (pr1 α),, disp_psfunctor_cell FFdata (pr2 α))).
  - exact (λ x, iso_in_E_weq _ _ (psfunctor_id F (pr1 x),, disp_psfunctor_id FFdata (pr2 x))).
  - refine (λ x y z f g, iso_in_E_weq _ _ _).
    exact (psfunctor_comp F (pr1 f) (pr1 g),, disp_psfunctor_comp FFdata (pr2 f) (pr2 g)).
Defined.

(** *** Properties *)

Section DispPseudofunctorLaws.

Variable FFdata : disp_psfunctor_data.

Definition disp_psfunctor_id2_law
  : UU
  := ∏ (a b : B₁) (f : a --> b)
       (aa : D₁ a)
       (bb : D₁ b)
       (ff : aa -->[f] bb),
     disp_psfunctor_cell FFdata (disp_id2 ff) =
     transportb
       (λ p : # F f ==> # F f, disp_psfunctor_mor FFdata ff ==>[p] disp_psfunctor_mor FFdata ff)
       (psfunctor_id2 F f) (disp_id2 (disp_psfunctor_mor FFdata ff)).

Definition disp_psfunctor_vcomp2_law : UU
  := ∏ (a b : B₁) (f g h : B₁ ⟦a, b⟧) (η : f ==> g) (φ : g ==> h) (aa : D₁ a)
       (bb : D₁ b) (ff : aa -->[f] bb) (gg : aa -->[g] bb) (hh : aa -->[h] bb)
       (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh),
     disp_psfunctor_cell FFdata (ηη •• φφ) =
     transportb
       (λ p : # F f ==> # F h, disp_psfunctor_mor FFdata ff ==>[ p] disp_psfunctor_mor FFdata hh)
       (psfunctor_vcomp F η φ) (disp_psfunctor_cell FFdata ηη •• disp_psfunctor_cell FFdata φφ).

Definition disp_psfunctor_lunitor_law : UU
  := ∏ (a b : B₁) (f : B₁ ⟦ a, b ⟧) (aa : D₁ a) (bb : D₁ b) (ff : aa -->[ f] bb),
     disp_lunitor (disp_psfunctor_mor FFdata ff) =
     transportb
       (λ p, _ ==>[p] _)
       (psfunctor_lunitor F f)
       (((disp_psfunctor_id FFdata aa ▹▹ disp_psfunctor_mor FFdata ff)
           •• disp_psfunctor_comp FFdata (id_disp aa) ff)
          •• disp_psfunctor_cell FFdata (disp_lunitor ff)).

Definition disp_psfunctor_runitor_law : UU
  := ∏ (a b : B₁) (f : B₁ ⟦ a, b ⟧) (aa : D₁ a) (bb : D₁ b) (ff : aa -->[ f] bb),
     disp_runitor (disp_psfunctor_mor FFdata ff) =
     transportb
       (λ p, _ ==>[p] _)
       (psfunctor_runitor F f)
       (((disp_psfunctor_mor FFdata ff ◃◃ disp_psfunctor_id FFdata _)
           •• disp_psfunctor_comp FFdata _ _)
          •• disp_psfunctor_cell FFdata (disp_runitor ff)).

Definition disp_psfunctor_lassociator_law : UU
  :=
    ∏ (a b c d : B₁) (f : B₁ ⟦ a, b ⟧) (g : B₁ ⟦ b, c ⟧) (h : B₁ ⟦ c, d ⟧)
      (aa : D₁ a) (bb : D₁ b) (cc : D₁ c) (dd : D₁ d) (ff : aa -->[ f] bb) (gg : bb -->[ g] cc)
      (hh : cc -->[ h] dd),
    ((disp_psfunctor_mor FFdata ff ◃◃ disp_psfunctor_comp FFdata gg hh)
       •• disp_psfunctor_comp FFdata ff (gg;; hh))
      •• disp_psfunctor_cell FFdata (disp_lassociator ff gg hh) =
    transportb
      (λ p, _ ==>[p] _)
      (psfunctor_lassociator F f g h)
      ((disp_lassociator (disp_psfunctor_mor FFdata ff) (disp_psfunctor_mor FFdata gg)
                         (disp_psfunctor_mor FFdata hh)
         •• (disp_psfunctor_comp FFdata ff gg ▹▹ disp_psfunctor_mor FFdata hh))
        •• disp_psfunctor_comp FFdata (ff;; gg) hh).

Definition disp_psfunctor_lwhisker_law : UU
  := ∏ (a b c : B₁) (f : B₁ ⟦ a, b ⟧) (g₁ g₂ : B₁ ⟦ b, c ⟧) (η : g₁ ==> g₂)
       (aa : D₁ a) (bb : D₁ b) (cc : D₁ c) (ff : aa -->[ f] bb) (gg₁ : bb -->[ g₁] cc)
       (gg₂ : bb -->[ g₂] cc) (ηη : gg₁ ==>[ η] gg₂),
     disp_psfunctor_comp FFdata ff gg₁ •• disp_psfunctor_cell FFdata (ff ◃◃ ηη) =
     transportb
       (λ p, _ ==>[p] _)
       (psfunctor_lwhisker F f η)
       ((disp_psfunctor_mor FFdata ff ◃◃ disp_psfunctor_cell FFdata ηη)
          •• disp_psfunctor_comp FFdata ff gg₂).

Definition disp_psfunctor_rwhisker_law : UU
  := ∏ (a b c : B₁) (f₁ f₂ : B₁ ⟦ a, b ⟧) (g : B₁ ⟦ b, c ⟧) (η : f₁ ==> f₂)
       (aa : D₁ a) (bb : D₁ b) (cc : D₁ c)
       (ff₁ : aa -->[f₁] bb)
       (ff₂ : aa -->[f₂] bb)
       (gg : bb -->[g] cc)
       (ηη : ff₁ ==>[ η] ff₂),
     disp_psfunctor_comp FFdata _ _ •• disp_psfunctor_cell FFdata (ηη ▹▹ gg) =
     transportb
       (λ p, _ ==>[p] _)
       (psfunctor_rwhisker F g η)
       ((disp_psfunctor_cell FFdata ηη ▹▹ _)
          •• disp_psfunctor_comp FFdata _ _).

Definition is_disp_psfunctor : UU
    := disp_psfunctor_id2_law
         × disp_psfunctor_vcomp2_law
         × disp_psfunctor_lunitor_law
         × disp_psfunctor_runitor_law
         × disp_psfunctor_lassociator_law
         × disp_psfunctor_lwhisker_law
         × disp_psfunctor_rwhisker_law.

Definition disp_psfunctor_id2 (H : is_disp_psfunctor) := pr1 H.

Definition disp_psfunctor_vcomp2 (H : is_disp_psfunctor) := pr12 H.

Definition disp_psfunctor_vcomp2_alt (H : is_disp_psfunctor)
           (a b : B₁) (f g h : B₁ ⟦a, b⟧) (η : f ==> g) (φ : g ==> h) (aa : D₁ a)
           (bb : D₁ b) (ff : aa -->[f] bb) (gg : aa -->[g] bb) (hh : aa -->[h] bb)
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh)
  : transportf
      (λ p : # F f ==> # F h, disp_psfunctor_mor FFdata ff ==>[ p] disp_psfunctor_mor FFdata hh)
      (psfunctor_vcomp F η φ)
      (disp_psfunctor_cell FFdata (ηη •• φφ)) =
    disp_psfunctor_cell FFdata ηη •• disp_psfunctor_cell FFdata φφ.
Proof.
  refine (transportf_transpose_left (P := λ p, _ ==>[p] _) _).
  apply (disp_psfunctor_vcomp2 H).
Qed.

End DispPseudofunctorLaws.

(** *** Disp pseudofunct *)

Definition disp_psfunctor : UU
  := ∑ FF : disp_psfunctor_data, is_disp_psfunctor FF.

Coercion disp_psfunctor_to_disp_psfunctor_data (FF : disp_psfunctor)
  : disp_psfunctor_data
  := pr1 FF.

Lemma total_psfunctor_laws (FF : disp_psfunctor)
  : psfunctor_laws (total_psfunctor_data FF).
Proof.
  repeat apply make_dirprod; intro; intros; (use total2_paths_b; [ apply F | apply FF ]).
Qed.

Definition total_psfunctor (FF : disp_psfunctor)
  : psfunctor (total_bicat D₁) (total_bicat D₂).
Proof.
  use make_psfunctor.
  - exact (total_psfunctor_data FF).
  - exact (total_psfunctor_laws FF).
  - split; intros; use iso_in_E_weq.
Defined.

Definition is_disp_psfunctor_from_total (FF : disp_psfunctor_data)
  : is_psfunctor (total_psfunctor_data FF) → is_disp_psfunctor FF.
Proof.
  intros HFF.
  pose (EF := make_psfunctor _ (pr1 HFF) (pr2 HFF)).
  repeat split.
  - intros a b f aa bb ff.
    pose (P := !fiber_paths (@psfunctor_id2 _ _ EF (a,,aa) (b,,bb) (f,,ff))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros a b f g h η φ aa bb ff gg hh ηη φφ.
    pose (P := !fiber_paths (@psfunctor_vcomp _ _ EF
                                              (a,,aa) (b,,bb) (f,,ff) (g,,gg) (h,,hh)
                                              (η,,ηη) (φ,,φφ))).
    cbn in P; rewrite P.
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros a b f aa bb ff.
    pose (P := !fiber_paths (@psfunctor_lunitor _ _
                                                EF (a,,aa) (b,,bb) (f,,ff))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros a b f aa bb ff.
    pose (P := !fiber_paths (@psfunctor_runitor _ _
                                                EF (a,,aa) (b,,bb) (f,,ff))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros a b c d f g h aa bb cc dd ff gg hh.
    pose (P := !fiber_paths (@psfunctor_lassociator _ _
                                                    EF (a,,aa) (b,,bb) (c,,cc) (d,,dd)
                                                    (f,,ff) (g,,gg)  (h,,hh))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros a b c f g1 g2 η aa bb cc ff gg1 gg2 ηη.
    pose (P := !fiber_paths (@psfunctor_lwhisker _ _
                                                 EF (a,,aa) (b,,bb) (c,,cc)
                                                 (f,,ff) (g1,,gg1) (g2,,gg2) (η,,ηη))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros a b c f1 f2 g η aa bb cc ff1 ff2 gg ηη.
    pose (P := !fiber_paths (@psfunctor_rwhisker _ _ EF (a,,aa) (b,,bb) (c,,cc)
                                                 (f1,,ff1) (f2,,ff2) (g,,gg) (η,,ηη))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
Qed.

End DispPseudofunctor.

(** ** Identity *)

Section DispPseudofunctor_identity.

Context {B : bicat} (D : disp_bicat B).

Definition disp_pseudo_id_data : disp_psfunctor_data D D (id_psfunctor B).
Proof.
  use make_disp_psfunctor_data; cbn.
  - exact (λ _ y, y).
  - exact (λ _ _ _ _ _ ff, ff).
  - exact (λ _ _ _ _ _ _ _ _ _ αα, αα).
  - intros. apply disp_id2_invertible_2cell.
  - intros. apply disp_id2_invertible_2cell.
Defined.

Lemma disp_pseudo_id_laws : is_disp_psfunctor D D _ disp_pseudo_id_data.
Proof.
  apply is_disp_psfunctor_from_total.
  apply id_psfunctor.
Qed.

Definition disp_pseudo_id : disp_psfunctor D D (id_psfunctor B)
  := disp_pseudo_id_data,, disp_pseudo_id_laws.

End DispPseudofunctor_identity.

Definition disp_psfunctor_cell_transportb
           {B₁ B₂ : bicat}
           {F : psfunctor B₁ B₂}
           {D₁ : disp_bicat B₁}
           {D₂ : disp_bicat B₂}
           (FF : disp_psfunctor D₁ D₂ F)
           {x y : B₁}
           {f : x --> y}
           {φ ψ : f ==> f}
           {xx : D₁ x}
           {yy : D₁ y}
           {ff : xx -->[f] yy}
           (p : φ = ψ)
           (ψψ : ff ==>[ ψ ] ff)
  : disp_psfunctor_cell
      _ _ _ (pr1 FF)
      (transportb (λ z, ff ==>[ z ] ff) p ψψ)
    =
    transportb
      (λ z, _ ==>[ z ] _)
      (maponpaths (λ z, ##F z) p)
      (disp_psfunctor_cell
         _ _ _ (pr1 FF)
         ψψ).
Proof.
  induction p.
  cbn.
  apply idpath.
Defined.

Section DispPseudofunctorInvertible_2cell.

Context {B₁ B₂ : bicat}
        {F : psfunctor B₁ B₂}
        {D₁ : disp_bicat B₁}
        {D₂ : disp_bicat B₂}
        (FF : disp_psfunctor D₁ D₂ F)
        {x y : B₁}
        {f g : x --> y}
        {α : invertible_2cell f g}
        {xx : D₁ x}
        {yy : D₁ y}
        {ff : xx -->[f] yy}
        {gg : xx -->[g] yy}
        (αα : disp_invertible_2cell α ff gg).

Definition disp_psfunctor_invertible_2cell
  : disp_invertible_2cell
      (_,, psfunctor_is_iso F α)
      (disp_psfunctor_mor _ _ _ FF ff)
      (disp_psfunctor_mor _ _ _ FF gg).
Proof.
  repeat use tpair; cbn.
  - exact (disp_psfunctor_cell _ _ _ FF αα).
  - exact (disp_psfunctor_cell _ _ _ FF (disp_inv_cell αα)).
  - abstract
      (rewrite <- (disp_psfunctor_vcomp2_alt _ _ _ _ (pr2 FF));
       rewrite disp_vcomp_rinv;
       rewrite disp_psfunctor_cell_transportb;
       unfold transportb;
       rewrite transport_f_f;
       rewrite (disp_psfunctor_id2 _ _ _ _ (pr2 FF));
       unfold transportb;
       rewrite transport_f_f;
       apply (@transportf_paths _ (λ p, _ ==>[ p ] _));
       apply B₂).
  - abstract
      (rewrite <- (disp_psfunctor_vcomp2_alt _ _ _ _ (pr2 FF));
       rewrite disp_vcomp_linv;
       rewrite disp_psfunctor_cell_transportb;
       unfold transportb;
       rewrite transport_f_f;
       rewrite (disp_psfunctor_id2 _ _ _ _ (pr2 FF));
       unfold transportb;
       rewrite transport_f_f;
       apply (@transportf_paths _ (λ p, _ ==>[ p ] _));
       apply B₂).
Defined.

End DispPseudofunctorInvertible_2cell.

(** ** Composition *)

Section DispPseudofunctor_comp.

Context {B₁ B₂ B₃ : bicat}
        (F₁ : psfunctor B₁ B₂)
        (F₂ : psfunctor B₂ B₃)
        (D₁ : disp_bicat B₁)
        (D₂ : disp_bicat B₂)
        (D₃ : disp_bicat B₃)
        (FF₁ : disp_psfunctor D₁ D₂ F₁)
        (FF₂ : disp_psfunctor D₂ D₃ F₂).

Definition disp_pseudo_comp_data : disp_psfunctor_data D₁ D₃ (comp_psfunctor F₂ F₁).
Proof.
  use make_disp_psfunctor_data; cbn.
  - exact (λ x xx, FF₂ _ (FF₁ _ xx)).
  - exact (λ x y f xx yy ff, disp_psfunctor_mor _ _ _ FF₂ (disp_psfunctor_mor _ _ _ FF₁ ff)).
  - exact (λ x y f g α xx yy ff gg αα, disp_psfunctor_cell _ _ _ FF₂ (disp_psfunctor_cell _ _ _ FF₁ αα)).
  - intros x xx.
    exact (vcomp_disp_invertible
             (disp_psfunctor_id _ _ _ FF₂ (FF₁ _ xx))
             (disp_psfunctor_invertible_2cell FF₂ (disp_psfunctor_id _ _ _ FF₁ xx))).
  - intros x y z f g xx yy zz ff gg.
    exact (vcomp_disp_invertible
             (disp_psfunctor_comp _ _ _ FF₂
                                  (disp_psfunctor_mor _ _ _ FF₁ ff)
                                  (disp_psfunctor_mor _ _ _ FF₁ gg))
             (disp_psfunctor_invertible_2cell FF₂ (disp_psfunctor_comp _ _ _ FF₁ ff gg))).
Defined.

Lemma disp_pseudo_comp_laws : is_disp_psfunctor _ _ _ disp_pseudo_comp_data.
Proof.
  apply is_disp_psfunctor_from_total.
  apply (comp_psfunctor (total_psfunctor _ _ _ FF₂) (total_psfunctor _ _ _ FF₁)).
Qed.

Definition disp_pseudo_comp : disp_psfunctor _ _ (comp_psfunctor F₂ F₁)
  := disp_pseudo_comp_data,, disp_pseudo_comp_laws.

End DispPseudofunctor_comp.

(** Fiber of a pseudofunctor *)
Local Open Scope mor_disp_scope.

Definition transportb_disp_psfunctor
           {C : bicat}
           (HC : is_univalent_2_1 C)
           (D₁ : disp_bicat C)
           (D₂ : disp_bicat C)
           (F : disp_psfunctor D₁ D₂ (id_psfunctor C))
           {x y : C}
           {f g : x --> y}
           {xx : D₁ x} {yy : D₁ y}
           (ff : xx -->[ f ] yy)
           (p : g = f)
  : transportb
      (mor_disp ((pr11 F) x xx) ((pr11 F) y yy)) p
      ((pr121 F) _ _ _ xx yy ff)
    =
    (pr121 F)
      x y g xx yy
      (transportb (mor_disp xx yy) p ff).
Proof.
  induction p.
  apply idpath.
Defined.

Section FiberOfFunctor.
  Context {C : bicat}
          (HC : is_univalent_2_1 C)
          {D₁ : disp_bicat C}
          (HD₁ : disp_2cells_isaprop D₁)
          (HD₁_2_1 : disp_univalent_2_1 D₁)
          (h₁ : local_iso_cleaving D₁)
          {D₂ : disp_bicat C}
          (HD₂ : disp_2cells_isaprop D₂)
          (HD₂_2_1 : disp_univalent_2_1 D₂)
          (h₂ : local_iso_cleaving D₂)
          (F : disp_psfunctor D₁ D₂ (id_psfunctor C)).

  Definition fiber_functor_data
             (c : C)
    : functor_data
        (discrete_fiber_category D₁ HD₁ HD₁_2_1 h₁ c)
        (discrete_fiber_category D₂ HD₂ HD₂_2_1 h₂ c).
  Proof.
    use make_functor_data.
    - exact (pr11 F c).
    - exact (pr121 F c c (id₁ c)).
  Defined.

  Definition fiber_is_functor
             (c : C)
    : is_functor (fiber_functor_data c).
  Proof.
    split.
    - intros x.
      exact (!(disp_isotoid_2_1 _ HD₂_2_1 (idpath _) _ _ (pr12 (pr221 F) c x))).
    - intros x y z f g ; cbn.
      pose ((disp_isotoid_2_1
               _
               HD₂_2_1 (idpath _)
               _ _
               (pr22 (pr221 F) c c c (id₁ c) (id₁ c) x y z f g))) as p.
      cbn in p.
      rewrite p ; clear p.
      pose (disp_local_iso_cleaving_invertible_2cell
              h₂
              ((pr121 F) c c (id₁ c · id₁ c) x z (f;; g))
              (idempunitor c)) as p1.
      pose (disp_local_iso_cleaving_invertible_2cell h₁ (f;; g) (idempunitor c)) as p2.
      rewrite <- (idtoiso_2_1_isotoid_2_1 HC (idempunitor c)) in p1, p2.
      etrans.
      {
        apply maponpaths.
        pose (transportb_transpose_right (disp_isotoid_2_1 D₁ HD₁_2_1 _ _ _ p2)) as p.
        rewrite idtoiso_2_1_isotoid_2_1 in p.
        exact p.
      }
      clear p2.
      refine (!_).
      etrans.
      {
        pose (transportb_transpose_right (disp_isotoid_2_1 D₂ HD₂_2_1 _ _ _ p1)) as p.
        rewrite idtoiso_2_1_isotoid_2_1 in p.
        exact p.
      }
      clear p1.
      apply transportb_disp_psfunctor.
      exact HC.
  Qed.

  Definition fiber_functor
             (c : C)
    : discrete_fiber_category D₁ HD₁ HD₁_2_1 h₁ c
      ⟶
      discrete_fiber_category D₂ HD₂ HD₂_2_1 h₂ c.
  Proof.
    use make_functor.
    - exact (fiber_functor_data c).
    - exact (fiber_is_functor c).
  Defined.
End FiberOfFunctor.

Definition disp_psfunctor_id_on_disp_adjequiv
           {B : bicat}
           {D₁ D₂ : disp_bicat B}
           (FF : disp_psfunctor D₁ D₂ (id_psfunctor _))
           {x y : B}
           {f : adjoint_equivalence x y}
           {xx : D₁ x}
           {yy : D₁ y}
           {ff : xx -->[ f ] yy}
           (Hff : disp_left_adjoint_equivalence f ff)
  : disp_left_adjoint_equivalence _ (disp_psfunctor_mor _ _ _ FF ff)
  := pr2 (left_adjoint_equivalence_total_disp_weq
            _ _
            (psfunctor_preserves_adjequiv'
               (total_psfunctor _ _ _ FF)
               (invmap (left_adjoint_equivalence_total_disp_weq f ff) (pr2 f ,, Hff)))).