(*
int crypto_scalarmult(u8 *q,const u8 *n,const u8 *p)
{
  u8 z[32];
  // i64 x[80],r,i;
  i64 r;
  int i;
  gf x,a,b,c,d,e,f;
  FOR(i,31) z[i]=n[i];
  z[31]=(n[31]&127)|64;
  z[0]&=248;
  unpack25519(x,p);
  FOR(i,16) {
    b[i]=x[i];
    d[i]=a[i]=c[i]=0;
  }
  a[0]=d[0]=1;
  for(i=254;i>=0;--i) {
    r=(z[i>>3]>>(i&7))&1;
    sel25519(a,b,r);
    sel25519(c,d,r);
    A(e,a,c);
    Z(a,a,c);
    A(c,b,d);
    Z(b,b,d);
    S(d,e);
    S(f,a);
    M(a,c,a);
    M(c,b,e);
    A(e,a,c);
    Z(a,a,c);
    S(b,a);
    Z(c,d,f);
    M(a,c,_121665);
    A(a,a,d);
    M(c,c,a);
    M(a,d,f);
    M(d,b,x);
    S(b,e);
    sel25519(a,b,r);
    sel25519(c,d,r);
  }
  inv25519(c,c);
  M(a,c,c);
  pack25519(q,a);
  return 0;
}
*)

Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl.Libs.Export.
Require Import Tweetnacl_verif.init_tweetnacl.
Require Import Tweetnacl_verif.spec_sel25519.
Require Import Tweetnacl_verif.spec_unpack25519.
Require Import Tweetnacl_verif.spec_pack25519.
Require Import Tweetnacl_verif.spec_A.
Require Import Tweetnacl_verif.spec_Z.
Require Import Tweetnacl_verif.spec_S.
Require Import Tweetnacl_verif.spec_M.
Require Import Tweetnacl_verif.spec_inv25519.
Require Import Tweetnacl_verif.spec_crypto_scalarmult.
Require Import Tweetnacl_verif.spec_pack25519.
Require Import Tweetnacl_verif.verif_crypto_scalarmult_lemmas.
Require Import Tweetnacl.Low.Export.
Require Import Tweetnacl.Low.M.
Require Import Tweetnacl.Low.S.
Require Import Tweetnacl.Low.Prep_n.
Require Import Tweetnacl.Low.Get_abcdef.
Require Import Tweetnacl.Low.ScalarMult_rev.
Require Import Tweetnacl.Low.GetBit.
Require Import Tweetnacl.Low.Inv25519.
Require Import Tweetnacl.Low.Constant.
Require Import Tweetnacl.Low.Pack25519.
Require Import Tweetnacl.Low.Crypto_Scalarmult.
Require Import Tweetnacl.Low.Crypto_Scalarmult_.
Require Import Tweetnacl.Low.ScalarMult_gen_small.
Require Import Tweetnacl.Low.ScalarMult_rev.
Require Import Tweetnacl.Mid.Instances.
Require Import Tweetnacl.Gen.ABCDEF.
Require Import Tweetnacl.rfc.rfc.

Open Scope Z.

Import Low.

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
      ltac:(with_library prog
        [sel25519_spec; pack25519_spec;
         inv25519_spec; unpack25519_spec;
         A_spec; Z_spec; M_spec; S_spec]).

Definition _121665_contents := C_121665.

Ltac solve_montgomery_rec_rev_Zlength :=
  repeat match goal with
    | _ => omega
    | _ => rewrite Zlength_map
    | _ => rewrite Sel25519_Zlength
    | _ => rewrite M_Zlength
    | _ => rewrite Sq_Zlength
    | _ => rewrite A_Zlength
    | _ => rewrite Zub_Zlength
    | _ => rewrite fa_Zlength
    | _ => rewrite fb_Zlength
    | _ => rewrite fc_Zlength
    | _ => rewrite fd_Zlength
    | _ => rewrite fe_Zlength
    | _ => rewrite ff_Zlength
    | _ => rewrite get_a_montgomery_fn_Zlength
    | _ => rewrite get_b_montgomery_fn_Zlength
    | _ => rewrite get_c_montgomery_fn_Zlength
    | _ => rewrite get_d_montgomery_fn_Zlength
    | _ => rewrite get_e_montgomery_fn_Zlength
    | _ => rewrite get_f_montgomery_fn_Zlength
  end ; try reflexivity.

Local Ltac solve_montgomery_bounds :=
  repeat (split ; try assumption);
  match goal with
    | |- Forall _ _ => solve_bounds_by_values_Forall_impl
    | |- Zlength _ = _ => solve_montgomery_rec_rev_Zlength
    | |- _ => auto
   end.

Local Ltac solve_equiv_fabcdef i :=
  clean_context_from_VST;
  repeat match goal with
   | [H: context[Zlength] |- _ ] => clear H
   | [H: context[Forall] |- _ ] => clear H
   | [H: _ <> _ |- _ ] => clear H
  end;
  clears sh;
  rewrite -?fa_step -?fb_step -?fc_step -?fd_step -?fe_step -?ff_step;
  [| assumption];
  replace (254 - (254 - i)) with i ; [|omega];
  subst; simpl;
  reflexivity.

Theorem body_crypto_scalarmult: semax_body Vprog Gprog f_crypto_scalarmult_curve25519_tweet crypto_scalarmult_spec.
Proof.
name v__121665 __121665.
  start_function.
unfold Sfor.
freeze [0;1;2;3;4;5;6;8;10;11] F.
freeze_local L.
forward_for_simple_bound 31 (crypto_scalarmult_Zinit_Inv F L sh v_z v_n n) ; subst L.
thaw_local.
- entailer!.
- forward.
  entailer!.
  clean_context_from_VST.
  solve_bounds_by_values_f (fun x : ℤ => 0 <= x < 2 ^ 8).
  forward.
  entailer!.
  clean_context_from_VST.
  unfold data_at.
  replace_cancel.

(*   symmetry. *)
  by apply firstn_skipn_upd_Znth_undef32.

  assert(0 < Zlength (firstn 31 n)).
  by apply Zlength_firstn_32_str_pos.

  assert(0 < Zlength (firstn 31 (map Vint (map Int.repr n)))).
  by rewrite -?map_firstn ?Zlength_map.

  assert(0 <= 31 < Zlength (firstn 31 (map Vint (map Int.repr n)) ++ [Vundef])).
  change 31%nat with (Z.to_nat 31).
  rewrite Zlength_app -?map_firstn ?Zlength_map ?Zlength_firstn ?Z.max_r ?Z.min_l ; simpl ; omega.
(* END OF FIRST FOR LOOP *)

forward. (* z[31]=(n[31]&127)|64; *)
entailer!.
clean_context_from_VST.
solve_bounds_by_values_f (fun x : ℤ => 0 <= x < 2 ^ 8).
forward.
forward.
entailer!.
clean_context_from_VST.
by apply isInt8Unsignedcontents_n.
simpl.
rewrite upd_Znth_diff ; try omega.
orewrite app_Znth1.
rewrite -?map_firstn map_map (Znth_map 0) ; try omega.

forward. (* z[0]&=248; *)
rewrite -clamped_n.
2: done.
2: done.

thaw F.
(* CALL FOR UNPACK25519 *)
rewrite /data_at_ /field_at_ /default_val /reptype_gen.
simpl.
assert(Hreadablesh: readable_share sh) by (by apply writable_readable).
assert(HwritableTsh : writable_share Tsh) by apply writable_share_top.
repeat match goal with
  | |- context[field_at Tsh lg16 [] ?A _] => change A with undef16
end.
match goal with
  | |- context[data_at Ews lg16 ?A _] => change A with (mVI64 C_121665)
end.
Ltac data_atify := repeat match goal with
  | |- context[field_at ?A ?B _ ?D ?E] => change (field_at A B [] D E) with (data_at A B D E)
end.
data_atify.
(* flatten_sepcon_in_SEP. *)
freeze [0; 1; 2; 3; 4; 5; 7; 9; 10] F.
sort.
forward_call (v_x, v_p, sh, Tsh, undef16 , p).
thaw F.
freeze_local L.
unfold Sfor.
assert(Zlength (Unpack25519 p) = 16).
by apply Unpack25519_Zlength.
freeze [0;2;3;8;9;10;11] F.
forward_for_simple_bound 16 (crypto_scalarmult_BDACinit_Inv F L sh v_x v_a v_b v_c v_d (Unpack25519 p)) ; subst L.
thaw_local.
entailer!.
assert(Haux1: exists aux1, Vlong aux1 = Znth i (map Vlong (map Int64.repr (Unpack25519 p))) Vundef)
  by (erewrite (Znth_map Int64.zero) ; [exists; reflexivity|]; rewrite Zlength_map; omega).
destruct Haux1 as [aux Haux].
forward ; rewrite -Haux.
entailer!.
do 6 forward.
rewrite ?map_firstn Haux.
rewrite <- (upd_Znth_app_step_Zlength i (map Vlong (map Int64.repr (Unpack25519 p)))) ; try omega.
unfold nat_of_Z ; rewrite ?Z2Nat.inj_succ.
replace (Z.to_nat (16 - (i + 1))) with (16 - S (Z.to_nat i))%nat.

