Load "include/ops_header.v".

Require annotated_recs_v.

Module v.
Include annotated_recs_v.
End v.

Section AnnOfB.

Variable v : int -> int -> rat.
Variable v_ann : v.Ann v.
Let v_Sn2 := v.Sn2_ v_ann.
Let v_SnSk := v.SnSk_ v_ann.
Let v_Sk2 := v.Sk2_ v_ann.

Theorem P_eq_Delta_Q : v.CT v.
Proof.
rewrite /v.CT => n k; rewrite /v.not_D => notD.
rewrite /v.P_horner /v.P_seq /punk.horner_seqop /= /v.Q_flat.
do 5! (rewrite v_Sn2; last by rewrite /v.precond.Sn2; lia).
rewrite v_SnSk; last by rewrite /v.precond.SnSk; lia.
rewrite v_Sk2; last by rewrite /v.precond.Sk2; lia.
(* Sanity check: at this point, we have a normal form wrt the Gröbner basis. *)
set v1 := v _ _; set v2 := v _ _; set v3 := v _ _.  (* set v4 := v _ _. *)
(* This unfolding takes a dozen seconds if the Q_cf<i> are unfolded first: *)
(* they are the largest objects in this formalization. *)
rewrite
  /v.P_cf0 /v.P_cf1 /v.P_cf2 /v.P_cf3 /v.P_cf4
  /v.Sk2_cf0_0 /v.Sk2_cf0_1 /v.Sn2_cf0_0 /v.Sn2_cf1_0 /v.Sn2_cf0_1
  /v.SnSk_cf0_0 /v.SnSk_cf1_0 /v.SnSk_cf0_1
  /v.Q_cf0_0 /v.Q_cf1_0 /v.Q_cf0_1
.
rewrite !int.shift2R.
(* This takes over 250 seconds. *)
by field; ring_lia.
Qed.

Let b (n : int) : rat := \sum_(0 <= k < n + 1 :> int) v n k.

Theorem recAperyB (n : int) : n >= (2 : int) -> v.P_horner b n = 0.
Proof using v v_ann v_Sn2 v_SnSk v_Sk2 b.
move=> nge2.
rewrite /v.P_horner.
rewrite (punk.sound_telescoping P_eq_Delta_Q) //;
  last exact: (addr_ge0 (le_trans _ nge2) _).
set onD := (X in _ + X + _).
set remP := (X in _ + _ + X).
set F := BIG_F in onD *.
(* Terms on onD are just the three following specializations. *)
have {onD} -> : onD = F 0 + F (n - 1) + F n.
  rewrite /onD /v.not_D.
  rewrite /punk.horner_seqop.
  rewrite /punk.horner_seqop_rec /=.
  rewrite big_mkcond /= big_int_recl /=; last lia.
  rewrite ifT; last lia.
  have hn : n = (n - 1 - 1) + 1 + 1 by lia.
  rewrite {1}[in LHS]hn.
  rewrite big_int_recr /=; last lia.
  rewrite ifT; last lia.
  rewrite big_int_recr /=; last lia.
  rewrite ifT; last lia.
  rewrite -hn [n - 1 - 1 + 1]addrNK -big_mkcond big_int_cond big_pred0
      => [ | i].
    by rewrite add0r addrA.
  lia.
(* Now we chase pathological denominators that may occur in values of F
   and "telQ". *)
rewrite {}/F.
rewrite add0r [n - 1 + 1]addrNK.
(* In fact, simplifying natural compensations is enough. *)
(* We use some abbreviations to ease the description of the simplified form. *)
set pv_0_S1 := punk.horner_seqop _ _ _.
set pv_S0_S1 := punk.horner_seqop _ _ _.
set pv_S1_S1 := punk.horner_seqop _ _ _.
set q_S1_S2 := v.Q_flat _ _ _.
set q_S1_0 := v.Q_flat _ _ _.
set q_S1_1 := v.Q_flat _ _ _.
set q_S1_S1 := v.Q_flat _ _ _.
set q_S1_S0 := v.Q_flat _ _ _.
Fail set q := v.Q_flat _ _ _.
set L := (X in (X + _ = _)).
have -> : L = pv_0_S1 - q_S1_1 + pv_S0_S1 + q_S1_S0 + pv_S1_S1.
  rewrite /L; ring.
clear L q_S1_S2 q_S1_0 q_S1_S1.
(* No more pathological denominators in the remaining terms. *)
(* We can observe two groups of terms: one right and above (n, 0) *)
(* produced by pv_0_S1 and q_S1_1, and one right and above (n -1, n -1), *)
(* produced by the other terms. We normalize them independently, since *)
(* they cannot interact to give the zero answer. *)
set around_n_0 := pv_0_S1 - q_S1_1.
have -> : around_n_0 = 0.
  rewrite {}/around_n_0.
  clear pv_S0_S1 pv_S1_S1 q_S1_S0 remP.
  rewrite {}/pv_0_S1 {}/q_S1_1.
  (* Unrolling the definition of P *)
  rewrite /punk.horner_seqop /punk.horner_seqop_rec /=.
  (* Unrolling the definition of Q *)
  rewrite /v.Q_flat.
  (* Just to ease reading, a few abbreviations *)
  set c10 := v (int.shift 1 n) 0.
  set c20 := v (int.shift 2 n) 0.
  set c30 := v (int.shift 3 n) 0.
  set c40 := v (int.shift 4 n) 0.
  set c11 := v (int.shift 1 n) (int.shift 1 0).
  set c02 := v n (int.shift 2 0).
  set c01 := v n 1.
  set c00 := v n 0.
  Fail set c := v _ _.
  (* This one will be produced by the normalization *)
  pose c21 := v (int.shift 2 n) (int.shift 1 0).
  rewrite [c40]v_Sn2; last by rewrite /v.precond.Sn2; lia.
  rewrite {c40} -/c30 -/c20 -/c21.
  rewrite [c30]v_Sn2; last by rewrite /v.precond.Sn2; lia.
  rewrite {c30} -/c20 -/c11 -/c10.
  rewrite [c21]v_SnSk; last by rewrite /v.precond.SnSk; lia.
  rewrite {c21} -/c11 -/c20 -/c10.
  rewrite [c20]v_Sn2; last by rewrite /v.precond.Sn2; lia.
  rewrite {c20} -/c00 -/c10 -/c01.
  rewrite [c02]v_Sk2; last by rewrite /v.precond.Sk2; lia.
  rewrite {c02} -/c00 -/c01.
  rewrite [c11]v_SnSk; last by rewrite /v.precond.SnSk; lia.
  rewrite {c11} -/c00 -/c01 -/c10.
 (* See comments about the protocole in the second normalization. *)
  set n1 := int.shift 1 n.
  set n2 := int.shift 2 n.
  (* Now we are under the stairs. *)
  have hn1 : n1%:Q = n%:Q + 1%:Q by rewrite rmorphD.
  have hn2 : n2%:Q = n%:Q + 2%:Q by rewrite !rmorphD /=; ring.
  rewrite /v.P_cf0 /v.P_cf1 /v.P_cf2 /v.P_cf3.
  rewrite /v.P_cf4 /v.Q_cf0_0 /v.Q_cf0_1.
  rewrite /v.Q_cf1_0 /v.Sk2_cf0_0 /v.Sk2_cf0_1.
  rewrite /v.Sn2_cf0_0 /v.Sn2_cf0_1 /v.Sn2_cf1_0.
  rewrite /v.SnSk_cf0_0 /v.SnSk_cf0_1 /v.SnSk_cf1_0.
  rewrite {n1}hn1 {n2}hn2.
  field; ring_lia.
  (* above: Finished transaction in 16. secs (16.761047u,0.s) *)
(* Now the normalization of the second part of the expression causes
   no problem. *)
suff around_p_p_eq_0 : pv_S0_S1 + q_S1_S0 + pv_S1_S1 + remP = 0.
  by rewrite -[RHS]around_p_p_eq_0 add0r.
clear around_n_0.
rewrite {}/q_S1_S0 {}/q_S1_1 {}/pv_S1_S1 {}/pv_S0_S1 {}/pv_0_S1.
(* Unrolling the definition of remP *)
rewrite {}/remP [bigop]unlock /=.
(* Avoid backward shifts, as our rewriting rules cannot deal with them. *)
set p := n - 1.
have -> : n = int.shift 1 p. by rewrite /p; lia.
have hp : (1 : int) <= p by rewrite /p; lia.
(* We can now clear n. *)
clearbody p; clear n nge2.
(* Unrolling the definition of P. *)
rewrite /punk.horner_seqop /punk.horner_seqop_rec /=.
(* Unrolling the definition of Q. *)
rewrite /v.Q_flat.
(* Just to ease reading, a few abbreviations. *)
set v10 := v (int.shift 1 p) p.
set v01 := v p (int.shift 1 p).
set v20 := v (int.shift 2 p) p.
set v11 := v (int.shift 1 p) (int.shift 1 p).
set v30 := v (int.shift 3 p) p.
set v21 := v (int.shift 2 p) (int.shift 1 p).
set v12 := v (int.shift 1 p) (int.shift 2 p).
set v40 := v (int.shift 4 p) p.
set v31 := v (int.shift 3 p) (int.shift 1 p).
set v22 := v (int.shift 2 p) (int.shift 2 p).
set v50 := v (int.shift 5 p) p.
set v41 := v (int.shift 4 p) (int.shift 1 p).
set v32 := v (int.shift 3 p) (int.shift 2 p).
set v51 := v (int.shift 5 p) (int.shift 1 p).
set v42 := v (int.shift 4 p) (int.shift 2 p).
set v33 := v (int.shift 3 p) (int.shift 3 p).
set v52 := v (int.shift 5 p) (int.shift 2 p).
set v43 := v (int.shift 4 p) (int.shift 3 p).
set v53 := v (int.shift 5 p) (int.shift 3 p).
set v44 := v (int.shift 4 p) (int.shift 4 p).
set v54 := v (int.shift 5 p) (int.shift 4 p).
set v55 := v (int.shift 5 p) (int.shift 5 p).
Fail set vvv := v _ _.
(* Normalization modulo annulators of v. *)
rewrite [v55]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v55} -/v54 -/v53 -/v52 -/v51 -/v50.
rewrite [v54]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v54} -/v53 -/v52 -/v51 -/v50.
rewrite [v53]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v53} -/v52 -/v51 -/v50.
rewrite [v52]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v52} -/v51 -/v50.
rewrite [v44]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v44} -/v43 -/v42 -/v41 -/v40.
rewrite [v43]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v43} -/v42 -/v41 -/v40.
rewrite [v42]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v42} -/v41 -/v40.
rewrite [v33]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v33} -/v32 -/v31 -/v30.
rewrite [v32]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v32} -/v31 -/v30.
rewrite [v22]v_Sk2; last by rewrite /v.precond.Sk2; lia.
rewrite {v22} -/v21 -/v20.
(* Use v_SnSk and v_Sn2 in alternation: *)
rewrite [v51]v_SnSk; last by rewrite /v.precond.SnSk; lia.
rewrite {v51} -/v50 -/v40 -/v41.
rewrite [v50]v_Sn2; last by rewrite /v.precond.Sn2; lia.
rewrite {v50} -/v40 -/v30 -/v31.
rewrite [v41]v_SnSk; last by rewrite /v.precond.SnSk; lia.
rewrite {v41} -/v40 -/v30 -/v31.
rewrite [v40]v_Sn2; last by rewrite /v.precond.Sn2; lia.
rewrite {v40} -/v30 -/v20 -/v21.
rewrite [v31]v_SnSk; last by rewrite /v.precond.SnSk; lia.
rewrite {v31} -/v30 -/v20 -/v21.
rewrite [v30]v_Sn2; last by rewrite /v.precond.Sn2; lia.
rewrite {v30} -/v20 -/v10 -/v11.
rewrite [v21]v_SnSk; last by rewrite /v.precond.SnSk; lia.
(* Now we are under the stair, we unfold the coefficients of the operators *)
(* and call field. *)
rewrite {v21} -/v20 -/v10 -/v11.
(* We inspect the current expression to collect the shifts of p that are *)
(* present and set definitions in normal form. *)
set p1 := int.shift 1 p.
set p2 := int.shift 2 p.
set p3 := int.shift 3 p.
set p4 := int.shift 4 p.
set p5 := int.shift 5 p.
(* We pre-compute the desired expressions for the embeddings in rat of the p* *)
(* that will occur after unfolding the operators. *)
have kp1 : p1%:Q = p%:Q + 1 by rewrite int.shift2R.
have kp2 : p2%:Q = p%:Q + 2%:Q by rewrite int.shift2R.
have kp3 : p3%:Q = p%:Q + 3%:Q by rewrite int.shift2R.
have kp4 : p4%:Q = p%:Q + 4%:Q by rewrite int.shift2R.
have kp5 : p5%:Q = p%:Q + 5%:Q by rewrite int.shift2R.
rewrite /v.P_cf0 /v.P_cf1 /v.P_cf2 /v.P_cf3.
rewrite /v.P_cf4 /v.Q_cf0_0 /v.Q_cf0_1.
rewrite /v.Q_cf1_0 /v.Sk2_cf0_0 /v.Sk2_cf0_1.
rewrite /v.Sn2_cf0_0 /v.Sn2_cf0_1 /v.Sn2_cf1_0.
rewrite /v.SnSk_cf0_0 /v.SnSk_cf0_1 /v.SnSk_cf1_0.
(* These rewriting catch the occurrences of p*%:~R modulo conversion, even *)
(* those that are not folded and display other forms in terms of nested *)
(* shift and shift1, because the head symbols in the rhs of kp* is _%:~R. *)
rewrite {p1}kp1 {p2}kp2 {p3}kp3 {p4}kp4 {p5}kp5.
field; ring_lia.
(* above: Finished transaction in 157. secs (156.849802u,0.252016s) *)
Qed.

