(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import div path tuple.
Require Import Init_ext ssrZ ZArith_ext String_ext Max_ext.
Require Import machine_int seq_ext ssrnat_ext tuple_ext path_ext.
Require order finmap.
Import MachineInt.

Require Import C_types C_types_fp C_value C_expr C_expr_equiv.

Local Close Scope Z_scope.
Local Open Scope C_types_scope.
Local Open Scope C_value_scope.
Local Open Scope C_expr_scope.
Local Open Scope machine_int_scope.

(** ground arithmetic expressions *)

Lemma cat_nil {A: Type}: forall (l1: seq A) l2, l1 ++ l2 = nil -> l1 = nil /\ l2 = nil.
elim => //=.
Defined.

Definition ground_exp  {g} {sigma : g.-env} {t : g.-typ} :
  forall (e : exp sigma t) (H: vars e = nil), t.-phy.
induction e; simpl.
- done.
- move => H; exact p.
- move => /cat_nil [] H1 H2.
  exact ([ bop_n _ t b ([ IHe1 H1 ]c) ([ IHe2 H2 ]c) ]_ (store0 sigma)).
- move => H.
  exact (eval (store0 sigma) (bopk_n _ t b [IHe H ]c n)).
- move => /cat_nil [] H1 H2.
  exact (eval (store0 sigma) (bop_r _ t b ([ IHe1 H1 ]c) ([ IHe2 H2 ]c))).
- move => /cat_nil [] H1 H2.
  exact (eval (store0 sigma) ([ IHe1 H1 ]c \+ [ IHe2 H2 ]c)).
- move => H.
  exact (eval (store0 sigma) (safe_cast _ t t' [IHe H ]c i)).
- move => H.
  exact (eval (store0 sigma) (unsafe_cast _ t t' [IHe H ]c i)).
- move => H'.
  exact (eval (store0 sigma) (fldp _ f [IHe H' ]c H e0)).
- move => /cat_nil [] H1 H2.
  exact (eval (store0 sigma) ([ IHe1 H1 ]c \= [ IHe2 H2 ]c)).
- move => /cat_nil [] H1 / cat_nil [] H2 H3.
  exact (eval (store0 sigma) (ifte_e _ t ([ IHe1 H1 ]c) ([ IHe2 H2 ]c) ([ IHe3 H3 ]c))).
Defined.
Global Opaque ground_exp.

Notation "'[' e ']ge'" := (@ground_exp _ _ _ e (Logic.eq_refl _)) (at level 9, only parsing) : C_expr_scope.
Notation "'[' e ']ge'" := (ground_exp e _) (at level 9, format "'[' [  e  ]ge ']'"): C_expr_scope.

Lemma ground_exp_sem {g} {ts : g.-env} (s : store ts) {ty : g.-typ} :
  forall (e : exp ts ty) (H : vars e = nil), [ e ]_s = ground_exp e H.
Transparent ground_exp.
induction e => //=.
- move/cat_nil => [] H1 H2.
  by rewrite -(IHe1 H1) -(IHe2 H2).
- move => H; by rewrite -(IHe H).
- move/cat_nil => [] H1 H2.
  by rewrite -(IHe1 H1) -(IHe2 H2).
- move/cat_nil => [] H1 H2.
  by rewrite -(IHe1 H1) -(IHe2 H2).
- move => H; by rewrite -(IHe H).
- move => H; by rewrite -(IHe H).
- move => H'; by rewrite -(IHe H').
- move/cat_nil => [] H1 H2.
  by rewrite -(IHe1 H1) -(IHe2 H2).
- move/cat_nil => [] H1 /cat_nil [] H2 H3.
  by rewrite -(IHe1 H1) -(IHe2 H2) -(IHe3 H3).
Opaque ground_exp.
Qed.

Lemma ground_exp_c_inj {g} {sigma : g.-env} {t} (pv1 pv2 : t.-phy) H1 H2 :
  ground_exp ([ pv1 ]c : exp sigma t) H1 = ground_exp ([ pv2 ]c : exp sigma t) H2 ->
  pv1 = pv2.
Proof. done. Qed.

Lemma ge_cast_sint_cst_8c g (sigma : g.-env) (a : int 8) H :
  ground_exp ((int) ([ a ]pc : exp sigma (g.-ityp: uchar)) ) H = [ zext 24 a ]p.
Proof.
Transparent eval beval.
rewrite /si32_of_phy /=.
by apply mkPhy_irrelevance.
Opaque eval beval.
Qed.

Lemma ge_cast_sint_cst_sint g (sigma : g.-env) (pv : (g.-ityp: sint).-phy) H :
  ground_exp ((int) ([ pv ]c : exp sigma (g.-ityp: sint))) H = pv.
Proof. done. Qed.

(* similar to ge_cst_e but in ge_cst_e c is a phyval *)
Lemma sequiv_ge {g} {ts : g.-env} ty (e : exp ts ty) (H : vars e = nil) :
  [ ground_exp e H ]c =s e.
Proof.
Transparent eval.
move=> s /=.
by rewrite ground_exp_sem.
Opaque eval.
Qed.

Lemma ge_cst_e {g sigma} {ty : g.-typ} (pv : ty.-phy) H : @ground_exp _ sigma _ [ pv ]c H = pv.
Proof. done. Qed.

Lemma i32_ge_s_cst_e {g} {sigma : g.-env} n H :
  si32<=phy (ground_exp ([ n ]sc : exp sigma _) H) = Z2s 32 n.
Proof. by rewrite ge_cst_e (si32_of_phy_sc _ _ (store0 sigma)). Qed.

Lemma i8_ge_8_cst_e {g} sigma z H :
  i8<=phy (@ground_exp g sigma _ [ z ]pc H) = z.
Proof. by rewrite ge_cst_e phy_of_ui8K. Qed.

Local Open Scope zarith_ext_scope.

Lemma sequiv_s2Z_si32_of_phy {g} {ts : g.-env} e H :
  ([s2Z (si32<=phy (ground_exp e H) )]sc : exp ts _ ) =s e.
Proof.
move=> s.
rewrite (ground_exp_sem _ e H).
set X := ground_exp e H.
destruct X.
unfold si32_of_phy; simpl.
move: (oi32_of_i8_Some _ Hphy) => [] x Hx.
rewrite Hx /= /phy_of_si32.
apply mkPhy_irrelevance => /=.
rewrite -(oi32_of_i8_bij _ _ Hx).
Transparent eval.
by rewrite /= Z2s_s2Z.
Opaque eval.
Qed.

Lemma s2Z_ge_s_cst_e {g sigma} z H : (- 2 ^^ 31 <= z < 2 ^^ 31)%Z ->
  s2Z (si32<=phy (@ground_exp g sigma _ [ z ]sc H)) = z.
Proof. move=> Hz. by rewrite i32_ge_s_cst_e Z2sK. Qed.

Lemma u2Z_ge_s_cst_e {g sigma} z H : (0 <= z < 2 ^^ 31)%Z ->
  u2Z (si32<=phy (@ground_exp g sigma _ [ z ]sc H)) = z.
Proof.
case=> Hz0 Hz1.
rewrite i32_ge_s_cst_e-s2Z_u2Z_pos.
rewrite Z2sK //; split => //; exact: (@leZ_trans Z0).
rewrite Z2sK //; split => //; exact: (@leZ_trans Z0).
Qed.

Lemma si32_of_phy_gb_add_e {g} {sigma : g.-env} (a b : exp sigma _) H Ha Hb :
  si32<=phy (ground_exp (a \+ b) H) =
  si32<=phy (ground_exp a Ha) `+ si32<=phy (ground_exp b Hb).
Proof.
by rewrite -(ground_exp_sem (store0 sigma)) si32_of_phy_binop_ne 2!(ground_exp_sem (store0 sigma)).
Qed.

Lemma si32_of_phy_gb_or_e {g} {sigma : g.-env} (a b : exp sigma _) H Ha Hb :
  si32<=phy (ground_exp (a \| b) H) =
  si32<=phy (ground_exp a Ha) `|` si32<=phy (ground_exp b Hb).
Proof.
by rewrite -(ground_exp_sem (store0 sigma)) si32_of_phy_binop_ne 2!(ground_exp_sem (store0 sigma)).
Qed.

(* NB: generaliser? *)
Lemma sint_shl_e_to_i32_ge g (sigma : g.-env) (a : int 8) H :
  si32<=phy (ground_exp ((int) ([ a ]pc : exp sigma (g.-ityp: uchar)) \<< [ 8 ]sc : exp sigma _) H) =
  zext 16 a `|| Z2u 8 0.
Proof.
Transparent eval beval.
rewrite /si32_of_phy /= i8_of_i32Ko /= !i8_of_i32K /= Z2s_Z2u_k // Z2uK //.
apply u2Z_inj.
rewrite (@u2Z_shl _ _ _ 8) //.
- by rewrite (u2Z_concat (zext 16 a)) Z2uK // !u2Z_zext addZ0 (u2Z_zext (8 * (4 - 1)) a).
- rewrite (u2Z_zext (8 * (4 - 1)) a).
  by apply max_u2Z.
Opaque eval beval.
Qed.

Local Open Scope Z_scope.

Lemma i8_of_phy_ifte {g sigma} (a b c d : _) H :
  i8<=phy (@ground_exp g sigma _ ([ a ]c \<= [ b ]c \? [ c ]c \: [ d ]c) H) =
  if Z<=u (i8<=phy a) <=? Z<=u (i8<=phy b) then i8<=phy c else i8<=phy d.
Proof.
Transparent eval.
rewrite -(ground_exp_sem (store0 sigma)) /=.
destruct a as [a Ha] => //=.
have Ha' : size a = 1%nat by rewrite Ha sizeof_ityp.
have Ha'Ha : Ha' = Ha by apply eq_irrelevance.
subst Ha.
destruct a as [|a []] => //=.
destruct b as [b Hb] => //=.
have Hb' : size b = 1%nat by rewrite Hb sizeof_ityp.
have Hb'Hb : Hb' = Hb by apply eq_irrelevance.
subst Hb.
destruct b as [|b []] => //=.
set a1 := Z<=u _.
set b1 := Z<=u _.
case: ifP.
  rewrite /is_zero.
  case: ifP => // _ /eqP.
  case.
  move/int_break_inj => abs.
  exfalso.
  lapply abs => //.
  by apply Z2u_dis.
case: ifP => // _.
by rewrite is_zero_0.
Opaque eval.
Qed.

Local Close Scope Z_scope.

(** ground boolean expressions *)

Lemma ground_bexp_helper1 {g} {sigma : g.-env} (e : exp sigma (ityp: uint)) : bvars (exp2bexp sigma e) = nil -> vars e = nil.
Proof. done. Qed.

Lemma ground_bexp_helper2 {g} {sigma : g.-env} (b : bexp sigma) : bvars (bneg sigma b) = nil -> bvars b = nil.
Proof. done. Qed.

Fixpoint ground_bexp {g} {sigma : g.-env} (b : bexp sigma) : bvars b = nil -> bool :=
match b as b0 return bvars b0 = nil -> bool with
| exp2bexp e => fun H => ~~ is_zero (ground_exp e (ground_bexp_helper1 e H))
| bneg b' => fun H => ~~ ground_bexp b' (ground_bexp_helper2 b' H)
end.
Global Opaque ground_bexp.

Lemma gb_bneg {g} {sigma: g.-env} (b : bexp sigma) H : ground_bexp (\~b b) H = ~~ ground_bexp b H.
Proof.
congr (~~ _ _ _ _ _).
by apply eq_irrelevance.
Qed.

Lemma ground_bexp_sem  {g} {sigma : g.-env} (s : store sigma) :
  forall (b : bexp sigma) (H : bvars b = nil), [ b ]b_ s = ground_bexp b H.
Proof.
Transparent beval.
induction b => //=.
- move => H.
  rewrite ground_exp_sem /=.
  congr (~~ _ [ _ ]ge).
  by apply eq_irrelevance.
- move => H; by rewrite IHb gb_bneg.
Opaque beval.
Qed.

Notation "'[' e ']gb'" := (@ground_bexp _ _ e erefl) (at level 9, only parsing) : C_expr_scope.
Notation "'[' e ']gb'" := (ground_bexp e _) (at level 9): C_expr_scope.

Section ground_bexp_prop.

Variables (g : wfctxt) (sigma : g.-env).

Lemma bneg_0uc H : @ground_bexp _ sigma (\~b \b [ 0 ]uc) H.
Proof.
Transparent beval.
by rewrite -(ground_bexp_sem (store0 sigma)) /= is_zero_0.
Opaque beval.
Qed.

Lemma oneuc H : @ground_bexp _ sigma ( \b [ 1 ]uc ) H.
Proof.
Transparent beval.
by rewrite -(ground_bexp_sem (store0 sigma)) /= not_is_zero_1.
Opaque beval.
Qed.

Lemma gb_eq_p {t} (a b : exp sigma (:* t)) H H1 H2 :
  ground_bexp ( \b a \= b ) H = (ground_exp a H1 == ground_exp b H2).
Proof.
by rewrite -(ground_bexp_sem (store0 sigma) _ H) beval_eq_p_eq -!(ground_exp_sem (store0 _)).
Qed.

Lemma and_gb (e1 e2 : exp sigma (ityp: uint)) H H1 H2 :
  ground_bexp (\b e1 \&& e2) H = ground_bexp (\b e1) H1 && ground_bexp (\b e2) H2.
Proof.
Transparent eval beval.
rewrite -!(ground_bexp_sem (store0 sigma)) /=.
move He1 : ( [ e1 ]_(store0 _) ) => [he1 Hhe1].
move He2 : ( [ e2 ]_(store0 _) ) => [he2 Hhe2].
set tmp1 := eq_ind_r _ _ _. rewrite (_ : tmp1 = Hhe1); last by apply eq_irrelevance.
set tmp2 := eq_ind_r _ _ _. rewrite (_ : tmp2 = Hhe2); last by apply eq_irrelevance.
case: ifP => [Hcase | /negbT].
  rewrite is_zero_0; symmetry; apply/negbTE.
  rewrite negb_and 2!negbK /is_zero /=.
  apply/orP.
  case/orP : Hcase => /eqP Hcase; [left | right].
    apply/eqP.
    apply mkPhy_irrelevance => /=.
    symmetry; apply i32_of_i8_bij with Hhe1.
    apply u2Z_inj.
    by rewrite Hcase Z2uK.
  apply/eqP.
  apply mkPhy_irrelevance => /=.
  symmetry; apply i32_of_i8_bij with Hhe2.
  apply u2Z_inj; by rewrite Hcase Z2uK.
rewrite not_is_zero_1 negb_or; case/andP => Ha Hb.
symmetry; apply/andP; split.
  move: Ha; apply contra.
  rewrite /is_zero; case/eqP => ?; subst he1.
  by rewrite i8_of_i32K Z2uK.
move: Hb; apply contra.
rewrite /is_zero; case/eqP => ?; subst he2.
by rewrite i8_of_i32K Z2uK.
Opaque eval beval.
Qed.

Lemma and_8c (a b : int 8) H :
  ground_exp ([ a ]pc \& [ b ]pc : exp sigma (g.-ityp: uchar)) H =
  ground_exp ([ a `& b ]pc : exp sigma _) H.
Proof. by []. Qed.

End ground_bexp_prop.

Section ground_bexp_eq.

Variables (g : wfctxt) (sigma : g.-env) (t : integral) (a b : exp sigma (ityp: t)).
Hypotheses (Ha : vars a = nil) (Hb : vars b = nil).

Lemma gb_eq_e H : ground_bexp (\b a \= b) H = (ground_exp a Ha == ground_exp b Hb).
Proof. by rewrite -(ground_bexp_sem (store0 _) _ H) beval_eq_e_eq -!(ground_exp_sem (store0 _)). Qed.

Lemma gb_neq H H' : ground_bexp (\b a \!= b) H = ~~ ground_bexp (\b a \= b) H'.
Proof. by rewrite -!(ground_bexp_sem (store0 sigma)) beval_neq_not_eq beval_eq_e_eq. Qed.

Lemma gb_bneg_bop_r_lt H H' : ground_bexp (\~b \b a \< b) H = ground_bexp (\b a \>= b) H'.
Proof. by rewrite -!(ground_bexp_sem (store0 sigma)) CgeqNlt. Qed.

Lemma gb_bneg_bop_r_ge H H' : ground_bexp (\~b \b a \>= b) H = ground_bexp (\b a \< b) H'.
Proof. by rewrite -!(ground_bexp_sem (store0 sigma)) CgeqNlt bnegK. Qed.

Lemma gb_bneg_bop_r_gt H H' : ground_bexp (\~b \b a \> b) H = ground_bexp (\b a \<= b) H'.
Proof. by rewrite -!(ground_bexp_sem (store0 sigma)) -CleqNgt. Qed.

Lemma gb_ge_lt H H' : ground_bexp (\b a \>= b) H = ground_bexp (\b b \<= a) H'.
Proof. by rewrite -!(ground_bexp_sem (store0 sigma)) sequiv_ge_sym. Qed.

End ground_bexp_eq.

Local Open Scope zarith_ext_scope.
Local Open Scope Z_scope.

Section ground_bexp_Zlt_Zle.

Variables (g : wfctxt) (sigma : g.-env) (e1 e2 : exp sigma (ityp: sint)).
Hypotheses (H1 : vars e1 = nil) (H2 : vars e2 = nil).

(* NB: lower bounds could be generalized to - 2 ^^ 31 *)
Lemma le_n_gb H : 0 <= Z<=s (si32<=phy (ground_exp e1 H1)) < 2 ^^ 31 ->
  0 <= Z<=s (si32<=phy (ground_exp e2 H2)) < 2 ^^ 31 ->
  ground_bexp (\b e1 \<= e2) H -> si32<=phy (ground_exp e1 H1) `<= si32<=phy (ground_exp e2 H2).
Proof.
move=> K1 K2.
rewrite -!(ground_bexp_sem (store0 sigma)) -!(ground_exp_sem (store0 sigma)).
move/bop_re_le_Zle => K.
apply Zle2le_n.
case: K1; move/s2Z_u2Z_pos => K1 _.
rewrite -!(ground_exp_sem (store0 sigma)) in K1.
case: K2; move/s2Z_u2Z_pos => K2 _.
rewrite -!(ground_exp_sem (store0 sigma)) in K2.
congruence.
Qed.

Lemma lt_n_gb H : 0 <= Z<=s (si32<=phy (ground_exp e1 H1)) < 2 ^^ 31 ->
  0 <= Z<=s (si32<=phy (ground_exp e2 H2)) < 2 ^^ 31 ->
  ground_bexp (\b e1 \< e2) H -> si32<=phy (ground_exp e1 H1) `< si32<=phy (ground_exp e2 H2).
Proof.
move=> K1 K2.
rewrite -!(ground_bexp_sem (store0 sigma)) -!(ground_exp_sem (store0 sigma)).
move/bop_re_lt_Zlt =>  K.
apply Zlt2lt_n.
case: K1; move/s2Z_u2Z_pos => K1 _.
rewrite -!(ground_exp_sem (store0 sigma)) in K1.
case: K2; move/s2Z_u2Z_pos => K2 _.
rewrite -!(ground_exp_sem (store0 sigma)) in K2.
congruence.
Qed.

Lemma Zlt_gb H : ground_bexp (\b e1 \< e2) H ->
  0 <= Z<=s (si32<=phy (ground_exp e1 H1)) < 2 ^^ 31 ->
  0 <= Z<=s (si32<=phy (ground_exp e2 H2)) < 2 ^^ 31 ->
  Z<=s (si32<=phy (ground_exp e1 H1)) < Z<=s (si32<=phy (ground_exp e2 H2)).
Proof.
move=> K K1 K2.
rewrite -1!(ground_bexp_sem (store0 sigma)) in K.
rewrite -2!(ground_exp_sem (store0 sigma)).
by apply bop_re_lt_Zlt.
Qed.

Lemma Zle_gb H : ground_bexp (\b e1 \<= e2) H ->
  s2Z (si32<=phy (ground_exp e1 H1)) <= s2Z (si32<=phy (ground_exp e2 H2)).
Proof.
move=> H'.
rewrite -2!(ground_exp_sem (store0 sigma)).
apply bop_re_le_Zle.
by rewrite -(ground_bexp_sem (store0 sigma)) in H'.
Qed.

Lemma Zle_gb_inv H :
  Z<=s (si32<=phy (ground_exp e1 H1)) <= Z<=s (si32<=phy (ground_exp e2 H2)) ->
  ground_bexp (\b e1 \<= e2) H.
Proof.
Transparent eval beval.
rewrite -(ground_bexp_sem (store0 sigma)) -2!(ground_exp_sem (store0 sigma)) /=.
move He1 : ( [ e1 ]_ _) => [e1s0 He1s0].
move He2 : ( [ e2 ]_ _) => [e2s0 He2s0] K.
case: ifP; first by rewrite not_is_zero_1.
rewrite /si32_of_phy /= in K.
have He1s0' : size e1s0 = 4%nat by rewrite He1s0 sizeof_ityp.
case/oi32_of_i8_Some : He1s0' => x Hx.
rewrite Hx /= in K.
have He2s0' : size e2s0 = 4%nat by rewrite He2s0 sizeof_ityp.
case/oi32_of_i8_Some : He2s0' => y Hy.
rewrite Hy /= in K.
rewrite (i32_of_i8_bij3 _ _ _ Hx) (i32_of_i8_bij3 _ _ _ Hy).
move/leZP => abs; contradiction.
Opaque eval beval.
Qed.

(* almost the same proof as Zle_gb_inv *)
Lemma Zlt_gb_inv H :
   Z<=s (si32<=phy (ground_exp e1 H1)) < Z<=s (si32<=phy (ground_exp e2 H2)) ->
   ground_bexp (\b e1 \< e2) H.
Proof.
Transparent eval beval.
rewrite -(ground_bexp_sem (store0 sigma)) -2!(ground_exp_sem (store0 sigma)) /=.
move He1 : ( [ e1 ]_ _) => [e1s0 He1s0].
move He2 : ( [ e2 ]_ _) => [e2s0 He2s0] => K.
case: ifP; first by rewrite not_is_zero_1.
rewrite /si32_of_phy /= in K.
have He1s0' : size e1s0 = 4%nat by rewrite He1s0 sizeof_ityp.
case/oi32_of_i8_Some : He1s0' => x Hx.
rewrite Hx /= in K.
have He2s0' : size e2s0 = 4%nat by rewrite He2s0 sizeof_ityp.
case/oi32_of_i8_Some : He2s0' => y Hy.
rewrite Hy /= in K.
rewrite (i32_of_i8_bij3 _ _ _ Hx) (i32_of_i8_bij3 _ _ _ Hy).
move/ltZP => abs; contradiction.
Opaque eval beval.
Qed.

Lemma ground_bexp_lt0n H :
  0 < Z<=s (si32<=phy (ground_exp e1 H1)) -> ground_bexp (\b [ 0 ]sc \< e1) H.
Proof.
move=> H0.
Transparent beval eval.
rewrite -(ground_bexp_sem (store0 sigma) (\b [ 0 ]sc \< e1)) /=.
move He1 : ([ e1 ]_ _) => [l1 Hl1].
rewrite i8_of_i32K Z2sK //.
case: ifP; first by rewrite not_is_zero_1.
rewrite -(ground_exp_sem (store0 sigma)) He1 /= in H0.
set lhs := si32<=phy _ in H0.
set rhs := i32<=i8 _ _.
suff: lhs = rhs by move=> <- /ltZP.
rewrite /lhs /rhs {lhs rhs H0} /si32_of_phy /oi32_of_i8.
have : List.length l1 = 4%nat.
  clear He1; by rewrite sizeof_ityp /= in Hl1.
case/(int_flat_Some erefl) => x Hx.
rewrite Hx /= /i32_of_i8.
by symmetry; apply int_flat_int_flat_ok.
Opaque beval eval.
Qed.

Lemma ground_bexp_le0n H :
  0 <= Z<=s (si32<=phy (ground_exp e1 H1)) -> ground_bexp (\b [ 0 ]sc \<= e1) H.
Proof.
move=> H0.
Transparent beval eval.
rewrite -(ground_bexp_sem (store0 sigma) (\b [ 0 ]sc \<= e1)) /=.
move He1 : ([ e1 ]_ _) => [l1 Hl1].
rewrite i8_of_i32K Z2sK //.
case: ifP; first by rewrite not_is_zero_1.
rewrite -(ground_exp_sem (store0 sigma)) He1 /= in H0.
set lhs := si32<=phy _ in H0.
set rhs := i32<=i8 _ _.
suff: lhs = rhs by move=> <- /leZP.
rewrite /lhs /rhs {lhs rhs H0} /si32_of_phy /oi32_of_i8.
have : List.length l1 = 4%nat.
  clear He1; by rewrite sizeof_ityp /= in Hl1.
case/(int_flat_Some erefl) => x Hx.
rewrite Hx /= /i32_of_i8.
by symmetry; apply int_flat_int_flat_ok.
Opaque beval eval.
Qed.

End ground_bexp_Zlt_Zle.

Definition ground_bexp_relation {g} {sigma : g.-env} :
  Relations.Relation_Definitions.relation (forall (b : bexp sigma) (Hb : bvars b = nil), Prop).
red.
apply Morphisms.respectful_hetero.
exact bequiv.
move=> x y.
apply Morphisms.respectful_hetero.
exact (fun _ _ => True).
move=> Hx Hy.
exact iff.
Defined.

Instance ground_bexp_morphism {g} {sigma : g.-env} :
  Morphisms.Proper ground_bexp_relation (@ground_bexp _ sigma).
move=> b1 b2 Hb /= Hb1 Hb2 _ /=.
by rewrite -(ground_bexp_sem (store0 _)) -(ground_bexp_sem (store0 _)) Hb.
Qed.


Require Import VST.floyd.proofauto.
Require Import common_predicates.
Require Import min2.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition min2_spec :=
  DECLARE _min2
   WITH r: val, x: val, y: val
   PRE [ (tptr (Tunion _sslval noattr)), tint, tint ]
   PROP( is_pointer_or_null((r : val)); ssl_is_valid_int((x : val)); ssl_is_valid_int((y : val)) )
   PARAMS(r; x; y)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr nullval)] (r : val)))
   POST[ tvoid ]
   EX m: Z,
   PROP( ((m : Z) <= (force_signed_int (x : val))); ((m : Z) <= (force_signed_int (y : val))) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inl ((Vint (Int.repr m)) : val))] (r : val))).

Definition Gprog : funspecs :=
  ltac:(with_library prog [min2_spec]).

Lemma body_min2 : semax_body Vprog Gprog f_min2 min2_spec.
Proof.

start_function.
ssl_open_context.
forward_if.

 - {
assert_PROP (isptr r). { entailer!. }
forward.
forward; entailer!.
Exists (x : Z).
ssl_entailer.

}
 - {
assert_PROP (isptr r). { entailer!. }
forward.
forward; entailer!.
Exists (y : Z).
ssl_entailer.

}

Qed.


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Local Open Scope logic.

Definition load8 id ofs :=
 (Sset id
      (Ederef
        (Ebinop Oadd
          (Efield
            (Ederef (Etempvar _ctx (tptr t_struct_SHA256state_st))
              t_struct_SHA256state_st) _h (tarray tuint 8))
          (Econst_int (Int.repr ofs) tint) (tptr tuint)) tuint)).

Lemma Znth_is_int:
 forall i r,
  0 <=  i < Zlength r ->
  is_int I32 Unsigned (Znth i (map Vint r)).
Proof.
intros.
unfold Znth.
rewrite if_false by lia.
rewrite (nth_map' Vint Vundef Int.zero).
apply I.
destruct H as [H0 H]; rewrite Zlength_correct in H.
rewrite <- (Z2Nat.id i) in H; auto.
apply Nat2Z.inj_lt in H; auto.
Qed.

Lemma sha256_block_load8:
  forall (Espec : OracleKind)
     (data: val) (r_h: list int) (ctx: val) gv (wsh: share)
   (Hwsh: writable_share wsh)
   (H5 : length r_h = 8%nat),
     semax
         (func_tycontext f_sha256_block_data_order Vprog Gtot nil)
  (PROP  ()
   LOCAL  (temp _data data; gvars gv; temp _ctx ctx; temp _in data)
   SEP  (field_at wsh t_struct_SHA256state_st  [StructField _h] (map Vint r_h) ctx))
   (Ssequence (load8 _a 0)
     (Ssequence (load8 _b 1)
     (Ssequence (load8 _c 2)
     (Ssequence (load8 _d 3)
     (Ssequence (load8 _e 4)
     (Ssequence (load8 _f 5)
     (Ssequence (load8 _g 6)
     (Ssequence (load8 _h 7)
         Sskip))))))))
  (normal_ret_assert
  (PROP  ()
   LOCAL  (temp _a (Vint (nthi r_h 0));
                temp _b (Vint (nthi r_h 1));
                temp _c (Vint (nthi r_h 2));
                temp _d (Vint (nthi r_h 3));
                temp _e (Vint (nthi r_h 4));
                temp _f (Vint (nthi r_h 5));
                temp _g (Vint (nthi r_h 6));
                temp _h (Vint (nthi r_h 7));
                temp _data data; temp _ctx ctx; temp _in data;
                gvars gv)
   SEP  (field_at wsh t_struct_SHA256state_st  [StructField _h] (map Vint r_h) ctx))).
Proof.
intros.
unfold load8.
abbreviate_semax.
assert (H5': Zlength r_h = 8%Z)
  by (rewrite Zlength_correct; rewrite H5; reflexivity).
do 8 forward.
entailer!.
Qed.

Definition get_h (n: Z) :=
    Sset _t
        (Ederef
           (Ebinop Oadd
              (Efield
                 (Ederef (Etempvar _ctx (tptr t_struct_SHA256state_st))
                    t_struct_SHA256state_st) _h (tarray tuint 8))
              (Econst_int (Int.repr n) tint) (tptr tuint)) tuint).

Definition add_h (n: Z) (i: ident) :=
   Sassign
       (Ederef
          (Ebinop Oadd
             (Efield
                (Ederef (Etempvar _ctx (tptr t_struct_SHA256state_st))
                   t_struct_SHA256state_st) _h (tarray tuint 8))
             (Econst_int (Int.repr n) tint) (tptr tuint)) tuint)
       (Ebinop Oadd (Etempvar _t tuint) (Etempvar i tuint) tuint).

Definition add_them_back :=
 [get_h 0; add_h 0 _a;
  get_h 1; add_h 1 _b;
  get_h 2; add_h 2 _c;
  get_h 3; add_h 3 _d;
  get_h 4; add_h 4 _e;
  get_h 5; add_h 5 _f;
  get_h 6; add_h 6 _g;
  get_h 7; add_h 7 _h].

Fixpoint add_upto (k: nat) (u v: list int) {struct k} :=
 match k with
 | O => u
 | S k' => match u,v with
                | u1::us, v1::vs => Int.add u1 v1 :: add_upto k' us vs
                | _, _ => u
                end
 end.

Lemma length_add_upto:
  forall i r s,
   length r = length s  ->
   length (add_upto i r s) = length r.
Proof.
induction i; destruct r,s; intros;
 inv H; simpl; auto.
Qed.

Lemma force_lengthn_short:
  forall {A} i (b: list A) v,
     (i <= length b)%nat -> force_lengthn i b v = firstn i b.
Proof.
induction i; destruct b; intros.
reflexivity.
reflexivity.
inv H.
simpl. f_equal. apply IHi. simpl in H. lia.
Qed.

Lemma add_upto_S:
  forall (atoh regs : list int) (i : nat),
  length atoh = 8%nat ->
  length regs = 8%nat ->
   (i < 8)%nat ->
  map Vint (add_upto (S i) regs atoh) =
  upd_Znth (Z.of_nat i) (map Vint (add_upto i regs atoh))
   (Vint
     (Int.add (nthi (add_upto i regs atoh) (Z.of_nat i))
        (nthi atoh (Z.of_nat i)))).
Proof.
intros. rename H1 into H4.
 assert ( i < length (add_upto i regs atoh))%nat
    by (rewrite length_add_upto; lia).
 rewrite upd_Znth_old_upd_Znth. 2 : {
   rewrite Zlength_map. rewrite Zlength_correct.
   lia.
 }
 unfold old_upd_Znth.
 rewrite !sublist_map, <- map_cons, <- map_app.
 f_equal.

assert (H18: length regs = length atoh) by congruence.
assert (H19: (i < length regs)%nat) by lia.
clear - H18 H19.
revert regs atoh H18 H19; induction i; destruct regs,atoh; intros;
try solve [inv H19]; inv H18.
simpl.
f_equal.
change (i::regs) with ([i]++regs).
autorewrite with sublist. auto.
simpl in H19.
change (add_upto (S (S i)) (i0 :: regs) (i1 :: atoh))
  with (Int.add i0 i1 :: add_upto (S i) regs atoh).
simpl in H19.
rewrite (IHi regs atoh); auto; [ | lia].
clear IHi.
simpl add_upto.
rewrite (sublist_split 0 1 (Z.of_nat (S i))); try lia.
change (@sublist int 0 1) with (@sublist int 0 (0+1)).
rewrite sublist_len_1; try lia.
rewrite inj_S.
simpl.
autorewrite with sublist.
f_equal.
f_equal.
change (cons (Int.add i0 i1)) with (app [Int.add i0 i1]).
rewrite sublist_app2 by (autorewrite with sublist; lia).
f_equal.
autorewrite with sublist; lia.
f_equal.
f_equal.
unfold nthi.
rewrite Z2Nat.inj_succ by lia.
reflexivity.
unfold nthi.
rewrite Z2Nat.inj_succ by lia.
reflexivity.
change (cons (Int.add i0 i1)) with (app [Int.add i0 i1]).
rewrite sublist_app2 by (autorewrite with sublist; lia).
f_equal.
autorewrite with sublist; lia.
autorewrite with sublist; lia.
autorewrite with sublist. Omega1.
rewrite inj_S.
split; try lia.
rewrite Zlength_cons.
unfold Z.succ.
apply Zplus_le_compat_r.
rewrite Zlength_correct.
rewrite length_add_upto; auto.
apply Nat2Z.inj_le; auto.
lia.
Qed.

Lemma upd_reptype_array_gso: (* perhaps move to floyd? *)
 forall t (a: list (reptype t)) v i j,
    0 <= j < Zlength a ->
    0 <= i < Zlength a ->
    i<>j ->
    Znth i (upd_Znth j a v) = Znth i a.
Proof.
intros.
unfold_upd_Znth_old.
assert (i<j \/ i>j) by lia.
clear H1; destruct H2.
autorewrite with sublist; auto.
autorewrite with sublist; auto.
change (cons v) with (app [v]).
autorewrite with sublist; auto.
f_equal; lia.
Qed.

Lemma int_add_upto:
  forall (regs atoh: list int),
   Datatypes.length regs = 8%nat ->
   Datatypes.length atoh = 8%nat ->
   forall (j:nat)  (i:Z),
     j = Z.to_nat i ->
     0 <= i < 8 ->
     is_int I32 Unsigned (Znth i (map Vint (add_upto j  regs atoh))).
Proof.
intros until 2.
  assert (ZR: Zlength regs = 8) by ( rewrite Zlength_correct, H; reflexivity).
  induction j; intros.
  simpl. apply Znth_is_int; lia.
  unfold Znth.
  rewrite if_false by lia.
 rewrite nth_map' with (d' := Int.zero).
  apply I.
  rewrite length_add_upto by lia.
  rewrite H. apply Nat2Z.inj_lt.
  rewrite Z2Nat.id by lia. apply H2.
Qed.

Lemma add_s:
  forall (regs atoh: list int),
   Datatypes.length regs = 8%nat ->
   Datatypes.length atoh = 8%nat ->
 forall i i',
    (i < 8)%nat ->
    i' = Z.of_nat i ->
    upd_Znth i' (map Vint (add_upto i regs atoh))
             (Vint
                (Int.add
                   (Znth i' (add_upto i regs atoh))
                   (nthi atoh i'))) =
     map Vint (add_upto (S i) regs atoh).
Proof.
intros.
assert (is_int I32 Unsigned (Znth i' (map Vint (add_upto i regs atoh)))).
 apply  Znth_is_int.   rewrite Zlength_correct, length_add_upto, H.
 change (Z.of_nat 8) with 8; lia. rewrite H,H0;  auto.
subst i'.
rewrite add_upto_S; try lia.
f_equal.
destruct (Znth (Z.of_nat i) (map Vint (add_upto i regs atoh)));
   try contradiction H3.
simpl.
f_equal. f_equal.
unfold Znth. rewrite if_false by lia.
unfold nthi.
rewrite Nat2Z.id. auto.
Qed.

Lemma add_upto_8:
  forall (regs atoh: list int),
   Datatypes.length regs = 8%nat ->
   Datatypes.length atoh = 8%nat ->
    add_upto 8 regs atoh = map2 Int.add regs atoh.
Proof.
intros.
destruct atoh as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; inv H0.
destruct regs as [ | a' [ | b' [ | c' [ | d' [ | e' [ | f' [ | g' [ | h' [ | ]]]]]]]]]; inv H.
simpl; auto.
Qed.

Lemma add_them_back_proof:
  forall (Espec : OracleKind)
     (regs regs': list int) (ctx: val) gv (wsh: share) (Hwsh: writable_share wsh),
     length regs = 8%nat ->
     length regs' = 8%nat ->
     semax  (func_tycontext f_sha256_block_data_order Vprog Gtot nil)
   (PROP  ()
   LOCAL  (temp _ctx ctx;
                temp _a  (Vint (nthi regs' 0));
                temp _b  (Vint (nthi regs' 1));
                temp _c  (Vint (nthi regs' 2));
                temp _d  (Vint (nthi regs' 3));
                temp _e  (Vint (nthi regs' 4));
                temp _f  (Vint (nthi regs' 5));
                temp _g  (Vint (nthi regs' 6));
                temp _h  (Vint (nthi regs' 7));
                gvars gv)
   SEP
   (field_at wsh t_struct_SHA256state_st  [StructField _h] (map Vint regs) ctx))
   (sequence add_them_back Sskip)
  (normal_ret_assert
   (PROP() LOCAL(temp _ctx ctx; gvars gv)
    SEP (field_at wsh t_struct_SHA256state_st  [StructField _h]
                (map Vint (map2 Int.add regs regs')) ctx))).
Proof.
intros.
rename regs' into atoh.
unfold sequence, add_them_back.
change regs with  (add_upto 0 regs atoh) at 1.
unfold get_h, add_h.
abbreviate_semax.
assert (ZR: Zlength regs = 8) by (rewrite Zlength_correct, H; reflexivity).
assert (INT_ADD_UPTO := int_add_upto _ _ H H0).
assert (ADD_S := add_s _ _ H H0).

Opaque add_upto.
assert (forall i i', i'=Z.of_nat i -> 0<= i' <8 -> 0 <= i' < Zlength (add_upto i regs atoh)). {
 intros;
 rewrite Zlength_correct; rewrite length_add_upto by lia;
 rewrite H; simpl; lia.
}
assert (0<=0) by computable.
forward.
forward.
autorewrite with sublist.
rewrite ADD_S by (try reflexivity; clear; lia).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; lia).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; lia).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; lia).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; lia).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; lia).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; lia).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; lia).
rewrite (add_upto_8 _ _ H H0).
entailer!.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing Smallest %\ensuremath{\frac13^{2n^2+n}}% *)
(** printing eta_0 %\ensuremath{\eta_0}% #η0# *)

Require Export CoRN.complex.NRootCC.
Require Export CoRN.complex.AbsCC.
Require Export CoRN.fta.MainLemma.

(**
** Kneser Lemma *)

Section Kneser_Lemma.

(**
%\begin{convention}% Let [b : nat->CC], [n : nat] and [c : IR]
such that [0 < n], [b_0 := b 0], [b_n := (b n) [=] [1]] and
[(AbsCC b_0) [<] c].
%\end{convention}%
*)

Variable b : nat -> CC.
Variable n : nat.
Hypothesis gt_n_0 : 0 < n.
(* begin hide *)
Let b_0 := b 0.
Let b_n := b n.
(* end hide *)
Hypothesis b_n_1 : b_n [=] [1].
Variable c : IR.
Hypothesis b_0_lt_c : AbsCC b_0 [<] c.

(**
%\begin{convention}% We define the following local abbreviations:
 - [two_n := 2 * n]
 - [Small := p3m n]
 - [Smaller := p3m (two_n * n)]
 - [Smallest := Small[*]Smaller]
 - [q := [1][-]Smallest]
 - [a i := AbsCC (b i)]

%\end{convention}%
*)

(* begin hide *)
Let two_n := 2 * n.
Let Small := p3m n.
Let Smaller := p3m (two_n * n).
Let Smallest := Small[*]Smaller.
Let q := [1][-]Smallest.
(* end hide *)

Lemma b_0'_exists : forall eta : IR, [0] [<] eta -> {b_0' : CC | AbsCC (b_0'[-]b_0) [<=] eta | b_0' [#] [0]}.
Proof.
 intros.
 exact (Cexis_AFS_CC [0] b_0 eta X).
Qed.

Let eta_0 := ((c[-]AbsCC b_0) [/]FourNZ) [/]TwoNZ.

Lemma eta_0_pos : [0] [<] eta_0.
Proof.
 unfold eta_0 in |- *.
 apply pos_div_two.
 apply pos_div_four.
 apply shift_zero_less_minus.
 assumption.
Qed.

Lemma eta_exists : {eta : IR | [0] [<] eta |
 {b_0' : CC | AbsCC (b_0'[-]b_0) [<=] eta | b_0' [#] [0] and AbsCC b_0'[+]Three[*]eta [<] c}}.
Proof.
 exists eta_0.
  exact eta_0_pos.
 generalize (b_0'_exists eta_0 eta_0_pos).
 intro H.
 elim H.
 intros b_0' H0 H1.
 exists b_0'.
  assumption.
 split. assumption.
  apply leEq_less_trans with ((AbsCC b_0[+]c) [/]TwoNZ).
  2: apply Average_less_Greatest; auto.
 apply shift_plus_leEq.
 apply leEq_wdl with (AbsCC (b_0'[-]b_0[+]b_0)).
  2: apply AbsCC_wd; rational.
 apply leEq_transitive with (AbsCC (b_0'[-]b_0) [+]AbsCC b_0).
  apply triangle.
 apply leEq_transitive with (eta_0[+]AbsCC b_0).
  apply plus_resp_leEq; auto.
 apply eq_imp_leEq.
 unfold eta_0 in |- *; rational.
Qed.

Lemma eps_exists_1 : forall eps x y : IR, [0] [<] eps -> [0] [<] x -> [0] [<] y ->
 {eps' : IR | [0] [<] eps' | eps' [<=] eps /\ x[*]eps' [<=] y}.
Proof.
 intros eps x y Heps Hx Hy.
 cut ([0] [<] Half[*]eps). intro H2.
  cut (x [#] [0]). intro H3.
   2: apply pos_ap_zero; auto.
  elim (less_cotransitive_unfolded _ _ _ H2 ((y[/] x[//]H3) [-]Half[*]eps)); intro H5.
   exists (Half[*]eps).
    auto.
   split. apply less_leEq; apply half_3. auto.
    astepr (x[*] (y[/] x[//]H3)).
   apply less_leEq.
   apply mult_resp_less_lft; auto.
   astepl ([0][+]Half[*]eps).
   apply shift_plus_less; auto.
  cut ([0] [<] (y[/] x[//]H3)). intro H4.
   2: apply div_resp_pos; auto.
  exists (Half[*] (y[/] x[//]H3)).
   apply mult_resp_pos. apply pos_half. auto.
    split. apply leEq_transitive with (y[/] x[//]H3).
   apply less_leEq; apply half_3; auto.
   apply less_leEq.
   astepr ([1][*]eps).
   astepr ((Half[+]Half) [*]eps).
   astepr (Half[*]eps[+]Half[*]eps).
   apply shift_less_plus'; auto.
  rstepl (Half[*]y).
  apply less_leEq; apply half_3; auto.
 apply mult_resp_pos; auto.
 apply pos_half.
Qed.

(* less_cotransitive_unfolded on
  {[0]  [<]  y[/]x[//]H3[-]Half[*]eps} +
  {y[/]x[//]H3[-]Half[*]eps  [<]  Half[*]eps}. *)

Lemma eps_exists : forall eta a_0 : IR, [0] [<] eta -> [0] [<] a_0 ->
 {eps : IR | [0] [<] eps | Two[*] (Three[^]n[+][1]) [*]eps [<=] eta /\ Three[*]eps [<=] Smaller[*]a_0 /\ eps [<=] a_0}.
Proof.
 intros eta a_0 Heta Ha_0.
 elim (eps_exists_1 ((Smaller[*]a_0) [/]ThreeNZ) (Three[^]n[+][1]) (eta [/]TwoNZ)).
    intros eps H H0.
    elim H0; intros H1 H2.
    exists eps.
     auto.
    split.
     astepl (Two[*] ((Three[^]n[+][1]) [*]eps)).
     apply shift_mult_leEq' with (two_ap_zero IR); auto.
     apply pos_two.
    split.
     apply shift_mult_leEq' with (three_ap_zero IR); auto.
     apply pos_three.
    eapply leEq_transitive.
     apply H1.
    apply shift_div_leEq'.
     apply pos_three.
    apply mult_resp_leEq_rht.
     unfold Smaller in |- *; apply leEq_transitive with OneR. apply p3m_small.
      apply less_leEq; apply one_less_three.
    apply less_leEq; auto.
   apply pos_div_three.
   apply mult_resp_pos; auto.
   unfold Smaller in |- *; apply p3m_pos.
  apply plus_resp_pos.
   apply nexp_resp_pos.
   apply pos_three.
  apply pos_one.
 apply pos_div_two; auto.
Qed.

(* begin hide *)
Let a (i : nat) : IR := AbsCC (b i).
(* end hide *)

Lemma z_exists : forall (b_0' : CC) (k : nat) (r eta : IR), let a_0 := AbsCC b_0' in
 [0] [<] a_0 -> [0] [<] a k -> 1 <= k -> k <= n -> [0] [<=] r -> [0] [<] eta ->
 AbsCC (b_0'[-]b_0) [<=] eta -> a k[*]r[^]k [<=] a_0 ->
 {z : CC | AbsCC z [=] r | AbsCC (b_0[+]b k[*]z[^]k) [<=] a_0[-]a k[*]r[^]k[+]eta}.
Proof.
 (* begin hide *)
 intros b_0' k r eta a_0 H H0 H1 H2 H3 H4 H5 H6.
 cut (AbsCC b_0' [#] [0]). intro H7.
  2: apply pos_ap_zero; auto.
 cut (cc_IR (AbsCC b_0') [#] [0]). intro H8.
  2: astepr (cc_IR [0]); apply cc_IR_resp_ap; auto.
 cut (a k [#] [0]). intro H9.
  2: apply pos_ap_zero; auto.
 cut (b k [#] [0]). intro H10.
  2: apply AbsCC_ap_zero; apply ap_symmetric_unfolded; auto.
 cut (0 < k). intro H11.
  2: auto with arith.
 cut ( [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10)) [#]
   [0]). intro H12.
  elim (CnrootCC [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10))
    H12 k H11).
  intros w H13.
  cut (AbsCC w [=] [1]). intro H14.
   exists (cc_IR r[*]w).
    astepl (AbsCC (cc_IR r) [*]AbsCC w).
    astepl (r[*]AbsCC w).
    Step_final (r[*][1]).
   apply leEq_transitive with (AbsCC (b_0'[+]b k[*] (cc_IR r[*]w) [^]k) [+]AbsCC (b_0[-]b_0')).
    apply leEq_wdl with (AbsCC (b_0'[+]b k[*] (cc_IR r[*]w) [^]k[+] (b_0[-]b_0'))).
     apply triangle.
    apply AbsCC_wd; rational.
   apply leEq_wdl with (AbsCC b_0'[-]a k[*]r[^]k[+]AbsCC (b_0[-]b_0')).
    apply plus_resp_leEq_lft.
    astepl (AbsCC [--] (b_0[-]b_0')).
    apply leEq_wdl with (AbsCC (b_0'[-]b_0)); auto.
    apply AbsCC_wd; rational.
   apply bin_op_wd_unfolded.
    2: algebra.
   apply eq_transitive_unfolded with (AbsCC ((b_0'[/] cc_IR (AbsCC b_0') [//]H8) [*]
     (cc_IR (AbsCC b_0') [-]cc_IR (a k) [*]cc_IR r[^]k))).
    astepl ([1][*] (AbsCC b_0'[-]a k[*]r[^]k)).
    astepr (AbsCC (b_0'[/] cc_IR (AbsCC b_0') [//]H8) [*]
      AbsCC (cc_IR (AbsCC b_0') [-]cc_IR (a k) [*]cc_IR r[^]k)).
    apply bin_op_wd_unfolded.
     astepl (AbsCC b_0'[/] AbsCC b_0'[//]H7).
     apply eq_symmetric_unfolded.
     apply cc_div_abs'.
     apply AbsCC_nonneg.
    apply eq_transitive_unfolded with (AbsCC (cc_IR (AbsCC b_0') [-]cc_IR (a k) [*]cc_IR (r[^]k))).
     2: apply AbsCC_wd; algebra.
    astepr (AbsCC (cc_IR (AbsCC b_0') [-]cc_IR (a k[*]r[^]k))).
    astepr (AbsCC (cc_IR (AbsCC b_0'[-]a k[*]r[^]k))).
    cut ([0] [<=] AbsCC b_0'[-]a k[*]r[^]k). algebra.
     apply shift_leEq_lft; auto.
   apply AbsCC_wd.
   rstepl (b_0'[+] b k[*] (cc_IR r[^]k[*]
     [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10)))).
   apply bin_op_wd_unfolded. algebra.
    apply bin_op_wd_unfolded. algebra.
    Step_final (cc_IR r[^]k[*]w[^]k).
  apply root_one with k; auto.
   apply AbsCC_nonneg.
  astepl (AbsCC (w[^]k)).
  astepl (AbsCC [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10))).
  astepl (AbsCC ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10))).
  astepl (AbsCC (cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] AbsCC (b_0'[/] b k[//]H10)).
  astepl (AbsCC (cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] AbsCC (b_0'[/] b k[//]H10)).
  cut ([0] [<=] AbsCC b_0'). intro. 2: apply AbsCC_nonneg.
   astepl ((AbsCC (cc_IR (a k)) [/] AbsCC b_0'[//]H7) [*]AbsCC (b_0'[/] b k[//]H10)).
  astepl ((AbsCC (cc_IR (a k)) [/] AbsCC b_0'[//]H7) [*]AbsCC (b_0'[/] b k[//]H10)).
  cut ([0] [<=] a k). intro. 2: apply less_leEq; auto.
   astepl ((a k[/] AbsCC b_0'[//]H7) [*]AbsCC (b_0'[/] b k[//]H10)).
  astepl ((a k[/] AbsCC b_0'[//]H7) [*] (AbsCC b_0'[/] AbsCC (b k) [//]H9)).
  unfold a in |- *; rational.
 apply ap_wdl_unfolded with (cc_IR [--] (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)).
  apply mult_resp_ap_zero.
   astepr (cc_IR [0]).
   apply cc_IR_resp_ap.
   apply inv_resp_ap_zero.
   apply div_resp_ap_zero_rev; auto.
  apply div_resp_ap_zero_rev.
  apply AbsCC_ap_zero.
  apply ap_symmetric_unfolded; auto.
 apply eq_transitive_unfolded with ( [--] (cc_IR (a k[/] AbsCC b_0'[//]H7)) [*] (b_0'[/] b k[//]H10)).
  apply mult_wdl.
  astepl (cc_IR ([0][-] (a k[/] AbsCC b_0'[//]H7))). astepr ([0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)).
  Step_final (cc_IR [0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)).
 astepl (([0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)) [*] (b_0'[/] b k[//]H10)).
 astepl ((cc_IR [0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)) [*] (b_0'[/] b k[//]H10)).
 astepl (cc_IR [0][*] (b_0'[/] b k[//]H10) [-]
   cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)).
 astepl ([0][*] (b_0'[/] b k[//]H10) [-] cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)).
 astepl ([0][-]cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)).
 astepl ( [--] (cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10))).
 apply un_op_wd_unfolded.
 apply mult_wdl.
 unfold cc_IR in |- *; simpl in |- *; split; simpl in |- *; rational.
Qed.
(* end hide *)

Lemma Kneser_1' : Half [<=] q.
Proof.
 unfold q in |- *.
 apply shift_leEq_minus.
 astepl (Smallest[+]Half).
 apply shift_plus_leEq.
 unfold Half in |- *.
 rstepr ([1] [/]TwoNZ:IR).
 unfold Smallest, Small, Smaller in |- *.
 generalize (p3m_smaller n gt_n_0).
 intro Hn.
 generalize (p3m_smaller (two_n * n)).
 intro H2nn.
 apply leEq_transitive with (Half[*] (Half:IR)).
  apply mult_resp_leEq_both; auto.
    apply less_leEq; apply p3m_pos.
   apply less_leEq; apply p3m_pos.
  apply H2nn.
  unfold two_n in |- *.
  elim gt_n_0. auto with arith.
   intros. simpl in |- *. auto with arith.
  rstepr ([1] [/]TwoNZ[*]OneR).
 apply less_leEq.
 apply mult_resp_less_lft.
  exact (half_lt1 _).
 exact (pos_half _).
Qed.

Lemma Kneser_1'' : q [<] [1].
Proof.
 unfold q in |- *.
 apply shift_minus_less'.
 rstepl ([0][+]OneR).
 apply plus_resp_less_rht.
 unfold Smallest, Small, Smaller in |- *.
 apply mult_resp_pos; apply p3m_pos.
Qed.

Lemma Kneser_1 : forall a_0 eta eps : IR, [0] [<] eta -> [0] [<] eps ->
 a_0[+]Three[*]eta [<] c -> Two[*] (Three[^]n[+][1]) [*]eps [<=] eta -> q[*]a_0[+]Three[^]n[*]eps[+]eps[+]eta [<] q[*]c.
Proof.
 intros.
 cut ([1] [/]TwoNZ[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta) [<=]
   q[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)).
  intro Hm.
  apply leEq_less_trans with (q[*] (a_0[+]Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)).
   rstepr (q[*]a_0[+]q[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)).
   rstepl (q[*]a_0[+][1] [/]TwoNZ[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)).
   apply plus_resp_leEq_lft; auto.
  apply mult_resp_less_lft.
   apply leEq_less_trans with (a_0[+]Three[*]eta); auto.
   rstepl (a_0[+] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)).
   apply plus_resp_leEq_lft.
   rstepl (Two[*] (Three[^]n[+][1]) [*]eps[+]Two[*]eta).
   rstepr (eta[+]Two[*]eta).
   apply plus_resp_leEq; auto.
  apply less_leEq_trans with (Half:IR).
   apply pos_half. exact Kneser_1'.
  apply mult_resp_leEq_rht. exact Kneser_1'.
  apply less_leEq.
 apply less_leEq_trans with ([0][+]Two[*]eta).
  rstepr (Two[*]eta).
  apply mult_resp_pos; auto.
  apply pos_two.
 apply less_leEq.
 apply plus_resp_less_rht.
 apply less_transitive_unfolded with ([0][+]Two[*]eps).
  rstepr (Two[*]eps).
  apply mult_resp_pos; auto.
  apply pos_two.
 apply plus_resp_less_rht.
 repeat apply mult_resp_pos; auto.
  apply pos_two.
 apply nexp_resp_pos; apply pos_three.
Qed.

Section with_CRing. (* We need a context so we can declare the ring structure. *)

  Variable R: CRing.

  Add Ring R: (CRing_Ring R).

  Lemma Kneser_2a : forall (m n i : nat) (f : nat -> R), 1 <= i ->
   Sum m n f [=] f m[+]f i[+] (Sum (S m) (pred i) f[+]Sum (S i) n f).
  Proof.
   intros.
   astepl (f m[+]Sum (S m) n0 f).
   astepl (f m[+] (Sum (S m) i f[+]Sum (S i) n0 f)).
   astepl (f m[+] (Sum (S m) (pred i) f[+]f i[+]Sum (S i) n0 f)).
   ring.
  Qed.

End with_CRing.

Lemma Kneser_2b : forall (k : nat) (z : CC), 1 <= k ->
 let p_ := fun i => b i[*]z[^]i in
 Sum 0 n (fun i => b i[*]z[^]i) [=] b_0[+]b k[*]z[^]k[+] (Sum 1 (pred k) p_[+]Sum (S k) n p_).
Proof.
 (* begin hide *)
 intros.
 unfold p_ in |- *.
 unfold b_0 in |- *.
 apply eq_transitive_unfolded
   with (b 0[*]z[^]0[+]b k[*]z[^]k[+] (Sum 1 (pred k) p_[+]Sum (S k) n p_)); unfold p_ in |- *.
  apply Kneser_2a with (f := fun i : nat => b i[*]z[^]i).
  auto.
 rational.
Qed.
(* end hide *)

Lemma Kneser_2c : forall (m n : nat) (z : CC), m <= S n ->
 let r := AbsCC z in
 AbsCC (Sum m n (fun i => b i[*]z[^]i)) [<=] Sum m n (fun i => a i[*]r[^]i).
Proof.
 (* begin hide *)
 intros.
 unfold r in |- *.
 apply leEq_wdr with (Sum m n0 (fun i : nat => AbsCC (b i[*]z[^]i))).
  apply triangle_Sum with (z := fun i : nat => b i[*]z[^]i). auto.
  apply Sum_wd.
 intros.
 unfold a in |- *.
 Step_final (AbsCC (b i) [*]AbsCC (z[^]i)).
Qed.
(* end hide *)

Lemma Kneser_2 : forall (k : nat) (z : CC), 1 <= k -> k <= n ->
 let r := AbsCC z in let p_ := fun i => a i[*]r[^]i in
 AbsCC (Sum 0 n (fun i => b i[*]z[^]i)) [<=]
  AbsCC (b_0[+]b k[*]z[^]k) [+] (Sum 1 (pred k) p_[+]Sum (S k) n p_).
Proof.
 (* begin hide *)
 intros.
 unfold p_, r in |- *.
 set (p_' := fun i : nat => b i[*]z[^]i) in *.
 apply leEq_wdl with (AbsCC (b_0[+]b k[*]z[^]k[+] (Sum 1 (pred k) p_'[+]Sum (S k) n p_')));
   unfold p_' in |- *.
  apply leEq_transitive with
    (AbsCC (b_0[+]b k[*]z[^]k) [+]AbsCC (Sum 1 (pred k) p_'[+]Sum (S k) n p_')); unfold p_' in |- *.
   apply triangle.
  apply plus_resp_leEq_lft.
  apply leEq_transitive with (AbsCC (Sum 1 (pred k) p_') [+]AbsCC (Sum (S k) n p_'));
    unfold p_' in |- *.
   apply triangle.
  apply plus_resp_leEq_both.
   apply Kneser_2c. auto with arith.
   apply Kneser_2c. auto with arith.
  apply AbsCC_wd.
 apply eq_symmetric_unfolded.
 apply Kneser_2b.
 auto.
Qed.
(* end hide *)
Lemma Kneser_3 : {z : CC | AbsCC z[^]n [<=] c | AbsCC (Sum 0 n (fun i => b i[*]z[^]i)) [<] q[*]c}.
Proof.
 elim eta_exists. intros eta H0 H1.
 elim H1. intros b_0' H3 H4. elim H4. intros H5 H6.
 clear H1 H4.
 cut ([0] [<] AbsCC b_0'). intro H7.
  2: apply AbsCC_pos; auto.
 elim (eps_exists eta (AbsCC b_0') H0 H7). intros eps H9 H10. elim H10. intros H11 H12. elim H12. intros H13 H14.
 clear H10 H12.
 cut (forall k : nat, [0] [<=] a k). intro H15.
  2: intro; unfold a in |- *; apply AbsCC_nonneg.
 cut (a n [=] [1]). intro H16.
  2: unfold a in |- *; Step_final (AbsCC [1]).
 elim (Main a n gt_n_0 eps H9 H15 H16 (AbsCC b_0') H14).
 intro r. intros H18 H19.
 elim H19. intros k H20.
 elim H20. intros H21 H22. elim H22. intros H23 H24. elim H24. intros H25 H26.
 elim H26. intros H27 H28. elim H28. intros H29 H30.
 clear H19 H20 H22 H24 H26 H28.
 cut ([0] [<] a k). intro H31.
  elim (z_exists b_0' k r eta H7 H31 H21 H23 H18 H0 H3 H30). intro z. intros H33 H34.
  exists z.
   astepl (r[^]n).
   apply leEq_transitive with (AbsCC b_0'); auto.
   apply leEq_transitive with (AbsCC b_0'[+]Three[*]eta).
    2: apply less_leEq; auto.
   astepl (AbsCC b_0'[+][0]).
   apply plus_resp_leEq_lft.
   apply less_leEq.
   apply mult_resp_pos; auto.
   apply pos_three.
  set (r' := AbsCC z) in *. unfold r' in H33, H34.
  set (p_' := fun i : nat => a i[*]r'[^]i) in *.
  apply leEq_less_trans with (eps[+] (q[*]AbsCC b_0'[+]Three[^]n[*]eps[+]eta)).
   2: rstepl (q[*]AbsCC b_0'[+]Three[^]n[*]eps[+]eps[+]eta); apply Kneser_1; auto.
  apply leEq_transitive with (AbsCC (b_0[+]b k[*]z[^]k) [+] (Sum 1 (pred k) p_'[+]Sum (S k) n p_'));
    unfold p_', r' in |- *.
   apply Kneser_2; auto.
  set (p_'' := fun i : nat => a i[*]r[^]i) in *.
  apply leEq_wdl with (AbsCC (b_0[+]b k[*]z[^]k) [+] (Sum 1 (pred k) p_''[+]Sum (S k) n p_''));
    unfold p_'' in |- *.
   2: apply bin_op_wd_unfolded; [ algebra | apply bin_op_wd_unfolded; apply Sum_wd; algebra ].
  apply leEq_transitive with (AbsCC (b_0[+]b k[*]z[^]k) [+]
    (([1][-]Small) [*] (a k[*]r[^]k) [+]Three[^]n[*]eps)).
   apply plus_resp_leEq_lft; auto.
  apply leEq_transitive with (AbsCC b_0'[-]AbsCC (b k) [*]r[^]k[+]eta[+]
    (([1][-]Small) [*] (a k[*]r[^]k) [+]Three[^]n[*]eps)).
   apply plus_resp_leEq; auto.
  unfold a in |- *.
  rstepl (AbsCC b_0'[+]Three[^]n[*]eps[+]eta[-]Small[*] (AbsCC (b k) [*]r[^]k)).
  apply leEq_transitive with (AbsCC b_0'[+]Three[^]n[*]eps[+]eta[-]
    Small[*] (Smaller[*]AbsCC b_0'[-]Two[*]eps)).
   apply minus_resp_leEq_rht.
   apply mult_resp_leEq_lft; auto.
   unfold Small in |- *.
   apply less_leEq; apply p3m_pos.
  apply leEq_wdl with (Small[*]Two[*]eps[+] (q[*]AbsCC b_0'[+]Three[^]n[*]eps[+]eta)).
   2: unfold q, Smallest in |- *; rational.
  apply plus_resp_leEq.
  astepr ([1][*]eps).
  apply mult_resp_leEq_rht.
   2: apply less_leEq; auto.
  astepr (Half[*] (Two:IR)).
  apply mult_resp_leEq_rht.
   unfold Small in |- *; apply p3m_smaller; auto.
  apply less_leEq; apply pos_two.
 apply mult_cancel_pos_lft with (r[^]k).
  2: apply nexp_resp_nonneg; auto.
 apply less_leEq_trans with eps; auto.
 eapply leEq_transitive.
  2: apply H29.
 apply shift_leEq_minus.
 rstepl (Three[*]eps). auto.
Qed.

End Kneser_Lemma.

Lemma Kneser : forall n : nat, 0 < n -> {q : IR | [0] [<=] q |
 q [<] [1] and (forall p : cpoly CC, monic n p -> forall c : IR,
  AbsCC p ! [0] [<] c -> {z : CC | AbsCC z[^]n [<=] c | AbsCC p ! z [<] q[*]c})}.
Proof.
 intros n H.
 exists ([1][-]p3m n[*]p3m (2 * n * n)).
  apply less_leEq.
  apply less_leEq_trans with (Half:IR).
   apply pos_half.
  apply Kneser_1'; auto.
 split. apply Kneser_1''.
  intros p H0 c H1.
 elim H0. intros H2 H3.
 cut (nth_coeff n p [=] [1]). intro H4.
  2: auto.
 elim (Kneser_3 (fun i : nat => nth_coeff i p) n H H4 c). intros z H6 H7.
  2: astepl (AbsCC p ! [0]); auto.
 exists z.
  auto.
 astepl (AbsCC (Sum 0 n (fun i : nat => nth_coeff i p[*]z[^]i))); auto.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
Require Import Functor.Functor_Extender.
Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations
        Ext_Cons.Prod_Cat.Nat_Facts.
Require Import Adjunction.Adjunction.
Require Import KanExt.Local  KanExt.LocalFacts.Uniqueness.
Require Import Basic_Cons.Terminal.

Local Open Scope functor_scope.

(** This module contains conversion from local kan extension defiend as cones
to local kan extensions defined through hom functor. *)

Section Local_Right_KanExt_to_Hom_Local_Right_KanExt.
  Context {C C' : Category} {p : C –≻ C'}
          {D : Category} {F : C –≻ D}
          (lrke : Local_Right_KanExt p F).

  (** The left to right side of Hom_Local_Right_KanExt isomorphism. *)
  Program Definition Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_LR :
    (((@Fix_Bi_Func_2 _ (Func_Cat C D) _ F (Hom_Func (Func_Cat C D)))
        ∘ (Left_Functor_Extender p D)^op)
       –≻ (@Fix_Bi_Func_2 _ (Func_Cat C' D) _ lrke (Hom_Func (Func_Cat C' D))))%nattrans :=
    {|
      Trans :=  fun c h => LRKE_morph_ex lrke {|cone_apex := c; cone_edge := h|}
    |}.

  Next Obligation.
  Proof.
    extensionality x.
    repeat rewrite NatTrans_id_unit_left.
    match goal with
      [|- cone_morph (LRKE_morph_ex lrke ?A) = ?X] =>
      match X with
        ((cone_morph ?C) ∘ ?B)%nattrans =>
        change X with
        (cone_morph
           (LoKan_Cone_Morph_compose
              _
              _
              (Build_LoKan_Cone_Morph p F A {|cone_apex := c; cone_edge := x|} h eq_refl) C
           )
        )
      end
    end.
    apply LRKE_morph_unique.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_LR_obligation_1.
  Qed.

  (** The right to left side of Hom_Local_Right_KanExt isomorphism. *)
  Program Definition Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_RL :
    ((@Fix_Bi_Func_2 _ (Func_Cat C' D) _ lrke (Hom_Func (Func_Cat C' D)))
       –≻ ((@Fix_Bi_Func_2 _ (Func_Cat C D) _ F (Hom_Func (Func_Cat C D)))
             ∘ (Left_Functor_Extender p D)^op
             ))%nattrans
    :=
    {|
      Trans :=  fun c h => (lrke ∘ (h ∘_h (NatTrans_id p)))%nattrans
    |}.

  Next Obligation.
  Proof.
    extensionality x.
    repeat rewrite NatTrans_id_unit_left.
    rewrite NatTrans_compose_assoc.
    rewrite NatTrans_comp_hor_comp.
    rewrite NatTrans_id_unit_right.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_RL_obligation_1.
  Qed.

    (** Conversion from Local_Right_KanExt Hom_Local_Right_KanExt isomorphism. *)
  Program Definition Local_Right_KanExt_to_Hom_Local_Right_KanExt :
    Hom_Local_Right_KanExt p F :=
    {|
      HLRKE := (cone_apex (LRKE lrke));
      HLRKE_Iso :=
        {|
          iso_morphism := Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_LR;
          inverse_morphism := Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_RL
        |}
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality h; extensionality x.
    symmetry.
    apply (cone_morph_com (LRKE_morph_ex lrke {| cone_apex := h; cone_edge := x |})).
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality h; extensionality x.
    cbn in *.
    match goal with
      [|- cone_morph (LRKE_morph_ex lrke ?A) = ?X] =>
      change X with (cone_morph (Build_LoKan_Cone_Morph p F A lrke x eq_refl));
        apply (LRKE_morph_unique lrke A)
    end.
  Qed.

End Local_Right_KanExt_to_Hom_Local_Right_KanExt.