2 : rewrite Z2Nat.inj_sub ; try omega ; rewrite Z2Nat.inj_succ ; try omega ; f_equal.
2: omega.
2: rewrite undef16_Zlength ; omega.
2: rewrite ?Zlength_map ; omega.
assert(H' := upd_Znth_app_step_Zlength i (mVI64 C_0) (undef16) Vundef).
rewrite ?H' ?undef16_Zlength ?Zlength_map ?nil16_Zlength ; try omega.

simpl cast_int_long.
replace (Znth i (mVI64 gf0) Vundef) with (Vlong (Int64.repr 0)).
2: clean_context_from_VST ; by apply Znth_nil16.
change nil16 with C_0.
entailer!.
rewrite ?list.drop_ge ?app_nil_r ?list.take_ge.

2: rewrite ?map_length ?nil16_length ; change 16%nat with (Z.to_nat 16) ; rewrite -Z2Nat.inj_le; omega.

2: {
rewrite ?map_length  Unpack25519_length.
change 16%nat with (Z.to_nat 16).
rewrite -Z2Nat.inj_le; omega.
rewrite Zlength_correct in H3.
omega.
}

2: rewrite undef16_length; change 16%nat with (Z.to_nat 16) ; rewrite -Z2Nat.inj_le; omega.

(* OUT OF THE SECOND LOOP *)
do 3 forward.

change ((upd_Znth 0
        (mVI64 nil16) (Vlong (cast_int_long Signed (Int.repr 1))))) with
         (map Vlong (map Int64.repr gf1)).

(* START THE BIG LOOP *)
thaw F.

change nil16 with C_0.
pose (Unpack25519 p) as x.
pose (gf1)  as a.
pose (Unpack25519 p) as b.
pose (gf0)  as c.
pose (gf1)  as d.
pose (Prep_n.clamp n) as z.
deadvars!.
data_atify.
change (data_at Tsh (tarray tuchar 32) (map Vint (map Int.repr (Prep_n.clamp n))) v_z) with
 (data_at Tsh (tarray tuchar 32) (map Vint (map Int.repr z)) v_z).
change (data_at Tsh (tarray tlg 16) (mVI64 (Unpack25519 p)) v_b) with
 (data_at Tsh (tarray tlg 16) (mVI64 (b)) v_b).
change (data_at Tsh (tarray tlg 16) (mVI64 gf1) v_a) with
 (data_at Tsh (tarray tlg 16) (mVI64 a) v_a).
change (data_at Tsh (tarray tlg 16) (mVI64 gf1) v_d) with
 (data_at Tsh (tarray tlg 16) (mVI64 d) v_d).
change (data_at Tsh (tarray tlg 16) (mVI64 nil16) v_c) with
 (data_at Tsh (tarray tlg 16) (mVI64 c) v_c).
change (data_at Tsh (tarray tlg 16) (mVI64 (Unpack25519 p)) v_x) with
 (data_at Tsh (tarray tlg 16) (mVI64 x) v_x).

freeze [0;3;6] F.

assert(Zlength(z) = 32). subst z; by apply Prep_n.clamp_Zlength.
assert(Zlength(a) = 16). subst a; reflexivity.
assert(Zlength(c) = 16). subst c; reflexivity.
assert(Zlength(d) = 16). subst d; reflexivity.
assert(Zlength(b) = 16). by subst b.
assert(Zlength(x) = 16). by subst x.
assert(Zlength(C_121665) = 16). reflexivity.

assert(Forall (fun x => 0 <= x < Z.pow 2 8) z).
  subst z. by apply Prep_n.clamp_bound.
assert(Forall (fun x => -38 <= x < Z.pow 2 16 + 38) a).
  subst a ; change (2^16 + 38) with 65574;
  repeat (rewrite list.Forall_cons ; split; [omega|]) ; apply Forall_nil.
assert(Forall (fun x => -38 <= x < Z.pow 2 16 + 38) b).
  subst b. eapply list.Forall_impl.
  by apply Unpack25519_bounded. intros y Hx ; simpl in Hx ; omega.
assert(Forall (fun x => -38 <= x < Z.pow 2 16 + 38) c).
  subst c ; change (2^16 + 38) with 65574;
  repeat (rewrite list.Forall_cons ; split; [omega|]) ; apply Forall_nil.
assert(Forall (fun x => -38 <= x < Z.pow 2 16 + 38) d).
  subst d ; change (2^16 + 38) with 65574;
  repeat (rewrite list.Forall_cons ; split; [omega|]) ; apply Forall_nil.
assert(Forall (fun x => 0 <= x < Z.pow 2 16) x).
  by apply Unpack25519_bounded.
assert(Forall (fun x => 0 <= x < Z.pow 2 16) C_121665).
  unfold C_121665 ; repeat apply Forall_cons ; solve_bounds_by_values.
  apply Forall_nil.

forward_for
(* Loop Invariant *)
(crypto_scalarmult_ladder_Inv F sh v_z v_x v_a v_b v_c v_d v_e v_f v_q z a b c d x c121665)
(* PreInc invariant *)
(crypto_scalarmult_ladder_PreIncInv F sh v_z v_x v_a v_b v_c v_d v_e v_f v_q z a b c d x c121665)
(* Loop postcondition *)
(crypto_scalarmult_ladder_PostInv F sh v_z v_x v_a v_b v_c v_d v_e v_f v_q z a b c d x c121665).

(* 6 sub goals are generated *)
(* 1 *)
forward.
unfold crypto_scalarmult_ladder_Inv.
Exists 254.
assert(H254: 254 = 254) by reflexivity.
apply Z.eqb_eq in H254.
rewrite /set_undef_array_sep ?H254.
change (254 - 254) with 0.
rewrite montgomery_fn_0 /get_a /get_b /get_c /get_d.

focus_SEP 0 4 6 5 7 8 2 1 9.
solve_bounds_by_values. (* this does nothing but if forces the 2^16 to be in Z and not in Z.pos ! *)
go_lowerx.
rewrite <- andp_assoc.
apply andp_right.
apply andp_right.
apply prop_right.
solve_montgomery_bounds ; omega.
apply prop_right.
repeat split; assumption.
cancel. (* Q |-- Q *)

(* 2 *)
rename a0 into i.
entailer!.
(* 3 *)
rename a0 into i.
assert(0 <= 254 - i) by omega.

Opaque two_p.
assert(Hidiv8: 0 <= i / two_p 3 <= 254 / two_p 3).
  apply i254div8bound ; omega.
assert(Hishr: (0 <= Int.unsigned (Int.shr (Int.repr i) (Int.repr 3)) < Zlength z)).
{
  replace (Zlength z) with 32.
  apply Intusignedshr32 ; omega.
}
assert(Hzlength: 0 <= i / two_p 3 < Zlength z).
{
  change (254 / two_p 3) with 31 in Hidiv8.
  omega.
}
assert(0 <= Z.land i 7 < 32).
  apply izland7_bound ; omega.
assert(HintluTrue : Int.ltu (Int.repr (Z.land i 7)) Int.iwordsize = true).
  apply Intltutrue ; omega.
forward.
entailer!.
solve_bounds_by_values_Znth.
orewrite Int.unsigned_repr.
solve_bounds_by_values.
rewrite Int.shr_div_two_p.
rewrite Int.signed_repr.
2: solve_bounds_by_values.
rewrite (Int.unsigned_repr 3).
2: solve_bounds_by_values.
rewrite Int.unsigned_repr.
2: change (254 / two_p 3) with 31 in Hidiv8 ; solve_bounds_by_values.
forward.
entailer!.
rewrite HintluTrue ; simpl; trivial.
replace (force_val
               (sem_binary_operation' Oand tint tint
                  (eval_binop Oshr tuchar tint (Vint (Int.repr (Znth (i / two_p 3) z 0)))
                     (eval_binop Oand tint tint (Vint (Int.repr i)) (Vint (Int.repr 7))))
                  (Vint (Int.repr 1)))) with
  (Vint (Int.repr (Low.getbit i z))).

2:{
  clean_context_from_VST. clears v_a v_b v_c v_d v_e v_f.
  simpl.
  rewrite and_repr /tuchar /sem_shift ; simpl.
  rewrite HintluTrue ; simpl.
  rewrite Int.shr_div_two_p.
  rewrite Int.unsigned_repr.
  2: solve_bounds_by_values.
  rewrite Int.signed_repr.
  2: solve_bounds_by_values_Znth.
  rewrite and_repr.
  assert(0 <= Z.land (Znth (i / two_p 3) z 0 / two_p (Z.land i 7)) 1 <= 1).
  apply and_0_or_1.
  rewrite /Low.getbit ?Z.shiftr_div_pow2 ?Znth_nth /nat_of_Z ?Z2Nat.id ?two_p_correct; try omega.
  reflexivity.
  apply Z_div_pos.
  reflexivity.
  omega.
  }

  freeze [0;1;4;5;6;7;8;9] L.
  assert(Hgb:= getbit_0_or_1 i z).
  forward_call (v_a, v_b, Tsh,
  (get_a (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x)),
  (get_b (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x)), (Low.getbit i z)).
  repeat split;
  try rewrite get_a_montgomery_fn_Zlength;
  try rewrite get_b_montgomery_fn_Zlength; auto.
  omega.
  thaw L.

  freeze [0;1;2;3;6;7;8;9] L.
  forward_call (v_c, v_d, Tsh,
  (get_c (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x)),
  (get_d (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x)), (Low.getbit i z)).

  repeat split;
  try rewrite get_c_montgomery_fn_Zlength;
  try rewrite get_d_montgomery_fn_Zlength; auto.
  omega.
  thaw L.

  rewrite /set_undef_array_sep.

  remember (Low.Sel25519 (Low.getbit i z) (get_c (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))
                (get_d (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))) as c0;
  remember (Low.Sel25519 (Low.getbit i z) (get_d (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))
           (get_c (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))) as d0;
  remember (Low.Sel25519 (Low.getbit i z) (get_a (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))
           (get_b (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))) as a0;
  remember (Low.Sel25519 (Low.getbit i z) (get_b (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))
           (get_a (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))) as b0.
  assert(Forall (fun x : ℤ => -38 <= x < 2 ^ 16 + 38) a0).
  {
    subst a0; clean_context_from_VST; apply Sel25519_bound_lt_le_id.
    apply get_a_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
    apply get_b_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
  }
  assert(Forall (fun x : ℤ => -38 <= x < 2 ^ 16 + 38) b0).
  {
    subst b0; clean_context_from_VST; apply Sel25519_bound_lt_le_id.
    apply get_b_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
    apply get_a_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
  }
  assert(Forall (fun x : ℤ => -38 <= x < 2 ^ 16 + 38) c0).
  {
    subst c0; clean_context_from_VST; apply Sel25519_bound_lt_le_id.
    apply get_c_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
    apply get_d_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
  }
  assert(Forall (fun x : ℤ => -38 <= x < 2 ^ 16 + 38) d0).
  {
    subst d0; clean_context_from_VST; apply Sel25519_bound_lt_le_id.
    apply get_d_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
    apply get_c_montgomery_fn_bound ; auto.
    apply List_Z_Ops_Prop.
  }
  assert(Zlength a0 = 16). subst; solve_montgomery_rec_rev_Zlength.
  assert(Zlength b0 = 16). subst; solve_montgomery_rec_rev_Zlength.
  assert(Zlength c0 = 16). subst; solve_montgomery_rec_rev_Zlength.
  assert(Zlength d0 = 16). subst; solve_montgomery_rec_rev_Zlength.

  rewrite ?data_at_sh_if.
  remember (if 254 =? i then undef16 else mVI64 (get_f (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))) as f0.
  assert(Zlength f0 = 16).
    subst f0 ; flatten ; solve_montgomery_bounds.
  remember (if 254 =? i then undef16 else mVI64 (get_e (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x))) as e0.
  assert(Zlength e0 = 16).
    subst e0 ; flatten ; solve_montgomery_bounds.
  replace (data_at Tsh (tarray tlg 16)
     (if 254 =? i then undef16 else mVI64 (get_e (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x)))
     v_e) with (data_at Tsh (tarray tlg 16) e0 v_e).
  2: by subst e0.
  replace (data_at Tsh (tarray tlg 16)
     (if 254 =? i then undef16 else mVI64 (get_f (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x)))
     v_f) with (data_at Tsh (tarray tlg 16) f0 v_f).
  2: by subst f0.

  freeze [1;3;4;5;7;8;9] L.

  forward_call (v_e, v_a, v_c, Tsh,Tsh,Tsh,
    e0, a0, -39, 2 ^ 16 + 38, c0, -39, 2 ^ 16 + 38, 4).
  unfold_nm_overlap_array_sep ; simpl; entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  clears e0. (* Heqe0 H57 e0. *)
  assert(Zlength (Low.A a0 c0) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;3;4;5;6;7;8;9] L.
  forward_call (v_a, v_a, v_c, Tsh,Tsh,Tsh,
    (mVI64 a0), a0, -39, 2 ^ 16 + 38, c0, -39, 2 ^ 16 + 38,0).
  unfold_nm_overlap_array_sep ; simpl; entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.Z a0 c0) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;2;5;6;7;8;9] L.
  forward_call (v_c, v_b, v_d, Tsh,Tsh,Tsh,
    (mVI64 c0), b0, -39, 2 ^ 16 + 38, d0, -39, 2 ^ 16 + 38,4).
  unfold_nm_overlap_array_sep ; simpl; entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.A b0 d0) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;3;4;5;6;7;8;9] L.
  forward_call (v_b, v_b, v_d, Tsh,Tsh,Tsh,
    (mVI64 b0), b0, -39, 2 ^ 16 + 38, d0, -39, 2 ^ 16 + 38,0).
  unfold_nm_overlap_array_sep ; simpl;entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.Z b0 d0) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;2;3;5;6;7;8;9] L.
  forward_call (v_d, v_e, Tsh,Tsh,
    (mVI64 d0), (Low.A a0 c0),1).
  unfold_nm_overlap_array_sep ; simpl;entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  freeze [0;1;2;3;5;6;8;9] L.
  forward_call (v_f, v_a, Tsh,Tsh,
    f0, (Low.Z a0 c0),1).
  unfold_nm_overlap_array_sep ; simpl;entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  clears f0.

  freeze [0;2;3;4;6;7;8;9] L.
  forward_call (v_a, v_c, v_a, Tsh, Tsh, Tsh,
    (mVI64 (Low.Z a0 c0)), (Low.A b0 d0), (Low.Z a0 c0),1).
  unfold_nm_overlap_array_sep ; simpl;entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.M (Low.A b0 d0) (Low.Z a0 c0)) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;2;3;6;7;8;9] L.
  forward_call (v_c, v_b, v_e, Tsh, Tsh, Tsh,
    (mVI64 (Low.A b0 d0)), (Low.Z b0 d0), (Low.A a0 c0),4).
  unfold_nm_overlap_array_sep ; simpl;entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.M (Low.Z b0 d0) (Low.A a0 c0)) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [1;4;5;6;7;8;9] L.
  remember (Low.M (Low.Z b0 d0) (Low.A a0 c0)) as c1.
  remember (Low.M (Low.A b0 d0) (Low.Z a0 c0)) as a1.
  assert(Zlength c1 = 16). auto.
  assert(Zlength a1 = 16). auto.
  forward_call (v_e, v_a, v_c, Tsh, Tsh, Tsh,
    (mVI64 (Low.A a0 c0)), a1, -39, 2 ^ 16 + 38, c1, -39, 2 ^ 16 + 38, 4).
  unfold_nm_overlap_array_sep ; simpl.
  cancel.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.A a1 c1) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;3;4;5;6;7;8;9] L.
  forward_call (v_a, v_a, v_c, Tsh, Tsh, Tsh,
    (mVI64 a1), a1, -39, 2 ^ 16 + 38, c1, -39, 2 ^ 16 + 38, 0).
  unfold_nm_overlap_array_sep ; simpl.
  cancel.
  entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.Z a1 c1) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [1;2;4;5;6;7;8;9] L.
  forward_call (v_b, v_a, Tsh, Tsh,
    (mVI64 (Low.Z b0 d0)), (Low.Z a1 c1), 1).
  unfold_nm_overlap_array_sep ; simpl; cancel.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  freeze [0;1;3;6;7;8;9] L.
  remember (Low.S (Low.A a0 c0)) as d1.
  remember (Low.S (Low.Z a0 c0)) as f1.
  assert(Zlength d1 = 16). auto.
  assert(Zlength d1 = 16). auto.

  forward_call (v_c, v_d, v_f, Tsh, Tsh, Tsh,
   (mVI64 c1) , d1, -39, 2 ^ 16 + 38, f1, -39, 2 ^ 16 + 38, 4).
  unfold_nm_overlap_array_sep ; simpl; cancel.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.Z d1 f1) = 16).
    solve_montgomery_rec_rev_Zlength.

  sort.

  freeze [1;2;3;5;6;7;8] L.
  remember (Low.Z a1 c1) as a2.
  remember (Low.Z d1 f1) as c2.
  assert(Zlength a2 = 16). auto.
  assert(Zlength c2 = 16). auto.

  forward_call (v_a, v_c, c121665, Tsh, Tsh, Ews,
   (mVI64 a2) , c2, C_121665,4).
  unfold_nm_overlap_array_sep ; simpl; cancel.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.M c2 C_121665) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [1;2;4;5;6;7;8;9] L.
  remember (Low.M c2 C_121665) as a3.
  assert(Zlength a3 = 16). auto.

  forward_call (v_a, v_a, v_d, Tsh, Tsh, Tsh,
   mVI64 a3, a3, -39, 2 ^ 16 + 38, d1, -39, 2 ^ 16 + 38,0).
  unfold_nm_overlap_array_sep ; simpl;
  cancel.
  entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.A a3 d1) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [1;3;4;5;6;7;8;9] L.
  forward_call (v_c, v_c, v_a, Tsh, Tsh, Tsh,
   (mVI64 c2) , c2, (Low.A a3 d1),0).
  unfold_nm_overlap_array_sep ; simpl; cancel.
  entailer!.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  freeze [0;3;5;6;7;8;9] L.
  forward_call (v_a, v_d, v_f, Tsh, Tsh, Tsh,
   (mVI64 (Low.A a3 d1)) , d1, f1,4).
  unfold_nm_overlap_array_sep ; simpl; cancel.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.M d1 f1) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;2;3;4;6;7;8] L.
  remember (Low.S a2) as b1.
  assert(Zlength b1 = 16). auto.
  forward_call (v_d, v_b, v_x, Tsh, Tsh, Tsh,
   (mVI64 d1), b1, x,4).
  unfold_nm_overlap_array_sep ; simpl; cancel.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  assert(Zlength (Low.M b1 x) = 16).
    solve_montgomery_rec_rev_Zlength.

  freeze [0;2;3;4;5;6;8;9] L.
  forward_call (v_b, v_e, Tsh,Tsh,
   mVI64 b1, Low.A a1 c1,1).
  unfold_nm_overlap_array_sep ; simpl;
  cancel.
  solve_montgomery_bounds.
  unfold_nm_overlap_array_sep ; simpl.
  thaw L.

  remember (Low.S (Low.A a1 c1)) as b2.
  remember (Low.M d1 f1) as a4.
  forward_call (v_a, v_b, Tsh, a4, b2, (Low.getbit i z)).
  solve_montgomery_bounds.
  omega.

  assert(Zlength (Low.M c2 (Low.A a3 d1)) = 16).
    solve_montgomery_rec_rev_Zlength.
  remember(Low.M c2 (Low.A a3 d1)) as c3.
  assert(Zlength c3 = 16). auto.
  remember (Low.M b1 x) as d2.
  assert(Zlength d2 = 16). auto.
  forward_call (v_c, v_d, Tsh, c3, d2, (Low.getbit i z)).
  solve_montgomery_bounds.
  omega.

  (* END OF THE LOOP *)
  (* We must now entail the loop. *)
  (* in other word prove a property correct before the increment but after the first loop *)
  (* In other word crypto_scalarmult_ladder_PreIncInv must be true for i = 254 but after the first loop *)

  (* CURRENT PROPERTY IS WRONG *)
  unfold crypto_scalarmult_ladder_PreIncInv.
  Exists i.
  replace (254 - (i - 1)) with ((254 - i) + 1).
  2: omega.
  remember (montgomery_fn List_Z_Ops (254 - i) 254 z a b c d nil16 nil16 x) as m0.
  replace (get_a (montgomery_fn List_Z_Ops ((254 - i) + 1) 254 z a b c d nil16 nil16 x))
    with (Low.Sel25519 (Low.getbit i z) a4 b2).
  replace (get_b (montgomery_fn List_Z_Ops ((254 - i) + 1) 254 z a b c d nil16 nil16 x))
    with (Low.Sel25519 (Low.getbit i z) b2 a4).
  replace (get_c (montgomery_fn List_Z_Ops ((254 - i) + 1) 254 z a b c d nil16 nil16 x))
    with (Low.Sel25519 (Low.getbit i z) c3 d2).
  replace (get_d (montgomery_fn List_Z_Ops ((254 - i) + 1) 254 z a b c d nil16 nil16 x))
    with (Low.Sel25519 (Low.getbit i z) d2 c3).
  replace (get_e (montgomery_fn List_Z_Ops ((254 - i) + 1) 254 z a b c d nil16 nil16 x))
    with (Low.A a1 c1).
  replace (get_f (montgomery_fn List_Z_Ops ((254 - i) + 1) 254 z a b c d nil16 nil16 x))
    with (f1).

