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

Require Import ZArith.
Require Import BigNumPrelude.
Require Import NSig.
Require Import ZSig.

Open Scope Z_scope.

(** * ZMake

  A generic transformation from a structure of natural numbers
  [NSig.NType] to a structure of integers [ZSig.ZType].
*)

Module Make (NN:NType) <: ZType.

 Inductive t_ :=
  | Pos : NN.t -> t_
  | Neg : NN.t -> t_.

 Definition t := t_.

 Definition zero := Pos NN.zero.
 Definition one  := Pos NN.one.
 Definition two := Pos NN.two.
 Definition minus_one := Neg NN.one.

 Definition of_Z x :=
  match x with
  | Zpos x => Pos (NN.of_N (Npos x))
  | Z0 => zero
  | Zneg x => Neg (NN.of_N (Npos x))
  end.

 Definition to_Z x :=
  match x with
  | Pos nx => NN.to_Z nx
  | Neg nx => Z.opp (NN.to_Z nx)
  end.

 Theorem spec_of_Z: forall x, to_Z (of_Z x) = x.
 Proof.
 intros x; case x; unfold to_Z, of_Z, zero.
   exact NN.spec_0.
   intros; rewrite NN.spec_of_N; auto.
   intros; rewrite NN.spec_of_N; auto.
 Qed.

 Definition eq x y := (to_Z x = to_Z y).

 Theorem spec_0: to_Z zero = 0.
 exact NN.spec_0.
 Qed.

 Theorem spec_1: to_Z one = 1.
 exact NN.spec_1.
 Qed.

 Theorem spec_2: to_Z two = 2.
 exact NN.spec_2.
 Qed.

 Theorem spec_m1: to_Z minus_one = -1.
 simpl; rewrite NN.spec_1; auto.
 Qed.

 Definition compare x y :=
  match x, y with
  | Pos nx, Pos ny => NN.compare nx ny
  | Pos nx, Neg ny =>
    match NN.compare nx NN.zero with
    | Gt => Gt
    | _ => NN.compare ny NN.zero
    end
  | Neg nx, Pos ny =>
    match NN.compare NN.zero nx with
    | Lt => Lt
    | _ => NN.compare NN.zero ny
    end
  | Neg nx, Neg ny => NN.compare ny nx
  end.

 Theorem spec_compare :
  forall x y, compare x y = Z.compare (to_Z x) (to_Z y).
 Proof.
 unfold compare, to_Z.
 destruct x as [x|x], y as [y|y];
 rewrite ?NN.spec_compare, ?NN.spec_0, ?Z.compare_opp; auto;
 assert (Hx:=NN.spec_pos x); assert (Hy:=NN.spec_pos y);
 set (X:=NN.to_Z x) in *; set (Y:=NN.to_Z y) in *; clearbody X Y.
 - destruct (Z.compare_spec X 0) as [EQ|LT|GT].
   + rewrite <- Z.opp_0 in EQ. now rewrite EQ, Z.compare_opp.
   + exfalso. omega.
   + symmetry. change (X > -Y). omega.
 - destruct (Z.compare_spec 0 X) as [EQ|LT|GT].
   + rewrite <- EQ, Z.opp_0; auto.
   + symmetry. change (-X < Y). omega.
   + exfalso. omega.
 Qed.

 Definition eqb x y :=
  match compare x y with
  | Eq => true
  | _ => false
  end.

 Theorem spec_eqb x y : eqb x y = Z.eqb (to_Z x) (to_Z y).
 Proof.
 apply Bool.eq_iff_eq_true.
 unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare.
 split; [now destruct Z.compare | now intros ->].
 Qed.

 Definition lt n m := to_Z n < to_Z m.
 Definition le n m := to_Z n <= to_Z m.

 Definition ltb (x y : t) : bool :=
  match compare x y with
  | Lt => true
  | _  => false
  end.

 Theorem spec_ltb x y : ltb x y = Z.ltb (to_Z x) (to_Z y).
 Proof.
 apply Bool.eq_iff_eq_true.
 rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare.
 split; [now destruct Z.compare | now intros ->].
 Qed.

 Definition leb (x y : t) : bool :=
  match compare x y with
  | Gt => false
  | _  => true
  end.

 Theorem spec_leb x y : leb x y = Z.leb (to_Z x) (to_Z y).
 Proof.
 apply Bool.eq_iff_eq_true.
 rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare.
 now destruct Z.compare; split.
 Qed.

 Definition min n m := match compare n m with Gt => m | _ => n end.
 Definition max n m := match compare n m with Lt => m | _ => n end.

 Theorem spec_min : forall n m, to_Z (min n m) = Z.min (to_Z n) (to_Z m).
 Proof.
 unfold min, Z.min. intros. rewrite spec_compare. destruct Z.compare; auto.
 Qed.

 Theorem spec_max : forall n m, to_Z (max n m) = Z.max (to_Z n) (to_Z m).
 Proof.
 unfold max, Z.max. intros. rewrite spec_compare. destruct Z.compare; auto.
 Qed.

 Definition to_N x :=
  match x with
  | Pos nx => nx
  | Neg nx => nx
  end.

 Definition abs x := Pos (to_N x).

 Theorem spec_abs: forall x, to_Z (abs x) = Z.abs (to_Z x).
 Proof.
 intros x; case x; clear x; intros x; assert (F:=NN.spec_pos x).
    simpl; rewrite Z.abs_eq; auto.
 simpl; rewrite Z.abs_neq; simpl; auto with zarith.
 Qed.

 Definition opp x :=
  match x with
  | Pos nx => Neg nx
  | Neg nx => Pos nx
  end.

 Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x.
 Proof.
 intros x; case x; simpl; auto with zarith.
 Qed.

 Definition succ x :=
  match x with
  | Pos n => Pos (NN.succ n)
  | Neg n =>
    match NN.compare NN.zero n with
    | Lt => Neg (NN.pred n)
    | _ => one
    end
  end.

 Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1.
 Proof.
 intros x; case x; clear x; intros x.
   exact (NN.spec_succ x).
 simpl. rewrite NN.spec_compare. case Z.compare_spec; rewrite ?NN.spec_0; simpl.
  intros HH; rewrite <- HH; rewrite NN.spec_1; ring.
  intros HH; rewrite NN.spec_pred, Z.max_r; auto with zarith.
 generalize (NN.spec_pos x); auto with zarith.
 Qed.

 Definition add x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (NN.add nx ny)
  | Pos nx, Neg ny =>
    match NN.compare nx ny with
    | Gt => Pos (NN.sub nx ny)
    | Eq => zero
    | Lt => Neg (NN.sub ny nx)
    end
  | Neg nx, Pos ny =>
    match NN.compare nx ny with
    | Gt => Neg (NN.sub nx ny)
    | Eq => zero
    | Lt => Pos (NN.sub ny nx)
    end
  | Neg nx, Neg ny => Neg (NN.add nx ny)
  end.

 Theorem spec_add: forall x y, to_Z (add x y) = to_Z x +  to_Z y.
 Proof.
 unfold add, to_Z; intros [x | x] [y | y];
   try (rewrite NN.spec_add; auto with zarith);
 rewrite NN.spec_compare; case Z.compare_spec;
  unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *.
 Qed.

 Definition pred x :=
  match x with
  | Pos nx =>
    match NN.compare NN.zero nx with
    | Lt => Pos (NN.pred nx)
    | _ => minus_one
    end
  | Neg nx => Neg (NN.succ nx)
  end.

 Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1.
 Proof.
 unfold pred, to_Z, minus_one; intros [x | x];
   try (rewrite NN.spec_succ; ring).
 rewrite NN.spec_compare; case Z.compare_spec;
  rewrite ?NN.spec_0, ?NN.spec_1, ?NN.spec_pred;
  generalize (NN.spec_pos x); omega with *.
 Qed.

 Definition sub x y :=
  match x, y with
  | Pos nx, Pos ny =>
    match NN.compare nx ny with
    | Gt => Pos (NN.sub nx ny)
    | Eq => zero
    | Lt => Neg (NN.sub ny nx)
    end
  | Pos nx, Neg ny => Pos (NN.add nx ny)
  | Neg nx, Pos ny => Neg (NN.add nx ny)
  | Neg nx, Neg ny =>
    match NN.compare nx ny with
    | Gt => Neg (NN.sub nx ny)
    | Eq => zero
    | Lt => Pos (NN.sub ny nx)
    end
  end.

 Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y.
 Proof.
 unfold sub, to_Z; intros [x | x] [y | y];
  try (rewrite NN.spec_add; auto with zarith);
 rewrite NN.spec_compare; case Z.compare_spec;
  unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *.
 Qed.

 Definition mul x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (NN.mul nx ny)
  | Pos nx, Neg ny => Neg (NN.mul nx ny)
  | Neg nx, Pos ny => Neg (NN.mul nx ny)
  | Neg nx, Neg ny => Pos (NN.mul nx ny)
  end.

 Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y.
 Proof.
 unfold mul, to_Z; intros [x | x] [y | y]; rewrite NN.spec_mul; ring.
 Qed.

 Definition square x :=
  match x with
  | Pos nx => Pos (NN.square nx)
  | Neg nx => Pos (NN.square nx)
  end.

 Theorem spec_square: forall x, to_Z (square x) = to_Z x *  to_Z x.
 Proof.
 unfold square, to_Z; intros [x | x]; rewrite NN.spec_square; ring.
 Qed.

 Definition pow_pos x p :=
  match x with
  | Pos nx => Pos (NN.pow_pos nx p)
  | Neg nx =>
    match p with
    | xH => x
    | xO _ => Pos (NN.pow_pos nx p)
    | xI _ => Neg (NN.pow_pos nx p)
    end
  end.

 Theorem spec_pow_pos: forall x n, to_Z (pow_pos x n) = to_Z x ^ Zpos n.
 Proof.
 assert (F0: forall x, (-x)^2 = x^2).
   intros x; rewrite Z.pow_2_r; ring.
 unfold pow_pos, to_Z; intros [x | x] [p | p |];
   try rewrite NN.spec_pow_pos; try ring.
 assert (F: 0 <= 2 * Zpos p).
  assert (0 <= Zpos p); auto with zarith.
 rewrite Pos2Z.inj_xI; repeat rewrite Zpower_exp; auto with zarith.
 repeat rewrite Z.pow_mul_r; auto with zarith.
 rewrite F0; ring.
 assert (F: 0 <= 2 * Zpos p).
  assert (0 <= Zpos p); auto with zarith.
 rewrite Pos2Z.inj_xO; repeat rewrite Zpower_exp; auto with zarith.
 repeat rewrite Z.pow_mul_r; auto with zarith.
 rewrite F0; ring.
 Qed.

 Definition pow_N x n :=
  match n with
  | N0 => one
  | Npos p => pow_pos x p
  end.

 Theorem spec_pow_N: forall x n, to_Z (pow_N x n) = to_Z x ^ Z.of_N n.
 Proof.
 destruct n; simpl. apply NN.spec_1.
 apply spec_pow_pos.
 Qed.

 Definition pow x y :=
  match to_Z y with
  | Z0 => one
  | Zpos p => pow_pos x p
  | Zneg p => zero
  end.

 Theorem spec_pow: forall x y, to_Z (pow x y) = to_Z x ^ to_Z y.
 Proof.
 intros. unfold pow. destruct (to_Z y); simpl.
 apply NN.spec_1.
 apply spec_pow_pos.
 apply NN.spec_0.
 Qed.

 Definition log2 x :=
  match x with
  | Pos nx => Pos (NN.log2 nx)
  | Neg nx => zero
  end.

 Theorem spec_log2: forall x, to_Z (log2 x) = Z.log2 (to_Z x).
 Proof.
  intros. destruct x as [p|p]; simpl. apply NN.spec_log2.
  rewrite NN.spec_0.
  destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ].
  rewrite Z.log2_nonpos; auto with zarith.
  now rewrite <- EQ.
 Qed.

 Definition sqrt x :=
  match x with
  | Pos nx => Pos (NN.sqrt nx)
  | Neg nx => Neg NN.zero
  end.

 Theorem spec_sqrt: forall x, to_Z (sqrt x) = Z.sqrt (to_Z x).
 Proof.
  destruct x as [p|p]; simpl.
  apply NN.spec_sqrt.
  rewrite NN.spec_0.
  destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ].
  rewrite Z.sqrt_neg; auto with zarith.
  now rewrite <- EQ.
 Qed.

 Definition div_eucl x y :=
  match x, y with
  | Pos nx, Pos ny =>
    let (q, r) := NN.div_eucl nx ny in
    (Pos q, Pos r)
  | Pos nx, Neg ny =>
    let (q, r) := NN.div_eucl nx ny in
    if NN.eqb NN.zero r
    then (Neg q, zero)
    else (Neg (NN.succ q), Neg (NN.sub ny r))
  | Neg nx, Pos ny =>
    let (q, r) := NN.div_eucl nx ny in
    if NN.eqb NN.zero r
    then (Neg q, zero)
    else (Neg (NN.succ q), Pos (NN.sub ny r))
  | Neg nx, Neg ny =>
    let (q, r) := NN.div_eucl nx ny in
    (Pos q, Neg r)
  end.

 Ltac break_nonneg x px EQx :=
  let H := fresh "H" in
  assert (H:=NN.spec_pos x);
  destruct (NN.to_Z x) as [|px|px] eqn:EQx;
   [clear H|clear H|elim H; reflexivity].

 Theorem spec_div_eucl: forall x y,
   let (q,r) := div_eucl x y in
   (to_Z q, to_Z r) = Z.div_eucl (to_Z x) (to_Z y).
 Proof.
 unfold div_eucl, to_Z. intros [x | x] [y | y].
 (* Pos Pos *)
 generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y); auto.
 (* Pos Neg *)
 generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
 break_nonneg x px EQx; break_nonneg y py EQy;
 try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr;
      simpl; rewrite Hq, NN.spec_0; auto).
 change (- Zpos py) with (Zneg py).
 assert (GT : Zpos py > 0) by (compute; auto).
 generalize (Z_div_mod (Zpos px) (Zpos py) GT).
 unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r').
 intros (EQ,MOD). injection 1 as Hq' Hr'.
 rewrite NN.spec_eqb, NN.spec_0, Hr'.
 break_nonneg r pr EQr.
 subst; simpl. rewrite NN.spec_0; auto.
 subst. lazy iota beta delta [Z.eqb].
 rewrite NN.spec_sub, NN.spec_succ, EQy, EQr. f_equal. omega with *.
 (* Neg Pos *)
 generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
 break_nonneg x px EQx; break_nonneg y py EQy;
 try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr;
      simpl; rewrite Hq, NN.spec_0; auto).
 change (- Zpos px) with (Zneg px).
 assert (GT : Zpos py > 0) by (compute; auto).
 generalize (Z_div_mod (Zpos px) (Zpos py) GT).
 unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r').
 intros (EQ,MOD). injection 1 as Hq' Hr'.
 rewrite NN.spec_eqb, NN.spec_0, Hr'.
 break_nonneg r pr EQr.
 subst; simpl. rewrite NN.spec_0; auto.
 subst. lazy iota beta delta [Z.eqb].
 rewrite NN.spec_sub, NN.spec_succ, EQy, EQr. f_equal. omega with *.
 (* Neg Neg *)
 generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
 break_nonneg x px EQx; break_nonneg y py EQy;
 try (injection 1 as -> ->; auto).
 simpl. intros <-; auto.
 Qed.

 Definition div x y := fst (div_eucl x y).

 Definition spec_div: forall x y,
     to_Z (div x y) = to_Z x / to_Z y.
 Proof.
 intros x y; generalize (spec_div_eucl x y); unfold div, Z.div.
 case div_eucl; case Z.div_eucl; simpl; auto.
 intros q r q11 r1 H; injection H; auto.
 Qed.

 Definition modulo x y := snd (div_eucl x y).

 Theorem spec_modulo:
   forall x y, to_Z (modulo x y) = to_Z x mod to_Z y.
 Proof.
 intros x y; generalize (spec_div_eucl x y); unfold modulo, Z.modulo.
 case div_eucl; case Z.div_eucl; simpl; auto.
 intros q r q11 r1 H; injection H; auto.
 Qed.

 Definition quot x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (NN.div nx ny)
  | Pos nx, Neg ny => Neg (NN.div nx ny)
  | Neg nx, Pos ny => Neg (NN.div nx ny)
  | Neg nx, Neg ny => Pos (NN.div nx ny)
  end.

 Definition rem x y :=
  if eqb y zero then x
  else
    match x, y with
      | Pos nx, Pos ny => Pos (NN.modulo nx ny)
      | Pos nx, Neg ny => Pos (NN.modulo nx ny)
      | Neg nx, Pos ny => Neg (NN.modulo nx ny)
      | Neg nx, Neg ny => Neg (NN.modulo nx ny)
    end.

 Lemma spec_quot : forall x y, to_Z (quot x y) = (to_Z x) ÷ (to_Z y).
 Proof.
  intros [x|x] [y|y]; simpl; symmetry; rewrite NN.spec_div;
  (* Nota: we rely here on [forall a b, a ÷ 0 = b / 0] *)
  destruct (Z.eq_dec (NN.to_Z y) 0) as [EQ|NEQ];
    try (rewrite EQ; now destruct (NN.to_Z x));
  rewrite ?Z.quot_opp_r, ?Z.quot_opp_l, ?Z.opp_involutive, ?Z.opp_inj_wd;
  trivial; apply Z.quot_div_nonneg;
   generalize (NN.spec_pos x) (NN.spec_pos y); Z.order.
 Qed.

 Lemma spec_rem : forall x y,
   to_Z (rem x y) = Z.rem (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold rem. rewrite spec_eqb, spec_0.
  case Z.eqb_spec; intros Hy.
  (* Nota: we rely here on [Z.rem a 0 = a] *)
  rewrite Hy. now destruct (to_Z x).
  destruct x as [x|x], y as [y|y]; simpl in *; symmetry;
   rewrite ?Z.eq_opp_l, ?Z.opp_0 in Hy;
   rewrite NN.spec_modulo, ?Z.rem_opp_r, ?Z.rem_opp_l, ?Z.opp_involutive,
    ?Z.opp_inj_wd;
   trivial; apply Z.rem_mod_nonneg;
    generalize (NN.spec_pos x) (NN.spec_pos y); Z.order.
 Qed.

 Definition gcd x y :=
  match x, y with
  | Pos nx, Pos ny => Pos (NN.gcd nx ny)
  | Pos nx, Neg ny => Pos (NN.gcd nx ny)
  | Neg nx, Pos ny => Pos (NN.gcd nx ny)
  | Neg nx, Neg ny => Pos (NN.gcd nx ny)
  end.

 Theorem spec_gcd: forall a b, to_Z (gcd a b) = Z.gcd (to_Z a) (to_Z b).
 Proof.
 unfold gcd, Z.gcd, to_Z; intros [x | x] [y | y]; rewrite NN.spec_gcd; unfold Z.gcd;
  auto; case NN.to_Z; simpl; auto with zarith;
  try rewrite Z.abs_opp; auto;
  case NN.to_Z; simpl; auto with zarith.
 Qed.

 Definition sgn x :=
  match compare zero x with
   | Lt => one
   | Eq => zero
   | Gt => minus_one
  end.

 Lemma spec_sgn : forall x, to_Z (sgn x) = Z.sgn (to_Z x).
 Proof.
 intros. unfold sgn. rewrite spec_compare. case Z.compare_spec.
 rewrite spec_0. intros <-; auto.
 rewrite spec_0, spec_1. symmetry. rewrite Z.sgn_pos_iff; auto.
 rewrite spec_0, spec_m1. symmetry. rewrite Z.sgn_neg_iff; auto with zarith.
 Qed.

 Definition even z :=
  match z with
   | Pos n => NN.even n
   | Neg n => NN.even n
  end.

 Definition odd z :=
  match z with
   | Pos n => NN.odd n
   | Neg n => NN.odd n
  end.

 Lemma spec_even : forall z, even z = Z.even (to_Z z).
 Proof.
  intros [n|n]; simpl; rewrite NN.spec_even; trivial.
  destruct (NN.to_Z n) as [|p|p]; now try destruct p.
 Qed.

 Lemma spec_odd : forall z, odd z = Z.odd (to_Z z).
 Proof.
  intros [n|n]; simpl; rewrite NN.spec_odd; trivial.
  destruct (NN.to_Z n) as [|p|p]; now try destruct p.
 Qed.

 Definition norm_pos z :=
   match z with
     | Pos _ => z
     | Neg n => if NN.eqb n NN.zero then Pos n else z
   end.

 Definition testbit a n :=
   match norm_pos n, norm_pos a with
     | Pos p, Pos a => NN.testbit a p
     | Pos p, Neg a => negb (NN.testbit (NN.pred a) p)
     | Neg p, _ => false
   end.

 Definition shiftl a n :=
   match norm_pos a, n with
     | Pos a, Pos n => Pos (NN.shiftl a n)
     | Pos a, Neg n => Pos (NN.shiftr a n)
     | Neg a, Pos n => Neg (NN.shiftl a n)
     | Neg a, Neg n => Neg (NN.succ (NN.shiftr (NN.pred a) n))
   end.

 Definition shiftr a n := shiftl a (opp n).

 Definition lor a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (NN.lor a b)
     | Neg a, Pos b => Neg (NN.succ (NN.ldiff (NN.pred a) b))
     | Pos a, Neg b => Neg (NN.succ (NN.ldiff (NN.pred b) a))
     | Neg a, Neg b => Neg (NN.succ (NN.land (NN.pred a) (NN.pred b)))
   end.

 Definition land a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (NN.land a b)
     | Neg a, Pos b => Pos (NN.ldiff b (NN.pred a))
     | Pos a, Neg b => Pos (NN.ldiff a (NN.pred b))
     | Neg a, Neg b => Neg (NN.succ (NN.lor (NN.pred a) (NN.pred b)))
   end.

 Definition ldiff a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (NN.ldiff a b)
     | Neg a, Pos b => Neg (NN.succ (NN.lor (NN.pred a) b))
     | Pos a, Neg b => Pos (NN.land a (NN.pred b))
     | Neg a, Neg b => Pos (NN.ldiff (NN.pred b) (NN.pred a))
   end.

 Definition lxor a b :=
   match norm_pos a, norm_pos b with
     | Pos a, Pos b => Pos (NN.lxor a b)
     | Neg a, Pos b => Neg (NN.succ (NN.lxor (NN.pred a) b))
     | Pos a, Neg b => Neg (NN.succ (NN.lxor a (NN.pred b)))
     | Neg a, Neg b => Pos (NN.lxor (NN.pred a) (NN.pred b))
   end.

 Definition div2 x := shiftr x one.

 Lemma Zlnot_alt1 : forall x, -(x+1) = Z.lnot x.
 Proof.
  unfold Z.lnot, Z.pred; auto with zarith.
 Qed.

 Lemma Zlnot_alt2 : forall x, Z.lnot (x-1) = -x.
 Proof.
  unfold Z.lnot, Z.pred; auto with zarith.
 Qed.

 Lemma Zlnot_alt3 : forall x, Z.lnot (-x) = x-1.
 Proof.
  unfold Z.lnot, Z.pred; auto with zarith.
 Qed.

 Lemma spec_norm_pos : forall x, to_Z (norm_pos x) = to_Z x.
 Proof.
  intros [x|x]; simpl; trivial.
  rewrite NN.spec_eqb, NN.spec_0.
  case Z.eqb_spec; simpl; auto with zarith.
 Qed.

 Lemma spec_norm_pos_pos : forall x y, norm_pos x = Neg y ->
  0 < NN.to_Z y.
 Proof.
  intros [x|x] y; simpl; try easy.
  rewrite NN.spec_eqb, NN.spec_0.
  case Z.eqb_spec; simpl; try easy.
  inversion 2. subst. generalize (NN.spec_pos y); auto with zarith.
 Qed.

 Ltac destr_norm_pos x :=
  rewrite <- (spec_norm_pos x);
  let H := fresh in
  let x' := fresh x in
  assert (H := spec_norm_pos_pos x);
  destruct (norm_pos x) as [x'|x'];
   specialize (H x' (eq_refl _)) || clear H.

 Lemma spec_testbit: forall x p, testbit x p = Z.testbit (to_Z x) (to_Z p).
 Proof.
  intros x p. unfold testbit.
  destr_norm_pos p; simpl. destr_norm_pos x; simpl.
  apply NN.spec_testbit.
  rewrite NN.spec_testbit, NN.spec_pred, Z.max_r by auto with zarith.
  symmetry. apply Z.bits_opp. apply NN.spec_pos.
  symmetry. apply Z.testbit_neg_r; auto with zarith.
 Qed.

 Lemma spec_shiftl: forall x p, to_Z (shiftl x p) = Z.shiftl (to_Z x) (to_Z p).
 Proof.
  intros x p. unfold shiftl.
  destr_norm_pos x; destruct p as [p|p]; simpl;
   assert (Hp := NN.spec_pos p).
  apply NN.spec_shiftl.
  rewrite Z.shiftl_opp_r. apply NN.spec_shiftr.
  rewrite !NN.spec_shiftl.
  rewrite !Z.shiftl_mul_pow2 by apply NN.spec_pos.
  symmetry. apply Z.mul_opp_l.
  rewrite Z.shiftl_opp_r, NN.spec_succ, NN.spec_shiftr, NN.spec_pred, Z.max_r
   by auto with zarith.
  now rewrite Zlnot_alt1, Z.lnot_shiftr, Zlnot_alt2.
 Qed.

 Lemma spec_shiftr: forall x p, to_Z (shiftr x p) = Z.shiftr (to_Z x) (to_Z p).
 Proof.
  intros. unfold shiftr. rewrite spec_shiftl, spec_opp.
  apply Z.shiftl_opp_r.
 Qed.

 Lemma spec_land: forall x y, to_Z (land x y) = Z.land (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold land.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor,
    ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith.
  now rewrite Z.ldiff_land, Zlnot_alt2.
  now rewrite Z.ldiff_land, Z.land_comm, Zlnot_alt2.
  now rewrite Z.lnot_lor, !Zlnot_alt2.
 Qed.

 Lemma spec_lor: forall x y, to_Z (lor x y) = Z.lor (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold lor.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor,
    ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith.
  now rewrite Z.lnot_ldiff, Z.lor_comm, Zlnot_alt2.
  now rewrite Z.lnot_ldiff, Zlnot_alt2.
  now rewrite Z.lnot_land, !Zlnot_alt2.
 Qed.

 Lemma spec_ldiff: forall x y, to_Z (ldiff x y) = Z.ldiff (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold ldiff.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor,
    ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith.
  now rewrite Z.ldiff_land, Zlnot_alt3.
  now rewrite Z.lnot_lor, Z.ldiff_land, <- Zlnot_alt2.
  now rewrite 2 Z.ldiff_land, Zlnot_alt2, Z.land_comm, Zlnot_alt3.
 Qed.

 Lemma spec_lxor: forall x y, to_Z (lxor x y) = Z.lxor (to_Z x) (to_Z y).
 Proof.
  intros x y. unfold lxor.
  destr_norm_pos x; destr_norm_pos y; simpl;
   rewrite ?NN.spec_succ, ?NN.spec_lxor, ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1;
   auto with zarith.
  now rewrite !Z.lnot_lxor_r, Zlnot_alt2.
  now rewrite !Z.lnot_lxor_l, Zlnot_alt2.
  now rewrite <- Z.lxor_lnot_lnot, !Zlnot_alt2.
 Qed.

 Lemma spec_div2: forall x, to_Z (div2 x) = Z.div2 (to_Z x).
 Proof.
  intros x. unfold div2. now rewrite spec_shiftr, Z.div2_spec, spec_1.
 Qed.

End Make.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                              Hurkens.v                               *)
(************************************************************************)

(** Exploiting Hurkens's paradox [[Hurkens95]] for system U- so as to
    derive various contradictory contexts.

    The file is divided into various sub-modules which all follow the
    same structure: a section introduces the contradictory hypotheses
    and a theorem named [paradox] concludes the module with a proof of
    [False].

    - The [Generic] module contains the actual Hurkens's paradox for a
      postulated shallow encoding of system U- in Coq. This is an
      adaptation by Arnaud Spiwack of a previous, more restricted
      implementation by Herman Geuvers. It is used to derive every
      other special cases of the paradox in this file.

    - The [NoRetractToImpredicativeUniverse] module contains a simple
      and effective formulation by Herman Geuvers [[Geuvers01]] of a
      result by Thierry Coquand [[Coquand90]]. It states that no
      impredicative sort can contain a type of which it is a
      retract. This result implies that Coq with classical logic
      stated in impredicative Set is inconsistent and that classical
      logic stated in Prop implies proof-irrelevance (see
      [ClassicalFacts.v])

    - The [NoRetractFromSmallPropositionToProp] module is a
      specialisation of the [NoRetractToImpredicativeUniverse] module
      to the case where the impredicative sort is [Prop].

    - The [NoRetractToModalProposition] module is a strengthening of
      the [NoRetractFromSmallPropositionToProp] module.  It shows that
      given a monadic modality (aka closure operator) [M], the type of
      modal propositions (i.e. such that [M A -> A]) cannot be a
      retract of a modal proposition. It is an example of use of the
      paradox where the universes of system U- are not mapped to
      universes of Coq.

    - The [NoRetractToNegativeProp] module is the specialisation of
      the [NoRetractFromSmallPropositionToProp] module where the
      modality is double-negation. This result implies that the
      principle of weak excluded middle ([forall A, ~~A\/~A]) implies
      a weak variant of proof irrelevance.

    - The [NoRetractFromTypeToProp] module proves that [Prop] cannot
      be a retract of a larger type.

    - The [TypeNeqSmallType] module proves that [Type] is different
      from any smaller type.

    - The [PropNeqType] module proves that [Prop] is different from
      any larger [Type]. It is an instance of the previous result.

    References:

    - [[Coquand90]] T. Coquand, "Metamathematical Investigations of a
      Calculus of Constructions", Proceedings of Logic in Computer
      Science (LICS'90), 1990.

    - [[Hurkens95]] A. J. Hurkens, "A simplification of Girard's paradox",
      Proceedings of the 2nd international conference Typed Lambda-Calculi
      and Applications (TLCA'95), 1995.

    - [[Geuvers01]] H. Geuvers, "Inconsistency of Classical Logic in Type
      Theory", 2001, revised 2007
      (see {{http://www.cs.ru.nl/~herman/PUBS/newnote.ps.gz}}).
*)

Set Universe Polymorphism.

(* begin show *)

(** * A modular proof of Hurkens's paradox. *)

(** It relies on an axiomatisation of a shallow embedding of system U-
    (i.e.  types of U- are interpreted by types of Coq). The
    universes are encoded in a style, due to Martin-Löf, where they
    are given by a set of names and a family [El:Name->Type] which
    interprets each name into a type. This allows the encoding of
    universe to be decoupled from Coq's universes. Dependent products
    and abstractions are similarly postulated rather than encoded as
    Coq's dependent products and abstractions. *)

Module Generic.

(* begin hide *)
(* Notations used in the proof. Hidden in coqdoc. *)

Reserved Notation "'∀₁' x : A , B" (at level 200, x ident, A at level 200,right associativity).
Reserved Notation "A '⟶₁' B" (at level 99, right associativity, B at level 200).
Reserved Notation "'λ₁' x , u" (at level 200, x ident, right associativity).
Reserved Notation "f '·₁' x" (at level 5, left associativity).
Reserved Notation "'∀₂' A , F" (at level 200, A ident, right associativity).
Reserved Notation "'λ₂' x , u" (at level 200, x ident, right associativity).
Reserved Notation "f '·₁' [ A ]" (at level 5, left associativity).
Reserved Notation "'∀₀' x : A , B" (at level 200, x ident, A at level 200,right associativity).
Reserved Notation "A '⟶₀' B" (at level 99, right associativity, B at level 200).
Reserved Notation "'λ₀' x , u" (at level 200, x ident, right associativity).
Reserved Notation "f '·₀' x" (at level 5, left associativity).
Reserved Notation "'∀₀¹' A : U , F" (at level 200, A ident, right associativity).
Reserved Notation "'λ₀¹' x , u" (at level 200, x ident, right associativity).
Reserved Notation "f '·₀' [ A ]" (at level 5, left associativity).

(* end hide *)

Section Paradox.

(** ** Axiomatisation of impredicative universes in a Martin-Löf style *)

(** System U- has two impredicative universes. In the proof of the
    paradox they are slightly asymmetric (in particular the reduction
    rules of the small universe are not needed).  Therefore, the
    axioms are duplicated allowing for a weaker requirement than the
    actual system U-. *)

(** *** Large universe *)
Variable U1 : Type.
Variable El1 : U1 -> Type.
(** **** Closure by small product *)
Variable Forall1 : forall u:U1, (El1 u -> U1) -> U1.
  Notation "'∀₁' x : A , B" := (Forall1 A (fun x => B)).
  Notation "A '⟶₁' B" := (Forall1 A (fun _ => B)).
Variable lam1 : forall u B, (forall x:El1 u, El1 (B x)) -> El1 (∀₁ x:u, B x).
  Notation "'λ₁' x , u" := (lam1 _ _ (fun x => u)).
Variable app1 : forall u B (f:El1 (Forall1 u B)) (x:El1 u), El1 (B x).
  Notation "f '·₁' x" := (app1 _ _ f x).
Variable beta1 : forall u B (f:forall x:El1 u, El1 (B x)) x,
                   (λ₁ y, f y) ·₁ x = f x.
(** **** Closure by large products *)
(** [U1] only needs to quantify over itself. *)
Variable ForallU1 : (U1->U1) -> U1.
  Notation "'∀₂' A , F" := (ForallU1 (fun A => F)).
Variable lamU1 : forall F, (forall A:U1, El1 (F A)) -> El1 (∀₂ A, F A).
  Notation "'λ₂' x , u" := (lamU1 _ (fun x => u)).
Variable appU1 : forall F (f:El1(∀₂ A,F A)) (A:U1), El1 (F A).
  Notation "f '·₁' [ A ]" := (appU1 _ f A).
Variable betaU1 : forall F (f:forall A:U1, El1 (F A)) A,
                    (λ₂ x, f x) ·₁ [ A ] = f A.

(** *** Small universe *)
(** The small universe is an element of the large one. *)
Variable u0 : U1.
Notation U0 := (El1 u0).
Variable El0 : U0 -> Type.
(** **** Closure by small product *)
(** [U0] does not need reduction rules *)
Variable Forall0 : forall u:U0, (El0 u -> U0) -> U0.
  Notation "'∀₀' x : A , B" := (Forall0 A (fun x => B)).
  Notation "A '⟶₀' B" := (Forall0 A (fun _ => B)).
Variable lam0 : forall u B, (forall x:El0 u, El0 (B x)) -> El0 (∀₀ x:u, B x).
  Notation "'λ₀' x , u" := (lam0 _ _ (fun x => u)).
Variable app0 : forall u B (f:El0 (Forall0 u B)) (x:El0 u), El0 (B x).
  Notation "f '·₀' x" := (app0 _ _ f x).
(** **** Closure by large products *)
Variable ForallU0 : forall u:U1, (El1 u->U0) -> U0.
  Notation "'∀₀¹' A : U , F" := (ForallU0 U (fun A => F)).
Variable lamU0 : forall U F, (forall A:El1 U, El0 (F A)) -> El0 (∀₀¹ A:U, F A).
  Notation "'λ₀¹' x , u" := (lamU0 _ _ (fun x => u)).
Variable appU0 : forall U F (f:El0(∀₀¹ A:U,F A)) (A:El1 U), El0 (F A).
  Notation "f '·₀' [ A ]" := (appU0 _ _ f A).

(** ** Automating the rewrite rules of our encoding. *)
Local Ltac simplify :=
  (* spiwack: ideally we could use [rewrite_strategy] here, but I am a tad
     scared of the idea of depending on setoid rewrite in such a simple
     file. *)
  (repeat rewrite ?beta1, ?betaU1);
  lazy beta.

Local Ltac simplify_in h :=
  (repeat rewrite ?beta1, ?betaU1 in h);
  lazy beta in h.

(** ** Hurkens's paradox. *)

(** An inhabitant of [U0] standing for [False]. *)
Variable F:U0.

(** *** Preliminary definitions *)

Definition V : U1 := ∀₂ A, ((A ⟶₁ u0) ⟶₁ A ⟶₁ u0) ⟶₁ A ⟶₁ u0.
Definition U : U1 := V ⟶₁ u0.

Definition sb (z:El1 V) : El1 V := λ₂ A, λ₁ r, λ₁ a, r ·₁ (z·₁[A]·₁r) ·₁ a.

Definition le (i:El1 (U⟶₁u0)) (x:El1 U) : U0 :=
  x ·₁ (λ₂ A, λ₁ r, λ₁ a, i ·₁ (λ₁ v, (sb v) ·₁ [A] ·₁ r ·₁ a)).
Definition le' : El1 ((U⟶₁u0) ⟶₁ U ⟶₁ u0) := λ₁ i, λ₁ x, le i x.
Definition induct (i:El1 (U⟶₁u0)) : U0 :=
  ∀₀¹ x:U, le i x ⟶₀ i ·₁ x.

Definition WF : El1 U := λ₁ z, (induct (z·₁[U] ·₁ le')).
Definition I (x:El1 U) : U0 :=
  (∀₀¹ i:U⟶₁u0, le i x ⟶₀ i ·₁ (λ₁ v, (sb v) ·₁ [U] ·₁ le' ·₁ x)) ⟶₀ F
.

(** *** Proof *)

Lemma Omega : El0 (∀₀¹ i:U⟶₁u0, induct i ⟶₀ i ·₁ WF).
Proof.
  refine (λ₀¹ i, λ₀ y, _).
  refine (y·₀[_]·₀_).
  unfold le,WF,induct. simplify.
  refine (λ₀¹ x, λ₀ h0, _). simplify.
  refine (y·₀[_]·₀_).
  unfold le. simplify.
  unfold sb at 1. simplify.
  unfold le' at 1. simplify.
  exact h0.
Qed.

Lemma lemma1 : El0 (induct (λ₁ u, I u)).
Proof.
  unfold induct.
  refine (λ₀¹ x, λ₀ p, _). simplify.
  refine (λ₀ q,_).
  assert (El0 (I (λ₁ v, (sb v)·₁[U]·₁le'·₁x))) as h.
  { generalize (q·₀[λ₁ u, I u]·₀p). simplify.
    intros q'.
    exact q'. }
  refine (h·₀_).
  refine (λ₀¹ i,_).
  refine (λ₀ h', _).
  generalize (q·₀[λ₁ y, i ·₁ (λ₁ v, (sb v)·₁[U] ·₁ le' ·₁ y)]). simplify.
  intros q'.
  refine (q'·₀_). clear q'.
  unfold le at 1 in h'. simplify_in h'.
  unfold sb at 1 in h'. simplify_in h'.
  unfold le' at 1 in h'. simplify_in h'.
  exact h'.
Qed.

Lemma lemma2 : El0 ((∀₀¹i:U⟶₁u0, induct i ⟶₀ i·₁WF) ⟶₀ F).
Proof.
  refine (λ₀ x, _).
  assert (El0 (I WF)) as h.
  { generalize (x·₀[λ₁ u, I u]·₀lemma1). simplify.
    intros q.
    exact q. }
  refine (h·₀_). clear h.
  refine (λ₀¹ i, λ₀ h0, _).
  generalize (x·₀[λ₁ y, i·₁(λ₁ v, (sb v)·₁[U]·₁le'·₁y)]). simplify.
  intros q.
  refine (q·₀_). clear q.
  unfold le in h0. simplify_in h0.
  unfold WF in h0. simplify_in h0.
  exact h0.
Qed.

Theorem paradox : El0 F.
Proof.
  exact (lemma2·₀Omega).
Qed.

End Paradox.

(** The [paradox] tactic can be called as a shortcut to use the paradox. *)
Ltac paradox h :=
  unshelve (refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ))).

End Generic.

(** * Impredicative universes are not retracts. *)

(** There can be no retract to an impredicative Coq universe from a
    smaller type. In this version of the proof, the impredicativity of
    the universe is postulated with a pair of functions from the
    universe to its type and back which commute with dependent product
    in an appropriate way. *)

Module NoRetractToImpredicativeUniverse.

Section Paradox.

Let      U2    := Type.
Let      U1:U2 := Type.
Variable U0:U1.

(** *** [U1] is impredicative *)
Variable u22u1 : U2 -> U1.
Hypothesis u22u1_unit   : forall (c:U2), c -> u22u1 c.
(** [u22u1_counit] and [u22u1_coherent] only apply to dependent
    product so that the equations happen in the smaller [U1] rather
    than [U2].  Indeed, it is not generally the case that one can
    project from a large universe to an impredicative universe and
    then get back the original type again. It would be too strong a
    hypothesis to require (in particular, it is not true of
    [Prop]). The formulation is reminiscent of the monadic
    characteristic of the projection from a large type to [Prop].*)
Hypothesis u22u1_counit : forall (F:U1->U1), u22u1 (forall A,F A) -> (forall A,F A).
Hypothesis u22u1_coherent : forall (F:U1 -> U1) (f:forall x:U1, F x) (x:U1),
                              u22u1_counit _ (u22u1_unit _ f) x = f x.

(** *** [U0] is a retract of [U1] *)
Variable u02u1 : U0 -> U1.
Variable u12u0 : U1 -> U0.
Hypothesis u12u0_unit   : forall (b:U1), b -> u02u1 (u12u0 b).
Hypothesis u12u0_counit : forall (b:U1), u02u1 (u12u0 b) -> b.

(** ** Paradox *)

Theorem paradox : forall F:U1, F.
Proof.
  intros F.
  Generic.paradox h.
  (** Large universe *)
  + exact U1.
  + exact (fun X => X).
  + cbn. exact (fun u F => forall x:u, F x).
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).

  + cbn. exact (fun F => u22u1 (forall x, F x)).
  + cbn. exact (fun _ x => u22u1_unit _ x).
  + cbn. exact (fun _ x => u22u1_counit _ x).
  (** Small universe *)
  + exact U0.
  (** The interpretation of the small universe is the image of
      [U0] in [U1]. *)
  + cbn. exact (fun X => u02u1 X).
  + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))).
  + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))).
  + cbn. exact (u12u0 F).
  + cbn in h.
    exact (u12u0_counit _ h).
  + cbn. easy.
  + cbn. intros **. now rewrite u22u1_coherent.
  + cbn. intros * x. exact (u12u0_unit _ x).
  + cbn. intros * x. exact (u12u0_counit _ x).
  + cbn. intros * x. exact (u12u0_unit _ x).
  + cbn. intros * x. exact (u12u0_counit _ x).
Qed.

End Paradox.

End NoRetractToImpredicativeUniverse.

(** * Modal fragments of [Prop] are not retracts *)

(** In presence of a a monadic modality on [Prop], we can define a
    subset of [Prop] of modal propositions which is also a complete
    Heyting algebra. These cannot be a retract of a modal
    proposition. This is a case where the universe in system U- are
    not encoded as Coq universes. *)

Module NoRetractToModalProposition.

(** ** Monadic modality *)

Section Paradox.

Variable M : Prop -> Prop.
Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B.

Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x).
Proof.
  intros A P h x.
  eapply incr in h; eauto.
Qed.

(** ** The universe of modal propositions *)

Definition MProp := { P:Prop | M P -> P }.
Definition El : MProp -> Prop := @proj1_sig _ _.

Lemma modal : forall P:MProp, M(El P) -> El P.
Proof.
  intros [P m]. cbn.
  exact m.
Qed.

Definition Forall {A:Type} (P:A->MProp) : MProp.
Proof.
  unshelve (refine (exist _ _ _)).
  + exact (forall x:A, El (P x)).
  + intros h x.
    eapply strength in h.
    eauto using modal.
Defined.

(** ** Retract of the modal fragment of [Prop] in a small type *)

(** The retract is axiomatized using logical equivalence as the
    equality on propositions. *)

Variable bool : MProp.
Variable p2b : MProp -> El bool.
Variable b2p : El bool -> MProp.
Hypothesis p2p1 : forall A:MProp, El (b2p (p2b A)) -> El A.
Hypothesis p2p2 : forall A:MProp, El A -> El (b2p (p2b A)).

(** ** Paradox *)

Theorem paradox : forall B:MProp, El B.
Proof.
  intros B.
  Generic.paradox h.
  (** Large universe *)
  + exact MProp.
  + exact El.
  + exact (fun _ => Forall).
  + cbn. exact (fun _ _ f => f).
  + cbn. exact (fun _ _ f => f).
  + exact Forall.
  + cbn. exact (fun _ f => f).
  + cbn. exact (fun _ f => f).
  (** Small universe *)
  + exact bool.
  + exact (fun b => El (b2p b)).
  + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))).
  + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))).
  + apply p2b.
    exact B.
  + cbn in h. auto.
  + cbn. easy.
  + cbn. easy.
  + cbn. auto.
  + cbn. intros * f.
    apply p2p1 in f. cbn in f.
    exact f.
  + cbn. auto.
  + cbn. intros * f.
    apply p2p1 in f. cbn in f.
    exact f.
Qed.

End Paradox.

End NoRetractToModalProposition.

(** * The negative fragment of [Prop] is not a retract *)

(** The existence in the pure Calculus of Constructions of a retract
    from the negative fragment of [Prop] into a negative proposition
    is inconsistent. This is an instance of the previous result. *)

Module NoRetractToNegativeProp.

(** ** The universe of negative propositions. *)

Definition NProp := { P:Prop | ~~P -> P }.
Definition El : NProp -> Prop := @proj1_sig _ _.

Section Paradox.

(** ** Retract of the negative fragment of [Prop] in a small type *)

(** The retract is axiomatized using logical equivalence as the
    equality on propositions. *)

Variable bool : NProp.
Variable p2b : NProp -> El bool.
Variable b2p : El bool -> NProp.
Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A.
Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)).

(** ** Paradox *)

Theorem paradox : forall B:NProp, El B.
Proof.
  intros B.
  unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))).
  + exact (fun P => ~~P).
  + exact bool.
  + exact p2b.
  + exact b2p.
  + exact B.
  + exact h.
  + cbn. auto.
  + cbn. auto.
  + cbn. auto.
Qed.

End Paradox.

End NoRetractToNegativeProp.

(** * Prop is not a retract *)

(** The existence in the pure Calculus of Constructions of a retract
    from [Prop] into a small type of [Prop] is inconsistent. This is a
    special case of the previous result. *)

Module NoRetractFromSmallPropositionToProp.

(** ** The universe of propositions. *)

Definition NProp := { P:Prop | P -> P}.
Definition El : NProp -> Prop := @proj1_sig _ _.

Section MParadox.

(** ** Retract of [Prop] in a small type, using the identity modality. *)

Variable bool : NProp.
Variable p2b : NProp -> El bool.
Variable b2p : El bool -> NProp.
Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A.
Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)).

(** ** Paradox *)

Theorem mparadox : forall B:NProp, El B.
Proof.
  intros B.
  unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))).
  + exact (fun P => P).
  + exact bool.
  + exact p2b.
  + exact b2p.
  + exact B.
  + exact h.
  + cbn. auto.
  + cbn. auto.
  + cbn. auto.
Qed.

End MParadox.

Section Paradox.

(** ** Retract of [Prop] in a small type *)

(** The retract is axiomatized using logical equivalence as the
    equality on propositions. *)
Variable bool : Prop.
Variable p2b : Prop -> bool.
Variable b2p : bool -> Prop.
Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A.
Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A).

(** ** Paradox *)

Theorem paradox : forall B:Prop, B.
Proof.
  intros B.
  unshelve (refine (mparadox (exist _ bool (fun x => x)) _ _ _ _
                   (exist _ B (fun x => x)))).
  + intros p. red. red. exact (p2b (El p)).
  + cbn. intros b. red. exists (b2p b). exact (fun x => x).
  + cbn. intros [A H]. cbn. apply p2p1.
  + cbn. intros [A H]. cbn. apply p2p2.
Qed.

End Paradox.

End NoRetractFromSmallPropositionToProp.

(** * Large universes are not retracts of [Prop]. *)

(** The existence in the Calculus of Constructions with universes of a
    retract from some [Type] universe into [Prop] is inconsistent. *)

(* Note: Assuming the context [down:Type->Prop; up:Prop->Type; forth:
      forall (A:Type), A -> up (down A); back: forall (A:Type), up
      (down A) -> A; H: forall (A:Type) (P:A->Type) (a:A),
      P (back A (forth A a)) -> P a] is probably enough.  *)

Module NoRetractFromTypeToProp.

Definition Type2 := Type.
Definition Type1 := Type : Type2.

Section Paradox.

(** ** Assumption of a retract from Type into Prop *)

Variable down : Type1 -> Prop.
Variable up : Prop -> Type1.
Hypothesis up_down : forall (A:Type1), up (down A) = A :> Type1.

(** ** Paradox *)

Theorem paradox : forall P:Prop, P.
Proof.
  intros P.
  Generic.paradox h.
  (** Large universe. *)
  + exact Type1.
  + exact (fun X => X).
  + cbn. exact (fun u F => forall x, F x).
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).
  + exact (fun F => forall A:Prop, F(up A)).
  + cbn. exact (fun F f A => f (up A)).
  + cbn.
    intros F f A.
    specialize (f (down A)).
    rewrite up_down in f.
    exact f.
  + exact Prop.
  + cbn. exact (fun X => X).
  + cbn. exact (fun A P => forall x:A, P x).
  + cbn. exact (fun A P => forall x:A, P x).
  + cbn. exact P.
  + exact h.
  + cbn. easy.
  + cbn.
    intros F f A.
    destruct (up_down A). cbn.
    reflexivity.
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).
Qed.

