(* Following http://REDACTED.net/theses/REDACTED.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.
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.

  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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 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/REDACTED/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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.

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


(*** Modeling specs and morphisms as Coq terms ***)

Require Import List.
Import ListNotations.
Require Import String.
Require Import Coq.Logic.Eqdep_dec.
Import EqNotations.

(*** Fields ***)

(* We define the type of fields in one place, so we can change it later *)
Definition Field : Set := string.
Definition Field_dec : forall (f1 f2 : Field), {f1=f2} + {f1<>f2} := string_dec.

Lemma Field_dec_eq f : { e : f = f | Field_dec f f = left e }.
  destruct (Field_dec f f).
  exists e; reflexivity.
  elimtype False; apply n; reflexivity.
Qed.

Lemma Field_dec_neq f f' : f <> f' -> { neq : f <> f' | Field_dec f f' = right neq }.
  destruct (Field_dec f f'); intros.
  elimtype False; apply (H e).
  exists n; reflexivity.
Qed.

(*** Field lists with no duplicates ***)

Inductive flist : list Field -> Set :=
| fnil : flist []
| fcons f {l} (not_in : ~In f l) (flist' : flist l) : flist (f::l)
.

Lemma flist_NoDup {l} (fl : flist l) : NoDup l.
  induction fl; constructor; assumption.
Qed.

Definition in_fl f {l} (fl : flist l) : Prop := In f l.

Definition in_fl_dec f {l} fl : {@in_fl f l fl} + {~ @in_fl f l fl} :=
  In_dec Field_dec f l.

Lemma in_fl_eq f {l} not_in fl : @in_fl f (f::l) (fcons f not_in fl).
  left; reflexivity.
Qed.

Lemma in_fl_cons {f l not_in fl} f' : in_fl f' fl -> in_fl f' (@fcons f l not_in fl).
  intro i. right. assumption.
Qed.

Lemma in_fl_tail {f' l fl not_in} f :
  f <> f' -> in_fl f (@fcons f' l not_in fl) -> in_fl f fl.
  intros neq i; destruct i.
  elimtype False; apply neq; symmetry; assumption.
  assumption.
Qed.

(* In proofs in lists without duplicates are always equal *)
Lemma in_fl_uniq (f:Field) l (nd:NoDup l) (in1 in2 : In f l) : in1 = in2.
  induction l.
  elimtype False; assumption.
  unfold In in in1,in2; fold (In f l) in in1,in2.
  destruct in1; destruct in2.
  rewrite (UIP_dec Field_dec e e0); reflexivity.
  elimtype False; apply (NoDup_remove_2 [] l a nd); rewrite e; assumption.
  elimtype False; apply (NoDup_remove_2 [] l a nd); rewrite e; assumption.
  f_equal; apply (IHl (NoDup_remove_1 [] l a nd)).
Qed.

(* Helper lemma for proving a field is not in a list *)
Definition not_in_cons A (f f':A) l : f<>f' -> ~In f l -> ~In f (f'::l).
  intros neq not_in i; destruct i.
  apply neq; symmetry; assumption.
  contradiction.
Qed.

(* Tactic for proving a field is not in a list *)
Ltac solve_not_in_list :=
  match goal with
    | |- (~In ?f (@nil _)) => intro; assumption
    | |- (~In ?f ?l) => apply not_in_cons; [ intro; discriminate | ]; try solve_not_in_list
    | |- ?goal => fail "solve_not_in_list" goal
  end.

(*** Maps on fields ***)

Definition FMap := Field -> Field.

Definition fmap_id : FMap := id.

Definition fmap_compose (m2 m1 : FMap) : FMap :=
  fun f => m2 (m1 f).

Definition fmap_cons f (m:FMap) : FMap :=
  fun f' => if Field_dec f f' then f else m f'.

(*** Models ***)

(* Helper for elements of a model at an arbitrary type *)
Definition Any : Type := { T : Type & T }.
Definition mkAny (T:Type) (t:T) : Any := existT (fun T => T) T t.
Definition anyType (any:Any) : Type := projT1 any.
Definition anyObj (any:Any) : anyType any := projT2 any.

(* A model is maps fields to ops for those fields *)
Definition Model : Type := Field -> Any.

(* Model equivalence is extensional equality (without needing an axiom) *)
Definition model_equiv (model1 model2 : Model) : Prop :=
  forall f, model1 f = model2 f.

(* Model equivalence on a restricted domain *)
Definition model_equiv_on {l} fl (model1 model2 : Model) : Prop :=
  forall f, @in_fl f l fl -> model1 f = model2 f.

(* Model equivalence on fl -> equivalence on the tail of fl *)
Lemma model_equiv_on_tail {f l not_in fl} (model1 model2 : Model) :
  model_equiv_on (@fcons f l not_in fl) model1 model2 ->
  model_equiv_on fl model1 model2.
  intros equiv f' i; apply equiv; apply in_fl_cons; assumption.
Qed.

(* General model equivalence -> equivalence on any fl *)
Lemma model_equiv_on_any {l} fl (model1 model2 : Model) :
  model_equiv model1 model2 ->
  @model_equiv_on l fl model1 model2.
  intros equiv f i; apply equiv.
Qed.

(* Whether f has type T in model *)
Definition has_type_in_model f T (model: Model) : Prop :=
  anyType (model f) = T.

(* has_type_in_model is equal in models that are equivalent on it *)
Lemma has_type_in_model_equiv_f f T model1 model2 :
  model1 f = model2 f ->
  has_type_in_model f T model1 = has_type_in_model f T model2.
  intros e; unfold has_type_in_model; rewrite <- e; reflexivity.
Qed.

(* has_type_in_model is equal in equivalent models *)
Lemma has_type_in_model_equiv f T model1 model2 :
  model_equiv model1 model2 ->
  has_type_in_model f T model1 = has_type_in_model f T model2.
  intros equiv; unfold has_type_in_model; rewrite <- equiv; reflexivity.
Qed.

(* Project field f from model *)
Definition model_proj f T (model: Model)
         (htim: has_type_in_model f T model) : T :=
  rew [id] htim in (anyObj (model f)).

(* model_proj is equal (modulo htim proof) in equivalent models *)
Lemma model_proj_equiv f T model1 model2 htim :
  model_equiv model1 model2 ->
  exists htim', model_proj f T model1 htim = model_proj f T model2 htim'.
  unfold model_proj; unfold has_type_in_model.
  intros equiv; rewrite <- (equiv f). exists htim. reflexivity.
Qed.

(* model_proj is equal (modulo htim proof) in equivalent models *)
Lemma model_proj_equiv_f f T model1 model2 htim :
  model1 f = model2 f ->
  exists htim', model_proj f T model1 htim = model_proj f T model2 htim'.
  unfold model_proj; unfold has_type_in_model.
  intros e; rewrite <- e. exists htim. reflexivity.
Qed.

(* Build a model with a subset of the fields in flds by mapping each f to the
corresponding value of (m f) in model *)
Definition unmap_model (m: FMap) (model: Model) : Model :=
  fun f => model (m f).

(* unmap_model on the identity map yields an equivalent model *)
Lemma unmap_model_id model :
  model_equiv model (unmap_model fmap_id model).
  intros f; reflexivity.
Qed.

(* unmap_model commutes with map composition *)
Lemma unmap_model_compose m2 m1 model :
  model_equiv (unmap_model m1 (unmap_model m2 model))
              (unmap_model (fmap_compose m2 m1) model).
  intros f. unfold unmap_model; reflexivity.
Qed.

(* The model_tail of unmap_model FIXME HERE *)
Lemma unmap_cons_equiv {l} fl f m model :
  ~@in_fl f l fl ->
  model_equiv_on fl (unmap_model m model) (unmap_model (fmap_cons f m) model).
  intros not_in f' i.
  unfold unmap_model; unfold fmap_cons.
  destruct (Field_dec_neq f f').
  intro e; apply not_in; rewrite e; assumption.
  rewrite e. reflexivity.
Qed.

(*** Proofs of equality to all elements in a list ***)

(* Construct the type t=t1 /\ ... /\ t=tn, where defs is [t1;...;tn] *)
Fixpoint eq_proofs {T} (t:T) (defs: list T) : Prop :=
  match defs with
    | nil => True
    | def::defs' => t = def /\ eq_proofs t defs'
  end.

(* Project the ith definition from a list of definitions, returning t if i is
bigger than the list *)
Definition proj_def {T t} i {defs} (pfs: eq_proofs t defs) : T :=
  nth i defs t.

(* Project the ith equality proof from a list of equality proofs *)
Fixpoint proj_eq_proof {T t} i defs {struct defs} : forall (pfs: eq_proofs t defs),
                                                      t = proj_def i pfs :=
  match defs return forall (pfs: eq_proofs t defs), t = proj_def i pfs with
    | nil =>
      fun pfs =>
        match i return t = @proj_def T t i nil pfs with
          | 0 => eq_refl t
          | S i' => eq_refl t
        end
    | def::defs' =>
      fun pfs =>
        match i return t = proj_def i pfs with
          | 0 => proj1 pfs
          | S i' => proj_eq_proof i' defs' (proj2 pfs)
        end
  end.

(*** Specs ***)

(* The inductive representation of specs, indexed by the op fields *)
Inductive SpecRepr : forall {l}, flist l -> Type :=
(* The base case contains the names and types of the axioms *)
| Spec_Axioms (axioms : list (Field * Prop)) : SpecRepr fnil
(* The inductive case adds an op named f with zero or more definitions to the
rest of the spec, that can depend on any f equal to all the definitions *)
| Spec_ConsOp f {l flds} not_in (T : Type) (defs: list T) (constraint: T -> Prop)
              (rest : forall t, eq_proofs t defs -> SpecRepr flds)
  : SpecRepr (@fcons f l not_in flds)
.

(* Make the field argument be parsed by Coq as a string *)
Arguments Spec_ConsOp f%string l flds not_in T defs constraint rest.

(* A bundled type for specs and their fields *)
Definition Spec : Type := {l:_ & {fl:_ & @SpecRepr l fl}}.

(* Extract the flist out of a Spec *)
Definition specFields (spec:Spec) := (projT1 (projT2 spec)).

(* Extract the representation out of a Spec *)
Definition specRepr (spec:Spec) := projT2 (projT2 spec).

(* Conjoin all the axioms in an axiom list *)
Definition conjoin_axioms (axioms : list (Field * Prop)) : Prop :=
  fold_left (fun P1 f_P2 => and P1 (snd f_P2)) axioms True.

(* Whether a model satisfies a spec representation *)
Fixpoint satisfies_specRepr {l flds} (spec: @SpecRepr l flds) : Model -> Prop :=
  match spec in @SpecRepr l flds with
    | Spec_Axioms axioms => fun _ => conjoin_axioms axioms
    | Spec_ConsOp f not_in T defs constraint rest =>
      fun model =>
        exists (htim: has_type_in_model f T model)
               (eq_pfs: eq_proofs (model_proj f T model htim) defs),
          constraint (model_proj f T model htim) /\
          satisfies_specRepr (rest (model_proj f T model htim) eq_pfs) model
  end.

(* The bundled version of satsifeis_spec, operating on the Spec bundle type *)
Definition satisfies_spec (spec:Spec) model :=
  satisfies_specRepr (specRepr spec) model.

(* satisfies_spec is equivalent on equivalent models *)
Lemma satisfies_spec_equiv_on_models {l fl} (spec: @SpecRepr l fl) model1 model2 :
  model_equiv_on fl model1 model2 ->
  satisfies_specRepr spec model1 -> satisfies_specRepr spec model2.
  intros equiv sats; induction spec.
  assumption.
  destruct sats as [htim H0]; destruct H0 as [eq_pfs H0];
    destruct H0 as [constraint_pf sats].
  destruct (model_proj_equiv_f f T model1 model2 htim
                               (equiv f (in_fl_eq _ _ _))) as [htim' e2].
  exists htim'; rewrite <- e2.
  exists eq_pfs.
  split.
  assumption.
  apply (H _ _ (model_equiv_on_tail _ _ equiv)). assumption.
Qed.

(* satisfies_spec is equivalent on equivalent models *)
Lemma satisfies_spec_equiv_models {l fl} (spec: @SpecRepr l fl) model1 model2 :
  model_equiv model1 model2 ->
  satisfies_specRepr spec model1 -> satisfies_specRepr spec model2.
  intro equiv; apply satisfies_spec_equiv_on_models.
  apply model_equiv_on_any. assumption.
Qed.

(*** Spec Examples ***)

(* Helper notation for building specs (FIXME) *)
(*
Notation "'DeclOp' f T rest" := (Spec_DeclOp f%string $(solve_not_in_list)$ T rest)
  (at level 0, f at level 0, T at level 0, rest at level 0).
Notation "'DefOp' f T t rest" := (Spec_DefOp f $(solve_not_in_list)$ T rest) (at level 0).
*)
(*
Notation "'Axioms f1 t1 ; .. ; fn tn'" :=
  (Spec_Axioms (cons (f1, t1) .. (cons (fn, tn) nil)))
  (at level 0).
*)

(* Example 1:  op n:nat;  axiom gt1: n > 1 *)
Program Definition spec_repr_example_1 :=
  Spec_ConsOp "n" _ nat [] (fun _ => True)
              (fun n _ => Spec_Axioms [("gt1"%string, n > 1)]).

(* Example 2:  op n:nat := 2;  (no axioms) *)
Program Definition spec_repr_example_2 :=
  Spec_ConsOp "n" _ nat [2] (fun _ => True)
              (fun n _ => Spec_Axioms []).

(* Example 3:  op T:Set := nat;  op n:T__def;  axiom gt1: n > 1 *)
Program Definition spec_repr_example_3 :=
  Spec_ConsOp
    "T" _ Set [nat] (fun _ => True)
    (fun T T__eq_pfs =>
       Spec_ConsOp "n" _ (proj_def 0 T__eq_pfs) [] (fun _ => True)
                   (fun n _ => Spec_Axioms [("gt1"%string, n > 1)])).
Next Obligation.
intro. destruct H. discriminate. assumption.
Defined.

Print spec_repr_example_3.

(*** Morphisms ***)

(* m is a morphism from source to target iff it can unmap models of target into
models of source *)
Definition is_morphism {l_s fl_s l_t fl_t}
           (source: @SpecRepr l_s fl_s) (target: @SpecRepr l_t fl_t) m : Prop :=
  forall model,
    satisfies_specRepr target model ->
    satisfies_specRepr source (unmap_model m model).

(* A morphism from source to target is an m that is_morphism *)
Definition Morphism source target : Type :=
  { m | is_morphism (specRepr source) (specRepr target) m }.

(* The identity map on fl is a morphism from any spec on fl to itself *)
Lemma is_morphism_id spec : is_morphism (specRepr spec) (specRepr spec) fmap_id.
  unfold is_morphism; intros.
  apply (satisfies_spec_equiv_models _ _ _ (unmap_model_id model)).
  assumption.
Qed.

(* The identity morphism on spec *)
Definition morph_id (spec:Spec) : Morphism spec spec :=
  exist _ fmap_id (is_morphism_id spec).

(* Composing maps yields a morphism *)
Lemma is_morphism_compose (s3 s2 s1: Spec) m2 m1 :
  is_morphism (specRepr s2) (specRepr s3) m2 ->
  is_morphism (specRepr s1) (specRepr s2) m1 ->
  is_morphism (specRepr s1) (specRepr s3) (fmap_compose m2 m1).
  unfold is_morphism; intros ism2 ism1 model sats.
  apply (satisfies_spec_equiv_models _ _ _ (unmap_model_compose m2 m1 model)).
  apply ism1. apply ism2. assumption.
Qed.

(* The composition of two morphisms *)
Definition morph_compose {s3 s2 s1}
           (morph2: Morphism s2 s3) (morph1: Morphism s1 s2)
: Morphism s1 s3 :=
  exist _ (fmap_compose (proj1_sig morph2) (proj1_sig morph1))
        (is_morphism_compose s3 s2 s1 (proj1_sig morph2) (proj1_sig morph1)
                             (proj2_sig morph2) (proj2_sig morph1)).

(*** Morphisms on the tail of a spec ***)

(* A dependent spec is a spec inside a binder; note that the field list is not
inside the scope of the binder *)
Definition DepSpec T defs : Type :=
  {l:_ & {fl:_ & forall t:T, eq_proofs t defs -> @SpecRepr l fl}}.

(* Project out the SpecRepr of a DepSpec *)
Definition depSpecRepr {T defs} (spec: DepSpec T defs) :=
  projT2 (projT2 spec).

(* Add an op to the beginning of a DepSpec to get a Spec *)
Definition depSpec_ConsOp f T defs constraint (spec: DepSpec T defs) not_in : Spec :=
  existT _ _ (existT _ _ (Spec_ConsOp f not_in T defs constraint (depSpecRepr spec))).

(* A dependent morphism is morphism inside a binder; note that the mapping is
not inside the scope of the binder *)
Definition DepMorphism {T defs} (source target: DepSpec T defs) :=
  { m | forall t eq_pfs, is_morphism (depSpecRepr source t eq_pfs)
                                     (depSpecRepr target t eq_pfs) m }.

(* A morphism on the tail of two specs extendeds to one on the full specs *)
Lemma is_morphism_cons f T defs constraint (source target: DepSpec T defs) not_in_s not_in_t m :
  (forall t eq_pfs, is_morphism (depSpecRepr source t eq_pfs)
                                (depSpecRepr target t eq_pfs) m) ->
  is_morphism (Spec_ConsOp f not_in_s T defs constraint (depSpecRepr source))
              (Spec_ConsOp f not_in_t T defs constraint (depSpecRepr target))
              (fmap_cons f m).
  intros ism model sats.
  destruct sats as [htim H]; destruct H as [eq_pfs H];
    destruct H as [constraint_pf sats].
  destruct (model_proj_equiv_f f T _ (unmap_model (fmap_cons f m) model) htim)
    as [htim' proj_eq].
  unfold unmap_model; unfold fmap_cons.
  destruct (Field_dec_eq f) as [e1 e2]; rewrite e2; reflexivity.
  exists htim'.
  rewrite <- proj_eq.
  exists eq_pfs.
  split.
  assumption.
  apply (satisfies_spec_equiv_on_models
           _ _ _
           (unmap_cons_equiv _ _ _ _ not_in_s)).
  apply ism.
  assumption.
Qed.

(* Cons an op onto the front of a dependent morphism *)
Definition morph_cons f {T} defs constraint {s1 s2} not_in1 not_in2
           (morph : @DepMorphism T defs s1 s2) :
  Morphism (depSpec_ConsOp f T defs constraint s1 not_in1)
           (depSpec_ConsOp f T defs constraint s2 not_in2) :=
  exist _ (fmap_cons f (proj1_sig morph))
        (is_morphism_cons f T _ _ _ _ not_in1 not_in2
                          (proj1_sig morph) (proj2_sig morph)).

(*** Transformations ***)

(* The top-level proof goal of a transformation is always RefinementOf spec *)
Definition RefinementOf (spec:Spec) : Type :=
  {spec' : Spec & Morphism spec spec'}.


Require Import String.
Require Import Lists.List.
Require Import Coq.Init.Nat.
Require Import Coq.Program.Basics.

Require Export Json.
Require Export CommonHelpers.
Require Export StringHelpers.

Import ListNotations.
Import JsonNotations.

Local Open Scope list_scope.
Local Open Scope string_scope.
Local Open Scope json_scope.

Inductive tree (X Y: Set) : Set :=
| tleaf : X -> @tree X Y
| tlbranch : list (nat*tree X Y) -> tree X Y
| tmbranch : list (Y*tree X Y) -> tree X Y.
(*the empty tree can be written as "tlbranch []"*)

Arguments tleaf [X] [Y].
Arguments tlbranch [X] [Y].
Arguments tmbranch [X] [Y].

Section tree_ind'.

Variable X Y: Set.
Variable P: tree X Y -> Prop.

Hypothesis tree_leaf_case : forall (x : X),
    P (tleaf x).

Hypothesis tree_list_case : forall (lj : list (nat*tree X Y)),
    Forall P (map snd lj) -> P (tlbranch lj).

Hypothesis tree_map_case : forall (mj : list (Y*tree X Y)),
    Forall P (map snd mj) -> P (tmbranch mj).

Fixpoint tree_ind' (t : tree X Y) : P t :=
match t return (P t) with
| tleaf x => tree_leaf_case x
| tlbranch lt => tree_list_case lt
        ((fix tree_list_ind (lt : list (nat*tree X Y)) : Forall P (map snd lt) :=
          match lt with
            | [] => Forall_nil P
            | (k,t)::ltx => @Forall_cons (tree X Y) P t (map snd ltx) (tree_ind' t) (tree_list_ind ltx)
          end) lt)
| tmbranch lt => tree_map_case lt
        ((fix tree_list_ind (lt : list (Y*tree X Y)) : Forall P (map snd lt) :=
          match lt with
            | [] => Forall_nil P
            | (k,t)::ltx => @Forall_cons (tree X Y) P t (map snd ltx) (tree_ind' t) (tree_list_ind ltx)
          end) lt)
end.

End tree_ind'.

Definition jtree := tree JsonData key.

Fixpoint json_tree (j: json): jtree :=
match j with
| $s => tleaf s
| 'l => tlbranch (indexate (map json_tree l))
| &m => let fix map_tree (mm: @key_map json) :=
            match mm with
            | empty => []
            | mapkv k v kvs => (k, json_tree v)::map_tree kvs
            end in
        tmbranch (map_tree m)
end.

Fixpoint tree_json (jt: jtree): option json :=
match jt with
| tleaf s => Some $s
| tlbranch lt => let l := fold_right (fun (kt:nat*jtree) l =>
                                    match l with
                                    | Some l => let mj := tree_json (snd kt) in
                                                       match mj with
                                                       | Some j => Some (cons j l)
                                                       | None => None
                                                       end
                                    | _ => None
                                    end) (Some []) lt in
                           match l with
                           | None => None
                           | Some l => Some 'l
                           end
| tmbranch mt => let m := fold_right (fun (kt: key*jtree) m =>
                                        let (k, t) := kt in
                                        match k, m with
                                        | k, Some m => let mj := tree_json t in
                                                           match mj with
                                                           | Some j => Some (mapkv k j m)
                                                           | None => None
                                                           end
                                        | _, _ => None
                                        end) (Some empty) mt in
                                  match m with
                                  | None => None
                                  | Some m => Some &m
                                  end
end.

Check json_ind'.

Lemma tree_json_ind_ign: forall lj m n, fold_right
  (fun (kt : nat * jtree) (l : option (list json)) =>
   match l with
   | Some l0 =>
       match tree_json (snd kt) with
       | Some j => Some (j :: l0)
       | None => None
       end
   | None => None
   end) (Some []) (indexate_with' m id (map json_tree lj)) =
fold_right
  (fun (kt : nat * jtree) (l : option (list json)) =>
   match l with
   | Some l0 =>
       match tree_json (snd kt) with
       | Some j => Some (j :: l0)
       | None => None
       end
   | None => None
   end) (Some []) (indexate_with' n id (map json_tree lj)).
Proof.
 intros lj. induction lj; intros. auto.
 simpl. rewrite IHlj with (n:= S n).
 auto.
Qed.

Lemma tree_json_inv: forall j, tree_json (json_tree j) = Some j.
Proof.
 intros. induction j using json_ind'.
 simpl. auto.
 induction lj. auto.
 inversion_clear H. apply IHlj in H1.
 simpl. rewrite H0. simpl in H1.
 remember (fold_right
         (fun (kt : nat * jtree) (l : option (list json)) =>
          match l with
          | Some l0 =>
              match tree_json (snd kt) with
              | Some j => Some (j :: l0)
              | None => None
              end
          | None => None
          end) (Some []) (indexate (map json_tree lj))).
 replace (fold_right
      (fun (kt : nat * jtree) (l : option (list json)) =>
       match l with
       | Some l0 =>
           match tree_json (snd kt) with
           | Some j => Some (j :: l0)
           | None => None
           end
       | None => None
       end) (Some []) (indexate_with' 1 id (map json_tree lj))) with o.
 destruct o; inversion H1; auto. rewrite Heqo.
 unfold indexate.
 apply tree_json_ind_ign.
 induction mj. auto.
 inversion_clear H. apply IHmj in H1.
 simpl. rewrite H0. simpl in H1.
 remember (fold_right
         (fun (kt : key * jtree) (m : option key_map) =>
          let (k, t) := kt in
          match m with
          | Some m0 => match tree_json t with
                       | Some j => Some ((k) # (j) m0)
                       | None => None
                       end
          | None => None
          end) (Some empty)
         ((fix map_tree (mm : key_map) : list (key * jtree) :=
             match mm with
             | empty => []
             | (k) # (v) kvs => (k, json_tree v) :: map_tree kvs
             end) mj)).
 destruct o; inversion H1; auto.
Qed.

Inductive MergeStrategyIn := SMergeRight | SReplace | SMergeLeft | SExchange.
Inductive MergeStrategyOut := SRemoveOrigin | SLeaveOrigin.
Inductive NameStrategy :=
| SRenameNode: key -> NameStrategy
| SLeaveNodeName: NameStrategy.

Inductive MergeStrategyT :=
| MergeStrategy: MergeStrategyIn -> MergeStrategyOut ->
                 NameStrategy -> NameStrategy -> MergeStrategyT.

Definition MergeStrategy0 := MergeStrategy SMergeRight SLeaveOrigin
                             SLeaveNodeName SLeaveNodeName.

Definition merge_trees (t1 t2: jtree) (s: MergeStrategyT) : jtree :=
match t1,t2 with
| tleaf s1, tleaf s2 => tlbranch (indexate [t1; t2])

| tleaf s1, tlbranch tl2 => tlbranch (indexate (t1::(map snd tl2)))
| tlbranch tl1, tleaf s2 => tlbranch (indexate (app (map snd tl1) [t2]))
| tlbranch tl1, tlbranch tl2 => tlbranch (indexate (app (map snd tl1) (map snd tl2)))

| tleaf s1, tmbranch tm2 => tmbranch ((indexNat 0, t1)::tm2)
| tmbranch tm1, tleaf s2 =>  tmbranch (app tm1 [(indexNat 0, t2)])
| tmbranch tm1, tmbranch tm2 => tmbranch (app tm1 tm2)

| tlbranch tl1, tmbranch tm2 => tmbranch (app (indexate_with indexNat (map snd tl1)) tm2)
| tmbranch tm1, tlbranch tl2 => tmbranch (app tm1 (indexate_with indexNat (map snd tl2)))
end.

Definition tlookup {X} (tm: list (key*(tree X key))) (k: key) :=
firstSome (map (fun (k'v: key*(tree X key)) => let (k', v) := k'v in
                           if (string_dec k k') then Some v else None) tm).

Definition tlookup_ind {X} (tm: list (key*(tree X key))) (k: key) :=
firstSome_ind (map (fun (k'v: key*(tree X key)) => let (k', v) := k'v in
                           if (string_dec k k') then Some v else None) tm).

Fixpoint tree_get (kk: jpoint) (jt: jtree) {struct jt}: option (nat*jtree) :=
match kk with
| inl k => match jt with
              | tmbranch tm => tlookup_ind tm k
              | _ => None
           end
| inr k => match jt with
              | tlbranch tl  => nth_error tl k
              | _ => None
           end
end.

Fixpoint tree_getin (lk: jpath) (jt: jtree): option jtree :=
match lk with
| [] => Some jt
| k::ks => let mjt' := tree_get k jt in
           match mjt' with
           | None => None
           | Some (_,jt') => tree_getin ks jt'
           end
end.

Fixpoint tree_setin (lk: jpath) (to_jt jt: jtree): jtree :=
match lk with
| [] => jt
| k::ks => let mjt' := tree_get k to_jt in
           match mjt' with
           | None => to_jt
           | Some (n, to_jt') => let nt := tree_setin ks to_jt' jt in
                                 match k, to_jt with
                                 | inr k, tlbranch tl => (tlbranch (replace n tl (k, nt)))
                                 | inl k, tmbranch tm => (tmbranch (replace n tm (k, nt)))
                                 | _,_ => to_jt
                                 end
           end
end.

Fixpoint tree_force_setin (lk: jpath) (to_jt jt: jtree): jtree :=
match lk with
| [] => jt
| k::ks => let mjt' := tree_get k to_jt in
           match mjt' with
           | None => let nt := tree_force_setin ks (match ks with
                                                    | (inl _)::_ => tmbranch []
                                                    | (inr _)::_ => tlbranch []
                                                    | [] => tlbranch []
                                                    end) jt in
                                 match k, to_jt with
                                 | inr k, tlbranch tl => tlbranch (app tl [(k, nt)])
                                 | inl k, tmbranch tm => tmbranch (app tm [(k, nt)])
                                 | _,_ => to_jt
                                 end
           | Some (n, to_jt') => let nt := tree_force_setin ks to_jt' jt in
                                 match k, to_jt with
                                 | inr k, tlbranch tl => (tlbranch (replace n tl (k, nt)))
                                 | inl k, tmbranch tm => (tmbranch (replace n tm (k, nt)))
                                 | _,_ => to_jt
                                 end
           end
end.

Definition tree_mergein (lk: jpath) (to_jt jt: jtree) s: jtree :=
let mjt':= tree_getin lk to_jt in
match mjt' with
| None => to_jt
| Some to_jt' => tree_setin lk to_jt (merge_trees to_jt' jt s)
end.

Definition tree_force_mergein (lk: jpath) (to_jt jt: jtree) s: jtree :=
let mjt':= tree_getin lk to_jt in
match mjt' with
| None => tree_force_setin lk to_jt jt
| Some to_jt' => tree_setin lk to_jt (merge_trees to_jt' jt s)
end.

Definition tree_submerge_with (lk_to lk_from: jpath)
                              (f: jpath -> jtree -> jtree) (jt: jtree) (s: MergeStrategyT): jtree :=
let mjt_from' := tree_getin lk_from jt in
match mjt_from' with
| Some jt_from' => tree_mergein lk_to jt (f lk_from jt_from') s
| None => jt
end.

Definition tree_submerge (lk_to lk_from: jpath)
                         (jt: jtree) (s: MergeStrategyT): jtree :=
tree_submerge_with lk_to lk_from (fun _ jt => jt) jt s.

Definition tree_modify (lk_in: jpath) (jt: jtree) (f: jtree -> jtree) : jtree :=
let mjt' := tree_getin lk_in jt in
match mjt' with
| Some jt' => tree_setin lk_in jt (f jt')
| None => jt
end.

Definition concat_tree_with (d: JsonData) (jt: jtree): jtree :=
match jt with
| tleaf s => tleaf s
| tlbranch tl => tleaf (fold_right (fun i r => match i with
                                        | (_, tleaf s) => if (string_dec r "") then s
                                                          else (s ++ d ++ r)
                                        | _ => r
                                        end) ""  tl)
| tmbranch tm => tleaf (fold_right (fun i r => match i with
                                        | (_, tleaf s) => if (string_dec r "") then s
                                                          else (s ++ d ++ r)
                                        | _ => r
                                        end) ""  tm)
end.

Inductive jnode :=
| data_node: JsonData -> jnode
| root_node: jnode.

Definition jtable_row := list jnode.

Fixpoint json_nodes (j: json): jtable_row :=
match j with
| $s => [data_node s]
| 'l => root_node::flatten (map json_nodes l)
| &m => let fix map_nodes (mm: @key_map json): jtable_row :=
            match mm with
            | empty => []
            | mapkv k v kvs => app (json_nodes v) (map_nodes kvs)
            end in
        root_node::map_nodes m
end.

Fixpoint jtree_nodes (jt: jtree): jtable_row :=
match jt with
| tleaf s => [data_node s]
| tlbranch tl => root_node::flatten (map (compose jtree_nodes snd) tl)
| tmbranch tm => root_node::flatten (map (compose jtree_nodes snd) tm)
end.

Lemma jtree_nodes_ind_ign: forall X Y T (f:Y->T) m n ind1 ind2 l,
            map (fun xy : X * Y => f (snd xy)) (indexate_with' m ind1 l) =
            map (fun xy : X * Y => f (snd xy)) (indexate_with' n ind2 l).
Proof.
 intros. generalize dependent m. generalize dependent n.
 induction l; intros; auto. simpl. rewrite IHl with (n:= S n).
 auto.
Qed.

Lemma jtree_nodes_equal: forall j, json_nodes j = jtree_nodes (json_tree j).
Proof.
 intros. induction j using json_ind'.
 simpl. auto. induction lj. simpl. auto.
 inversion_clear H. apply IHlj in H1.
 simpl. unfold compose. simpl. rewrite <- H0.
 simpl in H1. inversion H1. clear H1.
 rewrite H2. unfold compose. unfold indexate.
 rewrite jtree_nodes_ind_ign with (n:=1) (ind2:=id). auto.
 induction mj. simpl. auto.
 inversion_clear H. apply IHmj in H1.
 simpl. unfold compose. simpl. rewrite <- H0.
 simpl in H1. inversion H1. clear H1.
 rewrite H2. unfold compose. auto.
Qed.

Definition split_tree_with (d: JsonData) (jt: jtree): jtree :=
match jt with
| tleaf s => let ss := split_string s d in
             tlbranch (indexate (map (@tleaf JsonData key) ss))
| _ => jt (* FIXME *)
end.

Definition tree_wild_get (p: jpoint) (jpt: jpath*jtree): list (jpath*jtree) :=
let (p0, jt) := jpt in
match p with
| inr k => let mt := tree_get p jt in
           match mt with
           | None => []
           | Some (_, t) => [(app p0 [p], t)]
           end
| inl k => match jt with
           | tleaf s => []
           | tlbranch tl => map (fun kt => (app p0 [inr (fst kt)], snd kt))
                            (filter (fun (kt:nat*jtree) => let (k', t) := kt in
                                     match_string k (indexNat k')) tl)
           | tmbranch tm => map (fun kt => (app p0 [inl (fst kt)], snd kt))
                            (filter (fun (kt:key*jtree) => let (k', t) := kt in
                                     match_string k k') tm)
           end
end.

Definition zip_tree_with (ks: list key) (jt: jtree) : jtree :=
match jt with
| tleaf _ => jt
| tlbranch tl => tmbranch (zip_first_with ks tl (tlbranch []) indexNat)
| tmbranch tm => tmbranch (zip_first_with ks tm (tlbranch []) (@id key))
end.

Definition map_tree_with (ks: list key) (jt: jtree) : jtree :=
match jt with
| tleaf _ => jt
| tlbranch tl => tlbranch (map (fun (kt:nat*jtree) => let (k,t) := kt in
                                          (k, zip_tree_with ks t)) tl)
| tmbranch tm => tmbranch (map (fun (kt:key*jtree) => let (k,t) := kt in
                                          (k, zip_tree_with ks t)) tm)
end.

Definition map_tree_with_old (ks: list key) (jt: jtree) : jtree :=
match jt with
| tleaf _ => jt
| tlbranch tl => tlbranch (indexate (map (fun (ks:nat*key) => let (k,s):=ks in
                                let txs := filterSome (map (tree_get (inr k)) (map snd tl)) in
                                tmbranch [(s, tlbranch txs)] ) (indexate ks)))
| _ => jt
end.

Fixpoint ziptrees' (ll : list jtree)  (l: jtree) :=
match ll, l with
| _, tlbranch [] => ll
| [], tlbranch ((_::_) as l) => map (fun x => tlbranch [x]) l
| (tlbranch lx)::lxs, tlbranch (x::xs) => (tlbranch (app lx [x]))::(ziptrees' lxs (tlbranch xs))
| _,_ => ll
end.

(*tests*)

Let json1 := '[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"]}}].
Let jtree1 := json_tree json1.

Example tree_json1 : tree_json jtree1 = Some json1.
Proof. auto. Qed.

Example tree_setin1 : tree_json
                  (tree_setin [inr 2; inl "baz"; inl "x"; inr 1] jtree1 (tleaf "e")) =
                  Some '[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"e"]}}].
Proof. auto. Qed.

Example json_tree1 : jtree1 =
        tlbranch [(0,
          tmbranch
            [("foo",
             tlbranch
               [(0, tleaf "Andy"); (1, tleaf "Peter")])]);
         (1, tmbranch [("bar", tleaf "Good")]);
         (2,
         tmbranch
           [("baz",
            tmbranch
              [("x",
               tlbranch [(0, tleaf "d"); (1, tleaf "f")])])])].
Proof. auto. Qed.

Example tree_modify1: tree_json (tree_modify [inr 0; inl "foo"] jtree1 (concat_tree_with " ")) =
                  Some '[{"foo" # $"Andy Peter"};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"]}}].
Proof. auto. Qed.

Example tree_setin2: tree_json (tree_setin [inr 2; inl "baz"; inl "x"; inr 0] jtree1 (tleaf "e")) =
                 Some '[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"e"; $"f"]}}].
Proof. auto. Qed.

Example tree_mergein1: tree_json (tree_mergein [inr 2; inl "baz"; inl "x"] jtree1 (tleaf "j") MergeStrategy0) =
                    Some '[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"; $"j"]}}].
Proof. auto. Qed.

Example tree_submerge1: tree_json (tree_submerge [inr 0] [inr 2; inl "baz"; inl "x"] jtree1 MergeStrategy0) =
                   Some '[{"foo" # '[$"Andy"; $"Peter"], "#0" # $"d", "#1" # $"f"};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"]}}].
Proof. compute. auto. Qed.

Let json2 := {"menu" # {"header" # $"SVG Viewer",
    "items" # '[
        {"id"# $"Open"};
        {"id"# $"OpenNew", "label"# $"Open New"};
        {"id"# $"ZoomIn", "label"# $"Zoom In"};
        {"id"# $"ZoomOut", "label"# $"Zoom Out"};
        {"id"# $"OriginalView", "label"# $"Original View"};
        {"id"# $"Quality"};
        {"id"# $"Pause"};
        {"id"# $"Mute"};
        {"id"# $"Find", "label"# $"Find..."};
        {"id"# $"FindAgain", "label"# $"Find Again"};
        {"id"# $"Copy"};
        {"id"# $"CopyAgain", "label"# $"Copy Again"};
        {"id"# $"CopySVG", "label"# $"Copy SVG"};
        {"id"# $"ViewSVG", "label"# $"View SVG"};
        {"id"# $"ViewSource", "label"# $"View Source"};
        {"id"# $"SaveAs", "label"# $"Save As"};
        {"id"# $"Help"};
        {"id"# $"About", "label"# $"About Adobe CVG Viewer..."}]}}.

Let tree2 := json_tree json2.
Let json2' := tree_json tree2.

Example tree_json2: Some json2 = json2'.
Proof. auto. Qed.

Example json_nodes1: json_nodes json1 =
                     [root_node; root_node; root_node; data_node "Andy";
       data_node "Peter"; root_node; data_node "Good"; root_node;
       root_node; root_node; data_node "d"; data_node "f"].
Proof. auto. Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Pathing module for the Upsilon context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.

Require Export BoolEqualitySigDef.
Require Export EVarModuleDef.
Require Export CpdtTactics.
Require Export Case.

Module PathModule.
  Module E := EVarModule.

(* Bug 45, should have made this just zero/one not an i to make the inductions
   work. *)
Module Types.
Inductive IPE: Type :=
 | zero_pe
 | one_pe.

Inductive PE : Type :=
 | i_pe      : IPE -> PE
 | u_pe      : PE.

Definition Path : Type := list PE.
Definition pdot := [] : Path.
End Types.
Include Types.

Function beq_ipe (i i' : IPE) : bool :=
  match i, i' with
    | zero_pe, zero_pe => true
    | one_pe, one_pe => true
    | _, _ => false
  end.
Hint Resolve beq_ipe.
Hint Unfold beq_ipe.

Lemma beq_ipe_refl:
  forall i, beq_ipe i i = true.
Proof.
  destruct i; crush.
Qed.
Hint Resolve beq_ipe_refl.

Lemma beq_ipe_sym:
  forall i i', beq_ipe i i' = beq_ipe i' i.
Proof.
  destruct i; destruct i'; crush.
Qed.
Hint Immediate beq_ipe_sym.

Lemma beq_ipe_trans:
  forall p p0 p1,
    beq_ipe p p0 = true ->
    beq_ipe p0 p1 = true ->
    beq_ipe p p1 = true.
Proof.
  induction p; induction p0; induction p1; try solve[crush].
Qed.
Hint Resolve beq_ipe_trans.

Lemma beq_ipe_eq:
  forall i i', beq_ipe i i' = true -> i = i'.
Proof.
  destruct i; destruct i'; crush.
Qed.
Hint Immediate beq_ipe_eq.

Lemma beq_ipe_neq:
  forall i i', beq_ipe i i' = false -> i <> i'.
Proof.
  destruct i; destruct i'; crush.
Qed.
Hint Immediate beq_ipe_neq.

Function beq_pe (p p' : PE) : bool :=
  match p, p' with
    | i_pe x, i_pe y => beq_ipe x y
    | u_pe, u_pe => true
    | _, _ => false
  end.
Hint Resolve beq_pe.
Hint Unfold beq_pe.

Lemma beq_pe_refl:
  forall p, beq_pe p p = true.
Proof.
  destruct p; crush.
Qed.
Hint Resolve beq_pe_refl.

Lemma beq_pe_sym:
  forall p p', beq_pe p p' = beq_pe p' p.
Proof.
  destruct p; destruct p'; crush.
Qed.
Hint Immediate beq_pe_sym.

Lemma beq_pe_trans:
  forall p p0 p1,
    beq_pe p p0 = true ->
    beq_pe p0 p1 = true ->
    beq_pe p p1 = true.
Proof.
  induction p; induction p0; induction p1; try solve[crush].
  crush.
  apply beq_ipe_trans with (p:= i) (p0:= i0) (p1:= i1) in H; try assumption.
Qed.
Hint Resolve beq_pe_trans.

Lemma beq_pe_eq:
  forall p p', beq_pe p p' = true -> p = p'.
Proof.
  destruct p; destruct p'; try solve [crush].
  intros.
  unfold beq_pe in H.
  apply beq_ipe_eq in H.
  subst.
  reflexivity.
Qed.
Hint Immediate beq_pe_eq.

Lemma beq_pe_neq:
  forall p p', beq_pe p p' = false -> p <> p'.
Proof.
  destruct p; destruct p'; try solve [crush].
  intros.
  unfold beq_pe in H.
  apply beq_ipe_neq in H.
  subst.
  crush.
Qed.
Hint Immediate beq_pe_neq.

Function beq_path (p q : Path) : bool :=
  match p, q with
    | [], [] => true
    | x :: p', y :: q' => andb (beq_pe x y) (beq_path p' q')
    | _  , _ => false
  end.
Hint Resolve beq_path.
Hint Unfold beq_path.

Lemma beq_path_refl:
 forall (p : Path),
   beq_path p p = true.
Proof.
  induction p; crush.
Qed.
Hint Resolve beq_path_refl.

Lemma beq_path_sym : forall p p', beq_path p p' = beq_path p' p.
Proof.
  induction p; induction p'; try solve[crush].
  unfold beq_path.
  fold beq_path.
  specialize (IHp p').
  rewrite IHp.
  rewrite beq_pe_sym.
  reflexivity.
Qed.
Hint Immediate beq_path_sym.

Lemma beq_path_eq:
  forall p p',
    beq_path p p' = true ->
    p = p'.
Proof.
  induction p; induction p'; try solve [crush].
  unfold beq_path.
  fold beq_path.
  intros.
  apply andb_true_iff in H.
  inversion H.
  apply beq_pe_eq in H0.
  subst.
  apply IHp in H1.
  subst.
  reflexivity.
Qed.
Hint Resolve beq_path_eq.

Lemma beq_path_trans:
  forall p p0 p1,
    beq_path p p0 = true ->
    beq_path p0 p1 = true ->
    beq_path p p1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_path_eq in H.
  apply beq_path_eq in H0.
  subst.
  apply beq_path_refl.
Qed.

Lemma beq_path_neq:
  forall p p',
    beq_path p p' = false ->
    p <> p'.
Proof.
  induction p; induction p'; try solve [crush].
  unfold beq_path.
  fold beq_path.
  intros.
  apply andb_false_iff in H.
  inversion H.
  apply beq_pe_neq in H0.
  crush.
  apply IHp in H0.
  crush.
Qed.
Hint Resolve beq_path_eq.

Lemma beq_path_iff_eq:    forall a b, beq_path a b = true <-> a = b.
Proof.
  intros.
  split.
  apply beq_path_eq.
  intros.
  rewrite H.
  apply beq_path_refl.
Qed.
Hint Resolve beq_path_iff_eq.

Lemma beq_path_iff_neq:   forall a b, beq_path a b = false <-> a <> b.
Proof.
  intros.
  split.
  apply beq_path_neq.
  intros.
  induction a; induction b; try solve[crush].
  unfold beq_path.
  unfold beq_path.
  fold beq_path.
  apply andb_false_iff.
  destruct a; destruct a1.
Admitted.
Hint Resolve beq_path_iff_neq.
End PathModule.