End AnnOfB.


Require Export Iron.Language.SystemF2Effect.Base.

(* Kinds *)
Inductive ki : Type :=
 (* Kind of data values. *)
 | KData   : ki

 (* Kind of region variables and region handles. *)
 | KRegion : ki

 (* Kind of effect types. *)
 | KEffect : ki

 (* Kind of type constructors. *)
 | KFun    : ki -> ki -> ki.

Hint Constructors ki.

(* Kind Environments *)
Definition kienv := list ki.
Hint Unfold kienv.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import ssrfun.
Require Import eqtype.
Require Import ssrnat.
Require Import fintype.
Require Import finset.
Require Import groups.
Require Import normal.
Require Import morphisms.
Require Import automorphism.
Require Import bigops.
Require Import gprod.

Import GroupScope.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section IdentitySubFunctorDefs.

Implicit Types gT hT : finGroupType.

(* An object mapping on sets *)

Definition obmap : Type := forall gT, {set gT} -> {set gT}.

Identity Coercion fun_of_obmap : obmap >-> Funclass.

(* General functoriality, a.k.a continuity of the object mapping *)

Definition cont (F : obmap) : Prop :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
    phi @* (F _ G) \subset F _ (phi @* G).

(* Functoriality on grp whose arrows are restricted to isomorphisms *)

Definition acont (F : obmap) : Prop :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
   'injm phi -> phi @* (F _ G) \subset F _ (phi @* G).

Lemma acont_of_cont : forall F, cont F -> acont F.
Proof. by move=> F H gT hT G phi Ha; apply:H. Qed.

(* Hereditary w.r.t. inclusion *)

Definition hereditary (F : obmap) : Prop :=
  forall gT (H G : {group gT}), H \subset G -> (F _ G) :&: H \subset (F _ H).

(* Modulo Application *)

Definition appmod (F1 F2 : obmap) :=
  fun gT G => coset (F2 gT G) @*^-1 (F1 _ (G / (F2 gT G))).

Definition app (F1 F2 : obmap) :=
  fun gT G => F1 _ (F2 gT G).

(* Strong functoriality (wrt domains) *)

Definition dcont (F : obmap) : Prop :=
  forall gT hT (G D : {group gT}) (phi : {morphism D >-> hT}),
    phi @* (F _ G) \subset F _ (phi @* G).

Lemma cont_of_dcont : forall F, dcont F -> cont F.
Proof. by move=> F contF gT hT G; exact: contF. Qed.

Lemma hereditary_of_dcont sF : dcont sF -> hereditary sF.
Proof.
move=> sF Hcont gT H G sHG; move: (Hcont _ _ G _ (idm_morphism H)) => /=.
rewrite -morphimIdom -[idm H @* G]morphimIdom !morphim_idm ?subsetIl //.
by rewrite (setIidPl sHG) setIC.
Qed.

(* Order-preserving w.r.t. inclusion *)

Definition monotonous (F : obmap) : Prop :=
  forall gT (H G : {group gT}), H \subset G -> (F _ H) \subset (F _ G).

End IdentitySubFunctorDefs.

Module FunctorDefs.

Implicit Type gT : finGroupType.

Structure bgFunc : Type := BGFunc {
  Fobj :> obmap;
  (* group preservation *)
  _ : forall gT (G : {group gT}), group_set (@Fobj gT G);
  (* submapping *)
  _ : forall gT (G : {group gT}), @Fobj gT G \subset G;
  (* functoriality condition *)
  _ : acont Fobj}.

Structure gFunc : Type := GFunc {
  F_bgFunc :> bgFunc ;
   _ : cont F_bgFunc}.

Structure hgFunc : Type := HGFunc {
  F_hgFunc :> gFunc;
   _ : hereditary F_hgFunc}.

Structure mgFunc : Type := MGFunc {
  F_mgFunc :> gFunc;
   _ : monotonous F_mgFunc}.

Definition mkBGFunc F rF gF sF := @BGFunc F gF sF rF.

Definition mkGFunc F rF gF sF :=
  @GFunc (@BGFunc F gF sF (acont_of_cont rF)) rF.

Definition repack_bgFunc bgF :=
let: BGFunc _ gp smap arp := bgF
  return {type of BGFunc for bgF} -> bgFunc in
  fun k => k gp smap arp.

Definition obmap_phant := phantom obmap.
Definition obmap_uni op1 op2 := obmap_phant op1 -> obmap_phant op2.

Definition repack_gFunc F (bgF : bgFunc) (gF : gFunc) :=
  fun (_ : obmap_uni bgF F) ( _ : obmap_uni gF F) obmapEq =>
    (let: GFunc _ rp := gF
      return {type of GFunc for gF} -> gFunc in
      fun k => k rp)
    (let: erefl in _ = gF := obmapEq
      return {type of GFunc for gF}
      in @GFunc bgF).

Definition repack_hgFunc F (gF : gFunc) (hgF : hgFunc) :=
  fun (_ : obmap_uni gF F) ( _ : obmap_uni hgF F) obmapEq =>
    (let: HGFunc _ hp := hgF
      return {type of HGFunc for hgF} -> hgFunc in
      fun k => k hp)
    (let: erefl in _ = hgF := obmapEq
      return {type of HGFunc for hgF}
      in @HGFunc gF).

Definition repack_mgFunc F (gF : gFunc) (mgF : mgFunc) :=
  fun (_ : obmap_uni gF F) ( _ : obmap_uni mgF F) obmapEq =>
    (let: MGFunc _ cp := mgF
      return {type of MGFunc for mgF} -> mgFunc in
      fun k => k cp)
    (let: erefl in _ = mgF := obmapEq
      return {type of MGFunc for mgF}
      in @MGFunc gF).

End FunctorDefs.

Notation "[ 'bgFunc' 'of' F ]" :=
  (FunctorDefs.repack_bgFunc (fun bgP => @FunctorDefs.BGFunc F bgP))
  (at level 0, format"[ 'bgFunc'  'of'  F ]") : form_scope.

Notation "[ 'bgFunc' 'by' sF & ! rF ]" :=
  (FunctorDefs.mkBGFunc rF (fun gT G => groupP _) sF)
  (at level 0, format "[ 'bgFunc'  'by'  sF  &  ! rF ]") : form_scope.

Notation "[ 'bgFunc' 'by' sF & rF ]" :=
  [bgFunc by sF & !acont_of_cont rF]
  (at level 0, format "[ 'bgFunc'  'by'  sF  &  rF ]") : form_scope.

Notation "[ 'gFunc' 'by' sF & rF ]" :=
  (FunctorDefs.mkGFunc rF (fun gT G => groupP _) sF)
  (at level 0, format "[ 'gFunc'  'by'  sF  &  rF ]") : form_scope.

Notation "[ 'gFunc' 'of' F ]" :=
  (@FunctorDefs.repack_gFunc F _ _ id id (erefl _))
  (at level 0, format "[ 'gFunc'  'of'  F ]") : form_scope.

Notation "[ 'hgFunc' 'of' F ]" :=
  (@FunctorDefs.repack_hgFunc F _ _ id id (erefl _))
  (at level 0, format "[ 'hgFunc' 'of'  F ]") : form_scope.

Notation "[ 'mgFunc' 'of' F ]" :=
  (@FunctorDefs.repack_mgFunc F _ _ id id (erefl _))
  (at level 0, format "[ 'mgFunc' 'of'  F ]") : form_scope.

Notation bgFunc := FunctorDefs.bgFunc.
Notation gFunc := FunctorDefs.gFunc.
Notation hgFunc := FunctorDefs.hgFunc.
Notation mgFunc := FunctorDefs.mgFunc.

Notation BGFunc := FunctorDefs.BGFunc.
Notation GFunc := FunctorDefs.GFunc.
Notation HGFunc := FunctorDefs.HGFunc.
Notation MGFunc := FunctorDefs.MGFunc.

Section BgGroup.
(* Preliminary : group structure *)
Variables (sF : bgFunc) (gT : finGroupType) (H : {group gT}).
Lemma bgFunc_groupset : group_set (sF _ H). Proof. by case: sF. Qed.
Canonical Structure bgFunc_group := Group bgFunc_groupset.
End BgGroup.

Section BaseIdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.
Variable sF : bgFunc.

Lemma bgFunc_clos : forall gT (H : {group gT}), sF _ H \subset H.
Proof. by case sF. Qed.

Lemma bgFunc_acont : acont sF.
Proof. by case sF. Qed.

Lemma bgFunc_char : forall gT (G : {group gT}), sF _ G \char G.
Proof.
move=> gT G; apply/andP; split => //; first by apply: bgFunc_clos.
apply/forallP=> f; apply/implyP=> Af; rewrite -{2}(im_autm Af) -(autmE Af).
by rewrite -morphimEsub ?bgFunc_clos ?bgFunc_acont ?injm_autm.
Qed.

Lemma bgFunc_norm : forall gT (G : {group gT}), G \subset 'N(sF _ G).
Proof. by move=> *; rewrite char_norm ?bgFunc_char. Qed.

(* independent from the group preservation requirement*)
Lemma bgFunc_gen_norm : forall gT (G : {group gT}),
  << sF _ G >> \subset 'N(sF _ G).
Proof.
move=> gT G; apply/normsP=> x Hx; move/normsP: (bgFunc_norm G); apply.
by move: ((subsetP (genS (bgFunc_clos G))) _ Hx); rewrite genGid.
Qed.

Lemma bgFunc_normal : forall gT (G : {group gT}), sF _ G <| G.
Proof.  by move=> *; rewrite char_normal ?bgFunc_char. Qed.

Lemma bgFunc_ascont_sub :
   forall gT hT (H G : {group gT}) (f : {morphism G >-> hT}),
  'injm f -> H \subset G -> f @* (sF _ H) \subset sF _ (f @* H).
Proof.
move=> gT hT H G f injf sHG; apply/eqP; rewrite -(setIidPr (bgFunc_clos H)).
by rewrite-{3}(setIid H) -!(morphim_restrm sHG) bgFunc_acont // injm_restrm.
Qed.

Lemma bgFunc_ascont :
 forall gT hT (H G : {group gT}) (f : {morphism G >-> hT}),
 'injm f -> H \subset G -> f @* (sF _ H) = sF _ (f @* H).
Proof.
move=> gT hT H G f injf sHG.
apply/eqP; rewrite eqEsubset bgFunc_ascont_sub //=.
rewrite -{2}(morphim_invm injf sHG) -[f @* sF _ _](morphpre_invm injf).
have sFtr := subset_trans (bgFunc_clos _).
by rewrite -sub_morphim_pre (bgFunc_ascont_sub, sFtr) ?morphimS ?injm_invm.
Qed.

Lemma bgFunc_nker_cont :
  forall gT hT (H G : {group gT}) (f : {morphism G >-> hT}),
  'ker f = 1 -> H \subset G -> f @* (sF _ H) = sF _ (f @* H).
Proof. by move=> gT hT H G f; move/trivgP => /=; apply: bgFunc_ascont. Qed.

Lemma bgFunc_isom :
  forall gT hT (H G : {group gT}) (R : {group hT}) (f : {morphism G >-> hT}),
  H \subset G -> isom H R f -> isom (sF _ H) (sF _ R) f.
Proof.
move=> gT rT H G R f; case/(restrmP f)=> g [gf _ _ _]; rewrite -{f}gf.
by case/isomP=> injg <-; rewrite sub_isom ?bgFunc_clos ?bgFunc_ascont.
Qed.

Lemma bgFunc_isog : forall gT hT (G : {group gT}) (R : {group hT}),
  G \isog R -> sF _ G \isog sF _ R.
Proof.
move=> gT rT D R; case/isogP=> f *.
apply: (isom_isog f) => //; first by apply: bgFunc_clos.
apply: bgFunc_isom => //; exact/isomP.
Qed.

End BaseIdentitySubFunctorProps.

Section IdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.
Variable sF : gFunc.

Lemma gFunc_cont : cont sF.
Proof. by case sF. Qed.

Lemma morphim_sFunctor : forall gT hT (G D : {group gT})
  (f : {morphism D >-> hT}),
  G \subset D -> f @* (sF _ G) \subset sF _ (f @* G).
Proof.
move=> gT hT G D f sGD; rewrite -(setIidPr (bgFunc_clos sF G)).
by rewrite  -{3}(setIid G) -!(morphim_restrm sGD) gFunc_cont.
Qed.

Lemma injm_sFunctor :
  forall gT hT (G D : {group gT}) (f : {morphism D >-> hT}),
  'injm f -> G \subset D -> f @* (sF _ G) = sF _ (f @* G).
Proof. exact: bgFunc_ascont. Qed.

Lemma isom_sFunctor :
  forall gT hT (D G : {group gT}) (R : {group hT}) (f : {morphism D >-> hT}),
  G \subset D -> isom G R f -> isom (sF _ G) (sF _ R) f.
Proof. move=> gT hT D G; exact: bgFunc_isom. Qed.

Lemma isog_sFunctor : forall gT hT (D : {group gT}) (R : {group hT}),
  D \isog R -> sF _ D \isog sF _ R.
Proof. exact: bgFunc_isog. Qed.

End IdentitySubFunctorProps.

Section HereditaryIdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.

Section HereditaryIdBaseProps.

Variable sF : hgFunc.

Lemma hgFunc_cont : cont sF.
Proof. by apply: gFunc_cont. Qed.

Lemma hgFunc_hereditary : hereditary sF.
Proof. by case sF. Qed.

Lemma hgFunc_imsetI : forall gT (G H : {group gT}),
  sF _ G :&: H = sF _ G :&: sF _ (G :&: H).
