(** Test.v:  application demo of "ftype" usage-style of VCfloat.
 Copyright (C) 2021-2022 Andrew W. Appel and Ariel Kellison.
*)

Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary.
Import Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".

Open Scope R_scope.

Section WITHNANS.

(** NANS:  Each different computer architecture supports the same IEEE-754
  floating-point standard, but with slightly different Not-a-number (NAN) behavior.
  That behavior is encapsulated in a Nans typeclass.  You can instantiate that
  appropriate for your own architecture; but all the demos in this file are
  independent of the Nans details, so we can leave it abstract, like this: *)
Context {NANS: Nans}.

(** We will demonstrate VCfloat on a symplectic ODE (ordinary differential
  equation) integration for a simple harmonic oscillator. *)

Definition h := (1 / 32)%F32.   (* Time-step: 1/32 of a second *)

(* Force, as a function of position *)
Definition F (x : ftype Tsingle ) : ftype Tsingle := (-x)%F32.

(** Compute one time-step: given "ic" which is a pair of position and velocity,
  calculate the new position and velocity after time "h" has elapsed. *)
Definition leapfrog_step ( ic : ftype Tsingle * ftype Tsingle) : ftype Tsingle * ftype Tsingle :=
  let x  := fst ic in let v:= snd ic in
  let x' := ((x + h * v) + ((1/2) * (h * h)) * F x)%F32 in
  let v' :=  (v +  (1/2 * h) * (F x + F x'))%F32 in
  (x', v').

(** Calculate a new position, as a function of position x and velocity v *)
Definition leapfrog_stepx x v := fst (leapfrog_step (x,v)).

(** Calculate a new velocity, as a function of position x and velocity v *)
Definition leapfrog_stepv x v := snd (leapfrog_step (x,v)).

(** In deep-embedded (syntactic) expressons, variables are represented
  by "ident"ifiers, which are actually small positive numbers. *)
Definition _x : ident := 1%positive.  (* Variable name for position *)
Definition _v : ident := 2%positive.  (* Variable name for velocity *)

(** These two lines compute a deep-embedded "expr"ession from
  a shallow-embedded Coq expression.  *)
Definition x' := ltac:(let e' :=
  HO_reify_float_expr constr:([_x; _v]) leapfrog_stepx in exact e').
Definition v' := ltac:(let e' :=
  HO_reify_float_expr constr:([_x; _v]) leapfrog_stepv in exact e').

Print x'.  (* Demonstrates what x' looks like *)

(** When interpreting deep-embedded expressions, "Var"iables will appear
  which are labeled by identifiers such as "_x" and "_v".  We want a
  "varmap" for looking up the values of those variables.  We'll compute
  that varmap in two stages.  Step one, given values "x" and "v",
  make an association list mapping _x to x, and _v to v,  each labeled
  by its floating-point type.  *)

Definition leapfrog_vmap_list (x v : ftype Tsingle) :=
   [(_x, existT ftype _ x);(_v, existT ftype _ v)].

(** Step two, build that into "varmap" data structure, taking care to
  compute it into a lookup-tree ___here___, not later in each place
  where we look something up. *)
Definition leapfrog_vmap (x v : ftype Tsingle) : valmap :=
 ltac:(let z := compute_PTree (valmap_of_list (leapfrog_vmap_list x v)) in exact z).

(**  Demonstration of reification and reflection.   When you have a
  deep-embedded "expr"ession, you can get back the shallow embedding
   by applying the "fval" function *)

Lemma reflect_reify_x : forall x v,
             fval (env_ (leapfrog_vmap x v)) x' = leapfrog_stepx x v.
Proof.
intros.
destruct true.  (* artificial way to get two subgoals *)
-
   unfold x', leapfrog_stepx, leapfrog_step, F,  fst, snd.  (* This line makes things go faster *)
  Time reflexivity.  (* 0.01 sec *)
-
   (* Demonstration that unfold_reflect doesn't make things any faster (or much slower). *)
   unfold x', leapfrog_stepx, leapfrog_step, F,  fst, snd.  (* This line needed here  *)
   Time unfold_reflect. (* 0.02 secs *)
   Time reflexivity. (* 0.006 sec *)
   (* Therefore, use unfold_reflect if you wish to, for clarity, not for performance *)
Qed.

(**  Demonstration of reification and reflection, this time on  leapfrog_stepv *)
Lemma reflect_reify_v : forall x v, fval (env_ (leapfrog_vmap x v)) v' = leapfrog_stepv x v.
Proof.
intros.
unfold v'.
(* without this line, things are much slower: *) unfold leapfrog_stepv, leapfrog_step, F,  fst, snd.
Time reflexivity.
Qed.

(** The main point of VCFloat is to prove bounds on the roundoff error of
  floating-point expressions.  Generally those bounds are provable only if
  the free variables of the expression (e.g., "x" and "v") are themselves
  bounded in some way;  otherwise, the expression might overflow.
  A "boundsmap" is a mapping from identifier (such as "_x") to
  a "varinfo", which gives its (floating-point) and its lower and upper bound. *)

(** First we make an association list.  This one says that
   -2.0 <= x <= 2.0   and   -2.0 <= v <= 2.0  *)
Definition leapfrog_bmap_list : list varinfo :=
  [ Build_varinfo Tsingle _x (-2)  2 ;  Build_varinfo Tsingle _v (-2)  2 ].

(** Then we calculate an efficient lookup table, the "boundsmap". *)
Definition leapfrog_bmap : boundsmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list leapfrog_bmap_list) in exact z).

