(* Following http://adam.chlipala.net/theses/andreser.pdf chapter 3 *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Structures.Orders.
Require Import Coq.Lists.List.
Require Import Crypto.Algebra.Nsatz.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Import Crypto.Util.ListUtil.Reifiable.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Decidable.Bool2Prop.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Modulo.PullPush.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
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.
  Definition eval (p:list (Z*Z)) : Z :=
    fold_right (fun x y => x + y) 0%Z (map (fun t => fst t * snd t) p).

  Lemma eval_nil : eval nil = 0.
  Proof. trivial.                                             Qed.
  Lemma eval_cons p q : eval (p::q) = fst p * snd p + eval q.
  Proof. trivial.                                             Qed.
  Lemma eval_app p q: eval (p++q) = eval p + eval q.
  Proof. induction p; rewrite <-?List.app_comm_cons;
           rewrite ?eval_nil, ?eval_cons; nsatz.              Qed.

#[global]
  Hint Rewrite eval_nil eval_cons eval_app : push_eval.
  Local Ltac push := autorewrite with
      push_eval push_map push_partition push_flat_map
      push_fold_right push_nth_default cancel_pair.

  Lemma eval_map_mul (a x:Z) (p:list (Z*Z))
  : eval (List.map (fun t => (a*fst t, x*snd t)) p) = a*x*eval p.
  Proof. induction p; push; nsatz.                            Qed.
#[global]
  Hint Rewrite eval_map_mul : push_eval.

  Definition mul (p q:list (Z*Z)) : list (Z*Z) :=
    flat_map (fun t =>
      map (fun t' =>
        (fst t * fst t', snd t * snd t'))
    q) p.
  Lemma eval_mul p q : eval (mul p q) = eval p * eval q.
  Proof. induction p; cbv [mul]; push; nsatz.                 Qed.
#[global]
  Hint Rewrite eval_mul : push_eval.

  Definition square (p:list (Z*Z)) : list (Z*Z) :=
    list_rect
      _
      nil
      (fun t ts acc
       => (dlet two_t2 := 2 * snd t in
               (fst t * fst t, snd t * snd t)
                 :: (map (fun t'
                          => (fst t * fst t', two_t2 * snd t'))
                         ts))
            ++ acc)
      p.
  Lemma eval_square p : eval (square p) = eval p * eval p.
  Proof. induction p; cbv [square list_rect Let_In]; push; nsatz. Qed.
#[global]
  Hint Rewrite eval_square : push_eval.

  Definition negate_snd (p:list (Z*Z)) : list (Z*Z) :=
    map (fun cx => (fst cx, -snd cx)) p.
  Lemma eval_negate_snd p : eval (negate_snd p) = - eval p.
  Proof. induction p; cbv [negate_snd]; push; nsatz.          Qed.
#[global]
  Hint Rewrite eval_negate_snd : push_eval.

  Example base10_2digit_mul (a0:Z) (a1:Z) (b0:Z) (b1:Z) :
    {ab| eval ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)]}.
    eexists ?[ab].
    (* Goal: eval ?ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)] *)
    rewrite <-eval_mul.
    (* Goal: eval ?ab = eval (mul [(10,a1);(1,a0)] [(10,b1);(1,b0)]) *)
    cbv -[Z.mul eval]; cbn -[eval].
    (* Goal: eval ?ab = eval [(100,(a1*b1));(10,a1*b0);(10,a0*b1);(1,a0*b0)]%RT *)
    trivial.                                              Defined.

  Lemma eval_partition f (p:list (Z*Z)) :
    eval (snd (partition f p)) + eval (fst (partition f p)) = eval p.
  Proof. induction p; cbn [partition]; eta_expand; break_match; cbn [fst snd]; push; nsatz. Qed.
#[global]
  Hint Rewrite eval_partition : push_eval.

  Lemma eval_partition' f (p:list (Z*Z)) :
    eval (fst (partition f p)) + eval (snd (partition f p)) = eval p.
  Proof. rewrite Z.add_comm, eval_partition; reflexivity. Qed.