(*   solve_bounds_by_values. (* this does nothing but if forces the 2^16 to be in Z and not in Z.pos ! *) *)
  remember (Low.Sel25519 (Low.getbit i z) c3 d2) as c'.
  remember (Low.Sel25519 (Low.getbit i z) d2 c3) as d'.
  remember (Low.A a1 c1) as e'.
  remember (Low.Sel25519 (Low.getbit i z) a4 b2) as a'.
  remember (Low.Sel25519 (Low.getbit i z) b2 a4) as b'.
  (* this is super slow with cancel and entailer, better do it manually *)
  focus_SEP 8 9 2 3 0 1 4 6 5.
  solve_bounds_by_values. (* this does nothing but if forces the 2^16 to be in Z and not in Z.pos ! *)
  go_lowerx.
  rewrite <- andp_assoc.
  apply andp_right.
  apply andp_right.
  apply prop_right.
  solve_montgomery_bounds ; omega.
  apply prop_right.
  repeat split ; assumption.
  cancel. (* Q |-- Q *)

  solve_equiv_fabcdef i.   (* f equiv *)
  solve_equiv_fabcdef i.   (* e equiv *)
  solve_equiv_fabcdef i.   (* d equiv *)
  solve_equiv_fabcdef i.   (* c equiv *)
  solve_equiv_fabcdef i.   (* b equiv *)
  solve_equiv_fabcdef i.   (* a equiv *)

  (* GOAL 5 *)
  (* INCREMENT *)
  rename a0 into i.
  forward.
  (* END OF THE FOR *)
  (* We must now entail the for. *)
  (* in other word prove a property correct AFTER the increment but after the first loop *)
  (* In other word crypto_scalarmult_ladder_PreIncInv must be true for i < 254 but after the first loop *)
  rewrite sub_repr.
  Exists (i - 1).
  rewrite /set_undef_array_sep.
  assert(H254false: (254 =? i - 1) = false).
  {
    clean_context_from_VST.
    apply Z.eqb_neq; omega.
  }
  rewrite H254false.
  (* this is super slow with cancel and entailer, better do it manually *)
  solve_bounds_by_values. (* this does nothing but if forces the 2^16 to be in Z and not in Z.pos ! *)
  go_lowerx.
  rewrite <- andp_assoc.
  apply andp_right.
  apply andp_right.
  apply prop_right.
  solve_montgomery_bounds ; omega.
  apply prop_right.
  repeat split ; assumption.
  cancel. (* Q |-- Q *)

  (* GOAL 6 *)
  rename a0 into i.
  assert(Hi: i = -1).
  omega.
  rewrite Hi.
  change (254 - -1) with 255.
  unfold crypto_scalarmult_ladder_PostInv.
  rewrite /set_undef_array_sep.
  assert(H254false: (254 =? - 1) = false).
  {
    clean_context_from_VST.
    apply Z.eqb_neq; omega.
  }
  rewrite H254false.

  (* this is super slow with cancel and entailer, better do it manually *)
  remember (montgomery_fn List_Z_Ops 255 254 z a b c d nil16 nil16 x) as m. (* prevent some computing... *)
  go_lowerx.
  rewrite <- andp_assoc.
  apply andp_right.
  apply andp_right.
  apply prop_right.
  solve_montgomery_bounds ; omega.
  apply prop_right.
  repeat split ; assumption.
  cancel. (* Q |-- Q *)
  thaw F.

   freeze [0; 1; 2; 3; 4; 5; 7; 8; 9; 10; 11] F.
   remember (montgomery_fn List_Z_Ops 255 254 z a b c d nil16 nil16 x) as m.
   remember (get_c m) as cc.
   remember (get_a m) as aa.
   assert(Forall (fun x : ℤ => -38 <= x < 2 ^ 16 + 38) cc).
     subst; apply get_c_montgomery_fn_bound ; try assumption.
    apply List_Z_Ops_Prop.
    omega.
   assert(Zlength cc = 16).
     subst; rewrite get_c_montgomery_fn_Zlength ; try assumption ; omega.
   assert(Forall (fun x : ℤ => -38 <= x < 2 ^ 16 + 38) aa).
     subst; apply get_a_montgomery_fn_bound ; try assumption.
    apply List_Z_Ops_Prop.
    omega.
   assert(Zlength aa = 16).
     subst; rewrite get_a_montgomery_fn_Zlength; try assumption.
    omega.

   (* inv25519(c,c); *)
   forward_call (v_c, v_c, Tsh, Tsh, mVI64 cc, cc, 0).
   unfold_nm_overlap_array_sep ; simpl;entailer!.
   solve_montgomery_bounds.
   unfold_nm_overlap_array_sep.
   change (0 =? 0) with true.
   flatten.
   thaw F.
   remember (Inv25519.Inv25519 cc) as ccc.
   freeze [1; 2; 3; 4; 6; 7; 8; 9; 10; 11] L.

   (*  M(a,a,c); *)
   forward_call (v_a, v_a, v_c, Tsh, Tsh, Tsh,
   (mVI64 aa) , aa, ccc, 0).
   unfold_nm_overlap_array_sep ; simpl;entailer!.
   solve_montgomery_bounds.
   unfold_nm_overlap_array_sep ; simpl.
   thaw L.

  deadvars!.

  freeze [1;2;4;5;6;7;8;9;10;11] F.
  forward_call (v_q, v_a, Tsh, sh, q, (Low.M aa ccc)).
  repeat (split ; try assumption).
  apply writable_readable ; auto.
  solve_bounds_by_values_Forall_impl.
  apply M_Zlength ; try assumption.
  thaw F.
  replace (Pack25519 (Low.M aa ccc)) with (Crypto_Scalarmult n p).
  deadvars!.
  rewrite Crypto_Scalarmult_RFC_eq ; try assumption.
  unfold POSTCONDITION.
  unfold abbreviate.
  remember (RFC n p) as sc.
  eapply (semax_return_Some _ _ _ _ _ (stackframe_of f_crypto_scalarmult_curve25519_tweet)
    [Tsh [{v_a}]<<( lg16 )-- undef16; Tsh [{v_c}]<<( lg16 )-- undef16;
Tsh [{v_z}]<<( uch32 )-- undef32; Tsh [{v_b}]<<( lg16 )-- undef16; Tsh [{v_d}]<<( lg16 )-- undef16;
Tsh [{v_e}]<<( lg16 )-- undef16; Tsh [{v_f}]<<( lg16 )-- undef16; Tsh [{v_x}]<<( lg16 )-- undef16] _ _ _ (Vint (Int.repr 0))).
  go_lowerx.
  entailer!.
  entailer!.
  3: apply return_inner_gen_canon_Some.
  change (ret_type Delta) with tint.
  apply return_outer_gen_refl.

  2: change ([sh [{v_q}]<<( uch32 )-- mVI64 (sc);
          sh [{v_n}]<<( uch32 )-- mVI n; sh [{v_p}]<<( uch32 )-- mVI p;
          Ews [{c121665}]<<( lg16 )-- mVI64 C_121665] ++
          [Tsh [{v_a}]<<( lg16 )-- undef16; Tsh [{v_c}]<<( lg16 )-- undef16; Tsh [{v_z}]<<( uch32 )-- undef32; Tsh [{v_b}]<<( lg16 )-- undef16;
          Tsh [{v_d}]<<( lg16 )-- undef16; Tsh [{v_e}]<<( lg16 )-- undef16; Tsh [{v_f}]<<( lg16 )-- undef16;
          Tsh [{v_x}]<<( lg16 )-- undef16]) with
        ([sh [{v_q}]<<( uch32 )-- mVI64 (sc);
          sh [{v_n}]<<( uch32 )-- mVI n; sh [{v_p}]<<( uch32 )-- mVI p;
          Ews [{c121665}]<<( lg16 )-- mVI64 c_121665 ; Tsh [{v_a}]<<( lg16 )-- undef16; Tsh [{v_c}]<<( lg16 )-- undef16;
          Tsh [{v_z}]<<( uch32 )-- undef32; Tsh [{v_b}]<<( lg16 )-- undef16; Tsh [{v_d}]<<( lg16 )-- undef16;
          Tsh [{v_e}]<<( lg16 )-- undef16; Tsh [{v_f}]<<( lg16 )-- undef16; Tsh [{v_x}]<<( lg16 )-- undef16]).
  2: change ([Forall (fun x0 : ℤ => 0 <= x0 < 2 ^ 8) (sc);
       Zlength (sc) = 32] ++ [Vint (Int.repr 0) = Vint Int.zero]) with
        ([Forall (fun x0 : ℤ => 0 <= x0 < 2 ^ 8) (sc);
       Zlength (sc) = 32; Vint (Int.repr 0) = Vint Int.zero]).

  focus_SEP 2 7 0 3 1 4 5 6.
  eapply canonicalize_stackframe.
  reflexivity.
  repeat (apply Forall2_cons ; [apply fn_data_at_intro ; reflexivity|]).
  apply Forall2_nil.
  go_lowerx.
  rewrite <- andp_assoc.
  apply andp_right.
  apply andp_right.
  apply prop_right.
  2: by apply prop_right.
  2: cancel. (* Q |-- Q *)
  2: subst aa ccc m cc a b c d x z.
  subst sc.
  rewrite -Crypto_Scalarmult_RFC_eq ; try assumption.
  all: rewrite -Crypto_Scalarmult_eq.
  2: reflexivity.
  split ; [|split]; rewrite /Crypto_Scalarmult_proof.
  3: split ; trivial.
  all: rewrite -?Heqm -?Heqcc -?Heqaa  -?Heqccc.
  apply Pack25519_bound.
  apply M_Zlength ; assumption.
  solve_bounds_by_values_Forall_impl.
  rewrite /Pack25519.
  apply Pack.pack_for_Zlength_32_16.
  apply Reduce_by_P.get_t_subst_select_Zlength.
  omega.
  reflexivity.
  do 3 apply car25519_Zlength.
  apply M_Zlength ; assumption.