Proof.
move=> gT G H; rewrite -{1}(setIidPr (bgFunc_clos sF G)) [G :&: _]setIC -setIA.
move/setIidPr: (hgFunc_hereditary (subsetIl G H)) <-.
by rewrite setIC -setIA (setIidPr (bgFunc_clos sF (G:&: H))).
Qed.

Lemma hgFunc_morphim : dcont sF.
Proof.
move=> gT hT G D f.
rewrite -morphimIdom -(setIidPl (bgFunc_clos sF G)) setICA.
apply: (subset_trans (morphimS f (hgFunc_hereditary (subsetIr D G)))).
apply: (subset_trans (morphim_sFunctor sF _ _ )); last by rewrite morphimIdom.
exact: subsetIl.
Qed.

(* TOFIX: this should ultimately use the Idempotent Property defined below *)
Lemma hereditary_idem : forall (gT:finGroupType) (G:{group gT}),
  (app sF sF) _ G  = sF _ G.
Proof.
move=> gT G /=; apply/eqP; rewrite eqEsubset bgFunc_clos.
by move/hgFunc_hereditary: (bgFunc_clos sF G); rewrite setIid /=.
Qed.

End HereditaryIdBaseProps.

Section HereditaryIdentitySFComp.

Variables (sF : hgFunc) (sF2 : gFunc).

(* independent from the group preservation requirement *)
Lemma hgFunc_comp_clos : forall gT (G : {group gT}),
  (appmod sF sF2) gT G \subset G.
Proof.
move=> gT G; rewrite /appmod; have nFD := (bgFunc_norm sF2 G).
rewrite sub_morphpre_im ?(bgFunc_clos sF) //=.
  by rewrite ker_coset_prim subIset // gen_subG (bgFunc_clos sF2 G).
by apply: subset_trans (bgFunc_clos sF _) _; apply: morphimS.
Qed.

Lemma hgFunc_comp_quo : forall gT (G : {group gT}) (B : {set gT}),
  (coset B @*^-1  sF _ (G / B)) / B  = sF _ (G / B).
Proof.
move=> gT A B; apply: morphpreK; apply: subset_trans (bgFunc_clos sF _) _.
by rewrite /= /quotient -morphimIdom  morphimS ?subsetIl.
Qed.

Lemma hgFunc_comp_cont : cont (appmod sF sF2).
Proof.
move=> gT rT G f; have nF := bgFunc_norm sF2.
have kF := ker_coset (Group (bgFunc_groupset sF2 _)); simpl in kF.
have sDF: G \subset 'dom (coset (sF2 _ G)) by rewrite ?nF.
have sDFf: G \subset 'dom (coset (sF2 _ (f @* G)) \o f).
  by rewrite -sub_morphim_pre ?subsetIl // nF.
pose K := 'ker (restrm sDFf (coset (sF2 _ (f @* G)) \o f)).
have sFK: 'ker (restrm sDF (coset (sF2 _ G))) \subset K.
  rewrite /K  !ker_restrm ker_comp /= subsetI subsetIl /=.
  by rewrite -sub_morphim_pre ?subsetIl // morphimIdom !kF ?morphim_sFunctor.
have sOF := bgFunc_clos sF (G / sF2 _ G); have sGG: G \subset G by [].
rewrite -sub_morphim_pre -?quotientE; last first.
  by apply: subset_trans (nF _ _); rewrite morphimS ?hgFunc_comp_clos.
suffices im_fact: forall H : {group gT}, sF2 _ G \subset H -> H \subset G ->
  factm sFK sGG @* (H / sF2 _ G) = f @* H / sF2 _ (f @* G).
- rewrite -2?im_fact ?hgFunc_comp_clos ?bgFunc_clos //.
  by rewrite hgFunc_comp_quo morphim_sFunctor /= ?morphim_restrm ?setIid //.
  by rewrite -{1}kF morphpreS ?sub1G.
move=> H sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid.
rewrite -morphimIG ?kF // -(morphim_restrm sDF) morphim_factm morphim_restrm.
by rewrite morphim_comp -quotientE morphimIdom.
Qed.

Canonical Structure hgFunc_comp_bgFunc :=
  [bgFunc by hgFunc_comp_clos & hgFunc_comp_cont].

Canonical Structure hgFunc_comp_gFunc := GFunc hgFunc_comp_cont.

End HereditaryIdentitySFComp.

Variables sF sF3 : hgFunc.

Lemma hgFunc_comp_hereditary : hereditary (appmod sF sF3).
Proof.
move=> gT H G sHG; set FGH := _ :&: H; have nF3H := bgFunc_norm sF3 H.
rewrite -sub_quotient_pre; last exact: subset_trans (subsetIr _ _) _.
pose rH := restrm nF3H (coset (sF3 _ H)); pose rHM := [morphism of rH].
have rnorm_simpl: rHM @* H = H / sF3 _ H by rewrite morphim_restrm setIid.
have nF3G := subset_trans sHG (bgFunc_norm sF3 _).
pose rG := restrm nF3G (coset (sF3 _ G)); pose rGM := [morphism of rG].
have sqKfK: 'ker rGM \subset 'ker rHM.
  rewrite !ker_restrm !ker_coset (setIidPr (bgFunc_clos sF3 _)) setIC /=.
  exact: (hgFunc_hereditary sF3).
have sHH := subxx H; rewrite -rnorm_simpl /= -(morphim_factm sqKfK sHH) /=.
apply: subset_trans (gFunc_cont sF _); rewrite /= {2}morphim_restrm setIid /=.
apply: subset_trans (morphimS _ (hgFunc_hereditary _ (quotientS _ sHG))) => /=.
have ->: FGH / _ = restrm nF3H (coset _) @* FGH.
  by rewrite morphim_restrm setICA setIid.
rewrite -(morphim_factm sqKfK sHH) morphimS //= morphim_restrm -quotientE.
by rewrite setICA setIid (subset_trans (quotientI _ _ _)) // cosetpreK.
Qed.

Canonical Structure hgFunc_comp_hgFunc := HGFunc hgFunc_comp_hereditary.

End HereditaryIdentitySubFunctorProps.

Section MonotonousIdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.

Section MonotonousIdBaseProps.

Variable sF : mgFunc.

Lemma mgFunc_cont : cont sF.
Proof. exact: gFunc_cont. Qed.

Lemma mgFunc_monotonous : monotonous sF.
Proof. by case sF. Qed.

End MonotonousIdBaseProps.

Section MonotonousIdentitySFComp.

Variables (sF : mgFunc) (sF2 : gFunc).

(* independent from the group preservation requirement *)
Lemma mgFunc_comp_clos : forall gT (G : {group gT}),
  (app sF sF2) gT G \subset G.
Proof.
by move=> gT G; rewrite (subset_trans (bgFunc_clos _ _)) ?bgFunc_clos.
Qed.

Lemma mgFunc_comp_cont : cont (app sF sF2).
Proof.
move=> gT hT G phi.
rewrite (subset_trans (morphim_sFunctor _ _ (bgFunc_clos _ _))) //.
by rewrite (subset_trans (mgFunc_monotonous sF (gFunc_cont sF2 phi))).
Qed.

Canonical Structure mgFunc_comp_bgFunc :=
  [bgFunc by mgFunc_comp_clos & mgFunc_comp_cont].

Canonical Structure mgFunc_comp_gFunc := GFunc mgFunc_comp_cont.

End MonotonousIdentitySFComp.

Variables sF sF3 : mgFunc.

Lemma mgFunc_comp_monotonous : monotonous (mgFunc_comp_gFunc sF sF3).
Proof. by move=> gT H G sHG; rewrite !mgFunc_monotonous. Qed.

Definition mgFunc_comp_hgFunc := MGFunc mgFunc_comp_monotonous.

End MonotonousIdentitySubFunctorProps.

Section IdentitySubFunctorsExamples.

Implicit Types gT : finGroupType.

Definition id_sF gT := @id {set gT}.

Lemma id_cont : cont id_sF.
Proof. by []. Qed.

Lemma id_monotonous : monotonous id_sF.
Proof. by []. Qed.

Canonical Structure bgFunc_id := [bgFunc by fun _ _ => subxx _ & id_cont].
Canonical Structure gFunc_id := GFunc id_cont.
Canonical Structure mgFunc_id := MGFunc id_monotonous.

Definition triv_sF gT of {set gT} := [1 gT].

Lemma triv_cont : cont triv_sF.
Proof. by move=> gT hT H f; rewrite morphim1. Qed.

Canonical Structure bgFunc_triv := [bgFunc by sub1G & triv_cont].
Canonical Structure gFunc_triv := GFunc triv_cont.
Canonical Structure hgFunc_triv :=
  @HGFunc gFunc_triv (fun gT G _ _ => subsetIl 1 G).

End IdentitySubFunctorsExamples.

Section Torsion.

Implicit Types gT hT: finGroupType.

Require Import finfun.

(* Orthogonality property*)
Definition trivlsed gT (B : {group gT}) hT (C : {group hT}) :=
  forall f : {morphism B >-> hT},
  f @* B \subset C -> f @* B :=: 1%G.

Definition GClass := forall gT (B: {group gT}), Prop.

Identity Coercion fun_of_obsel : GClass >-> Funclass.

Implicit Types P Pa Pb : GClass.

(* Closure properties*)

Definition cisom P := forall gT (G : {group gT}) hT (H : {group hT}),
  isog G H -> P _ G -> P _ H.

Definition csub P := forall gT (G H : {group gT}),
  H \subset G -> P _ G -> P _ H.

Definition cquo P := forall gT (G H : {group gT}),
  H <| G -> P _ G -> P _ (G / H)%G.

Lemma cquoisom1 P : cquo P -> cisom P ->
  (forall gT (G:{group gT}), P _ G -> forall hT, P _ (one_group hT)).
Proof.
move=> P qP iP gT G PG hT; have : P (coset_groupType G) 1%G.
  move:(trivg_quotient G); move/group_inj=><-.
  by apply:(qP _ _ _ (normal_refl _) PG).