#[global]
  Hint Rewrite eval_partition' : push_eval.

  Lemma eval_fst_partition f p : eval (fst (partition f p)) = eval p - eval (snd (partition f p)).
  Proof. rewrite <- (eval_partition f p); nsatz. Qed.
  Lemma eval_snd_partition f p : eval (snd (partition f p)) = eval p - eval (fst (partition f p)).
  Proof. rewrite <- (eval_partition f p); nsatz. Qed.

  Definition split (s:Z) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z)
    := let hi_lo := partition (fun t => fst t mod s =? 0) p in
       (snd hi_lo, map (fun t => (fst t / s, snd t)) (fst hi_lo)).
  Lemma eval_snd_split s p (s_nz:s<>0) :
    s * eval (snd (split s p)) = eval (fst (partition (fun t => fst t mod s =? 0) p)).
  Proof using Type. cbv [split Let_In]; induction p;
    repeat match goal with
    | |- context[?a/?b] =>
      unique pose proof (Z_div_exact_full_2 a b ltac:(trivial) ltac:(trivial))
    | _ => progress push
    | _ => progress break_match
    | _ => progress nsatz                                end. Qed.
  Lemma eval_split s p (s_nz:s<>0) :
    eval (fst (split s p)) + s * eval (snd (split s p)) = eval p.
  Proof using Type. rewrite eval_snd_split, eval_fst_partition by assumption; cbv [split Let_In]; cbn [fst snd]; lia. Qed.

  Lemma reduction_rule' b s c (modulus_nz:s-c<>0) :
    (s * b) mod (s - c) = (c * b) mod (s - c).
  Proof using Type. replace (s * b) with ((c*b) + b*(s-c)) by nsatz.
    rewrite Z.add_mod,Z_mod_mult,Z.add_0_r,Z.mod_mod;trivial. Qed.

  Lemma reduction_rule a b s c (modulus_nz:s-c<>0) :
    (a + s * b) mod (s - c) = (a + c * b) mod (s - c).
  Proof using Type. apply Z.add_mod_Proper; [ reflexivity | apply reduction_rule', modulus_nz ]. Qed.

  Definition reduce (s:Z) (c:list _) (p:list _) : list (Z*Z) :=
    let lo_hi := split s p in fst lo_hi ++ mul c (snd lo_hi).

  Lemma eval_reduce s c p (s_nz:s<>0) (modulus_nz:s-eval c<>0) :
    eval (reduce s c p) mod (s - eval c) = eval p mod (s - eval c).
  Proof using Type. cbv [reduce]; push.
         rewrite <-reduction_rule, eval_split; trivial.      Qed.
#[global]
  Hint Rewrite eval_reduce : push_eval.

  Lemma eval_reduce_adjusted s c p w c' (s_nz:s<>0) (modulus_nz:s-eval c<>0)
        (w_mod:w mod s = 0) (w_nz:w <> 0) (Hc' : eval c' = (w / s) * eval c) :
    eval (reduce w c' p) mod (s - eval c) = eval p mod (s - eval c).
  Proof using Type.
    cbv [reduce]; push.
    rewrite Hc', <- (Z.mul_comm (eval c)), <- !Z.mul_assoc, <-reduction_rule by auto.
    autorewrite with zsimplify_const; rewrite !Z.mul_assoc, Z.mul_div_eq_full, w_mod by auto.
    autorewrite with zsimplify_const; rewrite eval_split; trivial.
  Qed.

  (* reduce at most [n] times, stopping early if the high list is nil at any point *)
  Definition repeat_reduce (n : nat) (s:Z) (c:list _) (p:list _) : list (Z * Z)
    := nat_rect
         _
         (fun p => p)
         (fun n' repeat_reduce_n' p
          => let lo_hi := split s p in
             if (length (snd lo_hi) =? 0)%nat
             then p
             else let p := fst lo_hi ++ mul c (snd lo_hi) in
                  repeat_reduce_n' p)
         n
         p.

  Lemma repeat_reduce_S_step n s c p
    : repeat_reduce (S n) s c p
      = if (length (snd (split s p)) =? 0)%nat
        then p
        else repeat_reduce n s c (reduce s c p).
  Proof using Type. cbv [repeat_reduce]; cbn [nat_rect]; break_innermost_match; auto. Qed.

  Lemma eval_repeat_reduce n s c p (s_nz:s<>0) (modulus_nz:s-eval c<>0) :
    eval (repeat_reduce n s c p) mod (s - eval c) = eval p mod (s - eval c).
  Proof using Type.
    revert p; induction n as [|n IHn]; intro p; [ reflexivity | ];
      rewrite repeat_reduce_S_step; break_innermost_match;
        [ reflexivity | rewrite IHn ].
    now rewrite eval_reduce.
  Qed.
#[global]
  Hint Rewrite eval_repeat_reduce : push_eval.

  Lemma eval_repeat_reduce_adjusted n s c p w c' (s_nz:s<>0) (modulus_nz:s-eval c<>0)
        (w_mod:w mod s = 0) (w_nz:w <> 0) (Hc' : eval c' = (w / s) * eval c) :
    eval (repeat_reduce n w c' p) mod (s - eval c) = eval p mod (s - eval c).
  Proof using Type.
    revert p; induction n as [|n IHn]; intro p; [ reflexivity | ];
      rewrite repeat_reduce_S_step; break_innermost_match;
        [ reflexivity | rewrite IHn ].
    now rewrite eval_reduce_adjusted.
  Qed.

  Definition split_one (s:Z) (w fw : Z) (p:list (Z*Z)) :=
    let hi_lo := partition (fun t => (fst t =? w)) p in
      (snd hi_lo, map (fun t => (fst t / fw, snd t)) (fst hi_lo)).

  Lemma eval_split_one s w fw p (s_nz:s<>0) (fw_nz:fw<>0) (w_fw : w mod fw = 0) (fw_s : fw mod s = 0):
    Associational.eval (fst (split_one s w fw p)) + fw * Associational.eval (snd (split_one s w fw p)) = Associational.eval p.
  Proof.
    remember (Z_div_exact_full_2 _ _ fw_nz w_fw) as H2.
    clear HeqH2 fw_nz w_fw.
    induction p as [|t p' IHp'].
    - simpl. cbv [Associational.eval]. simpl. lia.
    - cbv [split_one]. simpl. destruct (fst t =? w) eqn:E.
      + simpl in IHp'. remember (partition (fun t0 : Z * Z => fst t0 =? w) p') as thing.
        destruct thing as [thing1 thing2]. simpl. simpl in IHp'. repeat rewrite Associational.eval_cons.
        ring_simplify. simpl.
        apply Z.eqb_eq in E. rewrite E. rewrite <- H2. rewrite <- IHp'. ring.
      + simpl in IHp'. remember (partition (fun t0 : Z * Z => fst t0 =? w) p') as thing.
        destruct thing as [thing1 thing2]. simpl. simpl in IHp'. repeat rewrite Associational.eval_cons.
        rewrite <- IHp'. ring.
  Qed.

  Definition reduce_one (s:Z) (w fw : Z) (c: Z) (p:list _) : list (Z*Z) :=
    let lo_hi := split_one s w fw p in
    fst lo_hi ++ map (fun thing => (fst thing, snd thing * (c * (fw / s)))) (snd lo_hi).

  Lemma eval_map_mul_snd (x:Z) (p:list (Z*Z))
    : Associational.eval (List.map (fun t => (fst t, snd t * x)) p) = x * Associational.eval p.
  Proof. induction p; push; nsatz. Qed.

  Lemma eval_reduce_one s w fw c p (s_nz:s<>0) (fw_nz:fw<>0) (w_fw : w mod fw = 0) (fw_s : fw mod s = 0)
                               (modulus_nz: s - c<>0) :
              Associational.eval (reduce_one s w fw c p) mod (s - c) =
              Associational.eval p mod (s - c).
  Proof using Type.
    cbv [reduce_one]; push.
    rewrite eval_map_mul_snd. rewrite <- Z.mul_assoc.
    rewrite <- (reduction_rule _ _ _ _ modulus_nz).
    rewrite Z.mul_assoc. rewrite <- (Z_div_exact_full_2 fw s s_nz fw_s). rewrite eval_split_one; trivial.
  Qed.

  (*
  Definition splitQ (s:Q) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z)
    := let hi_lo := partition (fun t => (fst t * Zpos (Qden s)) mod (Qnum s) =? 0) p in
       (snd hi_lo, map (fun t => ((fst t * Zpos (Qden s)) / Qnum s, snd t)) (fst hi_lo)).
  Lemma eval_snd_splitQ s p (s_nz:Qnum s<>0) :
   Qnum s * eval (snd (splitQ s p)) = eval (fst (partition (fun t => (fst t * Zpos (Qden s)) mod (Qnum s) =? 0) p)) * Zpos (Qden s).
  Proof using Type.
    (* Work around https://github.com/mit-plv/fiat-crypto/issues/381 ([nsatz] can't handle [Zpos]) *)
    cbv [splitQ Let_In]; cbn [fst snd]; zify; generalize dependent (Zpos (Qden s)); generalize dependent (Qnum s); clear s; intros.
    induction p;
    repeat match goal with
    | |- context[?a/?b] =>
      unique pose proof (Z_div_exact_full_2 a b ltac:(trivial) ltac:(trivial))
    | _ => progress push
    | _ => progress break_match
    | _ => progress nsatz                                end. Qed.
  Lemma eval_splitQ s p (s_nz:Qnum s<>0) :
    eval (fst (splitQ s p)) + (Qnum s * eval (snd (splitQ s p))) / Zpos (Qden s) = eval p.
  Proof using Type. rewrite eval_snd_splitQ, eval_fst_partition by assumption; cbv [splitQ Let_In]; cbn [fst snd]; Z.div_mod_to_quot_rem_in_goal; nia. Qed.
  Lemma eval_splitQ_mul s p (s_nz:Qnum s<>0) :
    eval (fst (splitQ s p)) * Zpos (Qden s) + (Qnum s * eval (snd (splitQ s p))) = eval p * Zpos (Qden s).
  Proof using Type. rewrite eval_snd_splitQ, eval_fst_partition by assumption; cbv [splitQ Let_In]; cbn [fst snd]; nia. Qed.
   *)
  Lemma eval_rev p : eval (rev p) = eval p.
  Proof using Type. induction p; cbn [rev]; push; lia. Qed.
#[global]
  Hint Rewrite eval_rev : push_eval.
  (*
  Lemma eval_permutation (p q : list (Z * Z)) : Permutation p q -> eval p = eval q.
  Proof using Type. induction 1; push; nsatz.                          Qed.

  Module RevWeightOrder <: TotalLeBool.
    Definition t := (Z * Z)%type.
    Definition leb (x y : t) := Z.leb (fst y) (fst x).
    Infix "<=?" := leb.
    Local Coercion is_true : bool >-> Sortclass.
    Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1.
    Proof using Type.
      cbv [is_true leb]; intros x y; rewrite !Z.leb_le; pose proof (Z.le_ge_cases (fst x) (fst y)).
      lia.
    Qed.
    Global Instance leb_Transitive : Transitive leb.
    Proof using Type. repeat intro; unfold is_true, leb in *; Z.ltb_to_lt; lia. Qed.
  End RevWeightOrder.

  Module RevWeightSort := Mergesort.Sort RevWeightOrder.

  Lemma eval_sort p : eval (RevWeightSort.sort p) = eval p.
  Proof using Type. symmetry; apply eval_permutation, RevWeightSort.Permuted_sort. Qed.
  Hint Rewrite eval_sort : push_eval.
  *)
  (* rough template (we actually have to do things a bit differently to account for duplicate weights):
[ dlet fi_c := c * fi in
   let (fj_high, fj_low) := split fj at s/fi.weight in
   dlet fi_2 := 2 * fi in
    dlet fi_2_c := 2 * fi_c in
    (if fi.weight^2 >= s then fi_c * fi else fi * fi)
       ++ fi_2_c * fj_high
       ++ fi_2 * fj_low
 | fi <- f , fj := (f weight less than i) ]
   *)
  (** N.B. We take advantage of dead code elimination to allow us to
      let-bind partial products that we don't end up using *)
  (** [v] -> [(v, v*c, v*c*2, v*2)] *)
  Definition let_bind_for_reduce_square (c:list (Z*Z)) (p:list (Z*Z)) : list ((Z*Z) * list(Z*Z) * list(Z*Z) * list(Z*Z)) :=
    let two := [(1,2)] (* (weight, value) *) in
    map (fun t => dlet c_t := mul [t] c in dlet two_c_t := mul c_t two in dlet two_t := mul [t] two in (t, c_t, two_c_t, two_t)) p.
  Definition reduce_square (s:Z) (c:list (Z*Z)) (p:list (Z*Z)) : list (Z*Z) :=
    let p := let_bind_for_reduce_square c p in
    let div_s := map (fun t => (fst t / s, snd t)) in
    list_rect
      _
      nil
      (fun t ts acc
       => (let '(t, c_t, two_c_t, two_t) := t in
           (if ((fst t * fst t) mod s =? 0)
            then div_s (mul [t] c_t)
            else mul [t] [t])
             ++ (flat_map
                   (fun '(t', c_t', two_c_t', two_t')
                    => if ((fst t * fst t') mod s =? 0)
                       then div_s
                              (if fst t' <=? fst t
                               then mul [t'] two_c_t
                               else mul [t] two_c_t')
                       else (if fst t' <=? fst t
                             then mul [t'] two_t
                             else mul [t] two_t'))
                   ts))
            ++ acc)
      p.
  Lemma eval_map_div s p (s_nz:s <> 0) (Hmod : forall v, In v p -> fst v mod s = 0)
    : eval (map (fun x => (fst x / s, snd x)) p) = eval p / s.
  Proof using Type.
    assert (Hmod' : forall v, In v p -> (fst v * snd v) mod s = 0).
    { intros; push_Zmod; rewrite Hmod by assumption; autorewrite with zsimplify_const; reflexivity. }
    induction p as [|p ps IHps]; push.
    { autorewrite with zsimplify_const; reflexivity. }
    { cbn [In] in *; rewrite Z.div_add_exact by eauto.
      rewrite !Z.Z_divide_div_mul_exact', IHps by auto using Znumtheory.Zmod_divide.
      nsatz. }
  Qed.
  Lemma eval_map_mul_div s a b c (s_nz:s <> 0) (a_mod : (a*a) mod s = 0)
    : eval (map (fun x => ((a * (a * fst x)) / s, b * (b * snd x))) c) = ((a * a) / s) * (b * b) * eval c.
  Proof using Type.
    rewrite <- eval_map_mul; apply f_equal, map_ext; intro.
    rewrite !Z.mul_assoc.
    rewrite !Z.Z_divide_div_mul_exact' by auto using Znumtheory.Zmod_divide.
    f_equal; nia.
  Qed.
#[global]
  Hint Rewrite eval_map_mul_div using solve [ auto ] : push_eval.

  Lemma eval_map_mul_div' s a b c (s_nz:s <> 0) (a_mod : (a*a) mod s = 0)
    : eval (map (fun x => (((a * a) * fst x) / s, (b * b) * snd x)) c) = ((a * a) / s) * (b * b) * eval c.
  Proof using Type. rewrite <- eval_map_mul_div by assumption; f_equal; apply map_ext; intro; Z.div_mod_to_quot_rem_in_goal; f_equal; nia. Qed.
#[global]
  Hint Rewrite eval_map_mul_div' using solve [ auto ] : push_eval.

  Lemma eval_flat_map_if A (f : A -> bool) g h p
    : eval (flat_map (fun x => if f x then g x else h x) p)
      = eval (flat_map g (fst (partition f p))) + eval (flat_map h (snd (partition f p))).
  Proof using Type.
    induction p; cbn [flat_map partition fst snd]; eta_expand; break_match; cbn [fst snd]; push;
      nsatz.
  Qed.
  (*Local Hint Rewrite eval_flat_map_if : push_eval.*) (* this should be [Local], but that doesn't work *)

  Lemma eval_if (b : bool) p q : eval (if b then p else q) = if b then eval p else eval q.
  Proof using Type. case b; reflexivity. Qed.
#[global]
  Hint Rewrite eval_if : push_eval.

  Lemma split_app s p q :
    split s (p ++ q) = (fst (split s p) ++ fst (split s q), snd (split s p) ++ snd (split s q)).
  Proof using Type.
    cbv [split]; rewrite !partition_app; cbn [fst snd].
    rewrite !map_app; reflexivity.
  Qed.
  Lemma fst_split_app s p q :
    fst (split s (p ++ q)) = fst (split s p) ++ fst (split s q).
  Proof using Type. rewrite split_app; reflexivity. Qed.
  Lemma snd_split_app s p q :
    snd (split s (p ++ q)) = snd (split s p) ++ snd (split s q).
  Proof using Type. rewrite split_app; reflexivity. Qed.
#[global]
  Hint Rewrite fst_split_app snd_split_app : push_eval.

  Lemma eval_reduce_list_rect_app A s c N C p :
    eval (reduce s c (@list_rect A _ N (fun x xs acc => C x xs ++ acc) p))
    = eval (@list_rect A _ (reduce s c N) (fun x xs acc => reduce s c (C x xs) ++ acc) p).
  Proof using Type.
    cbv [reduce]; induction p as [|p ps IHps]; cbn [list_rect]; push; [ nsatz | rewrite <- IHps; clear IHps ].
    push; nsatz.
  Qed.
#[global]
  Hint Rewrite eval_reduce_list_rect_app : push_eval.

  Lemma eval_list_rect_app A N C p :
    eval (@list_rect A _ N (fun x xs acc => C x xs ++ acc) p)
    = @list_rect A _ (eval N) (fun x xs acc => eval (C x xs) + acc) p.
  Proof using Type. induction p; cbn [list_rect]; push; nsatz. Qed.
#[global]
  Hint Rewrite eval_list_rect_app : push_eval.

  Local Existing Instances list_rect_Proper pointwise_map flat_map_Proper.
  Local Hint Extern 0 (Proper _ _) => solve_Proper_eq : typeclass_instances.

  Lemma reduce_nil s c : reduce s c nil = nil.
  Proof using Type. cbv [reduce]; induction c; cbn; intuition auto. Qed.
#[global]
  Hint Rewrite reduce_nil : push_eval.

  Lemma eval_reduce_app s c p q : eval (reduce s c (p ++ q)) = eval (reduce s c p) + eval (reduce s c q).
  Proof using Type. cbv [reduce]; push; nsatz. Qed.
#[global]
  Hint Rewrite eval_reduce_app : push_eval.

  Lemma eval_reduce_cons s c p q :
    eval (reduce s c (p :: q))
    = (if fst p mod s =? 0 then eval c * ((fst p / s) * snd p) else fst p * snd p)
      + eval (reduce s c q).
  Proof using Type.
    cbv [reduce split]; cbn [partition fst snd]; eta_expand; push.
    break_innermost_match; cbn [fst snd map]; push; nsatz.
  Qed.
#[global]
  Hint Rewrite eval_reduce_cons : push_eval.

  Lemma mul_cons_l t ts p :
    mul (t::ts) p = map (fun t' => (fst t * fst t', snd t * snd t')) p ++ mul ts p.
  Proof using Type. reflexivity. Qed.
  Lemma mul_nil_l p : mul nil p = nil.
  Proof using Type. reflexivity. Qed.
  Lemma mul_nil_r p : mul p nil = nil.
  Proof using Type. cbv [mul]; induction p; cbn; intuition auto. Qed.
#[global]
  Hint Rewrite mul_nil_l mul_nil_r : push_eval.
  Lemma mul_app_l p p' q :
    mul (p ++ p') q = mul p q ++ mul p' q.
  Proof using Type. cbv [mul]; rewrite flat_map_app; reflexivity. Qed.
  Lemma mul_singleton_l_app_r p q q' :
    mul [p] (q ++ q') = mul [p] q ++ mul [p] q'.
  Proof using Type. cbv [mul flat_map]; rewrite !map_app, !app_nil_r; reflexivity. Qed.
#[global]
  Hint Rewrite mul_singleton_l_app_r : push_eval.
  Lemma mul_singleton_singleton p q :
    mul [p] [q] = [(fst p * fst q, snd p * snd q)].
  Proof using Type. reflexivity. Qed.

  Lemma eval_reduce_square_step_helper s c t' t v (s_nz:s <> 0) :
    (fst t * fst t') mod s = 0 \/ (fst t' * fst t) mod s = 0 -> In v (mul [t'] (mul (mul [t] c) [(1, 2)])) -> fst v mod s = 0.
  Proof using Type.
    cbv [mul]; cbn [map flat_map fst snd].
    rewrite !app_nil_r, flat_map_singleton, !map_map; cbn [fst snd]; rewrite in_map_iff; intros [H|H] [? [? ?] ]; subst; revert H.
    all:cbn [fst snd]; autorewrite with zsimplify_const; intro H; rewrite Z.mul_assoc, Z.mul_mod_l.
    all:rewrite H || rewrite (Z.mul_comm (fst t')), H; autorewrite with zsimplify_const; reflexivity.
  Qed.

  Lemma eval_reduce_square_step s c t ts (s_nz : s <> 0) :
    eval (flat_map
            (fun t' => if (fst t * fst t') mod s =? 0
                    then map (fun t => (fst t / s, snd t))
                             (if fst t' <=? fst t
                              then mul [t'] (mul (mul [t] c) [(1, 2)])
                              else mul [t] (mul (mul [t'] c) [(1, 2)]))
                    else (if fst t' <=? fst t
                          then mul [t'] (mul [t] [(1, 2)])
                          else mul [t] (mul [t'] [(1, 2)])))
            ts)
    = eval (reduce s c (mul [(1, 2)] (mul [t] ts))).
  Proof using Type.
    induction ts as [|t' ts IHts]; cbn [flat_map]; [ push; nsatz | rewrite eval_app, IHts; clear IHts ].
    change (t'::ts) with ([t'] ++ ts); rewrite !mul_singleton_l_app_r, !mul_singleton_singleton; autorewrite with zsimplify_const; push.
    break_match; Z.ltb_to_lt; push; try nsatz.
    all:rewrite eval_map_div by eauto using eval_reduce_square_step_helper; push; autorewrite with zsimplify_const.
    all:rewrite ?Z.mul_assoc, <- !(Z.mul_comm (fst t')), ?Z.mul_assoc.
    all:rewrite ?Z.mul_assoc, <- !(Z.mul_comm (fst t)), ?Z.mul_assoc.
    all:rewrite <- !Z.mul_assoc, Z.mul_assoc.
    all:rewrite !Z.Z_divide_div_mul_exact' by auto using Znumtheory.Zmod_divide.
    all:nsatz.
  Qed.

  Lemma eval_reduce_square_helper s c x y v (s_nz:s <> 0) :
    (fst x * fst y) mod s = 0 \/ (fst y * fst x) mod s = 0 -> In v (mul [x] (mul [y] c)) -> fst v mod s = 0.
  Proof using Type.
    cbv [mul]; cbn [map flat_map fst snd].
    rewrite !app_nil_r, ?flat_map_singleton, !map_map; cbn [fst snd]; rewrite in_map_iff; intros [H|H] [? [? ?] ]; subst; revert H.
    all:cbn [fst snd]; autorewrite with zsimplify_const; intro H; rewrite Z.mul_assoc, Z.mul_mod_l.
    all:rewrite H || rewrite (Z.mul_comm (fst x)), H; autorewrite with zsimplify_const; reflexivity.
  Qed.

  Lemma eval_reduce_square_exact s c p (s_nz:s<>0) (modulus_nz:s-eval c<>0)
    : eval (reduce_square s c p) = eval (reduce s c (square p)).
  Proof using Type.
    cbv [let_bind_for_reduce_square reduce_square square Let_In]; rewrite list_rect_map; push.
    apply list_rect_Proper; [ | repeat intro; subst | reflexivity ]; cbv [split]; push; [ nsatz | ].
    rewrite flat_map_map, eval_reduce_square_step by auto.
    break_match; Z.ltb_to_lt; push.
    1:rewrite eval_map_div by eauto using eval_reduce_square_helper; push.
    all:cbv [mul]; cbn [map flat_map fst snd]; rewrite !app_nil_r, !map_map; cbn [fst snd].
    all:autorewrite with zsimplify_const.
    all:rewrite <- ?Z.mul_assoc, !(Z.mul_comm (fst a)), <- ?Z.mul_assoc.
    all:rewrite ?Z.mul_assoc, <- (Z.mul_assoc _ (fst a) (fst a)), <- !(Z.mul_comm (fst a * fst a)).
    1:rewrite !Z.Z_divide_div_mul_exact' by auto using Znumtheory.Zmod_divide.
    all:idtac;
      let LHS := match goal with |- ?LHS = ?RHS => LHS end in
      let RHS := match goal with |- ?LHS = ?RHS => RHS end in
      let f := match LHS with context[eval (reduce _ _ (map ?f _))] => f end in
      let g := match RHS with context[eval (reduce _ _ (map ?f _))] => f end in
      rewrite (map_ext f g) by (intros; f_equal; nsatz).
    all:nsatz.
  Qed.
  Lemma eval_reduce_square s c p (s_nz:s<>0) (modulus_nz:s-eval c<>0)
    : eval (reduce_square s c p) mod (s - eval c)
      = (eval p * eval p) mod (s - eval c).
  Proof using Type. rewrite eval_reduce_square_exact by assumption; push; auto. Qed.
#[global]
  Hint Rewrite eval_reduce_square : push_eval.

  Definition bind_snd (p : list (Z*Z)) :=
    map (fun t => dlet_nd t2 := snd t in (fst t, t2)) p.

  Lemma bind_snd_correct p : bind_snd p = p.
  Proof using Type.
    cbv [bind_snd]; induction p as [| [? ?] ];
      push; [|rewrite IHp]; reflexivity.
  Qed.

  Definition value_at_weight (a : list (Z * Z)) (d : Z) :=
    fold_right Z.add 0 (map snd (filter (fun p => fst p =? d) a)).

  Lemma value_at_weight_works a d : d * (value_at_weight a d) = Associational.eval (filter (fun p => fst p =? d) a).
  Proof.
    induction a as [| a0 a' IHa'].
    - cbv [Associational.eval value_at_weight]. simpl. lia.
    - cbv [value_at_weight]. simpl. destruct (fst a0 =? d) eqn:E.
      + rewrite Associational.eval_cons. simpl. rewrite <- IHa'. cbv [value_at_weight]. lia.
      + apply IHa'.
  Qed.

  Lemma not_in_value_0 a d : ~ In d (map fst a) -> value_at_weight a d = 0.
  Proof.
    intros H. induction a as [| x a' IHa'].
    - reflexivity.
    - cbv [value_at_weight]. simpl. destruct (fst x =? d) eqn:E.
      + exfalso. apply H. simpl. lia.
      + apply IHa'. intros H'. apply H. simpl. right. apply H'.
  Qed.

  Definition dedup_weights a :=
    map (fun d => (d, value_at_weight a d)) (nodupb Z.eqb (map fst a)).

  Lemma funs_same (l : list Z) (a0 : Z*Z) (a' : list (Z*Z)) :
  ~ In (fst a0) l ->
  forall d, In d l ->
  (fun d : Z => (d, value_at_weight (a0 :: a') d)) d = (fun d => (d, value_at_weight a' d)) d.
  Proof.
    intros H d H'. simpl. f_equal. cbv [value_at_weight]. simpl. destruct (fst a0 =? d) eqn:E.
    - exfalso. rewrite Z.eqb_eq in E. subst. apply (H H').
    - reflexivity.
  Qed.

  Lemma eval_dedup_weights a : Associational.eval (dedup_weights a) = Associational.eval a.
  Proof.
    induction a as [| a0 a' IHa'].
    - reflexivity.
    - cbv [dedup_weights]. simpl. destruct (existsb (Z.eqb (fst a0)) (nodupb Z.eqb (map fst a'))) eqn:E.
      + apply (existsb_eqb_true_iff Z.eqb Z.eqb_eq) in E. rewrite <- (nodupb_in_iff Z.eqb Z.eqb_eq) in E.
        apply (nodupb_split Z.eqb Z.eqb_eq) in E. destruct E as [l1 [l2 [H1 [H2 H3] ] ] ]. rewrite H1.
        repeat rewrite map_app. rewrite (map_ext_in _ _ l1 (funs_same l1 a0 a' H2)).
        rewrite (map_ext_in _ _ l2 (funs_same l2 a0 a' H3)). repeat rewrite Associational.eval_app. simpl.
        repeat rewrite Associational.eval_cons. simpl. rewrite <- IHa'. simpl. rewrite Associational.eval_nil.
        cbv [dedup_weights]. rewrite H1. repeat rewrite map_app. repeat rewrite Associational.eval_app.
        cbv [value_at_weight]. simpl. rewrite Z.eqb_refl. simpl. cbv [Associational.eval]. simpl. lia.
      + simpl. apply (existsb_eqb_false_iff Z.eqb Z.eqb_eq) in E. rewrite (map_ext_in _ _ _ (funs_same _ _ _ E)).
        repeat rewrite Associational.eval_cons. simpl. rewrite <- IHa'. cbv [dedup_weights]. f_equal. f_equal.
        rewrite <- (nodupb_in_iff Z.eqb Z.eqb_eq) in E. cbv [value_at_weight]. simpl. rewrite Z.eqb_refl.
        apply not_in_value_0 in E. cbv [value_at_weight] in E. simpl. rewrite E. lia.
  Qed.

  Section Carries.
    Definition carryterm (w fw:Z) (t:Z * Z) :=
      if (Z.eqb (fst t) w)
      then dlet_nd t2 := snd t in
           dlet_nd d2 := t2 / fw in
           dlet_nd m2 := t2 mod fw in
           [(w * fw, d2);(w,m2)]
      else [t].

    Lemma eval_carryterm w fw (t:Z * Z) (fw_nonzero:fw<>0):
      eval (carryterm w fw t) = eval [t].
    Proof using Type*.
      cbv [carryterm Let_In]; break_match; push; [|trivial].
      pose proof (Z.div_mod (snd t) fw fw_nonzero).
      rewrite Z.eqb_eq in *.
      nsatz.
    Qed. Hint Rewrite eval_carryterm using auto : push_eval.

    Definition carry (w fw:Z) (p:list (Z * Z)):=
      flat_map (carryterm w fw) p.

    Lemma eval_carry w fw p (fw_nonzero:fw<>0):
      eval (carry w fw p) = eval p.
    Proof using Type*. cbv [carry]; induction p; push; nsatz. Qed.
    Hint Rewrite eval_carry using auto : push_eval.

  Definition borrowterm (w fw:Z) (t:Z * Z) :=
      let quot := w / fw in
      if (Z.eqb (fst t) w)
        then [(quot, snd t * fw)]
        else [t].

  Lemma eval_borrowterm w fw (t:Z * Z) (fw_nz:fw<>0) (w_fw:w mod fw = 0) :
        Associational.eval (borrowterm w fw t) = Associational.eval [t].
  Proof using Type*.
    cbv [borrowterm Let_In]; break_match; push; [|trivial].
    pose proof (Z.div_mod (snd t) fw fw_nz).
    rewrite Z.eqb_eq in *.
    ring_simplify. rewrite Z.mul_comm. rewrite Z.mul_assoc. rewrite <- Z_div_exact_full_2; lia.
  Qed.

  Definition borrow (w fw:Z) (p:list (Z*Z)) :=
    flat_map (borrowterm w fw) p.

  Lemma eval_borrow w fw p (fw_nz:fw<>0) (w_fw:w mod fw = 0):
        Associational.eval (borrow w fw p) = Associational.eval p.
  Proof using Type*.
    cbv [borrow borrowterm]. induction p as [| a p' IHp'].
    - trivial.
    - push. destruct (fst a =? w) eqn:E.
      + rewrite Z.mul_comm. rewrite <- Z.mul_assoc. rewrite <- Z_div_exact_full_2; lia.
      + rewrite IHp'. lia.
  Qed.

  End Carries.
End Associational.

Module Weight.
  Section Weight.
    Context weight
            (weight_0 : weight 0%nat = 1)
            (weight_positive : forall i, 0 < weight i)
            (weight_multiples : forall i, weight (S i) mod weight i = 0)
            (weight_divides : forall i : nat, 0 < weight (S i) / weight i).

    Lemma weight_multiples_full' j : forall i, weight (i+j) mod weight i = 0.
    Proof using weight_positive weight_multiples.
      induction j; intros;
        repeat match goal with
               | _ => rewrite Nat.add_succ_r
               | _ => rewrite IHj
               | |- context [weight (S ?x) mod weight _] =>
                 rewrite (Z.div_mod (weight (S x)) (weight x)), weight_multiples by auto with zarith
               | _ => progress autorewrite with push_Zmod natsimplify zsimplify_fast
               | _ => reflexivity
               end.
    Qed.

    Lemma weight_multiples_full j i : (i <= j)%nat -> weight j mod weight i = 0.
    Proof using weight_positive weight_multiples.
      intros; replace j with (i + (j - i))%nat by lia.
      apply weight_multiples_full'.
    Qed.

    Lemma weight_divides_full j i : (i <= j)%nat -> 0 < weight j / weight i.
    Proof using weight_positive weight_multiples. auto using Z.gt_lt, Z.div_positive_gt_0, weight_multiples_full with zarith. Qed.

    Lemma weight_div_mod j i : (i <= j)%nat -> weight j = weight i * (weight j / weight i).
    Proof using weight_positive weight_multiples. intros. apply Z.div_exact; auto using weight_multiples_full with zarith. Qed.

    Lemma weight_mod_pull_div n x :
      x mod weight (S n) / weight n =
      (x / weight n) mod (weight (S n) / weight n).
    Proof using weight_positive weight_multiples weight_divides.
      replace (weight (S n)) with (weight n * (weight (S n) / weight n));
      repeat match goal with
             | _ => progress autorewrite with zsimplify_fast
             | _ => rewrite Z.mul_div_eq_full by auto with zarith
             | _ => rewrite Z.mul_div_eq' by auto with zarith
             | _ => rewrite Z.mod_pull_div
             | _ => rewrite weight_multiples by auto with zarith
             | _ => solve [auto with zarith]
             end.
    Qed.

    Lemma weight_div_pull_div n x :
      x / weight (S n) =
      (x / weight n) / (weight (S n) / weight n).
    Proof using weight_positive weight_multiples weight_divides.
      replace (weight (S n)) with (weight n * (weight (S n) / weight n));
      repeat match goal with
             | _ => progress autorewrite with zdiv_to_mod zsimplify_fast
             | _ => rewrite Z.mul_div_eq_full by auto with zarith
             | _ => rewrite Z.mul_div_eq' by auto with zarith
             | _ => rewrite Z.div_div by auto with zarith
             | _ => rewrite weight_multiples by assumption
             | _ => solve [auto with zarith]
             end.
    Qed.
  End Weight.
End Weight.

Module Positional.
  Import Weight.
  Section Positional.
  Context (weight : nat -> Z)
          (weight_0 : weight 0%nat = 1)
          (weight_nz : forall i, weight i <> 0).

  Definition to_associational (n:nat) (xs:list Z) : list (Z*Z)
    := combine (map weight (List.seq 0 n)) xs.
  Definition eval n x := Associational.eval (@to_associational n x).
  Lemma eval_to_associational n x :
    Associational.eval (@to_associational n x) = eval n x.
  Proof using Type. trivial.                                             Qed.
  Hint Rewrite @eval_to_associational : push_eval.
  Lemma eval_nil n : eval n [] = 0.
  Proof using Type. cbv [eval to_associational]. rewrite combine_nil_r. reflexivity. Qed.
  Hint Rewrite eval_nil : push_eval.
  Lemma eval0 p : eval 0 p = 0.
  Proof using Type. cbv [eval to_associational]. reflexivity. Qed.
  Hint Rewrite eval0 : push_eval.

  Lemma eval_snoc n m x y : n = length x -> m = S n -> eval m (x ++ [y]) = eval n x + weight n * y.
  Proof using Type.
    cbv [eval to_associational]; intros; subst n m.
    rewrite seq_snoc, map_app.
    rewrite combine_app_samelength by distr_length.
    autorewrite with push_eval. simpl.
    autorewrite with push_eval cancel_pair; ring.
  Qed.

  Lemma eval_snoc_S n x y : n = length x -> eval (S n) (x ++ [y]) = eval n x + weight n * y.
  Proof using Type. intros; erewrite eval_snoc; eauto. Qed.
  Hint Rewrite eval_snoc_S using (solve [distr_length]) : push_eval.

  (* SKIP over this: zeros, add_to_nth *)
  Local Ltac push := autorewrite with push_eval push_map distr_length
    push_flat_map push_fold_right push_nth_default cancel_pair natsimplify.
  Definition zeros n : list Z := repeat 0 n.
  Lemma length_zeros n : length (zeros n) = n. Proof using Type. clear; cbv [zeros]; distr_length. Qed.
  Hint Rewrite length_zeros : distr_length.
  Lemma eval_combine_zeros ls n : Associational.eval (List.combine ls (zeros n)) = 0.
  Proof using Type.
    clear; cbv [Associational.eval zeros].
    revert n; induction ls, n; simpl; rewrite ?IHls; nsatz.   Qed.
  Lemma eval_zeros n : eval n (zeros n) = 0.
  Proof using Type. apply eval_combine_zeros.                            Qed.
  Definition add_to_nth i x (ls : list Z) : list Z
    := ListUtil.update_nth i (fun y => x + y) ls.
  Lemma length_add_to_nth i x ls : length (add_to_nth i x ls) = length ls.
  Proof using Type. clear; cbv [add_to_nth]; distr_length. Qed.
  Hint Rewrite length_add_to_nth : distr_length.
  Lemma eval_add_to_nth (n:nat) (i:nat) (x:Z) (xs:list Z) (H:(i<length xs)%nat)
        (Hn : length xs = n) (* N.B. We really only need [i < Nat.min n (length xs)] *) :
    eval n (add_to_nth i x xs) = weight i * x + eval n xs.
  Proof using Type.
    subst n.
    cbv [eval to_associational add_to_nth].
    rewrite ListUtil.combine_update_nth_r at 1.
    rewrite <-(update_nth_id i (List.combine _ _)) at 2.
    rewrite <-!(ListUtil.splice_nth_equiv_update_nth_update _ _
      (weight 0, 0)) by (push; lia); cbv [ListUtil.splice_nth id].
    repeat match goal with
           | _ => progress push
           | _ => progress break_match
           | _ => progress (apply Zminus_eq; ring_simplify)
           | _ => rewrite <-ListUtil.map_nth_default_always
           end; lia.                                          Qed.
  Hint Rewrite @eval_add_to_nth eval_zeros eval_combine_zeros : push_eval.
  Lemma add_to_nth_zero i l : add_to_nth i 0 l = l.
  Proof. cbv [add_to_nth]. apply update_nth_id_eq. reflexivity. Qed.

  Lemma zeros_ext_map {A} n (p : list A) : length p = n -> zeros n = map (fun _ => 0) p.
  Proof using Type. cbv [zeros]; intro; subst; induction p; cbn; congruence. Qed.

  Lemma eval_mul_each (n:nat) (a:Z) (p:list Z)
        (Hn : length p = n)
    : eval n (List.map (fun x => a*x) p) = a*eval n p.
  Proof using Type.
    clear -Hn.
    transitivity (Associational.eval (map (fun t => (1 * fst t, a * snd t)) (to_associational n p))).
    { cbv [eval to_associational]; rewrite !combine_map_r.
      f_equal; apply map_ext; intros; f_equal; nsatz. }
    { rewrite Associational.eval_map_mul, eval_to_associational; nsatz. }
  Qed.
  Hint Rewrite eval_mul_each : push_eval.

  Definition place (t:Z*Z) (i:nat) : nat * Z :=
    nat_rect
      (fun _ => unit -> (nat * Z)%type)
      (fun _ => (O, fst t * snd t))
      (fun i' place_i' _
       => let i := S i' in
          if (fst t mod weight i =? 0)
          then (i, let c := fst t / weight i in c * snd t)
          else place_i' tt)
      i
      tt.

  Lemma place_in_range (t:Z*Z) (n:nat) : (fst (place t n) < S n)%nat.
  Proof using Type. induction n; cbv [place nat_rect] in *; break_match; autorewrite with cancel_pair; try lia. Qed.
  Lemma weight_place t i : weight (fst (place t i)) * snd (place t i) = fst t * snd t.
  Proof using weight_nz weight_0. induction i; cbv [place nat_rect] in *; break_match; push;
    repeat match goal with |- context[?a/?b] =>
      unique pose proof (Z_div_exact_full_2 a b ltac:(auto) ltac:(auto))
           end; nsatz.                                        Qed.
  Hint Rewrite weight_place : push_eval.
  Lemma weight_add_mod (weight_mul : forall i, weight (S i) mod weight i = 0) i j
    : weight (i + j) mod weight i = 0.
  Proof using weight_nz.
    rewrite Nat.add_comm.
    induction j as [|[|j] IHj]; cbn [Nat.add] in *;
      eauto using Z_mod_same_full, Z.mod_mod_trans.
  Qed.
  Lemma weight_mul_iff (weight_pos : forall i, 0 < weight i) (weight_mul : forall i, weight (S i) mod weight i = 0) i j
    : weight i mod weight j = 0 <-> ((j < i)%nat \/ forall k, (i <= k <= j)%nat -> weight k = weight j).
  Proof using weight_nz.
    split.
    { destruct (dec (j < i)%nat); [ left; lia | intro H; right; revert H ].
      assert (j = (j - i) + i)%nat by lia.
      generalize dependent (j - i)%nat; intro jmi; intros ? H0.
      subst j.
      destruct jmi as [|j]; [ intros k ?; assert (k = i) by lia; subst; f_equal; lia | ].
      induction j as [|j IH]; cbn [Nat.add] in *.
      { intros k ?; assert (k = i \/ k = S i) by lia; destruct_head'_or; subst;
          eauto using Z.mod_mod_0_0_eq_pos. }
      { specialize_by lia.
        { pose proof (weight_mul (S (j + i))) as H.
          specialize_by eauto using Z.mod_mod_trans with lia.
          intros k H'; destruct (dec (k = S (S (j + i)))); subst;
            try rewrite IH by eauto using Z.mod_mod_trans with lia;
            eauto using Z.mod_mod_trans, Z.mod_mod_0_0_eq_pos with lia.
          rewrite (IH i) in * by lia.
          eauto using Z.mod_mod_trans, Z.mod_mod_0_0_eq_pos with lia. } } }
    { destruct (dec (j < i)%nat) as [H|H]; [ intros _ | intros [H'|H']; try lia ].
      { assert (i = j + (i - j))%nat by lia.
        generalize dependent (i - j)%nat; intro imj; intros.
        subst i.
        apply weight_add_mod; auto. }
      { erewrite H', Z_mod_same_full by lia; lia. } }
  Qed.
  Lemma weight_div_from_pos_mul (weight_pos : forall i, 0 < weight i) (weight_mul : forall i, weight (S i) mod weight i = 0)
    : forall i, 0 < weight (S i) / weight i.
  Proof using weight_nz.
    intro i; generalize (weight_mul i) (weight_mul (S i)).
    Z.div_mod_to_quot_rem; nia.
  Qed.
  Lemma place_weight n (weight_pos : forall i, 0 < weight i) (weight_mul : forall i, weight (S i) mod weight i = 0)
        (weight_unique : forall i j, (i <= n)%nat -> (j <= n)%nat -> weight i = weight j -> i = j)
        i x
    : (place (weight i, x) n) = (Nat.min i n, (weight i / weight (Nat.min i n)) * x).
  Proof using weight_0 weight_nz.
    cbv [place].
    induction n as [|n IHn]; cbn; [ destruct i; cbn; rewrite ?weight_0; autorewrite with zsimplify_const; reflexivity | ].
    destruct (dec (i < S n)%nat);
      break_innermost_match; cbn [fst snd] in *; Z.ltb_to_lt; [ | rewrite IHn | | rewrite IHn ];
        break_innermost_match;
        rewrite ?Min.min_l in * by lia;
        rewrite ?Min.min_r in * by lia;
        eauto with lia.
    { rewrite weight_mul_iff in * by auto.
      destruct_head'_or; try lia.
      assert (S n = i).
      { apply weight_unique; try lia.
        symmetry; eauto with lia. }
      subst; reflexivity. }
    { rewrite weight_mul_iff in * by auto.
      exfalso; intuition eauto with lia. }
  Qed.

  Definition from_associational n (p:list (Z*Z)) :=
    List.fold_right (fun t ls =>
      dlet_nd p := place t (pred n) in
      add_to_nth (fst p) (snd p) ls ) (zeros n) p.
  Lemma eval_from_associational n p (n_nz:n<>O \/ p = nil) :
    eval n (from_associational n p) = Associational.eval p.
  Proof using weight_0 weight_nz. destruct n_nz; [ induction p | subst p ];
  cbv [from_associational Let_In] in *; push; try
  pose proof place_in_range a (pred n); try lia; try nsatz;
  apply fold_right_invariant; cbv [zeros add_to_nth];
  intros; rewrite ?map_length, ?List.repeat_length, ?seq_length, ?length_update_nth;
  destruct n; cbn [pred] in *; try lia.                     Qed.
  Hint Rewrite @eval_from_associational : push_eval.
  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.

  Definition extend_to_length (n_in n_out : nat) (p:list Z) : list Z :=
    p ++ zeros (n_out - n_in).
  Lemma eval_extend_to_length n_in n_out p :
    length p = n_in -> (n_in <= n_out)%nat ->
    eval n_out (extend_to_length n_in n_out p) = eval n_in p.
  Proof using Type.
    cbv [eval extend_to_length to_associational]; intros.
    replace (seq 0 n_out) with (seq 0 (n_in + (n_out - n_in))) by (f_equal; lia).
    rewrite seq_add, map_app, combine_app_samelength, Associational.eval_app;
      push; lia.
  Qed.
  Hint Rewrite eval_extend_to_length : push_eval.
  Lemma length_extend_to_length n_in n_out p :
    length p = n_in -> (n_in <= n_out)%nat ->
    length (extend_to_length n_in n_out p) = n_out.
  Proof using Type. clear; cbv [extend_to_length]; intros; distr_length.        Qed.
  Hint Rewrite length_extend_to_length : distr_length.

  Definition drop_high_to_length (n : nat) (p:list Z) : list Z :=
    firstn n p.
  Lemma length_drop_high_to_length n p :
    length (drop_high_to_length n p) = Nat.min n (length p).
  Proof using Type. clear; cbv [drop_high_to_length]; intros; distr_length.        Qed.
  Hint Rewrite length_drop_high_to_length : distr_length.

  Section mulmod.
    Context (s:Z) (s_nz:s <> 0)
            (c:list (Z*Z))
            (m_nz:s - Associational.eval c <> 0).
    Definition mulmod (n:nat) (a b:list Z) : list Z
      := let a_a := to_associational n a in
         let b_a := to_associational n b in
         let ab_a := Associational.mul a_a b_a in
         let abm_a := Associational.repeat_reduce n s c ab_a in
         from_associational n abm_a.
    Lemma eval_mulmod n (f g:list Z)
          (Hf : length f = n) (Hg : length g = n) :
      eval n (mulmod n f g) mod (s - Associational.eval c)
      = (eval n f * eval n g) mod (s - Associational.eval c).
    Proof using m_nz s_nz weight_0 weight_nz. cbv [mulmod]; push; trivial.
    destruct f, g; simpl in *; [ right; subst n | left; try lia.. ].
    clear; cbv -[Associational.repeat_reduce].
    induction c as [|?? IHc]; simpl; trivial.                 Qed.

    Definition squaremod (n:nat) (a:list Z) : list Z
      := let a_a := to_associational n a in
         let aa_a := Associational.reduce_square s c a_a in
         let aam_a := Associational.repeat_reduce (pred n) s c aa_a in
         from_associational n aam_a.
    Lemma eval_squaremod n (f:list Z)
          (Hf : length f = n) :
      eval n (squaremod n f) mod (s - Associational.eval c)
      = (eval n f * eval n f) mod (s - Associational.eval c).
    Proof using m_nz s_nz weight_0 weight_nz. cbv [squaremod]; push; trivial.
    destruct f; simpl in *; [ right; subst n; reflexivity | left; try lia.. ]. Qed.
  End mulmod.
  Hint Rewrite @eval_mulmod @eval_squaremod : push_eval.

  Definition add (n:nat) (a b:list Z) : list Z
    := let a_a := to_associational n a in
       let b_a := to_associational n b in
       from_associational n (a_a ++ b_a).
  Lemma eval_add n (f g:list Z)
        (Hf : length f = n) (Hg : length g = n) :
    eval n (add n f g) = (eval n f + eval n g).
  Proof using weight_0 weight_nz. cbv [add]; push; trivial. destruct n; auto.          Qed.
  Hint Rewrite @eval_add : push_eval.
  Lemma length_add n f g
        (Hf : length f = n) (Hg : length g = n) :
    length (add n f g) = n.
  Proof using Type. clear -Hf Hf; cbv [add]; distr_length.               Qed.
  Hint Rewrite @length_add : distr_length.

  Section Carries.
    Definition carry n m (index:nat) (p:list Z) : list Z :=
      from_associational
        m (@Associational.carry (weight index)
                                (weight (S index) / weight index)
                                (to_associational n p)).

    Lemma length_carry n m index p : length (carry n m index p) = m.
    Proof using Type. cbv [carry]; distr_length. Qed.
    Hint Rewrite length_carry : distr_length.
    Lemma eval_carry n m i p: (n <> 0%nat) -> (m <> 0%nat) ->
                              weight (S i) / weight i <> 0 ->
      eval m (carry n m i p) = eval n p.
    Proof using weight_0 weight_nz.
      cbv [carry]; intros; push; [|tauto].
      rewrite @Associational.eval_carry by eauto.
      apply eval_to_associational.
    Qed. Hint Rewrite @eval_carry : push_eval.

    Definition carry_reduce n (s:Z) (c:list (Z * Z))
               (index:nat) (p : list Z) :=
      from_associational
        n (Associational.reduce
             s c (to_associational (S n) (@carry n (S n) index p))).

    Lemma eval_carry_reduce n s c index p :
      (s <> 0) -> (s - Associational.eval c <> 0) -> (n <> 0%nat) ->
      (weight (S index) / weight index <> 0) ->
      eval n (carry_reduce n s c index p) mod (s - Associational.eval c)
      = eval n p mod (s - Associational.eval c).
    Proof using weight_0 weight_nz. cbv [carry_reduce]; intros; push; auto.            Qed.
    Hint Rewrite @eval_carry_reduce : push_eval.
    Lemma length_carry_reduce n s c index p
      : length p = n -> length (carry_reduce n s c index p) = n.
    Proof using Type. cbv [carry_reduce]; distr_length.                  Qed.
    Hint Rewrite @length_carry_reduce : distr_length.

    (* N.B. It is important to reverse [idxs] here, because fold_right is
      written such that the first terms in the list are actually used
      last in the computation. For example, running:

      `Eval cbv - [Z.add] in (fun a b c d => fold_right Z.add d [a;b;c]).`

      will produce [fun a b c d => (a + (b + (c + d)))].*)
    Definition chained_carries n s c p (idxs : list nat) :=
      fold_right (fun a b => carry_reduce n s c a b) p (rev idxs).

    Lemma eval_chained_carries n s c p idxs :
      (s <> 0) -> (s - Associational.eval c <> 0) -> (n <> 0%nat) ->
      (forall i, In i idxs -> weight (S i) / weight i <> 0) ->
      eval n (chained_carries n s c p idxs) mod (s - Associational.eval c)
      = eval n p mod (s - Associational.eval c).
    Proof using Type*.
      cbv [chained_carries]; intros; push.
      apply fold_right_invariant; [|intro; rewrite <-in_rev];
        destruct n; intros; push; auto.
    Qed. Hint Rewrite @eval_chained_carries : push_eval.
    Lemma length_chained_carries n s c p idxs
      : length p = n -> length (@chained_carries n s c p idxs) = n.
    Proof using Type.
      intros; cbv [chained_carries]; induction (rev idxs) as [|x xs IHxs];
        cbn [fold_right]; distr_length.
    Qed. Hint Rewrite @length_chained_carries : distr_length.

    (* Reverse of [eval]; translate from Z to basesystem by putting
    everything in first digit and then carrying. *)
    Definition encode n s c (x : Z) : list Z :=
      chained_carries n s c (from_associational n [(1,x)]) (seq 0 n).
    Lemma eval_encode n s c x :
      (s <> 0) -> (s - Associational.eval c <> 0) -> (n <> 0%nat) ->
      (forall i, In i (seq 0 n) -> weight (S i) / weight i <> 0) ->
      eval n (encode n s c x) mod (s - Associational.eval c)
      = x mod (s - Associational.eval c).
    Proof using Type*. cbv [encode]; intros; push; auto; f_equal; lia. Qed.
    Lemma length_encode n s c x
      : length (encode n s c x) = n.
    Proof using Type. cbv [encode]; repeat distr_length.                 Qed.
  End Carries.
  Hint Rewrite @eval_encode @eval_carry @eval_carry_reduce @eval_chained_carries : push_eval.
  Hint Rewrite @length_encode @length_carry @length_carry_reduce @length_chained_carries : distr_length.

  Section sub.
    Context (n:nat)
            (s:Z) (s_nz:s <> 0)
            (c:list (Z * Z))
            (m_nz:s - Associational.eval c <> 0)
            (balance:list Z)
            (length_balance:length balance = n)
            (eval_balance:eval n balance mod (s - Associational.eval c) = 0).

    Definition negate_snd (a:list Z) : list Z
      := let A := to_associational n a in
         let negA := Associational.negate_snd A in
         from_associational n negA.

    Definition scmul (x:Z) (a:list Z) : list Z
      := let A := to_associational n a in
         let R := Associational.mul A [(1, x)] in
         from_associational n R.

    Definition sub (a b:list Z) : list Z
      := let ca := add n balance a in
         let _b := negate_snd b in
         add n ca _b.

    Lemma length_scmul x a : length (scmul x a) = n.
    Proof using Type. cbv [scmul]; now push. Qed.
    Hint Rewrite length_scmul : distr_length.

    Lemma eval_scmul x a : eval n (scmul x a) = x * eval n a.
    Proof using weight_0 weight_nz.
      clear -weight_0 weight_nz.
      destruct (zerop n) as [->|]; [ cbn; lia | ].
      cbv [scmul]; push; try lia.
    Qed.
    Hint Rewrite eval_scmul : push_eval.

    Hint Rewrite eval_balance : push_eval.
    Lemma eval_sub a b
      : (forall i, In i (seq 0 n) -> weight (S i) / weight i <> 0) ->
        (List.length a = n) -> (List.length b = n) ->
        eval n (sub a b) mod (s - Associational.eval c)
        = (eval n a - eval n b) mod (s - Associational.eval c).
    Proof using s_nz m_nz weight_0 weight_nz eval_balance length_balance.
      destruct (zerop n) as [->|]; try reflexivity.
      intros; cbv [sub negate_snd]; push; repeat distr_length;
        eauto with lia.
      push_Zmod; push; pull_Zmod; push_Zmod; pull_Zmod; distr_length; eauto.
    Qed.
    Hint Rewrite eval_sub : push_eval.
    Lemma length_sub a b
      : length a = n -> length b = n ->
        length (sub a b) = n.
    Proof using length_balance. intros; cbv [sub scmul negate_snd]; repeat distr_length. Qed.
    Hint Rewrite length_sub : distr_length.
    Definition opp (a:list Z) : list Z
      := sub (zeros n) a.
    Lemma eval_opp
          (a:list Z)
      : (length a = n) ->
        (forall i, In i (seq 0 n) -> weight (S i) / weight i <> 0) ->
        eval n (opp a) mod (s - Associational.eval c)
        = (- eval n a) mod (s - Associational.eval c).
    Proof using m_nz s_nz weight_0 weight_nz eval_balance length_balance. intros; cbv [opp]; push; distr_length; auto.       Qed.
    Lemma length_opp a
      : length a = n -> length (opp a) = n.
    Proof using length_balance. cbv [opp]; intros; repeat distr_length.            Qed.
  End sub.
  Hint Rewrite @eval_scmul @eval_opp @eval_sub : push_eval.
  Hint Rewrite @length_scmul @length_sub @length_opp : distr_length.

  Section select.
    Definition zselect (mask cond:Z) (p:list Z) :=
      dlet t := Z.zselect cond 0 mask in List.map (Z.land t) p.

    Definition select (cond:Z) (if_zero if_nonzero:list Z) :=
      List.map (fun '(p, q) => Z.zselect cond p q) (List.combine if_zero if_nonzero).

    Lemma map_and_0 n (p:list Z) : length p = n -> map (Z.land 0) p = zeros n.
    Proof using Type.
      intro; subst; induction p as [|x xs IHxs]; [reflexivity | ].
      cbn; f_equal; auto.
    Qed.
    Lemma eval_zselect n mask cond p (H:List.map (Z.land mask) p = p) :
      length p = n
      -> eval n (zselect mask cond p) =
         if dec (cond = 0) then 0 else eval n p.
    Proof using Type.
      cbv [zselect Let_In].
      rewrite Z.zselect_correct; break_match.
      { intros; erewrite map_and_0 by eassumption. apply eval_zeros. }
      { rewrite H; reflexivity. }
    Qed.
    Lemma length_zselect mask cond p :
      length (zselect mask cond p) = length p.
    Proof using Type. clear dependent weight. cbv [zselect Let_In]; break_match; intros; distr_length. Qed.

    (** We need an explicit equality proof here, because sometimes it
        matters that we retain the same bounds when selecting.  The
        alternative (weaker) lemma is [eval_select], where we only
        talk about equality under [eval]. *)
    Lemma select_eq cond n : forall p q,
        length p = n -> length q = n ->
        select cond p q = if dec (cond = 0) then p else q.
    Proof using weight.
      cbv [select]; induction n; intros;
        destruct p; distr_length;
          destruct q; distr_length;
        repeat match goal with
               | _ => progress autorewrite with push_combine push_map
               | _ => rewrite IHn by distr_length
               | _ => rewrite Z.zselect_correct
               | _ => break_match; reflexivity
               end.
    Qed.
    Lemma eval_select n cond p q :
      length p = n -> length q = n
      -> eval n (select cond p q) =
         if dec (cond = 0) then eval n p else eval n q.
    Proof using weight.
      intros; erewrite select_eq by eauto.
      break_match; reflexivity.
    Qed.
    Lemma length_select_min cond p q :
      length (select cond p q) = Nat.min (length p) (length q).
    Proof using Type. clear dependent weight. cbv [select Let_In]; distr_length. Qed.
    Hint Rewrite length_select_min : distr_length.
    Lemma length_select n cond p q :
      length p = n -> length q = n ->
      length (select cond p q) = n.
    Proof using Type. clear dependent weight. distr_length; lia **. Qed.

    Lemma select_push cond a b f (H : length a = length b) :
      f (select cond a b) = Z.zselect cond (f a) (f b).
    Proof using Type. unfold select, Z.zselect.
                      destruct (Z.eqb_spec cond 0); subst; simpl.
                      - rewrite (map_ext _ fst), ListUtil.map_fst_combine, <- H, firstn_all; reflexivity.
                      - rewrite (map_ext _ snd), ListUtil.map_snd_combine, H, firstn_all; reflexivity. Qed.
  End select.
End Positional.
(* Hint Rewrite disappears after the end of a section *)
#[global]
Hint Rewrite length_zeros length_add_to_nth length_from_associational @length_add @length_carry_reduce @length_carry @length_chained_carries @length_encode @length_scmul @length_sub @length_opp @length_select @length_zselect @length_select_min @length_extend_to_length @length_drop_high_to_length : distr_length.
#[global]
Hint Rewrite @eval_zeros @eval_nil @eval_snoc_S @eval_select @eval_zselect @eval_extend_to_length using solve [auto; distr_length]: push_eval.
Section Positional_nonuniform.
  Context (weight weight' : nat -> Z).

  Lemma eval_hd_tl n (xs:list Z) :
    length xs = n ->
    eval weight n xs = weight 0%nat * hd 0 xs + eval (fun i => weight (S i)) (pred n) (tl xs).
  Proof using Type.
    intro; subst; destruct xs as [|x xs]; [ cbn; lia | ].
    cbv [eval to_associational Associational.eval] in *; cbn.
    rewrite <- map_S_seq; reflexivity.
  Qed.

  Lemma eval_cons n (x:Z) (xs:list Z) :
    length xs = n ->
    eval weight (S n) (x::xs) = weight 0%nat * x + eval (fun i => weight (S i)) n xs.
  Proof using Type. intro; subst; apply eval_hd_tl; reflexivity. Qed.

  Lemma eval_weight_mul n p k :
    (forall i, In i (seq 0 n) -> weight i = k * weight' i) ->
    eval weight n p = k * eval weight' n p.
  Proof using Type.
    setoid_rewrite List.in_seq.
    revert n weight weight'; induction p as [|x xs IHxs], n as [|n]; intros weight weight' Hwt;
      cbv [eval to_associational Associational.eval] in *; cbn in *; try lia.
    rewrite Hwt, Z.mul_add_distr_l, Z.mul_assoc by lia.
    erewrite <- !map_S_seq, IHxs; [ reflexivity | ]; cbn; eauto with lia.
  Qed.
End Positional_nonuniform.
#[global]
Hint Rewrite @eval_cons using solve [auto; distr_length]: push_eval.
End Positional.

Record weight_properties {weight : nat -> Z} :=
  {
    weight_0 : weight 0%nat = 1;
    weight_positive : forall i, 0 < weight i;
    weight_multiples : forall i, weight (S i) mod weight i = 0;
    weight_divides : forall i : nat, 0 < weight (S i) / weight i;
  }.
Global Hint Resolve weight_0 weight_positive weight_multiples weight_divides : core.
#[global]
Hint Rewrite @weight_0 @weight_multiples using solve [auto]: push_eval.
Lemma weight_nz {weight : nat -> Z} {wprops : @weight_properties weight}
  : forall i, weight i <> 0.
Proof. intro i; pose proof (@weight_positive _ wprops i); lia. Qed.
Global Hint Resolve weight_nz : core.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.

Lemma eq_then_Permutation: forall{A:Type} (l1 l2:list A), l1 = l2 -> Permutation l1 l2.
Proof.
intros A l1 l2 H.
rewrite H; reflexivity.
Qed.

Lemma app_compat_perm_latter(A:Type) : forall l a1 a2:list A, Permutation a1 a2 -> Permutation (l++a1) (l++a2).
Proof.
intros l a1 a2 Ha.
induction l.
- exact Ha.
- apply perm_skip,IHl.
Qed.

Instance app_compat_perm(A:Type) : Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A).
Proof.
unfold Proper,respectful.
intros a1 a2 Ha b1 b2 Hb.
induction Ha.
- exact Hb.
- apply perm_skip.
  exact IHHa.
- apply perm_trans with ((x::y::l)++b1).
  + apply perm_swap.
  + apply perm_skip,perm_skip,app_compat_perm_latter,Hb.
- apply perm_trans with (l'++b2); [exact IHHa1|].
  apply perm_trans with (l'++b1); [|exact IHHa2].
  apply app_compat_perm_latter,Permutation_sym,Hb.
Qed.

Lemma Permutation_In_In: forall{A:Type} (x:A) (l1 l2:list A), Permutation l1 l2 -> In x l1 -> In x l2.
Proof.
intros A x l1 l2 HP H.
induction HP.
- exact H.
- destruct H as [H|H].
  + left.
    exact H.
  + right.
    apply IHHP,H.
- destruct H as [H|[H|H]].
  + right.
    left.
    exact H.
  + left.
    exact H.
  + right.
    right.
    exact H.
- apply IHHP2,IHHP1,H.
Qed.

Instance In_compat_perm(A:Type):
    Proper (eq ==> @Permutation A ==> iff) (@In A).
Proof.
unfold Proper,respectful.
intros x1 x2 Hx l1 l2 Hl.
rewrite Hx; clear x1 Hx.
split.
- apply Permutation_In_In,Hl.
- apply Permutation_In_In.
  symmetry.
  exact Hl.
Qed.

Instance length_compat_perm(A:Type):
    Proper (@Permutation A ==> eq) (@length A).
Proof.
unfold Proper, respectful.
intros LA LB HL.
apply Permutation_length,HL.
Qed.

Lemma app_normalize_1:
  forall(A:Type) (l1 l2 l3:list A),
    (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
intros A l1 l2 l3.
rewrite app_assoc.
reflexivity.
Qed.

Lemma app_normalize_2:
  forall(A:Type) (a1:A) (l2 l3:list A),
    (a1 :: l2) ++ l3 = a1 :: (l2 ++ l3).
Proof.
intros; reflexivity.
Qed.

Lemma app_normalize_3:
  forall(A:Type) (l1:list A), (nil++l1) = l1.
Proof.
intros; reflexivity.
Qed.

Ltac app_normalize := repeat (
  rewrite app_normalize_1 ||
  rewrite app_normalize_2 ||
  rewrite app_normalize_3).

Lemma perm_takeit_1:
  forall(A:Type) (target:list A) (l1 l2:list A),
    Permutation (l1 ++ (target ++ l2)) (target ++ (l1 ++ l2)).
Proof.
intros A target l1 l2.
rewrite (app_assoc l1 target l2),
  (Permutation_app_comm l1 target),
  <-(app_assoc target l1 l2).
reflexivity.
Qed.

Lemma perm_takeit_2:
  forall(A:Type) (target:list A) (a1:A) (l2:list A),
    Permutation (a1 :: (target ++ l2)) (target ++ (a1 :: l2)).
Proof.
intros A target a1 l2.
apply (perm_takeit_1 _ _ (a1::nil)).
Qed.

Lemma perm_takeit_3:
  forall(A:Type) (target:list A) (l1:list A),
    Permutation (l1 ++ target) (target ++ l1).
Proof.
intros A target l1.
apply Permutation_app_comm.
Qed.

Lemma perm_takeit_4:
  forall(A:Type) (target:list A) (a1:A),
    Permutation (a1 :: target) (target ++ (a1::nil)).
Proof.
intros A target a1.
apply (perm_takeit_3 _ _ (a1::nil)).
Qed.

Lemma perm_takeit_5:
  forall(A:Type) (target:A) (l1 l2:list A),
    Permutation (l1 ++ (target :: l2)) (target :: (l1 ++ l2)).
Proof.
intros A target l1 l2.
apply (perm_takeit_1 _ (target::nil)).
Qed.

Lemma perm_takeit_6:
  forall(A:Type) (target:A) (a1:A) (l2:list A),
    Permutation (a1 :: (target :: l2)) (target :: (a1 :: l2)).
Proof.
intros A target a1 l2.
apply (perm_takeit_2 _ (target::nil)).
Qed.

Lemma perm_takeit_7:
  forall(A:Type) (target:A) (l1:list A),
    Permutation (l1 ++ (target::nil)) (target :: l1).
Proof.
intros A target l1.
apply (perm_takeit_3 _ (target::nil)).
Qed.

Lemma perm_takeit_8:
  forall(A:Type) (target:A) (a1:A),
    Permutation (a1 :: (target::nil)) (target :: (a1::nil)).
Proof.
intros A target a1.
apply (perm_takeit_4 _ (target::nil)).
Qed.

Ltac perm_simplify := app_normalize; repeat (
  rewrite app_nil_r ||
  match goal with
  | [ |- Permutation ?L1 ?L1 ] => reflexivity
  | [ |- Permutation (?A1++_) (?A1++_) ] => apply Permutation_app_head
  | [ |- Permutation (?A1::_) (?A1::_) ] => apply perm_skip
  | [ |- Permutation _ (?L1++_) ] => (
      rewrite (perm_takeit_1 _ L1) at 1 ||
      rewrite (perm_takeit_2 _ L1) at 1 ||
      rewrite (perm_takeit_3 _ L1) at 1 ||
      rewrite (perm_takeit_4 _ L1) at 1 )
  | [ |- Permutation _ (?A1::_) ] => (
      rewrite (perm_takeit_5 _ A1) at 1 ||
      rewrite (perm_takeit_6 _ A1) at 1 ||
      rewrite (perm_takeit_7 _ A1) at 1 ||
      rewrite (perm_takeit_8 _ A1) at 1 )
  | [ |- Permutation _ _ ] => fail
  end).

Ltac perm :=
  match goal with
  | [ |- Permutation _ _ ] => perm_simplify; fail "perm failed"
  | [ |- _ ] => fail "perm can't solve this system."
  end.

Lemma PProp_perm_select:
  forall(A:Type) (P1 P2:A) (L1 L2:list A),
    Permutation (P1::L1) (P2::L2) ->
      (
        P1 = P2 /\ Permutation L1 L2
      ) \/ (
        exists L2',
          Permutation L2 (P1::L2') /\
          Permutation L1 (P2::L2')
      ).
Proof.
intros A P1 P2 L1 L2 HP.
assert (HI:=in_eq P1 L1).
rewrite HP in HI.
destruct HI as [HI|HI].
- left.
  split.
  + symmetry.
    exact HI.
  + rewrite HI in HP.
    apply Permutation_cons_inv in HP.
    exact HP.
- right.
  destruct (in_split _ _ HI) as (L2A,(L2B,HL2)).
  exists (L2A++L2B).
  split.
  + rewrite HL2.
    perm.
  + apply Permutation_cons_inv with (a:=P1).
    rewrite HP.
    rewrite HL2.
    perm.
Qed.


Require Import Coinduc.

Require Import Classical.

Lemma Not_Infinite_Finite :
  forall (A:Set) (l:LList A),
   ~ Infinite l -> Finite l.
Proof.
  intros A l H.
  case (classic (Finite l)).
  trivial.
  intro; elim H ; apply Not_Finite_Infinite ; trivial.
Qed.

Lemma Finite_or_Infinite :
  forall (A:Set)(l:LList A), Finite l \/ Infinite l.
Proof.
  intros A l; case (classic (Finite l)).
  auto.
  right; apply Not_Finite_Infinite ; trivial.
Qed.


Require Import HoTT HitTactics.
Require Import Circ.
(* This is a non-truncated definition of a free monoid *)
(* In this file we will prove that this construction does not give rise to a h-set. *)
Section monoid.
Variable A : Type.

Private Inductive M : Type :=
| el : A -> M
| e  : M
| op : M -> M -> M.

Infix "+" := op. (* left assoc *)
Notation "0" := e.
Coercion el : A >-> M.

Axiom assoc : forall (a b c : M),
 (a + b) + c = a + (b + c).
Axiom ident_l : forall (a : M),
  0 + a = a.
Axiom ident_r : forall (a : M),
  a + 0 = a.

Fixpoint M_ind
  (Y : M -> Type)
  (AY : forall a : A, Y (el a))
  (eY : Y 0)
  (opY : forall x y : M, Y x -> Y y -> Y (x + y))
  (opY_assoc : forall x y z : M, forall (xY : Y x) (yY : Y y) (zY : Y z),
      assoc x y z # opY _ _ (opY _ _ xY yY) zY = opY _ _ xY (opY _ _ yY zY))
  (opY_ident_l : forall (x : M) (xY : Y x),
      ident_l x # opY _ _ eY xY = xY)
  (opY_ident_r : forall (x : M) (xY : Y x),
      ident_r x # opY _ _ xY eY = xY)
  (x : M)
  {struct x}
  : Y x :=
  (match x return _ -> _ -> _ -> Y x with
    | el a => fun _ _ _ => AY a
    | e    => fun _ _ _ => eY
    | e1 + e2 => fun _ _ _ =>
       opY e1 e2 (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r e1)
                 (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r e2)
  end) opY_assoc opY_ident_l opY_ident_r.

Axiom M_ind_beta_assoc : forall
  (Y : M -> Type)
  (AY : forall a : A, Y (el a))
  (eY : Y 0)
  (opY : forall x y : M, Y x -> Y y -> Y (x + y))
  (opY_assoc : forall x y z : M, forall (xY : Y x) (yY : Y y) (zY : Y z),
      assoc x y z # opY _ _ (opY _ _ xY yY) zY = opY _ _ xY (opY _ _ yY zY))
  (opY_ident_l : forall (x : M) (xY : Y x),
      ident_l x # opY _ _ eY xY = xY)
  (opY_ident_r : forall (x : M) (xY : Y x),
      ident_r x # opY _ _ xY eY = xY)
  (x y z : M),
  apD (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r) (assoc x y z)
  = opY_assoc x y z (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r x)
                    (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r y)
                    (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r z).

Axiom M_ind_beta_ident_l : forall
  (Y : M -> Type)
  (AY : forall a : A, Y (el a))
  (eY : Y 0)
  (opY : forall x y : M, Y x -> Y y -> Y (x + y))
  (opY_assoc : forall x y z : M, forall (xY : Y x) (yY : Y y) (zY : Y z),
      assoc x y z # opY _ _ (opY _ _ xY yY) zY = opY _ _ xY (opY _ _ yY zY))
  (opY_ident_l : forall (x : M) (xY : Y x),
      ident_l x # opY _ _ eY xY = xY)
  (opY_ident_r : forall (x : M) (xY : Y x),
      ident_r x # opY _ _ xY eY = xY)
  (x : M),
  apD (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r) (ident_l x)
  = opY_ident_l x (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r x).

Axiom M_ind_beta_ident_r : forall
  (Y : M -> Type)
  (AY : forall a : A, Y (el a))
  (eY : Y 0)
  (opY : forall x y : M, Y x -> Y y -> Y (x + y))
  (opY_assoc : forall x y z : M, forall (xY : Y x) (yY : Y y) (zY : Y z),
      assoc x y z # opY _ _ (opY _ _ xY yY) zY = opY _ _ xY (opY _ _ yY zY))
  (opY_ident_l : forall (x : M) (xY : Y x),
      ident_l x # opY _ _ eY xY = xY)
  (opY_ident_r : forall (x : M) (xY : Y x),
      ident_r x # opY _ _ xY eY = xY)
  (x : M),
  apD (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r) (ident_r x)
  = opY_ident_r x (M_ind Y AY eY opY opY_assoc opY_ident_l opY_ident_r x).

Definition M_rec
  (Y : Type)
  (AY : A -> Y)
  (eY : Y)
  (opY : Y -> Y -> Y)
  (opY_assoc : forall x y z : Y,
      opY (opY x y) z = opY x (opY y z))
  (opY_ident_l : forall (x : Y),
      opY eY x = x)
  (opY_ident_r : forall (x : Y),
      opY x eY = x)
  (x : M) : Y.
Proof.
simple refine (M_ind (fun _ => Y)
                AY
                eY
                (fun _ _ => opY) _ _ _ x); simpl.
- intros ??? a b c.
  etransitivity. apply transport_const. apply opY_assoc.
- intros ? a.
  etransitivity. apply transport_const. apply opY_ident_l.
- intros ? a.
  etransitivity. apply transport_const. apply opY_ident_r.
Defined.

Definition M_rec_beta_assoc : forall
  (Y : Type)
  (AY : A -> Y)
  (eY : Y)
  (opY : Y -> Y -> Y)
  (opY_assoc : forall x y z : Y,
      opY (opY x y) z = opY x (opY y z))
  (opY_ident_l : forall (x : Y),
      opY eY x = x)
  (opY_ident_r : forall (x : Y),
      opY x eY = x)
  (x y z : M),
  ap (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r) (assoc x y z)
  = opY_assoc (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r x)
              (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r y)
              (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r z).
Proof.
  intros.
  eapply (cancelL (transport_const _ _)).
  etransitivity. symmetry.
   apply apD_const.
  unfold M_rec. simpl.
  change (fun x0 : M =>
   M_ind (fun _ : M => Y) AY eY (fun _ _ : M => opY)
     (fun (x1 y0 z0 : M) (a b c : Y) =>
      transport_const (assoc x1 y0 z0) (opY (opY a b) c) @ opY_assoc a b c)
     (fun (x1 : M) (a : Y) =>
      transport_const (ident_l x1) (opY eY a) @ opY_ident_l a)
     (fun (x1 : M) (a : Y) =>
      transport_const (ident_r x1) (opY a eY) @ opY_ident_r a) x0)
  with (M_ind (fun _ : M => Y) AY eY (fun _ _ : M => opY)
     (fun (x1 y0 z0 : M) (a b c : Y) =>
      transport_const (assoc x1 y0 z0) (opY (opY a b) c) @ opY_assoc a b c)
     (fun (x1 : M) (a : Y) =>
      transport_const (ident_l x1) (opY eY a) @ opY_ident_l a)
     (fun (x1 : M) (a : Y) =>
      transport_const (ident_r x1) (opY a eY) @ opY_ident_r a)).
  rewrite M_ind_beta_assoc. reflexivity.
Qed.

Definition M_rec_beta_ident_l : forall
  (Y : Type)
  (AY : A -> Y)
  (eY : Y)
  (opY : Y -> Y -> Y)
  (opY_assoc : forall x y z : Y,
      opY (opY x y) z = opY x (opY y z))
  (opY_ident_l : forall (x : Y),
      opY eY x = x)
  (opY_ident_r : forall (x : Y),
      opY x eY = x)
  (x : M),
  ap (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r) (ident_l x)
  = opY_ident_l (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r x).
Proof.
  intros.
  eapply (cancelL (transport_const _ _)).
  etransitivity. symmetry.
   apply apD_const.
  unfold M_rec. simpl.
  rewrite M_ind_beta_ident_l. reflexivity.
Qed.

Definition M_rec_beta_ident_r : forall
  (Y : Type)
  (AY : A -> Y)
  (eY : Y)
  (opY : Y -> Y -> Y)
  (opY_assoc : forall x y z : Y,
      opY (opY x y) z = opY x (opY y z))
  (opY_ident_l : forall (x : Y),
      opY eY x = x)
  (opY_ident_r : forall (x : Y),
      opY x eY = x)
  (x : M),
  ap (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r) (ident_r x)
  = opY_ident_r (M_rec Y AY eY opY opY_assoc opY_ident_l opY_ident_r x).
Proof.
  intros.
  eapply (cancelL (transport_const _ _)).
  etransitivity. symmetry.
   apply apD_const.
  unfold M_rec. simpl.
  rewrite M_ind_beta_ident_r. reflexivity.
Qed.

End monoid.

Arguments op {_} x y.
Arguments el {_} a.
Arguments e {_}.
Infix "⊡" := op (at level 80).

Instance M_recursion A : HitRecursion (M A) := {
  indTy := _; recTy := _;
  H_inductor := (M_ind A); H_recursor := (M_rec A) }.

(* (M A) is not an h-set by recursion into S1 *)
Section monoid_sphere.
Context `{UAxiom : Univalence}.
Variable A : Type.

Definition f (x : S1) : x = x.
Proof.
hinduction x.
- exact loop.
- etransitivity.
  eapply (@transport_paths_FlFr S1 S1 idmap idmap).
  hott_simpl.
Defined.

Definition S1op (x y : S1) : S1.
Proof.
hrecursion y.
- exact x. (* x + base = x *)
- apply f.
Defined.

Lemma S1op_nr (x : S1) : S1op x base = x.
Proof. reflexivity. Defined.

Lemma S1op_nl (x : S1) : S1op base x = x.
Proof.
hrecursion x.
- exact loop.
- etransitivity.
  apply (@transport_paths_FlFr _ _ (fun x => S1op base x) idmap _ _ loop loop).
  hott_simpl.
  apply moveR_pM. apply moveR_pM. hott_simpl.
  etransitivity. apply (ap_V (S1op base) loop).
  f_ap. apply S1_rec_beta_loop.
Defined.

Lemma S1op_assoc (x y z : S1) : S1op x (S1op y z) = S1op (S1op x y) z.
Proof.
hrecursion z.
- reflexivity.
- etransitivity.
  apply (@transport_paths_FlFr _ _ (fun z => S1op x (S1op y z)) (S1op (S1op x y)) _ _ loop idpath).
  hott_simpl.
  apply moveR_Mp. hott_simpl.
  rewrite S1_rec_beta_loop.
  rewrite ap_compose.
  rewrite S1_rec_beta_loop.
  hrecursion y.
  + symmetry. apply S1_rec_beta_loop.
  + apply is1type_S1.
Defined.

Definition M_to_S : M A -> S1.
Proof.
hrecursion.
- intro a. apply base.
- exact base.
- exact S1op.
- intros. symmetry. apply S1op_assoc.
- apply S1op_nl.
- apply S1op_nr.
Defined.

Lemma M_S_ap : (ident_l A e) = (ident_r A e) -> idpath = loop.
Proof.
intros H.
enough (ap M_to_S (ident_l A e) = ap M_to_S (ident_r A e)) as H'.
- rewrite M_rec_beta_ident_l in H'.
  simpl in H'.
  rewrite M_rec_beta_ident_r in H'.
  unfold S1op_nr in H'.
  exact H'^.
- f_ap.
Defined.

Lemma M_not_hset : IsHSet (M A) -> False.
Proof.
intros H.
enough (idpath = loop).
- assert (S1_encode _ idpath = S1_encode _ (loopexp loop (pos Int.one))) as H' by f_ap.
  rewrite S1_encode_loopexp in H'. simpl in H'. symmetry in H'.
  apply (pos_neq_zero H').
- apply M_S_ap.
  apply set_path2.
Defined.

End monoid_sphere.


From Coq Require Import ZArith Reals Psatz.
From mathcomp Require Import all_ssreflect ssralg
              ssrnat all_algebra seq matrix.
From mathcomp.analysis Require Import Rstruct.
Import List ListNotations.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import lemmas.

Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Fixpoint vec_to_list_real {n:nat} (m:nat) (v :'cV[R]_n.+1)
   : list R :=
   match m with
   | O => []
   | S p => [v (@inord n p) ord0] ++ vec_to_list_real p v
   end.

Definition A1_diag {n: nat} (A: 'M[R]_n.+1) : 'cV[R]_n.+1:=
  \col_i (1 / (A i i))%Re.

Definition diag_matrix_vec_mult_R {n:nat} (v1 v2 : 'cV[R]_n.+1)
  : 'cV[R]_n.+1 :=
  \col_i ((nth (n.+1.-1 -i) (vec_to_list_real n.+1 v1) 0%Re) *
          (nth (n.+1.-1 -i) (vec_to_list_real n.+1 v2) 0%Re)).

Lemma nth_vec_to_list_real_sub {n:nat} i m (v1 v2 :'cV[R]_n.+1) d:
  (i < m)%nat ->
  nth (m.-1 -i) (@vec_to_list_real n m (v1 - v2)) d =
  nth (m.-1 -i) (@vec_to_list_real n m v1) d -
  nth (m.-1 -i) (@vec_to_list_real n m v2) d.
Proof.
intros.
induction m.
+ by rewrite ltn0 in H.
+ simpl. rewrite -subn_gt0 in IHm. rewrite -predn_sub in IHm.
  destruct (m-i)%nat.
  - by rewrite !mxE /=.
  - simpl in IHm. by apply IHm.
Qed.

Lemma diag_matrix_vec_mult_diff {n:nat} (v1 v2 v3 : 'cV[R]_n.+1):
  diag_matrix_vec_mult_R v1 v2 - diag_matrix_vec_mult_R v1 v3 =
  diag_matrix_vec_mult_R v1 (v2 - v3).
Proof.
apply /matrixP. unfold eqrel. intros. rewrite !mxE.
rewrite nth_vec_to_list_real_sub.
+ rewrite -!RmultE -!RminusE. field_simplify. auto.
+ apply ltn_ord.
Qed.

Lemma diag_matrix_vec_mult_diff_r {n:nat} (v1 v2 v3 : 'cV[R]_n.+1):
  diag_matrix_vec_mult_R v1 v3 - diag_matrix_vec_mult_R v2 v3 =
  diag_matrix_vec_mult_R (v1 - v2) v3.
Proof.
apply /matrixP. unfold eqrel. intros. rewrite !mxE.
rewrite nth_vec_to_list_real_sub.
+ rewrite -!RmultE -!RminusE. field_simplify. auto.
+ apply ltn_ord.
Qed.

Lemma nth_vec_to_list_real {n:nat} i m (v :'cV[R]_n.+1) d:
  (i < m)%nat ->
  nth (m.-1 -i) (@vec_to_list_real n m v) d = v (@inord n i) ord0.
Proof.
intros.
elim: m i H => [ | m IHm] i H.
+ by [].
+ simpl.
  rewrite leq_eqVlt in H.
  assert ((i == m) \/ (i < m)%nat).
  { by apply /orP. } destruct H0.
  - assert (i = m). { by apply /eqP. }
    rewrite H1. simpl.
    assert ((m - m)%nat = 0%N).
    { apply /eqP. rewrite subn_eq0. by []. } by rewrite H2 /=.
  - assert (nth (m.-1 - i) (vec_to_list_real m v)
                d = v (inord i) ord0).
    { by apply IHm. }
    rewrite -H1. rewrite -[in RHS]predn_sub.
    rewrite -subn_gt0 in H0. rewrite -predn_sub in H1.
    by destruct (m - i)%nat.
Qed.

Definition A2_J_real {n:nat} (A: 'M[R]_n.+1):
  'M[R]_n.+1 :=
  \matrix_(i,j)
    if (i==j :> nat) then 0%Re else A i j.

(** Define real real functional model **)

Definition x_fix {n:nat} x b (A: 'M[R]_n.+1) :
  'cV[R]_n.+1 :=
  let r := b - ((A2_J_real A) *m x) in
  diag_matrix_vec_mult_R (A1_diag A) r.


Require Import init.

Require Import nat.
Require Import rat.
Require Import set.
Require Import nat_abstract.
Require Import int_abstract.
Require Import rat_abstract.

Record ArchOrderedField := make_arch_ordered {
    aof_set : (nat → Prop) → Prop;
    aof_plus : Plus (set_type aof_set);
    aof_zero : Zero (set_type aof_set);
    aof_neg : Neg (set_type aof_set);
    aof_plus_comm : @PlusComm (set_type aof_set) aof_plus;
    aof_plus_assoc : @PlusAssoc (set_type aof_set) aof_plus;
    aof_plus_lid : @PlusLid (set_type aof_set) aof_plus aof_zero;
    aof_plus_linv : @PlusLinv (set_type aof_set) aof_plus aof_zero aof_neg;

    aof_mult : Mult (set_type aof_set);
    aof_one : One (set_type aof_set);
    aof_div : Div (set_type aof_set);
    aof_mult_comm : @MultComm (set_type aof_set) aof_mult;
    aof_mult_assoc : @MultAssoc (set_type aof_set) aof_mult;
    aof_ldist : @Ldist (set_type aof_set) aof_plus aof_mult;
    aof_mult_lid : @MultLid (set_type aof_set) aof_mult aof_one;
    aof_mult_linv : @MultLinv (set_type aof_set) aof_zero aof_mult aof_one aof_div;

    aof_le : Order (set_type aof_set);
    aof_le_antisym : @Antisymmetric (set_type aof_set) le;
    aof_le_trans : @Transitive (set_type aof_set) le;
    aof_le_connex : @Connex (set_type aof_set) le;
    aof_le_lplus : @OrderLplus (set_type aof_set) aof_plus aof_le;
    aof_le_mult : @OrderMult (set_type aof_set) aof_zero aof_mult aof_le;

    aof_not_trivial : @NotTrivial (set_type aof_set);
    aof_arch : @Archimedean (set_type aof_set) aof_plus aof_zero aof_le;
}.

Section ArchOrderedField.

Variables (A B : ArchOrderedField).

Let U1 := aof_set A.
Let A_plus := aof_plus A.
Let A_zero := aof_zero A.
Let A_neg := aof_neg A.
Let A_plus_comm := aof_plus_comm A.
Let A_plus_assoc := aof_plus_assoc A.
Let A_plus_lid := aof_plus_lid A.
Let A_plus_linv := aof_plus_linv A.
Let A_mult := aof_mult A.
Let A_one := aof_one A.
Let A_div := aof_div A.
Let A_mult_comm := aof_mult_comm A.
Let A_mult_assoc := aof_mult_assoc A.
Let A_ldist := aof_ldist A.
Let A_mult_lid := aof_mult_lid A.
Let A_mult_linv := aof_mult_linv A.
Let A_le := aof_le A.
Let A_le_antisym := aof_le_antisym A.
Let A_le_trans := aof_le_trans A.
Let A_le_connex := aof_le_connex A.
Let A_le_lplus := aof_le_lplus A.
Let A_le_mult := aof_le_mult A.
Let A_not_trivial := aof_not_trivial A.
Let A_arch := aof_arch A.
Let U2 := aof_set B.
Let B_plus := aof_plus B.
Let B_zero := aof_zero B.
Let B_neg := aof_neg B.
Let B_plus_comm := aof_plus_comm B.
Let B_plus_assoc := aof_plus_assoc B.
Let B_plus_lid := aof_plus_lid B.
Let B_plus_linv := aof_plus_linv B.
Let B_mult := aof_mult B.
Let B_one := aof_one B.
Let B_div := aof_div B.
Let B_mult_comm := aof_mult_comm B.
Let B_mult_assoc := aof_mult_assoc B.
Let B_ldist := aof_ldist B.
Let B_mult_lid := aof_mult_lid B.
Let B_mult_linv := aof_mult_linv B.
Let B_le := aof_le B.
Let B_le_antisym := aof_le_antisym B.
Let B_le_trans := aof_le_trans B.
Let B_le_connex := aof_le_connex B.
Let B_le_lplus := aof_le_lplus B.
Let B_le_mult := aof_le_mult B.
Let B_not_trivial := aof_not_trivial B.
Let B_arch := aof_arch B.
Local Existing Instances A_plus A_zero A_neg A_plus_comm A_plus_assoc A_plus_lid
    A_plus_linv A_mult A_one A_div A_mult_comm A_mult_assoc A_ldist A_mult_lid
    A_mult_linv A_le A_le_antisym A_le_trans A_le_connex A_le_lplus A_le_mult
    A_not_trivial A_arch B_plus B_zero B_neg B_plus_comm B_plus_assoc B_plus_lid
    B_plus_linv B_mult B_one B_div B_mult_comm B_mult_assoc B_ldist B_mult_lid
    B_mult_linv B_le B_le_antisym B_le_trans B_le_connex B_le_lplus B_le_mult
    B_not_trivial B_arch.

Definition arch_ordered_homo (f : set_type (aof_set A) → set_type (aof_set B))
    :=
        f 0 = 0 ∧
        f 1 = 1 ∧
        (∀ a b, f (a + b) = f a + f b) ∧
        (∀ a b, f (a * b) = f a * f b) ∧
        (∀ a b, a ≤ b → f a ≤ f b).

Theorem arch_ordered_homo_neg : ∀ f, arch_ordered_homo f → ∀ x, f (-x) = -f x.
Proof.
    intros f f_homo x.
    pose proof f_homo as [f_zero [f_one [f_plus [f_mult f_le]]]].
    apply plus_lcancel with (f x).
    rewrite <- f_plus.
    do 2 rewrite plus_rinv.
    exact f_zero.
Qed.

Theorem arch_ordered_homo_inj : ∀ f, arch_ordered_homo f → Injective f.
Proof.
    intros f f_homo.
    split.
    intros a b eq.
    rewrite <- plus_0_anb_b_a.
    rewrite <- plus_0_anb_b_a in eq.
    rewrite <- (arch_ordered_homo_neg _ f_homo) in eq.
    pose proof f_homo as [f_zero [f_one [f_plus [f_mult f_le]]]].
    rewrite <- f_plus in eq.
    remember (b - a) as c.
    clear a b Heqc.
    classic_contradiction contr.
    apply lmult with (f (/c)) in eq.
    rewrite mult_ranni in eq.
    rewrite <- f_mult in eq.
    rewrite mult_linv in eq by exact contr.
    rewrite f_one in eq.
    apply not_trivial_one in eq.
    exact eq.
Qed.

Theorem arch_ordered_homo_le : ∀ f, arch_ordered_homo f →
    ∀ x y, x ≤ y ↔ f x ≤ f y.
Proof.
    intros f f_homo x y.
    split; [>apply f_homo|].
    intros leq.
    classic_contradiction contr.
    rewrite nle_lt in contr.
    destruct contr as [yx neq].
    apply f_homo in yx.
    pose proof (antisym leq yx) as eq.
    apply (arch_ordered_homo_inj _ f_homo) in eq.
    symmetry in eq.
    contradiction.
Qed.

Theorem arch_ordered_homo_lt : ∀ f, arch_ordered_homo f →
    ∀ x y, x < y ↔ f x < f y.
Proof.
    intros f f_homo x y.
    unfold strict.
    rewrite <- (arch_ordered_homo_le _ f_homo).
    split.
    -   intros [leq neq].
        split; [>exact leq|].
        intros eq.
        apply arch_ordered_homo_inj in eq; [>|exact f_homo].
        contradiction.
    -   intros [leq neq].
        split; [>exact leq|].
        intros eq.
        subst y.
        contradiction.
Qed.

Theorem arch_ordered_homo_div : ∀ f, arch_ordered_homo f →
    ∀ x, 0 ≠ x → f (/x) = /f x.
Proof.
    intros f f_homo x x_nz.
    pose proof f_homo as [f_zero [f_one [f_plus [f_mult f_le]]]].
    assert (0 ≠ f x) as fx_nz.
    {
        intros contr.
        rewrite <- f_zero in contr.
        apply arch_ordered_homo_inj in contr; [>|exact f_homo].
        contradiction.
    }
    apply mult_lcancel with (f x); [>exact fx_nz|].
    rewrite <- f_mult.
    rewrite mult_rinv by exact x_nz.
    rewrite mult_rinv by exact fx_nz.
    exact f_one.
Qed.

Theorem arch_ordered_homo_nat : ∀ f, arch_ordered_homo f →
    ∀ n, f (from_nat n) = from_nat n.
Proof.
    intros f f_homo n.
    pose proof f_homo as [f_zero [f_one [f_plus [f_mult f_le]]]].
    nat_induction n.
    -   setoid_rewrite homo_zero.
        exact f_zero.
    -   cbn.
        rewrite f_plus.
        rewrite f_one, IHn.
        reflexivity.
Qed.

Theorem arch_ordered_homo_int : ∀ f, arch_ordered_homo f →
    ∀ n, f (int_to_abstract n) = int_to_abstract n.
Proof.
    intros f f_homo n.
    pose proof f_homo as [f_zero [f_one [f_plus [f_mult f_le]]]].
    equiv_get_value n.
    destruct n as [m n].
    unfold int_to_abstract; equiv_simpl.
    unfold int_to_abstract_base; cbn.
    rewrite f_plus.
    rewrite arch_ordered_homo_neg by exact f_homo.
    do 2 rewrite arch_ordered_homo_nat by exact f_homo.
    reflexivity.
Qed.

Theorem arch_ordered_homo_rat : ∀ f, arch_ordered_homo f →
    ∀ q, f (rat_to_abstract q) = rat_to_abstract q.
Proof.
    intros f f_homo q.
    pose proof f_homo as [f_zero [f_one [f_plus [f_mult f_le]]]].
    equiv_get_value q.
    unfold rat_to_abstract; equiv_simpl.
    unfold rat_to_abstract_base; cbn.
    rewrite f_mult.
    rewrite arch_ordered_homo_div.
    2: exact f_homo.
    2: apply int_to_abstract_nz.
    do 2 rewrite arch_ordered_homo_int by exact f_homo.
    reflexivity.
Qed.

Theorem arch_ordered_homo_uni_wlog : ∀ f g,
    arch_ordered_homo f → arch_ordered_homo g →
    ∀ x, f x ≤ g x.
Proof.
    intros f g f_homo g_homo x.
    classic_contradiction ltq.
    rewrite nle_lt in ltq.
    pose proof (rat_dense_in_arch (g x) (f x) ltq) as [r [r_gt r_lt]].
    rewrite <- (arch_ordered_homo_rat g g_homo) in r_gt.
    rewrite <- (arch_ordered_homo_rat f f_homo) in r_lt.
    rewrite <- arch_ordered_homo_lt in r_gt by exact g_homo.
    rewrite <- arch_ordered_homo_lt in r_lt by exact f_homo.
    destruct (trans r_gt r_lt); contradiction.
Qed.
Theorem arch_ordered_homo_uni : ∀ f g,
    arch_ordered_homo f → arch_ordered_homo g → f = g.
Proof.
    intros f g f_homo g_homo.
    apply functional_ext.
    intros x.
    apply antisym; apply arch_ordered_homo_uni_wlog; assumption.
Qed.

Theorem arch_ordered_homo_eq : ∀ f g x,
    arch_ordered_homo f → arch_ordered_homo g → f x = g x.
Proof.
    intros f g x f_homo g_homo.
    rewrite (arch_ordered_homo_uni f g f_homo g_homo).
    reflexivity.
Qed.

End ArchOrderedField.

Arguments arch_ordered_homo_eq {A B}.

Theorem identity_arch_ordered_homo : ∀ A, arch_ordered_homo A A identity.
Proof.
    intros A.
    repeat split; intro; try assumption.
    intros b ab; exact ab.
Qed.

Theorem arch_ordered_homo_identity :
    ∀ A f, arch_ordered_homo A A f → f = identity.
Proof.
    intros A f f_homo.
    apply arch_ordered_homo_uni.
    -   exact f_homo.
    -   apply identity_arch_ordered_homo.
Qed.

Theorem arch_ordered_homo_compose :
    ∀ A B C f g, arch_ordered_homo A B f → arch_ordered_homo B C g →
    arch_ordered_homo A C (λ x, g (f x)).
Proof.
    intros A B C f g f_homo g_homo.
    destruct f_homo as [f_zero [f_one [f_plus [f_mult f_le]]]].
    destruct g_homo as [g_zero [g_one [g_plus [g_mult g_le]]]].
    split; [>|split; [>|split; [>|split]]].
    -   rewrite f_zero.
        exact g_zero.
    -   rewrite f_one.
        exact g_one.
    -   intros a b.
        rewrite f_plus.
        apply g_plus.
    -   intros a b.
        rewrite f_mult.
        apply g_mult.
    -   intros a b ab.
        apply g_le.
        apply f_le.
        exact ab.
Qed.

Global Instance arch_ordered_le : Order ArchOrderedField := {
    le A B := ∃ f, arch_ordered_homo A B f
}.
Global Program Instance arch_ordered_le_refl : Reflexive le.
Next Obligation.
    unfold le; cbn.
    exists identity.
    apply identity_arch_ordered_homo.
Qed.
Global Program Instance arch_ordered_le_trans : Transitive le.
Next Obligation.
    rename x into A, y into B, z into C, H into AB, H0 into BC.
    unfold le in *; cbn in *.
    destruct AB as [f f_homo].
    destruct BC as [g g_homo].
    exists (λ x, g (f x)).
    apply arch_ordered_homo_compose; assumption.
Qed.


Require Import List Omega SetoidClass Recdef.
Import ListNotations.

Require Import Class.

Fixpoint even n :=
  match n with
  | 0 => true
  | S m => negb (even m)
  end.

Lemma even_odd_half : forall n, (even n = true -> exists k, 2 * k = n) /\
  (even n = false -> exists k, S (2 * k) = n).
Proof.
  induction n; split; intros.
  - exists 0; auto.
  - discriminate.
  - simpl in H.
    destruct IHn.
    destruct H1 as [k Hk].
    + destruct (even n); [discriminate | auto].
    + exists (S k).
      omega.
  - destruct IHn.
    destruct H0 as [k Hk].
    + simpl in H.
      destruct (even n); [auto | discriminate].
    + exists k; omega.
Qed.

Lemma even_half : forall n, even n = true -> exists k, 2 * k = n.
Proof.
  intros; apply even_odd_half; auto.
Qed.

Lemma odd_half : forall n, even n = false -> exists k, S (2 * k) = n.
Proof.
  intros; apply even_odd_half; auto.
Qed.

Lemma even_2k : forall k, even (2 * k) = true.
Proof.
  induction k.
  - auto.
  - simpl; rewrite <- plus_n_Sm; simpl.
    simpl in IHk; rewrite IHk; auto.
Qed.

Lemma odd_2k1 : forall k, even (S (2 * k)) = false.
Proof.
  induction k.
  - auto.
  - simpl; rewrite <- plus_n_Sm.
    simpl; simpl in IHk.
    rewrite IHk; auto.
Qed.

Lemma half_2k : forall k, (2*k)/2 = k.
Proof.
  intro.
  rewrite Nat.mul_comm.
  rewrite Nat.div_mul; omega.
Qed.

Lemma half_2k1 : forall k, (S (2 * k))/2 = k.
Proof.
  intro.
  pose (Nat.add_b2n_double_div2 true).
  simpl Nat.b2n in e.
  apply e.
Qed.

Section Fin.

Fixpoint Fin(n : nat) : Type :=
  match n with
  | 0 => Empty_set
  | S m => unit + Fin m
  end.

Fixpoint Fin_le{n} : Fin n -> Fin n -> Prop :=
  match n with
  | 0 => fun i _ => match i with end
  | S m => fun i j => match i,j with
                      | inl _, inl _ => False
                      | inl _, inr _ => True
                      | inr _, inl _ => False
                      | inr i', inr j' => Fin_le i' j'
                      end
  end.

Lemma Fin_le_irref : forall (n : nat)(i : Fin n), ~ Fin_le i i.
Proof.
  induction n.
  - intros [].
  - destruct i as [[]|j].
    + tauto.
    + apply IHn.
Qed.

Lemma Fin_le_trans : forall (n : nat)(i j k : Fin n), Fin_le i j -> Fin_le j k -> Fin_le i k.
Proof.
  induction n; intros.
  - destruct i.
  - destruct i as [|i']; destruct k as [|k'].
    + destruct j; auto.
    + exact I.
    + destruct j; auto.
    + destruct j as [|j'].
      * destruct H.
      * apply (IHn _ j' _); auto.
Qed.

Lemma Fin_trich : forall (n : nat)(i j : Fin n), {i = j} + {Fin_le i j} + {Fin_le j i}.
Proof.
  induction n.
  - intros [].
  - intros [[]|i'] [[]|j'].
    + left; left; auto.
    + left; right; exact I.
    + right; exact I.
    + destruct (IHn i' j') as [[Heq|Hle]|Hge].
      * left; left; congruence.
      * left; right; exact Hle.
      * right; exact Hge.
Qed.

Fixpoint list_index{X}(xs : list X){struct xs} : Fin (length xs) -> X :=
  match xs return Fin (length xs) -> X with
  | [] => fun i => match i with end
  | y::ys => fun i => match i with
                      | inl _ => y
                      | inr j => list_index ys j
                      end
  end.

Lemma in_index : forall {X}`{Eq X}(xs : list X)(x : X), setoidIn x xs -> exists (i : Fin (length xs)),
  list_index xs i == x.
Proof.
  induction xs; intros.
  - destruct H1.
  - destruct H1.
    + exists (inl tt); simpl; symmetry; auto.
    + destruct (IHxs x H1) as [i Hi].
      exists (inr i); auto.
Qed.

End Fin.


Require Import Coq.Lists.List.
Import ListNotations.

Theorem silly1_using_apply : forall (n m o p : nat), n=m -> [n;o] = [n;p] -> [n;o] = [m;p].
Proof.
    intros.
    rewrite <- H.
    apply H0.
Qed.

Theorem silly1_using_rewrite : forall (n m o p : nat), n=m -> [n;o] = [n;p] -> [n;o] = [m;p].
Proof.
    intros.
    rewrite <- H.
    rewrite H0. reflexivity.
Qed.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Theorem plus_O_n' : forall n : nat, 0 + n = n.
1 subgoal

  ============================
  forall n : nat, 0 + n = n

plus_O_n' < Proof.
1 subgoal

  ============================
  forall n : nat, 0 + n = n

plus_O_n' < intros n.
1 subgoal

  n : nat
  ============================
  0 + n = n

plus_O_n' < reflexivity.
No more subgoals.

plus_O_n' < Qed.
Proof.
intros n.
reflexivity.

Qed.
plus_O_n' is defined


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

(* $Id: Zwf.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Import ZArith_base.
Require Export Wf_nat.
Require Import Omega.
Open Local Scope Z_scope.

(** Well-founded relations on Z. *)

(** We define the following family of relations on [Z x Z]:

    [x (Zwf c) y]   iff   [x < y & c <= y]
 *)

Definition Zwf (c x y:Z) := c <= y /\ x < y.

(** and we prove that [(Zwf c)] is well founded *)

Section wf_proof.

  Variable c : Z.

  (** The proof of well-foundness is classic: we do the proof by induction
      on a measure in nat, which is here [|x-c|] *)

  Let f (z:Z) := Zabs_nat (z - c).

  Lemma Zwf_well_founded : well_founded (Zwf c).
    red in |- *; intros.
    assert (forall (n:nat) (a:Z), (f a < n)%nat \/ a < c -> Acc (Zwf c) a).
    clear a; simple induction n; intros.
  (** n= 0 *)
    case H; intros.
    case (lt_n_O (f a)); auto.
    apply Acc_intro; unfold Zwf in |- *; intros.
    assert False; omega || contradiction.
  (** inductive case *)
    case H0; clear H0; intro; auto.
    apply Acc_intro; intros.
    apply H.
    unfold Zwf in H1.
    case (Zle_or_lt c y); intro; auto with zarith.
    left.
    red in H0.
    apply lt_le_trans with (f a); auto with arith.
    unfold f in |- *.
    apply Zabs.Zabs_nat_lt; omega.
    apply (H (S (f a))); auto.
  Qed.

End wf_proof.

Hint Resolve Zwf_well_founded: datatypes v62.

(** We also define the other family of relations:

    [x (Zwf_up c) y]   iff   [y < x <= c]
 *)

Definition Zwf_up (c x y:Z) := y < x <= c.

(** and we prove that [(Zwf_up c)] is well founded *)

Section wf_proof_up.

  Variable c : Z.

  (** The proof of well-foundness is classic: we do the proof by induction
      on a measure in nat, which is here [|c-x|] *)

  Let f (z:Z) := Zabs_nat (c - z).

  Lemma Zwf_up_well_founded : well_founded (Zwf_up c).
  Proof.
    apply well_founded_lt_compat with (f := f).
    unfold Zwf_up, f in |- *.
    intros.
    apply Zabs.Zabs_nat_lt.
    unfold Zminus in |- *. split.
    apply Zle_left; intuition.
    apply Zplus_lt_compat_l; unfold Zlt in |- *; rewrite <- Zcompare_opp;
      intuition.
  Qed.

End wf_proof_up.

Hint Resolve Zwf_up_well_founded: datatypes v62.


From Coq Require Import List.
Import ListNotations.

Definition iffT (X Y : Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).

(* Minimal Logic *)
Section Minimal.

  Inductive prop : Type :=
  | P : nat -> prop
  | Impl : prop -> prop -> prop
  | Conj : prop -> prop -> prop
  | Disj : prop -> prop -> prop.

  Notation "A ∧ B" := (Conj A B) (at level 41).
  Notation "A ∨ B" := (Disj A B) (at level 42).
  Notation "A '-->' B" := (Impl A B) (at level 43, right associativity).
  Notation "x 'el' A" := (In x A) (at level 70).
  Notation "A <<= B" := (incl A B) (at level 70).

  (* Inductive type formalizing deduction in minimal logic *)
  Reserved Notation "A ⊢ s" (at level 70).
  Inductive prv : list prop -> prop -> Type :=
  | II A phi psi : phi::A ⊢ psi -> A ⊢ phi --> psi
  | IE A phi psi : A ⊢ phi --> psi -> A ⊢ phi -> A ⊢ psi
  | Ctx A phi : phi el A -> A ⊢ phi
  | CI A phi psi : A ⊢ phi -> A ⊢ psi -> A ⊢ phi ∧ psi
  | CE1 A phi psi : A ⊢ phi ∧ psi -> A ⊢ phi
  | CE2 A phi psi : A ⊢ phi ∧ psi -> A ⊢ psi
  | DI1 A phi psi : A ⊢ phi -> A ⊢ phi ∨ psi
  | DI2 A phi psi : A ⊢ psi -> A ⊢ phi ∨ psi
  | DE  A phi psi theta : A ⊢ phi ∨ psi -> phi::A ⊢ theta -> psi::A ⊢ theta -> A ⊢ theta
  where "A ⊢ phi" := (prv A phi).

  Ltac Select n :=
    match n with
    | 0 => left
    | S ?x => right; Select x
    end.
  Ltac Exact n := apply Ctx; now Select n.
  Ltac Intro := apply II.
  Ltac Intros := repeat Intro.
  Ltac Apply n := eapply IE; [Exact n|idtac].
  Ltac Left := apply DI1.
  Ltac Right := apply DI2.
  Ltac Destruct n := eapply DE; [Exact n|idtac|idtac].
  Ltac Split := apply CI.

  Lemma Weak A B phi :
    A ⊢ phi -> A <<= B -> B ⊢ phi.
  Proof.
    induction 1 in B |-*; try unshelve (solve [econstructor; intuition]); try now econstructor.
  Qed.

  Fact Imp A s t :
    A ⊢ s --> t <=> s::A ⊢ t.
  Proof.
    split.
    - intros H. eapply IE.
      2: apply Ctx. eapply Weak. exact H.
      all: firstorder.
    - now Intro.
  Qed.

  (* Fix some propositional variable F *)
  Variable F : prop.

  Definition Contradiction := forall A B, nil ⊢ A --> (A --> F) --> B.
  Definition Explosion := forall A, nil ⊢ F --> A.
  Definition LEM := forall A, nil ⊢ A ∨ (A --> F).
  Definition DN := forall A, nil ⊢ ((A --> F) --> F) --> A.
  Definition CP := forall A B, nil ⊢ ((B --> F) --> (A --> F)) --> A --> B.

  Definition Peirce := forall A B, nil ⊢ ((A --> B) --> A) --> A.

  Lemma CP' {X Y Gamma} : CP -> Gamma ⊢ (Y --> F) --> (X --> F) -> Gamma ⊢ X --> Y.
  Proof.
    intros cp. apply IE. eapply Weak.
    apply (cp X Y). firstorder.
  Qed.

  Goal DN <=> CP.
  Proof.
    split.
    - intros dn A B.
      generalize (dn B).
      eapply IE. Intros.
      Apply 2. Intros.
      eapply IE. instantiate (1 := A).
      + Apply 2. Exact 0.
      + Exact 1.
    - intros cp A. apply (CP' cp).
      Intros. Apply 0. Intros.
      Apply 2. Exact 0.
  Qed.

  Goal DN -> Explosion.
  Proof.
    intros dn A.
    generalize (dn A).
    eapply IE. Intros.
    Apply 1. Intros. Exact 1.
  Qed.

  Goal CP -> Peirce.
  Proof.
    intros cp A B. apply (CP' cp).
    Intros. Apply 1. Apply 0.
    apply (CP' cp). Intro. Exact 2.
  Qed.

  Goal Peirce -> LEM.
  Proof.
    intros peirce X.
    eapply IE. apply (peirce (X ∨ (X --> F)) F).
    Intros. Right. Intros.
    Apply 1. Left. Exact 0.
  Qed.

  Goal LEM * Explosion -> DN.
  Proof.
    intros [lem expl] X.
    generalize (lem X); apply IE.
    generalize (expl X); apply IE.
    Intros. Destruct 1.
    - Exact 0.
    - Apply 3. Apply 1. Exact 0.
  Qed.

  Section NonDeduc.

    (*  Meta Argument: Assume it is possible to show
        Peirce -> Explosion = forall X, |- F -> X.
        Since F was an arbitrary choice, this would mean we would really have a way of showing :
     *)
    Hypothesis H : forall Y, Peirce -> forall X, nil ⊢ Y --> X.

    (* However it then turns out that *)
    Goal Peirce -> forall P, nil ⊢ P.
    Proof.
      intros peirce P.
      enough (nil ⊢ (P --> P) --> P) as C.
      revert C. eapply IE.
      - Intros. Apply 0. Intros. Exact 0.
      - now apply H.
    Qed.

  End NonDeduc.

End Minimal.