Qed.


Require Import HoTT.
From GR Require Import general polynomial setoid.

(** The quotient over an setoid. *)
Definition squot (R : setoid) : Type
  := quotient (rel R).

(** The equality of `squot` is given by the setoid. *)
Definition setoid_quotient_path (R : setoid) `{Univalence}
  : forall {a₁ a₂ : under R}, class_of (rel R) a₁ = class_of (rel R) a₂ <~> rel R a₁ a₂
  := sets_exact (rel R).

(** Every `0`-type (set) can be written as a `squot`. *)
Section set_is_setoid_quotient.
  Variable (A : hSet).

  Definition squot_to_A : squot (path_setoid A) -> A
    := quotient_rec (rel (path_setoid A)) idmap (fun _ _ => idmap).

  Global Instance squot_to_A_isequiv : IsEquiv squot_to_A.
  Proof.
    simple refine (isequiv_adjointify _ (class_of (rel (path_setoid A))) _ _).
    - intros x ; reflexivity.
    - unfold Sect.
      simple refine (quotient_ind _ _ _ _).
      + reflexivity.
      + intros.
        apply path_ishprop.
  Defined.
End set_is_setoid_quotient.

(** Taking the setoid quotient commutes with sums. *)
Section squot_sum.
  Variable (R₁ : setoid) (R₂ : setoid).

  Definition squot_sum_in
             (z : squot R₁ + squot R₂)
    : squot (sum_setoid R₁ R₂).
  Proof.
    destruct z as [z | z].
    - simple refine (quotient_rec _ _ _ z).
      + exact (fun a => class_of _ (inl a)).
      + intros a₁ a₂ p ; cbn in *.
        apply related_classes_eq ; assumption.
    - simple refine (quotient_rec _ _ _ z).
      + exact (fun a => class_of _ (inr a)).
      + intros b₁ b₂ p ; cbn in *.
        apply related_classes_eq ; assumption.
  Defined.

  Definition squot_sum_out
    : squot (sum_setoid R₁ R₂) -> squot R₁ + squot R₂.
  Proof.
    simple refine (quotient_rec _ _ _).
    - intros [z | z].
      + exact (inl(class_of _ z)).
      + exact (inr(class_of _ z)).
    - intros [x | x] [y | y] r ; try contradiction
      ; apply ap ; apply related_classes_eq ; assumption.
  Defined.

  Lemma squot_sum_out_in_sect : Sect squot_sum_out squot_sum_in.
  Proof.
    unfold Sect.
    simple refine (quotient_ind _ _ _ _).
    - intros [z | z] ; reflexivity.
    - intros ; apply path_ishprop.
  Defined.

  Lemma squot_sum_in_out_sect : Sect squot_sum_in squot_sum_out.
  Proof.
    intros [x | x] ; revert x.
    - simple refine (quotient_ind _ _ _ _).
      + intros ; reflexivity.
      + intros ; apply path_ishprop.
    - simple refine (quotient_ind _ _ _ _).
      + intros ; reflexivity.
      + intros ; apply path_ishprop.
  Defined.

  Global Instance squot_sum_out_isequiv : IsEquiv squot_sum_out
    := isequiv_adjointify _ squot_sum_in squot_sum_in_out_sect squot_sum_out_in_sect.
End squot_sum.

(** Taking the setoid quotient commutes with products (assuming function extensionality. *)
Section squot_prod.
  Variable (R₁ : setoid) (R₂ : setoid).
  Context `{Funext}.

  Definition squot_prod_in
             (z : squot R₁ * squot R₂)
    : squot (prod_setoid R₁ R₂).
  Proof.
    destruct z as [z₁ z₂]. revert z₁ z₂.
    simple refine (quotient_rec _ _ _).
    - intros a.
      simple refine (quotient_rec _ _ _).
      + intros b.
        exact (class_of _ (a,b)).
      + simpl ; intros b₁ b₂ p.
        apply related_classes_eq.
        exact (refl _,p).
    - simpl ; intros a₁ a₂ p₁.
      funext b. revert b.
      simple refine (quotient_ind _ _ _ _).
      + intros b ; simpl.
        apply related_classes_eq.
        exact (p₁,refl _).
      + intros ; apply path_ishprop.
  Defined.

  Definition squot_prod_out
    : squot (prod_setoid R₁ R₂) -> squot R₁ * squot R₂.
  Proof.
    simple refine (quotient_rec _ _ _).
    - exact (fun z => (class_of _ (fst z),class_of _ (snd z))).
    - simpl ; intros z₁ z₂ p.
      apply path_prod' ; apply related_classes_eq ; apply p.
  Defined.

  Lemma squot_prod_out_in_sect : Sect squot_prod_out squot_prod_in.
  Proof.
    unfold Sect.
    simple refine (quotient_ind _ _ _ _).
    - simpl ; intros [z₁ z₂] ; reflexivity.
    - intros ; apply path_ishprop.
  Defined.

  Lemma squot_prod_in_out_sect : Sect squot_prod_in squot_prod_out.
  Proof.
    intros [z₁ z₂]. revert z₁ z₂.
    simple refine (quotient_ind _ _ _ _).
    - simpl ; intros a.
      simple refine (quotient_ind _ _ _ _).
      + simpl ; intros b.
        reflexivity.
      + intros ; apply path_ishprop.
    - intros ; apply path_ishprop.
  Defined.

  Global Instance squot_prod_out_isequiv : IsEquiv squot_prod_out
    := isequiv_adjointify _ squot_prod_in squot_prod_in_out_sect squot_prod_out_in_sect.
