(* This file contains the definition of the auxiliary system R, and
   the formalisations of lemmas 29, 30, 31. *)

Require Import general.
Require Import iterms.
Require Import central_lemma.

(* definition 28 *)
Definition RootContr_aux t1 t2 :=
  match t1 with
  | C @i z @i x @i y =>
    (z = T /\ t2 = x) \/ (Eqv_clc z F /\ t2 = y) \/ (~(Eqv_clc z F) /\ Eqv_clc x y /\ t2 = x)
  | I @i x => t2 = x
  | K @i x @i y => t2 = x
  | Si @i x @i y @i z =>
    match t2 with
    | x1 @i z1 @i (y1 @i z2) =>  x = x1 /\ y = y1 /\ z = z1 /\ z = z2
    | _ => False
    end
  | _ => False
  end.

Definition Contr_aux := CtxClose_i RootContr_aux.
Definition Red_aux := clos_refl_trans iterm Contr_aux.
Definition Eqv_aux := EqvClose_i RootContr_aux.

Lemma lem_rcontr_aux_to_contr_aux : forall x y, RootContr_aux x y -> Contr_aux x y.
Proof.
  intros; unfold Contr_aux; pose_ctx_i; ycrush.
Qed.

Lemma lem_red_aux_refl : forall x, Red_aux x x.
Proof.
  unfold Red_aux; pose_rt; ycrush.
Qed.

Lemma lem_red_aux_trans : forall x y z, Red_aux x y -> Red_aux y z -> Red_aux x z.
Proof.
  unfold Red_aux; pose_rt; ycrush.
Qed.

Lemma lem_contr_aux_to_red_aux : forall x y, Contr_aux x y -> Red_aux x y.
Proof.
  unfold Red_aux; pose_rt; ycrush.
Qed.

Lemma lem_contr_aux_to_eqv_aux : forall x y, Contr_aux x y -> Eqv_aux x y.
Proof.
  unfold Eqv_aux; intros x y H; induction H; eqv_solve 1.
Qed.

Lemma lem_rcontr_aux_to_red_aux : forall x y, RootContr_aux x y -> Red_aux x y.
Proof.
  auto using lem_rcontr_aux_to_contr_aux, lem_contr_aux_to_red_aux.
Qed.

Lemma lem_red_aux_cong_l : forall x y z, Red_aux x y -> Red_aux (x @i z) (y @i z).
Proof.
  unfold Red_aux; intros; induction H.
  unfold Contr_aux in *; pose_rt; pose_ctx_i; ycrush.
  pose_rt; ycrush.
  pose_rt; ycrush.
Qed.

Lemma lem_red_aux_cong_r : forall x y z, Red_aux x y -> Red_aux (z @i x) (z @i y).
Proof.
  unfold Red_aux; intros; induction H.
  unfold Contr_aux in *; pose_rt; pose_ctx_i; ycrush.
  pose_rt; ycrush.
  pose_rt; ycrush.
Qed.

Lemma lem_contr_aux_cong_l : forall x y z, Contr_aux x y -> Contr_aux (x @i z) (y @i z).
Proof.
  unfold Contr_aux; intros; induction H; pose_ctx_i; ycrush.
Qed.

Lemma lem_contr_aux_cong_r : forall x y z, Contr_aux x y -> Contr_aux (z @i x) (z @i y).
Proof.
  unfold Contr_aux; intros; induction H; pose_ctx_i; ycrush.
Qed.

Ltac pose_contr_aux := pose lem_contr_aux_cong_l; pose lem_contr_aux_cong_r;
                       pose lem_rcontr_aux_to_contr_aux.

Ltac red_aux_induction z := unfold Red_aux in *; rt_induction z; fold Contr_aux Red_aux in *.

Ltac pose_red_aux := pose lem_red_aux_refl; pose lem_red_aux_trans; pose lem_rcontr_aux_to_red_aux;
                     pose lem_contr_aux_to_red_aux; pose lem_red_aux_cong_l; pose lem_red_aux_cong_r.

Lemma lem_rcontr_aux_to_red_clc : forall x y, RootContr_aux x y -> Red_clc x y.
Proof.
  intros.
  ydestruct x; yisolve.
  ydestruct x1; yisolve.
  rc0_crush.
  ydestruct x1_1; yisolve.
  rc0_crush.
  ydestruct x1_1_1; yisolve.
  yintuition.
  rc0_crush.
  assert (Red_clc x1_1_2 F) by auto using lem_central_lemma.
  assert (Red_clc (C @i F @i x1_2 @i x2) x2) by rc0_crush.
  pose_red_clc; ycrush.
  assert (Eqv_clc0 x1_2 x2).
  pose lem_eqv_clc_to_eqv_clc0; ycrush.
  apply lem_contr_clc_to_red_clc; apply lem_contr_clc_to_1.
  assert (RootContr_clc_n 1 (C @i x1_1_2 @i x1_2 @i x2) x1_2).
  unfold Eqv_clc0, RootContr_clc0 in *; ycrush.
  unfold Contr_clc_n; pose_ctx_i; ycrush.
  rc0_crush.
Qed.

(* lemma 30 *)
Lemma lem_contr_aux_to_red_clc : forall x y, Contr_aux x y -> Red_clc x y.
Proof.
  intros x y H; induction H.
  pose lem_rcontr_aux_to_red_clc; ycrush.
  pose_red_clc; ycrush.
  pose_red_clc; ycrush.
Qed.

Lemma lem_red_aux_to_red_clc : forall x y, Red_aux x y -> Red_clc x y.
Proof.
  intros x y H; induction H.
  pose lem_contr_aux_to_red_clc; ycrush.
  pose_red_clc; ycrush.
  pose_red_clc; ycrush.
Qed.

Lemma lem_rcontr_clc0_to_rcontr_aux : forall x y, RootContr_clc0 x y -> RootContr_aux x y.
Proof.
  intros.
  ydestruct x; yisolve.
  ydestruct x1; yisolve.
  ydestruct x1_1; yisolve.
  ydestruct x1_1_1; yisolve.
  unfold RootContr_clc0 in *; simpl in *; yintuition.
  assert (Eqv_clc y y) by eqv_solve 1.
  tauto.
Qed.

(* lemma 29 *)
Lemma lem_contr_clc0_to_contr_aux : forall x y, Contr_clc0 x y -> Contr_aux x y.
Proof.
  intros x y H; induction H.
  apply lem_rcontr_aux_to_contr_aux; apply lem_rcontr_clc0_to_rcontr_aux; ycrush.
  pose_contr_aux; ycrush.
  pose_contr_aux; ycrush.
Qed.

Lemma lem_red_clc0_to_red_aux : forall x y, Red_clc0 x y -> Red_aux x y.
Proof.
  intros x y H; induction H.
  apply lem_contr_aux_to_red_aux; apply lem_contr_clc0_to_contr_aux; ycrush.
  ycrush.
  pose_red_aux; ycrush.
Qed.

Lemma lem_eqv_clc0_to_eqv_aux : forall x y, Eqv_clc0 x y -> Eqv_aux x y.
Proof.
  intros x y H; induction H; fold Contr_clc0 in *.
  apply lem_contr_aux_to_eqv_aux; apply lem_contr_clc0_to_contr_aux; ycrush.
  ycrush.
  unfold Eqv_aux in *; eqv_solve 1.
  unfold Eqv_aux in *; eqv_solve 1.
Qed.

Lemma lem_eqv_clc_to_eqv_aux : forall x y, Eqv_clc x y -> Eqv_aux x y.
Proof.
  auto using lem_eqv_clc0_to_eqv_aux, lem_eqv_clc_to_eqv_clc0.
Qed.

Inductive Par_aux : iterm -> iterm -> Prop :=
| par_aux_base : forall x y, RootContr_aux x y -> Par_aux x y
| par_aux_eq : forall x, Par_aux x x
| par_aux_app : forall x x' y y', Par_aux x x' -> Par_aux y y' -> Par_aux (x @i y) (x' @i y').

Ltac pose_par_aux := pose par_aux_base; pose par_aux_eq; pose par_aux_app.

Lemma lem_contr_aux_to_par_aux : forall x y, Contr_aux x y -> Par_aux x y.
Proof.
  intros x y H; induction H; pose_par_aux; ycrush.
Qed.

Lemma lem_par_aux_to_red_aux : forall x y, Par_aux x y -> Red_aux x y.
Proof.
  intros x y H; induction H; pose_red_aux; ycrush.
Qed.

Lemma lem_par_aux_rcontr :
  forall x y, Par_aux x y -> forall z, RootContr_aux x z ->
                                       exists u, Par_aux y u /\ Par_aux z u.