(** Now we prove that the leapfrogx expression (deep-embedded as  x' )
   has a roundoff error less than 1.0e-5 *)
Lemma prove_roundoff_bound_x:
  forall vmap,
  prove_roundoff_bound leapfrog_bmap vmap x'
    (/ 4068166).
Proof.
intros.
prove_roundoff_bound.
 (* This divides into two proof goals.
  Goal 1 is "prove_rndval", which generates a list of verification conditions
        about subexpressions of x'; and if those can be proved, then
  x' evaluates equivalent to a perturbed expression.
  Goal 2 shows that the perturbed expression evaluates "close to"
  the exact real-number interpretation of expression x'.  *)
-
  (* Solve Goal 1 by the prove_rndval tactic, which generates
    a list of interval subgoals, and  prove each one of those
     by the "interval" tactic *)
 prove_rndval.
 all: interval.
-
 prove_roundoff_bound2.
 match goal with |- Rabs ?a <= _ => field_simplify a end. (* improves the bound *)

 (* Right now, just "interval" would solve the goal.
  but to see how we guess the bound to use, try this instead: *)
  match goal with |- Rabs ?a <= _ => interval_intro (Rabs a) end.
 eapply Rle_trans; [apply H | clear].
 eapply roundoff_bound_hack; [lia|lia|lia|compute; reflexivity|].
 lia.
Qed.

Derive x_acc
 SuchThat  (forall vmap,  prove_roundoff_bound leapfrog_bmap vmap x' x_acc)
 As prove_roundoff_bound_x_alt.
Proof.
intros.
 prove_roundoff_bound.
-
 prove_rndval; interval.
-
prove_roundoff_bound2.
match goal with |- Rabs ?a <= _ => field_simplify a end.
match goal with |- Rabs ?a <= _ => interval_intro (Rabs a) end.
subst x_acc; apply H.
Qed.

Print x_acc.
Check prove_roundoff_bound_x_alt.

Lemma prove_roundoff_bound_v:
  forall x v : ftype Tsingle,
  prove_roundoff_bound leapfrog_bmap (leapfrog_vmap x v) v'
    (/ 7662902).
Proof.
intros.
prove_roundoff_bound.
- abstract (prove_rndval; interval).
-
  prove_roundoff_bound2.
 match goal with |- Rabs ?a <= _ => field_simplify a end.
 interval.
Qed.

(*  This one commented out, because prove_val_bound2 needs to
   be brought up to date with the recent changes to prove_roundoff_bound2
(** The following lemma demonstrates [val_bound],  that is,
  compute the maximum absolute value of a floating-point expression *)
Lemma prove_val_bound_x:
  forall vmap,
  prove_val_bound leapfrog_bmap vmap x'
    (4642138645987358 / 2251799813685248).
Proof.
intros.
prove_val_bound.
-
 abstract (prove_rndval; interval).
-
  prove_val_bound2.
 match goal with |- Rabs ?a <= _ => field_simplify a end.
  match goal with |- Rabs ?a <= _ => interval_intro (Rabs a) end.
 eapply Rle_trans; [apply H | clear].
 lra.
Qed.
*)
End WITHNANS.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import div fintype tuple finfun bigop prime finset.

(******************************************************************************)
(* This files contains the definition of:                                     *)
(*   'C(n, m) == the binomial coefficient n choose m.                         *)
(*     n ^_ m == the falling (or lower) factorial of n with m terms, i.e.,    *)
(*               the product n * (n - 1) * ... * (n - m + 1).                 *)
(*               Note that n ^_ m = 0 if m > n, and 'C(n, m) = n ^_ m %/ m`!. *)
(*                                                                            *)
(* In additions to the properties of these functions, we prove a few seminal  *)
(* results such as triangular_sum, Wilson and Pascal; their proofs are good   *)
(* examples of how to manipulate expressions with bigops.                     *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** More properties of the factorial **)

Lemma fact_prod n : n`! = \prod_(1 <= i < n.+1) i.
Proof.
elim: n => [|n IHn] //; first by rewrite big_nil.
by apply/esym; rewrite factS IHn // !big_add1 big_nat_recr //= mulnC.
Qed.

Lemma fact_split n m : m <= n -> n`! = m`! * \prod_(m.+1 <= k < n.+1) k.
Proof. by move=> leq_mn; rewrite !fact_prod -big_cat_nat. Qed.

Lemma logn_fact p n : prime p -> logn p n`! = \sum_(1 <= k < n.+1) n %/ p ^ k.
Proof.
move=> p_prime; transitivity (\sum_(1 <= i < n.+1) logn p i).
  rewrite big_add1; elim: n => /= [|n IHn]; first by rewrite logn1 big_geq.
  by rewrite big_nat_recr // -IHn /= factS mulnC lognM ?fact_gt0.
transitivity (\sum_(1 <= i < n.+1) \sum_(1 <= k < n.+1) (p ^ k %| i)).
  apply: eq_big_nat => i /andP[i_gt0 le_i_n]; rewrite logn_count_dvd //.
  rewrite -!big_mkcond (big_nat_widen _ _ n.+1) 1?ltnW //; apply: eq_bigl => k.
  by apply: andb_idr => /dvdn_leq/(leq_trans (ltn_expl _ (prime_gt1 _)))->.
by rewrite exchange_big_nat; apply: eq_bigr => i _; rewrite divn_count_dvd.
Qed.

Theorem Wilson p : p > 1 -> prime p = (p %| ((p.-1)`!).+1).
Proof.
have dFact n: 0 < n -> (n.-1)`! = \prod_(0 <= i < n | i != 0) i.
  move=> n_gt0; rewrite -big_filter fact_prod; symmetry; apply: congr_big => //.
  rewrite /index_iota subn1 -[n]prednK //=; apply/all_filterP.
  by rewrite all_predC has_pred1 mem_iota.
move=> lt1p; have p_gt0 := ltnW lt1p.
apply/idP/idP=> [pr_p | dv_pF]; last first.
  apply/primeP; split=> // d dv_dp; have: d <= p by apply: dvdn_leq.
  rewrite orbC leq_eqVlt => /orP[-> // | ltdp].
  have:= dvdn_trans dv_dp dv_pF; rewrite dFact // big_mkord.
  rewrite (bigD1 (Ordinal ltdp)) /=; last by rewrite -lt0n (dvdn_gt0 p_gt0).
  by rewrite orbC -addn1 dvdn_addr ?dvdn_mulr // dvdn1 => ->.
pose Fp1 := Ordinal lt1p; pose Fp0 := Ordinal p_gt0.
have ltp1p: p.-1 < p by [rewrite prednK]; pose Fpn1 := Ordinal ltp1p.
case eqF1n1: (Fp1 == Fpn1); first by rewrite -{1}[p]prednK -1?((1 =P p.-1) _).
have toFpP m: m %% p < p by rewrite ltn_mod.
pose toFp := Ordinal (toFpP _); pose mFp (i j : 'I_p) := toFp (i * j).
have Fp_mod (i : 'I_p) : i %% p = i by apply: modn_small.
have mFpA: associative mFp.
  by move=> i j k; apply: val_inj; rewrite /= modnMml modnMmr mulnA.
have mFpC: commutative mFp by move=> i j; apply: val_inj; rewrite /= mulnC.
have mFp1: left_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= mul1n.
have mFp1r: right_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= muln1.
pose mFpLaw := Monoid.Law mFpA mFp1 mFp1r.
pose mFpM := Monoid.operator (@Monoid.ComLaw _ _ mFpLaw mFpC).
pose vFp (i : 'I_p) := toFp (egcdn i p).1.
have vFpV i: i != Fp0 -> mFp (vFp i) i = Fp1.
  rewrite -val_eqE /= -lt0n => i_gt0; apply: val_inj => /=.
  rewrite modnMml; case: egcdnP => //= _ km -> _; rewrite {km}modnMDl.
  suffices: coprime i p by move/eqnP->; rewrite modn_small.
  rewrite coprime_sym prime_coprime //; apply/negP=> /(dvdn_leq i_gt0).
  by rewrite leqNgt ltn_ord.
have vFp0 i: i != Fp0 -> vFp i != Fp0.
  by move/vFpV; apply/contra_eq_neq => ->; rewrite -val_eqE /= mul0n mod0n.
have vFpK: {in predC1 Fp0, involutive vFp}.
  move=> i n0i; rewrite /= -[vFp _]mFp1r -(vFpV _ n0i) mFpA.
  by rewrite vFpV (vFp0, mFp1).
have le_pmFp (i : 'I_p) m: i <= p + m.
  by apply: leq_trans (ltnW _) (leq_addr _ _).
have eqFp (i j : 'I_p): (i == j) = (p %| p + i - j).
  by rewrite -eqn_mod_dvd ?(modnDl, Fp_mod).
have vFpId i: (vFp i == i :> nat) = xpred2 Fp1 Fpn1 i.
  have [->{i} | ni0] := eqVneq i Fp0.
    by rewrite -!val_eqE /= egcd0n modn_small //= -(subnKC lt1p).
  rewrite 2!eqFp -Euclid_dvdM // -[_ - p.-1]subSS prednK //.
  have lt0i: 0 < i by rewrite lt0n.
  rewrite -addnS addKn -addnBA // mulnDl -{2}(addn1 i) -subn_sqr.
  rewrite addnBA ?leq_sqr // mulnS -addnA -mulnn -mulnDl.
  rewrite -(subnK (le_pmFp (vFp i) i)) mulnDl addnCA.
  rewrite -[1 ^ 2]/(Fp1 : nat) -addnBA // dvdn_addl.
    by rewrite Euclid_dvdM // -eqFp eq_sym orbC /dvdn Fp_mod eqn0Ngt lt0i.
  by rewrite -eqn_mod_dvd // Fp_mod modnDl -(vFpV _ ni0).
suffices [mod_fact]: toFp (p.-1)`! = Fpn1.
  by rewrite /dvdn -addn1 -modnDml mod_fact addn1 prednK // modnn.
rewrite dFact //; rewrite ((big_morph toFp) Fp1 mFpM) //; first last.
- by apply: val_inj; rewrite /= modn_small.
- by move=> i j; apply: val_inj; rewrite /= modnMm.
rewrite big_mkord (eq_bigr id) => [|i _]; last by apply: val_inj => /=.
pose ltv i := vFp i < i; rewrite (bigID ltv) -/mFpM [mFpM _ _]mFpC.
rewrite (bigD1 Fp1) -/mFpM; last by rewrite [ltv _]ltn_neqAle vFpId.
rewrite [mFpM _ _]mFp1 (bigD1 Fpn1) -?mFpA -/mFpM; last first.
  rewrite -lt0n -ltnS prednK // lt1p.
  by rewrite [ltv _]ltn_neqAle vFpId eqxx orbT eq_sym eqF1n1.
rewrite (reindex_onto vFp vFp) -/mFpM => [|i]; last by do 3!case/andP; auto.
rewrite (eq_bigl (xpredD1 ltv Fp0)) => [|i]; last first.
  rewrite andbC -!andbA -2!negb_or -vFpId orbC -leq_eqVlt -ltnNge.
  have [->|ni0] := eqVneq i; last by rewrite vFpK // eqxx vFp0.
  by case: eqP => // ->; rewrite !andbF.
rewrite -{2}[mFp]/mFpM -[mFpM _ _]big_split -/mFpM.
by rewrite big1 ?mFp1r //= => i /andP [/vFpV].
Qed.

(** The falling factorial *)

Fixpoint ffact_rec n m := if m is m'.+1 then n * ffact_rec n.-1 m' else 1.

Definition falling_factorial := nosimpl ffact_rec.

Notation "n ^_ m" := (falling_factorial n m)
  (at level 30, right associativity) : nat_scope.

Lemma ffactE : falling_factorial = ffact_rec. Proof. by []. Qed.

Lemma ffactn0 n : n ^_ 0 = 1. Proof. by []. Qed.

Lemma ffact0n m : 0 ^_ m = (m == 0). Proof. by case: m. Qed.

Lemma ffactnS n m : n ^_ m.+1 = n * n.-1 ^_ m. Proof. by []. Qed.

Lemma ffactSS n m : n.+1 ^_ m.+1 = n.+1 * n ^_ m. Proof. by []. Qed.

Lemma ffactn1 n : n ^_ 1 = n. Proof. exact: muln1. Qed.

Lemma ffactnSr n m : n ^_ m.+1 = n ^_ m * (n - m).
Proof.
elim: n m => [|n IHn] [|m] //=; first by rewrite ffactn1 mul1n.
by rewrite !ffactSS IHn mulnA.
Qed.

Lemma ffact_prod n m : n ^_ m = \prod_(i < m) (n - i).
Proof.
elim: m n => [n | m IH [|n] //]; first by rewrite ffactn0 big_ord0.
  by rewrite big_ord_recr /= sub0n muln0.
by rewrite ffactSS IH big_ord_recl subn0.
Qed.

Lemma ffact_gt0 n m : (0 < n ^_ m) = (m <= n).
Proof. by elim: n m => [|n IHn] [|m] //=; rewrite ffactSS muln_gt0 IHn. Qed.

Lemma ffact_small n m : n < m -> n ^_ m = 0.
Proof. by rewrite ltnNge -ffact_gt0; case: posnP. Qed.

Lemma ffactnn n : n ^_ n = n`!.
Proof. by elim: n => [|n IHn] //; rewrite ffactnS IHn. Qed.

Lemma ffact_fact n m : m <= n -> n ^_ m * (n - m)`! = n`!.
Proof.
by elim: n m => [|n IHn] [|m] //= le_m_n; rewrite ?mul1n // -mulnA IHn.
Qed.

Lemma ffact_factd n m : m <= n -> n ^_ m = n`! %/ (n - m)`!.
Proof. by move/ffact_fact <-; rewrite mulnK ?fact_gt0. Qed.

(** Binomial coefficients *)

Fixpoint binomial_rec n m :=
  match n, m with
  | n'.+1, m'.+1 => binomial_rec n' m + binomial_rec n' m'
  | _, 0 => 1
  | 0, _.+1 => 0
  end.
Arguments binomial_rec : simpl nomatch.

Definition binomial := nosimpl binomial_rec.

Notation "''C' ( n , m )" := (binomial n m)
  (at level 8, format "''C' ( n ,  m )") : nat_scope.

Lemma binE : binomial = binomial_rec. Proof. by []. Qed.

Lemma bin0 n : 'C(n, 0) = 1. Proof. by case: n. Qed.

Lemma bin0n m : 'C(0, m) = (m == 0). Proof. by case: m. Qed.

Lemma binS n m : 'C(n.+1, m.+1) = 'C(n, m.+1) + 'C(n, m). Proof. by []. Qed.

Lemma bin1 n : 'C(n, 1) = n.
Proof. by elim: n => //= n IHn; rewrite binS bin0 IHn addn1. Qed.

Lemma bin_gt0 n m : (0 < 'C(n, m)) = (m <= n).
Proof.
by elim: n m => [|n IHn] [|m] //; rewrite addn_gt0 !IHn orbC ltn_neqAle andKb.
Qed.

Lemma leq_bin2l n1 n2 m : n1 <= n2 -> 'C(n1, m) <= 'C(n2, m).
Proof.
by elim: n1 n2 m  => [|n1 IHn] [|n2] [|n] le_n12 //; rewrite leq_add ?IHn.
Qed.

Lemma bin_small n m : n < m -> 'C(n, m) = 0.
Proof. by rewrite ltnNge -bin_gt0; case: posnP. Qed.

Lemma binn n : 'C(n, n) = 1.
Proof. by elim: n => [|n IHn] //; rewrite binS bin_small. Qed.

(* Multiply to move diagonally down and right in the Pascal triangle. *)
Lemma mul_bin_diag n m : n * 'C(n.-1, m) = m.+1 * 'C(n, m.+1).
Proof.
rewrite [RHS]mulnC; elim: n m => [|[|n] IHn] [|m] //=; first by rewrite bin1.
by rewrite mulSn [in _ * _]binS mulnDr addnCA !IHn -mulnS -mulnDl -binS.
Qed.

Lemma bin_fact n m : m <= n -> 'C(n, m) * (m`! * (n - m)`!) = n`!.
Proof.
elim: n m => [|n IHn] [|m] // le_m_n; first by rewrite bin0 !mul1n.
by rewrite !factS -!mulnA mulnCA mulnA -mul_bin_diag -mulnA IHn.
Qed.

(* In fact the only exception for bin_factd is n = 0 and m = 1 *)
Lemma bin_factd n m : 0 < n -> 'C(n, m) = n`! %/ (m`! * (n - m)`!).
Proof.
have [/bin_fact<-|*] := leqP m n; first by rewrite mulnK ?muln_gt0 ?fact_gt0.
by rewrite divnMA bin_small ?divn_small ?fact_gt0 ?ltn_fact.
Qed.

Lemma bin_ffact n m : 'C(n, m) * m`! = n ^_ m.
Proof.
have [lt_n_m | le_m_n] := ltnP n m; first by rewrite bin_small ?ffact_small.
by rewrite ffact_factd // -(bin_fact le_m_n) mulnA mulnK ?fact_gt0.
Qed.

Lemma bin_ffactd n m : 'C(n, m) = n ^_ m %/ m`!.
Proof. by rewrite -bin_ffact mulnK ?fact_gt0. Qed.

Lemma bin_sub n m : m <= n -> 'C(n, n - m) = 'C(n, m).
Proof.
by move=> le_m_n; rewrite !bin_ffactd !ffact_factd ?leq_subr // divnAC subKn.
Qed.

(* Multiply to move down in the Pascal triangle. *)
Lemma mul_bin_down n m : n * 'C(n.-1, m) = (n - m) * 'C(n, m).
Proof.
case: n => //= n; have [lt_n_m | le_m_n] := ltnP n m.
  by rewrite (eqnP lt_n_m) mulnC bin_small.
by rewrite -!['C(_, m)]bin_sub ?leqW ?subSn ?mul_bin_diag.
Qed.

(* Multiply to move left in the Pascal triangle. *)
Lemma mul_bin_left n m : m.+1 * 'C(n, m.+1) = (n - m) * 'C(n, m).
Proof. by rewrite -mul_bin_diag mul_bin_down. Qed.

Lemma binSn n : 'C(n.+1, n) = n.+1.
Proof. by rewrite -bin_sub ?leqnSn // subSnn bin1. Qed.

Lemma bin2 n : 'C(n, 2) = (n * n.-1)./2.
Proof. by rewrite -[n.-1]bin1 mul_bin_diag -divn2 mulKn. Qed.

Lemma bin2odd n : odd n -> 'C(n, 2) = n * n.-1./2.
Proof. by case: n => // n oddn; rewrite bin2 -!divn2 muln_divA ?dvdn2. Qed.

Lemma prime_dvd_bin k p : prime p -> 0 < k < p -> p %| 'C(p, k).
Proof.
move=> p_pr /andP[k_gt0 lt_k_p].
suffices /Gauss_dvdr<-: coprime p (p - k) by rewrite -mul_bin_down dvdn_mulr.
by rewrite prime_coprime // dvdn_subr 1?ltnW // gtnNdvd.
Qed.

Lemma triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2).
Proof.
elim: n => [|n IHn]; first by rewrite big_geq.
by rewrite big_nat_recr // IHn binS bin1.
Qed.

Lemma textbook_triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2).
Proof.
rewrite bin2; apply: canRL half_double _.
rewrite -addnn {1}big_nat_rev -big_split big_mkord /= ?add0n.
rewrite (eq_bigr (fun _ => n.-1)); first by rewrite sum_nat_const card_ord.
by case: n => [|n] [i le_i_n] //=; rewrite subSS subnK.
Qed.

Theorem Pascal a b n :
  (a + b) ^ n = \sum_(i < n.+1) 'C(n, i) * (a ^ (n - i) * b ^ i).
Proof.
elim: n => [|n IHn]; rewrite big_ord_recl muln1 ?big_ord0 //.
rewrite expnS {}IHn /= mulnDl !big_distrr /= big_ord_recl muln1 subn0.
rewrite !big_ord_recr /= !binn !subnn bin0 !subn0 !mul1n -!expnS -addnA.
congr (_ + _); rewrite addnA -big_split /=; congr (_ + _).
apply: eq_bigr => i _; rewrite mulnCA (mulnA a) -expnS subnSK //=.
by rewrite (mulnC b) -2!mulnA -expnSr -mulnDl.
Qed.
Definition expnDn := Pascal.

Lemma Vandermonde k l i :
  \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j) = 'C(k + l , i).
Proof.
pose f k i := \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j).
suffices{k i} fxx k i: f k.+1 i.+1 = f k i.+1 + f k i.
  elim: k i => [i | k IHk [|i]]; last by rewrite -/(f _ _) fxx /f !IHk -binS.
    by rewrite big_ord_recl big1_eq addn0 mul1n subn0.
  by rewrite big_ord_recl big_ord0 addn0 !bin0 muln1.
rewrite {}/f big_ord_recl (big_ord_recl (i.+1)) !bin0 !mul1n.
rewrite -addnA -big_split /=; congr (_ + _).
by apply: eq_bigr => j _; rewrite -mulnDl.
Qed.

Lemma subn_exp m n k :
  m ^ k - n ^ k = (m - n) * (\sum_(i < k) m ^ (k.-1 -i) * n ^ i).
Proof.
case: k => [|k]; first by rewrite big_ord0 muln0.
rewrite mulnBl !big_distrr big_ord_recl big_ord_recr /= subn0 muln1.
rewrite subnn mul1n -!expnS subnDA; congr (_ - _); apply: canRL (addnK _) _.
congr (_ + _); apply: eq_bigr => i _.
by rewrite (mulnCA n) -expnS mulnA -expnS subnSK /=.
Qed.

Lemma predn_exp m k : (m ^ k).-1 = m.-1 * (\sum_(i < k) m ^ i).
Proof.
rewrite -!subn1 -[in LHS](exp1n k) subn_exp; congr (_ * _).
symmetry; rewrite (reindex_inj rev_ord_inj); apply: eq_bigr => i _ /=.
by rewrite -subn1 -subnDA exp1n muln1.
Qed.

Lemma dvdn_pred_predX n e : (n.-1 %| (n ^ e).-1)%N.
Proof. by rewrite predn_exp dvdn_mulr. Qed.

Lemma modn_summ I r (P : pred I) F d :
  \sum_(i <- r | P i) F i %% d = \sum_(i <- r | P i) F i %[mod d].
Proof.
by apply/eqP; elim/big_rec2: _ => // i m n _; rewrite modnDml eqn_modDl.
Qed.

Lemma prime_modn_expSn p n : prime p -> n.+1 ^ p = (n ^ p).+1 %[mod p].
Proof.
case: p => // p pP.
rewrite -[(_ ^ _).+1]addn0 (expnDn 1) big_ord_recr big_ord_recl /=.
rewrite subnn binn exp1n !mul1n addnAC -modnDmr; congr ((_ + _) %% _).
apply/eqP/dvdn_sum => -[i ?] _; exact/dvdn_mulr/prime_dvd_bin.
Qed.

Lemma fermat_little a p : prime p -> a ^ p = a %[mod p].
Proof.
move=> pP.
elim: a => [|a IH]; first by rewrite exp0n // prime_gt0.
by rewrite prime_modn_expSn // -addn1 -modnDml IH modnDml addn1.
Qed.

(* Combinatorial characterizations. *)

Section Combinations.

Implicit Types T D : finType.

Lemma card_uniq_tuples T n (A : pred T) :
  #|[set t : n.-tuple T | all A t & uniq t]| = #|A| ^_ n.
Proof.
elim: n A => [|n IHn] A.
  by rewrite (@eq_card1 _ [tuple]) // => t; rewrite [t]tuple0 inE.
rewrite -sum1dep_card (partition_big (@thead _ _) A) /= => [|t]; last first.
  by case/tupleP: t => x t; do 2!case/andP.
rewrite ffactnS -sum_nat_const; apply: eq_bigr => x Ax.
rewrite (cardD1 x) [x \in A]Ax /= -(IHn [predD1 A & x]) -sum1dep_card.
rewrite (reindex (fun t : n.-tuple T => [tuple of x :: t])) /=; last first.
  pose ttail (t : n.+1.-tuple T) := [tuple of behead t].
  exists ttail => [t _ | t /andP[_ /eqP <-]]; first exact: val_inj.
  by rewrite -tuple_eta.
apply: eq_bigl=> t; rewrite Ax theadE eqxx andbT /= andbA; congr (_ && _).
by rewrite all_predI all_predC has_pred1 andbC.
Qed.

Lemma card_inj_ffuns_on D T (R : pred T) :
  #|[set f : {ffun D -> T} in ffun_on R | injectiveb f]| = #|R| ^_ #|D|.
Proof.
rewrite -card_uniq_tuples.
have bijFF: {on (_ : pred _), bijective (@Finfun D T)}.
  by exists fgraph => x _; [apply: FinfunK | apply: fgraphK].
rewrite -(on_card_preimset (bijFF _)); apply: eq_card => /= t.
rewrite !inE -(big_andE predT) -big_image /= big_all.
by rewrite -[t in RHS]FinfunK -codom_ffun.
Qed.

Lemma card_inj_ffuns D T :
  #|[set f : {ffun D -> T} | injectiveb f]| = #|T| ^_ #|D|.
Proof.
rewrite -card_inj_ffuns_on; apply: eq_card => f.
by rewrite 2!inE; case: ffun_onP.
Qed.

Lemma cards_draws T (B : {set T}) k :
  #|[set A : {set T} | A \subset B & #|A| == k]| = 'C(#|B|, k).
Proof.
have [ltTk | lekT] := ltnP #|B| k.
  rewrite bin_small // eq_card0 // => A.
  rewrite inE eqn_leq [k <= _]leqNgt.
  have [AsubB /=|//] := boolP (A \subset B).
  by rewrite (leq_ltn_trans (subset_leq_card AsubB)) ?andbF.
apply/eqP; rewrite -(eqn_pmul2r (fact_gt0 k)) bin_ffact // eq_sym.
rewrite -sum_nat_cond_const -{1 3}(card_ord k).
rewrite -card_inj_ffuns_on -sum1dep_card.
pose imIk (f : {ffun 'I_k -> T}) := f @: 'I_k.
rewrite (partition_big imIk (fun A => (A \subset B) && (#|A| == k))) /=
  => [|f]; last first.
  move=> /andP [/ffun_onP f_ffun /injectiveP inj_f].
  rewrite card_imset ?card_ord // eqxx andbT.
  by apply/subsetP => x /imsetP [i _ ->]; rewrite f_ffun.
apply/eqP; apply: eq_bigr => A /andP [AsubB /eqP cardAk].
have [f0 inj_f0 im_f0]: exists2 f, injective f & f @: 'I_k = A.
  rewrite -cardAk; exists enum_val; first exact: enum_val_inj.
  apply/setP=> a; apply/imsetP/idP=> [[i _ ->] | Aa]; first exact: enum_valP.
  by exists (enum_rank_in Aa a); rewrite ?enum_rankK_in.
rewrite (reindex (fun p : {ffun _} => [ffun i => f0 (p i)])) /=; last first.
  pose ff0' f i := odflt i [pick j | f i == f0 j].
  exists (fun f => [ffun i => ff0' f i]) => [p _ | f].
    apply/ffunP=> i; rewrite ffunE /ff0'; case: pickP => [j | /(_ (p i))].
      by rewrite ffunE (inj_eq inj_f0) => /eqP.
    by rewrite ffunE eqxx.
  rewrite -im_f0 => /andP[/andP[/ffun_onP f_ffun /injectiveP injf] /eqP im_f].
  apply/ffunP=> i; rewrite !ffunE /ff0'; case: pickP => [y /eqP //|].
  have /imsetP[j _ eq_f0j_fi]: f i \in f0 @: 'I_k by rewrite -im_f imset_f.
  by move/(_ j)/eqP.
rewrite -ffactnn -card_inj_ffuns -sum1dep_card; apply: eq_bigl => p.
rewrite -andbA.
apply/and3P/injectiveP=> [[_ /injectiveP inj_f0p _] i j eq_pij | inj_p].
  by apply: inj_f0p; rewrite !ffunE eq_pij.
set f := finfun _.
have injf: injective f by move=> i j /[!ffunE] /inj_f0; apply: inj_p.
have imIkf : imIk f == A.
  rewrite eqEcard card_imset // cardAk card_ord leqnn andbT -im_f0.
  by apply/subsetP=> x /imsetP[i _ ->]; rewrite ffunE imset_f.
split; [|exact/injectiveP|exact: imIkf].
by apply/ffun_onP => x; apply: (subsetP AsubB); rewrite -(eqP imIkf) imset_f.
Qed.

Lemma card_draws T k : #|[set A : {set T} | #|A| == k]| = 'C(#|T|, k).
Proof.
by rewrite -cardsT -cards_draws; apply: eq_card => A; rewrite !inE subsetT.
Qed.

Lemma card_ltn_sorted_tuples m n :
  #|[set t : m.-tuple 'I_n | sorted ltn (map val t)]| = 'C(n, m).
Proof.
have [-> | n_gt0] := posnP n; last pose i0 := Ordinal n_gt0.
  case: m => [|m]; last by apply: eq_card0; case/tupleP=> [[]].
  by apply: (@eq_card1 _ [tuple]) => t; rewrite [t]tuple0 inE.
rewrite -[n in RHS]card_ord -card_draws.
pose f_t (t : m.-tuple 'I_n) := [set i in t].
pose f_A (A : {set 'I_n}) := [tuple of mkseq (nth i0 (enum A)) m].
have val_fA (A : {set 'I_n}) : #|A| = m -> val (f_A A) = enum A.
  by move=> Am; rewrite -[enum _](mkseq_nth i0) -cardE Am.
have inc_A (A : {set 'I_n}) : sorted ltn (map val (enum A)).
  rewrite -[enum _](eq_filter (mem_enum _)).
  rewrite -(eq_filter (mem_map val_inj _)) -filter_map.
  by rewrite (sorted_filter ltn_trans) // unlock val_ord_enum iota_ltn_sorted.
rewrite -!sum1dep_card (reindex_onto f_t f_A) /= => [|A]; last first.
  by move/eqP=> cardAm; apply/setP=> x; rewrite inE -(mem_enum A) -val_fA.
apply: eq_bigl => t.
apply/idP/idP => [inc_t|/andP [/eqP t_m /eqP <-]]; last by rewrite val_fA.
have ft_m: #|f_t t| = m.
  rewrite cardsE (card_uniqP _) ?size_tuple // -(map_inj_uniq val_inj).
  exact: (sorted_uniq ltn_trans ltnn).
rewrite ft_m eqxx -val_eqE val_fA // -(inj_eq (inj_map val_inj)) /=.
apply/eqP/(irr_sorted_eq ltn_trans ltnn) => // y.
by apply/mapP/mapP=> [] [x t_x ->]; exists x; rewrite // mem_enum inE in t_x *.
Qed.

Lemma card_sorted_tuples m n :
  #|[set t : m.-tuple 'I_n.+1 | sorted leq (map val t)]| = 'C(m + n, m).
Proof.
set In1 := 'I_n.+1; pose x0 : In1 := ord0.
have add_mnP (i : 'I_m) (x : In1) : i + x < m + n.
  by rewrite -ltnS -addSn -!addnS leq_add.
pose add_mn t i := Ordinal (add_mnP i (tnth t i)).
pose add_mn_nat (t : m.-tuple In1) i := i + nth x0 t i.
have add_mnC t: val \o add_mn t =1 add_mn_nat t \o val.
  by move=> i; rewrite /= (tnth_nth x0).
pose f_add t := [tuple of map (add_mn t) (ord_tuple m)].
rewrite -card_ltn_sorted_tuples -!sum1dep_card (reindex f_add) /=.
  apply: eq_bigl => t; rewrite -map_comp (eq_map (add_mnC t)) map_comp.
  rewrite enumT unlock val_ord_enum -[in LHS](drop0 t).
  have [m0 | m_gt0] := posnP m.
    by rewrite {2}m0 /= drop_oversize // size_tuple m0.
  have def_m := subnK m_gt0; rewrite -{2}def_m addn1 /= {1}/add_mn_nat.
  move: 0 (m - 1) def_m => i k; rewrite -[in RHS](size_tuple t) => def_m.
  rewrite (drop_nth x0) /=; last by rewrite -def_m leq_addl.
  elim: k i (nth x0 t i) def_m => [|k IHk] i x /=.
    by rewrite add0n => ->; rewrite drop_size.
  rewrite addSnnS => def_m; rewrite -addSn leq_add2l -IHk //.
  by rewrite (drop_nth x0) // -def_m leq_addl.
pose sub_mn (t : m.-tuple 'I_(m + n)) i : In1 := inord (tnth t i - i).
exists (fun t => [tuple of map (sub_mn t) (ord_tuple m)]) => [t _ | t].
  apply: eq_from_tnth => i; apply: val_inj.
  by rewrite /sub_mn !(tnth_ord_tuple, tnth_map) addKn inord_val.
rewrite inE /= => inc_t; apply: eq_from_tnth => i; apply: val_inj.
rewrite tnth_map tnth_ord_tuple /= tnth_map tnth_ord_tuple.
suffices [le_i_ti le_ti_ni]: i <= tnth t i /\ tnth t i <= i + n.
  by rewrite /sub_mn inordK ?subnKC // ltnS leq_subLR.
pose y0 := tnth t i; rewrite (tnth_nth y0) -(nth_map _ (val i)) ?size_tuple //.
case def_e: (map _ _) => [|x e] /=; first by rewrite nth_nil ?leq_addr.
set nth_i := nth (i : nat); rewrite def_e in inc_t; split.
  have: i < size (x :: e) by rewrite -def_e size_map size_tuple ltn_ord.
  elim: (val i) => //= j IHj lt_j_e.
  by apply: leq_trans (pathP (val i) inc_t _ lt_j_e); rewrite ltnS IHj 1?ltnW.
move: (_ - _) (subnK (valP i)) => k /=.
elim: k (val i) => /= [|k IHk] j; rewrite -ltnS -addSn ?add0n => def_m.
  by rewrite def_m -def_e /nth_i (nth_map y0) ?ltn_ord // size_tuple -def_m.
rewrite (leq_trans _ (IHk _ _)) -1?addSnnS //; apply: (pathP _ inc_t).
rewrite -ltnS (leq_trans (leq_addl k _)) // -addSnnS def_m.
by rewrite -(size_tuple t) -(size_map val) def_e.
Qed.

Lemma card_partial_ord_partitions m n :
  #|[set t : m.-tuple 'I_n.+1 | \sum_(i <- t) i <= n]| = 'C(m + n, m).
Proof.
symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0.
pose add_mn (i j : In1) : In1 := inord (i + j).
pose f_add (t : m.-tuple In1) := [tuple of scanl add_mn x0 t].
rewrite -card_sorted_tuples -!sum1dep_card (reindex f_add) /=.
  apply: eq_bigl => t; rewrite -[\sum_(i <- t) i]add0n.
  transitivity (path leq x0 (map val (f_add t))) => /=; first by case: map.
  rewrite -{1 2}[0]/(val x0); elim: {t}(val t) (x0) => /= [|x t IHt] s.
    by rewrite big_nil addn0 -ltnS ltn_ord.
  rewrite big_cons addnA IHt /= val_insubd ltnS.
  have [_ | ltn_n_sx] := leqP (s + x) n; first by rewrite leq_addr.
  rewrite -(leq_add2r x) leqNgt (leq_trans (valP x)) //=.
  by rewrite leqNgt (leq_trans ltn_n_sx) ?leq_addr.
pose sub_mn (i j : In1) := Ordinal (leq_ltn_trans (leq_subr i j) (valP j)).
exists (fun t : m.-tuple In1 => [tuple of pairmap sub_mn x0 t]) => /= t inc_t.
  apply: val_inj => /=; have{inc_t}: path leq x0 (map val (f_add t)).
    by move: inc_t; rewrite inE /=; case: map.
  rewrite [map _ _]/=; elim: {t}(val t) (x0) => //= x t IHt s.
  case/andP=> le_s_sx /IHt->; congr (_ :: _); apply: val_inj => /=.
  move: le_s_sx; rewrite val_insubd.
  case le_sx_n: (_ < n.+1); first by rewrite addKn.
  by case: (val s) le_sx_n; rewrite ?ltn_ord.
apply: val_inj => /=; have{inc_t}: path leq x0 (map val t).
  by move: inc_t; rewrite inE /=; case: map.
elim: {t}(val t) (x0) => //= x t IHt s /andP[le_s_sx inc_t].
suffices ->: add_mn s (sub_mn s x) = x by rewrite IHt.
by apply: val_inj; rewrite /add_mn /= subnKC ?inord_val.
Qed.

Lemma card_ord_partitions m n :
  #|[set t : m.+1.-tuple 'I_n.+1 | \sum_(i <- t) i == n]| = 'C(m + n, m).
Proof.
symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0.
pose f_add (t : m.-tuple In1) := [tuple of sub_ord (\sum_(x <- t) x) :: t].
rewrite -card_partial_ord_partitions -!sum1dep_card (reindex f_add) /=.
  by apply: eq_bigl => t; rewrite big_cons /= addnC (sameP maxn_idPr eqP) maxnE.
exists (fun t : m.+1.-tuple In1 => [tuple of behead t]) => [t _|].
  exact: val_inj.
case/tupleP=> x t /[!(inE, big_cons)] /eqP def_n.
by apply: val_inj; congr (_ :: _); apply: val_inj; rewrite /= -{1}def_n addnK.
Qed.

End Combinations.


(** * lset: finite sets represented as lists *)

(** This module is used quite intensively, as finite sets are
   pervasives (free variables, summations, partial derivatives...):

   We implement finite sets as simple lists, without any additional
   structure: this allows for very simple operations and
   specifications, without the need for keeping well-formedness
   hypotheses around.

   When a bit of efficiency is required, we use sorted listed without
   duplicates as a special case (but without ensuring that these lists
   are sorted: we managed to avoid such a need in our proofs).

   We declare these finite sets a sup-semilattice with bottom element,
   allowing us to use the lattice tactics and theorems in a
   transparent way. *)

Require Import lattice comparisons.
Require Export List. Export ListNotations.

Set Implicit Arguments.

(** * semi-lattice of finite sets as simple lists *)

(** two lists are equal when they contain the same elements,
   independently of their position or multiplicity *)

Universe lset.

Canonical Structure lset_ops (A:Type@{lset}) := lattice.mk_ops (list A)
  (fun h k => forall a, In a h -> In a k)
  (fun h k => forall a, In a h <-> In a k)
  (@app A) (@app A) (assert_false id) (@nil A) (@nil A).

(** the fact that this makes a semi-lattice is almost trivial *)
#[export] Instance lset_laws (A:Type@{lset}) : lattice.laws BSL (lset_ops A).
Proof.
  constructor; simpl; try discriminate.
   firstorder.
   firstorder.
   setoid_rewrite in_app_iff. firstorder.
   firstorder.
Qed.

(** the [map] function on lists is actually a monotone function over the
   represented sets *)
#[export] Instance map_leq A B (f: A -> B): Proper (leq ==> leq) (map f).
Proof.
  intro h. induction h as [|a h IH]; intros k H. apply leq_bx.
  intros i [<-|I]. apply in_map. apply H. now left.
  apply IH. 2: assumption. intros ? ?. apply H. now right.
Qed.
#[export] Instance map_weq A B (f: A -> B): Proper (weq ==> weq) (map f) := op_leq_weq_1.

(** [map] is extensional *)
#[export] Instance map_compat A B: Proper (pwr eq ==> eq ==> eq) (@map A B).
Proof. intros f g H h k <-. apply map_ext, H. Qed.

(** belonging to a singleton *)
Lemma in_singleton A (x y: A): In x [y] <-> y=x.
Proof. simpl. tauto. Qed.

(** the following tactic replaces all occurrences of [cons] with
   degenerated concatenations, so that the [lattice] can subsequently
   handle them *)

Ltac fold_cons :=
  repeat match goal with
    | |- context[@cons ?A ?x ?q] => (constr_eq q (@nil A); fail 1) || change (x::q) with ([x]++q)
    | H: context[!cons ?A ?x ?q] |- _ => (constr_eq q (@nil A); fail 1) || change (x::q) with ([x]++q) in H
  end.

(** * sorted lists without duplicates *)

(** when the elements come with a [cmpType] structure, one can perform
   sorted lists operations *)

Section m.
 Context {A: cmpType}.

 (** sorted merge of sorted lists *)
 Fixpoint union (l1: list A) :=
   match l1 with
     | nil => fun l2 => l2
     | h1::t1 =>
       let fix union' l2 :=
         match l2 with
           | nil => l1
           | h2::t2 =>
             match cmp h1 h2 with
               | Eq => h1::union t1 t2
               | Lt => h1::union t1 l2
               | Gt => h2::union' t2
             end
         end
         in union'
   end.

 (** sorted insertion in a sorted list *)
 Fixpoint insert (i: A) l :=
   match l with
     | nil => i::nil
     | j::q =>
       match cmp i j with
         | Eq => l
         | Lt => i::l
         | Gt => j::insert i q
       end
   end.

 (** weak specification: [union] actually performs an union *)
 Lemma union_app: forall h k, union h k ≡ h ++ k.
 Proof.
   induction h as [|x h IHh]; simpl union. reflexivity.
   induction k as [|y k IHk]. lattice. case cmp_spec.
   intros ->. fold_cons. rewrite IHh. lattice.
   intros _. fold_cons. rewrite IHh. lattice.
   intros _. fold_cons. rewrite IHk. lattice.
 Qed.

 (** and [insert] actually performs an insertion *)
 Lemma insert_union: forall i l, insert i l = union [i] l.
 Proof.
   induction l; simpl. reflexivity.
   case cmp_spec. congruence. reflexivity. now rewrite IHl.
 Qed.

 Lemma insert_app: forall i l, insert i l ≡ [i] ++ l.
 Proof. intros. rewrite insert_union. apply union_app. Qed.

End m.

Module Fix.

Canonical Structure lset_ops A := lattice.mk_ops (list A)
  (fun h k => forall a, In a h -> In a k)
  (fun h k => forall a, In a h <-> In a k)
  (@app A) (@app A) (assert_false id) (@nil A) (@nil A).

End Fix.


(**
CoLoR, a Coq library on rewriting and termination.

See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2013-05-10

* Knaster-Tarski theorem
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil RelUtil SetUtil.
From Coq Require Import Morphisms Basics.

(****************************************************************************)
(** * We assume given a set [A] equipped with a transitive relation [<=]
and a relation [==] containing [inter_transp <=] (reflexivity is not
needed). *)

Section tarski.

  Variables (A : Type) (le eq : relation A).

  Infix "<=" := le (at level 70).
  Infix "==" := eq (at level 70).

  Variable eq_ok : forall x y, x <= y -> y <= x -> x == y.

(****************************************************************************)
(** Definitions of the notions of (least) upper/(greatest) lower bound. *)

  Definition is_sup a (P : set A) := forall x, P x -> x <= a.

  Definition is_inf a (P : set A) := forall x, P x -> a <= x.

  Definition is_lub a P := is_sup a P /\ forall a', is_sup a' P -> a <= a'.

  Definition is_glb a P := is_inf a P /\ forall a', is_inf a' P -> a' <= a.

(****************************************************************************)
(** lub's and glb's are unique modulo [==]. *)

  Lemma lub_is_uniq : forall P a b, is_lub a P -> is_lub b P -> a == b.

  Proof. fo. Qed.

  Lemma glb_is_uniq : forall P a b, is_glb a P -> is_glb b P -> a == b.

  Proof. fo. Qed.

(****************************************************************************)
(** Definition of the least and greatest fixpoints of a monotone
function [f], when one can compute a lub and glb for every subset of
[A] ([A] is a complete lattice). *)

  Variables (lub glb : set A -> A)
    (lub_ok : forall P, is_lub (lub P) P)
    (glb_ok : forall P, is_glb (glb P) P).

  Section lfp.

    Variables (le_trans : Transitive le)
              (f : A -> A) (f_mon : Proper (le ==> le) f).

    Definition lfp := glb (fun x => f x <= x).

    Lemma lfp_eq : lfp == f lfp.

    Proof.
      unfold lfp. set (P x := f x <= x). set (a := glb P).
      destruct (glb_ok P) as [a_inf a_glb].
      (* f a <= a *)
      assert (Pa : f a <= a).
      apply a_glb. intros x Px. trans (f x). apply f_mon. apply a_inf. hyp. hyp.
      (* a <= f a *)
      assert (h : a <= f a). apply a_inf. apply f_mon. hyp.
      (* conclusion *)
      fo.
    Qed.

    Definition gfp := lub (fun x => x <= f x).

    Lemma gfp_eq : gfp == f gfp.

    Proof.
      unfold gfp. set (P x := x <= f x). set (a := lub P).
      destruct (lub_ok P) as [a_sup a_lub].
      (* a <= f a *)
      assert (Pa : a <= f a).
      apply a_lub. intros x Px. trans (f x). hyp. apply f_mon. apply a_sup. hyp.
      (* f a <= a *)
      assert (h : f a <= a). apply a_sup. apply f_mon. hyp.
      (* conclusion *)
      fo.
    Qed.

(** The least fixpoint can be reached by transfinite iteration. *)

    (*COQ: see https://coq.inria.fr/bugs/show_bug.cgi?id=4506 *)
    Unset Elimination Schemes.

    Inductive K : set A :=
    | Kf x : K x -> K (f x)
    | Klub S : S [<=] K -> K (lub S).

    Set Elimination Schemes.

    Section K_ind.

      Variables (P : A -> Prop) (Pf : forall x, K x -> P x -> P (f x))
                (Plub : forall S, S [<=] K -> S [<=] P -> P (lub S)).

      Fixpoint K_ind y (h : K y) : P y :=
        match h in K y return P y with
        | Kf g => Pf g (K_ind g)
        | Klub QK => Plub QK (fun x g => K_ind (QK x g))
        end.

    End K_ind.

    Lemma lfp_eq_lub : eq (lub K) lfp.

    Proof.
      eapply glb_is_uniq. 2: apply glb_ok.
      destruct (lub_ok K) as [h1 h2]. split.
      intros x hx. apply h2. induction 1.
      trans (f x). apply f_mon. hyp. hyp.
      destruct (lub_ok S) as [g1 g2]. apply g2. hyp.
      intros y hy. apply hy. apply h1. apply Kf. apply Klub. refl.
    Qed.

    Lemma lfp_ind (P : A -> Prop) :
      Proper (eq ==> impl) P ->
      (forall x, P x -> P (f x)) -> (forall S, S [<=] P -> P (lub S)) -> P lfp.

    Proof.
      intros Peq Pf Plub. rewrite <- lfp_eq_lub. apply Plub. induction 1.
      apply Pf. hyp. apply Plub. hyp.
    Qed.

  End lfp.

(****************************************************************************)
(** Extensionality of fixpoints: two fixpoints are equivalent modulo
[==] if their functions are pointwise equivalent modulo [==], [==] is
reflexive, [<=] is compatible with [==], and two glb's (resp. lub's)
are equivalent modulo [==] if their arguments are equivalent modulo
[SetUtil.equiv]. *)

  Variables (eq_refl : Reflexive eq)
    (le_eq : Proper (eq ==> eq ==> iff) le)
    (glb_equiv : Proper (equiv ==> eq) glb)
    (lub_equiv : Proper (equiv ==> eq) lub).

  Existing Instance eq_refl.
  Existing Instance le_eq.
  Existing Instance glb_equiv.
  Existing Instance lub_equiv.

  Lemma lfp_ext : forall f g, (forall x, f x == g x) -> lfp f == lfp g.

  Proof.
    intros f g fg. unfold lfp. apply glb_equiv. intro x.
    unfold mem. rewrite fg. refl.
  Qed.

  Lemma gfp_ext : forall f g, (forall x, f x == g x) -> gfp f == gfp g.

  Proof.
    intros f g fg. unfold lfp. apply lub_equiv. intro x.
    unfold mem. rewrite fg. refl.
  Qed.

End tarski.

Arguments lfp_eq [A le eq] _ [glb] _ _ [f] _.
Arguments gfp_eq [A le eq] _ [lub] _ _ [f] _.

(****************************************************************************)
(** * Example of complete lattice: the powerset of some set [X]. *)

Section powerset.

  Variable X : Type.

  Notation A := (set X).
  Notation set_le := (@subset X).
  Notation set_eq := (@equiv X).

  Global Instance set_le_trans : Transitive set_le.

  Proof. fo. Qed.

  Lemma set_eq_ok : forall x y : A, x [<=] y -> y [<=] x -> x [=] y.

  Proof. fo. Qed.

  Section lub.

    Variable P : set A.

    Definition set_lub : A := fun x => exists S, P S /\ S x.

    Lemma set_lub_ok : is_lub set_le set_lub P.

    Proof. fo. Qed.

    Definition set_glb : A := fun x => forall S, P S -> S x.

    Lemma set_glb_ok : is_glb set_le set_glb P.

    Proof. fo. Qed.

  End lub.

  Definition set_lfp := lfp set_le set_glb.
  Definition set_gfp := gfp set_le set_lub.

  Definition set_lfp_eq := lfp_eq set_eq_ok set_glb_ok set_le_trans.
  Definition set_gfp_eq := gfp_eq set_eq_ok set_lub_ok set_le_trans.

  Global Instance set_eq_refl : Reflexive set_eq.

  Proof. fo. Qed.

  Global Instance set_le_eq : Proper (set_eq ==> set_eq ==> iff) set_le.

  Proof. fo. Qed.

  Global Instance set_glb_equiv : Proper (equiv ==> set_eq) set_glb.

  Proof. fo. Qed.

  Global Instance set_lub_equiv : Proper (equiv ==> set_eq) set_lub.

  Proof. fo. Qed.

  Definition set_lfp_ext := lfp_ext set_eq_refl set_le_eq set_glb_equiv.
  Definition set_gfp_ext := lfp_ext set_eq_refl set_le_eq set_lub_equiv.

End powerset.

Arguments set_lub {X} _ _.
Arguments set_glb {X} _ _.
Arguments set_lfp {X} _ _.
Arguments set_lfp_eq {X} [f] _ _.
Arguments set_gfp_eq {X} [f] _ _.
Arguments set_lfp_ext {X} [f g] _ _.
Arguments set_gfp_ext {X} [f g] _ _.

(****************************************************************************)
(** * Least fixpoint over a sigma type. *)

Section sig.

  Variables (A : Type) (le eq : relation A)
            (eq_ok : forall x y, le x y -> le y x -> eq x y)
            (lub glb : set A -> A)
            (lub_ok : forall S, is_lub le (lub S) S)
            (glb_ok : forall S, is_glb le (glb S) S)
            (P : A -> Prop).

  Notation B := (sig P).

  Notation pr1 := (@proj1_sig A P).
  Notation pr2 := (@proj2_sig A P).

  Definition le_sig := Rof le pr1.
  Definition eq_sig := Rof eq pr1.

  Lemma eq_sig_ok x y : le_sig x y -> le_sig y x -> eq_sig x y.

  Proof. fo. Qed.

  Definition pr (R : set B) : set A := fun x => exists h : P x, R (exist h).

  Variable glb_prop : forall S : set A, (forall x, S x -> P x) -> P (glb S).

  Definition glb_sig (R : set B) : B.

  Proof.
    assert (h : P (glb (pr R))). apply glb_prop. intros x [h _]. hyp.
    exact (exist h).
  Defined.

  Lemma glb_sig_ok R : is_glb le_sig (glb_sig R) R.

  Proof.
    destruct (glb_ok (pr R)) as [h1 h2]. split.
    intros [x Px] Rx. unfold le_sig, Rof, glb_sig. simpl. apply h1. ex Px. hyp.
    intros x x_inf. unfold le_sig, Rof, glb_sig. simpl. apply h2.
    intros y [Py Ry]. apply (x_inf (exist Py)). hyp.
  Qed.

  Variable lub_prop : forall S : set A, (forall x, S x -> P x) -> P (lub S).

  Definition lub_sig (R : set B) : B.

  Proof.
    assert (h : P (lub (pr R))). apply lub_prop. intros x [h _]. hyp.
    exact (exist h).
  Defined.

  Lemma lub_sig_ok R : is_lub le_sig (lub_sig R) R.

  Proof.
    destruct (lub_ok (pr R)) as [h1 h2]. split.
    intros [x Px] Rx. unfold le_sig, Rof, lub_sig. simpl. apply h1. ex Px. hyp.
    intros x x_inf. unfold le_sig, Rof, lub_sig. simpl. apply h2.
    intros y [Py Ry]. apply (x_inf (exist Py)). hyp.
  Qed.

  Variable le_trans : Transitive le.

  Global Instance le_sig_trans : Transitive le_sig.

  Proof. apply Rof_trans. hyp. Qed.

  Variables (f : A -> A) (f_prop : forall x, P x -> P (f x)).

  Definition lift (x : B) : B := exist (f_prop (pr2 x)).

  Variable f_mon : Proper (le ==> le) f.

  Lemma lift_mon : Proper (le_sig ==> le_sig) lift.

  Proof. fo. Qed.

  Definition lfp_lift := pr1 (lfp le_sig glb_sig lift).

  Lemma lfp_lift_prop : P lfp_lift.

  Proof.
    unfold lfp_lift. destruct (lfp le_sig glb_sig lift) as [x Px]. hyp.
  Qed.

  Global Instance proj1_sig_eq : Proper (eq_sig ==> eq) pr1.

  Proof. fo. Qed.

  Lemma lfp_lift_eq : eq lfp_lift (f lfp_lift).

  Proof.
    ded (lfp_eq eq_sig_ok glb_sig_ok le_sig_trans lift_mon).
    apply proj1_sig_eq in H. hyp.
  Qed.

End sig.

Arguments lfp_lift [A] _ [glb P] _ [f] _.
Arguments lfp_lift_eq [A le eq] _ [glb] _ [P] _ _ [f] _ _.
Arguments lfp_lift_prop [A le glb P] _ [f] _.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Crypto.Algebra.Ring.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Partition.
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.

Module Associational.
  Section Associational.

    Definition sat_multerm s (t t' : (Z * Z)) : list (Z * Z) :=
      dlet_nd xy := Z.mul_split s (snd t) (snd t') in
      [(fst t * fst t', fst xy); (fst t * fst t' * s, snd xy)].

    Definition sat_mul s (p q : list (Z * Z)) : list (Z * Z) :=
      flat_map (fun t => flat_map (fun t' => sat_multerm s t t') q) p.

    Lemma eval_map_sat_multerm s a q (s_nonzero:s<>0):
      Associational.eval (flat_map (sat_multerm s a) q) = fst a * snd a * Associational.eval q.
    Proof using Type.
      cbv [sat_multerm Let_In]; induction q;
        repeat match goal with
               | _ => progress autorewrite with cancel_pair push_eval to_div_mod in *
               | _ => progress simpl flat_map
               | _ => rewrite IHq
               | _ => rewrite Z.mod_eq by assumption
               | _ => ring_simplify; lia
               end.
    Qed.
    Hint Rewrite eval_map_sat_multerm using (lia || assumption) : push_eval.

    Lemma eval_sat_mul s p q (s_nonzero:s<>0):
      Associational.eval (sat_mul s p q) = Associational.eval p * Associational.eval q.
    Proof using Type.
      cbv [sat_mul]; induction p; [reflexivity|].
      repeat match goal with
             | _ => progress (autorewrite with push_flat_map push_eval in * )
             | _ => rewrite IHp
             | _ => ring_simplify; lia
             end.
    Qed.
    Hint Rewrite eval_sat_mul : push_eval.

    Definition sat_multerm_const s (t t' : (Z * Z)) : list (Z * Z) :=
      if snd t =? 1
      then [(fst t * fst t', snd t')]
      else if snd t =? -1
           then [(fst t * fst t', - snd t')]
           else if snd t =? 0
                then nil
                else dlet_nd xy := Z.mul_split s (snd t) (snd t') in
            [(fst t * fst t', fst xy); (fst t * fst t' * s, snd xy)].

    Definition sat_mul_const s (p q : list (Z * Z)) : list (Z * Z) :=
      flat_map (fun t => flat_map (fun t' => sat_multerm_const s t t') q) p.

    Lemma eval_map_sat_multerm_const s a q (s_nonzero:s<>0):
      Associational.eval (flat_map (sat_multerm_const s a) q) = fst a * snd a * Associational.eval q.
    Proof using Type.
      cbv [sat_multerm_const Let_In]; induction q;
        repeat match goal with
               | _ => progress autorewrite with cancel_pair push_eval to_div_mod in *
               | _ => progress simpl flat_map
               | H : _ = 1 |- _ => rewrite H
               | H : _ = -1 |- _ => rewrite H
               | H : _ = 0 |- _ => rewrite H
               | _ => progress break_match; Z.ltb_to_lt
               | _ => rewrite IHq
               | _ => rewrite Z.mod_eq by assumption
               | _ => ring_simplify; lia
               end.
    Qed.
    Hint Rewrite eval_map_sat_multerm_const using (lia || assumption) : push_eval.

    Lemma eval_sat_mul_const s p q (s_nonzero:s<>0):
      Associational.eval (sat_mul_const s p q) = Associational.eval p * Associational.eval q.
    Proof using Type.
      cbv [sat_mul_const]; induction p; [reflexivity|].
      repeat match goal with
             | _ => progress (autorewrite with push_flat_map push_eval in * )
             | _ => rewrite IHp
             | _ => ring_simplify; lia
             end.
    Qed.
    Hint Rewrite eval_sat_mul_const : push_eval.
  End Associational.
End Associational.

Module Columns.
  Import Weight.
  Section Columns.
    Context weight {wprops : @weight_properties weight}.

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

    Lemma eval_nil n : eval n [] = 0.
    Proof using Type. cbv [eval]; simpl. apply Positional.eval_nil. Qed.
    Hint Rewrite eval_nil : push_eval.
    Lemma eval_snoc n x y : n = length x -> eval (S n) (x ++ [y]) = eval n x + weight n * sum y.
    Proof using Type.
      cbv [eval]; intros; subst. rewrite map_app. simpl map.
      apply Positional.eval_snoc; distr_length.
    Qed. Hint Rewrite eval_snoc using (solve [distr_length]) : push_eval.

    Ltac cases :=
      match goal with
      | |- _ /\ _ => split
      | H: _ /\ _ |- _ => destruct H
      | H: _ \/ _ |- _ => destruct H
      | _ => progress break_match; try discriminate
      end.

    Section Flatten.
      Context (add_split : Z -> Z -> Z -> Z * Z).
      Context (add_split_mod :
                 forall s x y, fst (add_split s x y) = (x + y) mod s)
              (add_split_div :
                 forall s x y, snd (add_split s x y) = (x + y) / s).
      Hint Rewrite add_split_mod add_split_div : to_div_mod.

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

        (* Outputs (sum, carry) *)
        Definition flatten_column (digit: list Z) : (Z * Z) :=
          list_rect (fun _ => (Z * Z)%type) (0,0)
                    (fun x tl flatten_column_tl =>
                       list_case
                         (fun _ => (Z * Z)%type) (x mod fw, x / fw)
                         (fun y tl' =>
                            list_case
                              (fun _ => (Z * Z)%type) (add_split fw x y)
                              (fun _ _ =>
                                 dlet_nd rec := flatten_column_tl in (* recursively get the sum and carry *)
                                   dlet_nd sum_carry := add_split fw x (fst rec) in (* add the new value to the sum *)
                                   dlet_nd carry' := snd sum_carry + snd rec in (* add the two carries together *)
                                   (fst sum_carry, carry'))
                              tl')
                         tl)
                    digit.
      End flatten_column.

      Definition flatten_step (digit:list Z) (acc_carry:list Z * Z) : list Z * Z :=
        let acc := fst acc_carry in
        let carry := snd acc_carry in
        let fw := weight (S (length acc)) / weight (length acc) in
        dlet sum_carry := flatten_column fw (digit ++ [snd acc_carry]) in
              (acc ++ fst sum_carry :: nil, snd sum_carry).

      Definition flatten (xs : list (list Z)) : list Z * Z :=
        fold_right (fun a b => flatten_step a b) (nil,0) (rev xs).

      Ltac push_fast :=
        repeat match goal with
               | _ => progress cbv [Let_In list_case]
               | |- context [list_rect _ _ _ ?ls] => rewrite single_list_rect_to_match; destruct ls
               | _ => progress (unfold flatten_step in *; fold flatten_step in * )
               | _ => rewrite Nat.add_1_r
               | _ => rewrite Z.mul_div_eq_full by (auto with zarith; lia)
               | _ => rewrite weight_multiples
               | _ => reflexivity
               | _ => solve [repeat (f_equal; try ring)]
               | _ => congruence
               | _ => progress cases
               end.
      Ltac push :=
        repeat match goal with
               | _ => progress push_fast
               | _ => progress autorewrite with cancel_pair to_div_mod
               | _ => progress autorewrite with push_sum push_fold_right push_nth_default in *
               | _ => progress autorewrite with pull_Zmod pull_Zdiv zsimplify_fast
               | _ => progress autorewrite with list distr_length push_eval
               end.

      Lemma flatten_column_mod fw (xs : list Z) :
        fst (flatten_column fw xs)  = sum xs mod fw.
      Proof using add_split_mod.
        induction xs; simpl flatten_column; cbv [Let_In];
          repeat match goal with
                 | _ => rewrite IHxs
                 | _ => progress push
                 end.
      Qed. Hint Rewrite flatten_column_mod : to_div_mod.

      Lemma flatten_column_div fw (xs : list Z) (fw_nz : fw <> 0) :
        snd (flatten_column fw xs)  = sum xs / fw.
      Proof using add_split_div add_split_mod.
        (* this hint is already in the database but Z.div_add_l' is triggered first and that screws things up *)
        Hint Rewrite <- Z.div_add' using zutil_arith : pull_Zdiv.
        induction xs; simpl flatten_column; cbv [Let_In];
          repeat match goal with
                 | _ => rewrite IHxs
                 | _ => rewrite <-Z.div_add' by zutil_arith
                 | _ => rewrite Z.mul_div_eq_full by lia
                 | _ => progress push
                 end.
      Qed. Hint Rewrite flatten_column_div using auto with zarith : to_div_mod.

      Hint Rewrite Positional.eval_nil : push_eval.

      Lemma length_flatten_step digit state :
        length (fst (flatten_step digit state)) = S (length (fst state)).
      Proof using add_split_mod. cbv [flatten_step]; push. Qed.
      Hint Rewrite length_flatten_step : distr_length.
      Lemma length_flatten inp : length (fst (flatten inp)) = length inp.
      Proof using add_split_mod.
        cbv [flatten]. induction inp using rev_ind; push.
      Qed.
      Hint Rewrite length_flatten : distr_length.

      Lemma flatten_snoc x inp : flatten (inp ++ [x]) = flatten_step x (flatten inp).
      Proof using Type. cbv [flatten]. rewrite rev_unit. reflexivity. Qed.

      Lemma flatten_correct inp:
        forall n,
          length inp = n ->
          flatten inp = (Partition.partition weight n (eval n inp),
                         eval n inp / (weight n)).
      Proof using wprops add_split_mod add_split_div.
        induction inp using rev_ind; intros;
          destruct n; distr_length; [ reflexivity | ].
        rewrite flatten_snoc.
        rewrite partition_step.
        erewrite IHinp with (n:=n) by distr_length.
        push.
        pose proof (@weight_positive _ wprops n).
        repeat match goal with
               | |- pair _ _ = pair _ _ => f_equal
               | |- _ ++ _ = _ ++ _ => f_equal
               | |- _ :: _ = _ :: _ => f_equal
               | _ => apply (@partition_eq_mod _ wprops)
               | _ => rewrite length_partition
               | _ => rewrite weight_mod_pull_div by auto
               | _ => rewrite weight_div_pull_div by auto
               | _ => f_equal; ring
               | _ => progress autorewrite with zsimplify
               end.
      Qed.

      Lemma flatten_div_mod n inp :
        length inp = n ->
        (Positional.eval weight n (fst (flatten inp))
         = (eval n inp) mod (weight n))
        /\ (snd (flatten inp) = eval n inp / weight n).
      Proof using wprops add_split_mod add_split_div.
        intros.
        rewrite flatten_correct with (n:=n) by auto.
        cbn [fst snd].
        rewrite eval_partition; auto.
      Qed.

      Lemma flatten_mod {n} inp :
        length inp = n ->
        (Positional.eval weight n (fst (flatten inp)) = (eval n inp) mod (weight n)).
      Proof using wprops add_split_mod add_split_div.
        apply flatten_div_mod.
      Qed.
      Hint Rewrite @flatten_mod : push_eval.

      Lemma flatten_div {n} inp :
        length inp = n -> snd (flatten inp) = eval n inp / weight n.
      Proof using wprops add_split_mod add_split_div.
        apply flatten_div_mod.
      Qed.
      Hint Rewrite @flatten_div : push_eval.

      Lemma flatten_same_sum p q :
        Forall2 (fun x y => sum x = sum y) p q ->
        flatten p = flatten q.
      Proof using wprops add_split_mod add_split_div.
        cbv [flatten].
        let H := fresh in
        intro H; apply Forall2_rev in H;
          induction H; [ reflexivity | ].
        push.
      Qed.
    End Flatten.

    Section FromAssociational.
      (* nils *)
      Definition nils n : list (list Z) := repeat nil n.
      Lemma length_nils n : length (nils n) = n. Proof using Type. cbv [nils]. distr_length. Qed.
      Hint Rewrite length_nils : distr_length.
      Lemma eval_nils n : eval n (nils n) = 0.
      Proof using Type.
        erewrite <-Positional.eval_zeros by eauto.
        cbv [eval nils]; rewrite List.map_repeat; reflexivity.
      Qed. Hint Rewrite eval_nils : push_eval.

      (* 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.
      Lemma length_cons_to_nth i x xs : length (cons_to_nth i x xs) = length xs.
      Proof using Type. cbv [cons_to_nth]. distr_length. Qed.
      Hint Rewrite length_cons_to_nth : distr_length.
      Lemma cons_to_nth_add_to_nth xs : forall i x,
          map sum (cons_to_nth i x xs) = Positional.add_to_nth i x (map sum xs).
      Proof using Type.
        cbv [cons_to_nth]; induction xs as [|? ? IHxs];
          intros i x; destruct i; simpl; rewrite ?IHxs; reflexivity.
      Qed.
      Lemma eval_cons_to_nth n i x xs : (i < length xs)%nat -> length xs = n ->
                                        eval n (cons_to_nth i x xs) = weight i * x + eval n xs.
      Proof using Type.
        cbv [eval]; intros. rewrite cons_to_nth_add_to_nth.
        apply Positional.eval_add_to_nth; distr_length.
      Qed. Hint Rewrite eval_cons_to_nth using (solve [distr_length]) : push_eval.

      Hint Rewrite Positional.eval_zeros : push_eval.
      Hint Rewrite Positional.eval_add_to_nth using (solve [distr_length]): push_eval.

      (* from_associational *)
      Definition from_associational n (p:list (Z*Z)) : list (list Z) :=
        List.fold_right (fun t ls =>
                           dlet_nd p := Positional.place weight t (pred n) in
                           cons_to_nth (fst p) (snd p) ls ) (nils n) p.
      Lemma length_from_associational n p : length (from_associational n p) = n.
      Proof using Type. cbv [from_associational Let_In]. apply fold_right_invariant; intros; distr_length. Qed.
      Hint Rewrite length_from_associational: distr_length.
      Lemma eval_from_associational n p (n_nonzero:n<>0%nat\/p=nil) :
        eval n (from_associational n p) = Associational.eval p.
      Proof using wprops.
        erewrite <-Positional.eval_from_associational by eauto with zarith.
        induction p; [ autorewrite with push_eval; solve [auto] |].
        cbv [from_associational Positional.from_associational]; autorewrite with push_fold_right.
        fold (from_associational n p); fold (Positional.from_associational weight n p).
        cbv [Let_In].
        match goal with |- context [Positional.place _ ?x ?n] =>
                        pose proof (Positional.place_in_range weight x n) end.
        repeat match goal with
               | _ => rewrite Nat.succ_pred in * by auto
               | _ => rewrite IHp by auto
               | _ => progress autorewrite with push_eval
               | _ => progress cases
               | _ => congruence
               end.
      Qed.

      Lemma from_associational_step n t p :
        from_associational n (t :: p) =
        cons_to_nth (fst (Positional.place weight t (Nat.pred n)))
                    (snd (Positional.place weight t (Nat.pred n)))
                    (from_associational n p).
      Proof using Type. reflexivity. Qed.
    End FromAssociational.

    Section Reverse.
      Definition reverse (p : list (list Z)) : list (list Z) :=
        map (@rev Z) p.

      Lemma eval_reverse n p :
        eval n (reverse p) = eval n p.
      Proof.
        cbv [eval reverse]. rewrite map_map.
        f_equal. apply map_ext; intros.
        autorewrite with push_sum. reflexivity.
      Qed. Hint Rewrite @eval_reverse : push_eval.

      Lemma length_reverse p :
        length (reverse p) = length p.
      Proof. cbv [reverse]; distr_length. Qed.
      Hint Rewrite @length_reverse : distr_length.

      Lemma reverse_same_sum p :
        Forall2 (fun x y => sum x = sum y) (reverse p) p.
      Proof.
        cbv [reverse].
        induction p; cbn [rev map]; constructor;
          autorewrite with push_sum; auto.
      Qed.
    End Reverse.
  End Columns.
End Columns.

Module Rows.
  Import Weight.
  Section Rows.
    Context weight {wprops : @weight_properties weight}.
    Local Notation rows := (list (list Z)) (only parsing).
    Local Notation cols := (list (list Z)) (only parsing).

    Hint Rewrite Positional.eval_nil Positional.eval0 @Positional.eval_snoc
         Positional.eval_to_associational
         Columns.eval_nil Columns.eval_snoc using (auto; solve [distr_length]) : push_eval.
    Hint Resolve in_eq in_cons : core.

    Definition eval n (inp : rows) :=
      sum (map (Positional.eval weight n) inp).
    Lemma eval_nil n : eval n nil = 0.
    Proof using Type. cbv [eval]. rewrite map_nil, sum_nil; reflexivity. Qed.
    Hint Rewrite eval_nil : push_eval.
    Lemma eval0 x : eval 0 x = 0.
    Proof using Type. cbv [eval]. induction x; autorewrite with push_map push_sum push_eval; lia. Qed.
    Hint Rewrite eval0 : push_eval.
    Lemma eval_cons n r inp : eval n (r :: inp) = Positional.eval weight n r + eval n inp.
    Proof using Type. cbv [eval]; autorewrite with push_map push_sum; reflexivity. Qed.
    Hint Rewrite eval_cons : push_eval.
    Lemma eval_app n x y : eval n (x ++ y) = eval n x + eval n y.
    Proof using Type. cbv [eval]; autorewrite with push_map push_sum; reflexivity. Qed.
    Hint Rewrite eval_app : push_eval.

    Ltac In_cases :=
      repeat match goal with
             | H: In _ (_ ++ _) |- _ => apply in_app_or in H; destruct H
             | H: In _ (_ :: _) |- _ => apply in_inv in H; destruct H
             | H: In _ nil |- _ => contradiction H
             | H: forall x, In x (?y :: ?ls) -> ?P |- _ =>
               unique pose proof (H y ltac:(apply in_eq));
               unique assert (forall x, In x ls -> P) by auto
             | H: forall x, In x (?ls ++ ?y :: nil) -> ?P |- _ =>
               unique pose proof (H y ltac:(auto using in_or_app, in_eq));
               unique assert (forall x, In x ls -> P) by eauto using in_or_app
             end.

    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).

      Lemma eval_extract_row (inp : cols): forall n,
          length inp = n ->
          Positional.eval weight n (snd (extract_row inp)) = Columns.eval weight n inp - Columns.eval weight n (fst (extract_row inp)) .
      Proof using Type.
        cbv [extract_row].
        induction inp using rev_ind; [ | destruct n ];
          repeat match goal with
                 | _ => progress intros
                 | _ => progress distr_length
                 | _ => rewrite Positional.eval_snoc with (n:=n) by distr_length
                 | _ => progress autorewrite with cancel_pair push_eval push_map in *
                 | _ => ring
                 end.
        rewrite IHinp by distr_length.
        destruct x; cbn [hd tl]; rewrite ?sum_nil, ?sum_cons; ring.
      Qed. Hint Rewrite eval_extract_row using (solve [distr_length]) : push_eval.

      Lemma length_fst_extract_row (inp : cols) :
        length (fst (extract_row inp)) = length inp.
      Proof using Type. cbv [extract_row]; autorewrite with cancel_pair; distr_length. Qed.
      Hint Rewrite length_fst_extract_row : distr_length.

      Lemma length_snd_extract_row (inp : cols) :
        length (snd (extract_row inp)) = length inp.
      Proof using Type. cbv [extract_row]; autorewrite with cancel_pair; distr_length. Qed.
      Hint Rewrite length_snd_extract_row : distr_length.

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

      (* TODO: move to where list is defined *)
      Hint Rewrite @app_nil_l : list.
      Hint Rewrite <-@app_comm_cons: list.

      Lemma max_column_size_nil : max_column_size nil = 0%nat.
      Proof using Type. reflexivity. Qed. Hint Rewrite max_column_size_nil : push_max_column_size.
      Lemma max_column_size_cons col (inp : cols) :
        max_column_size (col :: inp) = Nat.max (length col) (max_column_size inp).
      Proof using Type. reflexivity. Qed. Hint Rewrite max_column_size_cons : push_max_column_size.
      Lemma max_column_size_app (x y : cols) :
        max_column_size (x ++ y) = Nat.max (max_column_size x) (max_column_size y).
      Proof using Type. induction x; autorewrite with list push_max_column_size; lia. Qed.
      Hint Rewrite max_column_size_app : push_max_column_size.
      Lemma max_column_size0 (inp : cols) :
        forall n,
          length inp = n -> (* this is not needed to make the lemma true, but prevents reliance on the implementation of Columns.eval*)
          max_column_size inp = 0%nat -> Columns.eval weight n inp = 0.
      Proof using Type.
        induction inp as [|x inp] using rev_ind; destruct n; try destruct x; intros;
          autorewrite with push_max_column_size push_eval push_sum distr_length in *; try lia.
        rewrite IHinp; distr_length; lia.
      Qed.

      (* 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, [])).

      Local Ltac eval_from_columns'_with_length_t :=
        cbv [from_columns'];
        first [ intros; apply fold_right_invariant; intros
              | apply fold_right_invariant ];
        repeat match goal with
               | _ => progress (intros; subst)
               | _ => progress autorewrite with cancel_pair push_eval in *
               | _ => progress In_cases
               | _ => split; try lia
               | H: _ /\ _ |- _ => destruct H
               | _ => progress distr_length
               | _ => solve [auto]
               end.
      Lemma length_from_columns' m st n:
        (length (fst st) = n) ->
        length (fst (from_columns' m st)) = n /\
        ((forall r, In r (snd st) -> length r = n) ->
         forall r, In r (snd (from_columns' m st)) -> length r = n).
      Proof using Type. eval_from_columns'_with_length_t. Qed.
      Lemma eval_from_columns'_with_length m st n:
        (length (fst st) = n) ->
        length (fst (from_columns' m st)) = n /\
        ((forall r, In r (snd st) -> length r = n) ->
         forall r, In r (snd (from_columns' m st)) -> length r = n) /\
        eval n (snd (from_columns' m st)) = Columns.eval weight n (fst st) + eval n (snd st)
                                                                             - Columns.eval weight n (fst (from_columns' m st)).
      Proof using Type. eval_from_columns'_with_length_t. Qed.
      Lemma length_fst_from_columns' m st :
        length (fst (from_columns' m st)) = length (fst st).
      Proof using Type. apply length_from_columns'; reflexivity. Qed.
      Hint Rewrite length_fst_from_columns' : distr_length.
      Lemma length_snd_from_columns' m st :
        (forall r, In r (snd st) -> length r = length (fst st)) ->
        forall r, In r (snd (from_columns' m st)) -> length r = length (fst st).
      Proof using Type. apply length_from_columns'; reflexivity. Qed.
      Hint Rewrite length_snd_from_columns' : distr_length.
      Lemma eval_from_columns' m st n :
        (length (fst st) = n) ->
        eval n (snd (from_columns' m st)) = Columns.eval weight n (fst st) + eval n (snd st)
                                                                             - Columns.eval weight n (fst (from_columns' m st)).
      Proof using Type. apply eval_from_columns'_with_length. Qed.
      Hint Rewrite eval_from_columns' using (auto; solve [distr_length]) : push_eval.

      Lemma max_column_size_extract_row inp :
        max_column_size (fst (extract_row inp)) = (max_column_size inp - 1)%nat.
      Proof using Type.
        cbv [extract_row]. autorewrite with cancel_pair.
        induction inp; [ reflexivity | ].
        autorewrite with push_max_column_size push_map distr_length.
        rewrite IHinp. auto using Nat.sub_max_distr_r.
      Qed.
      Hint Rewrite max_column_size_extract_row : push_max_column_size.

      Lemma max_column_size_from_columns' m st :
        max_column_size (fst (from_columns' m st)) = (max_column_size (fst st) - m)%nat.
      Proof using Type.
        cbv [from_columns']; induction m; intros; cbn - [max_column_size extract_row];
          autorewrite with push_max_column_size; lia.
      Qed.
      Hint Rewrite max_column_size_from_columns' : push_max_column_size.

      Lemma eval_from_columns (inp : cols) :
        forall n, length inp = n -> eval n (from_columns inp) = Columns.eval weight n inp.
      Proof using Type.
        intros; cbv [from_columns];
          repeat match goal with
                 | _ => progress autorewrite with cancel_pair push_eval push_max_column_size
                 | _ => rewrite max_column_size0 with (inp := fst (from_columns' _ _)) by
                       (autorewrite with push_max_column_size; distr_length)
                 | _ => lia
                 end.
      Qed.
      Hint Rewrite eval_from_columns using (auto; solve [distr_length]) : push_eval.

      Lemma length_from_columns inp:
        forall r, In r (from_columns inp) -> length r = length inp.
      Proof using Type.
        cbv [from_columns]; intros.
        change inp with (fst (inp, @nil (list Z))).
        eapply length_snd_from_columns'; eauto.
        autorewrite with cancel_pair; intros; In_cases.
      Qed.
      Hint Rewrite length_from_columns using eassumption : distr_length.

      (* from associational *)
      Definition from_associational n (p : list (Z * Z)) := from_columns (Columns.from_associational weight n p).

      Lemma eval_from_associational n p: (n <> 0%nat \/ p = nil) ->
                                         eval n (from_associational n p) = Associational.eval p.
      Proof using wprops.
        intros. cbv [from_associational].
        rewrite eval_from_columns by auto using Columns.length_from_associational.
        auto using Columns.eval_from_associational.
      Qed.

      Lemma length_from_associational n p :
        forall r, In r (from_associational n p) -> length r = n.
      Proof using Type.
        cbv [from_associational]; intros.
        match goal with H: _ |- _ => apply length_from_columns in H end.
        rewrite Columns.length_from_associational in *; auto.
      Qed.

      Lemma max_column_size_zero_iff x :
        max_column_size x = 0%nat <-> (forall c, In c x -> c = nil).
      Proof using Type.
        cbv [max_column_size]; induction x; intros; [ cbn; tauto | ].
        autorewrite with push_fold_right push_map.
        rewrite max_0_iff, IHx.
        split; intros; [ | rewrite length_zero_iff_nil; solve [auto] ].
        match goal with H : _ /\ _ |- _ => destruct H end.
        In_cases; subst; auto using length0_nil.
      Qed.

      Lemma max_column_size_Columns_from_associational n p :
        n <> 0%nat -> p <> nil ->
        max_column_size (Columns.from_associational weight n p) <> 0%nat.
      Proof using Type.
        intros.
        rewrite max_column_size_zero_iff.
        intro. destruct p; [congruence | ].
        rewrite Columns.from_associational_step in *.
        cbv [Columns.cons_to_nth] in *.
        match goal with H : forall c, In c (update_nth ?n ?f ?ls) -> _ |- _ =>
                        assert (n < length (update_nth n f ls))%nat;
                          [ | specialize (H (nth n (update_nth n f ls) nil) ltac:(auto using nth_In)) ]
        end.
        { distr_length.
          rewrite Columns.length_from_associational.
          remember (Nat.pred n) as m. replace n with (S m) by lia.
          apply Positional.place_in_range. }
        rewrite <-nth_default_eq in *.
        autorewrite with push_nth_default in *.
        rewrite eq_nat_dec_refl in *.
        congruence.
      Qed.

      Lemma from_associational_nonnil n p :
        n <> 0%nat -> p <> nil ->
        from_associational n p <> nil.
      Proof using Type.
        intros; cbv [from_associational from_columns from_columns'].
        pose proof (max_column_size_Columns_from_associational n p ltac:(auto) ltac:(auto)).
        case_eq (max_column_size (Columns.from_associational weight n p)); [lia|].
        intros; cbn.
        rewrite <-length_zero_iff_nil. distr_length.
      Qed.
    End FromAssociational.

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

      Section SumRows.
        Definition sum_rows' start_state (row1 row2 : list Z) : list Z * Z * nat :=
          fold_right (fun next (state : list Z * Z * nat) =>
                        let i := snd state in
                        let low_high' :=
                            let low_high := fst state in
                            let low := fst low_high in
                            let high := snd low_high in
                          dlet_nd sum_carry := Z.add_with_get_carry_full (fw i) high (fst next) (snd next) in
                          (low ++ [fst sum_carry], snd sum_carry) in
                     (low_high', S i)) start_state (rev (combine row1 row2)).
        Definition sum_rows row1 row2 := fst (sum_rows' (nil, 0, 0%nat) row1 row2).

        Ltac push :=
          repeat match goal with
                 | _ => progress intros
                 | _ => progress cbv [Let_In]
                 | _ => rewrite Nat.add_1_r
                 | _ => erewrite Positional.eval_snoc by eauto
                 | H : length _ = _ |- _ => rewrite H
                 | H: 0%nat = _ |- _ => rewrite <-H
                 | [p := _ |- _] => subst p
                 | _ => progress autorewrite with cancel_pair natsimplify push_sum_rows list
                 | _ => progress autorewrite with cancel_pair in *
                 | _ => progress distr_length
                 | _ => progress break_match
                 | _ => ring
                 | _ => solve [ repeat (f_equal; try ring) ]
                 | _ => tauto
                 | _ => solve [eauto]
                 end.

        Lemma sum_rows'_cons state x1 row1 x2 row2 :
          sum_rows' state (x1 :: row1) (x2 :: row2) =
          sum_rows' (fst (fst state) ++ [(snd (fst state) + x1 + x2) mod (fw (snd state))],
                     (snd (fst state) + x1 + x2) / fw (snd state),
                     S (snd state)) row1 row2.
        Proof using Type.
          cbv [sum_rows' Let_In]; autorewrite with push_combine.
          rewrite !fold_left_rev_right. cbn [fold_left].
          autorewrite with cancel_pair to_div_mod. congruence.
        Qed.

        Lemma sum_rows'_nil state :
          sum_rows' state nil nil = state.
        Proof using Type. reflexivity. Qed.

        Hint Rewrite sum_rows'_cons sum_rows'_nil : push_sum_rows.

        Lemma sum_rows'_correct row1 :
          forall start_state nm row2 row1' row2',
            let m := snd start_state in
            let n := length row1 in
            length row2 = n ->
            length row1' = m ->
            length row2' = m ->
            length (fst (fst start_state)) = m ->
            nm = (n + m)%nat ->
            let eval := Positional.eval weight in
            snd (fst start_state) = (eval m row1' + eval m row2') / weight m ->
            (fst (fst start_state) = Partition.partition weight m (eval m row1' + eval m row2')) ->
            let sum := eval nm (row1' ++ row1) + eval nm (row2' ++ row2) in
            sum_rows' start_state row1 row2
            = (Partition.partition weight nm sum, sum / weight nm, nm) .
        Proof using wprops.
          destruct start_state as [ [acc rem] m].
          cbn [fst snd]. revert acc rem m.
          induction row1 as [|x1 row1];
            destruct row2 as [|x2 row2]; intros;
              subst nm; push; [ congruence | ].
          rewrite (app_cons_app_app _ row1'), (app_cons_app_app _ row2').
          subst rem acc.
          apply IHrow1; clear IHrow1;
            repeat match goal with
                   | _ => rewrite <-(Z.add_assoc _ x1 x2)
                   | _ => rewrite div_step by auto using Z.gt_lt
                   | _ => rewrite Z.mul_div_eq_full by auto
                   | _ => rewrite weight_multiples by auto
                   | _ => rewrite partition_step by auto
                   | _ => rewrite weight_div_pull_div by auto
                   | _ => rewrite weight_mod_pull_div by auto
                   | _ => rewrite <-Z.div_add' by auto with zarith
                   | _ => progress push
                   end.
          f_equal; push; [ ].
          apply (@partition_eq_mod _ wprops).
          push_Zmod.
          autorewrite with zsimplify_fast; reflexivity.
        Qed.

        Lemma sum_rows_correct row1: forall row2 n,
            length row1 = n -> length row2 = n ->
            let sum := Positional.eval weight n row1 + Positional.eval weight n row2 in
            sum_rows row1 row2 = (Partition.partition weight n sum, sum / weight n).
        Proof using wprops.
          cbv [sum_rows]; intros.
          erewrite sum_rows'_correct with (nm:=n) (row1':=nil) (row2':=nil)by (cbn; distr_length; reflexivity).
          reflexivity.
        Qed.

        Lemma sum_rows_mod n row1 row2 :
          length row1 = n -> length row2 = n ->
          Positional.eval weight n (fst (sum_rows row1 row2))
          = (Positional.eval weight n row1 + Positional.eval weight n row2) mod (weight n).
        Proof using wprops.
          intros; erewrite sum_rows_correct by eauto.
          cbn [fst]. auto using eval_partition.
        Qed.

        Lemma length_sum_rows row1 row2 n:
          length row1 = n -> length row2 = n ->
          length (fst (sum_rows row1 row2)) = n.
        Proof using wprops.
          intros; erewrite sum_rows_correct by eauto.
          cbn [fst]. distr_length.
        Qed. Hint Rewrite length_sum_rows : distr_length.
      End SumRows.
      Hint Resolve length_sum_rows : core.
      Hint Rewrite sum_rows_mod using (auto; solve [distr_length; auto]) : push_eval.

      Definition flatten' (start_state : list Z * Z) (inp : rows) : list Z * Z :=
        fold_right (fun next_row (state : list Z * Z)=>
                      let out_carry := sum_rows (fst state) next_row in
                      (fst out_carry, snd state + snd out_carry)) 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 n (inp : rows) : list Z * Z :=
        let default := Positional.zeros n in
        flatten' (hd default inp, 0) (hd default (tl inp) :: tl (tl inp)).

      Lemma flatten'_cons state r inp :
        flatten' state (r :: inp) = (fst (sum_rows (fst (flatten' state inp)) r), snd (flatten' state inp) + snd (sum_rows (fst (flatten' state inp)) r)).
      Proof using Type. cbv [flatten']; autorewrite with list push_fold_right. reflexivity. Qed.
      Lemma flatten'_snoc state r inp :
        flatten' state (inp ++ r :: nil) = flatten' (fst (sum_rows (fst state) r), snd state + snd (sum_rows (fst state) r)) inp.
      Proof using Type. cbv [flatten']; autorewrite with list push_fold_right. reflexivity. Qed.
      Lemma flatten'_nil state : flatten' state [] = state. Proof using Type. reflexivity. Qed.
      Hint Rewrite flatten'_cons flatten'_snoc flatten'_nil : push_flatten.

      Ltac push :=
        repeat match goal with
               | _ => progress intros
               | _ => erewrite sum_rows_correct by (eassumption || distr_length; reflexivity)
               | _ => rewrite eval_partition by auto
               | H: length _ = _ |- _ => rewrite H
               | _ => progress autorewrite with cancel_pair push_flatten push_eval distr_length zsimplify_fast
               | _ => progress In_cases
               | |- _ /\ _ => split
               | |- context [?x mod ?y] => unique pose proof (Z.mul_div_eq_full x y ltac:(auto)); lia
               | _ => apply length_sum_rows
               | _ => solve [repeat (ring_simplify; f_equal; try ring)]
               | _ => congruence
               | _ => solve [eauto]
               end.

      Lemma flatten'_correct n inp : forall start_state,
        length (fst start_state) = n ->
        (forall row, In row inp -> length row = n) ->
        inp <> nil ->
        let sum := Positional.eval weight n (fst start_state) + eval n inp + weight n * snd start_state in
        flatten' start_state inp = (Partition.partition weight n sum, sum / weight n).
      Proof using wprops.
        induction inp using rev_ind; push. subst sum.
        destruct (dec (inp = nil)); [ subst inp; cbn | ];
          repeat match goal with
                 | _ => rewrite IHinp by push; clear IHinp
                 | |- pair _ _ = pair _ _ => f_equal
                 | _ => apply (@partition_eq_mod _ wprops)
                 | _ => rewrite <-Z.div_add_l' by auto with zarith
                 | _ => rewrite Z.mod_add'_full by lia
                 | _ => rewrite Z.mul_div_eq_full by auto with zarith
                 | _ => progress (push_Zmod; pull_Zmod)
                 | _ => progress push
                 end.
      Qed.

      Hint Rewrite (@Positional.length_zeros) : distr_length.
      Hint Rewrite (@Positional.eval_zeros) using auto : push_eval.

      Lemma flatten_correct inp n :
        (forall row, In row inp -> length row = n) ->
        flatten n inp = (Partition.partition weight n (eval n inp), eval n inp / weight n).
      Proof using wprops.
        intros; cbv [flatten].
        destruct inp; [|destruct inp]; cbn [hd tl];
          [ | | erewrite ?flatten'_correct ]; push.
      Qed.

      Lemma flatten_mod inp n :
        (forall row, In row inp -> length row = n) ->
        Positional.eval weight n (fst (flatten n inp)) = (eval n inp) mod (weight n).
      Proof using wprops. intros; rewrite flatten_correct; push. Qed.

      Lemma length_flatten n inp :
        (forall row, In row inp -> length row = n) ->
        length (fst (flatten n inp)) = n.
      Proof using wprops. intros; rewrite flatten_correct by assumption; push. Qed.
    End Flatten.
    Hint Rewrite length_flatten : distr_length.

    Section Ops.
      Definition add n p q := flatten 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 n p q := flatten n [p; map (fun x => dlet y := x in Z.opp y) q].

      Definition conditional_add n mask cond (p q:list Z) :=
        let qq := Positional.zselect mask cond q in
        add n p qq.

      (* Subtract q if and only if p >= q. *)
      Definition conditional_sub n (p q:list Z) :=
        let '(v, c) := sub n p q in
        Positional.select (-c) v p.

      (* the carry will be 0 unless we underflow--we do the addition only
         in the underflow case *)
      Definition sub_then_maybe_add n mask (p q r:list Z) :=
        let '(p_minus_q, c) := sub n p q in
        let rr := Positional.zselect mask (-c) r in
        let '(res, c') := add n p_minus_q rr in
        (res, c' - c).

      Hint Rewrite eval_cons eval_nil using solve [auto] : push_eval.

      Definition mul 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
        let pq_a := Associational.sat_mul base p_a q_a in
        flatten m (from_associational 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 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
        fst lo_hi ++ (Associational.sat_mul_const base [(1, s'/s)] (Associational.sat_mul_const base c (snd lo_hi))).

      Definition repeat_sat_reduce base s c (p : list (Z * Z)) n :=
        fold_right (fun _ q => sat_reduce base s c n q) p (seq 0 n).

      Definition mulmod 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
        let pq_a := Associational.sat_mul base p_a q_a in
        let r_a := repeat_sat_reduce base s c pq_a nreductions in
        flatten n (from_associational n r_a).

      Hint Rewrite Associational.eval_sat_mul_const Associational.eval_sat_mul Associational.eval_split using solve [auto] : push_eval.
      Hint Rewrite eval_from_associational using solve [auto] : push_eval.
      Ltac solver :=
        intros; cbv [sub add mul mulmod sat_reduce];
        rewrite ?flatten_correct by (intros; In_cases; subst; distr_length; eauto using length_from_associational);
        autorewrite with push_eval; ring_simplify_subterms;
        try reflexivity.

      Lemma add_partitions n p q :
        length p = n -> length q = n ->
        fst (add n p q) = Partition.partition weight n (Positional.eval weight n p + Positional.eval weight n q).
      Proof using wprops. solver. Qed.

      Lemma add_div n p q :
        length p = n -> length q = n ->
        snd (add n p q) = (Positional.eval weight n p + Positional.eval weight n q) / weight n.
      Proof using wprops. solver. Qed.

      Lemma conditional_add_partitions n mask cond p q :
        length p = n -> length q = n -> map (Z.land mask) q = q ->
        fst (conditional_add n mask cond p q)
        = Partition.partition weight n (Positional.eval weight n p + (if dec (cond = 0) then 0 else Positional.eval weight n q)).
      Proof using wprops.
        cbv [conditional_add]; intros; rewrite add_partitions by (distr_length; auto).
        autorewrite with push_eval; reflexivity.
      Qed.

      Lemma conditional_add_div n mask cond p q :
        length p = n -> length q = n -> map (Z.land mask) q = q ->
        snd (conditional_add n mask cond p q) = (Positional.eval weight n p + (if dec (cond = 0) then 0 else Positional.eval weight n q)) / weight n.
      Proof using wprops.
        cbv [conditional_add]; intros; rewrite add_div by (distr_length; auto).
        autorewrite with push_eval; auto.
      Qed.

      Lemma eval_map_opp q :
        forall n, length q = n ->
                  Positional.eval weight n (map Z.opp q) = - Positional.eval weight n q.
      Proof using Type.
        induction q using rev_ind; intros;
          repeat match goal with
                 | _ => progress autorewrite with push_map push_eval
                 | _ => erewrite !Positional.eval_snoc with (n:=length q) by distr_length
                 | _ => rewrite IHq by auto
                 | _ => ring
                 end.
      Qed. Hint Rewrite eval_map_opp using solve [auto]: push_eval.

      Lemma sub_partitions n p q :
        length p = n -> length q = n ->
        fst (sub n p q) = Partition.partition weight n (Positional.eval weight n p - Positional.eval weight n q).
      Proof using wprops. solver. Qed.

      Lemma sub_div n p q :
        length p = n -> length q = n ->
        snd (sub n p q) = (Positional.eval weight n p - Positional.eval weight n q) / weight n.
      Proof using wprops. solver. Qed.

      Lemma conditional_sub_partitions n p q
        (Hp : p = Partition.partition weight n (Positional.eval weight n p)) :
        length q = n ->
        0 <= Positional.eval weight n q < weight n ->
        conditional_sub n p q = Partition.partition weight n (if Positional.eval weight n q <=? Positional.eval weight n p then Positional.eval weight n p - Positional.eval weight n q else Positional.eval weight n p).
      Proof using wprops.
        cbv [conditional_sub]; intros.
        rewrite (surjective_pairing (sub _ _ _)).
        assert (length p = n) by (rewrite Hp; distr_length).
        assert (0 <= Positional.eval weight n p < weight n) by
            (rewrite Hp; autorewrite with push_eval; auto using Z.mod_pos_bound).
        rewrite sub_partitions, sub_div; distr_length.
        erewrite Positional.select_eq by (distr_length; eauto).
        rewrite Z.div_sub_small, Z.ltb_antisym by lia.
        destruct (Positional.eval weight n q <=? Positional.eval weight n p);
          cbn [negb]; autorewrite with zsimplify_fast;
            break_match; try lia; congruence.
      Qed.

      Let sub_then_maybe_add_Z a b c :=
        a - b + (if (a - b <? 0) then c else 0).

      Lemma sub_then_maybe_add_partitions n mask p q r :
        length p = n -> length q = n -> length r = n ->
        map (Z.land mask) r = r ->
        0 <= Positional.eval weight n p < weight n ->
        0 <= Positional.eval weight n q < weight n ->
        fst (sub_then_maybe_add n mask p q r) = Partition.partition weight n (sub_then_maybe_add_Z (Positional.eval weight n p) (Positional.eval weight n q) (Positional.eval weight n r)).
      Proof using wprops.
        cbv [sub_then_maybe_add]. subst sub_then_maybe_add_Z.
        intros.
        rewrite (surjective_pairing (sub _ _ _)).
        rewrite (surjective_pairing (add _ _ _)).
        cbn [fst snd].
        rewrite sub_partitions, add_partitions, sub_div by distr_length.
        autorewrite with push_eval.
        Z.rewrite_mod_small.
        rewrite Z.div_sub_small by lia.
        break_innermost_match; Z.ltb_to_lt; try lia;
          auto using partition_eq_mod with zarith.
      Qed.

      Lemma mul_partitions base n m p q :
        base <> 0 -> m <> 0%nat -> length p = n -> length q = n ->
        fst (mul base n m p q) = Partition.partition weight m (Positional.eval weight n p * Positional.eval weight n q).
      Proof using wprops. solver. Qed.

      Lemma mul_div base n m p q :
        base <> 0 -> m <> 0%nat -> length p = n -> length q = n ->
        snd (mul base n m p q) = (Positional.eval weight n p * Positional.eval weight n q) / weight m.
      Proof using wprops. solver. Qed.

      Lemma length_mul base n m p q :
        length p = n -> length q = n ->
        length (fst (mul base n m p q)) = m.
      Proof using wprops. solver; cbn [fst snd]; distr_length. Qed.

      Lemma adjust_s_invariant fuel s (s_nz:s<>0) :
        fst (adjust_s fuel s) mod s = 0
        /\ fst (adjust_s fuel s) <> 0.
      Proof using wprops.
        cbv [adjust_s]; rewrite fold_right_map; generalize (List.rev (seq 0 fuel)); intro ls; induction ls as [|l ls IHls];
          cbn.
        { rewrite Z.mod_same by assumption; auto. }
        { break_match; cbn in *; auto with zarith. }
      Qed.

      Lemma eval_sat_reduce base s c n p :
        base <> 0 -> s - Associational.eval c <> 0 -> s <> 0 ->
        Associational.eval (sat_reduce base s c n p) mod (s - Associational.eval c)
        = Associational.eval p mod (s - Associational.eval c).
      Proof using wprops.
        intros; cbv [sat_reduce].
        lazymatch goal with |- context[adjust_s ?fuel ?s] => destruct (adjust_s_invariant fuel s ltac:(assumption)) as [Hmod ?] end.
        eta_expand; autorewrite with push_eval zsimplify_const; cbn [fst snd].
        rewrite !Z.mul_assoc, <- (Z.mul_comm (Associational.eval c)), <- !Z.mul_assoc, <-Associational.reduction_rule by auto.
        autorewrite with zsimplify_const; rewrite !Z.mul_assoc, Z.mul_div_eq_full, Hmod by auto.
        autorewrite with zsimplify_const push_eval; trivial.
      Qed.
      Hint Rewrite eval_sat_reduce using auto : push_eval.

      Lemma eval_repeat_sat_reduce base s c p n :
        base <> 0 -> s - Associational.eval c <> 0 -> s <> 0 ->
        Associational.eval (repeat_sat_reduce base s c p n) mod (s - Associational.eval c)
        = Associational.eval p mod (s - Associational.eval c).
      Proof using wprops.
        intros; cbv [repeat_sat_reduce].
        apply fold_right_invariant; intros; autorewrite with push_eval; auto.
      Qed.
      Hint Rewrite eval_repeat_sat_reduce using auto : push_eval.

      Lemma eval_mulmod base s c n nreductions p q :
        base <> 0 -> s <> 0 -> s - Associational.eval c <> 0 ->
        n <> 0%nat -> length p = n -> length q = n ->
        (Positional.eval weight n (fst (mulmod base s c n nreductions p q))
         + weight n * (snd (mulmod base s c n nreductions p q))) mod (s - Associational.eval c)
        = (Positional.eval weight n p * Positional.eval weight n q) mod (s - Associational.eval c).
      Proof using wprops.
        solver. cbn [fst snd].
        rewrite eval_partition by auto.
        rewrite <-Z.div_mod'' by auto with zarith.
        autorewrite with push_eval; reflexivity.
      Qed.

      (* 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.
#[global]
  Hint Rewrite length_from_columns using eassumption : distr_length.
#[global]
  Hint Rewrite length_sum_rows using solve [ reflexivity | eassumption | distr_length; eauto ] : distr_length.
#[global]
  Hint Rewrite length_fst_extract_row length_snd_extract_row length_flatten length_fst_from_columns' length_snd_from_columns' : distr_length.
End Rows.


Inductive day : Type :=
    | monday
    | tuesday
    | wednesday
    | thursday
    | friday
    | saturday
    | sunday.

Definition next_weekday (d:day) : day :=
    match d with
    | monday => tuesday
    | tuesday => wednesday
    | wednesday => thursday
    | thursday => friday
    | friday => saturday
    | saturday => sunday
    | sunday => monday
    end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
    (next_weekday (next_weekday tuesday)) = thursday.

Proof. simpl. reflexivity. Qed.