End squot_prod.

(*
Section axiom_of_choice.
  Context `{Univalence}.

  Definition axiom_of_choice : hProp
    := BuildhProp(forall (X : hSet)
                         (A : X -> hSet)
                         (P : forall (x : X), A x -> hProp),
                     (forall (x : X), hexists (P x))
                     ->
                     merely {g : forall (x : X), A x & forall (x : X), P x (g x)}).

  Definition axiom_of_choice_rel : hProp
    := BuildhProp(forall (X Y : hSet)
                         (P : X -> Y -> hProp),
                     (forall (x : X), hexists (P x))
                     ->
                     merely {g : X -> Y & forall (x : X), P x (g x)}).

  Definition ac_vs_ac_rel
    : axiom_of_choice <~> axiom_of_choice_rel.
  Proof.
    apply equiv_iff_hprop.
    - unfold axiom_of_choice.
      intros ac X Y P HX.
      specialize (ac X (fun _ => Y)).
      apply ac.
      apply HX.
    - unfold axiom_of_choice_rel.
      intros acr X A P HX.
      specialize (acr X
                      (BuildhSet {x : X & A x})
                      (fun x a => BuildhProp((x = a.1) * P a.1 a.2))
                 ).
      cbn in acr.
      assert (forall x : X, Trunc -1 {x0 : {x0 : X & A x0} & (x = x0.1) * P x0.1 x0.2}).
      {
        intros x.
        specialize (HX x).
        strip_truncations.
        apply tr.
        destruct HX as [a Ha].
        exists (x;a) ; cbn.
        exact (idpath, Ha).
      }
      specialize (acr X0).
      strip_truncations.
      apply tr.
      destruct acr as [g Hg].
      simple refine (_;_).
      + intros x.
        exact (transport A (fst (Hg x))^ (g x).2).
      + intros x.
        pose (snd (Hg x)).
  Admitted.

  Definition pick_representatives : hProp
    := BuildhProp(forall (A B : hSet)
                         (R : relation B)
                         `{is_mere_relation _ R}
                         (f : A -> quotient R),
                     merely {g : A -> B & forall (x : A), class_of _ (g x) = f x}).

  Global Instance ja : forall (P : hProp), IsHProp (P + ~P).
  Admitted.

  Definition yolo : pick_representatives -> (forall (P : hProp), P + ~P).
  Proof.
    unfold pick_representatives.
    intros pick P.
    pose (R := fun b1 b2 : Bool =>
                 if b1 then (if b2 then BuildhProp Unit else P)
                 else (if b2 then P else BuildhProp Unit)).
    specialize (pick (BuildhSet Bool) (BuildhSet Bool) R _ (class_of _)).
    strip_truncations.
    destruct pick as [g Hg] ; cbn in *.
    assert (forall (x : Bool), R (g x) x).
    {
      intros x.
      specialize (Hg x).
      admit.
    }

  Definition pick_representatives_implies_ac
    : pick_representatives <~> axiom_of_choice.
  Proof.
    apply equiv_iff_hprop.
    - unfold pick_representatives.
      intros Hpc X A P HX.
      admit.
    - unfold axiom_of_choice.
      intros AC A B R ? f.
      apply (AC A (fun _ => B) (fun a b => BuildhProp(class_of R b = f a))).
      intros x.
      simple refine (quotient_ind _ (fun q => Trunc (-1) {x0 : B & class_of R x0 = q}) _ _ (f x)).
      + exact (fun b => tr(b;idpath)).
      + intros ; apply path_ishprop.
  Admitted.
End axiom_of_choice.

