Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import bedrock2.string2ident.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Tactics.syntactic_unify.
Require Import Bedrock.Examples.felem_copy_64.
Require Import coqutil.Tactics.letexists.
Require Import Bedrock.Util.Tactics.
Require Import Bedrock.Util.Word.
Require Import bedrock2.Lift1Prop.
Require Import coqutil.Map.Properties.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.ptsto_bytes.
Require Import coqutil.Datatypes.HList.
Require Import coqutil.Byte.
Require Import Bedrock.Util.Bignum.
Require Import Bedrock.Util.Tactics.
Require Import Bedrock.Util.Bignum.
Require Import Bedrock.Util.Util.
Local Open Scope Z_scope.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults32.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Local Open Scope string_scope.
Import ListNotations.
Require Import bedrock2.NotationsCustomEntry.
(* Require Import bedrock2.NotationsInConstr. *)
Require Import bedrock2.Syntax.
(* Local Open Scope bedrock_expr. *)
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults32.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Require Import Coq.ZArith.ZArith.
(* Require Import bedrock2.NotationsInConstr. *)
Require Import bedrock2.Syntax.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import bedrock2.Semantics.
Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.ReifiedOperation.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Local Open Scope Z_scope.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.Spec.MxDH.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Translation.Parameters.SelectParameters.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import bedrock2.Semantics.

Require Import Theory.Fields.QuadraticFieldExtensions.

Require Import Bedrock.Field.bls12prime.
Require Import Theory.WordByWordMontgomery.MontgomeryRingTheory.

Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.
Section Spec.

Local Open Scope Z_scope.

(*Parameters to be changed: specify prime and import reification from cache.*)
    Local Notation m := bls12prime.m.
    Local Definition prefix := "bls12_"%string. (* placed before function names *)

    Require Import Bedrock.Field.bls12prime.

    Existing Instances Defaults64.default_parameters bls12_bedrock2_funcs
    bls12_bedrock2_specs bls12_bedrock2_correctness.
(*  We require that the prime specified here is the same that was used for reification:
    Change names to match reification cache.*)
(*  We instantiate specs of all imported bedrock2 functions.
    This needs to be done for typeclass inference to work properly.*)

  Instance spec_of_reified_mul :
  spec_of (append prefix "mul") := spec_of_mul.

  Instance spec_of_reified_square :
  spec_of (append prefix "square") := spec_of_square.

  Instance spec_of_reified_add :
  spec_of (append prefix "add") := spec_of_add.

  Instance spec_of_reified_sub :
  spec_of (append prefix "sub") := spec_of_sub.

  Instance spec_of_reified_opp :
  spec_of (append prefix "opp") := spec_of_opp.

  Instance spec_of_reified_to_montgomery :
  spec_of (append prefix "to_montgomery") := spec_of_to_montgomery.

  Instance spec_of_reified_from_montgomery :
  spec_of (append prefix "from_montgomery") := spec_of_from_montgomery.

  Instance spec_of_reified_nonzero :
  spec_of (append prefix "nonzero") := spec_of_nonzero.

  Instance spec_of_reified_selectznz :
  spec_of (append prefix "selectznz") := spec_of_selectznz.

  Instance spec_of_reified_to_bytes :
  spec_of (append prefix "to_bytes") := spec_of_to_bytes.

  Instance spec_of_reified_from_bytes :
  spec_of (append prefix "from_bytes") := spec_of_from_bytes.
(*Instantiation done.*)

(*Initializing parameters; do not touch*)
Local Notation bw := (@width (semantics)).
Local Notation m' := (@WordByWordMontgomery.m' m bw).
Notation n := (WordByWordMontgomery.n m bw).
Local Notation eval := (@WordByWordMontgomery.eval bw n).
Local Notation valid := (@WordByWordMontgomery.valid bw n m).
Local Notation from_mont := (@WordByWordMontgomery.from_montgomerymod bw n m m').

Local Definition valid_words w := valid (List.map (@Interface.word.unsigned 64 Naive.word64) w).
Local Definition map_words := List.map (@Interface.word.unsigned 64 Naive.word64).
Local Notation r := (WordByWordMontgomery.r bw).
Local Notation r' := (WordByWordMontgomery.r' m bw).
Local Definition num_bytes := Eval compute in (Z.of_nat (((Z.to_nat bw * n) / 8)%nat)).
(* Local Notation word.add := (@word.add (@width)) *)

Local Notation evfst x := (eval (from_mont (fst x))).
Local Notation evsnd x := (eval (from_mont (snd x))).

Lemma r_equiv : r = MontgomeryRingTheory.r bw.
Proof.
  cbv. auto.
Qed.

Lemma r'_correct : (MontgomeryRingTheory.r bw * r') mod m = 1.
Proof. cbv; auto. Qed.

Lemma m'_correct : m * m' mod MontgomeryRingTheory.r bw = (-1) mod MontgomeryRingTheory.r bw.
Proof. cbv; auto. Qed.

Lemma bw_big : 0 < bw.
Proof. cbv; auto. Qed.

Lemma n_nz : n <> 0%nat.
Proof. cbv; intros; discriminate. Qed.

Lemma m_big : m < MontgomeryRingTheory.r bw ^ (Z.of_nat n).
Proof. cbv; auto. Qed.

Lemma m_small : 1 < m.
Proof. cbv; auto. Qed.

Local Notation valid_mod := (@valid_mod m bw n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).

Ltac postcondition_pre := repeat (split; [solve [reflexivity]| ]); repeat (
  lazymatch goal with
  | |- exists _, _ => eexists
  | _ => fail
  end); repeat ( split; [| ecancel_assumption]).

  Ltac copy_next R fR thism pX1 wX1 RX1 a H := straightline_call; [subst R; remember fR as thisP;
  eassert (thisH : ((fun m => (Bignum n pX1 wX1 * RX1)%sep m /\ thisP m) * Bignum n a _ * _)%sep thism) by (subst thisP; ecancel_assumption); subst thisP; apply thisH |]; clear H; repeat straightline.

Definition Fp2_add_Gallina_spec in1 in2 out :=
    valid (fst out) /\ valid (snd out) /\
    evfst out = (evfst in1 + evfst in2) mod m /\
    evsnd out = (evsnd in1 + evsnd in2) mod m.

Definition Fp2_sub_Gallina_spec in1 in2 out :=
  valid (fst out) /\ valid (snd out) /\
  evfst out = (evfst in1 - evfst in2) mod m /\
  evsnd out = (evsnd in1 - evsnd in2) mod m.

Definition Fp2_mul_Gallina_spec in1 in2 out :=
    valid (fst out) /\ valid (snd out) /\
    evfst out = (evfst in1 * evfst in2 - evsnd in1 * evsnd in2) mod m /\
    evsnd out = (evfst in1 * evsnd in2 + evfst in2 * evsnd in1) mod m.

Definition Fp2_square_Gallina_spec inp out :=
  valid (fst out) /\ valid (snd out) /\
  evfst out = ((evfst inp + evsnd inp) * (evfst inp - evsnd inp) ) mod m /\
  evsnd out = (2 * (evfst inp * evsnd inp)) mod m.

    (*Why let-bindings? Are they necessary?*)
  Definition Fp2_add : Syntax.func :=
  let outr := "outr" in
  let outi := "outi" in
  let xr := "xr" in
  let xi := "xi" in
  let yr := "yr" in
  let yi := "yi" in
  let add := (append prefix "add") in
  ("Fp2_add", (
    [outr; outi; xr; xi; yr; yi], [],
    bedrock_func_body:(
    add (outr, yr, xr);
    add (outi, yi, xi)
    )
  )).

  Definition Fp2_mul : Syntax.func :=
    let outr := "outr" in
    let outi := "outi" in
    let xr := "xr" in
    let xi := "xi" in
    let yr := "yr" in
    let yi := "yi" in
    let v0 := "v0" in
    let v1 := "v1" in
    let v2 := "v2" in
    let add := (append prefix "add") in
    let mul := (append prefix "mul") in
    let sub := (append prefix "sub") in
    ("Fp2_mul", (
      [outr; outi; xr; xi; yr; yi], [],
      bedrock_func_body:(
      stackalloc num_bytes as v0 {
        stackalloc num_bytes as v1 {
          stackalloc num_bytes as v2 {
            mul (v0, xr, yr);
            mul (v1, xi, yi);
            sub (outr, v0, v1);
            add (v2, xr, xi);
            add (outi, yr, yi);
            mul (outi, v2, outi);
            sub (outi, outi, v0);
            sub (outi, outi, v1)
          }
        }
      }
      )
    )).

  Definition Fp2_sub : Syntax.func :=
  let outr := "outr" in
  let outi := "outi" in
  let xr := "xr" in
  let xi := "xi" in
  let yr := "yr" in
  let yi := "yi" in
  let add := (append prefix "add") in
  ("Fp2_sub", (
    [outr; outi; xr; xi; yr; yi], [],
    bedrock_func_body:(
    sub (outr, xr, yr);
    sub (outi, xi, yi)
    )
  )).

  Definition Fp2_square : Syntax.func :=
    let outr := "outr" in
    let outi := "outi" in
    let inr := "inr" in
    let ini := "ini" in
    let v := "v" in
    let add := (append prefix "add") in
    let mul := (append prefix "mul") in
    let sub := (append prefix "sub") in
    ("Fp2_square", (
      [outr; outi; inr; ini], [],
      bedrock_func_body:(
        stackalloc num_bytes as v {
          add(v, inr, ini);
          sub(outr, inr, ini);
          mul(outr, outr, v);
          mul(outi, inr, ini);
          add(outi, outi, outi)
        }
      )
    )).

  Local Open Scope string_scope.
  Local Infix "*" := sep : sep_scope.
  Delimit Scope sep_scope with sep.

Instance spec_of_my_add: spec_of Fp2_add :=
fun functions : list (string * (list string * list string * cmd)) =>
    forall (wxr wxi wyr wyi : list Interface.word.rep)
    (pxr pxi pyr pyi poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rout : Interface.map.rep -> Prop),
    (*typeclass isntead of valid?*)
    valid (List.map Interface.word.unsigned wxr) /\
    valid (List.map Interface.word.unsigned wxi) /\
    valid (List.map Interface.word.unsigned wyr) /\
    valid (List.map Interface.word.unsigned wyi) ->
    (((Bignum n pxr wxr) ) *
    ((Bignum n pxi wxi) ) *
    ((Bignum n pyr wyr) ) *
    ((Bignum n pyi wyi) ) *
    (Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_add") t m0
    ([poutr; pouti; pxr; pxi; pyr; pyi])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep),
        (
                (Fp2_add_Gallina_spec (List.map Interface.word.unsigned wxr, List.map Interface.word.unsigned wxi)
                (List.map Interface.word.unsigned wyr, List.map Interface.word.unsigned wyi)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
                valid (List.map Interface.word.unsigned woutr) /\
                valid (List.map Interface.word.unsigned wouti)) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) * (Bignum n pxr wxr)
              * (Bignum n pxi wxi) * (Bignum n pyr wyr) * (Bignum n pyi wyi) * Rout)%sep m'))).

Instance spec_of_my_sub: spec_of Fp2_sub :=
fun functions : list (string * (list string * list string * cmd)) =>
    forall (wxr wxi wyr wyi : list Interface.word.rep)
    (pxr pxi pyr pyi poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rout : Interface.map.rep -> Prop),
    valid (List.map Interface.word.unsigned wxr) /\
    valid (List.map Interface.word.unsigned wxi) /\
    valid (List.map Interface.word.unsigned wyr) /\
    valid (List.map Interface.word.unsigned wyi) ->
    (((Bignum n pxr wxr) ) *
    ((Bignum n pxi wxi) ) *
    ((Bignum n pyr wyr) ) *
    ((Bignum n pyi wyi) ) *
    (Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_sub") t m0
    ([poutr; pouti; pxr; pxi; pyr; pyi])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep),
        (
                (Fp2_sub_Gallina_spec (List.map Interface.word.unsigned wxr, List.map Interface.word.unsigned wxi)
                (List.map Interface.word.unsigned wyr, List.map Interface.word.unsigned wyi)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
                valid (List.map Interface.word.unsigned woutr) /\
                valid (List.map Interface.word.unsigned wouti)) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) *
                (Bignum n pxr wxr) * (Bignum n pxi wxi) *
                (Bignum n pyr wyr) * (Bignum n pyi wyi) * Rout)%sep m'))).

Instance spec_of_my_mul: spec_of Fp2_mul :=
fun functions : list (string * (list string * list string * cmd)) =>
    forall (wxr wxi wyr wyi : list Interface.word.rep)
    (pxr pxi pyr pyi poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rout : Interface.map.rep -> Prop),
    valid (List.map Interface.word.unsigned wxr) /\
    valid (List.map Interface.word.unsigned wxi) /\
    valid (List.map Interface.word.unsigned wyr) /\
    valid (List.map Interface.word.unsigned wyi) ->
    (((Bignum n pxr wxr) ) *
    ((Bignum n pxi wxi) ) *
    ((Bignum n pyr wyr) ) *
    ((Bignum n pyi wyi) ) *
    (Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_mul") t m0
    ([poutr; pouti; pxr; pxi; pyr; pyi])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep) Routnew,
        (
                (Fp2_mul_Gallina_spec (List.map Interface.word.unsigned wxr, List.map Interface.word.unsigned wxi)
                (List.map Interface.word.unsigned wyr, List.map Interface.word.unsigned wyi)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
                valid (List.map Interface.word.unsigned woutr) /\
                valid (List.map Interface.word.unsigned wouti)) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) *
             (Bignum n pxr wxr) * (Bignum n pxi wxi) *
             (Bignum n pyr wyr) * (Bignum n pyi wyi) * Rout * Routnew)%sep m'))).