apply:iP; rewrite isog_symr //; have:= (quotient1 G); move/group_inj=><-.
apply: (@isog_trans _ _ _ _ (one_group gT)); first by apply: trivial_isog.
apply: (isom_isog _ _ (quotient_isom (sub1G 'N(G)) (setIidPl (sub1G G)))).
by apply:subxx.
Qed.

Definition cex P := forall gT (G H : {group gT}),
  H <| G -> P _ H -> P _ (G / H)%G -> P _ G.

Definition cjoin P := forall gT (H G : {group gT}),
  P _ H -> P _ G -> P _ (H <*> G)%G.

(* TOFIX : this is a puny excuse for being 'closed by direct product' *)
Definition csetX P := forall gT (G : {group gT}) hT (H : {group hT}),
  P _ G -> P _ H -> P _ [group of setX G H].

(* Order relations on group classes *)

(* NB : lP has to relate polymorphically quantified classes,
   otherwise a finGroupType and a quotient type of it can't be in the same class
   This is necessary as soon as ClB below. *)

Definition lP Pa Pb := forall gT B, Pa gT B -> Pb _ B.

Definition eP Pa Pb := forall gT B, Pa gT B <-> Pb _ B.

(* a torsion theory is a couple of classes related by the two operators below.

   A formal definition would correspond to the hypotheses of sections
   EquivalenceTheorem2 & EquivalenceTheorem3.*)

Definition Rfun P hT (C : {group hT}) :=
  lP P (fun gT B => trivlsed B C) (* : forall gT, Prop ~= bool*).

Definition Lfun P gT (B : {group gT}) :=
  lP P (trivlsed B).

Lemma RightLeft : forall (Bs Cs : GClass),
   lP Cs (Rfun Bs) <-> lP Bs (Lfun Cs).
Proof.
by move=> Bs Cs; split; move=> H gT B HB hT C HC; apply H.
Qed.

(* TOFIX : those should be moved to section IdentitySubFunctorDefs *)
Definition Idemp (F : obmap) := forall gT (G : {group gT}), F _ (F _ G) = F _ G.
Definition radical (F : obmap) := forall gT (G : {group gT}),
  F _ (G / (F _ G)) = 1.

Section EquivalenceTheorem1.
(* An indempotent radical generated by a torsion theory*)

Variable T : mgFunc.
Hypothesis Hid : Idemp T.
Hypothesis Hrad : radical T.

Local Notation Bs :=
  (fun (fT:finGroupType) (B : {group fT}) => T _ B = B).
Local Notation Cs :=
  (fun (fT:finGroupType) (C : {group fT}) => T _ C = 1).

(* NB : we need monotonicity (alone) here *)
Lemma BCl : lP Bs (Lfun Cs).
Proof.
move=> gT B /= HB hT C /= HC; move=> f; rewrite /= -{6}HB.
move/(mgFunc_monotonous T)=>HTB; apply/trivgP; rewrite -HC.
by apply:subset_trans HTB; apply: mgFunc_cont.
Qed.

Lemma CBr : lP Cs (Rfun Bs).
Proof. by apply/RightLeft; apply:BCl. Qed.

(* NB : radicality alone needed*)
Lemma ClB : lP (Lfun Cs) Bs.
Proof.
move=> gT B2; rewrite /Lfun /lP; move/(_ _ (B2 / T _ B2)%G); move/(_ (Hrad B2)).
pose f:= [morphism of restrm (bgFunc_norm T B2) (coset (T _ B2))].
move/(_ f); rewrite /= /restrm quotientE=> H.
have e : B2 \subset 'ker (coset (T _ B2)).
  rewrite ker_trivg_morphim bgFunc_norm; apply/trivgP.
  by apply: val_inj; rewrite /= -H !morphim_restrm !morphimE setIid.
by apply/eqP; rewrite eqEsubset bgFunc_clos; rewrite ker_coset in e.
Qed.

(* NB : idempotence alone needed *)
Lemma BrC : lP (Rfun Bs) Cs.
Proof.
move=> hT C2; rewrite /Rfun /lP; move/(_ _ [group of T _ C2])=>/=.
move/(_ (Hid C2)); pose f := [morphism of restrm (bgFunc_clos T C2) (idm C2)].
move/(_ f); rewrite /= /restrm morphim_restrm morphim_idm setIid bgFunc_clos //.
by apply.
Qed.

Lemma eBC : eP Bs (Lfun Cs) /\ eP Cs (Rfun Bs).
Proof.
by split; move=> gT B; split; [apply BCl|apply ClB|apply CBr|apply BrC].
Qed.

End EquivalenceTheorem1.

Section EquivalenceTheorem2.

(* Here we get closure properties from Lfun properties.
   Those will ultimately allow us to build a corresponding
   (not necessarily idempotent) radical
*)

Variables Bs Cs : forall gT (_:{group gT}), Prop.
Hypothesis eBC : eP Bs (Lfun Cs).

Lemma hBCl : lP Bs (Lfun Cs).
Proof. by move=> gT B; rewrite (eBC B). Qed.

Lemma hClB : lP (Lfun Cs) Bs.
Proof. by move=> gT B; rewrite (eBC B). Qed.

Lemma cisomB : cisom Bs.
Proof.
move=> gT B hT C; move/isogP => [f Hfinj Hfim]; move/hBCl=>HB.
apply:hClB=> fT Y HY g Hgim; move : (injmK Hfinj (subxx _)).
rewrite Hfim=> Hfpre; have:= (comp_morphM g (f:=f)); rewrite Hfpre => H.
pose gof := Morphism H; move: (HB _ _ HY gof).
by rewrite morphimE imset_comp -morphimE Hfim -{2 4}(setIid C) -morphimE;
move/(_ Hgim).
Qed.

Lemma cquoB : cquo Bs.
Proof.
move=> gT X H Hs; move/hBCl=>HX; apply:hClB=> hT C2 HC2 g2 Hg2.
pose f:= [morphism of restrm (normal_sub Hs) (coset H)].
have:= (comp_morphM g2 (f:=f)); rewrite /restrm (quotientGK Hs)=>Hm.
pose g:= Morphism Hm; move:(HX _ _ HC2 g); rewrite morphimE imset_comp.
rewrite setIid -(setIidPr (normal_norm Hs)) -morphimE /= /restrm -quotientE.
by rewrite -{2 4}(setIid (X / H)) -morphimE; move/(_ Hg2).
Qed.

Lemma cexB : cex Bs.
Proof.
move=> gT M B Hs; move/hBCl=>HB; move/hBCl=> Hqu; apply:hClB=> hT C3 HC3 f3 Hf3.
move: (comp_morphM f3 (f:= [morphism of idm B])).
rewrite morphpre_idm (setIidPl (normal_sub Hs))=>Hf3i; pose f:= Morphism Hf3i.
move: (HB _ _ HC3 f); rewrite morphimE imset_comp -morphimE.
rewrite morphim_idm ?subxx // -{1 2}(setIidPr (normal_sub Hs)) -morphimE.
move/(_ (subset_trans (morphimS f3 (normal_sub Hs)) Hf3))=>Hf3B.
move/trivgP:(Hf3B); move/(conj (normal_sub Hs)); move/andP.
rewrite -ker_trivg_morphim=> HBker.
have Hinj : 'injm (coset (f3 @* B)) by rewrite Hf3B; apply:coset1_injm.
move: (morphM [morphism of (invm Hinj) \o (quotm f3 Hs)])=>/=.
rewrite -quotientE morphpre_quotm {1}Hf3B norm1 morphpreT=>Hq.
pose qfq := Morphism Hq; move:(Hqu _ _ HC3 qfq).
rewrite morphimE imset_comp -morphimE morphim_quotm quotientE.
have:= (subsetT (f3 @* M)); rewrite -norm1 -[1]/(gval _) -{1}Hf3B =>Hm.
rewrite -(setIidPr (morphimS _  Hm)) -morphimE morphim_invm ?Hm //.
by move/(_ Hf3).
Qed.

Lemma cjoinB : cjoin Bs.
Proof.
move=> Pb G H BH BG; apply: hClB=> hT C5 HC5 f5.
rewrite morphim_gen ?subset_gen // gen_subG {1}morphimU subUset.
rewrite 2!morphimE (setIidPr (mulgen_subl _ _)) (setIidPr (mulgen_subr _ _)).
move/andP=> [Hf5G Hf5H]; apply/trivgP; rewrite gen_subG.
rewrite sub_morphim_pre ?subset_gen -?sub_morphim_pre ?sub_gen //.
move: (morphM [morphism of f5 \o (idm G)]).
move: (morphM [morphism of f5 \o (idm H)]).
rewrite {1}[idm_morphism G @*^-1 _]morphpre_idm.
rewrite {1}[idm_morphism H @*^-1 _]morphpre_idm.
rewrite (setIidPl (mulgen_subl _ _)) (setIidPl (mulgen_subr _ _)) =>Hf Hg.
pose f:= Morphism Hf; pose g:= Morphism Hg.
move: (hBCl BH HC5) (hBCl BG HC5)=> HtG HtH; move: (HtG g) (HtH f).
rewrite 2!morphimE 2!imset_comp -!morphimE !morphim_idm ?subxx // morphimU.
rewrite subUset !morphimE (setIidPr (mulgen_subl _ _)).
rewrite (setIidPr (mulgen_subr _ _)); move/(_ Hf5G)=>->; move/(_ Hf5H)=>->.
by rewrite subxx.
Qed.

(*
TOFIX : add closure wrt direct sum
*)

End EquivalenceTheorem2.

Section EquivalenceTheorem3.

(* Closure properties from Rfun properties.
   Those will ultimately allow us to build a corresponding
   (not necessarily radical) idempotent pre-radical
*)

Variables Bs Cs : forall gT (_:{group gT}), Prop.
Hypothesis eCB : eP Cs (Rfun Bs).

(* This is done to syntactically isolate what I use, of course views apply
   bidirectionnaly
*)

Lemma hCBr : lP Cs (Rfun Bs).
Proof. by move=> gT C; rewrite (eCB C). Qed.

Lemma hBrC : lP (Rfun Bs) Cs.
Proof. by move=> gT C; rewrite (eCB C). Qed.

Lemma cisomC : cisom Cs.
Proof.
move=> gT G hT H; case/isogP=> f Hfinj Hfim; move/hCBr=>HC.
apply:hBrC=> fT Y HY g Hgim; pose h := (invm Hfinj)\o g.
have mH: morphic Y h.
  move:Hgim; rewrite (sub_morphim_pre _ _ (subxx _)); move/subsetP=>Hgim.
  have:= (comp_morphM [morphism of invm Hfinj] (f:=g)); rewrite /= Hfim=> Hm.
  by apply/morphicP; move=> x y; move/Hgim=> Hx; move/Hgim=>Hy; apply:Hm.
rewrite -Hfim in Hgim.
apply: (injm_morphim_inj (injm_invm Hfinj) Hgim (sub1G _)).
pose invfog := Morphism (morphicP mH); move: (HC _ _ HY invfog).
rewrite morphimE imset_comp -morphimE -{1 2}(setIidPr Hgim) -morphimE.
move/(morphimS [morphism of invm Hfinj]) : Hgim =>/=.
by rewrite morphim1 (morphim_invm _ (subxx _))=>Hi; move/(_ Hi).
Qed.

Lemma csubC : csub Cs.
Proof.
move=> hT X H Hs; move/hCBr=> HtBrG; apply:hBrC=> gT B2 HB2 f2 Hf2.
pose h:= (idm H) \o f2; have mH : morphic B2 h.
  rewrite (sub_morphim_pre _ _ (subxx _)) in Hf2; move/subsetP:Hf2=>Hf2.
  apply/morphicP; have := (morphM [morphism of h])=> Hm x y; move/Hf2=>Hx.
  by move/Hf2=>Hy; apply:Hm.
pose iof := Morphism (morphicP mH); move: (HtBrG _ _ HB2 iof); rewrite morphimE.
rewrite imset_comp -morphimE -{1 2}(setIidPr Hf2) -morphimE morphim_idm ?Hf2 //.
by move/(_ (subset_trans Hf2 Hs)).
Qed.

Lemma cexC : cex Cs.
Proof.
move=> hT M C Hs; move/hCBr=>HB; move/hCBr=> Hqu; apply:hBrC=> gT B3 HB3 f3 Hf3.
pose h:= (restrm (normal_norm Hs) (coset C)) \o f3.
have mH: morphic B3 h.
  apply/morphicP; move: (morphM [morphism of h])=> Hm x y.
  rewrite (sub_morphim_pre _ _ (subxx _)) in Hf3; move/subsetP:Hf3=>Hf3.
  by move/Hf3=> Hx; move/Hf3=> Hy; apply:Hm.
(* TOFIX : don't know why the simpl is mandatory here*)
move/morphicP: mH=> /= mH; pose hm := Morphism mH.
move: (Hqu _ _ HB3 hm); rewrite morphimE imset_comp -morphimE /restrm.
rewrite -{1 2}(setIidPr (subset_trans Hf3 (normal_norm Hs))) -morphimE.
rewrite -quotientE; move/(_ (quotientS _ Hf3)).
move/trivgP; move/(conj (subset_trans Hf3 (normal_norm Hs))); move/andP.
by rewrite -ker_trivg_morphim ker_coset; move/(HB _ _ HB3 f3).
Qed.

(* TOFIX : according to what is inferred in this lemma, the structures on
   [eta fst], [eta snd] declared in gprod.v don't work so well*)
Lemma csetXP : csetX Cs.
Proof.
move=> gT G hT H; move/hCBr=> HG; move/hCBr=> HH; apply hBrC=> fT B4 HB4 g4 Hg4.
pose p1g4 := restrm (subsetT (setX G H)) [morphism of fun x => x.1] \o g4.
pose p2g4 := restrm (subsetT (setX G H)) [morphism of fun x => x.2] \o g4.
have Hp1g4 : morphic B4 p1g4.
  apply/morphicP=> x y;  move: Hg4; rewrite (sub_morphim_pre _ _ (subxx _)).
  move/subsetP=> Hs; move/Hs=> Hx; move/Hs=>Hy.
  by apply:(morphM [morphism of p1g4]).
have Hp2g4: morphic B4 p2g4.
  apply/morphicP=> x y;  move: Hg4; rewrite (sub_morphim_pre _ _ (subxx _)).
  move/subsetP=> Hs; move/Hs=> Hx; move/Hs=>Hy.
  by apply: (morphM [morphism of p2g4]).
pose mp1g4:= Morphism (morphicP Hp1g4); pose mp2g4 := Morphism (morphicP Hp2g4).
move: (HG _ _ HB4 mp1g4) (HH _ _ HB4 mp2g4).
rewrite morphimE imset_comp -morphimE /restrm -{1}(setTI (g4 @* B4)) -morphimE.
move: (morphimS [morphism of restrm (subsetT (setX G H)) (fun x => x.1)] Hg4).
move: (morphimS [morphism of restrm (subsetT (setX G H)) (fun x => x.2)] Hg4).
rewrite morphim_fstX morphim_sndX /restrm=> Hm2 Hm1.
move/(_ Hm1)=>H1; rewrite morphimE imset_comp -morphimE /restrm.
rewrite  -{1}(setTI (g4 @* B4)) -morphimE; move/(_ Hm2)=> H2.
apply/trivgP; apply/subsetP; case=>[x1 x2 Hx12].
move: (mem_imset [morphism of fun x =>x.1] Hx12); rewrite H1 /=; move/set1P=>->.
move: (mem_imset [morphism of fun x =>x.2] Hx12); rewrite H2 /=; move/set1P=>->.
by apply/set1P.
Qed.

End EquivalenceTheorem3.

Section EquivalenceTheorem4.

(* Here, as well as in the next section we define a (pre-)radical from
 closure properties.

 Since our assumptions in the last section are minimal, the ones in this
 section might surprise. Notice that in fact, we simply require closure
 properties on the class we study (here, Bs), and computational definition
 on the other (C = B^r).

*)

Variables (Bs Cs : GClass).
Hypothesis  eCB : eP Cs (Rfun Bs).

(* This is done to syntactically isolate what I use, of course views apply
   bidirectionnaly
*)

Lemma hCBr' : lP Cs (Rfun Bs).
Proof. by move=> gT C; rewrite (eCB C). Qed.

Lemma hBrC' : lP (Rfun Bs) Cs.
Proof. by move=> gT C; rewrite (eCB C). Qed.

Hypothesis cquoB : cquo Bs.
Hypothesis cisomB : cisom Bs.
Hypothesis cexB : cex Bs.
Hypothesis cjoinB : cjoin Bs.

Variables Bbool Cbool : forall gT, pred {group gT}.
Hypothesis reflectB : forall gT (G:{group gT}), reflect (Bs G) (Bbool G).

(***************************************************************************)
(* This implies our interpretation of class Bs in terms of a functor will  *)
(* only be valid when Bs is not empty. We will have to carry around a      *)
(* non-emptyness hypothesis, but this is actually better than the          *)
(* alternative, which is to have a T that does not always carry a group    *)
(* structure (being sometimes empty) - hence one that wouldn't even fit our*)
(* bgFunc structure.                                                       *)
(***************************************************************************)

Definition T gT (G:{set gT}) :=
  \big[mulGen/1%G]_(H: {group gT} | (@Bbool _ H) && (H \subset G)) H.

(* The following is trivial, but important to notice *)
Lemma sub1TG : forall gT (G:{group gT}), 1%G \subset T G.
Proof. by move=> gT G; apply: sub1G. Qed.

Lemma noBstrivT : (forall gT (H:{group gT}), Bs H -> False) ->
  (forall hT (H:{group hT}), T H :=: 1).
Proof.
move=> noBs hT H; apply/trivgP; rewrite bigprodGE gen_subG.
by apply/bigcupsP=> G; case/andP; move/reflectB; move/noBs.
Qed.

Lemma T_B : forall hT (H:{group hT}), Bs H ->
  forall gT (G:{group gT}), Bs (T G).
Proof.
move=> hT H BsH gT G.
apply: big_prop; last by move=>H0; case/andP => BbH0 _; apply/reflectB.
  apply: (cquoisom1 cquoB cisomB BsH).
apply: cjoinB.
Qed.

Lemma T_sub : forall gT (G:{group gT}), T G \subset G.
Proof.
by move=>gT G; rewrite bigprodGE gen_subG; apply/bigcupsP=> H; case/andP.
Qed.

Lemma T_cont : cont T.
Proof.
move=> gT hT G f; have sUG:(\bigcup_(H | Bbool H && (H \subset G)) H \subset G).
 by apply/bigcupsP=> H; case/andP.
rewrite bigprodGE morphim_gen ?sUG ?gen_subG ?sub_morphim_pre ?sUG //.
apply/bigcupsP=> H; case/andP=> BbH sHG; rewrite -sub_morphim_pre ?sub_gen //.
rewrite -[f @* H]/(gval _); rewrite bigprodGE sub_gen //; apply:bigcup_sup.
rewrite morphimS ?andbT //; apply/reflectB; suff : (Bs (H / 'ker_H f)%G).
  by apply : cisomB; apply: (first_isog_loc f sHG).
apply:cquoB; last by apply/reflectB.
by rewrite /= -(ker_restrm sHG f) ker_normal.
Qed.

Canonical Structure bgFunc_T := [bgFunc by T_sub & T_cont].
Canonical Structure gFunc_T := GFunc (T_cont: cont bgFunc_T).

Lemma T_rad : radical T.
Proof.
move=> gT G; apply/trivgP; rewrite (@bigprodGE (coset_groupType _) _) gen_subG.
apply/bigcupsP=> H; case/andP=> BbH.
case/(inv_quotientS (bgFunc_normal bgFunc_T G)) => K KH sTGK sKG.
have KsNTG : K \subset 'N(T G) by exact: (subset_trans sKG (bgFunc_norm bgFunc_T G)).
rewrite KH quotient_sub1; last by exact: KsNTG.
rewrite bigprodGE sub_gen //; apply:bigcup_sup; rewrite sKG andbT.
move: (BbH); move/group_inj: KH =>->; move/reflectB => Bbquo.
apply/reflectB; apply: (cexB _ _ Bbquo); first by rewrite /normal sTGK KsNTG.
exact: (T_B (reflectB _ BbH)).
Qed.

Lemma T_Bs_devel : forall hT (H:{group hT}), Bs H ->
  forall gT (G : {group gT}), Bs G <-> T G :=: G.
Proof.
move=> hT H BsH gT G; split; last first.
  by move/group_inj=>eq; move:(T_B BsH G); rewrite eq.
move=> BsG; apply/eqP; rewrite eqEsubset; apply/andP; split; rewrite bigprodGE.
  by rewrite gen_subG; apply/bigcupsP=> H0; case/andP=> _.
by rewrite sub_gen //; apply: bigcup_sup; rewrite subxx andbT; apply/reflectB.
Qed.

Lemma T_idem : Idemp T.
Proof.
move=> gT G /=.
case e: (existsb H:{group gT}, Bbool H).
  move/idP: e; move/existsP; case=> /= H; move/reflectB=> BsH.
  by move: (T_B BsH G); move/(T_Bs_devel BsH).
suff noBs : (forall gT (H:{group gT}), Bs H -> False).
  by rewrite !(noBstrivT noBs).
move=> hT H BsH; case: (elimF existsP e); exists 1%G.
by apply/reflectB; apply: (cquoisom1 _ _ BsH).
Qed.

Lemma T_Cs_devel : forall hT (H:{group hT}), Bs H ->
  forall gT (G : {group gT}), Cs G <-> T G :=: 1%G.
Proof.
move=> hT H BsH gT G; split.
  move:(T_B BsH G)=>BsTG; move/hCBr'; move/(_ _ _ BsTG).
  move/(_ (idm_morphism (T G))); rewrite morphim_idm ?subxx //.
  (* TOFIX : Ugh ! Tsub !*)
  by move: (bgFunc_clos bgFunc_T G)=>/= TsubG; move/(_ TsubG).
move=> trivTG; apply: hBrC'=> hT0 H0 BsH0 f sfH0G.
apply/trivgP; rewrite -trivTG bigprodGE sub_gen //.
apply:bigcup_sup; rewrite sfH0G andbT; apply/reflectB.
move: (gFunc_cont gFunc_T f); move:(BsH0); move/(T_Bs_devel BsH0 H0)=>-> /=.
move/(conj (bgFunc_clos bgFunc_T (f @* H0))); move/andP; rewrite -eqEsubset /=.
by move/eqP; move/(T_Bs_devel BsH0).
Qed.

End EquivalenceTheorem4.

End Torsion.

Unset Implicit Arguments.


Require Import List.
Import ListNotations.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.BuiltinSyntax.
Require Import Cryptol.Values.
Require Import Cryptol.Bitstream.
Require Import Cryptol.Lib.
Require Import Cryptol.GlobalExtends.
Require Import Cryptol.GetEachN.

Require Import Cryptol.EvalTac.
Require Import Cryptol.Eager.

Require Import Cryptol.Prims.
Require Import SHA256.SHA256.

Definition w32 := tseq 32 tbit.

Definition S1_spec (x : ext_val) : ext_val :=
  match x with
  | eseq x => eseq (xor_ev (xor_ev (rotr_ev x 6) (rotr_ev x 11)) (rotr_ev x 25))
  | _ => eseq nil
  end.

Lemma S1_eval :
  forall x,
    has_type x w32 ->
    forall GE TE SE,
      wf_env ge GE TE SE ->
      forall ex res,
        eager_eval_expr GE TE SE ex (to_sval x) ->
        res = (to_sval (S1_spec x)) ->
        eager_eval_expr GE TE SE (EApp (EVar S1) ex) res.
Proof.
  intros.
  gen_global (33,">>>").
  gen_global (28,"^").
  gen_global S1.
  gen_global (0,"demote").
  inversion H. subst.
  e. ag.
  e. use xor_eval.
  use xor_eval.
  use rotr_eval.
  lv.

  use demote_eval.
  simpl. f_equal.
  unfold strictnum. f_equal.
  unfold strictval_from_bitv.
  instantiate (1 := (ebit true) :: (ebit true) :: (ebit false) :: nil).
  reflexivity.
  unfold ExtToBitvector.to_bitv. simpl.
  instantiate (2 := 3%nat).
  simpl. reflexivity. reflexivity. eassumption.
  solve [repeat econstructor; eauto].
  use rotr_eval; try lv.
  use demote_eval.
  simpl. f_equal.
  unfold strictnum. f_equal.
  unfold strictval_from_bitv.
  instantiate (1 := (ebit true) :: (ebit false) :: (ebit true) :: (ebit true) :: nil).
  reflexivity.
  instantiate (2 := 4%nat). reflexivity.
  reflexivity. eassumption.
  solve [repeat econstructor; eauto].
  reflexivity.

  eapply has_type_rotr. eassumption.
  eapply has_type_rotr. eassumption.

  use rotr_eval; try lv.
  use demote_eval.
  simpl. f_equal.
  unfold strictnum. f_equal.
  unfold strictval_from_bitv.
  instantiate (1 := (ebit true) :: (ebit true) :: (ebit false) :: (ebit false) :: (ebit true) :: nil).
  reflexivity.
  unfold ExtToBitvector.to_bitv. simpl.
  instantiate (2 := 5%nat).
  reflexivity.
  reflexivity.
  eassumption.
  solve [repeat econstructor; eauto].
  reflexivity.
  eapply has_type_xor.
  eapply has_type_rotr. eassumption.
  eapply has_type_rotr. eassumption.
  eapply has_type_rotr. eassumption.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-27

Operation of lifting (increasing indexes of variables)
and lowering (decreasing them) on terms of simply typed
lambda-calculus (which is an equivalent of renaming
of variables for the representation of terms using
de Bruijn indices) is defined in this file.
*)

Set Implicit Arguments.

From Coq Require Import Compare_dec Arith Lia.
From CoLoR Require Import RelExtras ListExtras LogicUtil.
From CoLoR Require TermsManip.

Module TermsLifting (Sig : TermsSig.Signature).

  Module Export TB := TermsManip.TermsManip Sig.

  Fixpoint prelift_aux (n: nat) (P: Preterm) (k: nat) : Preterm :=
    match P with
    | Fun _ => P
    | Var i =>
        match (le_gt_dec k i) with
	| left _ =>  (* i >= k *) Var (i + n)
	| right _ => (* i < k *)  Var i
	end
    | App M N => App (prelift_aux n M k) (prelift_aux n N k)
    | Abs A M => Abs A (prelift_aux n M (S k))
    end.
  Definition prelift P n := prelift_aux n P 0.

  Definition liftedEnv (n: nat) (E: Env) (k: nat) : Env :=
    initialSeg E k ++ copy n None ++ finalSeg E k.

  Lemma liftedEnv_next : forall A E n k,
    liftedEnv n (decl A E) (S k) = decl A (liftedEnv n E k).

  Proof.
    intros A E n k.
    unfold liftedEnv; simpl.
    destruct k.
    simpl.
    rewrite finalSeg_full.
    unfold decl; rewrite finalSeg_cons; trivial.
    destruct E; trivial.
  Qed.

  Global Hint Rewrite liftedEnv_next : terms.

  Lemma liftedEnv_var_lifted : forall E x A k n, E |= x := A -> x >= k ->
    liftedEnv n E k |= x + n := A.

  Proof.
    intros E x A k n.
    unfold VarD, liftedEnv.
    intros E_x x_k.
    assert (x_E: x < length E).
    rewrite_lr (nth_in E x).
    destruct (nth_error E x); discr.
    assert (k_E: Min.min k (length E) = k).
    apply Min.min_l.
    lia.
    rewrite nth_app_right; autorewrite with datatypes.
    rewrite k_E.
    rewrite nth_app_right; autorewrite with datatypes.
    replace (k + (x + n - k - n)) with x; trivial.
    lia.
    lia.
    lia.
  Qed.

  Lemma liftedEnv_var_notLifted : forall E x A k n,
    E |= x := A -> x < k -> liftedEnv n E k |= x := A.

  Proof.
    unfold VarD, liftedEnv.
    intros E x A k n Ex x_k.
    rewrite nth_app_left.
    rewrite initialSeg_nth; trivial.
    autorewrite with datatypes.
    apply (Min.min_case2 k (length E)); trivial.
    rewrite_lr (nth_in E x).
    destruct (nth_error E x); discr.
  Qed.

  Lemma var_liftedEnv_var_lifted : forall E x A k n,
    liftedEnv n E k |= x + n := A -> x >= k -> E |= x := A.

  Proof.
    unfold VarD, liftedEnv.
    intros E x A k n Ex x_k.
    assert (x < length E).
    set (q := initialSeg E k ++ copy n None ++ finalSeg E k).
    assert (nth_error q (x + n) <> None).
    unfold q; try_solve.
    set (w := proj1 (nth_in q (x + n)) H).
    assert (length q = length E + n).
    unfold q.
    do 2 rewrite length_app.
    rewrite plus_comm.
    rewrite <- plus_assoc.
    rewrite (plus_comm (length (finalSeg E k)) (length (initialSeg E k))).
    rewrite initialFinalSeg_length.
    autorewrite with datatypes using lia.
    rewrite H0 in w; lia.
    rewrite nth_app_right in Ex.
    rewrite initialSeg_length in Ex.
    destruct (le_lt_dec k (length E)).
    rewrite nth_app_right in Ex.
    rewrite copy_length in Ex.
    rewrite Min.min_l in Ex; trivial.
    rewrite (finalSeg_nth_nth E x_k).
    replace (x - k) with (x + n - k - n); trivial.
    lia.
    autorewrite with datatypes.
    rewrite Min.min_l; trivial.
    lia.
    lia.
    autorewrite with datatypes.
    destruct (le_gt_dec k (length E)).
    rewrite Min.min_l; solve [trivial | lia].
    lia.
  Qed.

  Lemma var_liftedEnv_var_notLifted : forall E x A k n,
    liftedEnv n E k |= x := A -> x < k -> E |= x := A.

  Proof.
    unfold VarD, liftedEnv.
    intros E x A k n Ex x_k.
    destruct (le_gt_dec k (length E)).
    rewrite nth_app_left in Ex.
    rewrite <- (initialSeg_nth E x_k); trivial.
    autorewrite with datatypes.
    rewrite Min.min_l; trivial.
    destruct (le_gt_dec (length E) x).
    rewrite nth_app_right in Ex.
    rewrite initialSeg_length in Ex.
    rewrite Min.min_r in Ex; [trivial | lia].
    rewrite finalSeg_empty in Ex; trivial.
    rewrite <- app_nil_end in Ex.
    destruct (le_gt_dec (length (copy n (A := option SimpleType) None))
      (x - length E)).
    set (w := nth_beyond (copy n None) l0); try_solve.
    assert (x - length E < n).
    rewrite copy_length in g0.
    trivial.
    set (w := nth_copy_in (A:=option SimpleType) (n:=n) None H); try_solve.
    lia.
    autorewrite with datatypes.
    rewrite Min.min_r; trivial.
    lia.
    rewrite nth_app_left in Ex.
    rewrite <- (initialSeg_nth E x_k); trivial.
    autorewrite with datatypes.
    rewrite Min.min_r; lia.
  Qed.

  Global Hint Rewrite liftedEnv_var_lifted liftedEnv_var_notLifted
    var_liftedEnv_var_lifted var_liftedEnv_var_notLifted
    using solve [lia | auto] : terms.

  Definition lift_aux : forall (n: nat) (M: Term) (k: nat),
   {N: Term | env N = liftedEnv n (env M) k
              /\ term N = prelift_aux n (term M) k /\ type N = type M }.

  Proof.
    intros n M; gen n; clear n.
    destruct M as [E Pt T TypM].
    induction TypM; intros n k.
     (* variable *)
    simpl.
    case (le_gt_dec k x); intro xk.
    assert (TT: (liftedEnv n E k) |- %(x + n) := A).
    constructor.
    apply liftedEnv_var_lifted; trivial.
    exists (buildT TT); repeat split; auto.
    assert (TT: (liftedEnv n E k) |- %x := A).
    constructor.
    apply liftedEnv_var_notLifted; trivial.
    exists (buildT TT); repeat split; auto.
    simpl.
     (* function symbol *)
    assert (TT: (liftedEnv n E k) |- ^f := f_type f).
    constructor.
    exists (buildT TT); auto.
     (* abstraction *)
    destruct (IHTypM n (S k)) as [W [envW [termW typeW]]].
    destruct W as [EW PtW TW TypW].
    simpl in *.
    assert (TT: (liftedEnv n E k) |- \A => PtW := A --> B).
    constructor.
    rewrite <- liftedEnv_next.
    rewrite <- envW.
    rewrite <- typeW.
    trivial.
    exists (buildT TT); repeat split; auto.
    simpl; rewrite termW; auto.
     (* application *)
    destruct (IHTypM1 n k) as [L [envL [termL typeL]]].
    destruct (IHTypM2 n k) as [R [envR [termR typeR]]].
    destruct L as [EL PtL' TL TypL].
    destruct R as [ER PtR' TR TypR].
    simpl in * .
    rewrite typeL in TypL.
    rewrite typeR in TypR.
    rewrite envL in TypL.
    rewrite envR in TypR.
    exists (buildT (TApp TypL TypR)); repeat split; auto.
    simpl; congruence.
  Defined.

  Definition lift (M: Term)(n: nat) : Term :=
    proj1_sig (lift_aux n M 0).

  Definition Subst := list (option Term).

  Definition lift_subst_comp P l :=
    match P with
    | None => None
    | Some P => Some (lift P l)
    end.

  Definition lift_subst (G: Subst)(l: nat) : Subst := map (fun T => lift_subst_comp T l) G.

  #[global] Hint Resolve prelift_aux : terms.
  #[global] Hint Unfold lift : terms.

  Lemma lift_env : forall M n, env (lift M n) = liftedEnv n (env M) 0.

  Proof.
    intros; unfold lift.
    destruct (lift_aux n M 0) as [M' [env_M' [term_M' type_M']]].
    trivial.
  Qed.

  Lemma lift_term : forall M n, term (lift M n) = prelift (term M) n.

  Proof.
    intros; unfold lift.
    destruct (lift_aux n M 0) as [M' [env_M' [term_M' type_M']]].
    trivial.
  Qed.

  Lemma lift_type : forall M n, type (lift M n) = type M.

  Proof.
    intros; unfold lift.
    destruct (lift_aux n M 0) as [M' [env_M' [term_M' type_M']]].
    trivial.
  Qed.

  Global Hint Rewrite lift_env lift_term lift_type : terms.

  Lemma in_lift_subst : forall Q G i, In (Some Q) (lift_subst G i) ->
    (exists2 W, In (Some W) G  &  Q = lift W i).

  Proof.
    induction G.
    simpl; tauto.
    intros i Q_G.
    unfold lift_subst_comp in Q_G; simpl in Q_G.
    destruct Q_G.
    destruct a; try discr.
    exists t.
    auto with datatypes.
    unfold lift_subst_comp in H; simpl in H.
    congruence.
    destruct (IHG i); trivial.
    exists x; auto with datatypes.
  Qed.

  Lemma lift_subst_distr : forall G H i,
    lift_subst (G ++ H) i = lift_subst G i ++ lift_subst H i.

  Proof.
    induction G; trivial.
    intros H i; simpl.
    rewrite (IHG H i); trivial.
  Qed.

  Lemma prelift_aux_0 : forall Pt i, prelift_aux 0 Pt i = Pt.

  Proof.
    induction Pt; intro i.
     (* variable *)
    unfold prelift_aux.
    case (le_gt_dec i x); auto.
     (* function symbol *)
    auto.
     (* abstraction *)
    simpl.
    rewrite (IHPt (S i)); trivial.
     (* application *)
    simpl.
    rewrite (IHPt1 i); rewrite (IHPt2 i); trivial.
  Qed.

  Lemma prelift_0 : forall Pt, prelift Pt 0 = Pt.

  Proof.
    unfold prelift; intros.
    apply prelift_aux_0.
  Qed.

  Lemma lift_0 : forall (M: Term), lift M 0 = M.

  Proof.
    intro M.
    unfold lift.
    destruct (lift_aux 0 M 0) as [W [envW [termW typeW]]].
    simpl.
    apply term_eq.
    rewrite envW.
    unfold liftedEnv.
    simpl.
    rewrite finalSeg_full; trivial.
    rewrite termW.
    rewrite (prelift_aux_0 (term M) 0); trivial.
  Qed.

  Lemma lift_subst_0 : forall (G: Subst), lift_subst G 0 = G.

  Proof.
    induction G; trivial.
    simpl; unfold lift_subst_comp.
    destruct a; try rewrite lift_0; rewrite IHG; trivial.
  Qed.

  Global Hint Rewrite prelift_aux_0 prelift_0 lift_0 lift_subst_0 : terms.

  Lemma prelift_aux_fold_aux : forall Pt m n i j, j >= i -> j <= n + i ->
    prelift_aux m (prelift_aux n Pt i) j = prelift_aux (m + n) Pt i.

  Proof.
    induction Pt; unfold prelift; intros m n i j j_ge j_le; simpl.
    destruct (le_gt_dec i x); simpl.
    destruct (le_gt_dec j (x + n)); simpl.
    assert (x + (m + n) = x + n + m).
    lia.
    try_solve.
    lia.
    destruct (le_gt_dec j x); simpl.
    lia.
    try_solve.
    trivial.
    rewrite <- (IHPt m n (S i) (S j)); trivial.
    lia.
    lia.
    rewrite IHPt1; try_solve.
    rewrite IHPt2; try_solve.
  Qed.

  Lemma prelift_aux_fold : forall Pt m n i,
    prelift_aux (m + n) Pt i = prelift_aux m (prelift_aux n Pt i) i.

  Proof.
    intros.
    rewrite prelift_aux_fold_aux; try_solve.
    lia.
  Qed.

  Lemma prelift_fold : forall Pt m n,
    prelift Pt (m + n) = prelift (prelift Pt n) m.

  Proof.
    intros Pt m n.
    unfold prelift.
    apply prelift_aux_fold.
  Qed.

  Lemma lift_fold : forall Pt m n, lift Pt (m + n) = lift (lift Pt m) n.

  Proof.
    intros Pt m n.
    unfold lift.
    destruct (lift_aux (m+n) Pt 0) as [L [envL [termL typeL]]].
    destruct (lift_aux m Pt 0) as [Rm [envRm [termRm typeRm]]].
    simpl.
    destruct (lift_aux n Rm 0) as [Rn [envRn [termRn typeRn]]].
    apply term_eq; simpl in * .

     (* equality of environments *)
    rewrite envL, envRn, envRm. unfold liftedEnv; simpl.
    rewrite !finalSeg_full, plus_comm, copy_split, app_ass; trivial.

     (* equality of preterms *)
    rewrite termL, termRn, termRm, plus_comm. fold (prelift (term Pt) (n+m)).
    rewrite prelift_fold. trivial.
  Qed.

  Lemma lift_fold_1out : forall M n, lift (lift M n) 1 = lift M (S n).

  Proof.
    intros.
    replace (S n) with (n + 1).
    rewrite lift_fold; trivial.
    lia.
  Qed.

  Lemma lift_fold_1in : forall M n, lift (lift M 1) n = lift M (S n).

  Proof.
    intros.
    replace (S n) with (1 + n).
    rewrite lift_fold; trivial.
    lia.
  Qed.

  Lemma lift_subst_fold : forall G m n,
    lift_subst G (m+n) = lift_subst (lift_subst G m) n.

  Proof.
    induction G.
    trivial.
    intros m n; simpl.
    rewrite (IHG m n).
    destruct a; simpl.
    rewrite lift_fold; trivial.
    trivial.
  Qed.

  Global Hint Rewrite lift_fold lift_subst_fold : terms.

  Lemma lift_empty_subst : forall m i,
    lift_subst (copy m None) i = copy m None.

  Proof.
    induction m; intro i.
    trivial.
    simpl.
    rewrite (IHm i); trivial.
  Qed.

  Lemma length_lift_subst : forall G i, length (lift_subst G i) = length G.

  Proof.
    induction G.
    trivial.
    intro i; simpl.
    rewrite (IHG i); trivial.
  Qed.

  Global Hint Rewrite lift_empty_subst length_lift_subst : terms.

  Lemma nth_lift_subst_n : forall (G: Subst) i x, nth_error G x = None ->
    nth_error (lift_subst G i) x = None.

  Proof.
    unfold lift_subst; intros.
    rewrite nth_map_none; trivial.
  Qed.

  Lemma nth_lift_subst_n_rev : forall (G: Subst) i x,
    nth_error (lift_subst G i) x = None -> nth_error G x = None.

  Proof.
    unfold lift_subst; intros.
    rewrite (nth_map_none_rev G x (fun T => lift_subst_comp T i) H); trivial.
  Qed.

  Lemma nth_lift_subst_sn : forall G i x, nth_error G x = Some None ->
    nth_error (lift_subst G i) x = Some None.

  Proof.
    unfold lift_subst; intros.
    rewrite (nth_map_some G x (fun T => lift_subst_comp T i) H).
    simpl; trivial.
  Qed.

  Lemma nth_lift_subst_sn_rev : forall G i x,
    nth_error (lift_subst G i) x = Some None -> nth_error G x = Some None.

  Proof.
    unfold lift_subst; intros.
    destruct (nth_map_some_rev G x (fun T => lift_subst_comp T i) H)
      as [T [GT LT]].
    destruct T; trivial.
    try_solve.
  Qed.

  Lemma nth_lift_subst_s : forall G i x T, nth_error G x = Some (Some T) ->
    nth_error (lift_subst G i) x = Some (Some (lift T i)).

  Proof.
    unfold lift_subst; intros.
    rewrite (nth_map_some G x (fun T => lift_subst_comp T i) H).
    simpl; trivial.
  Qed.

  Global Hint Rewrite nth_lift_subst_n nth_lift_subst_n_rev nth_lift_subst_sn
    nth_lift_subst_sn_rev
    using solve [auto with terms] : terms.

  Lemma nth_lift_subst_s_rev : forall G i x T,
    nth_error (lift_subst G i) x = Some (Some T) ->
    exists T', nth_error G x = Some (Some T') /\ T = lift T' i.

  Proof.
    unfold lift_subst; intros.
    destruct (nth_map_some_rev G x (fun T => lift_subst_comp T i) H)
      as [W [GW LW]].
    destruct W.
    exists t; split; try_solve.
    try_solve.
  Qed.

  Lemma nth_lift_normal : forall G i x T,
    nth_error (lift_subst G i) x = Some (Some T) ->
    exists2 Tg, T = lift Tg i & nth_error G x = Some (Some Tg).

  Proof.
    induction G; destruct x; try_solve.
    destruct a; try_solve.
    exists t; try_solve.
  Qed.

  Lemma app_lift_app_aux : forall M (Mapp: isApp M) n k,
    isApp (proj1_sig (lift_aux n M k)).

  Proof.
    intros.
    destruct M as [E Pt T M]; destruct M; try contr.
    destruct (lift_aux n (buildT (TApp M1 M2))) as [W [WE [WPt WT]]].
    apply app_isApp with (prelift_aux n PtL k) (prelift_aux n PtR k); trivial.
  Qed.

  Lemma app_lift_app : forall M (Mapp: isApp M) n, isApp (lift M n).

  Proof.
    intros; unfold lift.
    apply app_lift_app_aux; trivial.
  Qed.

  Lemma lift_absBody : forall E Pt A B (M: decl A E |- Pt := B) n k
    (MLabs: isAbs (proj1_sig (lift_aux n (buildT (TAbs M)) k))),
    absBody MLabs = proj1_sig (lift_aux n (buildT M) (S k)).

  Proof.
    intros.
    destruct (lift_aux n (buildT M) (S k)) as [P [Penv [Pterm Ptype]]].
    destruct (lift_aux n (buildT (TAbs M)) k) as [Q [Qenv [Qterm Qtype]]].
    apply term_eq.
     (* equal environment *)
    rewrite absBody_env.
    simpl; rewrite Penv; rewrite Qenv.
    unfold liftedEnv, decl; simpl.
    replace A with (absType MLabs).
    unfold finalSeg; trivial.
    apply abs_type with B; trivial.

     (* equal preterm *)
    apply absBody_term with A.
    simpl; rewrite Qterm; rewrite Pterm; trivial.
  Qed.

  Lemma lift_appBodyL : forall E PtL PtR A B n k (Ml: E |- PtL := A --> B)
    (Mr: E |- PtR := A)
    (MLapp: isApp (proj1_sig (lift_aux n (buildT (TApp Ml Mr)) k))),
    appBodyL MLapp = proj1_sig (lift_aux n (buildT Ml) k).

  Proof.
    intros.
    destruct (lift_aux n (buildT (TApp Ml Mr)) k) as [P [PE [PPt PA]]].
    destruct (lift_aux n (buildT Ml) k) as [Q [QE [QPt QA]]].
    apply term_eq.
     (* environment equal *)
    rewrite appBodyL_env.
    simpl; rewrite QE; rewrite PE; trivial.
     (* preterms equal *)
    simpl; rewrite QPt; simpl.
    apply appBodyL_term with (prelift_aux n PtR k).
    rewrite PPt; trivial.
  Qed.

  Lemma lift_appBodyR : forall E PtL PtR A B n k (Ml: E |- PtL := A --> B)
    (Mr: E |- PtR := A)
    (MLapp: isApp (proj1_sig (lift_aux n (buildT (TApp Ml Mr)) k))),
    appBodyR MLapp = proj1_sig (lift_aux n (buildT Mr) k).

  Proof.
    intros.
    destruct (lift_aux n (buildT (TApp Ml Mr)) k) as [P [PE [PPt PA]]].
    destruct (lift_aux n (buildT Mr) k) as [Q [QE [QPt QA]]].
    apply term_eq.
     (* environment equal *)
    rewrite appBodyR_env.
    simpl; rewrite QE; rewrite PE; trivial.
     (* preterms equal *)
    simpl; rewrite QPt; simpl.
    apply appBodyR_term with (prelift_aux n PtL k).
    rewrite PPt; trivial.
  Qed.

  Lemma term_prelift_eq : forall M N i j,
    prelift_aux i M j = prelift_aux i N j -> M = N .

  Proof.
    induction M; destruct N; intros; try_solve; try solve
      [destruct (le_gt_dec j x); try_solve].
    destruct (le_gt_dec j x); destruct (le_gt_dec j x0); try_solve.
    inversion H.
    cut (x = x0); [auto | lia].
    inversion H; lia.
    inversion H; lia.
    rewrite (IHM N i (S j)); inversion H; trivial.
    rewrite (IHM1 N1 i j).
    rewrite (IHM2 N2 i j).
    trivial.
    inversion H; trivial.
    inversion H; trivial.
  Qed.

  Lemma terms_lift_eq : forall M N, lift M 1 = lift N 1 -> M = N.

  Proof.
    intros.
    apply term_eq.
    cut (env (lift M 1) = env (lift N 1)).
    autorewrite with terms datatypes using unfold liftedEnv; try_solve.
    rewrite H; trivial.
    apply term_prelift_eq with 1 0.
    cut (term (lift M 1) = term (lift N 1)).
    autorewrite with terms using trivial.
    rewrite H; trivial.
  Qed.

  Fixpoint prelower_aux (P: Preterm) (k: nat) : Preterm :=
    match P with
    | Fun _ => P
    | Var i =>
        match (le_gt_dec k i) with
	| left _ =>  (* i >= k *) Var (pred i)
	| right _ => (* i < k *)  Var i
	end
    | App M N => App (prelower_aux M k) (prelower_aux N k)
    | Abs A M => Abs A (prelower_aux M (S k))
    end.
  Definition prelower P := prelower_aux P 0.

  Definition loweredEnv (E: Env) (k: nat) : Env :=
    initialSeg E k ++ finalSeg E (S k).

  Lemma loweredEnv_var_lowered : forall E x A k,
    E |= k :! -> E |= x := A -> k <= x -> loweredEnv E k |= pred x := A.

  Proof.
    intros E x A k Ek0 Ex k_x.
    assert (x_E: x < length E).
    rewrite_lr (nth_in E x); unfold VarD in Ex; try_solve.
    destruct (le_lt_or_eq k_x) as [k_lt_x | k_eq_x].
    destruct x.
    lia.
    unfold VarD, loweredEnv.
    rewrite nth_app_right.
    unfold finalSeg; simpl.
    destruct E; try_solve.
    assert (k_E: Min.min k (S (length E)) = k).
    rewrite Min.min_l; lia.
    rewrite seg_nth.
    rewrite initialSeg_length; simpl.
    rewrite k_E.
    replace (k + (x - k)) with x; solve [trivial | lia].
    rewrite initialSeg_length; simpl.
    rewrite k_E; lia.
    rewrite initialSeg_length.
    rewrite Min.min_l; lia.
    rewrite k_eq_x in Ek0.
    unfold VarD in Ex; destruct Ek0; try_solve.
  Qed.

  Lemma loweredEnv_var_notLowered : forall E x A k,
    E |= k :! -> E |= x := A -> k > x -> loweredEnv E k |= x := A.

  Proof.
    intros E x A k Ek0 Ex kx.
    unfold VarD, loweredEnv.
    rewrite nth_app_left.
    rewrite initialSeg_nth; trivial.
    rewrite initialSeg_length; trivial.
    apply Min.min_case2; trivial.
    rewrite_lr (nth_in E x); unfold VarD in Ex; try_solve.
  Qed.

  Lemma var_loweredEnv_var_lowered : forall E x A k,
    E |= k :! -> loweredEnv E k |= x := A -> k <= x -> E |= S x := A.

  Proof.
    unfold VarD, loweredEnv.
    intros E x A k Ek0 Ex kx.
    rewrite nth_app_right in Ex.
    rewrite initialSeg_length in Ex.
    destruct (le_gt_dec (length E) k).
    rewrite finalSeg_empty in Ex.
    destruct (x - Min.min k (length E)); try_solve.
    lia.
    rewrite Min.min_l in Ex.
    destruct (le_gt_dec (length E) (S x)).
    rewrite nth_beyond in Ex; try_solve.
    rewrite finalSeg_length.
    lia.
    rewrite (@finalSeg_nth_nth (option SimpleType) E (S k) (S x)).
    replace (S x - S k) with (x - k); trivial.
    lia.
    lia.
    rewrite initialSeg_length.
    set (w := Min.le_min_l k (length E)).
    lia.
  Qed.

  Lemma var_loweredEnv_var_notLowered : forall E x A k,
    E |= k :! -> loweredEnv E k |= x := A -> k > x -> E |= x := A.

  Proof.
    unfold VarD, loweredEnv.
    intros E x A k Ek0 Ex kx.
    destruct (le_gt_dec (length E) x).
    destruct (le_gt_dec k (length E)).
    rewrite nth_app_left in Ex; trivial.
    rewrite <- (initialSeg_nth E kx); trivial.
    autorewrite with datatypes.
    apply Min.min_case2; lia.
    rewrite nth_app_right in Ex.
    rewrite finalSeg_empty in Ex.
    destruct (x - length (initialSeg E k)); try_solve.
    lia.
    autorewrite with datatypes.
    rewrite Min.min_r; trivial.
    lia.
    rewrite nth_app_left in Ex.
    rewrite initialSeg_nth in Ex; trivial.
    autorewrite with datatypes.
    apply Min.min_case2; lia.
  Qed.

  Lemma prelower_prelift_aux : forall Pt i j k, k >= j -> k <= i + j + 1 ->
    prelift_aux i Pt j = prelower_aux (prelift_aux (i + 1) Pt j) k.

  Proof.
    induction Pt; intros; simpl.
    destruct (le_gt_dec j x); simpl.
    destruct (le_gt_dec k (x + (i + 1))); simpl.
    assert (x + i = pred (x + (i + 1))).
    lia.
    try_solve.
    lia.
    destruct (le_gt_dec k x); trivial.
    lia.
    trivial.
    rewrite (IHPt i (S j) (S k)); solve [trivial | lia].
    rewrite (IHPt1 i j k); try lia.
    rewrite (IHPt2 i j k); try lia.
    trivial.
  Qed.

  Lemma prelower_prelift : forall Pt i,
    prelift Pt i = prelower_aux (prelift Pt (i + 1)) i.

  Proof.
    intros; unfold prelift.
    apply prelower_prelift_aux.
    lia.
    lia.
  Qed.

  Definition lower_aux : forall (M: Term) (k: nat), env M |= k :! ->
    {N: Term | env N = loweredEnv (env M) k
               /\ term N = prelower_aux (term M) k /\ type N = type M }.

  Proof.
    destruct M as [E Pt T TypM].
    induction TypM; intros k env0.

     (* variable *)
    simpl.
    case (le_gt_dec k x); intro k_x.
     (*   - variable lowered *)
    set (res := loweredEnv_var_lowered env0 v k_x).
    exists (buildT (TVar res)); repeat split; try_solve.
     (*  - variable untouched *)
    set (res := loweredEnv_var_notLowered env0 v k_x).
    exists (buildT (TVar res)); repeat split; try_solve.

     (* function symbols *)
    exists (buildT (TFun (loweredEnv E k) f)); split; try_solve.

     (* abstraction *)
    simpl in * .
    assert (res: loweredEnv E k |- \A => prelower_aux Pt (S k) := A --> B).
    constructor.
    destruct (IHTypM (S k)) as [W [WE [WPt WB]]]; try_solve.
    rewrite <- WPt.
    rewrite <- WB.
    replace (decl A (loweredEnv E k)) with (loweredEnv (decl A E) (S k)).
    rewrite <- WE.
    exact (typing W).
    unfold loweredEnv, finalSeg; try_solve.
    exists (buildT res); repeat split; try_solve.

     (* application *)
    simpl in * .
    destruct (IHTypM1 k) as [L [LE [LPt LT]]]; trivial.
    destruct (IHTypM2 k) as [R [RE [RPt RT]]]; trivial.
    assert
      (res: loweredEnv E k |- prelower_aux PtL k [prelower_aux PtR k] := B).
    constructor 4 with A.
    rewrite <- LE.
    rewrite <- LPt.
    rewrite <- LT.
    exact (typing L).
    rewrite <- RE.
    rewrite <- RPt.
    rewrite <- RT.
    exact (typing R).
    exists (buildT res); repeat split; try_solve.
  Defined.

  Definition lower (M: Term) (ME: env M |= 0 :!) : Term :=
    proj1_sig (lower_aux M ME).

  Lemma lower_env : forall M ME, env (lower M ME) = loweredEnv (env M) 0.

  Proof.
    intros; unfold lower.
    destruct (lower_aux M ME); try_solve.
  Qed.

  Lemma lower_term : forall M ME, term (lower M ME) = prelower (term M).

  Proof.
    intros; unfold lower.
    destruct (lower_aux M ME); try_solve.
  Qed.

  Lemma lower_type : forall M ME, type (lower M ME) = type M.

  Proof.
    intros; unfold lower.
    destruct (lower_aux M ME); try_solve.
  Qed.

  Global Hint Rewrite lower_env lower_term lower_type : terms.

  Lemma prelift_prelower_aux : forall M i, env M |= i :! ->
    prelift_aux 1 (prelower_aux (term M) i) i = (term M).

  Proof.
    destruct M as [E Pt T M].
    induction M; simpl; intros.
    destruct (le_gt_dec i x); simpl.
    destruct (le_gt_dec i (pred x)); simpl.
    destruct x.
    assert (i = 0).
    lia.
    rewrite H0 in H.
    inversion v; destruct E; inversion H; try_solve.
    assert (pred (S x) + 1 = S x); [lia | auto].
    assert (i = x).
    lia.
    inversion v; destruct E; inversion H; try_solve.
    destruct (le_gt_dec i x); simpl; trivial.
    assert (i = x).
    lia.
    inversion v; destruct E; inversion H; try_solve.
    trivial.
    set (w := IHM (S i)); simpl in w.
    rewrite w; trivial.
    set (w := IHM1 i); simpl in w; rewrite w; trivial.
    set (t := IHM2 i); simpl in t; rewrite t; trivial.
  Qed.

  Lemma prelift_prelower : forall M M0, term (lift (lower M M0) 1) = term M.

  Proof.
    intros.
    autorewrite with terms; unfold prelift, prelower.
    rewrite (prelift_prelower_aux M M0); trivial.
  Qed.

  Lemma lower_absBody : forall E Pt A B (M: decl A E |- Pt := B) n
    (Menv: E |= n :!) (M'env: decl A E |= S n :!)
    (MLabs: isAbs (proj1_sig (lower_aux (buildT (TAbs M)) Menv))),
    absBody MLabs = proj1_sig (lower_aux (buildT M) M'env).

  Proof.
    intros.
    destruct (lower_aux (buildT M) M'env) as [P [Penv [Pterm Ptype]]].
    destruct (lower_aux (buildT (TAbs M)) Menv) as [Q [Qenv [Qterm Qtype]]].
    apply term_eq.
     (* equal environment *)
    rewrite absBody_env.
    simpl; rewrite Penv; rewrite Qenv.
    unfold loweredEnv, decl; simpl.
    replace A with (absType MLabs); simpl; trivial.
    rewrite (@abs_type Q MLabs A B); trivial.

     (* equal preterm *)
    apply absBody_term with A.
    simpl; rewrite Qterm; rewrite Pterm; trivial.
  Qed.

  Lemma lower_appBodyL : forall E PtL PtR A B n (Menv: E |= n :!)
    (Ml: E |- PtL := A --> B) (Mr: E |- PtR := A)
    (MLapp: isApp (proj1_sig (lower_aux (buildT (TApp Ml Mr)) Menv))),
    appBodyL MLapp = proj1_sig (lower_aux (buildT Ml) Menv).

  Proof.
    intros.
    destruct (lower_aux (buildT (TApp Ml Mr)) Menv) as [P [PE [PPt PA]]].
    destruct (lower_aux (buildT Ml) Menv) as [Q [QE [QPt QA]]].
    apply term_eq.
     (* environment equal *)
    rewrite appBodyL_env.
    simpl; rewrite QE; rewrite PE; trivial.
     (* preterms equal *)
    simpl; rewrite QPt; simpl.
    apply appBodyL_term with (prelower_aux PtR n).
    rewrite PPt; trivial.
  Qed.

  Lemma lower_appBodyR : forall E PtL PtR A B n (Menv: E |= n :!)
    (Ml: E |- PtL := A --> B) (Mr: E |- PtR := A)
    (MLapp: isApp (proj1_sig (lower_aux (buildT (TApp Ml Mr)) Menv))),
    appBodyR MLapp = proj1_sig (lower_aux (buildT Mr) Menv).
  Proof.
    intros.
    destruct (lower_aux (buildT (TApp Ml Mr)) Menv) as [P [PE [PPt PA]]].
    destruct (lower_aux (buildT Mr) Menv) as [Q [QE [QPt QA]]].
    apply term_eq.
     (* environment equal *)
    rewrite appBodyR_env.
    simpl; rewrite QE; rewrite PE; trivial.
     (* preterms equal *)
    simpl; rewrite QPt; simpl.
    apply appBodyR_term with (prelower_aux PtL n).
    rewrite PPt; trivial.
  Qed.

End TermsLifting.


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

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Open Local Scope R_scope.

(**********)
Lemma formule :
  forall (x h l1 l2:R) (f1 f2:R -> R),
    h <> 0 ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
    (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
    / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
    l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
    f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
    l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
Proof.
  intros; unfold Rdiv, Rminus, Rsqr in |- *.
  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
    repeat rewrite Rinv_mult_distr; try assumption.
  replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
  [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
  (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
  (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
  (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x)));
  [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try assumption || ring.
  apply prod_neq_R0; assumption.
Qed.

(* begin hide *)
Notation Rmin_pos := Rmin_pos (only parsing). (* compat *)
(* end hide *)

Lemma maj_term1 :
  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f1d ->
      Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f1d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4.
Proof.
  intros.
  assert (H7 := H3 h H6).
  assert (H8 := H2 h H4 H5).
  apply Rle_lt_trans with
    (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
  rewrite Rabs_mult.
  apply Rmult_le_compat_r.
  apply Rabs_pos.
  rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
  apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
  apply Rmult_lt_compat_l.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
  exact H8.
  right; unfold Rdiv in |- *.
  repeat rewrite Rabs_mult.
  rewrite Rabs_Rinv; discrR.
  replace (Rabs 8) with 8.
  replace 8 with 8; [ idtac | ring ].
  rewrite Rinv_mult_distr; [ idtac | discrR | discrR ].
  replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with
  (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x)));
  [ idtac | ring ].
  replace (Rabs eps) with eps.
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; assumption.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
Qed.

Lemma maj_term2 :
  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal)
    (f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2t2 ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4.
Proof.
  intros.
  assert (H8 := H3 h H6).
  assert (H9 := H2 h H5).
  apply Rle_lt_trans with
    (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  rewrite Rabs_mult; apply Rmult_le_compat_l.
  apply Rabs_pos.
  rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    try assumption || discrR.
  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; try assumption.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H8; exact H8.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv in |- *.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with
  (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term3 :
  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f2d ->
      Rabs ((f2 (x + h) - f2 x) / h - l2) <
      Rabs (Rsqr (f2 x) * eps / (8 * f1 x))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
    eps / 4.
Proof.
  intros.
  assert (H8 := H2 h H4 H5).
  assert (H9 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H8.
  apply Rlt_le_trans with
    (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    try assumption.
  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; assumption || idtac.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H9; exact H9.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv in |- *.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with
  (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term4 :
  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2c ->
      Rabs (f2 (x + a) - f2 x) <
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2c ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    l2 <> 0 ->
    Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
    eps / 4.
Proof.
  intros.
  assert (H9 := H2 h H5).
  assert (H10 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    assumption || idtac.
  red in |- *; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0.
  apply prod_neq_R0.
  discrR.
  assumption.
  assumption.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr;
    try assumption || (unfold Rsqr in |- *; apply prod_neq_R0; assumption).
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  replace
  (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2))));
  [ idtac | ring ].
  replace
  (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr in |- *;
    apply prod_neq_R0; assumption.
  repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H10; exact H10.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right; unfold Rsqr, Rdiv in |- *.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * Rabs l2 *
    (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
      (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with
  (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
  apply prod_neq_R0; assumption || discrR.
  apply prod_neq_R0; assumption.
Qed.

Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a).
Proof.
  intros.
  unfold D_x, no_cond in |- *.
  split.
  trivial.
  apply Rminus_not_eq.
  unfold Rminus in |- *.
  rewrite Ropp_plus_distr.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  apply Ropp_neq_0_compat; assumption.
Qed.

Lemma Rabs_4 :
  forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
Proof.
  intros.
  apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
  replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ].
  apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
  apply Rplus_le_compat_r.
  apply Rabs_triang.
  repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
  apply Rabs_triang.
Qed.

Lemma Rlt_4 :
  forall a b c d e f g h:R,
    a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
Proof.
  intros; apply Rlt_trans with (b + c + e + g).
  repeat apply Rplus_lt_compat_r; assumption.
  repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
  apply Rlt_trans with (d + e + g).
  rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
  rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
  apply Rplus_lt_compat_r; assumption.
  apply Rplus_lt_compat_l; assumption.
Qed.

(* begin hide *)
Notation Rmin_2 := Rmin_glb_lt (only parsing).
(* end hide *)

Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
Proof.
  intro; ring.
Qed.

Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4.
Proof.
  intro; rewrite <- quadruple.
  unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
  reflexivity.
Qed.

(**********)
Lemma continuous_neq_0 :
  forall (f:R -> R) (x0:R),
    continuity_pt f x0 ->
    f x0 <> 0 ->
    exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> 0).
Proof.
  intros; unfold continuity_pt in H; unfold continue_in in H;
    unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))).
  intros; elim H1; intros.
  exists (mkposreal x H2).
  intros; assert (H5 := H3 (x0 + h)).
  cut
    (dist R_met (x0 + h) x0 < x ->
      dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
  unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
    replace (x0 + h - x0) with h.
  intros; assert (H7 := H6 H4).
  red in |- *; intro.
  rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
    rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
      pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
  cut (0 < Rabs (f x0)).
  intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
  cut (Rabs (/ 2) = / 2).
  assert (Hyp : 0 < 2).
  prove_sup0.
  intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12;
      [ idtac | discrR ].
  cut (IZR 1 < IZR 2).
  unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
    elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
  apply IZR_lt; omega.
  unfold Rabs in |- *; case (Rcase_abs (/ 2)); intro.
  assert (Hyp : 0 < 2).
  prove_sup0.
  assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
    rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
  elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
  reflexivity.
  apply (Rabs_pos_lt _ H0).
  ring.
  assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
  intro; rewrite <- H7; unfold dist, R_met in |- *; unfold R_dist in |- *;
    unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
      apply Rabs_pos_lt.
  unfold Rdiv in |- *; apply prod_neq_R0;
    [ assumption | apply Rinv_neq_0_compat; discrR ].
  intro; apply H5.
  split.
  unfold D_x, no_cond in |- *.
  split; trivial || assumption.
  assumption.
  change (0 < Rabs (f x0 / 2)) in |- *.
  apply Rabs_pos_lt; unfold Rdiv in |- *; apply prod_neq_R0.
  assumption.
  apply Rinv_neq_0_compat; discrR.
Qed.


(** * Kan Extensions *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import ExponentialLaws.Law4.Functors FunctorCategory.Core.
Require Import Functor.Composition.Functorial.Core.
Require Import UniversalProperties.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.

(** Quoting nCatLab on Kan Exensions:

    ** Idea

    The Kan extension of a functor [F : C → D] with respect to a
    functor

<<
    C
    |
    | p
    ↓
    C'
>>

    is, if it exists, a kind of best approximation to the problem of
    finding a functor [C' → D] such that

<<
        F
    C -----> D
    |       ↗
    | p   /
    |   /
    ↓ /
    C'
>>

    hence to extending the domain of [F] through [p] from [C] to [C'].

    More generally, this makes sense not only in Cat but in any
    2-category.

    Similarly, a Kan lift is the best approximation to lifting a
    morphism [F : C → D] through a morphism

<<
    D'
    |
    ↓
    D
>>

    to a morphism [F̂]

<<
                D'
              ↗ |
            /   |
        F̂ /     |
        /       |
      /   F     ↓
    C --------> D
>>

    Kan extensions are ubiquitous. See the discussion at Examples
    below.

    ** Definitions

    There are various slight variants of the definition of Kan
    extension. In good cases they all exist and all coincide, but in
    some cases only some of these will actually exist.

    We (have to) distinguish the following cases:

    - “ordinary” or “weak” Kan extensions

      These define the extension of an entire functor, by an
      adjointness relation.

      Here we (have to) distinguish further between

      - global Kan extensions,

        which define extensions of all possible functors of given
        domain and codomain (if all of them indeed exist);

      - local Kan extensions,

        which define extensions of single functors only, which may
        exist even if not every functor has an extension.

    - “pointwise” or “strong” Kan extensions

      These define the value of an extended functor on each object
      (each “point”) by a weighted (co)limit.

      Furthermore, a pointwise Kan extension can be “absolute”.

    If the pointwise version exists, then it coincides with the
    “ordinary” or “weak” version, but the former may exist without the
    pointwise version existing. See below for more.

    Some authors (such as Kelly) assert that only pointwise Kan
    extensions deserve the name “Kan extension,” and use the term as
    “weak Kan extension” for a functor equipped with a universal
    natural transformation. It is certainly true that most Kan
    extensions which arise in practice are pointwise. This distinction
    is even more important in enriched category theory. *)

Section kan_extensions.
  (** ** Ordinary or weak Kan extensions

      *** Global Kan extensions

      Let [p : C → C'] be a functor. For [D] any other category, write
      [p* : (C' → D) → (C → D)] for the induced functor on the functor
      categories: this sends a functor [h : C' → D] to the composite functor

<<
                p      h
      p* h : C --> C' --> D
>>
   *)

  (** *** Pullback-along functor *)
  Context `{Funext}.
  Variables C C' D : PreCategory.

  Section pullback_along.
    Definition pullback_along_functor
    : object ((C -> C') -> (C' -> D) -> (C -> D))
      := Functor.Composition.Functorial.Core.compose_functor _ _ _.

    Definition pullback_along (p : Functor C C')
    : object ((C' -> D) -> (C -> D))
      := Eval hnf in pullback_along_functor p.
  End pullback_along.

  (** Definition. If [p*] has a left adjoint, typically denoted [p_! :
      (C → D) → (C' → D)] or [Lan_p : (C → D) → (C' → D)] then this
      left adjoint is called the (ordinary or weak) left Kan extension
      operation along [p]. For [h ∈ (C -> D)] we call [p_! h] the left
      Kan extension of [h] along [p].

      Similarly, if [p*] has a right adjoint, this right adjoint is
      called the right Kan extension operation along [p]. It is
      typically denoted [p_* : (C → D) → (C' → D)] or [Ran = Ran_p :
      (C → D) → (C' → D)].

      The analogous definition clearly makes sense as stated in other
      contexts, such as in enriched category theory.

      Observation. If [C' = 1] is the terminal category, then

      - the left Kan extension operation forms the colimit of a functor;

      - the right Kan extension operation forms the limit of a functor. *)

  (** *** Left Kan extensions *)
  (** Colimits are initial morphisms. *)
  Definition IsLeftKanExtensionAlong (p : Functor C C') (h : Functor C D)
    := @IsInitialMorphism (_ -> _) _ h (pullback_along p).

  (** *** Right Kan extensions *)
  (** Limits are terminal morphisms *)
  Definition IsRightKanExtensionAlong (p : Functor C C') (h : Functor C D)
    := @IsTerminalMorphism _ (_ -> _) (pullback_along p) h.
End kan_extensions.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal30.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq lst (append (Cons (Zero) (Nil)) (append (Nil) (Nil))) (append (append (Cons (Zero) (Nil)) (Nil)) (Nil))).
Admitted.
QuickChick lfind_hyp_test.


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep.

Fixpoint gen_str n : string :=
  match n with
    | O => EmptyString
    | S n' => String "0" (gen_str n')
  end.

Fixpoint gen_ns n :=
  match n with
    | O => nil
    | S n' => gen_str n' :: gen_ns n'
  end.

Lemma gen_ns_len : forall n, length (gen_ns n) = n.
  induction n; simpl; intuition.
Qed.

Lemma gen_str_inj : forall a b, gen_str a = gen_str b -> a = b.
  induction a; induction b; simpl; intuition.
Qed.

Lemma fold_gen_str : forall n, String "0" (gen_str n) = gen_str (S n).
  eauto.
Qed.

Lemma longer_str_not_in : forall r n, (n <= r)%nat -> ~ List.In (gen_str r) (gen_ns n).
  induction r; induction n; simpl; intuition.
  rewrite fold_gen_str in *.
  eapply gen_str_inj in H1.
  intuition.
Qed.

Hint Resolve longer_str_not_in.

Lemma gen_ns_NoDup : forall n, NoDup (gen_ns n).
  Hint Constructors NoDup.
  induction n; simpl; intuition.
Qed.

Hint Resolve gen_ns_NoDup.

Lemma behold_the_array_ls : forall len p, p =?> len ===> Ex ls, [| length ls = len |] * array ls p.
  intros; unfold array; rewrite <- (gen_ns_len len); eapply Himp_trans; [ eapply behold_the_array | rewrite gen_ns_len; sepLemma; rewrite length_toArray; rewrite gen_ns_len ]; eauto.
Qed.

Lemma buf_2_fwd : forall p len, (2 <= len)%nat -> p =?> len ===> p =?> 2 * (p ^+ $8) =?> (len - 2).
  destruct len; simpl; intros; try omega.
  destruct len; simpl; intros; try omega.
  sepLemma; eapply allocated_shift_base; [ words | intuition ].
Qed.

Definition hints_buf_2_fwd : TacPackage.
  prepare buf_2_fwd tt.
Defined.

Definition hints_array : TacPackage.
  prepare behold_the_array_ls tt.
Defined.

Definition hints_buf_2_fwd_array : TacPackage.
  prepare (buf_2_fwd, behold_the_array_ls) tt.
Defined.