Proof.
  intros x y H; induction H.
  intros.
  ydestruct x; yisolve.
  ydestruct x1; yisolve.
  ycrush.
  ydestruct x1_1; yisolve.
  ycrush.
  ydestruct x1_1_1; yisolve.
  yintuition; yisolve.
  pose cor_t_not_f; ycrush.
  pose cor_t_not_f; ycrush.
  ycrush.
  pose_par_aux; ycrush.
  intros.
  ydestruct x; yisolve.
  yinversion H; yisolve.
  pose_par_aux; ycrush.
  ydestruct x1; yisolve.
  yinversion H; yisolve.
  pose_par_aux; ycrush.
  yinversion H4; yisolve.
  pose_par_aux; ycrush.
  ydestruct x1_1; yisolve.
  yinversion H; yisolve.
  yintuition; yisolve.
  assert (RootContr_aux (C @i T @i x2 @i y') x2) by ycrush.
  pose_par_aux; ycrush.
  assert (RootContr_aux (C @i x1_2 @i x2 @i y') y') by ycrush.
  pose_par_aux; ycrush.
  assert (RootContr_aux (C @i x1_2 @i x2 @i y') x2).
  assert (Eqv_clc x2 y').
  assert (Eqv_clc y y').
  pose lem_par_aux_to_red_aux; pose lem_red_aux_to_red_clc; pose lem_red_clc_to_eqv_clc; ycrush.
  unfold Eqv_clc in *; eqv_solve 1.
  ycrush.
  pose_par_aux; ycrush.
  yinversion H4; yisolve.
  yintuition; yisolve.
  assert (RootContr_aux (C @i T @i y'0 @i y') y'0) by ycrush.
  pose_par_aux; ycrush.
  assert (RootContr_aux (C @i x1_2 @i y'0 @i y') y') by ycrush.
  pose_par_aux; ycrush.
  assert (Eqv_clc y'0 y').
  assert (Eqv_clc y y').
  pose lem_par_aux_to_red_aux; pose lem_red_aux_to_red_clc; pose lem_red_clc_to_eqv_clc; ycrush.
  assert (Eqv_clc x2 y'0).
  pose lem_par_aux_to_red_aux; pose lem_red_aux_to_red_clc; pose lem_red_clc_to_eqv_clc; ycrush.
  unfold Eqv_clc in *; eauto using eqv_sym, eqv_trans.
  assert (RootContr_aux (C @i x1_2 @i y'0 @i y') y'0) by ycrush.
  pose_par_aux; ycrush.
  yinversion H3; yisolve.
  yintuition.
  yinversion H7; yisolve.
  assert (RootContr_aux (C @i T @i y'0 @i y') y'0) by ycrush.
  pose_par_aux; ycrush.
  assert (Eqv_clc y'1 F).
  assert (Eqv_clc x1_2 y'1).
  pose lem_par_aux_to_red_aux; pose lem_red_aux_to_red_clc; pose lem_red_clc_to_eqv_clc; ycrush.
  unfold Eqv_clc in *; eauto using eqv_sym, eqv_trans.
  assert (RootContr_aux (C @i y'1 @i y'0 @i y') y') by ycrush.
  pose_par_aux; ycrush.
  assert (Eqv_clc y'0 y').
  assert (Eqv_clc y y').
  pose lem_par_aux_to_red_aux; pose lem_red_aux_to_red_clc; pose lem_red_clc_to_eqv_clc; ycrush.
  assert (Eqv_clc x2 y'0).
  pose lem_par_aux_to_red_aux; pose lem_red_aux_to_red_clc; pose lem_red_clc_to_eqv_clc; ycrush.
  unfold Eqv_clc in *; eauto using eqv_sym, eqv_trans.
  assert (~(Eqv_clc y'1 F)).
  unfold not; intro HH.
  assert (Eqv_clc x1_2 y'1).
  pose lem_par_aux_to_red_aux; pose lem_red_aux_to_red_clc; pose lem_red_clc_to_eqv_clc; ycrush.
  unfold Eqv_clc in *; eqv_solve 1.
  assert (RootContr_aux (C @i y'1 @i y'0 @i y') y'0) by ycrush.
  pose_par_aux; ycrush.
  ydestruct z; yisolve.
  ydestruct z1; yisolve.
  ydestruct z2; yisolve.
  simpl in *; simp_hyps; subst.
  yinversion H; yisolve.
  assert (RootContr_aux (Si @i z1_1 @i z2_1 @i y') (z1_1 @i y' @i (z2_1 @i y'))) by ycrush.
  exists (z1_1 @i y' @i (z2_1 @i y')).
  pose_par_aux; ycrush.
  yinversion H3; yisolve.
  assert (RootContr_aux (Si @i z1_1 @i y'0 @i y') (z1_1 @i y' @i (y'0 @i y'))) by ycrush.
  exists (z1_1 @i y' @i (y'0 @i y')).
  pose_par_aux; ycrush.
  yinversion H2; yisolve.
  assert (RootContr_aux (Si @i y'1 @i y'0 @i y') (y'1 @i y' @i (y'0 @i y'))) by ycrush.
  exists (y'1 @i y' @i (y'0 @i y')).
  pose_par_aux; ycrush.
Qed.

Lemma lem_par_aux_confluent : forall x y z, Par_aux x y -> Par_aux x z ->
                                            exists u, Par_aux y u /\ Par_aux z u.
Proof.
  induction x.
  intros; exists C; ycrush.
  intros; exists T; ycrush.
  intros; exists F; ycrush.
  intros; exists I; ycrush.
  intros; exists K; ycrush.
  intros; exists Si; ycrush.
  intros; exists (var n); ycrush.
  intros.
  yinversion H.
  assert (exists u : iterm, Par_aux z u /\ Par_aux y u).
  eapply lem_par_aux_rcontr; ycrush.
  ycrush.
  pose_par_aux; ycrush.
  yinversion H0.
  eapply lem_par_aux_rcontr with (x := (x1 @i x2)); pose_par_aux; ycrush.
  pose_par_aux; ycrush.
  assert (exists u : iterm, Par_aux x' u /\ Par_aux x'0 u) by ycrush.
  assert (exists u : iterm, Par_aux y' u /\ Par_aux y'0 u) by ycrush.
  pose_par_aux; ycrush.
Qed.

Lemma lem_aux_commute : forall x y z, Par_aux x y -> Red_aux x z ->
                                      exists u, Red_aux y u /\ Par_aux z u.
Proof.
  assert (forall x z, Red_aux x z -> forall y, Par_aux x y ->
                                               exists u, Red_aux y u /\ Par_aux z u).
  intros x z H; induction H; fold Red_aux in *.
  intros.
  assert (exists u, Par_aux y0 u /\ Par_aux y u).
  pose lem_par_aux_confluent; pose lem_contr_aux_to_par_aux; ycrush.
  pose lem_par_aux_to_red_aux; ycrush.
  pose_red_aux; ycrush.
  pose_red_aux; ycrush.
  ycrush.
Qed.

(* lemma 31 *)
Lemma lem_aux_confluent : forall x y z, Red_aux x y -> Red_aux x z ->
                                        exists u, Red_aux y u /\ Red_aux z u.
Proof.
  assert (forall x y, Red_aux x y -> forall z, Red_aux x z ->
                                               exists u, Red_aux y u /\ Red_aux z u).
  intros x y H; induction H; fold Contr_aux Red_aux in *.
  pose lem_aux_commute; pose lem_contr_aux_to_par_aux; pose lem_par_aux_to_red_aux; ycrush.
  ycrush.
  pose_red_aux; ycrush.
  ycrush.
Qed.

Lemma lem_aux_cr : forall x y, Eqv_aux x y -> exists u, Red_aux x u /\ Red_aux y u.
Proof.
  intros x y H; induction H; fold Contr_aux Red_aux in *.
  pose_red_aux; ycrush.
  pose_red_aux; ycrush.
  pose_red_aux; ycrush.
  simp_hyps.
  assert (exists u, Red_aux x1 u /\ Red_aux x0 u).
  pose lem_aux_confluent; ycrush.
  pose_red_aux; ycrush.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export inversion.
Require Export complexes_conjugaison.
Require Export complexes_similitudes.
Set Implicit Arguments.
Unset Strict Implicit.
(* a mettre plus haut dans les complexes*)

Lemma Rinj_opp : forall k : R, Rinj (- k) = Copp (Rinj k).
unfold Rinj in |- *; intros.
rewrite Copp_algebrique.
RReplace (-0) 0; auto.
Qed.

Lemma Conj_Copp : forall z : C, Conj (Copp z) = Copp (Conj z).
intros.
elim existence_parties_relles_imaginaires with (z := z); intros x1 H; elim H;
 intros y1 H0; try clear H; try exact H0.
rewrite H0.
rewrite Copp_algebrique.
repeat rewrite Conj_algebrique.
rewrite Copp_algebrique; auto.
Qed.

Lemma Copp_Cmult : forall z : C, Copp z = Cmult (Rinj (-1)) z.
intros.
replace (Rinj (-1)) with (Copp oneC).
ring.
unfold oneC, Rinj in |- *.
rewrite Copp_algebrique; auto.
RReplace (-0) 0; auto.
Qed.

Lemma Copp_non_zeroC : forall z : C, z <> zeroC -> Copp z <> zeroC.
intros.
rewrite Copp_Cmult.
apply nonzero_produit; auto with geo.
Qed.
Hint Resolve Copp_non_zeroC nonzero_produit: geo.

Lemma Cinv_Copp : forall z : C, z <> zeroC -> Cinv (Copp z) = Copp (Cinv z).
intros.
assert (Copp z <> zeroC); auto with geo.
assert (Cmult (Copp z) (Copp (Cinv z)) = oneC).
2: apply Cinv_def2; auto.
ring_simplify.
apply Cinv_def; auto.
Qed.

Lemma carre_module :
 forall (z : C) (x y : R),
 z = cons_cart x y -> Rsqr (module z) = Rsqr x + Rsqr y.
intros.
rewrite (passage_algebrique_module H).
rewrite Rsqr_sqrt; auto.
assert (0 <= Rsqr x); auto with real.
assert (0 <= Rsqr y); auto with real.
fourier.
Qed.

Lemma produit_Conj_module :
 forall z : C, Cmult z (Conj z) = Rinj (Rsqr (module z)).
intros.
elim existence_parties_relles_imaginaires with (z := z); intros x H; elim H;
 intros y H0; try clear H; try exact H0.
pattern z at 1 2 in |- *.
rewrite H0.
rewrite Conj_algebrique.
rewrite (passage_algebrique_module H0).
rewrite Cmult_algebrique.
RReplace (y * x + x * - y) 0.
rewrite Rsqr_sqrt.
unfold Rsqr, Rinj in |- *.
RReplace (x * x + - (y * - y)) (x * x + y * y); auto.
assert (0 <= Rsqr x); auto with real.
assert (0 <= Rsqr y); auto with real.
fourier.
Qed.

Lemma Rinj_Cmult : forall x y : R, Rinj (x * y) = Cmult (Rinj x) (Rinj y).
intros.
unfold Rinj, oneC in |- *.
rewrite Cmult_algebrique.
RReplace (x * y + - (0 * 0)) (x * y).
RReplace (0 * y + x * 0) 0; auto.
Qed.

Lemma Rinj_Cinv : forall k : R, k <> 0 -> Rinj (/ k) = Cinv (Rinj k).
intros.
assert (Rinj k <> zeroC); auto with geo.
assert (Cmult (Rinj k) (Rinj (/ k)) = oneC).
2: symmetry  in |- *; apply Cinv_def2; auto.
unfold Rinj, oneC in |- *.
rewrite Cmult_algebrique.
replace (0 * / k + k * 0) with 0 by (field;auto).
replace (k * / k + - (0 * 0)) with 1 by (field;auto).
auto.
Qed.

Lemma Cinv_Cmult :
 forall z z' : C,
 z <> zeroC -> z' <> zeroC -> Cinv (Cmult z z') = Cmult (Cinv z) (Cinv z').
intros.
assert (Cmult z z' <> zeroC); [ auto with geo | idtac ].
assert (Cmult (Cmult z z') (Cmult (Cinv z) (Cinv z')) = oneC).
replace (Cmult (Cmult z z') (Cmult (Cinv z) (Cinv z'))) with
 (Cmult (Cmult z (Cinv z)) (Cmult z' (Cinv z'))); [ idtac | ring ].
rewrite Cinv_def; auto.
rewrite Cinv_def; auto.
ring.
apply Cinv_def2; auto.
Qed.

Lemma Cinv_Conj :
 forall z : C,
 z <> zeroC -> Cinv z = Cmult (Cinv (Rinj (Rsqr (module z)))) (Conj z).
intros.
assert (module z <> 0); auto with geo.
assert (Rsqr (module z) <> 0).
unfold Rsqr in |- *; auto with real.
assert (Rinj (Rsqr (module z)) <> zeroC); auto with geo.
assert (Cmult z (Cmult (Cinv (Rinj (Rsqr (module z)))) (Conj z)) = oneC).
2: apply Cinv_def2; auto.
replace (Cmult z (Cmult (Cinv (Rinj (Rsqr (module z)))) (Conj z))) with
 (Cmult (Cinv (Rinj (Rsqr (module z)))) (Cmult z (Conj z))).
rewrite produit_Conj_module.
apply Cinv_l; auto.
ring.
Qed.

Lemma Conj_Cinv :
 forall z : C,
 z <> zeroC -> Cinv (Conj z) = Cmult (Cinv (Rinj (Rsqr (module z)))) z.
intros.
assert (Conj z <> zeroC); auto with geo.
rewrite Cinv_Conj; auto.
rewrite Conj_Conj; rewrite module_Conj; auto.
Qed.

Lemma Cmult_Rinj_algebrique :
 forall x y k : R, Cmult (Rinj k) (cons_cart x y) = cons_cart (k * x) (k * y).
unfold Rinj in |- *; intros.
rewrite Cmult_algebrique.
replace (k * x + - (0 * y)) with (k * x) by ring.
replace (0 * x + k * y) with (k * y) by ring.
auto.
Qed.

Lemma Cinv_algebrique :
 forall (z : C) (x y : R),
 z <> zeroC ->
 z = cons_cart x y ->
 Cinv z = cons_cart (x / (Rsqr x + Rsqr y)) (- y / (Rsqr x + Rsqr y)).
intros.
assert (module z <> 0); auto with geo.
assert (Rsqr (module z) <> 0).
unfold Rsqr in |- *; auto with real.
rewrite Cinv_Conj; auto.
rewrite (Conj_def H0); auto.
rewrite <- Rinj_Cinv; auto.
rewrite Cmult_Rinj_algebrique.
rewrite (carre_module H0); auto.
unfold Rdiv in |- *.
RReplace (/ (Rsqr x + Rsqr y) * x) (x * / (Rsqr x + Rsqr y)).
RReplace (/ (Rsqr x + Rsqr y) * - y) (- y * / (Rsqr x + Rsqr y)); auto.
Qed.
(* partie concernant l'inversion *)

Lemma inversion_origine_module :
 forall (k : R) (z z' : C) (M M' : PO),
 k <> 0 ->
 O <> M ->
 z = affixe_vec (vec O M) ->
 z' = affixe_vec (vec O M') ->
 M' = inversion O k M :>PO -> module z' = Rabs k * / module z.
intros.
assert (vec O M' = mult_PP (/ Rsqr (distance O M) * k) (vec O M)).
apply inversion_pole_vecteur; auto.
assert (module z <> 0).
apply module_non_zero.
apply points_distincts_non_zeroC with (1 := H0); auto with geo.
RReplace (/ module z) (1 * / module z).
RReplace 1 (/ module z * module z).
RReplace (/ module z * module z * / module z)
 (/ module z * / module z * module z).
replace (/ module z * / module z) with (/ Rsqr (module z)).
pattern (module z) at 1 in |- *.
rewrite (module_def2 (z:=z) (M:=M)); auto with geo.
RReplace (Rabs k * (/ Rsqr (distance O M) * module z))
 (/ Rsqr (distance O M) * Rabs k * module z).
replace (/ Rsqr (distance O M) * Rabs k) with
 (Rabs (/ Rsqr (distance O M) * k)).
apply
 (module_affixe_produit_vecteur_OM (k:=/ Rsqr (distance O M) * k) (M:=M)
    (M':=M') (z:=z) (z':=z')); auto with geo.
rewrite Rabs_mult.
rewrite <- (module_def2 (z:=z) (M:=M)); auto with geo.
unfold Rsqr in |- *.
rewrite Rabs_Rinv; auto with real.
rewrite Rabs_right; auto with geo real.
unfold Rsqr in |- *.
rewrite Rinv_mult_distr; auto with real.
Qed.

Lemma aux_positif :
 forall (k : R) (M : PO),
 O <> M :>PO -> k > 0 -> / Rsqr (distance O M) * k > 0.
intros.
apply Rmult_gt_0_compat; auto.
apply Rgt_inv; auto.
unfold Rsqr in |- *.
assert (distance O M > 0).
assert (distance O M >= 0); auto with geo.
elim H1; intros; auto.
absurd (distance O M = 0); auto with geo.
apply Rmult_gt_0_compat; auto.
Qed.

Lemma aux_negatif :
 forall (k : R) (M : PO),
 O <> M :>PO -> k < 0 -> / Rsqr (distance O M) * k < 0.
intros.
RReplace (/ Rsqr (distance O M) * k) (- (/ Rsqr (distance O M) * - k)).
apply Ropp_lt_gt_0_contravar.
apply aux_positif; auto with real.
Qed.

Lemma argument_affixe_inversion_pole_positif :
 forall (k : R) (M M' : PO) (z z' : C),
 O <> M :>PO ->
 k > 0 ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 M' = inversion O k M :>PO -> argument z' = argument z :>AV.
intros.
assert (vec O M' = mult_PP (/ Rsqr (distance O M) * k) (vec O M)).
apply inversion_pole_vecteur; auto.
auto with real.
apply argument_affixe_produit_positif_vecteur_OM with (3 := H4); auto.
apply aux_positif; auto.
Qed.

Lemma argument_affixe_inversion_pole_negatif :
 forall (k : R) (M M' : PO) (z z' : C),
 O <> M :>PO ->
 k < 0 ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 M' = inversion O k M :>PO ->
 argument z' = plus (argument z) (image_angle pi) :>AV.
intros.
assert (vec O M' = mult_PP (/ Rsqr (distance O M) * k) (vec O M)).
apply inversion_pole_vecteur; auto.
auto with real.
apply argument_affixe_produit_negatif_vecteur_OM with (3 := H4); auto.
apply aux_negatif; auto.
Qed.

Lemma argument_affixe_inversion_positif_conjugue :
 forall (k : R) (M M' : PO) (z z' : C),
 O <> M :>PO ->
 k > 0 ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 M' = inversion O k M :>PO -> argument z' = argument (Cinv (Conj z)) :>AV.
intros.
assert (z <> zeroC).
apply points_distincts_non_zeroC with (1 := H); auto with geo.
assert (Conj z <> zeroC); auto with geo.
rewrite
 (argument_affixe_inversion_pole_positif (k:=k) (M:=M) (M':=M') (z:=z)
    (z':=z')); auto.
rewrite Cinv_argument; auto.
rewrite argument_Conj2; auto.
mes (argument z).
RReplace (- - x) x; auto.
Qed.

Theorem inversion_positif_complexe :
 forall (k : R) (z z' : C) (M M' : PO),
 O <> M :>PO ->
 k > 0 ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 M' = inversion O k M :>PO -> z' = Cmult (Rinj k) (Cinv (Conj z)).
intros.
assert (k <> 0); auto with real.
assert (z <> zeroC).
apply points_distincts_non_zeroC with (1 := H); auto with geo.
assert (Conj z <> zeroC); auto with geo.
assert (O <> M').
apply image_distinct_pole with (3 := H3); auto with real.
apply egalite_forme_polaire.
apply points_distincts_non_zeroC with (1 := H7); auto with geo.
apply nonzero_produit; auto with geo.
rewrite (inversion_origine_module (k:=k) (z:=z) (z':=z') (M:=M) (M':=M'));
 auto.
rewrite <- (module_Conj z).
rewrite Cmult_module; auto.
rewrite Cinv_module; auto.
rewrite module_reel; auto.
rewrite
 (argument_affixe_inversion_positif_conjugue (k:=k) (M:=M) (M':=M') (z:=z)
    (z':=z')); auto.
rewrite Cmult_argument; auto with geo.
rewrite argument_reel_pos; auto with real.
mes (argument (Cinv (Conj z))).
RReplace (0 + x) x; auto.
Qed.

Theorem inversion_negatif_complexe :
 forall (k : R) (z z' : C) (M M' : PO),
 O <> M :>PO ->
 k < 0 ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 M' = inversion O k M :>PO -> z' = Cmult (Rinj k) (Cinv (Conj z)).
intros.
assert (k <> 0); auto with real.
assert (z <> zeroC).
apply points_distincts_non_zeroC with (1 := H); auto with geo.
assert (Conj z <> zeroC); auto with geo.
symetrique O M ipattern:(N).
assert (M' = inversion O (- k) N).
apply inversion_oppose_puissance with (3 := H3); auto.
assert (- k > 0); auto with real.
assert (O <> N).
assert (O = homothetie (-1) O O); auto with geo.
unfold symetrie in H5.
apply
 (image_homothetie_distincts (k:=-1) (I:=O) (A:=O) (A':=O) (B:=M) (B':=N));
 auto with real.
rewrite
 (inversion_positif_complexe (k:=- k) (z:=Copp z) (z':=z') (M:=N) (M':=M'))
 ; auto.
rewrite Rinj_opp.
rewrite Conj_Copp.
rewrite Cinv_Copp; auto.
ring.
symmetry  in |- *.
rewrite
 (produit_vecteur_image (k:=-1) (z:=z) (z':=affixe_vec (vec O N)) (A:=O)
    (B:=M) (A':=O) (B':=N)); auto.
replace (Rinj (-1)) with (Copp oneC).
ring.
unfold oneC, Rinj in |- *.
rewrite Copp_algebrique; auto.
RReplace (-0) 0; auto.
VReplace (mult_PP (-1) (vec O M)) (vec M O).
rewrite (milieu_vecteur H8); auto.
Qed.

Theorem inversion_pole_origine_complexe :
 forall (k : R) (z z' : C) (M M' : PO),
 O <> M :>PO ->
 k <> 0 ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 M' = inversion O k M :>PO -> z' = Cmult (Rinj k) (Cinv (Conj z)).
intros.
elim Rtotal_order with (r1 := k) (r2 := 0);
 [ intros H4; try clear total_order
 | intros H4; elim H4;
    [ intros H5; try clear H4 total_order; try exact H5
    | intros H5; try clear H4 total_order ] ].
rewrite (inversion_negatif_complexe (k:=k) (z:=z) (z':=z') (M:=M) (M':=M'));
 auto.
absurd (k = 0); auto.
rewrite (inversion_positif_complexe (k:=k) (z:=z) (z':=z') (M:=M) (M':=M'));
 auto.
Qed.

Theorem complexe_inversion_pole_origine :
 forall (k : R) (z z' : C) (M M' : PO),
 O <> M :>PO ->
 k <> 0 ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 z' = Cmult (Rinj k) (Cinv (Conj z)) -> M' = inversion O k M :>PO.
intros.
apply homothetie_inversion; auto.
apply vecteur_homothetie; auto.
apply
 (produit_reel_affixe_vecteur_OM (k:=/ Rsqr (distance O M) * k) (z:=z)
    (z':=z') (M:=M) (M':=M')); auto.
rewrite H3.
rewrite Rinj_Cmult.
assert (z <> zeroC).
apply points_distincts_non_zeroC with (1 := H); auto with geo.
assert (Conj z <> zeroC); auto with geo.
rewrite <- (module_def2 (z:=z) (M:=M)); auto with geo.
rewrite Rinj_Cinv.
rewrite <- produit_Conj_module.
rewrite Cinv_Cmult; auto.
replace (Cmult (Cmult (Cmult (Cinv z) (Cinv (Conj z))) (Rinj k)) z) with
 (Cmult (Cmult z (Cinv z)) (Cmult (Cinv (Conj z)) (Rinj k))).
2: ring.
rewrite Cinv_def; auto.
ring.
unfold Rsqr in |- *.
assert (module z <> 0); auto with geo.
auto with real.
Qed.

Theorem ecriture_complexe_inversion_pole_origine :
 forall (k : R) (z z' : C) (M M' : PO),
 O <> M ->
 k <> 0 ->
 z = affixe M ->
 z' = affixe M' ->
 (M' = inversion O k M <-> z' = Cmult (Rinj k) (Cinv (Conj z))).
intros; red in |- *; try split; intros.
apply
 (inversion_pole_origine_complexe (k:=k) (z:=z) (z':=z') (M:=M) (M':=M'));
 auto with geo.
apply
 (complexe_inversion_pole_origine (k:=k) (z:=z) (z':=z') (M:=M) (M':=M'));
 auto with geo.
Qed.

Theorem inversion_complexe :
 forall (k : R) (j z z' : C) (J M M' : PO),
 J <> M ->
 k <> 0 ->
 z = affixe M ->
 z' = affixe M' ->
 j = affixe J ->
 M' = inversion J k M ->
 Cplus z' (Copp j) = Cmult (Rinj k) (Cinv (Conj (Cplus z (Copp j)))).
intros.
elim existence_representant_vecteur with (A := O) (B := J) (C := M); intros N;
 intros.
elim existence_representant_vecteur with (A := O) (B := J) (C := M');
 intros N'; intros.
assert (O <> N).
apply distinct_egalite_vecteur with (2 := H5); auto.
assert (vec J M' = mult_PP (/ Rsqr (distance J M) * k) (vec J M)).
apply homothetie_vecteur.
apply inversion_homothetie; auto.
generalize H8.
replace (Rsqr (distance J M)) with (Rsqr (distance O N)).
rewrite <- H6; rewrite <- H5; intros.
assert (N' = inversion O k N).
apply homothetie_inversion; auto.
apply vecteur_homothetie; auto.
rewrite (affixe_vec_AB H3 H2).
rewrite (affixe_vec_AB H3 H1).
rewrite <- H6; rewrite <- H5.
elim existence_affixe_vecteur_point with (M := N); intros z1; intros.
elim existence_affixe_vecteur_point with (M := N'); intros z2; intros.
rewrite <- H12; rewrite <- H11.
apply inversion_pole_origine_complexe with (5 := H10); auto.
unfold Rsqr in |- *.
repeat rewrite <- carre_scalaire_distance.
rewrite H5; auto.
Qed.

Theorem complexe_inversion :
 forall (k : R) (j z z' : C) (J M M' : PO),
 J <> M ->
 k <> 0 ->
 z = affixe M ->
 z' = affixe M' ->
 j = affixe J ->
 Cplus z' (Copp j) = Cmult (Rinj k) (Cinv (Conj (Cplus z (Copp j)))) ->
 M' = inversion J k M.
intros.
elim existence_representant_vecteur with (A := O) (B := J) (C := M); intros N;
 intros.
elim existence_representant_vecteur with (A := O) (B := J) (C := M');
 intros N'; intros.
assert (O <> N).
apply distinct_egalite_vecteur with (2 := H5); auto.
apply homothetie_inversion; auto.
apply vecteur_homothetie.
rewrite <- H6; rewrite <- H5.
replace (Rsqr (distance J M)) with (Rsqr (distance O N)).
assert (N' = inversion O k N).
apply complexe_inversion_pole_origine with (5 := H4); auto.
rewrite H5; auto with geo.
rewrite H6; auto with geo.
apply homothetie_vecteur.
apply inversion_homothetie; auto.
unfold Rsqr in |- *.
repeat rewrite <- carre_scalaire_distance.
rewrite H5; auto.
Qed.

Theorem ecriture_complexe_inversion :
 forall (k : R) (j z z' : C) (J M M' : PO),
 J <> M ->
 k <> 0 ->
 z = affixe M ->
 z' = affixe M' ->
 j = affixe J ->
 (M' = inversion J k M <->
  Cplus z' (Copp j) = Cmult (Rinj k) (Cinv (Conj (Cplus z (Copp j))))).
intros; red in |- *; try split; intros.
apply
 (inversion_complexe (k:=k) (j:=j) (z:=z) (z':=z') (J:=J) (M:=M) (M':=M'));
 auto.
apply
 (complexe_inversion (k:=k) (j:=j) (z:=z) (z':=z') (J:=J) (M:=M) (M':=M'));
 auto.
Qed.


Require Import Frap Setoid Classes.Morphisms SepCancel.
Export Setoid Classes.Morphisms.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Shared notations and definitions; main material starts afterward. *)

Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
Definition heap := fmap nat nat.
Definition assertion := heap -> Prop.

Global Hint Extern 1 (_ <= _) => linear_arithmetic : core.
Global Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.

Ltac simp := repeat (simplify; subst; propositional;
                     try match goal with
                         | [ H : ex _ |- _ ] => invert H
                         end); try linear_arithmetic.

(** * Encore of last mixed-embedding language from last time *)

(* First, almost exactly the same syntactic language definition as from class: *)

Inductive loop_outcome acc res :=
| Done (r : res)
| Again (a : acc).
(* ^-- One slight difference: we allow the result type from a loop to differ from the
 *     type of the iteration variable.
 *)

Arguments Done {acc} {res}.
Arguments Again {acc} {res}.

Inductive cmd : Set -> Type :=
| Return {result : Set} (r : result) : cmd result
| Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
| Read (a : nat) : cmd nat
| Write (a v : nat) : cmd unit
| Loop {acc res : Set} (init : acc) (body : acc -> cmd (loop_outcome acc res)) : cmd res
| Fail {result} : cmd result
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit.

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).

Fixpoint initialize (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => initialize h base numWords' $+ (base + numWords', 0)
  end.

Fixpoint deallocate (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => deallocate (h $- base) (base+1) numWords'
  end.

(* Now here's *almost* exactly the same semantics.  See one exception noted
 * below. *)
Inductive step : forall A, heap * cmd A -> heap * cmd A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h h',
  step (h, c1) (h', c1')
  -> step (h, Bind c1 c2) (h', Bind c1' c2)
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h,
  step (h, Bind (Return v) c2) (h, c2 v)

| StepLoop : forall (acc res : Set) (init : acc) (body : acc -> cmd (loop_outcome acc res)) h,
  step (h, Loop init body) (h, o <- body init; match o with
                                               | Done a => Return a
                                               | Again a => Loop a body
                                               end)

| StepRead : forall h a v,
  h $? a = Some v
  -> step (h, Read a) (h, Return v)
| StepWrite : forall h a v v',
  h $? a = Some v
  -> step (h, Write a v') (h $+ (a, v'), Return tt)

| StepAlloc : forall h numWords a,
  (forall i, i < numWords -> h $? (a + i) = None)
  -> a <> 0
  -> step (h, Alloc numWords) (initialize h a numWords, Return a)
(* ^-- DIFFERENCE FROM CLASS: Now we record that a freshly allocated object has
 * a nonnull address, so that we are free to use null (0) for a special purpose
 * in linked data structures. *)

| StepFree : forall h a numWords,
  step (h, Free a numWords) (deallocate h a numWords, Return tt).

Definition trsys_of (h : heap) {result} (c : cmd result) := {|
  Initial := {(h, c)};
  Step := step (A := result)
|}.

(* Here's exactly the same instantiation of the separation-logic connectives and
 * their algebraic laws. *)
Module Import Sep <: SEP.
  Definition hprop := heap -> Prop.

  (* Implication *)
  Definition himp (p q : hprop) := forall h, p h -> q h.

  (* Equivalence *)
  Definition heq (p q : hprop) := forall h, p h <-> q h.

  (* Lifting a pure proposition *)
  Definition lift (P : Prop) : hprop :=
    fun h => P /\ h = $0.

  (* Separating conjunction, one of the two big ideas of separation logic *)
  Definition star (p q : hprop) : hprop :=
    fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

  (* Existential quantification *)
  Definition exis A (p : A -> hprop) : hprop :=
    fun h => exists x, p x h.

  (* Convenient notations *)
  Declare Scope sep_scope.
  Notation "[| P |]" := (lift P) : sep_scope.
  Infix "*" := star : sep_scope.
  Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
  Delimit Scope sep_scope with sep.
  Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
  Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).

  Local Open Scope sep_scope.

  Lemma iff_two : forall A (P Q : A -> Prop),
    (forall x, P x <-> Q x)
    -> (forall x, P x -> Q x) /\ (forall x, Q x -> P x).
  Proof.
    firstorder.
  Qed.

  Local Ltac t := (unfold himp, heq, lift, star, exis; propositional; subst);
                 repeat (match goal with
                         | [ H : forall x, _ <-> _ |- _  ] =>
                           apply iff_two in H
                         | [ H : ex _ |- _ ] => destruct H
                         | [ H : split _ _ $0 |- _ ] => apply split_empty_fwd in H
                         end; propositional; subst); eauto 15.

  Theorem himp_heq : forall p q, p === q
                               <-> (p ===> q /\ q ===> p).
  Proof.
    t.
  Qed.

  Theorem himp_refl : forall p, p ===> p.
  Proof.
    t.
  Qed.

  Theorem himp_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_left : forall p (Q : Prop) r,
    (Q -> p ===> r)
    -> p * [| Q |] ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_right : forall p q (R : Prop),
    p ===> q
    -> R
    -> p ===> q * [| R |].
  Proof.
    t.
  Qed.

  Local Hint Resolve split_empty_bwd' : core.

  Theorem extra_lift : forall (P : Prop) p,
    P
    -> p === [| P |] * p.
  Proof.
    t.
    apply split_empty_fwd' in H1; subst; auto.
  Qed.

  Theorem star_comm : forall p q, p * q === q * p.
  Proof.
    t.
  Qed.

  Theorem star_assoc : forall p q r, p * (q * r) === (p * q) * r.
  Proof.
    t.
  Qed.

  Theorem star_cancel : forall p1 p2 q1 q2, p1 ===> p2
    -> q1 ===> q2
    -> p1 * q1 ===> p2 * q2.
  Proof.
    t.
  Qed.

  Theorem exis_gulp : forall A p (q : A -> _),
    p * exis q === exis (fun x => p * q x).
  Proof.
    t.
  Qed.

  Theorem exis_left : forall A (p : A -> _) q,
    (forall x, p x ===> q)
    -> exis p ===> q.
  Proof.
    t.
  Qed.

  Theorem exis_right : forall A p (q : A -> _) x,
    p ===> q x
    -> p ===> exis q.
  Proof.
    t.
  Qed.

  Theorem emp_heap : forall h, lift True h -> h = $0.
  Proof.
    t.
  Qed.
End Sep.

(* Instantiate our big automation engine to these definitions. *)
Module Import Se := SepCancel.Make(Sep).
Export Sep Se.

(* ** Some extra predicates outside the set that the engine knows about *)

(* These are exactly the same as before, too! *)

(* Capturing single-mapping heaps *)
Definition heap1 (a v : nat) : heap := $0 $+ (a, v).
Definition ptsto (a v : nat) : hprop :=
  fun h => h = heap1 a v.

Theorem try_ptsto_first : forall a v, try_me_first (ptsto a v).
Proof.
  simplify.
  apply try_me_first_easy.
Qed.

Global Hint Resolve try_ptsto_first : core.

(* Helpful notations, some the same as above *)
Notation "[| P |]" := (lift P) : sep_scope.
Notation emp := (lift True).
Infix "*" := star : sep_scope.
Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
Delimit Scope sep_scope with sep.
Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).
Infix "|->" := ptsto (at level 30) : sep_scope.

Fixpoint multi_ptsto (a : nat) (vs : list nat) : hprop :=
  match vs with
  | nil => emp
  | v :: vs' => a |-> v * multi_ptsto (a + 1) vs'
  end%sep.

Infix "|-->" := multi_ptsto (at level 30) : sep_scope.

Fixpoint zeroes (n : nat) : list nat :=
  match n with
  | O => nil
  | S n' => zeroes n' ++ 0 :: nil
  end.

Fixpoint allocated (a n : nat) : hprop :=
  match n with
  | O => emp
  | S n' => (exists v, a |-> v) * allocated (a+1) n'
  end%sep.

Infix "|->?" := allocated (at level 30) : sep_scope.

(** * Finally, the Hoare logic *)

(* The only change we make here is in the loop rule. *)

Inductive hoare_triple : forall {result}, assertion -> cmd result -> (result -> assertion) -> Prop :=
(* First, some basic rules that look exactly the same as before *)
| HtReturn : forall P {result : Set} (v : result),
    hoare_triple P (Return v) (fun r => P * [| r = v |])%sep
| HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
    hoare_triple P c1 Q
    -> (forall r, hoare_triple (Q r) (c2 r) R)
    -> hoare_triple P (Bind c1 c2) R

(* THIS RULE IS DIFFERENT. *)
| HtLoop : forall {acc res : Set} (init : acc) (body : acc -> cmd (loop_outcome acc res)) P Q,
    (* As before, the premise forces us to consider any accumulator at the start
     * of a loop iteration, proving a Hoare triple for each case. *)
    (forall acc,
        (* Important difference: now the rule is parameterized over both a
         * precondition [P] and a postcondition [Q], each of which takes, as an
         * extra argument, the latest accumulator value. *)
        hoare_triple (P acc) (body acc)
                     (fun r =>
                        match r with
                        | Done res =>
                          Q acc res
                          (* The loop is done?  Then the postcondition had
                           * better be satisfied directly.  Note that it takes
                           * the "before" and "after" accumulators as arguments.
                           * We'll see shortly why that pays off.... *)
                        | Again acc' =>
                          (* It's time for more iterations?  Then we'd better
                           * satisfy [P] w.r.t. the "after" accumulator, but
                           * with a twist.  We are allowed to *forget* some
                           * state, captured by the arbitrary frame predicate
                           * [R].  The idea is that the state we shunt into [R]
                           * will not be touched again until the loop finishes
                           * running. *)
                          exists R, P acc' * R
                                    (* There is another important requirement on
                                     * [R]: Assume that the loop finishes, so
                                     * that the postcondition [Q] is satisfied
                                     * w.r.t. the new accumulator [acc'].  If we
                                     * *put back* [R], we should then arrive at
                                     * a state where the postcondition is
                                     * satisfied w.r.t. the "before" accumulator
                                     * [acc]! *)
                                    * [| forall r, Q acc' r * R ===> Q acc r |]
                        end%sep))
    -> hoare_triple (P init) (Loop init body) (Q init)
(* All that may be a bit abstract, but we will soon show an example
 * verification, to illustrate. *)

| HtFail : forall {result},
    hoare_triple (fun _ => False) (Fail (result := result)) (fun _ _ => False)

| HtRead : forall a R,
    hoare_triple (exists v, a |-> v * R v)%sep (Read a) (fun r => a |-> r * R r)%sep
| HtWrite : forall a v v',
    hoare_triple (a |-> v)%sep (Write a v') (fun _ => a |-> v')%sep
| HtAlloc : forall numWords,
    hoare_triple emp%sep (Alloc numWords) (fun r => [| r <> 0 |] * r |--> zeroes numWords)%sep
| HtFree : forall a numWords,
    hoare_triple (a |->? numWords)%sep (Free a numWords) (fun _ => emp)%sep

| HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
    hoare_triple P c Q
    -> P' ===> P
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P' c Q'
| HtFrame : forall {result} (c : cmd result) P Q R,
    hoare_triple P c Q
    -> hoare_triple (P * R)%sep c (fun r => Q r * R)%sep.

(* Now more duplicated infrastructure from class.  Feel free to skip ahead to
 * the example verification. *)

Notation "{{ P }} c {{ r ~> Q }}" :=
  (hoare_triple P%sep c (fun r => Q%sep))
    (at level 90, c at next level,
     format "'[hv' {{ P }} '/'  c  '/' {{ r  ~>  Q }} ']'").

Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
    hoare_triple P c Q
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P c Q'.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

Lemma HtWeaken : forall {result} (c : cmd result) P Q (P' : assertion),
    hoare_triple P c Q
    -> P' ===> P
    -> hoare_triple P' c Q.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

(* Fancy theorem to help us rewrite within preconditions and postconditions *)
Global Instance hoare_triple_morphism : forall A,
  Proper (heq ==> eq ==> (eq ==> heq) ==> iff) (@hoare_triple A).
Proof.
  Transparent himp.
  repeat (hnf; intros).
  unfold pointwise_relation in *; intuition subst.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.
Qed.

Global Opaque heq himp lift star exis ptsto.

Theorem use_lemma : forall result P' (c : cmd result) (Q : result -> assertion) P R,
  hoare_triple P' c Q
  -> P ===> P' * R
  -> hoare_triple P c (fun r => Q r * R)%sep.
Proof.
  simp.
  eapply HtWeaken.
  eapply HtFrame.
  eassumption.
  eauto.
Qed.

Theorem HtRead' : forall a v,
  hoare_triple (a |-> v)%sep (Read a) (fun r => a |-> v * [| r = v |])%sep.
Proof.
  simp.
  apply HtWeaken with (exists r, a |-> r * [| r = v |])%sep.
  eapply HtStrengthen.
  apply HtRead.
  simp.
  cancel; auto.
  subst; cancel.
Qed.

Theorem HtRead'' : forall p P R,
  P ===> (exists v, p |-> v * R v)
  -> hoare_triple P (Read p) (fun r => p |-> r * R r)%sep.
Proof.
  simp.
  eapply HtWeaken.
  apply HtRead.
  assumption.
Qed.

Lemma HtReturn' : forall P {result : Set} (v : result) Q,
    P ===> Q v
    -> hoare_triple P (Return v) Q.
Proof.
  simp.
  eapply HtStrengthen.
  constructor.
  simp.
  cancel.
  subst. assumption.
Qed.

Ltac basic := apply HtReturn' || eapply HtWrite || eapply HtAlloc || eapply HtFree.

Ltac step0 := basic || eapply HtBind || (eapply use_lemma; [ basic | cancel; auto ])
              || (eapply use_lemma; [ eapply HtRead' | solve [ cancel; auto ] ])
              || (eapply HtRead''; solve [ cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ basic | cancel; auto ] | ])
              || (eapply HtConsequence; [ apply HtFail | .. ]).
Ltac step := step0; simp.
Ltac ht := simp; repeat step.
Ltac conseq := simplify; eapply HtConsequence.
Ltac use_IH H := conseq; [ apply H | .. ]; ht.
Ltac loop_inv0 P0 Q0 := eapply HtConsequence; [ apply HtLoop with (P := P0) (Q := Q0) | .. ].
Ltac loop_inv P0 Q0 := loop_inv0 P0 Q0; ht.
Ltac use H := (eapply use_lemma; [ eapply H | cancel; auto ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ eapply H | cancel; auto ] | ]).

Ltac heq := intros; apply himp_heq; split.

(* Some lemmas that may or may not be useful. *)

Lemma star_emp_l P :
  emp * P === P.
Proof.
  heq; cancel.
Qed.

Lemma star_emp_r P :
  P * emp === P.
Proof.
  heq; cancel.
Qed.

(** * Binary trees *)

(* Now we define binary trees and ask you to verify two of their classic
 * operations. *)

Inductive tree :=
| Leaf
| Node (l : tree) (x : nat) (r : tree).

(* [m] for memory! *)
Fixpoint mtree' (t : tree) (p : nat) : hprop :=
  match t with
  | Leaf => [| p = 0 |]
  | Node l x r => [| p <> 0 |]
                  * exists p1 p2, p |--> [p1; x; p2]
                                  * mtree' l p1
                                  * mtree' r p2
  end%sep.

(* Here's the version that forgets exactly which tree it is. *)
Definition mtree (p : nat) : hprop :=
  (exists t, mtree' t p)%sep.

(* And here's an extra layer of indirection: a mutable pointer to a tree, which
 * comes in handy for operations that modify the tree. *)
Definition mtreep (p : nat) : hprop :=
  (exists p', [| p <> 0 |] * p |-> p' * mtree p')%sep.

(* Here's the usual lookup operation. *)
Definition lookup (x p : nat) :=
  t <- Read p; (* First peel away the initial layer of indirection.
                * You will want to use the regular old frame rule to forget
                * about some of the state that you won't need after this
                * point! *)
  for a := t loop
    (* The accumulator tells us: the node of the tree we have reached
     * (for [Again]) or whether the key [x] has been found (for [Done]). *)
    if a ==n 0 then
      (* Oh, the pointer is null.  Sorry, didn't find [x]. *)
      Return (Done false)
    else
      (* Read the data value of the current node (which must be nonnull). *)
      y <- Read (a + 1);
      if x ==n y then
        (* Found it! *)
        Return (Done true)
      else if x <=? y then
        (* The key must be earlier in the tree.  Read the left-child pointer and
         * continue looping with it. *)
        l <- Read a;
        Return (Again l)
      else
        (* The key must be later in the tree.  Read the right-child pointer and
         * continue looping with it. *)
        r <- Read (a + 1 + 1);
        (* Why [+ 1 + 1] instead of [+ 2]?  It happens to work better with the
         * automation we're using. ;) *)
        Return (Again r)
  done.

(* And here's the operation to add a new key to a tree. *)
Definition insert (x p : nat) :=
  for a := p loop
    (* Note that now the accumulator is not the latest tree root, but instead
     * *a pointer to it*, so that we may overwrite that pointer if necessary.
     * We start by reading the actual root out of the pointer [p]. *)
    q <- Read a;
    if q ==n 0 then
      (* It's a null pointer?  Perfect.  This is the spot to insert a new
       * node. *)
      node <- Alloc 3;
      (* Initialize its data field with [x]. *)
      _ <- Write (node + 1) x;
      (* Redirect the pointer [p] to the new node. *)
      _ <- Write a node;
      Return (Done tt)
    else
      (* Nonnull?  Read the data field into [y]. *)
      y <- Read (q + 1);
      if x <=? y then
        (* The right spot to insert must be to the left.  Recurse thataway. *)
        Return (Again q)
      else
        (* The right spot to insert must be to the right.  Recurse thataway. *)
        Return (Again (q + 1 + 1))
  done.

(* Something very subtle happened in that loop: we iterated using a pointer into
 * *the interior of a struct*, in each branch of the last [if]!  This is a fun
 * example of the kinds of tricks that can be played in a low-level language,
 * and the verification techniques are up to the challenge. *)

(* Your task: verify the two methods.  (By the way, our solution also includes a
 * soundness proof for this logic, but we aren't asking you to write one.)
 *
 * IMPORTANT NOTE:
 * The difficulty of this problem set is scoped assuming you will use the
 * tactics included in this file, which are very similar to the ones from
 * Lecture 18!  Trying to attack these proofs from first principles will likely
 * lead to proof size spiraling out of control.  The main ingredients you should
 * expect to reuse are:
 *  - [step]: A tactic to choose the right Hoare-logic rule to apply next, when
 *    your goal is a Hoare triple
 *  - [cancel]: A tactic to prove an implication between two separation-logic
 *    assertions, or reduce it to a simpler implication by *cancel*ing matching
 *    subformulas; before calling [cancel], be sure you have marked [Opaque]
 *    all of the predicates standing for data structures!  There is an
 *    [Opaque mtree] command in Pset10.v for precisely this reason; don't
 *    remove it, and put any lemmas about this predicate before it.
 *  - [heq]: A tactic to reduce a separation-logic assertion equivalence (using
 *    [===]) to two implications (using [===>])
 *  - [loop_inv P0 Q0]: A tactic to apply the loop rule, given an invariant
 *    split in a peculiar way; see above for an example
 *  - [setoid_rewrite H]: A tactic to rewrite within a separation-logic
 *    implication, using an equivalence that applies to one of its subterms
 *
 * Our solution also has a few direct uses of rules [HtConsequence] and
 * [HtFrame], sometimes using the [with] syntax of [apply] to specify values
 * for some variables that appear in these rules' statements. In particular,
 * you can use [HtConsequence] before [HtFrame] to ensure that the predicate
 * that you want to frame out is in the desired syntactic position so that
 * [HtFrame] will apply. The [exis_right] lemma will also be handy, as used
 * in the example included in Pset10.v. *)
Module Type S.
  (* Confirm that [lookup] has no memory errors and that [p] still points to
   * some binary tree once [lookup] has completed. Note that this theorem is
   * very similar to [llength_ok]. We encourage you to adapt that proof to
   * this one.
   *)
  (*[40%]*) Axiom lookup_ok : forall x p,
    {{ mtreep p }}
      lookup x p
    {{ _ ~> mtreep p }}.

  (* Confirm that [insert] has no memory errors and preserves the binary
   * tree structure pointed to by [p].
   *)
  (*[60%]*) Axiom insert_ok : forall x p,
    {{ mtreep p }}
      insert x p
    {{ _ ~> mtreep p }}.
End S.

(* For an extra challenge, you might try implementing and verifying deletion. *)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e224m2e96p1_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Module Type ELEM.
  Parameter A : Set.
  Parameter x : A.
End ELEM.

Module Nat.
    Definition A := nat.
    Definition x := 0.
End Nat.

Module List (X: ELEM).
  Inductive list : Set :=
    | nil : list
    | cons : X.A -> list -> list.

  Definition head (l : list) := match l with
                                | nil => X.x
                                | cons x _ => x
                                end.

  Definition singl (x : X.A) := cons x nil.

  Lemma head_singl : forall x : X.A, head (singl x) = x.
  auto.
  Qed.

End List.

Module N := List Nat.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e450m2e225m1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e448m2e224m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(** **********************************************************

Contents:

- Derivation of Generalized Iteration in Mendler-style
  Instantiation to a special case, Specialized
- Mendler Iteration Proof of a fusion law à la Bird-Paterson
  (Generalised folds for nested datatypes, theorem 1) for
  Generalized Iteration in Mendler-style

This file differs from GenMendlerIteration.v in the hypotheses.
Here we use omega cocontinuity instead of Kan extensions.

Written by: Anders Mörtberg, 2016.
Based on a note by Ralph Matthes.

************************************************************)

Require Export UniMath.Tactics.EnsureStructuredProofs.
Require Import UniMath.Foundations.PartD.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.Adamek.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op").
Local Notation "↓ f" := (mor_from_algebra_mor _ _ _ f) (at level 3, format "↓ f").
Local Notation "'chain'" := (diagram nat_graph).

(** Goal: derive Generalized Iteration in Mendler-style and a fusion law *)

(** * Generalized Iteration in Mendler-style *)
Section GenMenIt.

Context {C : category} (IC : Initial C)
        (CC : Colims_of_shape nat_graph C) (F : functor C C)
        (HF : is_omega_cocont F).

Local Notation "0" := (InitialObject IC).

Let AF : category := FunctorAlg F.
Let chnF : chain C := initChain IC F.
Let μF_Initial : Initial AF := colimAlgInitial IC HF (CC chnF).
Let μF : C := alg_carrier _ (InitialObject μF_Initial).
Let inF : C⟦F μF,μF⟧ := alg_map _ (InitialObject μF_Initial).
Let e : ∏ (n : nat), C⟦iter_functor F n IC,μF⟧ := colimIn (CC chnF).
Let cocone_μF : cocone chnF μF := colimCocone (CC chnF).

Local Lemma e_comm (n : nat) : e (S n) = # F (e n) · inF.
Proof.
apply pathsinv0,
      (colimArrowCommutes (make_ColimCocone _ _ _ (HF _ _ _
                          (isColimCocone_from_ColimCocone (CC chnF))))).
Qed.

Context {D : category}.

Section the_iteration_principle.

Variables (X : D) (L : functor C D) (IL : isInitial D (L 0)) (HL : is_omega_cocont L).

Let ILD : Initial D := tpair _ _ IL.
Local Notation "'L0'" := (InitialObject ILD).

Let Yon : functor D^op HSET := yoneda_objects D X.

Definition ψ_source : functor C^op HSET := functor_composite (functor_opp L) Yon.
Definition ψ_target : functor C^op HSET := functor_composite (functor_opp F) ψ_source.

Section general_case.

Variable (ψ : ψ_source ⟹ ψ_target).

Let LchnF : chain D := mapchain L chnF.
Let z : D⟦L0,X⟧ := InitialArrow ILD X.

Local Definition Pow_source : functor C^op HSET := ψ_source.
Local Definition Pow_target (n : nat) : functor C^op HSET :=
  functor_composite (functor_opp (iter_functor F n)) ψ_source.

Local Definition Pow (n : nat) : Pow_source ⟹ Pow_target n.
Proof.
induction n as [|n Pown].
- apply nat_trans_id.
- apply (nat_trans_comp Pown (pre_whisker (functor_opp (iter_functor F n)) ψ)).
Defined.

Local Lemma Pow_cocone_subproof n :
  dmor LchnF (idpath (S n)) · pr1 (Pow (S n)) IC z = pr1 (Pow n) IC z.
Proof.
induction n as [|n IHn].
+ cbn.
  apply (InitialArrowUnique ILD).
+ change (pr1 (Pow (S (S n))) _ z) with (ψ (iter_functor F (S n) 0) (Pow (S n) _ z)).
  assert (H : dmor LchnF (idpath (S (S n))) · ψ ((iter_functor F (S n)) IC) ((Pow (S n)) IC z) =
              ψ (iter_functor F n 0) (dmor LchnF (idpath (S n)) · pr1 (Pow (S n)) _ z)).
  { apply pathsinv0, (eqtohomot (nat_trans_ax ψ _ _ (dmor chnF (idpath (S n))))). }
  now rewrite H, IHn.
Qed.

Local Definition Pow_cocone : cocone LchnF X.
Proof.
use make_cocone.
- intro n.
  apply (pr1 (Pow n) _ z).
- abstract (intros n m k; induction k; apply Pow_cocone_subproof).
Defined.

Local Definition CC_LchnF : ColimCocone LchnF.
Proof.
use make_ColimCocone.
- apply (L μF).
- apply (mapcocone L _ cocone_μF).
- apply HL, (isColimCocone_from_ColimCocone (CC chnF)).
Defined.

Definition preIt : D⟦L μF,X⟧ := colimArrow CC_LchnF X Pow_cocone.

Local Lemma eqSS n : # L (e n) · preIt = Pow n IC z.
Proof.
apply (colimArrowCommutes CC_LchnF).
Qed.

Local Lemma is_z_iso_inF : is_z_isomorphism inF.
Proof.
(* Use Lambek's lemma, this could be extracted from the concrete proof as well *)
apply initialAlg_is_z_iso, pr2.
Defined.

Let inF_z_iso : z_iso (F μF) μF := make_z_iso' _ is_z_iso_inF.
Let inF_inv : C⟦μF,F μF⟧ := inv_from_z_iso inF_z_iso.

(* The direction * -> ** *)
Lemma S_imp_SS h n : # L inF · h = ψ μF h → # L (e n) · h = Pow n IC z.
Proof.
intros Hh.
induction n.
- cbn.
  apply (InitialArrowUnique ILD).
- rewrite e_comm, functor_comp, <- assoc, Hh.
  assert (H : # L (# F (e n)) · ψ μF h = ψ (iter_functor F n 0) (# L (e n) · h)).
  { apply pathsinv0, (eqtohomot (nat_trans_ax ψ _ _ (e n))). }
  now rewrite H, IHn.
Qed.

(* The direction ** -> * *)
Local Lemma SS_imp_S (H : ∏ n, # L (e n) · preIt = Pow n IC z) : # L inF · preIt = ψ μF preIt.
Proof.
assert (H'' : # L inF · # L inF_inv = identity _).
{ rewrite <- functor_comp,  <- functor_id.
   apply maponpaths, (z_iso_inv_after_z_iso inF_z_iso). }
assert (H' : ∏ n, # L (e (S n)) · # L inF_inv · ψ μF preIt = pr1 (Pow (S n)) _ z).
{ intro n.
  rewrite e_comm, functor_comp.
  etrans;
   [apply cancel_postcomposition; rewrite <-assoc;  apply maponpaths, H''|].
  rewrite id_right.
  assert (H1 : # L (# F (e n)) · ψ μF preIt = ψ (iter_functor F n 0) (# L (e n) · preIt)).
  { apply pathsinv0, (eqtohomot (nat_trans_ax ψ _ _ (e n))). }
  etrans; [ apply H1|].
  now rewrite H.
}
assert (HH : preIt = # L inF_inv · ψ μF preIt).
{ apply pathsinv0, (colimArrowUnique CC_LchnF); simpl; intro n.
  destruct n.
  - apply (InitialArrowUnique ILD).
  - simpl; etrans; [| apply H'].
    now apply assoc.
}
etrans; [ apply maponpaths, HH|].
now rewrite assoc, H'', id_left.
Qed.

Lemma preIt_ok : # L inF · preIt = ψ μF preIt.
Proof.
now apply SS_imp_S; intro n; apply eqSS.
Qed.

Lemma preIt_uniq (t : ∑ h, # L inF · h = ψ μF h) : t = (preIt,,preIt_ok).
Proof.
apply subtypePath; [intros f; apply homset_property|]; simpl.
destruct t as [f Hf]; simpl.
apply (colimArrowUnique CC_LchnF); intro n.
now apply S_imp_SS, Hf.
Qed.

Theorem GenMendlerIteration : ∃! (h : L μF --> X), #L inF · h = ψ μF h.
Proof.
use tpair.
- apply (preIt,,preIt_ok).
- exact preIt_uniq.
Defined.

Definition It : L μF --> X := pr1 (pr1 GenMendlerIteration).

Lemma It_is_preIt : It = preIt.
Proof.
apply idpath.
Qed.

End general_case.

(** * Specialized Mendler Iteration *)
Section special_case.

Variables (G : functor D D) (ρ : G X --> X).
Variables (θ : functor_composite F L ⟹ functor_composite L G).

Lemma is_nat_trans_ψ_from_comps :
        is_nat_trans ψ_source ψ_target
          (λ A (f : yoneda_objects_ob D X (L A)), θ A · # G f · ρ).
Proof.
intros A B h; apply funextfun; intro f; cbn.
rewrite functor_comp, !assoc.
assert (θ_nat_trans_ax := nat_trans_ax θ); simpl in θ_nat_trans_ax.
now rewrite <- θ_nat_trans_ax.
Qed.

Definition ψ_from_comps : ψ_source ⟹ ψ_target.
Proof.
use tpair.
- intros A f.
  exact (θ A · #G f · ρ).
- apply is_nat_trans_ψ_from_comps.
Defined.

Definition SpecialGenMendlerIteration :
  ∃! (h : L μF --> X), # L inF · h = θ μF · #G h · ρ
    := GenMendlerIteration ψ_from_comps.

End special_case.
End the_iteration_principle.

(** * Fusion law for Generalized Iteration in Mendler-style *)
Section fusion_law.

Variables (X X' : D).

Let Yon : functor D^op HSET := yoneda_objects D X.
Let Yon' : functor D^op HSET := yoneda_objects D X'.

Variables (L : functor C D) (HL : is_omega_cocont L) (IL : isInitial D (L 0)).
Variables (ψ : ψ_source X L ⟹ ψ_target X L).

Variables (L' : functor C D) (HL' : is_omega_cocont L') (IL' : isInitial D (L' 0)).
Variables (ψ' : ψ_source X' L' ⟹ ψ_target X' L').

Variables (Φ : functor_composite (functor_opp L) Yon ⟹ functor_composite (functor_opp L') Yon').

Variables (H : ψ μF · Φ (F μF) = Φ μF · ψ' μF).

Theorem fusion_law : Φ μF (It X L IL HL ψ) = It X' L' IL' HL' ψ'.
Proof.
apply path_to_ctr.
assert (Φ_is_nat := nat_trans_ax Φ).
assert (Φ_is_nat_inst1 := Φ_is_nat _ _ inF).
assert (Φ_is_nat_inst2 := eqtohomot Φ_is_nat_inst1 (It X L IL HL ψ)).
unfold compose in Φ_is_nat_inst2; simpl in Φ_is_nat_inst2.
simpl.
rewrite <- Φ_is_nat_inst2.
assert (H_inst :=  eqtohomot H (It X L IL HL ψ)).
unfold compose in H_inst; simpl in H_inst.
rewrite <- H_inst.
apply maponpaths.
rewrite It_is_preIt.
apply preIt_ok.
Qed.

End fusion_law.
End GenMenIt.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e450m2e225m1_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.