Instance spec_of_my_square: spec_of Fp2_square :=
fun functions : list (string * (list string * list string * cmd)) =>
    forall (winr wini : list Interface.word.rep)
    (pinr pini poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rout : Interface.map.rep -> Prop),
    valid (List.map Interface.word.unsigned winr) /\
    valid (List.map Interface.word.unsigned wini) ->
    (((Bignum n pinr winr) ) *
    ((Bignum n pini wini) ) *
    (Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_square") t m0
    ([poutr; pouti; pinr; pini])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep) Rout,
        (
                (Fp2_square_Gallina_spec (List.map Interface.word.unsigned winr, List.map Interface.word.unsigned wini)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) *
             (Bignum n pinr winr) * (Bignum n pini wini) * Rout)%sep m')))).

Theorem Fp2_add_ok: program_logic_goal_for_function! Fp2_add.
Proof.
    (*Initializing*)
    straightline_init_with_change.
    repeat straightline.

    (*first function call*)
    handle_call; [eauto ..|].
    (*Second function call*)
    handle_call; [eauto .. |].

    (*Prove Postcondition*)
    postcondition_pre.

    split; [split; [eauto| split; [eauto| split]]| split; eauto].
        + rewrite !Prod.fst_pair, Z.add_comm.
          apply valid_mod in H8. rewrite <- H8. assumption.
        + rewrite !Prod.snd_pair, Z.add_comm.
          apply valid_mod in H11. rewrite <- H11. assumption.
Qed.

Theorem Fp2_sub_ok: program_logic_goal_for_function! Fp2_sub.
Proof.
    (*Initializing*)
    straightline_init_with_change.
    repeat straightline.

    (*first function call*)
    handle_call; [eauto ..|].
    (*Second function call*)
    handle_call; [eauto .. |].

    (*Prove postcondition*)
    postcondition_pre.
    split; [split; [eauto| split; [eauto| split]]| split; eauto].
    - rewrite !Prod.fst_pair; apply valid_mod in H8; rewrite <- H8; assumption.
    - rewrite !Prod.snd_pair; apply valid_mod in H11; rewrite <- H11; assumption.
Qed.
(* Notation msplit := Interface.map.split. *)

Notation montsub a b c :=
  ((eval (from_mont (a))) mod m =
      (eval (from_mont (b)) -
       eval (from_mont (c))) mod m).

Notation montadd a b c :=
  ((eval (from_mont (a))) mod m =
      (eval (from_mont (b)) +
       eval (from_mont (c))) mod m).

Notation montmul a b c :=
  ((eval (from_mont (a))) mod m =
      (eval (from_mont (b)) *
       eval (from_mont (c))) mod m).

Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.

Lemma postcond_from_precond xr xi yr yi resr resi x1 x2 x3 x4 x5 x6:
  montsub resi x1 x2 -> valid resi -> valid x1 -> valid x2
  -> montsub x1 x3 x4 -> montmul x3 x5 x6 -> valid x3 -> valid x6
  -> montadd x6 yr yi -> valid x5 -> montadd x5 xr xi -> valid resr
  -> montsub resr x4 x2 -> montmul x2 xi yi -> valid x4 -> montmul x4 xr yr
  -> valid xr -> valid xi -> valid yr -> valid yi
-> Fp2_mul_Gallina_spec (xr, xi) (yr, yi) (resr, resi).
Proof.
  intros. unfold Fp2_mul_Gallina_spec.
  split; [auto|].
  split; [auto|]. split.
                    - rewrite !Prod.fst_pair, !Prod.snd_pair.
                      rewrite (valid_mod H10) in H11; rewrite H11.
                      rewrite (valid_mod H13) in H14; rewrite H14.
                      rewrite (valid_mod H2) in H12; rewrite H12.
                      rewrite <- Zminus_mod. reflexivity.
                    - rewrite !Prod.fst_pair, !Prod.snd_pair.
                      (*Put valid in type, try using congruence.*)
                      rewrite (valid_mod H0) in H; rewrite H.
                      rewrite (valid_mod H1) in H3; rewrite H3.
                      rewrite (valid_mod H5) in H4; rewrite H4.
                      rewrite (valid_mod H8) in H9; rewrite H9.
                      rewrite (valid_mod H6) in H7; rewrite H7.
                      rewrite (valid_mod H13) in H14; rewrite H14.
                      rewrite (valid_mod H2) in H12; rewrite H12.
                      rewrite <- Z.mul_mod; [| cbv; intros; discriminate].
                      remember (eval (from_mont xr)) as xr'.
                      remember (eval (from_mont yr)) as yr'.
                      remember (eval (from_mont xi)) as xi'.
                      remember (eval (from_mont yi)) as yi'.
                      pull_Zmod. apply (f_equal (fun y => (y mod m))). ring.
Qed.

Lemma numbytes_correct : 48 = Z.of_nat (n * Z.to_nat word_size_in_bytes).
Proof.
  auto.
Qed.

  Ltac straightline' H :=
    lazymatch goal with
    | [Hminit : ?mcond (?minit : @Interface.map.rep _ _ _)
        |- forall (_ : @word.rep _ _)
                  (_ _ : @Interface.map.rep _ _ _),
            anybytes _ ?numbytes _ -> msplit _ ?minit _ -> _ ] =>
        let a := (fresh "a") in
        let mStack := (fresh "mStack") in
        let mnew := (fresh "mnew") in
        let Hany := (fresh "Hany") in
        let HanyBignum := (fresh "HanyBignum") in
        let anyval := (fresh "anyval") in
        let Hsplit := (fresh "Hsplit") in
        let Hmnew := (fresh "Hmnew") in
        let R := (fresh "R") in
        intros a mStack mnew Hany Hsplit; destruct (anybytes_Bignum n mStack numbytes a H Hany) as [anyval HanyBignum];
        destruct (alloc_seps_alt mnew minit mStack mcond (Bignum _ _ _) Hsplit (empty_frame mcond minit Hminit) (empty_frame (Bignum _ _ _) mStack HanyBignum)) as [R Hmnew];
        clear Hany Hsplit HanyBignum
    | _ => straightline
    end.

    Ltac defrag_in_context := lazymatch goal with
| [
    |- exists (_ _ : @Interface.map.rep _ _ _),
      (anybytes ?addr _ _) /\ (msplit ?mem _ _) /\ _ ] =>
      repeat lazymatch goal with
      | [ H : (?Rl * ((Bignum _ addr ?aval) * ?Rr))%sep mem |- _ ] =>
        let Ha := (fresh "Ha") in
        let m := fresh "m" in
        let mStack := fresh "mStack" in
        assert (Ha : ((Bignum n addr aval) * (Rl * Rr))%sep mem) by ecancel_assumption;
        destruct Ha as [mStack [m [? []]]];
        exists m; exists mStack; split; [ eapply Bignum_anybytes; [apply numbytes_correct |eassumption] | split; [apply Properties.map.split_comm; auto|]]
      | [ H : (((Bignum _ addr ?aval) * ?Rr))%sep mem |- _ ] =>
        let Ha := (fresh "Ha") in
        let m := fresh "m" in
        let mStack := fresh "mStack" in
        assert (Ha : ((Bignum n addr aval) * (Rr))%sep mem) by ecancel_assumption;
        destruct Ha as [mStack [m [? []]]];
        exists m; exists mStack; split; [ eapply Bignum_anybytes; [apply numbytes_correct |eassumption] | split; [apply Properties.map.split_comm; auto|]]

      | [ H : _ mem |- _ ] => apply (sep_assoc_proj2 mem) in H
      end
end.

Ltac defrag_in_context' := lazymatch goal with
| [
    |- exists (_ _ : @Interface.map.rep _ _ _),
      (anybytes ?addr _ _) /\ (msplit ?mem _ _) /\ _ ] =>
      match goal with
      | [ H : _ mem |- _ ] => cleanup_hyp H mem
      end
    end; defrag_in_context.

  Lemma Bignum_eq: forall x p, Bignum n p x = (emp (Datatypes.length x = n) * array Scalars.scalar (word.of_Z word_size_in_bytes) p x)%sep.
Proof. auto. Qed.

Theorem Fp2_mul_ok: program_logic_goal_for_function! Fp2_mul.
Proof.
  (*Handle parts of function up until function calls.
    We use a modified version of Bedrock2's straightline tactic.
    This version  undoes the fragmentation of memory in the context
    done by stack allocation.*)
    repeat (straightline' numbytes_correct).
    (*Handle function calls.
    Note that the use of the "auto" tactic here is to handle preconditions af callees.
    In this case auto is sufficient, but for more complicated function calls
    this should be done manually.*)
    repeat (handle_call; [auto| auto| ]).

  (*Fragmentation of the memory after function body is necessary for stack allocation
    to ensure that output and intermediate variables are stored correctly in memory
    TODO: find a better name for this tactic.*)
    cleanup_hyp H28 a5.
    repeat defrag_in_context'.

    (* Handle parts of function up until proving the postcondition*)
    repeat (straightline' numbytes_correct).

  (*Postcondition is proved. Trivial subgoals are handled by tactic postcondition_pre*)
    postcondition_pre.
    split; [split; [eauto| split; [eauto|]]| split; eauto].

  (*We have proved that the Gallina specification is met in a separate lemma: postcond_from_precond.
    A more natural approach would be to prove the precondition directly here.
    We use a lemma to illustrate the fact that proving the non-Bedrock2 specific parts of
    the postcondition is separated from the Bedrock2 specific parts, which are mostly automated.*)
  apply (postcond_from_precond (map word.unsigned wxr) (map word.unsigned wxi) (map word.unsigned wyr) (map word.unsigned wyi) (map word.unsigned x1) (map word.unsigned x6)
  (map word.unsigned x5) (map word.unsigned x0) (map word.unsigned x4) (map word.unsigned x)
  (map word.unsigned x2) (map word.unsigned x3)
  ); auto.
  Qed.

  Theorem Fp2_square_ok: program_logic_goal_for_function! Fp2_square.
  Proof.
    (*Handle parts of function up until function calls.
      We use a modified version of Bedrock2's straightline tactic.
      This version  undoes the fragmentation of memory in the context
      done by stack allocation.*)
    repeat (straightline' numbytes_correct).
    (*Handle function calls.
      Note that the use of the "auto" tactic here is to handle preconditions af callees.
      In this case auto is sufficient, but for more complicated function calls
      this should be done manually.*)
    repeat (handle_call; [auto| auto| ]).

    (*Fragmentation of the memory after function body is necessary for stack allocation
      to ensure that output and intermediate variables are stored correctly in memory
      TODO: find a better name for this tactic.*)
    repeat defrag_in_context'.

    (* Handle parts of function up until proving the postcondition*)
    repeat (straightline' numbytes_correct).

    (*Postcondition is proved
      reflexivity solves first part; which will always be the case when no complicated
      reasoning about separation logic is needed, i.e. when the seperating conjuction is
      used only as a means of referencing memory. *)
      postcondition_pre.

    (*Postcondition*)
    do 2 (split; [auto|]).
    split.
      - rewrite !Prod.snd_pair, !Prod.fst_pair.
        rewrite (valid_mod H12) in H9; rewrite H9.
        rewrite (valid_mod H8) in H5; rewrite H5.
        rewrite (valid_mod H10) in H7; rewrite H7.
        remember (eval (from_mont (map word.unsigned winr))) as inr.
        remember (eval (from_mont (map word.unsigned wini))) as ini.
        pull_Zmod; rewrite Z.mul_comm; reflexivity.
      - rewrite !Prod.snd_pair, !Prod.fst_pair.
        remember (eval (from_mont (map word.unsigned winr))) as inr.
        remember (eval (from_mont (map word.unsigned wini))) as ini.
        rewrite (valid_mod H18) in H16; rewrite H16.
        rewrite (valid_mod H15) in H13; rewrite H13.
        pull_Zmod. apply (f_equal (fun y => y mod Spec.m)). ring.
    Qed.

(*Lemmas*)
Notation N aw := (word.add (word.of_Z word_size_in_bytes) aw).

Lemma nval : n = 6%nat.
Proof. auto. Qed.

Lemma length_nil {A : Type} (l : list A) : length l = 0%nat -> l = [].
Proof.
  destruct l; auto; discriminate.
Qed.

Definition Fp2_add_alt2 : Syntax.func :=
  let outr := "outr" in
  let outi := "outi" in
  let xr := "xr" in
  let xi := "xi" in
  let yr := "yr" in
  let yi := "yi" in
  let xrsep := "xrsep" in
  let xisep := "xisep" in
  let yrsep := "yrsep" in
  let yisep := "yisep" in
  let add := (append prefix "add") in
  let felem_copy := ("felem_copy_64") in
  ("Fp2_add_alt2", (
    [outr; outi; xr; xi; yr; yi], [],
    bedrock_func_body:(
      stackalloc num_bytes as xrsep {
        stackalloc num_bytes as xisep {
          stackalloc num_bytes as yrsep {
            stackalloc num_bytes as yisep {
              (*Copies real part of first operand*)
              felem_copy (xrsep, xr);
              felem_copy (yrsep, yr);
              felem_copy (xisep, xi);
              felem_copy (yisep, yi);

              Fp2_add (outr, outi, xrsep, xisep, yrsep, yisep)
            }
          }
        }
      }
    )
  )).

Instance spec_of_my_add_alt2: spec_of Fp2_add_alt2 :=
fun functions : list (string * (list string * list string * Syntax.cmd)) =>
    forall (wxr wxi wyr wyi : list Interface.word.rep)
    (pxr pxi pyr pyi poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rxr Rxi Ryr Ryi Rout : Interface.map.rep -> Prop),
    (*typeclass isntead of valid?*)
    valid (List.map Interface.word.unsigned wxr) /\
    valid (List.map Interface.word.unsigned wxi) /\
    valid (List.map Interface.word.unsigned wyr) /\
    valid (List.map Interface.word.unsigned wyi) ->
    ((Bignum n pxr wxr) * Rxr)%sep m0 ->
    ((Bignum n pxi wxi) * Rxi)%sep m0 ->
    ((Bignum n pyr wyr) * Ryr)%sep m0 ->
    ((Bignum n pyi wyi) * Ryi)%sep m0 ->
    ((Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_add_alt2") t m0
    ([poutr; pouti; pxr; pxi; pyr; pyi])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep) Routnew,
        (
                (Fp2_add_Gallina_spec (List.map Interface.word.unsigned wxr, List.map Interface.word.unsigned wxi)
                (List.map Interface.word.unsigned wyr, List.map Interface.word.unsigned wyi)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
                valid (List.map Interface.word.unsigned woutr) /\
                valid (List.map Interface.word.unsigned wouti)) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) * Rout * Routnew)%sep m'))).

Ltac remember_sep_in_hyp H Hname :=
  lazymatch H with
  | ?R _ => remember R as Hname end.

(* Ltac pack_disj_hyps_4 H1 H2 H3 H4 H5 := *)

Theorem Fp2_add_alt2_okay: program_logic_goal_for_function! Fp2_add_alt2.
Proof.
  do 7 straightline' numbytes_correct.

  (*Assert single hypothesis for stackallocation.*)
  remember (Bignum n pxr wxr * Rxr)%sep as Rxr'.
  remember (Bignum n pyr wyr * Ryr)%sep as Ryr'.
  remember (Bignum n pxi wxi * Rxi)%sep as Rxi'.
  remember (Bignum n pyi wyi * Ryi)%sep as Ryi'.
  remember ((Bignum n poutr wold_outr * Bignum n pouti wold_outi * Rout)%sep) as Rout'.

  assert (
      id (fun m => (Rxr' m /\ Ryr' m /\ Rxi' m /\ Ryi' m /\ Rout' m)) m0).
  {
    cbv [id]. split; auto.
  }

  (*Allocate memory on stack. *)
  repeat straightline' numbytes_correct. clear H1 Hmnew Hmnew0 Hmnew1.
  repeat straightline' numbytes_correct. cbv [id] in *.

 (*Handle calls to felem_copy*)

  copy_next Rxr' (fun m => Ryr' m /\ Rxi' m /\ Ryi' m /\ Rout' m) mnew2 pxr wxr Rxr a Hmnew2.
  copy_next Ryr' (fun m => Rxi' m /\ Ryi' m /\ Rout' m) a4 pyr wyr Ryr a1 H15.
  copy_next Rxi' (fun m => Ryi' m /\ Rout' m) a6 pxi wxi Rxi a0 H15.
  copy_next Ryi' (fun m => Rout' m) a4 pyi wyi Ryi a2 H15.

 (*Handle function call*)
 repeat straightline.
 straightline_call.
 2:
 {
   assert (Hnumlimbs : n = num_limbs) by auto.
   repeat rewrite Hnumlimbs. repeat rewrite Hnumlimbs in H15. ecancel_assumption.
 }
 1: split; auto.

 (*Defragment memory in context after stack allocation. *)
 repeat straightline.
 repeat defrag_in_context'.

 (*Postcondition*)
 postcondition_pre.
 split; [auto| split; auto].
Qed.

Definition Fp2_sub_alt2 : Syntax.func :=
  let outr := "outr" in
  let outi := "outi" in
  let xr := "xr" in
  let xi := "xi" in
  let yr := "yr" in
  let yi := "yi" in
  let xrsep := "xrsep" in
  let xisep := "xisep" in
  let yrsep := "yrsep" in
  let yisep := "yisep" in
  let add := (append prefix "add") in
  let felem_copy := ("felem_copy_64") in
  ("Fp2_sub_alt2", (
    [outr; outi; xr; xi; yr; yi], [],
    bedrock_func_body:(
      stackalloc num_bytes as xrsep {
        stackalloc num_bytes as xisep {
          stackalloc num_bytes as yrsep {
            stackalloc num_bytes as yisep {
              (*Copies real part of first operand*)
              felem_copy (xrsep, xr);
              felem_copy (yrsep, yr);
              felem_copy (xisep, xi);
              felem_copy (yisep, yi);

              Fp2_sub (outr, outi, xrsep, xisep, yrsep, yisep)
            }
          }
        }
      }
    )
  )).

Instance spec_of_my_sub_alt2: spec_of Fp2_sub_alt2 :=
fun functions : list (string * (list string * list string * Syntax.cmd)) =>
    forall (wxr wxi wyr wyi : list Interface.word.rep)
    (pxr pxi pyr pyi poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rxr Rxi Ryr Ryi Rout : Interface.map.rep -> Prop),
    (*typeclass isntead of valid?*)
    valid (List.map Interface.word.unsigned wxr) /\
    valid (List.map Interface.word.unsigned wxi) /\
    valid (List.map Interface.word.unsigned wyr) /\
    valid (List.map Interface.word.unsigned wyi) ->
    ((Bignum n pxr wxr) * Rxr)%sep m0 ->
    ((Bignum n pxi wxi) * Rxi)%sep m0 ->
    ((Bignum n pyr wyr) * Ryr)%sep m0 ->
    ((Bignum n pyi wyi) * Ryi)%sep m0 ->
    ((Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_sub_alt2") t m0
    ([poutr; pouti; pxr; pxi; pyr; pyi])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep) Routnew,
        (
                (Fp2_sub_Gallina_spec (List.map Interface.word.unsigned wxr, List.map Interface.word.unsigned wxi)
                (List.map Interface.word.unsigned wyr, List.map Interface.word.unsigned wyi)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
                valid (List.map Interface.word.unsigned woutr) /\
                valid (List.map Interface.word.unsigned wouti)) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) * Rout * Routnew)%sep m'))).

Theorem Fp2_sub_alt2_okay: program_logic_goal_for_function! Fp2_sub_alt2.
Proof.
  do 7 straightline' numbytes_correct.

  (*Assert single hypothesis for stackallocation.*)
  remember (Bignum n pxr wxr * Rxr)%sep as Rxr'.
  remember (Bignum n pyr wyr * Ryr)%sep as Ryr'.
  remember (Bignum n pxi wxi * Rxi)%sep as Rxi'.
  remember (Bignum n pyi wyi * Ryi)%sep as Ryi'.
  remember ((Bignum n poutr wold_outr * Bignum n pouti wold_outi * Rout)%sep) as Rout'.

  assert (
      id (fun m => (Rxr' m /\ Ryr' m /\ Rxi' m /\ Ryi' m /\ Rout' m)) m0).
  {
    cbv [id]. split; auto.
  }

  (*Allocate memory on stack. *)
  repeat straightline' numbytes_correct. clear H1 Hmnew Hmnew0 Hmnew1.
  repeat straightline'. cbv [id] in *.

 (*Handle calls to felem_copy*)
  copy_next Rxr' (fun m => Ryr' m /\ Rxi' m /\ Ryi' m /\ Rout' m) mnew2 pxr wxr Rxr a Hmnew2.
  copy_next Ryr' (fun m => Rxi' m /\ Ryi' m /\ Rout' m) a4 pyr wyr Ryr a1 H15.
  copy_next Rxi' (fun m => Ryi' m /\ Rout' m) a6 pxi wxi Rxi a0 H15.
  copy_next Ryi' (fun m => Rout' m) a4 pyi wyi Ryi a2 H15.

 (*Handle function call*)
 repeat straightline.
 straightline_call.
 2: {
   assert (Hnumlimbs : n = num_limbs) by auto. rewrite !Hnumlimbs. rewrite !Hnumlimbs in H15. ecancel_assumption.
 }
 1: split; auto.

 (*Defragment memory in context after stack allocation. *)
 repeat straightline.
 repeat defrag_in_context'.

 (*Postcondition*)
 postcondition_pre.
 split; [auto| split; auto].
Qed.

Definition Fp2_mul_alt2 : Syntax.func :=
  let outr := "outr" in
  let outi := "outi" in
  let xr := "xr" in
  let xi := "xi" in
  let yr := "yr" in
  let yi := "yi" in
  let xrsep := "xrsep" in
  let xisep := "xisep" in
  let yrsep := "yrsep" in
  let yisep := "yisep" in
  let add := (append prefix "add") in
  let felem_copy := ("felem_copy_64") in
  ("Fp2_mul_alt2", (
    [outr; outi; xr; xi; yr; yi], [],
    bedrock_func_body:(
      stackalloc num_bytes as xrsep {
        stackalloc num_bytes as xisep {
          stackalloc num_bytes as yrsep {
            stackalloc num_bytes as yisep {
              (*Copies real part of first operand*)
              felem_copy (xrsep, xr);
              felem_copy (yrsep, yr);
              felem_copy (xisep, xi);
              felem_copy (yisep, yi);

              Fp2_mul (outr, outi, xrsep, xisep, yrsep, yisep)
            }
          }
        }
      }
    )
  )).

Instance spec_of_my_mul_alt2: spec_of Fp2_mul_alt2 :=
fun functions : list (string * (list string * list string * Syntax.cmd)) =>
    forall (wxr wxi wyr wyi : list Interface.word.rep)
    (pxr pxi pyr pyi poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rxr Rxi Ryr Ryi Rout : Interface.map.rep -> Prop),
    (*typeclass isntead of valid?*)
    valid (List.map Interface.word.unsigned wxr) /\
    valid (List.map Interface.word.unsigned wxi) /\
    valid (List.map Interface.word.unsigned wyr) /\
    valid (List.map Interface.word.unsigned wyi) ->
    ((Bignum n pxr wxr) * Rxr)%sep m0 ->
    ((Bignum n pxi wxi) * Rxi)%sep m0 ->
    ((Bignum n pyr wyr) * Ryr)%sep m0 ->
    ((Bignum n pyi wyi) * Ryi)%sep m0 ->
    ((Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_mul_alt2") t m0
    ([poutr; pouti; pxr; pxi; pyr; pyi])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep) Routnew,
        (
                (Fp2_mul_Gallina_spec (List.map Interface.word.unsigned wxr, List.map Interface.word.unsigned wxi)
                (List.map Interface.word.unsigned wyr, List.map Interface.word.unsigned wyi)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
                valid (List.map Interface.word.unsigned woutr) /\
                valid (List.map Interface.word.unsigned wouti)) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) * Rout * Routnew)%sep m'))).

Theorem Fp2_mul_alt2_okay: program_logic_goal_for_function! Fp2_mul_alt2.
Proof.
  do 7 straightline' numbytes_correct.

  (*Assert single hypothesis for stackallocation.*)
  remember (Bignum n pxr wxr * Rxr)%sep as Rxr'.
  remember (Bignum n pyr wyr * Ryr)%sep as Ryr'.
  remember (Bignum n pxi wxi * Rxi)%sep as Rxi'.
  remember (Bignum n pyi wyi * Ryi)%sep as Ryi'.
  remember ((Bignum n poutr wold_outr * Bignum n pouti wold_outi * Rout)%sep) as Rout'.

  assert (
      id (fun m => (Rxr' m /\ Ryr' m /\ Rxi' m /\ Ryi' m /\ Rout' m)) m0).
  {
    cbv [id]. split; auto.
  }

  (*Allocate memory on stack. *)
  repeat straightline' numbytes_correct. clear H1 Hmnew Hmnew0 Hmnew1.
  repeat straightline' numbytes_correct. cbv [id] in *.

 (*Handle calls to felem_copy*)
  copy_next Rxr' (fun m => Ryr' m /\ Rxi' m /\ Ryi' m /\ Rout' m) mnew2 pxr wxr Rxr a Hmnew2.
  copy_next Ryr' (fun m => Rxi' m /\ Ryi' m /\ Rout' m) a4 pyr wyr Ryr a1 H15.
  copy_next Rxi' (fun m => Ryi' m /\ Rout' m) a6 pxi wxi Rxi a0 H15.
  copy_next Ryi' (fun m => Rout' m) a4 pyi wyi Ryi a2 H15.

 (*Handle function call*)
 repeat straightline.
 straightline_call.
 2: {
   assert (Hnumlimbs : n = num_limbs) by auto. rewrite !Hnumlimbs. rewrite !Hnumlimbs in H15.
   ecancel_assumption.
 }
 1: split; auto.

 (*Defragment memory in context after stack allocation. *)
 repeat straightline.
 repeat defrag_in_context'.

 (*Postcondition*)
 postcondition_pre.
 split; [auto| split; auto].
Qed.

Definition Fp2_square_alt2 : Syntax.func :=
  let outr := "outr" in
  let outi := "outi" in
  let xr := "xr" in
  let xi := "xi" in
  let xrsep := "xrsep" in
  let xisep := "xisep" in
  let felem_copy := ("felem_copy_64") in
  ("Fp2_square_alt2", (
    [outr; outi; xr; xi], [],
    bedrock_func_body:(
      stackalloc num_bytes as xrsep {
        stackalloc num_bytes as xisep {
          (*Copies real part of first operand*)
          felem_copy (xrsep, xr);
          felem_copy (xisep, xi);

          Fp2_square (outi, outr, xrsep, xisep)
        }
      }
    )
  )).

Instance spec_of_my_square_alt2: spec_of Fp2_square_alt2 :=
fun functions : list (string * (list string * list string * Syntax.cmd)) =>
    forall (wxr wxi : list Interface.word.rep)
    (pxr pxi poutr pouti : Interface.word.rep)
    (wold_outr wold_outi : list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rxr Rxi Rout : Interface.map.rep -> Prop),
    (*typeclass isntead of valid?*)
    valid (List.map Interface.word.unsigned wxr) /\
    valid (List.map Interface.word.unsigned wxi) ->
    ((Bignum n pxr wxr) * Rxr)%sep m0 ->
    ((Bignum n pxi wxi) * Rxi)%sep m0 ->
    ((Bignum n poutr wold_outr) * (Bignum n pouti wold_outi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "Fp2_square_alt2") t m0
    ([pouti; poutr; pxr; pxi])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutr wouti : list Interface.word.rep) Routnew,
        (
                (Fp2_square_Gallina_spec (List.map Interface.word.unsigned wxr, List.map Interface.word.unsigned wxi)
                (List.map Interface.word.unsigned woutr, List.map Interface.word.unsigned wouti) /\
                valid (List.map Interface.word.unsigned woutr) /\
                valid (List.map Interface.word.unsigned wouti)) /\
             ((Bignum n poutr woutr) * (Bignum n pouti wouti) * Routnew)%sep m'))).

Theorem Fp2_square_alt2_okay: program_logic_goal_for_function! Fp2_square_alt2.
Proof.
  do 4 straightline' numbytes_correct.

  (*Assert single hypothesis for stackallocation.*)
  remember (Bignum n pxr wxr * Rxr)%sep as Rxr'.
  remember (Bignum n pxi wxi * Rxi)%sep as Rxi'.
  remember ((Bignum n poutr wold_outr * Bignum n pouti wold_outi * Rout)%sep) as Rout'.

  assert (
      id (fun m => (Rxr' m /\ Rxi' m /\ Rout' m)) m0).
  {
    cbv [id]. split; auto.
  }

  (*Allocate memory on stack. *)
  repeat straightline' numbytes_correct. clear Hmnew.
  repeat straightline' numbytes_correct. cbv [id] in *.

 (*Handle calls to felem_copy*)
  copy_next Rxr' (fun m => Rxi' m /\ Rout' m) mnew0 pxr wxr Rxr a Hmnew0.
  copy_next Rxi' (fun m => Rout' m) a2 pxi wxi Rxi a0 H10.

 (*Handle function call*)
 repeat straightline.
 straightline_call.
 2: {
   assert (Hnumlimbs : n = num_limbs) by auto. rewrite !Hnumlimbs. rewrite !Hnumlimbs in H10. ecancel_assumption.
 }
 1: split; auto.

 (*Defragment memory in context after stack allocation. *)
 repeat straightline.
 repeat defrag_in_context'.

 (*Postcondition*)
 repeat straightline. do 2 split; auto.
 do 3 eexists. split.
 2: ecancel_assumption.
 split.
 2: destruct H13; destruct H19; split; auto.
 auto.
Qed.
End Spec.


Require Import NoQ.PartialOrder.
Require Import NoQ.Universe.
Require Import NoQ.PArrow.
Require Import NoQ.MArrow.
Require Import NoQ.PreOrder.
Require Import NoQ.Reflexive.
Require Import NoQ.LibReflexive.
Require Import NoQ.Arrow.
Require Import NoQ.Transitive.
Require Import NoQ.Eqv.
Require Import NoQ.Function.
Require Import NoQ.Relation.

Class GaloisConnection (A B:UPO) :=
  { galois_α : dom (A ⇒ B)
  ; galois_γ : dom (B ⇒ A)
  ; galois_connection : forall {x:dom A} {y:dom B}, (galois_α ∙ x) ⊑ y <-> x ⊑ (galois_γ ∙ y)
  }.

Section Corollaries.
  (* These 4 corollaries are equivalent to galois_connection above *)

  Definition galois_γα_expansive {A B} `{! GaloisConnection A B }
  : forall (x:dom A), x ⊑ galois_γ ∙ (galois_α ∙ x).
  Proof.
    intros.
    apply galois_connection.
    apply reflexivity ; logical.
  Qed.

  Definition galois_αγ_contractive {A B} `{! GaloisConnection A B }
  : forall (y:dom B), galois_α ∙ (galois_γ ∙ y) ⊑ y.
  Proof.
    intros.
    apply galois_connection.
    apply reflexivity ; logical.
  Qed.

  Definition galois_α_monotonic {A B} `{! GaloisConnection A B }
  : proper (lte ∙⇉∙ lte) (galois_α:dom(A ⇒ B)).
  Proof.
    simpl.
    unfold proper,"∙⇉∙" ; intros.
    apply galois_connection.
    apply (transitivity y) ; auto.
    apply galois_γα_expansive ; auto.
  Qed.
  Definition mon_galois_α {A B} `{! GaloisConnection A B } : dom (A ⇗ B) :=
    {| mfun := galois_α
     ; mfun_monotonic := galois_α_monotonic
    |}.

  Definition galois_γ_monotonic {A B} `{! GaloisConnection A B }
  : proper (lte ∙⇉∙ lte) (galois_γ:dom (B ⇒ A)).
  Proof.
    simpl.
    unfold proper,"∙⇉∙" ; intros.
    apply galois_connection.
    apply (transitivity x) ; auto.
    apply galois_αγ_contractive ; auto.
  Qed.
  Definition mon_galois_γ {A B} `{! GaloisConnection A B } : dom (B ⇗ A) :=
    {| mfun := galois_γ
     ; mfun_monotonic := galois_γ_monotonic
    |}.

  Definition mon_galois_connection {A B} `{! GaloisConnection A B } {x:dom A} {y:dom B}
  : (mon_galois_α ∙ x) ⊑ y <-> x ⊑ (mon_galois_γ ∙ y) := galois_connection.
  Definition mon_galois_γα_expansive {A B} `{! GaloisConnection A B }
  : forall (x:dom A), x ⊑ mon_galois_γ ∙ (mon_galois_α ∙ x) := galois_γα_expansive.
  Definition mon_galois_αγ_contractive {A B} `{! GaloisConnection A B }
  : forall (y:dom B), mon_galois_α ∙ (mon_galois_γ ∙ y) ⊑ y := galois_αγ_contractive.
End Corollaries.

Definition Monotonic_galois_α {A B} `{! GaloisConnection A B } : dom ((A ⇗ A) ⇒ (B ⇗ B)).
Proof.
  refine {| pfun φ := mon_galois_α ∙⊙∙ φ ∙⊙∙ mon_galois_γ |}.
  unfold proper,"⇉" ; intros.
  apply logical_elim ; unfold "∙⇉∙" ; intros.
  apply (eqv_change (mon_galois_α ∙ (x ∙ (mon_galois_γ ∙ x0)))
                    (mon_galois_α ∙ (y ∙ (mon_galois_γ ∙ y0)))) ; logical.
Defined.

Definition Monotonic_galois_γ {A B} `{! GaloisConnection A B } : dom ((B ⇗ B) ⇒ (A ⇗ A)).
  refine {| pfun φ := mon_galois_γ ∙⊙∙ φ ∙⊙∙ mon_galois_α |}.
  unfold proper,"⇉" ; intros.
  apply logical_elim ; unfold "∙⇉∙" ; intros.
  apply (eqv_change (mon_galois_γ ∙ (x ∙ (mon_galois_α ∙ x0)))
                    (mon_galois_γ ∙ (y ∙ (mon_galois_α ∙ y0)))) ; logical.
Defined.

Instance Monotonic_GaloisConnection {A B} `{! GaloisConnection A B }
: GaloisConnection (A ⇗ A) (B ⇗ B) :=
  { galois_α := Monotonic_galois_α
  ; galois_γ := Monotonic_galois_γ
  }.
Proof.
  intros ; constructor ; intros.
  - apply monotonic_elim ; unfold "∙⇉∙" ; intros.
    change (x ∙ x0 ⊑ (mon_galois_γ ∙ (y ∙ (mon_galois_α ∙ y0)))).
    apply mon_galois_connection.
    apply (lte_change_lte
            (mon_galois_α ∙ (x ∙ (mon_galois_γ ∙ (mon_galois_α ∙ x0))))
            (y ∙ (mon_galois_α ∙ y0))) ; monotonic.
    { apply mon_galois_γα_expansive. }
    change ( (mon_galois_α ∙⊙∙ x ∙⊙∙ mon_galois_γ) ∙ (mon_galois_α ∙ x0)
           ⊑ y ∙ (mon_galois_α ∙ y0)) ; monotonic.
  - apply monotonic_elim ; unfold "∙⇉∙" ; intros.
    change (mon_galois_α ∙ (x ∙ (mon_galois_γ ∙ x0)) ⊑ y ∙ y0).
    apply mon_galois_connection.
    apply (lte_change_lte
            (x ∙ (mon_galois_γ ∙ x0))
            (mon_galois_γ ∙ (y ∙ (mon_galois_α ∙ (mon_galois_γ ∙ y0))))) ; monotonic.
    { apply mon_galois_αγ_contractive. }
    change ( (x ∙ (mon_galois_γ ∙ x0))
           ⊑ (mon_galois_γ ∙⊙∙ y ∙⊙∙ mon_galois_α) ∙ (mon_galois_γ ∙ y0)) ; monotonic.
Defined.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__collinearorder.
Require Export lemma__parallelNC.
Require Export logic.
Definition lemma__parallelbetween : forall B H K L M, (euclidean__axioms.BetS H B K) -> ((euclidean__defs.Par M B H L) -> ((euclidean__axioms.Col L M K) -> (euclidean__axioms.BetS L M K))).
Proof.
intro B.
intro H.
intro K.
intro L.
intro M.
intro H0.
intro H1.
intro H2.
assert (* Cut *) (~(euclidean__defs.Meet M B H L)) as H3.
- assert (exists U V u v X, (euclidean__axioms.neq M B) /\ ((euclidean__axioms.neq H L) /\ ((euclidean__axioms.Col M B U) /\ ((euclidean__axioms.Col M B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col H L u) /\ ((euclidean__axioms.Col H L v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet M B H L)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H3 by exact H1.
assert (exists U V u v X, (euclidean__axioms.neq M B) /\ ((euclidean__axioms.neq H L) /\ ((euclidean__axioms.Col M B U) /\ ((euclidean__axioms.Col M B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col H L u) /\ ((euclidean__axioms.Col H L v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet M B H L)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H3.
destruct __TmpHyp as [x H4].
destruct H4 as [x0 H5].
destruct H5 as [x1 H6].
destruct H6 as [x2 H7].
destruct H7 as [x3 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H25.
- assert (* Cut *) (euclidean__axioms.nCol M B H) as H4.
-- assert (* Cut *) ((euclidean__axioms.nCol M B H) /\ ((euclidean__axioms.nCol M H L) /\ ((euclidean__axioms.nCol B H L) /\ (euclidean__axioms.nCol M B L)))) as H4.
--- apply (@lemma__parallelNC.lemma__parallelNC M B H L H1).
--- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
exact H5.
-- assert (* Cut *) (euclidean__axioms.nCol M H L) as H5.
--- assert (* Cut *) ((euclidean__axioms.nCol M B H) /\ ((euclidean__axioms.nCol M H L) /\ ((euclidean__axioms.nCol B H L) /\ (euclidean__axioms.nCol M B L)))) as H5.
---- apply (@lemma__parallelNC.lemma__parallelNC M B H L H1).
---- destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H8.
--- assert (* Cut *) (euclidean__axioms.neq M B) as H6.
---- assert (* Cut *) ((euclidean__axioms.neq M B) /\ ((euclidean__axioms.neq B H) /\ ((euclidean__axioms.neq M H) /\ ((euclidean__axioms.neq B M) /\ ((euclidean__axioms.neq H B) /\ (euclidean__axioms.neq H M)))))) as H6.
----- apply (@lemma__NCdistinct.lemma__NCdistinct M B H H4).
----- destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H7.
---- assert (* Cut *) (euclidean__axioms.neq H L) as H7.
----- assert (* Cut *) ((euclidean__axioms.neq M H) /\ ((euclidean__axioms.neq H L) /\ ((euclidean__axioms.neq M L) /\ ((euclidean__axioms.neq H M) /\ ((euclidean__axioms.neq L H) /\ (euclidean__axioms.neq L M)))))) as H7.
------ apply (@lemma__NCdistinct.lemma__NCdistinct M H L H5).
------ destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H10.
----- assert (* Cut *) (euclidean__axioms.nCol M L H) as H8.
------ assert (* Cut *) ((euclidean__axioms.nCol H M L) /\ ((euclidean__axioms.nCol H L M) /\ ((euclidean__axioms.nCol L M H) /\ ((euclidean__axioms.nCol M L H) /\ (euclidean__axioms.nCol L H M))))) as H8.
------- apply (@lemma__NCorder.lemma__NCorder M H L H5).
------- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H15.
------ assert (* Cut *) (euclidean__axioms.Col M L K) as H9.
------- assert (* Cut *) ((euclidean__axioms.Col M L K) /\ ((euclidean__axioms.Col M K L) /\ ((euclidean__axioms.Col K L M) /\ ((euclidean__axioms.Col L K M) /\ (euclidean__axioms.Col K M L))))) as H9.
-------- apply (@lemma__collinearorder.lemma__collinearorder L M K H2).
-------- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H10.
------- assert (* Cut *) (euclidean__axioms.Col H B K) as H10.
-------- right.
right.
right.
right.
left.
exact H0.
-------- assert (* Cut *) (M = M) as H11.
--------- apply (@logic.eq__refl Point M).
--------- assert (* Cut *) (L = L) as H12.
---------- apply (@logic.eq__refl Point L).
---------- assert (* Cut *) (B = B) as H13.
----------- apply (@logic.eq__refl Point B).
----------- assert (* Cut *) (H = H) as H14.
------------ apply (@logic.eq__refl Point H).
------------ assert (* Cut *) (~(M = K)) as H15.
------------- intro H15.
assert (* Cut *) (euclidean__axioms.Col H B M) as H16.
-------------- apply (@eq__ind__r euclidean__axioms.Point K (fun M0 => (euclidean__defs.Par M0 B H L) -> ((euclidean__axioms.Col L M0 K) -> ((~(euclidean__defs.Meet M0 B H L)) -> ((euclidean__axioms.nCol M0 B H) -> ((euclidean__axioms.nCol M0 H L) -> ((euclidean__axioms.neq M0 B) -> ((euclidean__axioms.nCol M0 L H) -> ((euclidean__axioms.Col M0 L K) -> ((M0 = M0) -> (euclidean__axioms.Col H B M0))))))))))) with (x := M).
---------------intro H16.
intro H17.
intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
exact H10.

--------------- exact H15.
--------------- exact H1.
--------------- exact H2.
--------------- exact H3.
--------------- exact H4.
--------------- exact H5.
--------------- exact H6.
--------------- exact H8.
--------------- exact H9.
--------------- exact H11.
-------------- assert (* Cut *) (euclidean__axioms.Col M B H) as H17.
--------------- assert (* Cut *) ((euclidean__axioms.Col B H M) /\ ((euclidean__axioms.Col B M H) /\ ((euclidean__axioms.Col M H B) /\ ((euclidean__axioms.Col H M B) /\ (euclidean__axioms.Col M B H))))) as H17.
---------------- apply (@lemma__collinearorder.lemma__collinearorder H B M H16).
---------------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H25.
--------------- assert (* Cut *) (euclidean__axioms.Col H L H) as H18.
---------------- right.
left.
exact H14.
---------------- assert (* Cut *) (euclidean__defs.Meet M B H L) as H19.
----------------- exists H.
split.
------------------ exact H6.
------------------ split.
------------------- exact H7.
------------------- split.
-------------------- exact H17.
-------------------- exact H18.
----------------- apply (@H3 H19).
------------- assert (* Cut *) (euclidean__axioms.nCol M L H) as H16.
-------------- assert (* Cut *) ((euclidean__axioms.nCol H M L) /\ ((euclidean__axioms.nCol H L M) /\ ((euclidean__axioms.nCol L M H) /\ ((euclidean__axioms.nCol M L H) /\ (euclidean__axioms.nCol L H M))))) as H16.
--------------- apply (@lemma__NCorder.lemma__NCorder M H L H5).
--------------- destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H8.
-------------- assert (* Cut *) (euclidean__axioms.Col M L M) as H17.
--------------- right.
left.
exact H11.
--------------- assert (* Cut *) (euclidean__axioms.nCol M K H) as H18.
---------------- apply (@euclidean__tactics.nCol__notCol M K H).
-----------------apply (@euclidean__tactics.nCol__not__Col M K H).
------------------apply (@lemma__NChelper.lemma__NChelper M L H M K H16 H17 H9 H15).

---------------- assert (* Cut *) (euclidean__axioms.nCol H M K) as H19.
----------------- assert (* Cut *) ((euclidean__axioms.nCol K M H) /\ ((euclidean__axioms.nCol K H M) /\ ((euclidean__axioms.nCol H M K) /\ ((euclidean__axioms.nCol M H K) /\ (euclidean__axioms.nCol H K M))))) as H19.
------------------ apply (@lemma__NCorder.lemma__NCorder M K H H18).
------------------ destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H24.
----------------- assert ((L = M) \/ ((L = K) \/ ((M = K) \/ ((euclidean__axioms.BetS M L K) \/ ((euclidean__axioms.BetS L M K) \/ (euclidean__axioms.BetS L K M)))))) as H20 by exact H2.
assert (* Cut *) (euclidean__axioms.BetS L M K) as H21.
------------------ assert ((L = M) \/ ((L = K) \/ ((M = K) \/ ((euclidean__axioms.BetS M L K) \/ ((euclidean__axioms.BetS L M K) \/ (euclidean__axioms.BetS L K M)))))) as H21 by exact H20.
assert ((L = M) \/ ((L = K) \/ ((M = K) \/ ((euclidean__axioms.BetS M L K) \/ ((euclidean__axioms.BetS L M K) \/ (euclidean__axioms.BetS L K M)))))) as __TmpHyp by exact H21.
destruct __TmpHyp as [H22|H22].
------------------- assert (* Cut *) (~(~(euclidean__axioms.BetS L M K))) as H23.
-------------------- intro H23.
assert (* Cut *) (euclidean__axioms.Col M B M) as H24.
--------------------- right.
left.
exact H11.
--------------------- assert (* Cut *) (euclidean__axioms.Col H L L) as H25.
---------------------- right.
right.
left.
exact H12.
---------------------- assert (* Cut *) (euclidean__axioms.Col H L M) as H26.
----------------------- apply (@eq__ind__r euclidean__axioms.Point M (fun L0 => (euclidean__defs.Par M B H L0) -> ((euclidean__axioms.Col L0 M K) -> ((~(euclidean__defs.Meet M B H L0)) -> ((euclidean__axioms.nCol M H L0) -> ((euclidean__axioms.neq H L0) -> ((euclidean__axioms.nCol M L0 H) -> ((euclidean__axioms.Col M L0 K) -> ((L0 = L0) -> ((euclidean__axioms.nCol M L0 H) -> ((euclidean__axioms.Col M L0 M) -> ((~(euclidean__axioms.BetS L0 M K)) -> ((euclidean__axioms.Col H L0 L0) -> (euclidean__axioms.Col H L0 M)))))))))))))) with (x := L).
------------------------intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
exact H37.

------------------------ exact H22.
------------------------ exact H1.
------------------------ exact H2.
------------------------ exact H3.
------------------------ exact H5.
------------------------ exact H7.
------------------------ exact H8.
------------------------ exact H9.
------------------------ exact H12.
------------------------ exact H16.
------------------------ exact H17.
------------------------ exact H23.
------------------------ exact H25.
----------------------- assert (* Cut *) (euclidean__defs.Meet M B H L) as H27.
------------------------ exists M.
split.
------------------------- exact H6.
------------------------- split.
-------------------------- exact H7.
-------------------------- split.
--------------------------- exact H24.
--------------------------- exact H26.
------------------------ apply (@H3 H27).
-------------------- apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS L M K)).
---------------------intro H24.
destruct H4 as [H25 H26].
destruct H5 as [H27 H28].
destruct H8 as [H29 H30].
destruct H16 as [H31 H32].
destruct H18 as [H33 H34].
destruct H19 as [H35 H36].
destruct H26 as [H37 H38].
destruct H28 as [H39 H40].
destruct H30 as [H41 H42].
destruct H32 as [H43 H44].
destruct H34 as [H45 H46].
destruct H36 as [H47 H48].
destruct H38 as [H49 H50].
destruct H40 as [H51 H52].
destruct H42 as [H53 H54].
destruct H44 as [H55 H56].
destruct H46 as [H57 H58].
destruct H48 as [H59 H60].
destruct H50 as [H61 H62].
destruct H52 as [H63 H64].
destruct H54 as [H65 H66].
destruct H56 as [H67 H68].
destruct H58 as [H69 H70].
destruct H60 as [H71 H72].
destruct H62 as [H73 H74].
destruct H64 as [H75 H76].
destruct H66 as [H77 H78].
destruct H68 as [H79 H80].
destruct H70 as [H81 H82].
destruct H72 as [H83 H84].
assert (* Cut *) (False) as H85.
---------------------- apply (@H23 H24).
---------------------- contradiction H85.

------------------- destruct H22 as [H23|H23].
-------------------- assert (* Cut *) (~(~(euclidean__axioms.BetS L M K))) as H24.
--------------------- intro H24.
assert (* Cut *) (euclidean__axioms.Col H B L) as H25.
---------------------- apply (@eq__ind__r euclidean__axioms.Point K (fun L0 => (euclidean__defs.Par M B H L0) -> ((euclidean__axioms.Col L0 M K) -> ((~(euclidean__defs.Meet M B H L0)) -> ((euclidean__axioms.nCol M H L0) -> ((euclidean__axioms.neq H L0) -> ((euclidean__axioms.nCol M L0 H) -> ((euclidean__axioms.Col M L0 K) -> ((L0 = L0) -> ((euclidean__axioms.nCol M L0 H) -> ((euclidean__axioms.Col M L0 M) -> ((~(euclidean__axioms.BetS L0 M K)) -> (euclidean__axioms.Col H B L0))))))))))))) with (x := L).
-----------------------intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
exact H10.

----------------------- exact H23.
----------------------- exact H1.
----------------------- exact H2.
----------------------- exact H3.
----------------------- exact H5.
----------------------- exact H7.
----------------------- exact H8.
----------------------- exact H9.
----------------------- exact H12.
----------------------- exact H16.
----------------------- exact H17.
----------------------- exact H24.
---------------------- assert (* Cut *) (euclidean__axioms.Col H L B) as H26.
----------------------- assert (* Cut *) ((euclidean__axioms.Col B H L) /\ ((euclidean__axioms.Col B L H) /\ ((euclidean__axioms.Col L H B) /\ ((euclidean__axioms.Col H L B) /\ (euclidean__axioms.Col L B H))))) as H26.
------------------------ apply (@lemma__collinearorder.lemma__collinearorder H B L H25).
------------------------ destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H33.
----------------------- assert (* Cut *) (euclidean__axioms.Col M B B) as H27.
------------------------ right.
right.
left.
exact H13.
------------------------ assert (* Cut *) (euclidean__defs.Meet M B H L) as H28.
------------------------- exists B.
split.
-------------------------- exact H6.
-------------------------- split.
--------------------------- exact H7.
--------------------------- split.
---------------------------- exact H27.
---------------------------- exact H26.
------------------------- apply (@H3 H28).
--------------------- apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS L M K)).
----------------------intro H25.
destruct H4 as [H26 H27].
destruct H5 as [H28 H29].
destruct H8 as [H30 H31].
destruct H16 as [H32 H33].
destruct H18 as [H34 H35].
destruct H19 as [H36 H37].
destruct H27 as [H38 H39].
destruct H29 as [H40 H41].
destruct H31 as [H42 H43].
destruct H33 as [H44 H45].
destruct H35 as [H46 H47].
destruct H37 as [H48 H49].
destruct H39 as [H50 H51].
destruct H41 as [H52 H53].
destruct H43 as [H54 H55].
destruct H45 as [H56 H57].
destruct H47 as [H58 H59].
destruct H49 as [H60 H61].
destruct H51 as [H62 H63].
destruct H53 as [H64 H65].
destruct H55 as [H66 H67].
destruct H57 as [H68 H69].
destruct H59 as [H70 H71].
destruct H61 as [H72 H73].
destruct H63 as [H74 H75].
destruct H65 as [H76 H77].
destruct H67 as [H78 H79].
destruct H69 as [H80 H81].
destruct H71 as [H82 H83].
destruct H73 as [H84 H85].
assert (* Cut *) (False) as H86.
----------------------- apply (@H24 H25).
----------------------- contradiction H86.

-------------------- destruct H23 as [H24|H24].
--------------------- assert (* Cut *) (~(~(euclidean__axioms.BetS L M K))) as H25.
---------------------- intro H25.
apply (@H15 H24).
---------------------- apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS L M K)).
-----------------------intro H26.
destruct H4 as [H27 H28].
destruct H5 as [H29 H30].
destruct H8 as [H31 H32].
destruct H16 as [H33 H34].
destruct H18 as [H35 H36].
destruct H19 as [H37 H38].
destruct H28 as [H39 H40].
destruct H30 as [H41 H42].
destruct H32 as [H43 H44].
destruct H34 as [H45 H46].
destruct H36 as [H47 H48].
destruct H38 as [H49 H50].
destruct H40 as [H51 H52].
destruct H42 as [H53 H54].
destruct H44 as [H55 H56].
destruct H46 as [H57 H58].
destruct H48 as [H59 H60].
destruct H50 as [H61 H62].
destruct H52 as [H63 H64].
destruct H54 as [H65 H66].
destruct H56 as [H67 H68].
destruct H58 as [H69 H70].
destruct H60 as [H71 H72].
destruct H62 as [H73 H74].
destruct H64 as [H75 H76].
destruct H66 as [H77 H78].
destruct H68 as [H79 H80].
destruct H70 as [H81 H82].
destruct H72 as [H83 H84].
destruct H74 as [H85 H86].
assert (* Cut *) (False) as H87.
------------------------ apply (@H15 H24).
------------------------ assert (* Cut *) (False) as H88.
------------------------- apply (@H25 H26).
------------------------- contradiction H88.

--------------------- destruct H24 as [H25|H25].
---------------------- assert (* Cut *) (~(~(euclidean__axioms.BetS L M K))) as H26.
----------------------- intro H26.
assert (* Cut *) (euclidean__axioms.nCol H K M) as H27.
------------------------ assert (* Cut *) ((euclidean__axioms.nCol M H K) /\ ((euclidean__axioms.nCol M K H) /\ ((euclidean__axioms.nCol K H M) /\ ((euclidean__axioms.nCol H K M) /\ (euclidean__axioms.nCol K M H))))) as H27.
------------------------- apply (@lemma__NCorder.lemma__NCorder H M K H19).
------------------------- destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H34.
------------------------ assert (* Cut *) (exists E, (euclidean__axioms.BetS H E L) /\ (euclidean__axioms.BetS M E B)) as H28.
------------------------- apply (@euclidean__axioms.postulate__Pasch__inner H M K B L H0 H25 H27).
------------------------- destruct H28 as [E H29].
destruct H29 as [H30 H31].
assert (* Cut *) (euclidean__axioms.Col H E L) as H32.
-------------------------- right.
right.
right.
right.
left.
exact H30.
-------------------------- assert (* Cut *) (euclidean__axioms.Col M E B) as H33.
--------------------------- right.
right.
right.
right.
left.
exact H31.
--------------------------- assert (* Cut *) (euclidean__axioms.Col H L E) as H34.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col E H L) /\ ((euclidean__axioms.Col E L H) /\ ((euclidean__axioms.Col L H E) /\ ((euclidean__axioms.Col H L E) /\ (euclidean__axioms.Col L E H))))) as H34.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder H E L H32).
----------------------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H41.
---------------------------- assert (* Cut *) (euclidean__axioms.Col M B E) as H35.
----------------------------- assert (* Cut *) ((euclidean__axioms.Col E M B) /\ ((euclidean__axioms.Col E B M) /\ ((euclidean__axioms.Col B M E) /\ ((euclidean__axioms.Col M B E) /\ (euclidean__axioms.Col B E M))))) as H35.
------------------------------ apply (@lemma__collinearorder.lemma__collinearorder M E B H33).
------------------------------ destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H42.
----------------------------- assert (* Cut *) (euclidean__defs.Meet M B H L) as H36.
------------------------------ exists E.
split.
------------------------------- exact H6.
------------------------------- split.
-------------------------------- exact H7.
-------------------------------- split.
--------------------------------- exact H35.
--------------------------------- exact H34.
------------------------------ apply (@H3 H36).
----------------------- apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS L M K)).
------------------------intro H27.
destruct H4 as [H28 H29].
destruct H5 as [H30 H31].
destruct H8 as [H32 H33].
destruct H16 as [H34 H35].
destruct H18 as [H36 H37].
destruct H19 as [H38 H39].
destruct H29 as [H40 H41].
destruct H31 as [H42 H43].
destruct H33 as [H44 H45].
destruct H35 as [H46 H47].
destruct H37 as [H48 H49].
destruct H39 as [H50 H51].
destruct H41 as [H52 H53].
destruct H43 as [H54 H55].
destruct H45 as [H56 H57].
destruct H47 as [H58 H59].
destruct H49 as [H60 H61].
destruct H51 as [H62 H63].
destruct H53 as [H64 H65].
destruct H55 as [H66 H67].
destruct H57 as [H68 H69].
destruct H59 as [H70 H71].
destruct H61 as [H72 H73].
destruct H63 as [H74 H75].
destruct H65 as [H76 H77].
destruct H67 as [H78 H79].
destruct H69 as [H80 H81].
destruct H71 as [H82 H83].
destruct H73 as [H84 H85].
destruct H75 as [H86 H87].
assert (* Cut *) (False) as H88.
------------------------- apply (@H26 H27).
------------------------- contradiction H88.

---------------------- destruct H25 as [H26|H26].
----------------------- exact H26.
----------------------- assert (* Cut *) (~(~(euclidean__axioms.BetS L M K))) as H27.
------------------------ intro H27.
assert (* Cut *) (euclidean__axioms.BetS M K L) as H28.
------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry L K M H26).
------------------------- assert (* Cut *) (exists E, (euclidean__axioms.BetS H E L) /\ (euclidean__axioms.BetS M B E)) as H29.
-------------------------- apply (@euclidean__axioms.postulate__Pasch__outer H M K B L H0 H28 H16).
-------------------------- destruct H29 as [E H30].
destruct H30 as [H31 H32].
assert (* Cut *) (euclidean__axioms.Col H E L) as H33.
--------------------------- right.
right.
right.
right.
left.
exact H31.
--------------------------- assert (* Cut *) (euclidean__axioms.Col M B E) as H34.
---------------------------- right.
right.
right.
right.
left.
exact H32.
---------------------------- assert (* Cut *) (euclidean__axioms.Col H L E) as H35.
----------------------------- assert (* Cut *) ((euclidean__axioms.Col E H L) /\ ((euclidean__axioms.Col E L H) /\ ((euclidean__axioms.Col L H E) /\ ((euclidean__axioms.Col H L E) /\ (euclidean__axioms.Col L E H))))) as H35.
------------------------------ apply (@lemma__collinearorder.lemma__collinearorder H E L H33).
------------------------------ destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H42.
----------------------------- assert (* Cut *) (euclidean__defs.Meet M B H L) as H36.
------------------------------ exists E.
split.
------------------------------- exact H6.
------------------------------- split.
-------------------------------- exact H7.
-------------------------------- split.
--------------------------------- exact H34.
--------------------------------- exact H35.
------------------------------ apply (@H3 H36).
------------------------ apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS L M K)).
-------------------------intro H28.
destruct H4 as [H29 H30].
destruct H5 as [H31 H32].
destruct H8 as [H33 H34].
destruct H16 as [H35 H36].
destruct H18 as [H37 H38].
destruct H19 as [H39 H40].
destruct H30 as [H41 H42].
destruct H32 as [H43 H44].
destruct H34 as [H45 H46].
destruct H36 as [H47 H48].
destruct H38 as [H49 H50].
destruct H40 as [H51 H52].
destruct H42 as [H53 H54].
destruct H44 as [H55 H56].
destruct H46 as [H57 H58].
destruct H48 as [H59 H60].
destruct H50 as [H61 H62].
destruct H52 as [H63 H64].
destruct H54 as [H65 H66].
destruct H56 as [H67 H68].
destruct H58 as [H69 H70].
destruct H60 as [H71 H72].
destruct H62 as [H73 H74].
destruct H64 as [H75 H76].
destruct H66 as [H77 H78].
destruct H68 as [H79 H80].
destruct H70 as [H81 H82].
destruct H72 as [H83 H84].
destruct H74 as [H85 H86].
destruct H76 as [H87 H88].
assert (* Cut *) (False) as H89.
-------------------------- apply (@H27 H28).
-------------------------- contradiction H89.

------------------ exact H21.
Qed.


(* ******************************************************************************* *)
(** * Yoneda Lemma
    Niccolo Veltri, Niels van der Weide
    June 2019
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Examples.OpMorBicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.Properties.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.UnivalenceOp.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.PseudoFunctors.Yoneda.
Require Import UniMath.Bicategories.PseudoFunctors.Representable.
Require Import UniMath.Bicategories.Core.Examples.Image.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.CorestrictImage.

Local Open Scope bicategory_scope.
Local Open Scope cat.

Opaque psfunctor.

Section YonedaLemma.
  Context {B : bicat}.
  Variable (B_is_univalent_2_1 : is_univalent_2_1 B)
           (F : psfunctor (op1_bicat B) bicat_of_univ_cats)
           (X : B).

  (** First, we construct a functor from the yoneda to the presheaf *)
  Definition yoneda_to_presheaf_data_ob
    : pstrans (representable B_is_univalent_2_1 X) F → pr1 (F X).
  Proof.
    intro τ.
    pose (τ X) as f; cbn in f.
    exact (f (identity X)).
  Defined.

  Definition yoneda_to_presheaf_data_mor
             (η₁ η₂ : pstrans (representable B_is_univalent_2_1 X) F)
             (m : modification η₁ η₂)
    : yoneda_to_presheaf_data_ob η₁ --> yoneda_to_presheaf_data_ob η₂.
  Proof.
    pose (m X) as n; cbn in n.
    exact (n (identity X)).
  Defined.

  Definition yoneda_to_presheaf_data
    : functor_data
        (univ_hom
           (psfunctor_bicat_is_univalent_2_1
              (op1_bicat B) bicat_of_univ_cats
              univalent_cat_is_univalent_2_1)
           (y B_is_univalent_2_1 X) F)
        (F X : univalent_category).
  Proof.
    use make_functor_data.
    - exact yoneda_to_presheaf_data_ob.
    - exact yoneda_to_presheaf_data_mor.
  Defined.

  Lemma yoneda_to_presheaf_is_functor
    : is_functor yoneda_to_presheaf_data.
  Proof.
    split.
    - intro η ; cbn.
      apply idpath.
    - intros η₁ η₂ η₃ f g ; cbn.
      apply idpath.
  Qed.

  Definition yoneda_to_presheaf
    : bicat_of_univ_cats
        ⟦ univ_hom
            (psfunctor_bicat_is_univalent_2_1
               _ _ univalent_cat_is_univalent_2_1)
            (y B_is_univalent_2_1 X) F
          , F X ⟧.
  Proof.
    use make_functor.
    - exact yoneda_to_presheaf_data.
    - exact yoneda_to_presheaf_is_functor.
  Defined.

  (** Next, we construct a functor in the opposite direction *)
  Section PresheafToYonedaOb.
    Variable (x : (F X : univalent_category)).

    Definition presheaf_to_yoneda_ob_pstrans_functor_ob
               (Y : op1_bicat B)
      : B ⟦ Y , X ⟧ → pr1 (F Y)
      := λ f, (#F f : _ ⟶ _) x.

    Definition presheaf_to_yoneda_ob_pstrans_functor_mor
               (Y : op1_bicat B)
               (f g : B ⟦ Y , X ⟧)
               (α : f ==> g)
      : (presheaf_to_yoneda_ob_pstrans_functor_ob Y f)
          -->
          presheaf_to_yoneda_ob_pstrans_functor_ob Y g
      := (##F α : nat_trans _ _) x.

    Definition presheaf_to_yoneda_ob_pstrans_functor_data
               (Y : op1_bicat B)
      : functor_data (@hom B Y X) (pr1 (F Y)).
    Proof.
      use make_functor_data.
      - exact (presheaf_to_yoneda_ob_pstrans_functor_ob Y).
      - exact (presheaf_to_yoneda_ob_pstrans_functor_mor Y).
    Defined.

    Lemma presheaf_to_yoneda_ob_pstrans_is_functor
               (Y : op1_bicat B)
      : is_functor (presheaf_to_yoneda_ob_pstrans_functor_data Y).
    Proof.
      split.
      - intro f ; cbn.
        unfold presheaf_to_yoneda_ob_pstrans_functor_mor ;
        unfold presheaf_to_yoneda_ob_pstrans_functor_ob.
        exact (nat_trans_eq_pointwise (psfunctor_id2 F f) x).
      - intros f₁ f₂ f₃ α₁ α₂ ; cbn.
        unfold presheaf_to_yoneda_ob_pstrans_functor_mor.
        exact (nat_trans_eq_pointwise (psfunctor_vcomp F α₁ α₂) x).
    Qed.

    Definition presheaf_to_yoneda_ob_pstrans_functor
               (Y : op1_bicat B)
      : bicat_of_univ_cats ⟦ @univ_hom B B_is_univalent_2_1 Y X , F Y ⟧.
    Proof.
      use make_functor.
      - exact (presheaf_to_yoneda_ob_pstrans_functor_data Y).
      - exact (presheaf_to_yoneda_ob_pstrans_is_functor Y).
    Defined.

    Definition presheaf_to_yoneda_ob_pstrans_nat_trans_data
               (Y₁ Y₂ : op1_bicat B)
               (f : B ⟦ Y₂ , Y₁ ⟧)
      : nat_trans_data
          (presheaf_to_yoneda_ob_pstrans_functor Y₁ · # F f : _ ⟶ _)
          (#(y B_is_univalent_2_1 X : psfunctor _ _) f
            · presheaf_to_yoneda_ob_pstrans_functor Y₂ : _ ⟶ _).
    Proof.
      intros g ; cbn in *.
      unfold presheaf_to_yoneda_ob_pstrans_functor_ob.
      pose (psfunctor_comp F g f : _ ==> _) as p ; cbn in p.
      exact (p x).
    Defined.

    Lemma presheaf_to_yoneda_ob_pstrans_is_nat_trans
               (Y₁ Y₂ : op1_bicat B)
               (f : B ⟦ Y₂ , Y₁ ⟧)
      : is_nat_trans _ _ (presheaf_to_yoneda_ob_pstrans_nat_trans_data Y₁ Y₂ f).
    Proof.
      intros g₁ g₂ α ; cbn in *.
      unfold presheaf_to_yoneda_ob_pstrans_functor_mor ;
      unfold presheaf_to_yoneda_ob_pstrans_nat_trans_data.
      pose (psfunctor_rwhisker F f α) as p.
      pose (nat_trans_eq_pointwise p x) as q.
      exact (!q).
    Qed.

    Definition presheaf_to_yoneda_ob_pstrans_nat_trans
               (Y₁ Y₂ : op1_bicat B)
               (f : B ⟦ Y₂ , Y₁ ⟧)
      : (presheaf_to_yoneda_ob_pstrans_functor Y₁ · # F f)
          ==>
          #(y B_is_univalent_2_1 X : psfunctor _ _) f
          · presheaf_to_yoneda_ob_pstrans_functor Y₂.
    Proof.
      use make_nat_trans.
      - exact (presheaf_to_yoneda_ob_pstrans_nat_trans_data Y₁ Y₂ f).
      - exact (presheaf_to_yoneda_ob_pstrans_is_nat_trans Y₁ Y₂ f).
    Defined.

    Definition presheaf_to_yoneda_ob_pstrans_is_nat_z_iso
               (Y₁ Y₂ : op1_bicat B)
               (f : B ⟦ Y₂ , Y₁ ⟧)
      : is_nat_z_iso (pr1 (presheaf_to_yoneda_ob_pstrans_nat_trans Y₁ Y₂ f)).
    Proof.
      intro g ; cbn in g.
      unfold presheaf_to_yoneda_ob_pstrans_nat_trans.
      simpl.
      unfold presheaf_to_yoneda_ob_pstrans_nat_trans_data.
      pose (is_invertible_2cell_to_is_nat_z_iso (psfunctor_comp F g f)) as i.
      apply i.
      exact (psfunctor_comp F g f).
    Defined.

    Definition presheaf_to_yoneda_ob_pstrans_data
      : pstrans_data ((y B_is_univalent_2_1) X) F.
    Proof.
      pose x.
      use make_pstrans_data.
      - exact presheaf_to_yoneda_ob_pstrans_functor.
      - intros Y₁ Y₂ f.
        use make_invertible_2cell.
        + exact (presheaf_to_yoneda_ob_pstrans_nat_trans Y₁ Y₂ f).
        + apply is_nat_z_iso_to_is_invertible_2cell.
          exact (presheaf_to_yoneda_ob_pstrans_is_nat_z_iso Y₁ Y₂ f).
    Defined.

    Lemma presheaf_to_yoneda_ob_pstrans_is_pstrans
      : is_pstrans presheaf_to_yoneda_ob_pstrans_data.
    Proof.
      repeat split.
      - intros Y₁ Y₂ g₁ g₂ α.
        apply nat_trans_eq.
        { apply homset_property. }
        intro h ; cbn in *.
        unfold presheaf_to_yoneda_ob_pstrans_functor_ob,
               presheaf_to_yoneda_ob_pstrans_functor_mor,
               presheaf_to_yoneda_ob_pstrans_nat_trans_data.
        pose (psfunctor_lwhisker F h α).
        pose (nat_trans_eq_pointwise p x) as q.
        exact (!q).
      - intros Y.
        apply nat_trans_eq.
        { apply homset_property. }
        intro h ; cbn in *.
        unfold presheaf_to_yoneda_ob_pstrans_functor_ob,
               presheaf_to_yoneda_ob_pstrans_functor_mor,
               presheaf_to_yoneda_ob_pstrans_nat_trans_data.
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            apply id_left.
          }
          etrans.
          {
            apply id_left.
          }
          exact (nat_trans_eq_pointwise (psfunctor_rinvunitor F h) x).
        }
        cbn -[psfunctor_id psfunctor_comp].
        apply maponpaths_2.
        apply id_left.
      - intros Y₁ Y₂ Y₃ g₁ g₂.
        apply nat_trans_eq.
        { apply homset_property. }
        intro h ; cbn in *.
        unfold presheaf_to_yoneda_ob_pstrans_functor_ob,
               presheaf_to_yoneda_ob_pstrans_functor_mor,
               presheaf_to_yoneda_ob_pstrans_nat_trans_data.
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            etrans.
            { apply id_right. }
            apply maponpaths_2.
            etrans.
            { apply id_right. }
            apply id_left.
          }
          exact (nat_trans_eq_pointwise (psfunctor_rassociator F h g₁ g₂) x).
        }
        simpl.
        etrans.
        {
          apply maponpaths_2.
          apply id_left.
        }
        apply idpath.
    Qed.

    Definition presheaf_to_yoneda_ob
      : pstrans (y B_is_univalent_2_1 X) F.
    Proof.
      use make_pstrans.
      - exact presheaf_to_yoneda_ob_pstrans_data.
      - exact presheaf_to_yoneda_ob_pstrans_is_pstrans.
    Defined.

  End PresheafToYonedaOb.

  Section PresheafToYonedaMor.
    Variable (a b : (F X : univalent_category))
             (f : a --> b).

    Definition presheaf_to_yoneda_mor_modification_nat_trans_data
               (Y : op1_bicat B)
      : nat_trans_data
          ((presheaf_to_yoneda_ob a) Y : _ ⟶ _)
          ((presheaf_to_yoneda_ob b) Y : _ ⟶ _)
      := λ h, #(#F h : _ ⟶ _) f.

    Lemma presheaf_to_yoneda_mor_modification_is_nat_trans
               (Y : op1_bicat B)
      : is_nat_trans
          _ _
          (presheaf_to_yoneda_mor_modification_nat_trans_data Y).
    Proof.
      intros h₁ h₂ α ; cbn in *.
      unfold presheaf_to_yoneda_ob_pstrans_functor_mor,
             presheaf_to_yoneda_mor_modification_nat_trans_data.
      pose (pr2 (##F α : _ ⟹ _)) as p.
      exact (!(p a b f)).
    Qed.

    Definition presheaf_to_yoneda_mor_modification_data
      : modification_data (presheaf_to_yoneda_ob a) (presheaf_to_yoneda_ob b).
    Proof.
      intros Y.
      use make_nat_trans.
      - exact (presheaf_to_yoneda_mor_modification_nat_trans_data Y).
      - exact (presheaf_to_yoneda_mor_modification_is_nat_trans Y).
    Defined.

    Lemma presheaf_to_yoneda_mor_is_modification
      : is_modification presheaf_to_yoneda_mor_modification_data.
    Proof.
      intros Y₁ Y₂ g.
      apply nat_trans_eq.
      { apply homset_property. }
      intros h ; cbn in *.
      unfold presheaf_to_yoneda_ob_pstrans_nat_trans_data,
             presheaf_to_yoneda_mor_modification_nat_trans_data.
      pose (pr21 (psfunctor_comp F h g)) as p.
      exact (!(p a b f)).
    Qed.

    Definition presheaf_to_yoneda_mor_modification
      : modification (presheaf_to_yoneda_ob a) (presheaf_to_yoneda_ob b).
    Proof.
      use make_modification.
      - exact presheaf_to_yoneda_mor_modification_data.
      - exact presheaf_to_yoneda_mor_is_modification.
    Defined.

  End PresheafToYonedaMor.

  Definition presheaf_to_yoneda_data
    : functor_data
        (F X : univalent_category)
        (univ_hom
           (psfunctor_bicat_is_univalent_2_1
              (op1_bicat B) bicat_of_univ_cats
              univalent_cat_is_univalent_2_1) ((y B_is_univalent_2_1) X) F).
  Proof.
    use make_functor_data.
    - exact presheaf_to_yoneda_ob.
    - exact presheaf_to_yoneda_mor_modification.
  Defined.

  Lemma presheaf_to_yoneda_is_functor
    : is_functor presheaf_to_yoneda_data.
  Proof.
    split.
    - intros z.
      apply modification_eq.
      intros Z.
      apply nat_trans_eq.
      { apply homset_property. }
      intros f.
      cbn in *.
      unfold  presheaf_to_yoneda_mor_modification_nat_trans_data,
              presheaf_to_yoneda_ob_pstrans_functor_ob.
      apply functor_id.
    - intros z₁ z₂ z₃ f₁ f₂.
      apply modification_eq.
      intros Z.
      apply nat_trans_eq.
      { apply homset_property. }
      intros f.
      cbn in *.
      unfold  presheaf_to_yoneda_mor_modification_nat_trans_data,
              presheaf_to_yoneda_ob_pstrans_functor_ob.
      apply functor_comp.
  Qed.

  Definition presheaf_to_yoneda
    : bicat_of_univ_cats
        ⟦ F X ,
          univ_hom
            (psfunctor_bicat_is_univalent_2_1
               _ _ univalent_cat_is_univalent_2_1)
            (y B_is_univalent_2_1 X) F ⟧.
  Proof.
    use make_functor.
    - exact presheaf_to_yoneda_data.
    - exact presheaf_to_yoneda_is_functor.
  Defined.

  Definition yoneda_unit_component_mod_component_nat_component
             (η : pstrans (representable B_is_univalent_2_1 X) F)
             (Z : op1_bicat B)
             (f : B ⟦ Z , X ⟧)
    : pr1 (F Z)
        ⟦ (η Z : _ ⟶ _) f ,
          (# F f : _ ⟶ _) ((η X : _ ⟶ _) (id₁ X)) ⟧
    := #(η Z : _ ⟶ _) (rinvunitor f)
        · pr1 ((psnaturality_of η f)^-1) (id₁ X).

  Lemma yoneda_unit_component_mod_component_is_nat_trans
             (η : pstrans (representable B_is_univalent_2_1 X) F)
             (Z : op1_bicat B)
             (f₁ f₂ : B ⟦ Z , X ⟧)
             (α : f₁ ==> f₂)
    : # (η Z : _ ⟶ _) α
        · yoneda_unit_component_mod_component_nat_component η Z f₂
      =
      (yoneda_unit_component_mod_component_nat_component η Z f₁)
        · (## F α : _ ⟹ _) ((η X : _ ⟶ _) (id₁ X)).
  Proof.
    cbn ; unfold yoneda_unit_component_mod_component_nat_component.
    pose (nat_trans_eq_pointwise (psnaturality_inv_natural η _ _ _ _ α) (id₁ X)).
    cbn in p.
    refine (!_).
    etrans.
    {
      refine (!(assoc _ _ _) @ _).
      apply maponpaths.
      exact (nat_trans_eq_pointwise (psnaturality_inv_natural η _ _ _ _ α) (id₁ X)).
    }
    cbn.
    refine (assoc _ _ _ @ _ @ !(assoc _ _ _)).
    apply maponpaths_2.
    refine (!(functor_comp _ _ _) @ _ @ functor_comp _ _ _).
    apply maponpaths.
    refine (!_).
    refine (rinvunitor_natural _ @ _).
    apply maponpaths.
    refine (!_).
    apply rwhisker_hcomp.
  Qed.

  Definition yoneda_unit_component_mod_component_nat
             (η : pstrans (representable B_is_univalent_2_1 X) F)
    : modification_data
        ((functor_identity (hom_data (representable B_is_univalent_2_1 X) F)) η)
        ((yoneda_to_presheaf ∙ presheaf_to_yoneda) η).
  Proof.
    intro Z.
    use make_nat_trans.
    - exact (yoneda_unit_component_mod_component_nat_component η Z).
    - exact (yoneda_unit_component_mod_component_is_nat_trans η Z).
  Defined.

  Lemma yoneda_unit_component_is_modification
             (η : pstrans (representable B_is_univalent_2_1 X) F)
    : is_modification (yoneda_unit_component_mod_component_nat η).
  Proof.
    intros Z₁ Z₂ f.
    apply nat_trans_eq.
    { apply homset_property. }
    intro g ; cbn in g.
    cbn.
    unfold yoneda_unit_component_mod_component_nat_component, yoneda_to_presheaf_data_ob,
    presheaf_to_yoneda_ob_pstrans_nat_trans_data.
    cbn in f.
    etrans.
    {
      do 2 apply maponpaths.
      exact (nat_trans_eq_pointwise (pstrans_inv_comp_alt η g f) (id₁ X)).
    }
    cbn.
    rewrite !id_right.
    rewrite !assoc.
    apply maponpaths_2.
    refine (!_).
    etrans.
    {
      apply functor_comp.
    }
    apply maponpaths_2.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      refine (!(assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        refine (!_).
        apply functor_comp.
      }
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply rinvunitor_triangle.
      }
      cbn.
      refine (vassocl _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        apply lassociator_rassociator.
      }
      apply id2_right.
    }
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      exact (pr21 (psnaturality_of η f) g (g · id₁ X) (rinvunitor g)).
    }
    cbn.
    etrans.
    {
      refine (!(assoc _ _ _) @ _).
      apply maponpaths.
      exact (nat_trans_eq_pointwise (vcomp_rinv (psnaturality_of η f)) (g · id₁ X)).
    }
    apply id_right.
  Qed.

  Definition yoneda_unit_component_mod
             (η : pstrans (representable B_is_univalent_2_1 X) F)
    : modification
        (functor_identity (hom_data (representable B_is_univalent_2_1 X) F) η)
        ((yoneda_to_presheaf ∙ presheaf_to_yoneda) η).
  Proof.
    use make_modification.
    - exact (yoneda_unit_component_mod_component_nat η).
    - exact (yoneda_unit_component_is_modification η).
  Defined.

  Lemma yoneda_unit_is_nat_trans
    : is_nat_trans
        (functor_identity (hom_data (representable B_is_univalent_2_1 X) F))
        (yoneda_to_presheaf ∙ presheaf_to_yoneda)
        yoneda_unit_component_mod.
  Proof.
    intros η₁ η₂ m.
    apply modification_eq.
    intros Z.
    apply nat_trans_eq.
    { apply homset_property. }
    intros g ; cbn in g.
    cbn.
    unfold yoneda_unit_component_mod_component_nat_component, yoneda_to_presheaf_data_ob,
    presheaf_to_yoneda_mor_modification_nat_trans_data,
    yoneda_to_presheaf_data_mor.
    refine (!_).
    etrans.
    {
      rewrite <- assoc.
      apply maponpaths.
      exact (!(nat_trans_eq_pointwise (mod_inv_naturality_of m X Z g) (id₁ X))).
    }
    simpl.
    rewrite !assoc.
    apply maponpaths_2.
    exact (pr2 ((m : modification _ _) Z) _ _ (rinvunitor g)).
  Qed.

  Definition yoneda_unit
    : functor_identity _ ⟹ yoneda_to_presheaf ∙ presheaf_to_yoneda.
  Proof.
    use make_nat_trans.
    - exact yoneda_unit_component_mod.
    - exact yoneda_unit_is_nat_trans.
  Defined.

  Lemma yoneda_unit_is_inverses
             (g : pstrans (representable B_is_univalent_2_1 X) F)
             (Z : B)
             (Y : Z --> X)
    :  is_inverse_in_precat
         (# (g Z : _ ⟶ _) (rinvunitor Y) · pr1 ((psnaturality_of g Y) ^-1) (id₁ X))
         ((pr11 (psnaturality_of g Y)) (id₁ X) · # (g Z : _ ⟶ _) (runitor Y)).
  Proof.
    split.
    - rewrite <- !assoc.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          rewrite assoc.
          apply maponpaths_2.
          exact (nat_trans_eq_pointwise (vcomp_linv (psnaturality_of g Y)) (id₁ X)).
        }
        apply id_left.
      }
      refine (!(functor_comp _ _ _) @ _ @ functor_id (g Z) _).
      apply maponpaths.
      exact (rinvunitor_runitor Y).
    - rewrite <- !assoc.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          rewrite assoc.
          apply maponpaths_2.
          refine (!(functor_comp (g Z) _ _) @ _ @ functor_id (g Z) _).
          apply maponpaths.
          apply runitor_rinvunitor.
        }
        apply id_left.
      }
      exact (nat_trans_eq_pointwise (vcomp_rinv (psnaturality_of g Y)) (id₁ X)).
  Qed.

  Definition yoneda_unit_z_iso
             (g : pstrans (representable B_is_univalent_2_1 X) F)
             (Z : B)
             (Y : Z --> X)
    : is_z_isomorphism (# (g Z : _ ⟶ _) (rinvunitor Y) · pr1 ((psnaturality_of g Y) ^-1) (id₁ X)).
  Proof.
    use tpair.
    - exact (pr11 (psnaturality_of g Y) (id₁ X) · #(g Z : _ ⟶ _) (runitor Y)).
    - exact (yoneda_unit_is_inverses g Z Y).
  Defined.

  Definition yoneda_counit_component
             (Z : pr1 (F X))
    : pr1 (F X) ⟦ (# F (id₁ X) : _ ⟶ _) Z, Z ⟧
    := pr1 ((psfunctor_id F X)^-1) Z.

  Lemma yoneda_counit_is_natural
    : is_nat_trans
        _
        (functor_identity _)
        yoneda_counit_component.
  Proof.
    intros Z₁ Z₂ h ; cbn.
    unfold yoneda_counit_component.
    pose (pr2 ((psfunctor_id F X)^-1) _ _ h) as p.
    exact p.
  Qed.

  Definition yoneda_counit
    : presheaf_to_yoneda ∙ yoneda_to_presheaf ⟹ functor_identity _.
  Proof.
    use make_nat_trans.
    - exact yoneda_counit_component.
    - exact yoneda_counit_is_natural.
  Defined.

  Definition bicategorical_yoneda_lemma
    : left_adjoint_equivalence yoneda_to_presheaf.
  Proof.
    apply equiv_to_isadjequiv.
    use tpair.
    - use tpair.
      + exact presheaf_to_yoneda.
      + split.
        * exact yoneda_unit.
        * exact yoneda_counit.
    - split.
      + cbn.
        apply is_nat_z_iso_to_is_invertible_2cell.
        intro g.
        apply is_inv2cell_to_is_z_iso.
        apply make_is_invertible_modification.
        intro Z.
        apply is_nat_z_iso_to_is_invertible_2cell.
        intros Y.
        exact (yoneda_unit_z_iso g Z Y).
      + apply is_nat_z_iso_to_is_invertible_2cell.
        intros Z ; cbn.
        unfold yoneda_counit_component.
        exists (pr1 (pr1 (psfunctor_id F X)) Z).
        split.
        * abstract (exact (nat_trans_eq_pointwise
                             (vcomp_linv (psfunctor_id F X)) Z)).
        * abstract (exact (nat_trans_eq_pointwise
                             (vcomp_rinv (psfunctor_id F X)) Z)).
  Defined.

  Definition bicategorical_yoneda_lemma_inv
    : left_adjoint_equivalence presheaf_to_yoneda
    := inv_adjequiv (_ ,, bicategorical_yoneda_lemma).

End YonedaLemma.

Section YonedaLocalEquivalence.
  Context {B : bicat}.
  Variable (B_is_univalent_2_1 : is_univalent_2_1 B)
           (X Y : B).

  Definition yoneda_to_presheaf_representable_component_mod_component_nat
             (f : X --> Y)
             (Z : B)
             (g : Z --> X)
    : g · f ==> g · f
    := id₂ (g · f).

  Lemma yoneda_to_presheaf_representable_component_mod_is_nat_trans
             (f : X --> Y)
             (Z : B)
    : is_nat_trans
        (representable1 B_is_univalent_2_1 f Z : _ ⟶ _)
        (presheaf_to_yoneda_ob
           B_is_univalent_2_1
           (representable B_is_univalent_2_1 Y)
           X f Z
         : _ ⟶ _)
        (yoneda_to_presheaf_representable_component_mod_component_nat f Z).
  Proof.
    intros h₁ h₂ α.
    cbn in *.
    unfold yoneda_to_presheaf_representable_component_mod_component_nat.
    rewrite id2_left,id2_right.
    apply idpath.
  Qed.

  Definition yoneda_to_presheaf_representable_component_mod_component
             (f : X --> Y)
    : modification_data
        (representable1 B_is_univalent_2_1 f)
        (presheaf_to_yoneda_ob
           B_is_univalent_2_1
           (representable B_is_univalent_2_1 Y) X f).
  Proof.
    intros Z.
    use make_nat_trans.
    - exact (yoneda_to_presheaf_representable_component_mod_component_nat f Z).
    - exact (yoneda_to_presheaf_representable_component_mod_is_nat_trans f Z).
  Defined.

  Lemma yoneda_to_presheaf_representable_is_modification
             (f : X --> Y)
    : is_modification (yoneda_to_presheaf_representable_component_mod_component f).
  Proof.
    intros Z₁ Z₂ h.
    apply nat_trans_eq.
    { apply homset_property. }
    intros g.
    cbn in *.
    unfold yoneda_to_presheaf_representable_component_mod_component_nat.
    rewrite id2_right, lwhisker_id2, id2_left.
    apply idpath.
  Qed.

  Definition yoneda_to_presheaf_representable_component_mod
             (f : X --> Y)
    : modification
        (Fmor (y B_is_univalent_2_1) X Y f)
        ((presheaf_to_yoneda
            B_is_univalent_2_1
            (representable B_is_univalent_2_1 Y)
            X
          : _ ⟶ _) f).
  Proof.
    use make_modification.
    - exact (yoneda_to_presheaf_representable_component_mod_component f).
    - exact (yoneda_to_presheaf_representable_is_modification f).
  Defined.

  Lemma yoneda_to_presheaf_representable_is_natural
    : is_nat_trans
        (Fmor_data (y B_is_univalent_2_1) X Y)
        _
        yoneda_to_presheaf_representable_component_mod.
  Proof.
    intros g₁ g₂ α.
    apply modification_eq.
    intros Z.
    apply nat_trans_eq.
    { apply homset_property. }
    intros h.
    cbn in *.
    unfold yoneda_to_presheaf_representable_component_mod_component_nat.
    rewrite id2_right, id2_left.
    apply idpath.
  Qed.

  Definition yoneda_to_presheaf_representable
    : (Fmor_univ  (y B_is_univalent_2_1) X Y _ _)
        ⟹
        (presheaf_to_yoneda
           B_is_univalent_2_1
           (representable B_is_univalent_2_1 Y)
           X
         : _⟶ _).
  Proof.
    use make_nat_trans.
    - exact yoneda_to_presheaf_representable_component_mod.
    - exact yoneda_to_presheaf_representable_is_natural.
  Defined.

  Definition yoneda_to_presheaf_representable_is_iso
    : @is_invertible_2cell
        bicat_of_univ_cats
        _ _
        (Fmor_univ (y B_is_univalent_2_1) X Y _ _ : _ ⟶ _)
        _ (yoneda_to_presheaf_representable).
  Proof.
    apply is_nat_z_iso_to_is_invertible_2cell.
    intro g.
    apply is_inv2cell_to_is_z_iso.
    apply make_is_invertible_modification.
    intro Z.
    apply is_nat_z_iso_to_is_invertible_2cell.
    intros h.
    cbn in *.
    unfold yoneda_to_presheaf_representable_component_mod_component_nat.
    apply is_inv2cell_to_is_z_iso.
    is_iso.
  Defined.

  Definition yoneda_mor_is_equivalence
    : @left_adjoint_equivalence
        bicat_of_univ_cats
        _ _
        (Fmor_univ
           (y B_is_univalent_2_1)
           X Y
           B_is_univalent_2_1
           (psfunctor_bicat_is_univalent_2_1
              (op1_bicat B) _
              univalent_cat_is_univalent_2_1)).
  Proof.
    apply equiv_to_isadjequiv.
    exact (@left_equivalence_invertible
            bicat_of_univ_cats
            _
            _
            _
            (presheaf_to_yoneda
               B_is_univalent_2_1
               (representable B_is_univalent_2_1 Y)
               X
             : _⟶ _)
            (bicategorical_yoneda_lemma_inv B_is_univalent_2_1 _ _)
            _
            yoneda_to_presheaf_representable_is_iso).
  Defined.

End YonedaLocalEquivalence.

Definition yoneda_local_equivalence
           {B : bicat}
           (B_is_univalent_2_1 : is_univalent_2_1 B)
  : local_equivalence
      B_is_univalent_2_1
      (psfunctor_bicat_is_univalent_2_1
         (op1_bicat B) _
         univalent_cat_is_univalent_2_1)
      (y B_is_univalent_2_1).
Proof.
  intros x y.
  apply yoneda_mor_is_equivalence.
Defined.

Definition rezk_completion_2_0
           (B : bicat)
           (HB : is_univalent_2_1 B)
  : ∑ (GC : bicat)
      (CB : psfunctor B GC)
      (HGC : is_univalent_2 GC),
    weak_equivalence HB (pr2 HGC) CB.
Proof.
  refine (full_image (y HB) ,, _).
  refine (corestrict_full_image (y HB) ,, _).
  use tpair.
  - apply is_univalent_2_full_image.
    apply psfunctor_bicat_is_univalent_2.
    exact univalent_cat_is_univalent_2.
  - exact (corestrict_full_image_weak_equivalence
             (y HB)
             HB
             _
             _
             (yoneda_local_equivalence HB)).
Defined.