(** Taking the setoid quotient commutes with products (assuming function extensionality. *)
Section squot_fun.
  Variable (A B : Type)
           (R₁ : setoid A) (R₂ : setoid B).
  Context `{Univalence} `{IsHSet A} `{IsHSet B}.
  Variable (AC : pick_representatives).

  Definition squot_fun_out
    : squot (fun_setoid R₁ R₂) -> (squot R₁ -> squot R₂).
  Proof.
    simple refine (quotient_rec _ _ _).
    - intros f.
      simple refine (quotient_rec _ _ _).
      + exact (fun a => class_of _ (f.1 a)).
      + simpl ; intros a₁ a₂ p.
        apply related_classes_eq.
        apply f.2 ; assumption.
    - simpl ; intros f₁ f₂ p.
      funext x. revert x.
      simple refine (quotient_ind _ _ _ _).
      + intros a ; simpl.
        apply related_classes_eq.
        apply p.
      + intros ; apply path_ishprop.
  Defined.

  Global Instance squot_fun_out_equiv
    : IsEquiv squot_fun_out.
  Proof.
    apply isequiv_surj_emb.
    - apply BuildIsSurjection.
      intros f.
      pose (AC _ _ _ _ f) as t.
      simple refine (Trunc_rec _ t) ; clear t.
      intros t.
      simple refine (tr(_;_)).
      + apply class_of.
        destruct t as [g Hg].
        exists (g o class_of _).
        intros x₁ x₂ Hx.
        apply (setoid_quotient_path _).
        rewrite !Hg.
        apply ap.
        apply related_classes_eq.
        assumption.
      + simpl.
        funext x. revert x.
        simple refine (quotient_ind _ _ _ _).
        * intros a ; simpl.
          rewrite t.2.
          reflexivity.
        * intros ; apply path_ishprop.
    - apply isembedding_isinj_hset.
      unfold isinj.
      simple refine (quotient_ind _ _ _ _) ; simpl.
      + intros f.
        simple refine (quotient_ind _ _ _ _) ; simpl.
        * intros g Hfg.
          apply related_classes_eq.
          intros x.
          pose (ap10 Hfg (class_of _ x)) as p ; cbn in p.
          exact (setoid_quotient_path _ p).
        * intros ; apply path_ishprop.
      + intros ; apply path_ishprop.
  Defined.
  *)


(* PREAMBLE *)

From compcert.cfrontend Require Csem.
From trancert.lib       Require Algebraic.

Import Csem Csyntax Algebraic.

(** *Generic Invariants *)

(** When we execute a program some predicates might hold for all its states.
They can be:

- universal: hold for all states of all correct programs;
- conditional: hold for all states of some specific programs.
 *)

Section Def.
  Import Smallstep.

  Context (sem: semantics)
          (I: state sem -> Prop).

  Record invariant :=
    {
    inv_init:      forall s, initial_state sem s -> I s ;
    inv_stability: forall t, stability I (fun s1 s2 => step sem (globalenv sem) s1 t s2)
    }.

  Notation ge := (globalenv sem).
  Notation step := (step sem).

  Theorem stability_star:
    (forall t, stability I (fun s1 s2 => step ge s1 t s2) ) ->
    forall t, stability I (fun s1 s2 => star step ge s1 t s2).
  Proof.
    intros Hstab t s1 s2 HI. induction 1; auto.
    - subst. apply IHstar. eapply Hstab; eauto.
  Qed.

End Def.

Notation "x /*\ y" := (fun s => x s /\ y s) (at level 61, left associativity).


(** * DomKildall: Dominators via Kildall *)
(** * Computing Dominators *)
(** Implementation via fixpoint iteration. *)

Require Import Coq.Program.Equality.
Require Import Equalities.
From Vellvm Require Import
     Analysis.Dom
     Analysis.Dom
     Analysis.Kildall
     Utils.Util.
Require Import FSets FMaps.

Module Type GRAPH_CMP (G: GRAPH).
 Parameter succs : G.t -> G.V -> list G.V.
 Parameter enum_vs : G.t -> list G.V.
End GRAPH_CMP.

Module AlgdomKildall (PC:UsualDecidableType) (Import G: GRAPH with Definition V := PC.t)
                     (Import GC:GRAPH_CMP G)
       <: Algdom G.

  Module Import GS := Spec G.
  Module N := PC.
  Module E := PC.                   (* FIX: clean up all these module aliases *)
  Module NS := FSetWeakList.Make N.

  Module L := BoundedSet NS.
  Module Import K := ! ForwardSolver N L.  (* FIX: some suprising inlining here without ! *)
  Module NM := K.NM.                       (* FIX: fix up sharing? *)

  (* Module Import FMP := FMapProps N NM. *)
  Module FMF := FMapFacts.WFacts_fun N NM.
  Module FSF := FSetFacts.WFacts_fun N NS.

  (* FIX: simplify this ...  *)
  (* Parameter succs : G.t -> N.t -> list N.t. *)
  Axiom succs_compat : forall g n s, edge g n s <-> In s (succs g n).
  Axiom succs_compat2 : forall g n s, In s (succs g n) -> mem g s.

  (* Parameter enum_vs : G.t -> list N.t. *)
  Axiom enum_vs_compat : forall g n, mem g n <-> In n (enum_vs g).

  (* this follows directly from wf_cfg *)
  Axiom entry_not_sdom : forall g v, ~ SDom g v (entry g).

  Definition trans (n: N.t) (l:L.t) : L.t :=
    L.union (L.singleton n) l.

  Definition inits (g:G.t) : NM.t L.t :=
    NM.add (entry g) L.top
    (fold_right (fun n g => NM.add n L.bot g) (NM.empty L.t) (enum_vs g) ).

  Definition calc_sdom (g:G.t) : option (N.t -> L.t) :=
    let nmo := K.fixpoint (succs g) trans (inits g) in
    match nmo with
      | None => None
      | Some nm => Some (fun n => nm!!n)
    end.

  Lemma entry_sound : forall g sdom,
    calc_sdom g = Some sdom ->
    sdom (entry g) == L.top.
  Proof.
    unfold calc_sdom. intros.
    destruct (K.fixpoint _ _ _) eqn:Heqk; try discriminate H.
    injection H. intro. clear H. subst sdom.
    set (r := t0!!(entry g)). cut (L.le L.top r).
    destruct r; try inversion 1. simpl.
    intro Hsub. red. intro a. split;
    intro; exfalso; eapply FSF.empty_iff; eauto.

    replace L.top with ((inits g)!!(entry g)).
    eapply K.fixpoint_entry. apply Heqk.
    unfold inits. rewrite FMP.find_default_eq; auto.
  Qed.

  Lemma successors_sound : forall g sdom n1 n2,
    calc_sdom g = Some sdom ->
    mem g n1 -> mem g n2 -> edge g n1 n2 ->
    L.union (L.singleton n1) (sdom n1) <= sdom n2.
  Proof.
    unfold calc_sdom. intros.
    destruct (K.fixpoint _ _ _) eqn:Heqk; try discriminate H.
    injection H. intro. clear H. subst sdom.

    set (trans n o := L.union (L.singleton n) o).
    change (L.union (L.singleton n1) t0!!n1)
           with (trans n1 t0!!n1).
    eapply K.fixpoint_solution.
    eauto.

    unfold inits. destruct (N.eq_dec n1 (entry g)).
    apply FMF.add_in_iff; auto. apply FMF.add_neq_in_iff; auto.

    (* separate lemma? *)
    apply enum_vs_compat in H0. set (f g n := NM.add n L.bot g).
    assert (In n1 (enum_vs g) \/ NM.In n1 (NM.empty L.t))
           as Hin by exact (or_introl H0).
    generalize (enum_vs g) (NM.empty L.t) Hin.
    induction l; simpl. intuition.
    intros to Hin'. destruct Hin' as [[? | ?] | ?]; subst; auto.
    apply FMF.add_in_iff; auto.
    destruct (N.eq_dec a n1).
      subst.
      apply FMF.add_in_iff; auto. apply FMF.add_neq_in_iff; auto.
      lapply (IHl to). intros.
      apply FMF.add_in_iff; auto.
      right; auto.
    apply succs_compat; auto.
  Qed.

  (* Include AlgdomProperties G. *)

  Lemma complete : forall g sdom n1 n2,
    calc_sdom g = Some sdom ->
    SDom g n1 n2 -> L.In n1 (sdom n2).
  Proof.
    intros. pose proof entry_sound _ _ H as Hentry.
    unfold calc_sdom in *.
    destruct (K.fixpoint _ _ _) as [res|] eqn:heqk; try discriminate H.
    injection H. intro. clear H. subst sdom.

    generalize H0. clear H0. pattern n2, res!!n2.
    eapply K.fixpoint_invariant; eauto.

    intros. destruct (N.eq_dec (entry g) n).
    subst n. contradict H0.
    apply entry_not_sdom. unfold inits.
    rewrite FMP.find_default_neq; auto. unfold FMP.find_default.
    destruct (NM.find _ _) as [l'|] eqn:Heq; simpl; auto.

    induction (enum_vs g); simpl in *.
    rewrite FMF.empty_o in Heq. inversion Heq.
    rewrite <- FMF.find_mapsto_iff in Heq.
    rewrite FMF.add_mapsto_iff in Heq.
    destruct Heq as [[eq1 eq2] | [neq1 hyp]]; subst; simpl in *; auto.
    apply IHl. rewrite FMF.find_mapsto_iff in hyp.
    apply hyp.

    (* step preserves completeness *)
    intros. unfold trans.

    pose proof (succs_compat2 _ _ _ H) as Hmem.
    apply succs_compat in H.

    destruct ls eqn:Heqls, ln eqn:Heqln; simpl; auto.
    apply FSF.inter_iff. split. apply H1; auto.
    apply FSF.union_iff.
    destruct (N.eq_dec n1 n). left. apply FSF.singleton_iff; auto.
    right. apply H0. red; split; auto.
    eapply dom_step with (v2:=s); auto.

    apply H1; auto.

    apply FSF.union_iff.
    destruct (N.eq_dec n1 n). left. apply FSF.singleton_iff; auto.
    right. apply H0. red; split; auto.
    eapply dom_step with (v2:=s); auto.

  Qed.

End AlgdomKildall.


Set Implicit Arguments.
Require Import TLC.LibTactics.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
Require Pervasives_ml.
Require Array_ml.
Require Import Pervasives_proof.
Require Import ArrayCredits_proof.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import LibZExtra.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.
(* Load the CF definitions. *)
Require Import Dependent_nested_ml.

Ltac auto_tilde ::= try solve [ auto with maths | false; math ].

Lemma f_spec :
  specZ [cost \in_O (fun n => n^2)]
    (forall n,
       0 <= n -> (* FIXME (need more xfor lemmas) *)
       app f [n]
       PRE (\$ cost n)
       POST (fun (_:unit) => \[])).
Proof.
  xspecO_refine straight_line. intros n N. xcf.
  xpay. xfor_inv (fun (_:int) => \[]). math.
  { intros i Hi.
    xpay. xfor_inv (fun (_:int) => \[]). math.
    intros j Hj. xpay. xret~. hsimpl. hsimpl. }
  hsimpl. hsimpl.

  cleanup_cost.
  { eapply monotonic_sum; [| now monotonic]. eapply monotonic_cumul_Z.
    intros. rewrite~ <-cumul_nonneg. }
  dominated.
  rewrite dominated_big_sum_bound.
  2: now repeat ultimately_greater.
  { setoid_rewrite Z.pow_2_r. dominated.
    rewrite dominated_big_sum_bound. dominated. ultimately_greater.
    apply~ filter_universe_alt. monotonic. }
  { apply filter_universe_alt.
    eauto using monotonic_after_of_monotonic with monotonic zarith. }
Qed.


Require Import Poly.
Require Import List.
Require Import String.

(* Tipo das fórmulas nor *)

Inductive LF :=
| Atom : string -> LF
| Nor : LF -> LF -> LF.

Notation "[ A ]" := (Atom A) (at level 50).
Notation "A ↓ B"   := (Nor A B) (at level 100).
Notation "~ A"     := (Nor A A).
Notation "A /\ B"  := (Nor (Nor A A) (Nor B B)).
Notation "A \/ B"  := (Nor (Nor A B) (Nor A B)).
Notation "A -> B"  := (Nor (Nor (Nor A A) B) (Nor (Nor A A) B)).

Inductive node :=
| Empty
| Node (SL : SignedLF LF).

Definition NORTableau
  (snapshot : poly_binary_tree node)
  (lc : list (check node))
  (listNodes : list node)
  (m : list(mem nat))
  (p : parameters) : stt node nat :=
  match listNodes with
  | nil => state _ _ (Leaf _ nil) nil nil
  | h::tl =>
      match h with
      | Empty => state _ _ (Leaf _ nil) nil nil
      | Node SF =>
          match SF with
          | T _ b L =>
              match L with
              | Atom _ => state _ _ (Leaf _ (explode listNodes)) nil nil
              | Nor P Q =>
                  if b then
                    let node1 := (Node (T _ false P)) in
                    let node2 := (Node (T _ false Q)) in
                    state _ _ (Alpha _ node1 ((Alpha _ node2 (Leaf _ (node1::node2::(explode listNodes)))))) nil nil
                  else
                    let node1 := (Node (T _ true P)) in
                    let node2 := (Node (T _ true Q)) in
                    state _ _ (Beta _ (Alpha _ node1 ((Leaf _ (node1::(explode listNodes)))))
                      (Alpha _ node2 ((Leaf _ (node2::(explode listNodes)))))) nil nil
              end
          end
      end
  end.

Open Scope string_scope.

Definition P := "P".
Definition Q := "Q".
Definition R := "R".
Definition S := "S".
Definition X := "X".

Definition node1 := Node (T _ false (([R] /\ [P]) /\ ([X]))).
Definition node2 := Node (T _ false ([X])).
Definition listNodes := node1::nil.

Compute make _ _ NORTableau (makeInitialTree _ listNodes listNodes).


(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Leclerc

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import
    ssreflect
    ssrsearch
    Arith
    Lia
    Utf8
.

Section square_bij_def.

    Context (n : nat).

    Definition square_bij :=
        fun c : (nat * nat) =>
        let (k1, k2) := c in
        k1 * n + k2.

    Definition square_bij_inv :=
        fun m : nat =>
            ((m / n), (m mod n)).

End square_bij_def.

Section square_bij_prop.

    Context (n : nat).

    Lemma is_bij_square :
        ∀ k1 k2 : nat, k2 <= n -> square_bij_inv (S n) (square_bij (S n) (k1, k2)) = (k1, k2).
    Proof.
        move => k1 k2 Hk2.
        unfold square_bij, square_bij_inv.
        congr pair.
            rewrite Nat.div_add_l => //.
            rewrite Nat.div_small => //.
            apply le_n_S => //.
            rewrite Nat.add_comm.
            rewrite Nat.mod_add => //.
            rewrite Nat.mod_small => //.
            apply le_n_S => //.
    Qed.

    Lemma confined_snd_square_inv :
        ∀ m : nat, (snd (square_bij_inv (S n) m)) <= n.
    Proof.
        move => m.
        unfold square_bij_inv, snd.
        suff: (m mod S n < S n) by lia.
        apply Nat.mod_upper_bound => //.
    Qed.

    Lemma is_bij_square_inv :
        ∀ m : nat, square_bij (S n) (square_bij_inv (S n) m) = m.
    Proof.
        move => m; unfold square_bij_inv, square_bij.
        rewrite Nat.mul_comm.
        rewrite <-Nat.div_mod => //.
    Qed.

    Lemma square_bij_corner :
        ∀ n' : nat,
            square_bij (S n) (n', n) = ((S n') * (S n) - 1).
    Proof.
        unfold square_bij; lia.
    Qed.

    Lemma square_bij_inv_corner :
        ∀ n' : nat,
            square_bij_inv (S n) ((S n') * (S n) - 1) = (n', n).
    Proof.
        move => n'.
        pose Hnn' := square_bij_corner n'; clearbody Hnn'.
        assert
            (square_bij_inv (S n) (square_bij (S n) (n', n))
            = square_bij_inv (S n) (S n' * S n - 1))
            as Eq by congruence.
        rewrite is_bij_square in Eq; easy.
    Qed.

    Lemma confined_square_inv : ∀ n' : nat,
        ∀ m : nat, m <= S n' * S n - 1 ->
            let (k1, k2) := square_bij_inv (S n) m in
            k1 <= n' ∧ k2 <= n.
    Proof.
        move => n' m Hm; split.
        assert (m < S n' * S n) by lia.
        suff: (m / S n < S n') by lia.
        apply Nat.div_lt_upper_bound => //.
            rewrite Nat.mul_comm => //.
        suff: (m mod S n < S n) by lia.
        apply Nat.mod_upper_bound => //.
    Qed.

    Lemma confined_square : ∀ n' : nat,
        ∀ k1 k2 : nat,
            k1 <= n' ∧ k2 <= n -> square_bij (S n) (k1, k2) <= (S n' * S n) - 1.
    Proof.
        move => n' k1 k2 [Hk1 Hk2].
        unfold square_bij.
        replace
            (S n' * S n - 1)
            with
            ((n' * S n) + n)
            by lia.
        apply plus_le_compat => //.
        apply mult_le_compat => //.
    Qed.

End square_bij_prop.

From Coquelicot Require Import
    Hierarchy
.

Section square_bij_sum.

    Lemma sum_n_m_shift {G : AbelianGroup} :
        ∀ n m k : nat, ∀ u : nat -> G,
            sum_n_m (fun x => u (k + x)) n m
            = sum_n_m u (k + n) (k + m).
    Proof.
        induction n => m k.
            replace (k + 0) with k by lia.
            move: m k.
            induction m => k u.
                rewrite sum_n_n; replace (k + 0) with k by lia; rewrite sum_n_n.
                reflexivity.
                rewrite sum_n_Sm.
                    2 : lia.
                replace (k + S m) with (S (k + m)) by lia.
                rewrite sum_n_Sm.
                    2 : lia.
                congr plus; auto.
            move => u.
            replace (k + S n) with (S (k + n)) by lia.
            case_eq (m <? S n).
                (* On traite à part le cas ou le support de la somme est l'ensemble vide *)
                move /Nat.ltb_lt => Hmn.
                rewrite sum_n_m_zero.
                    2 : assumption.
                assert (k + m < S (k + n)) as Hkmn by lia.
                rewrite sum_n_m_zero.
                    2 : assumption.
                reflexivity.
            (* cas ou le support est non vide *)
            move /Nat.ltb_ge => Hnm.
            assert (n <= m) as Hnm_wk by lia.
            pose IHn_mk := IHn m k u; clearbody IHn_mk.
            rewrite sum_Sn_m in IHn_mk.
                2 : lia.
            assert ((k + n) <= (k + m)) as Hknm by lia.
            rewrite (sum_Sn_m u) in IHn_mk.
                2 : lia.
            apply plus_reg_l with (u (k + n)) => //.
    Qed.

    Lemma square_bij_sum {G : AbelianGroup} :
        ∀ n1 n2 : nat, ∀ u : nat -> G,
            sum_n u (S n1 * S n2 - 1) =
            sum_n (
                fun k1 => sum_n (
                    fun k2 => u (square_bij (S n2) (k1, k2))
                ) n2
            ) n1.
    Proof.
        induction n1 => n2 u.
        simpl; replace (n2 + 0 - 0) with n2 by lia.
        rewrite sum_O => //=.
        replace (S (S n1) * S n2 - 1)
            with ((S n1) * (S n2) - 1 + S n2)
            by lia.
        rewrite sum_Sn.
        rewrite <-IHn1.
        assert (0 <= S (S n1 * S n2 - 1)) as H0 by lia.
        assert ((S n1 * S n2 - 1) <= (S n1 * S n2 - 1 + S n2)) as H1 by lia.
        unfold sum_n at 1; rewrite (sum_n_m_Chasles _ _ _ _ H0 H1).
        replace (sum_n_m u 0 (S n1 * S n2 - 1)) with (sum_n u (S n1 * S n2 - 1))
            by unfold sum_n => //.
        congr plus.
        clear H0 H1 IHn1.

        replace (S (S n1 * S n2 - 1)) with (S n1 * S n2) by lia.
        replace (S n1 * S n2 - 1 + S n2) with (S n1 * S n2 + n2) by lia.
        unfold square_bij.
        unfold sum_n; rewrite (sum_n_m_shift 0 n2 (S n1 * S n2) u).
        replace (S n1 * S n2 + 0) with (S n1 * S n2) by lia.
        reflexivity.
    Qed.

End square_bij_sum.

Global Opaque square_bij.
Global Opaque square_bij_inv.


(** * ImpCEvalFun: Evaluation Function for Imp *)

(* $Date: 2013-07-01 18:48:47 -0400 (Mon, 01 Jul 2013) $ *)

(* #################################### *)
(** ** Evaluation Function *)

Require Import Imp.

(** Here's a first try at an evaluation function for commands,
    omitting [WHILE]. *)

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        update st l (aeval st a1)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.

(** In a traditional functional programming language like ML or
    Haskell we could write the WHILE case as follows:
<<
    | WHILE b1 DO c1 END =>
        if (beval st b1)
          then ceval_step1 st (c1;; WHILE b1 DO c1 END)
          else st
>>
    Coq doesn't accept such a definition ([Error: Cannot guess
    decreasing argument of fix]) because the function we want to
    define is not guaranteed to terminate. Indeed, the changed
    [ceval_step1] function applied to the [loop] program from [Imp.v] would
    never terminate. Since Coq is not just a functional programming
    language, but also a consistent logic, any potentially
    non-terminating function needs to be rejected. Here is an
    invalid(!) Coq program showing what would go wrong if Coq allowed
    non-terminating recursive functions:
<<
     Fixpoint loop_false (n : nat) : False := loop_false n.
>>
    That is, propositions like [False] would become
    provable (e.g. [loop_false 0] would be a proof of [False]), which
    would be a disaster for Coq's logical consistency.

    Thus, because it doesn't terminate on all inputs, the full version
    of [ceval_step1] cannot be written in Coq -- at least not
    without one additional trick... *)

(** Second try, using an extra numeric argument as a "step index" to
    ensure that evaluation always terminates. *)

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_state
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          update st l (aeval st a1)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

(** _Note_: It is tempting to think that the index [i] here is
    counting the "number of steps of evaluation."  But if you look
    closely you'll see that this is not the case: for example, in the
    rule for sequencing, the same [i] is passed to both recursive
    calls.  Understanding the exact way that [i] is treated will be
    important in the proof of [ceval__ceval_step], which is given as
    an exercise below. *)

(** Third try, returning an [option state] instead of just a [state]
    so that we can distinguish between normal and abnormal
    termination. *)

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

(** We can improve the readability of this definition by introducing a
    bit of auxiliary notation to hide the "plumbing" involved in
    repeatedly matching against optional states. *)

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

(* Eval compute in
     (test_ceval empty_state
         (X ::= ANum 2;;
          IFB BLe (AId X) (ANum 1)
            THEN Y ::= ANum 3
            ELSE Z ::= ANum 4
          FI)).
   ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars (pup_to_n) *)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com :=
  (* FILL IN HERE *) admit.

(*
Example pup_to_n_1 :
  test_ceval (update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)
(** [] *)

(** **** Exercise: 2 stars, optional (peven) *)
(** Write a [While] program that sets [Z] to [0] if [X] is even and
    sets [Z] to [1] otherwise.  Use [ceval_test] to test your
    program. *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################ *)
(** ** Equivalence of Relational and Step-Indexed Evaluation *)

(** As with arithmetic and boolean expressions, we'd hope that
    the two alternative definitions of evaluation actually boil down
    to the same thing.  This section shows that this is the case.
    Make sure you understand the statements of the theorems and can
    follow the structure of the proofs. *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st || st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  Case "i = 0 -- contradictory".
    intros c st st' H. inversion H.

  Case "i = S i'".
    intros c st st' H.
    com_cases (destruct c) SCase;
           simpl in H; inversion H; subst; clear H.
      SCase "SKIP". apply E_Skip.
      SCase "::=". apply E_Ass. reflexivity.

      SCase ";;".
        destruct (ceval_step st c1 i') eqn:Heqr1.
        SSCase "Evaluation of r1 terminates normally".
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        SSCase "Otherwise -- contradiction".
          inversion H1.

      SCase "IFB".
        destruct (beval st b) eqn:Heqr.
        SSCase "r = true".
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        SSCase "r = false".
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      SCase "WHILE". destruct (beval st b) eqn :Heqr.
        SSCase "r = true".
         destruct (ceval_step st c i') eqn:Heqr1.
          SSSCase "r1 = Some s".
            apply E_WhileLoop with s. rewrite Heqr. reflexivity.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
          SSSCase "r1 = None".
            inversion H1.
        SSCase "r = false".
          inversion H1.
          apply E_WhileEnd.
          rewrite <- Heqr. subst. reflexivity.  Qed.

(** **** Exercise: 4 stars (ceval_step__ceval_inf) *)
(** Write an informal proof of [ceval_step__ceval], following the
    usual template.  (The template for case analysis on an inductively
    defined value should look the same as for induction, except that
    there is no induction hypothesis.)  Make your proof communicate
    the main ideas to a human reader; do not simply transcribe the
    steps of the formal proof.

(* FILL IN HERE *)
[]
*)

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  Case "i1 = 0".
    simpl in Hceval. inversion Hceval.
  Case "i1 = S i1'".
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    com_cases (destruct c) SCase.
    SCase "SKIP".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase "::=".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase ";;".
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      SSCase "st1'o = Some".
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "st1'o = None".
        inversion Hceval.

    SCase "IFB".
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval; assumption.

    SCase "WHILE".
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      SSCase "st1'o = Some".
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "i1'o = None".
        simpl in Hceval. inversion Hceval.  Qed.

(** **** Exercise: 3 stars (ceval__ceval_step) *)
(** Finish the following proof.  You'll need [ceval_step_more] in a
    few places, as well as some basic facts about [<=] and [plus]. *)

Theorem ceval__ceval_step: forall c st st',
      c / st || st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  ceval_cases (induction Hce) Case.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem ceval_and_ceval_step_coincide: forall c st st',
      c / st || st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ####################################################### *)
(** ** Determinism of Evaluation (Simpler Proof) *)

(** Here's a slicker proof showing that the evaluation relation is
    deterministic, using the fact that the relational and step-indexed
    definition of evaluation are the same. *)

Theorem ceval_deterministic' : forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.  Qed.


(** Lib.v: various general-purpose properties *)
Require Export Tactics.
Require Export Relations.
Require Export List.
Require Export Bool.
Require Export ZArith.
Require Export EqBoolAux.
Require Export PosAux.
Require Export BinArray.
Require Export MapSignatures.

Lemma in_nth_error : forall (A:Set) (l:list A) n a,
  nth_error l n = Some a -> In a l.
Proof.
  induction l; simpl; intros.
  destruct n; discriminate.
  destruct n; simpl in H.
  inversion H; auto.
  right; eauto.
Qed.

Lemma app_cons : forall (A:Set) (l1 l2:list A) a,
  l1++a::l2 = (l1++a::nil)++l2.
Proof.
  induction l1; simpl; intros.
  reflexivity.
  rewrite IHl1; reflexivity.
Qed.

Lemma length_app_cons_nil : forall (A:Set) (l:list A) a,
  length (l++a::nil) = S (length l).
Proof.
  induction l; simpl; intros.
  reflexivity.
  rewrite IHl; reflexivity.
Qed.

Lemma app_inj_right : forall (A:Set) (l1 r1 l2 r2:list A),
  length l1 = length l2 ->
  l1++r1 = l2++r2 -> r1=r2.
Proof.
  induction l1; destruct l2; simpl; intros; try discriminate; auto.
  injection H; injection H0; intros; eauto.
Qed.

Lemma app_inj : forall (A:Set) (l1 r1 l2 r2:list A),
  length l1 = length l2 ->
  l1++r1 = l2++r2 -> l1=l2 /\ r1=r2.
Proof.
  induction l1; destruct l2; simpl; intros; try discriminate; auto.
  injection H; injection H0; intros.
  elim IHl1 with r1 l2 r2; intros; auto.
  subst; auto.
Qed.

Lemma app_exists_if_length : forall (A:Set) (l:list A) n,
  (n <= length l)%nat ->
  exists l1, exists l2, length l1 = n /\ l = l1 ++ l2.
Proof.
  induction l; simpl; intros.
  exists (@nil A).
  destruct n.
  exists (@nil A); simpl; auto.
  apply False_ind; omega.
  destruct n.
  exists (@nil A); exists (a::l); auto.
  destruct (IHl n) as [l1 [l2 [H1 H2]]].
  omega.
  exists (a::l1); exists l2; split; simpl; auto.
  rewrite H2; auto.
Qed.

Lemma app_length_le : forall (A:Set) (l1 l2:list A),
  (length l1 <= length (l1++l2))%nat.
Proof.
  induction l1; simpl; intros.
  omega.
  generalize (IHl1 l2); omega.
Qed.

Lemma length_app_length : forall (A B:Set) (l1 l3 :list A) (l2 l4 :list B),
  length l1 = length l2 ->
  length (l1++l3) = length (l2++l4) ->
  length l3 = length l4.
Proof.
  induction l1; destruct l2; intros; try discriminate;
  simpl in *; auto.
  injection H; injection H0; intros; eapply IHl1; eauto.
Qed.

Lemma not_none_some : forall (A:Type) (a:option A) (b:A),
  a <> None -> exists b, a = Some b.
Proof.
  intros; destruct a; try(exists a; auto); try (apply False_ind; auto).
Qed.

Section eq_dec.
  Variable t:Set.
  Variable P:t->t->Prop.
  Variable test_bool : t -> t -> bool.
  Definition test_bool_spec : Prop := forall x y, if test_bool x y then P x y else ~ P x y.
  Variable test_bool_prop : test_bool_spec.
  Lemma P_dec : forall l l':t, {P l l'}+{~P l l'}.
  Proof.
    intros x y; generalize (test_bool_prop x y); case (test_bool x y); auto.
  Qed.
End eq_dec.
Implicit Arguments P_dec.
Implicit Arguments test_bool_spec.


Require Import Category Functor Transform Comma Limit.
Require Import Equality ProofIrrelevance.

Module Pullback.
(*
    Pullback diagram :
    X ---> Z < --- Y
*)
Inductive Obj := X | Y | Z.

Definition Hom (x y : Obj) : Prop :=
    match x, y with
    | X, X => True
    | Y, Y => True
    | Z, Z => True
    | X, Z => True
    | Y, Z => True
    | _, _ => False
    end.

Definition Id (x : Obj) : Hom x x.
destruct x; now simpl.
Qed.

Program Definition Cat : Category := {|
    ob := Obj;
    hom := Hom;
    id  := Id;
|}.
Next Obligation.
destruct a, b, c; now simpl.
Qed.
Next Obligation.
apply proof_irrelevance.
Qed.
Next Obligation.
apply proof_irrelevance.
Qed.
Next Obligation.
apply proof_irrelevance.
Qed.

Definition X_to_Z : @hom Cat X Z := I.
Definition Y_to_Z : @hom Cat Y Z := I.

Definition diagram_ob {C : Category} (a b c : [C]) (x : Obj) : [C] :=
    match x with
    | X => a
    | Y => b
    | Z => c
    end.

(* Any idea to simplify ?*)
Definition diagram_hom {C : Category} {a b c : [C]} (f : a ~> c) (g : b ~> c) (x y : Obj) (t : Hom x y) :
    diagram_ob a b c x ~> diagram_ob a b c y :=
    match x, y, t with
    | X, Z, _ => f
    | Y, Z, _ => g
    | X, X, _ => id a
    | Y, Y, _ => id b
    | Z, Z, _ => id c
    | _, _, t => match t with end
    end.

Program Definition construct_diagram {C : Category} {a b c : [C]} (f : a ~> c) (g : b ~> c) : Cat → C := {|
    f_ob := diagram_ob a b c;
    f_hom := diagram_hom f g
|}.
Next Obligation.
destruct a0; now simpl.
Defined.
Next Obligation.
destruct a0, b0, c0; simpl; try rewrite cat_id_l; try rewrite cat_id_r; now simpl.
Defined.

End Pullback.

Definition is_pullback {C : Category} {D : Pullback.Cat → C} (p : [cone_cat D]) := is_limit p.

Definition pullback_obj {C : Category} {D : Pullback.Cat → C} (p : [cone_cat D]) : [C] := cone_base p.

Definition pullback_to_a_mph {C : Category} {D : Pullback.Cat → C} (p : [cone_cat D]) : pullback_obj p ~> ob[D] Pullback.X :=
    tf[cone_transform p] Pullback.X.

Definition pullback_to_b_mph {C : Category} {D : Pullback.Cat → C} (p : [cone_cat D]) : pullback_obj p ~> ob[D] Pullback.Y :=
    tf[cone_transform p] Pullback.Y.

Lemma pullback_square_commute {C : Category} {D : Pullback.Cat → C} (p : [cone_cat D]) :
    pullback_to_a_mph p >> hom[D] Pullback.X_to_Z = pullback_to_b_mph p >> hom[D] Pullback.Y_to_Z.
Proof.
assert (pullback_to_a_mph p >> hom[D] Pullback.X_to_Z = tf[cone_transform p] Pullback.Z).
- now rewrite <- (cone_naturality p Pullback.X_to_Z).
- rewrite H. now rewrite <- (cone_naturality p Pullback.Y_to_Z).
Qed.

Definition tf_pullback {C : Category} {D : Pullback.Cat → C} (x : [C]) (f : x ~> ob[D] Pullback.X) (g : x ~> ob[D] Pullback.Y) :=
    fun i : [Pullback.Cat] =>
        match i with
        | Pullback.X => f
        | Pullback.Y => g
        | Pullback.Z => f >> hom[D] Pullback.X_to_Z
        end.

(* We prove that if we have a commutative square, we have what we need to construct a cone *)
Lemma nat_pullback {C : Category} {D : Pullback.Cat → C} (x : [C]) (f : x ~> ob[D] Pullback.X) (g : x ~> ob[D] Pullback.Y)
(square_commute : f >> hom[D] Pullback.X_to_Z = g >> hom[D] Pullback.Y_to_Z) :
    (forall i j : [Pullback.Cat], forall u : i ~> j, tf_pullback x f g i >> hom[D] u = tf_pullback x f g j).
Proof.
intros. destruct i, j; simpl.
- assert (I = @id Pullback.Cat Pullback.X). apply proof_irrelevance. assert (hom[D] u = id _).
destruct u. rewrite <- f_id_distr. now rewrite H. now rewrite H0, cat_id_r.
- destruct u.
- destruct u. now unfold Pullback.X_to_Z.
- destruct u.
- assert (I = @id Pullback.Cat Pullback.Y). apply proof_irrelevance. assert (hom[D] u = id _).
destruct u. rewrite <- f_id_distr. now rewrite H. now rewrite H0, cat_id_r.
- rewrite square_commute. destruct u. now unfold Pullback.Y_to_Z.
- destruct u.
- destruct u.
- assert (I = @id Pullback.Cat Pullback.Z). apply proof_irrelevance. assert (hom[D] u = id _).
destruct u. now rewrite <- f_id_distr, H. now rewrite H0, cat_id_r.
Qed.

(* And now, we construct such a cone *)
Definition commutative_pullback_square_to_cone {C : Category} (D : Pullback.Cat → C) (x : [C]) (f : x ~> ob[D] Pullback.X) (g : x ~> ob[D] Pullback.Y)
    (square_commute : f >> hom[D] Pullback.X_to_Z = g >> hom[D] Pullback.Y_to_Z) : [cone_cat D].
Proof.
exact (@construct_cone Pullback.Cat C D x (tf_pullback x f g) (nat_pullback x f g square_commute)).
Defined.

(* Now, when we have to pullback cones and a morphism between the two such that the upper and lwoer triangles commute,
we can create a morphism of cone thanks to this definition *)
(* First a lemma that ensures the naturality of the cone morphism we'll construct between cones *)
Lemma naturality_pullback_morphism {C : Category} {D : Pullback.Cat → C} (p1 p2 : [cone_cat D]) (mph : cone_base p1 ~> cone_base p2)
    (lower_nat : mph >> pullback_to_a_mph p2 = pullback_to_a_mph p1) (upper_nat : mph >> pullback_to_b_mph p2 = pullback_to_b_mph p1) :
    forall i : [Pullback.Cat], tf[cone_transform p1] i = mph >> tf[cone_transform p2] i.
Proof.
intro. destruct i; unfold pullback_to_a_mph, pullback_to_b_mph in *; apply eq_sym; try assumption.
now rewrite <- (cone_naturality p2 Pullback.X_to_Z), <- cat_comp_assoc, lower_nat, <- (cone_naturality p1 Pullback.X_to_Z).
Qed.

Definition pullback_morphism_to_cone_morphism {C : Category} (D : Pullback.Cat → C) (p1 p2 : [cone_cat D]) (mph : cone_base p1 ~> cone_base p2)
    (lower_nat : mph >> pullback_to_a_mph p2 = pullback_to_a_mph p1) (upper_nat : mph >> pullback_to_b_mph p2 = pullback_to_b_mph p1) :
    p1 ~> p2 := morphism_to_cone_morphism p1 p2 mph (naturality_pullback_morphism p1 p2 mph lower_nat upper_nat).

Lemma pullback_preserves_mono_b {C : Category} {D : Pullback.Cat → C} (p : [cone_cat D]) (hyp_pullback : is_pullback p) :
    is_mono (hom[D] Pullback.Y_to_Z) -> is_mono (pullback_to_a_mph p).
Proof.
intros. unfold is_mono. intros.
assert (g >> pullback_to_a_mph p >> (hom[D] Pullback.X_to_Z) = g' >> pullback_to_a_mph p >> (hom[D] Pullback.X_to_Z)).
now rewrite H0.
rewrite !cat_comp_assoc in H1.
rewrite (pullback_square_commute p) in H1.
assert (g >> pullback_to_b_mph p = g' >> pullback_to_b_mph p).
- rewrite <- !cat_comp_assoc in H1. unfold is_mono in H. now specialize (H x (g >> pullback_to_b_mph p) (g' >> pullback_to_b_mph p) H1).
- assert (g >> pullback_to_b_mph p >> hom[D] Pullback.Y_to_Z = g >> pullback_to_a_mph p >> hom[D] Pullback.X_to_Z).
now rewrite !cat_comp_assoc, pullback_square_commute.
apply eq_sym in H3.
assert (g' >> pullback_to_a_mph p >> hom[D] Pullback.X_to_Z = g' >> pullback_to_b_mph p >> hom[D] Pullback.Y_to_Z).
now rewrite H0, H2 in H3.
pose (cone := commutative_pullback_square_to_cone D x (g >> pullback_to_a_mph p) (g >> pullback_to_b_mph p) H3).
unfold is_pullback, is_limit, is_terminal in hyp_pullback. specialize (hyp_pullback cone). unfold universal_arrow in hyp_pullback.
destruct hyp_pullback as [phi].
pose (phi_g := pullback_morphism_to_cone_morphism D cone p g eq_refl eq_refl).
pose (phi_g' := pullback_morphism_to_cone_morphism D cone p g' (eq_sym H0) (eq_sym H2)).
assert (phi_g = phi). exact (eq_sym (H5 phi_g)).
assert (phi_g' = phi). exact (eq_sym (H5 phi_g')).
assert (phi_g = phi_g'). now rewrite H6, H7.
assert (cone_mph_to_induced_mph phi_g = cone_mph_to_induced_mph phi_g').
now apply same_cone_morphism_same_induced_morphism.
unfold cone_mph_to_induced_mph, Comma.source_mph in H9. now simpl in H9.
Qed.