End Paradox.

End NoRetractFromTypeToProp.

(** * [A<>Type] *)

(** No Coq universe can be equal to one of its elements. *)

Module TypeNeqSmallType.

Unset Universe Polymorphism.

Section Paradox.

(** ** Universe [U] is equal to one of its elements. *)

Let U := Type.
Variable A:U.
Hypothesis h : U=A.

(** ** Universe [U] is a retract of [A] *)

(** The following context is actually sufficient for the paradox to
    hold. The hypothesis [h:U=A] is only used to define [down], [up]
    and [up_down]. *)

Let down (X:U) : A := @eq_rect _ _ (fun X => X) X _ h.
Let up   (X:A) : U := @eq_rect_r _ _ (fun X => X) X _ h.

Lemma up_down : forall (X:U), up (down X) = X.
Proof.
  unfold up,down.
  rewrite <- h.
  reflexivity.
Qed.

Theorem paradox : False.
Proof.
  Generic.paradox p.
  (** Large universe *)
  + exact U.
  + exact (fun X=>X).
  + cbn. exact (fun X F => forall x:X, F x).
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).
  + exact (fun F => forall x:A, F (up x)).
  + cbn. exact (fun _ f => fun x:A => f (up x)).
  + cbn. intros * f X.
    specialize (f (down X)).
    rewrite up_down in f.
    exact f.
  (** Small universe *)
  + exact A.
  (** The interpretation of [A] as a universe is [U]. *)
  + cbn. exact up.
  + cbn. exact (fun _ F => down (forall x, up (F x))).
  + cbn. exact (fun _ F => down (forall x, up (F x))).
  + cbn. exact (down False).
  + rewrite up_down in p.
    exact p.
  + cbn. easy.
  + cbn. intros ? f X.
    destruct (up_down X). cbn.
    reflexivity.
  + cbn. intros ? ? f.
    rewrite up_down.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down in f.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down in f.
    exact f.
Qed.

End Paradox.

End TypeNeqSmallType.

(** * [Prop<>Type]. *)

(** Special case of [TypeNeqSmallType]. *)

Module PropNeqType.

Theorem paradox : Prop <> Type.
Proof.
  intros h.
  unshelve (refine (TypeNeqSmallType.paradox _ _)).
  + exact Prop.
  + easy.
Qed.

End PropNeqType.

(* end show *)


(*
B2. Pebbling Homomorphisms
==========================
*)

From graph_pebbling Require Import A_primitives B1_graph_pebbling.

Section Pebbling_Embedding.

Context `{graph_G : Basic_Graph G}.
Context `{graph_H : Basic_Graph H}.
Context `{hom : Graph_Hom G H h}.

(*
Injective Embedding
-------------------
*)
Section Injective.

Context {inj : Inj (=) (=) h}.

Theorem inj_hom_solvable_le t n (c_g : conf G) (c_h : conf H) :
  (∀ v, c_g v ≤ c_h (h v)) -> solvable G t n c_g -> solvable H (h t) n c_h.
Proof.
intros H_le (c' & Hc & Ht); revert c_h H_le.
induction Hc as [c_g|c1_g c2_g c'_g H1]; intros.
- eexists; split; [reflexivity|].
  etrans; [apply Ht|apply H_le].
- inversion_clear H1; cbn in H_conf.
  pose (w_uv := weight H (h u) (h v));
  pose (c2_h := alter S (h v) (alter (subtract w_uv) (h u) c_h)).
  apply IHHc with (c_h:=c2_h) in Ht as (c'_h & H2 & H3).
  + exists c'_h; split; [|done]. eapply rtc_l; [|done].
    eapply one_pebble_step; [apply graph_hom_edge; done|cbn|done].
    etrans; [|apply H_le]; etrans; [|apply H_conf].
    rewrite graph_hom_weight; done.
  + intros w; unfold c2_h, w_uv; rewrite R_conf.
    assert (H2 := graph_hom_weight u v); assert (H3 := H_le w).
    dec (w = u); [dec (v = u)|dec (w = v)]; simpl_alter;
    cbn; try apply not_inj; try done; lia.
Qed.

Corollary inj_hom_solvable t n (c : conf H) :
  solvable G t n (c ∘ h) -> solvable H (h t) n c.
Proof. apply inj_hom_solvable_le; done. Qed.

End Injective.

(*
Surjective Embedding
-------------------
*)
Section Surjective.

Context {surj : Surj (=) h}.

Lemma pebble_step_map_conf c c' :
  c --> c' -> dmap h c --> dmap h c'.
Proof.
inversion_clear 1; subst.
assert (Hh_edge : E H (h u) (h v)) by (apply graph_hom_edge; done).
eapply one_pebble_step; [done|cbn|].
- rewrite graph_hom_weight; [|done]; etrans; [apply H_conf|].
  apply elem_of_summation, elem_of_list_fmap_1, elem_of_inv.
- apply irrefl_ne in H_edge as ?, Hh_edge.
  extensionality w; unfold dmap.
  assert (Hw := NoDup_inv h w).
  (* Simplify left side. *)
  destruct (decide (u ∈ inv h w)) as [Hu|Hu], (decide (v ∈ inv h w)) as [Hv|Hv];
  repeat (rewrite foldr_alter; [|done|done|done])
    || (rewrite fmap_no_alter; [|done]).
  (* Simplify right side. *)
  all: try apply elem_of_inv_spec in Hu; subst.
  all: try apply elem_of_inv_spec in Hv; subst. 1: done.
  all: try apply not_elem_of_inv_spec in Hu as H1.
  all: try apply not_elem_of_inv_spec in Hv as H2.
  all: simpl_alter; cbn; try done.
  rewrite graph_hom_weight; done.
Qed.

Theorem surj_hom_solvable t n (c : conf G) :
  solvable G t n c -> solvable H (h t) n (dmap h c).
Proof.
intros (c' & H1 & H2); exists (dmap h c'); split.
- revert H1; apply rtc_congruence, pebble_step_map_conf.
- etrans; [apply H2|apply elem_of_summation, elem_of_list_fmap_1, elem_of_inv].
Qed.

Lemma surj_hom_vertex_pebbling_bound n t :
  vertex_pebbling_bound G n t -> vertex_pebbling_bound H n (h t).
Proof.
intros Hn c Hc; rewrite <-inv_dmap_spec; apply surj_hom_solvable, Hn.
rewrite size_inv_dmap; done.
Qed.

Corollary surj_hom_pebbling_bound n :
  pebbling_bound G n -> pebbling_bound H n.
Proof.
intros Hn t; destruct (surj t) as [t' <-].
apply surj_hom_vertex_pebbling_bound; done.
Qed.

End Surjective.

End Pebbling_Embedding.


From Coq Require Import Strings.String.
From SE Require Export Model.

(** Checks whether two symbolic expressions are equal.
    As of right now, does not worry about manipulations
    by commutativity, associativity, or the like. *)
Fixpoint symbolicExpEq (se1 se2: SymbolicExp) : bool :=
  match se1 with
  | Symbol str1 =>
    match se2 with
    | Symbol str2 => (String.eqb str1 str2)
    | _ => false
    end
  | SymAdd se1_l se1_r =>
    match se2 with
    | SymAdd se2_l se2_r => andb (symbolicExpEq se1_l se2_l) (symbolicExpEq se1_r se2_r)
    | _ => false
    end
  | SymSub se1_l se1_r =>
    match se2 with
    | SymSub se2_l se2_r => andb (symbolicExpEq se1_l se2_l) (symbolicExpEq se1_r se2_r)
    | _ => false
    end
  | SymMult se1_l se1_r =>
    match se2 with
    | SymMult se2_l se2_r => andb (symbolicExpEq se1_l se2_l) (symbolicExpEq se1_r se2_r)
    | _ => false
    end
  | Constant n1 =>
    match se2 with
    | Constant n2 => true
    | _ => false
    end
  end.

(** Checks whether two symbolic boolean expressions
    are equal. As above, we don't consider any logical
    manipulations of the same boolean function as equivalent. *)
Fixpoint SBoolExpEq (sbe1 sbe2: SBoolExp) : bool :=
  match sbe1 with
  | SBTrue =>
    match sbe2 with
    | SBTrue => true
    | _ => false
    end
  | SBFalse =>
    match sbe2 with
    | SBFalse => true
    | _ => false
    end
  | SBnot sbe1p =>
    match sbe2 with
    | SBnot sbe2p => SBoolExpEq sbe1p sbe2p
    | _ => false
    end
  | SBge0 se1 => match sbe2 with
    | SBge0 se2 => symbolicExpEq se1 se2
    | _ => false
    end
  end.

Fixpoint listEq {A: Type} (eq: A -> A -> bool) (list1 list2: list A) : bool :=
  match (Nat.eqb (List.length list1) (List.length list2)) with
  | true =>
    match list1 with
    | nil =>
      match list2 with
      | nil => true
      | _   => false
      end
    | h1 :: t1 => match list2 with
      | nil => false
      | h2 :: t2 => andb (eq h1 h2) (listEq eq t1 t2)
      end
    end
  | false => false
  end.

Definition oneMapEq (x y: (string * SymbolicExp)) : bool :=
  match x with
  | (s1, se1) =>
  match y with
  | (s2, se2) =>
  andb (String.eqb s1 s2) (symbolicExpEq se1 se2)
  end
  end.

Definition stateEq (st1 st2: state) : bool :=
  listEq oneMapEq st1 st2.

Definition pcEq (pc1 pc2: PathCond) : bool :=
  listEq SBoolExpEq pc1 pc2.

(** Building on everything else in this file, this function tests
    whether two nodes are equal. This definition of equality will
    treat the node's state and path condition as sets of individual
    mappings and boolean expressions, respectively. But we only check
    equality naively on expressions, not worrying about rearrangements
    of equivalent statements. In practice this isn't a problem, as
    we mostly will be comparing nodes within one symbolic execution
    tree. *)
Definition nodeEq (node1 node2: TreeNode) : bool :=
  match node1 with
  | << st1, pc1, i1 >> =>
  match node2 with
  | << st2, pc2, i2 >> =>
  andb (stateEq st1 st2) (andb (pcEq pc1 pc2) (Nat.eqb i1 i2))
  end
end.


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

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

Print Assumptions square.


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

Ralph Matthes

2022, after the model of EndofunctorsMonoidal
*)

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

Contents :

- build monoidal category for the endofunctors

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

Require Import UniMath.Foundations.PartD.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.

Local Open Scope cat.

Section Endofunctors_as_monoidal_category.

  Context (C : category).

  Definition cat_of_endofunctors: category := category_from_bicat_and_ob(C:=bicat_of_cats) C.

  Definition monoidal_of_endofunctors: monoidal cat_of_endofunctors:= monoidal_from_bicat_and_ob(C:=bicat_of_cats) C.
  (** we need this high-level view in order to be able to instantiate [montrafotargetbicat_disp_monoidal] in [ActionBasedStrongFunctorsWhiskeredMonoidal] *)

End Endofunctors_as_monoidal_category.


(** Coq coding by choukh, May 2022 **)

From ZF Require Export Basic.

(** 关于并入的引理 **)
Section AdjunctionFacts.
Context {𝓜 : ZF}.
Implicit Type a b x y z : 𝓜.

Lemma 并入之并 a b : ⋃ (a ⨮ b) = a ∪ ⋃b.
Proof.
  apply 外延; intros x xu.
  - apply 并集 in xu as [y [xy yu]].
    apply 并入 in yu as [->|].
    apply 二元并. auto.
    apply 二元并. right. apply 并集. eauto.
  - apply 二元并 in xu as []; apply 并集.
    + exists a. split. auto. apply 并入. auto.
    + apply 并集 in H as [y [xy yb]].
      exists y. split. auto. apply 并入. auto.
Qed.

Lemma 分离掉再并回去 a b : a ∈ b → a ⨮ b ∩ₚ (λ x, x ≠ a) = b.
Proof.
  intros ab. apply 外延; intros x X.
  - apply 并入 in X as [->|[xb neq]%分离]; auto.
  - 排中 (x = a) as [->|]; apply 并入. auto. right. now apply 分离.
Qed.

Lemma 并入之幂 a b : 𝒫 (a ⨮ b) = (λ x, a ⨮ x)[𝒫 b] ∪ 𝒫 b.
Proof.
  apply 外延; intros x X.
  - apply 幂集 in X. 排中 (a ∈ x).
    + apply 二元并. left. apply 函数式替代.
      exists (x ∩ₚ (λ x, x ≠ a)). split.
      * apply 幂集. intros y [yx neq]%分离.
        apply X, 并入 in yx as []; congruence.
      * now apply 分离掉再并回去.
    + apply 二元并. right. apply 幂集.
      intros y yx. apply X in yx as yu.
      apply 并入 in yu as [->|]; congruence.
  - apply 幂集. intros y yx. apply 二元并 in X as [X|X].
    + apply 函数式替代 in X as [z [zb%幂集 <-]].
      apply 并入 in yx as [->|]; apply 并入; auto.
    + apply 幂集 in X. apply 并入. auto.
Qed.

(* a在R中没定义的时候 (𝓕 R a) 还是一个集合, 所以反向不成立 *)
Lemma 并入之替代 R a b : 函数性 R → R @ (a ⨮ b) ⊆ (𝓕 R a) ⨮ (R @ b).
Proof.
  intros Fun y Y.
  apply 替代 in Y as [x [[->|xb]%并入 Rxy]]; trivial; apply 并入.
  - left. apply 函数化 in Rxy; auto.
  - right. apply 替代; trivial. now exists x.
Qed.

End AdjunctionFacts.


Require Export functor.
Require Import prod.

(** △ diagonal functor. *)
Definition diag := fun A => prod A A.

Instance Fmap_diag : Fmap diag :=
  fun _ _ f => bimap f f.

Instance Functor_diag : Functor diag.
Proof.
  constructor; intros.
  - apply bimap_id.
  - apply bimap_comp.
Qed.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Crypto.Algebra.Ring.
Require Import Crypto.ArithmeticCPS.Core.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Util.CPSUtil.
Require Import Crypto.Util.CPSNotations.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.AddGetCarry Crypto.Util.ZUtil.MulSplit.
Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.

Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope Z_scope.

Import CPSBindNotations.
Local Open Scope cps_scope.

Module Associational (Import RT : Runtime).
  Section Associational.

    Definition sat_multerm_cps s (t t' : (Z * Z)) : ~> list (Z * Z) :=
      fun T k => dlet_nd xy := RT_Z.mul_split s (snd t) (snd t') in
      k [(fst t * fst t', fst xy); (fst t * fst t' * s, snd xy)].

    Definition sat_mul_cps s (p q : list (Z * Z)) : ~> list (Z * Z) :=
      fun T => flat_map_cps (fun t T => flat_map_cps (fun t' => sat_multerm_cps s t t') q) p.

    Definition sat_multerm_const_cps s (t t' : (Z * Z)) : ~> list (Z * Z) :=
      fun T k
      => if snd t =? 1
         then k [(fst t * fst t', snd t')]
         else if snd t =? -1
              then k [(fst t * fst t', - snd t')]
              else if snd t =? 0
                   then k nil
                   else dlet_nd xy := RT_Z.mul_split s (snd t) (snd t') in
          k [(fst t * fst t', fst xy); (fst t * fst t' * s, snd xy)].

    Definition sat_mul_const_cps s (p q : list (Z * Z)) : ~> list (Z * Z) :=
      fun T => flat_map_cps (fun t T => flat_map_cps (fun t' => sat_multerm_const_cps s t t') q) p.
  End Associational.
End Associational.

Module Columns (Import RT : Runtime).
  Module Import Deps.
    Module Import Positional := Positional RT.
  End Deps.
  Section Columns.
    Context (weight : nat -> Z).

    Definition eval n (x : list (list Z)) : Z := Positional.eval weight n (map sum x).

    Section Flatten.
      Section flatten_column.
        Context (fw : Z). (* maximum size of the result *)

        (* Outputs (sum, carry) *)
        Definition flatten_column_cps (digit: list Z) : ~> (Z * Z) :=
          list_rect (fun _ => ~> (Z * Z)%type) (return (0,0))
                    (fun xx tl flatten_column_tl =>
                       list_case
                         (fun _ => ~> (Z * Z)%type) (fun T k => k ((xx mod fw)%RT, (xx / fw)%RT))
                         (fun yy tl' =>
                            list_case
                              (fun _ => ~> (Z * Z)%type) (fun T k => dlet_nd x := xx in dlet_nd y := yy in k (RT_Z.add_get_carry_full fw x y))
                              (fun _ _ =>
                                 flatten_column_tl <- flatten_column_tl;
                                 fun T k => dlet_nd x := xx in
                                   dlet_nd rec1 := fst flatten_column_tl in (* recursively get the sum and carry *)
                                   dlet_nd rec2 := snd flatten_column_tl in
                                   dlet_nd sum_carry := RT_Z.add_get_carry_full fw x rec1 in (* add the new value to the sum *)
                                   dlet_nd carry' := (snd sum_carry + rec2)%RT in (* add the two carries together *)
                                   k (fst sum_carry, carry'))
                              tl')
                         tl)
                    digit.
      End flatten_column.

      Definition flatten_step_cps (digit:list Z) (acc_carry:list Z * Z) : ~> list Z * Z :=
        (sum_carry <- flatten_column_cps (weight (S (length (fst acc_carry))) / weight (length (fst acc_carry))) (snd acc_carry::digit);
           dlet_nd sum := fst sum_carry in
           dlet_nd carry := snd sum_carry in
             return (fst acc_carry ++ sum :: nil, carry)).

      Definition flatten (xs : list (list Z)) : ~> list Z * Z :=
        fun T => fold_right_cps2 (fun a b => flatten_step_cps a b) (nil,0) (rev xs).
    End Flatten.

    Section FromAssociational.
      (* nils *)
      Definition nils n : list (list Z) := repeat nil n.
      (* cons_to_nth *)
      Definition cons_to_nth i x (xs : list (list Z)) : list (list Z) :=
        ListUtil.update_nth i (fun y => cons x y) xs.

      (* from_associational *)
      Definition from_associational_cps n (p:list (Z*Z)) : ~> list (list Z) :=
        fun T => fold_right_cps2 (fun t ls T k =>
                                    let '(p1, p2) := Positional.place weight t (pred n) in
                                    dlet_nd p2 := p2 in
                           k (cons_to_nth p1 p2 ls) ) (nils n) p.
    End FromAssociational.
  End Columns.
End Columns.

Module Rows (Import RT : Runtime).
  Module Import Deps.
    Module Associational := Associational RT.
    Module Positional := Positional RT.
    Module Columns := Columns RT.
    Module Export Core.
      Module Associational := ArithmeticCPS.Core.Associational RT.
    End Core.
  End Deps.
  Section Rows.
    Context (weight : nat -> Z).
    Local Notation rows := (list (list Z)) (only parsing).
    Local Notation cols := (list (list Z)) (only parsing).

    Definition eval n (inp : rows) :=
      sum (map (Positional.eval weight n) inp).

    Section FromAssociational.
      (* extract row *)
      Definition extract_row (inp : cols) : cols * list Z := (map (fun c => tl c) inp, map (fun c => hd 0 c) inp).

      Definition max_column_size (x:cols) := fold_right (fun a b => Nat.max a b) 0%nat (map (fun c => length c) x).

      (* from_columns *)
      Definition from_columns' n start_state : cols * rows :=
        fold_right (fun _ (state : cols * rows) =>
                      let cols'_row := extract_row (fst state) in
                      (fst cols'_row, snd state ++ [snd cols'_row])
                   ) start_state (repeat 0 n).

      Definition from_columns (inp : cols) : rows := snd (from_columns' (max_column_size inp) (inp, [])).

      (* from associational *)
      Definition from_associational_cps n (p : list (Z * Z)) : ~> _ :=
        (p <- Columns.from_associational_cps weight n p; return (from_columns p)).
    End FromAssociational.

    Section Flatten.
      Local Notation fw := (fun i => weight (S i) / weight i) (only parsing).

      Section SumRows.
        Definition sum_rows'_cps start_state (row1 row2 : list Z) : ~> list Z * Z * nat :=
          fun T => fold_right_cps2 (fun next (state : list Z * Z * nat) T k =>
                        let i := snd state in
                        let low_high := fst state in
                        let low := fst low_high in
                        let high := snd low_high in
                        dlet_nd sum_carry := RT_Z.add_with_get_carry_full (fw i) high (fst next) (snd next) in
                        let low_high' := (low ++ [fst sum_carry], snd sum_carry) in
                        k (low_high', S i)) start_state (rev (combine row1 row2)).
        Definition sum_rows_cps row1 row2 : ~> _ := (sum_rows' <- sum_rows'_cps (nil, 0, 0%nat) row1 row2; return (fst sum_rows')).
      End SumRows.

      Definition flatten'_cps (start_state : list Z * Z) (inp : rows) : ~> list Z * Z :=
        fun T => fold_right_cps2 (fun next_row (state : list Z * Z)=>
                      out_carry <- sum_rows_cps (fst state) next_row;
                        return (fst out_carry, (snd state + snd out_carry)%RT)) start_state inp.

      (* In order for the output to have the right length and bounds,
         we insert rows of zeroes if there are fewer than two rows. *)
      Definition flatten_cps n (inp : rows) : ~> list Z * Z :=
        let default := Positional.zeros n in
        flatten'_cps (hd default inp, 0) (hd default (tl inp) :: tl (tl inp)).
    End Flatten.

    Section Ops.
      Definition add_cps n p q : ~> _ := flatten_cps n [p; q].

      (* TODO: Although cleaner, using Positional.negate snd inserts
      dlets which prevent add-opp=>sub transformation in partial
      evaluation. Should probably either make partial evaluation
      handle that or remove the dlet in Positional.from_associational.

      NOTE(from jgross): I think partial evaluation now handles that
      fine; we should check this. *)
      Definition sub_cps n p q : ~> _ := (_q <- fun T => map_cps2 (fun x T k => dlet y := x in k (-y)%RT) q; flatten_cps n [p; _q]).

      Definition conditional_add_cps n mask cond (p q:list Z) : ~> _ :=
        (qq <- Positional.zselect_cps mask cond q;
           add_cps n p qq).

      (* Subtract q if and only if p >= q. *)
      Definition conditional_sub_cps n (p q:list Z) : ~> _ :=
        (vc <- sub_cps n p q;
           let '(v, c) := vc in
           return (Positional.select (-c)%RT v p)).

      (* the carry will be 0 unless we underflow--we do the addition only
         in the underflow case *)
      Definition sub_then_maybe_add_cps n mask (p q r:list Z) : ~> _ :=
        (p_minus_q_c <- sub_cps n p q;
           let '(p_minus_q, c) := p_minus_q_c in
           rr <- Positional.zselect_cps mask (-c)%RT r;
             res_c' <- add_cps n p_minus_q rr;
             let '(res, c') := res_c' in
         return (res, (c' - c)%RT)).

      Definition mul_cps base n m (p q : list Z) : ~> _ :=
        let p_a := Positional.to_associational weight n p in
        let q_a := Positional.to_associational weight n q in
        (pq_a <- Associational.sat_mul_cps base p_a q_a;
           pq_a <- from_associational_cps m pq_a;
           flatten_cps m pq_a).

      (* if [s] is not exactly equal to a weight, we must adjust it to
         be a weight, so that rather than dividing by s and
         multiplying by c, we divide by w and multiply by c*(w/s).
         See
         https://github.com/mit-plv/fiat-crypto/issues/326#issuecomment-404135131
         for a bit more discussion *)
      Definition adjust_s fuel s : Z * bool :=
        fold_right
          (fun w_i res
           => let '(v, found_adjustment) := res in
              let res := (v, found_adjustment) in
              if found_adjustment:bool
              then res
              else if w_i mod s =? 0
                   then (w_i, true)
                   else res)
          (s, false)
          (map weight (List.rev (seq 0 fuel))).

      (* TODO : move sat_reduce and repeat_sat_reduce to Saturated.Associational *)
      Definition sat_reduce_cps base s c n (p : list (Z * Z)) : ~> _ :=
        let '(s', _) := adjust_s (S (S n)) s in
        let lo_hi := Associational.split s' p in
        (p <- Associational.sat_mul_const_cps base c (snd lo_hi);
           p <- Associational.sat_mul_const_cps base [(1, s'/s)] p;
         return (fst lo_hi ++ p)).

      Definition repeat_sat_reduce_cps base s c (p : list (Z * Z)) n : ~> _ :=
        fun T => fold_right_cps2 (fun _ q => sat_reduce_cps base s c n q) p (seq 0 n).

      Definition mulmod_cps base s c n nreductions (p q : list Z) : ~> _ :=
        let p_a := Positional.to_associational weight n p in
        let q_a := Positional.to_associational weight n q in
        (pq_a <- Associational.sat_mul_cps base p_a q_a;
           r_a <- repeat_sat_reduce_cps base s c pq_a nreductions;
           r_a <- from_associational_cps n r_a;
           flatten_cps n r_a).

      (* returns all-but-lowest-limb and lowest limb *)
      Definition divmod (p : list Z) : list Z * Z
        := (tl p, hd 0 p).
    End Ops.
  End Rows.
End Rows.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.PrimeFieldTheorems Crypto.Algebra.Field.

Require Import Circom.Tuple.
Require Import Crypto.Util.Decidable.
Require Import BabyJubjub.
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

Require Import Circom.Circom.
Require Import Circom.DSL.
Require Import Circom.CircomLib.Bitify.

Require Import Crypto.Spec.ModularArithmetic.
(* Circuit:
* https://github.com/0xPARC/circom-ecdsa/blob/08c2c905b918b563c81a71086e493cb9d39c5a08/circuits/bigint.circom
*)

Module PrimeReduce (C: CIRCOM).

Module B := Bitify C.
Module D := DSL C.
Import C.

Local Open Scope list_scope.
Local Open Scope F_scope.

Local Notation "x [ i ]" := (Tuple.nth_default 0 i x).

(**************************
 * Overflow Representation
 **************************)

Notation "2" := (1 + 1 : F).

Definition half: Z. exact (Z.div q 2). Defined.
Notation "r//2" := half.

(* To signed integer *)
Definition toSZ (x: F) := let z := F.to_Z x in
  if z >=? r//2 + 1 then (z-q)%Z else z.

Lemma toSZ_add: forall a b,
  Z.abs (toSZ a) + Z.abs (toSZ b) < r//2 ->
  toSZ (a + b) = (toSZ a + toSZ b)%Z.
Proof. Abort.

Lemma toSZ_mult: forall a b,
  Z.abs (toSZ a) * Z.abs (toSZ b) < r//2 ->
  toSZ (a * b) = (toSZ a * toSZ b)%Z.
Proof. Abort.

(* PrimeReduce *)
(* source: https://github.com/yi-sun/circom-pairing/blob/743d761f07254ea6407d29ba05f29886cfd14aec/circuits/bigint.circom#L786 *)

(* source: https://github.com/yi-sun/circom-pairing/blob/743d761f07254ea6407d29ba05f29886cfd14aec/circuits/bigint_func.circom *)

Definition F_mod (a b: F) :=
  F.of_Z q ((F.to_Z a) mod (F.to_Z b))%Z.

(* // a is a n-bit scalar
// b has k registers
function long_scalar_mult(n, k, a, b) {
    var out[50];
    for (var i = 0; i < 50; i++) {
        out[i] = 0;
    }
    for (var i = 0; i < k; i++) {
        var temp = out[i] + (a * b[i]);
        out[i] = temp % (1 << n);
        out[i + 1] = out[i + 1] + temp \ (1 << n);
    }
    return out;
} *)
Definition long_scalar_mult
n k a (_b : tuple F k) (out : tuple F 50) :=
let _C := True in
let '( _C) :=
  (* loop: construct out[i] *)
  D.iter (fun i '( _C) => (_C /\ out[i] = 0))
    50 ( _C) in
let '( _C) :=
  D.iter (fun i _C => _C /\
              out[i] = F_mod (out[i] + (a * _b[i]))  (2^n) /\
              out[i + 1] = out[i + 1] + F.div (out[i] + (a * _b[i])) (2^n))
    k _C in
  _C
.

(* // n bits per register
// a has k registers
// b has k registers
// a >= b
function long_sub(n, k, a, b) {
    var diff[50];
    var borrow[50];
    for (var i = 0; i < k; i++) {
        if (i == 0) {
           if (a[i] >= b[i]) {
               diff[i] = a[i] - b[i];
               borrow[i] = 0;
            } else {
               diff[i] = a[i] - b[i] + (1 << n);
               borrow[i] = 1;
            }
        } else {
            if (a[i] >= b[i] + borrow[i - 1]) {
               diff[i] = a[i] - b[i] - borrow[i - 1];
               borrow[i] = 0;
            } else {
               diff[i] = (1 << n) + a[i] - b[i] - borrow[i - 1];
               borrow[i] = 1;
            }
        }
    }
    return diff;
} *)
Definition long_sub (n : nat) (_k : nat) (a b : tuple F _k) : tuple F 50.
Admitted.

(* // 1 if true, 0 if false
function long_gt(n, k, a, b) {
    for (var i = k - 1; i >= 0; i--) {
        if (a[i] > b[i]) {
            return 1;
        }
        if (a[i] < b[i]) {
            return 0;
        }
    }
    return 0;
} *)
Definition long_gt (n : nat) (_k : nat) (a b : tuple F _k) : F.
Admitted.

(* // n bits per register
// a has k + 1 registers
// b has k registers
// assumes leading digit of b is at least 2^(n - 1)
// 0 <= a < (2**n) * b
function short_div_norm(n, k, a, b) {
   var qhat = (a[k] * (1 << n) + a[k - 1]) \ b[k - 1];
   if (qhat > (1 << n) - 1) {
      qhat = (1 << n) - 1;
   }

   var mult[50] = long_scalar_mult(n, k, qhat, b);
   if (long_gt(n, k + 1, mult, a) == 1) {
      mult = long_sub(n, k + 1, mult, b);
      if (long_gt(n, k + 1, mult, a) == 1) {
         return qhat - 2;
      } else {
         return qhat - 1;
      }
   } else {
       return qhat;
   }
} *)
Definition short_div_norm (n : nat) (_k : nat) (a : tuple F (_k + 1)) (b : tuple F _k) : F.
Admitted.

(* // n bits per register
// a has k + 1 registers
// b has k registers
// assumes leading digit of b is non-zero
// 0 <= a < b * 2^n
function short_div(n, k, a, b) {
    var scale = (1 << n) \ (1 + b[k - 1]);
    // k + 2 registers now
    var norm_a[50] = long_scalar_mult(n, k + 1, scale, a);
    // k + 1 registers now
    var norm_b[50] = long_scalar_mult(n, k, scale, b);

    var ret;
    if (norm_b[k] != 0) {
	ret = short_div_norm(n, k + 1, norm_a, norm_b);
    } else {
	ret = short_div_norm(n, k, norm_a, norm_b);
    }
    return ret;
}*)
Definition short_div (n : nat) (_k : nat) (a : tuple F (_k + 1)) (b : tuple F _k) : F.
Admitted.

(* // n bits per register
// a has k + m registers
// b has k registers
// out[0] has length m + 1 -- quotient
// out[1] has length k -- remainder
// implements algorithm of https://people.eecs.berkeley.edu/~fateman/282/F%20Wright%20notes/week4.pdf
// b[k-1] must be nonzero! *)
Definition long_div2 (n : nat) (_k m : nat) (a : tuple F (_k + m)) (b : tuple F _k) : tuple F 2.
Admitted.

Definition long_div := long_div2.

(* function SplitThreeFn(in, n, m, k) {
    return [in % (1 << n), (in \ (1 << n)) % (1 << m), (in \ (1 << n + m)) % (1 << k)];
} *)

Definition SplitThreeFn _in n m k (out : tuple F 3):=
  out[0] = F_mod _in (2^n) /\
  out[1] = F_mod (F.div _in (2^n)) (2^m) /\
  out[2] = F_mod (F.div _in (2^n + (F.of_Z q m))) (2^k).

(* function SplitFn(in, n, m) {
    return [in % (1 << n), (in \ (1 << n)) % (1 << m)];
} *)
Definition SplitFn _in n m (out : tuple F 2):=
  out[0] = F_mod _in (2^n) /\
  out[1] = F_mod (F.div _in (2^n)) (2^m).

(* // n bits per register
// a and b both have k registers
// out[0] has length 2 * k
// adapted from BigMulShortLong and LongToShortNoEndCarry witness computation *)
Definition prod (n : nat) (_k : nat) (a : tuple F _k) (b : tuple F _k) : tuple F 50.
Admitted.

(* function prod_mod(n, k, a, b, p) {
    var prod[50] = prod(n,k,a,b);
    var temp[2][50] = long_div(n,k,prod,p);
    return temp[1];
} *)
Definition prod_mod {_k1 _k2 _k3}(n : nat) (_k : nat) (a : tuple F _k1) (b: tuple F _k2) (p: tuple F _k3): tuple F 50.
Admitted.

Hypothesis prod_mod_correct:
  forall (n: nat) k (a b p: tuple F k),
  B.repr_le n (F_mod ((B.as_le n (to_list k a)) * (B.as_le n (to_list k b))) (B.as_le n (to_list k p))) 50
  (to_list 50 (prod_mod n k a b p)).

(* // n bits per register
// a has k registers
// p has k registers
// e has k registers
// k * n <= 500
// p is a prime
// computes a^e mod p *)
Definition mod_exp {_k1 _k2 _k3} (n: nat) (_k: nat) (a : tuple F _k1) (p : tuple F _k2) (e : tuple F _k3) : tuple F 50. Admitted.

Hypothesis mod_exp_correct:
  forall (n: nat) k k1 (a: tuple F k1)(p e : tuple F k),
  B.repr_le n (F_mod ((B.as_le n (to_list k1 a)) ^ (F.to_N (B.as_le n (to_list k e))))
                        (B.as_le n (to_list k p))) 50
  (to_list 50 (mod_exp n k a p e)).

Print D.iter'.
(* k < 2^n *)
Definition PrimeReduce_cons
  n k m (p : tuple F k)
  (_in : tuple F (m+k))
  (_out : tuple F k)
  (two : tuple F k)
  (e_1 : tuple F k)
  (e_2 : tuple F k)
  (_r : tuple (tuple F 50) m)
  (out_sum : tuple F k)
   :=
  let _C := two[0] = 2 /\ e_1[0] = (F.of_nat q n) /\ e_2[0] = (F.of_nat q k) in
  let _C :=
    D.iter' (fun i _C => _C /\
      two[i] = 0 /\ e_1[i] = 0 /\ e_2[i] = 0) (Nat.sub k 1) k _C in
  let pow2n := mod_exp n k two p e_1 in
  let pow2nk := mod_exp n k pow2n p e_2 in
  let _C :=
    D.iter' (fun i _C => _C /\
          (nth_default (repeat 0 50) i _r) = prod_mod n k (nth_default (repeat 0 50) (i-1) _r) pow2n p)
          (Nat.sub m 1) m
          ((nth_default (repeat 0 50) 0 _r) = pow2nk /\ _C) in
  let _C :=
    D.iter (fun i _C => _C /\
      out_sum[i] = _in[i]) k _C in
  let _C :=
    D.iter (fun i _C => _C /\
      (D.iter (fun j _C => _C /\
                  out_sum[j] = out_sum[j] + _in[i+k] * (nth_default (repeat 0 50) i _r)[j]) k _C)) m _C in
  let _C :=
    D.iter (fun i _C => _C /\
      _out[i] = out_sum[i]) k _C in
  _C
  .

Definition PrimeReduce n k m p _in _out :=
  exists two e_1 e_2 _r out_sum,
  PrimeReduce_cons n k m p _in _out two e_1 e_2 _r out_sum.

Definition toPoly {m} (xs: tuple F m) : list F := to_list m xs.

Lemma toPoly_length: forall {m} (xs: tuple F m),
  length (toPoly xs) = m.
Proof.
  intros. apply length_to_list.
Qed.

Definition sum_in_helper n m _k (_in : tuple F (m+_k)) (_r : tuple (tuple F 50) m) :=
  D.iter (_k) (fun i a => a + _in[i]) 0 +
  D.iter' m (m+_k) (fun i a => a + _in[i] * (B.as_le n (toPoly (nth_default (repeat 0 50) i _r)))) 0.

Definition sum_in_helper1 n m _k (_in : tuple F (m+_k)) (_r : tuple (tuple F 50) m) :=
  D.iter (_k) (fun i a => a + (_in[i] +
  (D.iter' m (m+_k) (fun j b => b + _in[j] * ((nth_default (repeat 0 50) j _r)[i])) 0)) * (2^((N.of_nat n)*(N.of_nat i))) ) 0.

Definition PrimeReduce_spec n k m (p : tuple F k) (_in : tuple F (m+k)) (_out : tuple F k) :=
  F_mod (B.as_le n (toPoly _in)) (B.as_le n (toPoly p)) =
  F_mod (B.as_le n (toPoly _out)) (B.as_le n (toPoly p)).

Theorem PrimeReduce_correct n _k m p _in _out:
  PrimeReduce n _k m p _in _out -> PrimeReduce_spec n _k m p _in _out.
Proof.
  unfold PrimeReduce, PrimeReduce_spec, PrimeReduce_cons.
  intros. unwrap_C.
  destruct H as [two H]. destruct H as [e_1 H]. destruct H as [e_2 H].
  destruct H as [_r H]. destruct H as [out_sum H].
  remember ((two [0] = 2 /\ e_1 [0] = F.of_nat q n /\ e_2 [0] = F.of_nat q _k)) as init_two.
  remember (D.iter' (_k - 1) _k
  (fun (i : nat) (_C : Prop) =>
   _C /\ two [i] = 0 /\ e_1 [i] = 0 /\ e_2 [i] = 0) init_two) as init_two_e.
  remember (mod_exp n _k two p e_1) as pow2n.
  remember (mod_exp n _k pow2n p e_2) as pow2nk.
  remember ((D.iter' (m - 1) m
               (fun (i : nat) (_C : Prop) =>
                _C /\
                nth_default (repeat 0 50) i _r =
                prod_mod n _k (nth_default (repeat 0 50) (i - 1) _r) pow2n p)
               (nth_default (repeat 0 50) 0 _r = pow2nk /\ init_two_e))) as init_r.
  remember ((D.iter _k (fun (i : nat) (_C : Prop) => _C /\ out_sum [i] = _in [i]) init_r)) as init_out_sum.
  remember ((D.iter m
         (fun (i : nat) (_C : Prop) =>
          _C /\
          D.iter _k
            (fun (j : nat) (_C0 : Prop) =>
             _C0 /\
             out_sum [j] = out_sum [j] + _in [i + _k] * nth_default (repeat 0 50) i _r [j])
            _C) init_out_sum)) as init_out_sum'.
  (* init_two *)
  assert(init_two_correct_1: B.as_le _k (toPoly two) = 2). { admit. }
  assert(init_two_correct_2: B.as_le _k (toPoly e_1) = F.of_nat q n). { admit. }
  assert(init_two_correct_3: B.as_le _k (toPoly e_2) = F.of_nat q _k). { admit. }
  (* pow2n pow2nk *)
  pose proof (mod_exp_correct n _k _k two p e_1) as pow2n_correct.
  pose proof (mod_exp_correct n _k 50 pow2n p e_2) as pow2nk_correct.
  (* init_r *)
  (* r_i = B.as_le _k (toPoly r[i]) *)
  assert(init_r_correct: forall i, F_mod ((_in[i]) * (2^((N.of_nat n)*(N.of_nat i)))) (B.as_le n
        (toPoly p)) = F_mod (_in[i] * (B.as_le _k (toPoly (nth_default (repeat 0 50) i _r)))) (B.as_le n
        (toPoly p))). { admit. }
  (* proof *)
  assert(mainProof: sum_in_helper n m _k _in _r = sum_in_helper1 n m _k _in _r).
  { unfold sum_in_helper, sum_in_helper1. admit. }
Admitted.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Export XRdefinitions.
Local Open Scope XR_scope.

Fixpoint INR (n:nat) : R :=
  match n with
  | O => R0
  | S O => R1
  | S n => INR n + R1
  end.
Arguments INR n%nat.


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

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

Print Assumptions carry.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms.
Local Open Scope core_scope.
Axiom f : nat -> nat.
Axiom g : nat -> nat.
Axiom fg : forall x, f x = g x.
Lemma fg_ext : forall x y, x = y -> f x = g y.
Proof. intros; subst; apply fg. Qed.

Axiom f' : nat -> nat -> nat.
Axiom g' : nat -> nat -> nat.
Axiom f'g' : forall x y, f' x y = g' x y.

Hint Rewrite fg : rew_fg.

Fixpoint comp_pow {A} (f : A -> A) (n : nat) (x : A) {struct n} : A
  := match n with
     | O => x
     | S n => f (comp_pow f n x)
     end.

Fixpoint comp_pow_tree {A} (f : A -> A -> A) (n : nat) (x : A) {struct n} : A
  := match n with
     | O => x
     | S n => f (comp_pow_tree f n x) (comp_pow_tree f n x)
     end.

Local Infix "^" := comp_pow : core_scope.

Global Instance eq_Proper {A}
  : Proper (eq ==> eq ==> Basics.flip Basics.impl) (@eq A).
Proof. repeat intro; subst; reflexivity. Qed.
Global Instance f_Proper : Proper (eq ==> eq) f.
Proof. repeat intro; subst; reflexivity. Qed.
Global Instance g_Proper : Proper (eq ==> eq) g.
Proof. repeat intro; subst; reflexivity. Qed.

Notation goal n := (forall x, (f^n) x = (g^n) x).
Notation goal_noop n := (forall x, (g^n) x = (g^n) x).
Notation goal_noop_exp lgn := (forall x, comp_pow_tree g' lgn x = comp_pow_tree g' lgn x).
Ltac mkgoal n := constr:(goal n).
Ltac mkgoal_noop n := constr:(goal_noop n).
Ltac mkgoal_noop_exp n := constr:(goal_noop_exp n).
Ltac redgoal _ := cbv [comp_pow comp_pow_tree]; intro.
Ltac describe_goal_noop_exp lgn :=
  let lgnz := (eval cbv in (Z.of_nat lgn)) in
  let nz := (eval cbv in ((2^(lgnz+1) - 1)%Z)) in
  idtac "Params: 0-n=" nz ", 1-lgn=" lgnz.

Ltac preshare_pf f g fx gy Hfg_ext cont :=
  lazymatch fx with
  | f ?x
    => lazymatch gy with
       | g ?y
         => preshare_pf
              f g x y Hfg_ext
              ltac:(fun x' y' pf
                    => let fH := fresh f in
                       let gH := fresh g in
                       let __ := match goal with _ => pose (f x') as fH; pose (g y') as gH end in
                       cont fH gH uconstr:(Hfg_ext x' y' pf))
       | _ => fail 0 "Invalid mismatch" fx gy
       end
  | ?x
    => lazymatch gy with
       | x
         => let A := type of x in
            cont x x uconstr:(@eq_refl A x)
       | _ => fail 0 "Invalid mismatch" fx gy
       end
  end.

Ltac fast_rewrite :=
  time "pose-build-and-refine-regression-cubic"
    lazymatch goal with
    | [ |- f ?x = g ?y :> ?A ]
      => refine (_ : f x = g y :> A);
         preshare_pf
           f g (f x) (g y) fg_ext
           ltac:(fun x' y' pf
                 => time "refine-regression-quadratic-regression-linear" refine pf)
    end.