Require Import Coq.ZArith.Zpower Coq.ZArith.ZArith Coq.micromega.Psatz.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Lists.List.
Require Import Coq.funind.Recdef.
Require Import Crypto.Util.ListUtil Crypto.Util.ZUtil Crypto.Util.NatUtil.
Require Import Crypto.LegacyArithmetic.VerdiTactics.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.LegacyArithmetic.Pow2Base.
Require Import Crypto.Util.Notations.
Require Export Crypto.Util.Bool.
Require Export Crypto.Util.FixCoqMistakes.
Local Open Scope Z_scope.

Require Crypto.LegacyArithmetic.BaseSystemProofs.

Create HintDb simpl_add_to_nth discriminated.
Create HintDb push_upper_bound discriminated.
Create HintDb pull_upper_bound discriminated.
Create HintDb push_base_from_limb_widths discriminated.
Create HintDb pull_base_from_limb_widths discriminated.

Hint Extern 1 => progress autorewrite with push_upper_bound in * : push_upper_bound.
Hint Extern 1 => progress autorewrite with pull_upper_bound in * : pull_upper_bound.
Hint Extern 1 => progress autorewrite with push_base_from_limb_widths in * : push_base_from_limb_widths.
Hint Extern 1 => progress autorewrite with pull_base_from_limb_widths in * : pull_base_from_limb_widths.

Section Pow2BaseProofs.
  Context {limb_widths} (limb_widths_nonneg : forall w, In w limb_widths -> 0 <= w).
  Local Notation base := (base_from_limb_widths limb_widths).

  Lemma base_from_limb_widths_length ls : length (base_from_limb_widths ls) = length ls.
  Proof using Type.
    clear limb_widths limb_widths_nonneg.
    induction ls; [ reflexivity | simpl in * ].
    autorewrite with distr_length; auto.
  Qed.
  Hint Rewrite base_from_limb_widths_length : distr_length.

  Lemma base_from_limb_widths_cons : forall l0 l,
    base_from_limb_widths (l0 :: l) = 1 :: map (Z.mul (two_p l0)) (base_from_limb_widths l).
  Proof using Type. reflexivity. Qed.
  Hint Rewrite base_from_limb_widths_cons : push_base_from_limb_widths.
  Hint Rewrite <- base_from_limb_widths_cons : pull_base_from_limb_widths.

  Lemma base_from_limb_widths_nil : base_from_limb_widths nil = nil.
  Proof using Type. reflexivity. Qed.
  Hint Rewrite base_from_limb_widths_nil : push_base_from_limb_widths.

  Lemma firstn_base_from_limb_widths : forall n, firstn n (base_from_limb_widths limb_widths) = base_from_limb_widths (firstn n limb_widths).
  Proof using Type.
    clear limb_widths_nonneg. (* don't use this in the inductive hypothesis *)
    induction limb_widths as [|l ls IHls]; intros [|n]; try reflexivity.
    autorewrite with push_base_from_limb_widths push_firstn; boring.
  Qed.
  Hint Rewrite <- @firstn_base_from_limb_widths : push_base_from_limb_widths.
  Hint Rewrite <- @firstn_base_from_limb_widths : pull_firstn.
  Hint Rewrite @firstn_base_from_limb_widths : pull_base_from_limb_widths.
  Hint Rewrite @firstn_base_from_limb_widths : push_firstn.

  Lemma sum_firstn_limb_widths_nonneg : forall n, 0 <= sum_firstn limb_widths n.
  Proof using Type*.
    unfold sum_firstn; intros.
    apply fold_right_invariant; try omega.
    eauto using Z.add_nonneg_nonneg, limb_widths_nonneg, In_firstn.
  Qed. Hint Resolve sum_firstn_limb_widths_nonneg.

  Lemma base_from_limb_widths_step : forall i b w, (S i < length limb_widths)%nat ->
    nth_error base i = Some b ->
    nth_error limb_widths i = Some w ->
    nth_error base (S i) = Some (two_p w * b).
  Proof using Type.
    clear limb_widths_nonneg. (* don't use this in the inductive hypothesis *)
    induction limb_widths; intros i b w ? nth_err_w nth_err_b;
      unfold base_from_limb_widths in *; fold base_from_limb_widths in *;
      [rewrite (@nil_length0 Z) in *; omega | ].
    simpl in *.
    case_eq i; intros; subst.
    + subst; apply nth_error_first in nth_err_w.
      apply nth_error_first in nth_err_b; subst.
      apply map_nth_error.
      case_eq l; intros; subst; [simpl in *; omega | ].
      unfold base_from_limb_widths; fold base_from_limb_widths.
      reflexivity.
    + simpl in nth_err_w.
      apply nth_error_map in nth_err_w.
      destruct nth_err_w as [x [A B] ].
      subst.
      replace (two_p w * (two_p a * x)) with (two_p a * (two_p w * x)) by ring.
      apply map_nth_error.
      apply IHl; auto. omega.
  Qed.

  Lemma nth_error_base : forall i, (i < length limb_widths)%nat ->
    nth_error base i = Some (two_p (sum_firstn limb_widths i)).
  Proof using Type*.
    induction i as [|i IHi]; intros H.
    + unfold sum_firstn, base_from_limb_widths in *; case_eq limb_widths; try reflexivity.
      intro lw_nil; rewrite lw_nil, (@nil_length0 Z) in *; omega.
    + assert (i < length limb_widths)%nat as lt_i_length by omega.
      specialize (IHi lt_i_length).
      destruct (nth_error_length_exists_value _ _ lt_i_length) as [w nth_err_w].
      erewrite base_from_limb_widths_step; eauto.
      f_equal.
      simpl.
      destruct (NPeano.Nat.eq_dec i 0).
      - subst; unfold sum_firstn; simpl.
        apply nth_error_exists_first in nth_err_w.
        destruct nth_err_w as [l' lw_destruct]; subst.
        simpl; ring_simplify.
        f_equal; ring.
      - erewrite sum_firstn_succ; eauto.
        symmetry.
        apply two_p_is_exp; auto using sum_firstn_limb_widths_nonneg.
        apply limb_widths_nonneg.
        eapply nth_error_value_In; eauto.
  Qed.

  Lemma nth_default_base : forall d i, (i < length limb_widths)%nat ->
    nth_default d base i = 2 ^ (sum_firstn limb_widths i).
  Proof using Type*.
    intros ? ? i_lt_length.
    apply nth_error_value_eq_nth_default.
    rewrite nth_error_base, two_p_correct by assumption.
    reflexivity.
  Qed.

   Lemma b0_1 : forall x : Z, limb_widths <> nil -> nth_default x base 0 = 1.
   Proof using Type.
     case_eq limb_widths; intros; [congruence | reflexivity].
   Qed.

  Lemma base_from_limb_widths_app : forall l0 l
                                           (l0_nonneg : forall x, In x l0 -> 0 <= x)
                                           (l_nonneg : forall x, In x l -> 0 <= x),
      base_from_limb_widths (l0 ++ l)
      = base_from_limb_widths l0 ++ map (Z.mul (two_p (sum_firstn l0 (length l0)))) (base_from_limb_widths l).
  Proof using Type.
    induction l0 as [|?? IHl0].
    { simpl; intros; rewrite <- map_id at 1; apply map_ext; intros; omega. }
    { simpl; intros; rewrite !IHl0, !map_app, map_map, sum_firstn_succ_cons, two_p_is_exp by auto with znonzero.
      do 2 f_equal; apply map_ext; intros; lia. }
  Qed.

  Lemma skipn_base_from_limb_widths : forall n, skipn n (base_from_limb_widths limb_widths) = map (Z.mul (two_p (sum_firstn limb_widths n))) (base_from_limb_widths (skipn n limb_widths)).
  Proof using Type*.
    intro n; pose proof (base_from_limb_widths_app (firstn n limb_widths) (skipn n limb_widths)) as H.
    specialize_by eauto using In_firstn, In_skipn.
    autorewrite with simpl_firstn simpl_skipn in *.
    rewrite H, skipn_app, skipn_all by auto with arith distr_length; clear H.
    simpl; distr_length.
    apply Min.min_case_strong; intro;
      unfold sum_firstn; autorewrite with natsimplify simpl_skipn simpl_firstn;
        reflexivity.
  Qed.
  Hint Rewrite <- @skipn_base_from_limb_widths : push_base_from_limb_widths.
  Hint Rewrite <- @skipn_base_from_limb_widths : pull_skipn.
  Hint Rewrite @skipn_base_from_limb_widths : pull_base_from_limb_widths.
  Hint Rewrite @skipn_base_from_limb_widths : push_skipn.

  Lemma pow2_mod_bounded :forall lw us i, (forall w, In w lw -> 0 <= w) -> bounded lw us ->
                                          Z.pow2_mod (nth_default 0 us i) (nth_default 0 lw i) = nth_default 0 us i.
  Proof using Type.
    clear.
    cbv [bounded]; intros lw us i H H0.
    repeat match goal with
           | |- _ => progress (cbv [bounded]; intros)
           | |- _ => break_if
           | |- _ => apply Z.bits_inj'
           | |- _ => rewrite Z.testbit_pow2_mod by (apply nth_default_preserves_properties; auto; omega)
           | |- _ => reflexivity
           end.
    specialize (H0 i).
    symmetry.
    let n := match goal with n : Z |- _ => n end in
    rewrite <- (Z.mod_pow2_bits_high (nth_default 0 us i) (nth_default 0 lw i) n);
      [ rewrite Z.mod_small by omega; reflexivity | ].
    split; try omega.
    apply nth_default_preserves_properties; auto; omega.
  Qed.

  Lemma bounded_nil_iff : forall us, bounded nil us <-> (forall u, In u us -> u = 0).
  Proof using Type.
    clear.
    intros us; split; cbv [bounded]; [ intros H u H0 | intros H i ].
    + edestruct (In_nth_error_value us u) as [x]; try assumption.
      specialize (H x).
      replace u with (nth_default 0 us x) by (auto using nth_error_value_eq_nth_default).
      rewrite nth_default_nil, Z.pow_0_r in H.
      omega.
    + rewrite nth_default_nil, Z.pow_0_r.
      apply nth_default_preserves_properties; try omega.
      intros x H0.
      apply H in H0.
      omega.
  Qed.

  Lemma bounded_iff : forall lw us, bounded lw us <-> forall i, 0 <= nth_default 0 us i < 2 ^ nth_default 0 lw i.
  Proof using Type.
    clear.
    cbv [bounded]; intros.
    reflexivity.
  Qed.

  Lemma digit_select : forall us i, bounded limb_widths us ->
                                    nth_default 0 us i = Z.pow2_mod (BaseSystem.decode base us >> sum_firstn limb_widths i) (nth_default 0 limb_widths i).
  Proof using Type*.
    intro us; revert limb_widths limb_widths_nonneg; induction us as [|a us IHus];
      intros limb_widths limb_widths_nonneg i H.
    + rewrite nth_default_nil, BaseSystemProofs.decode_nil, Z.shiftr_0_l, Z.pow2_mod_spec, Z.mod_0_l by
          (try (apply Z.pow_nonzero; try omega); apply nth_default_preserves_properties; auto; omega).
      reflexivity.
    + destruct i.
      - rewrite nth_default_cons, sum_firstn_0, Z.shiftr_0_r.
        destruct limb_widths as [|w lw].
        * cbv [base_from_limb_widths].
          rewrite <-pow2_mod_bounded with (lw := nil); rewrite bounded_nil_iff in *; auto using in_cons;
            try solve [intros; exfalso; eauto using in_nil].
          rewrite !nth_default_nil, BaseSystemProofs.decode_base_nil; auto.
          cbv. auto using in_eq.
        * rewrite nth_default_cons, base_from_limb_widths_cons, BaseSystemProofs.peel_decode.
          fold (BaseSystem.mul_each (two_p w)).
          rewrite <-BaseSystemProofs.mul_each_base, BaseSystemProofs.mul_each_rep.
          rewrite two_p_correct, (Z.mul_comm (2 ^ w)).
          rewrite <-Z.shiftl_mul_pow2 by auto using in_eq.
          rewrite bounded_iff in *.
          specialize (H 0%nat); rewrite !nth_default_cons in H.
          rewrite <-Z.lor_shiftl by (auto using in_eq; omega).
          apply Z.bits_inj'; intros n H0.
          rewrite Z.testbit_pow2_mod by auto using in_eq.
          break_if. {
            autorewrite with Ztestbit; break_match;
              try rewrite Z.testbit_neg_r with (n := n - w) by omega;
              autorewrite with bool_congr;
              f_equal; ring.
          } {
            replace a with (a mod 2 ^ w) by (auto using Z.mod_small).
            apply Z.mod_pow2_bits_high. split; auto using in_eq; omega.
          }
      - rewrite nth_default_cons_S.
        destruct limb_widths as [|w lw].
        * cbv [base_from_limb_widths].
          rewrite <-pow2_mod_bounded with (lw := nil); rewrite bounded_nil_iff in *; auto using in_cons.
          rewrite sum_firstn_nil, !nth_default_nil, BaseSystemProofs.decode_base_nil, Z.shiftr_0_r.
          apply nth_default_preserves_properties; intros; auto using in_cons.
          f_equal; auto using in_cons.
        * rewrite sum_firstn_succ_cons, nth_default_cons_S, base_from_limb_widths_cons, BaseSystemProofs.peel_decode.
          fold (BaseSystem.mul_each (two_p w)).
          rewrite <-BaseSystemProofs.mul_each_base, BaseSystemProofs.mul_each_rep.
          rewrite two_p_correct, (Z.mul_comm (2 ^ w)).
          rewrite <-Z.shiftl_mul_pow2 by auto using in_eq.
          rewrite bounded_iff in *.
          rewrite Z.shiftr_add_shiftl_high by first
            [ pose proof (sum_firstn_nonnegative i lw); split; auto using in_eq; specialize_by auto using in_cons; omega
            | specialize (H 0%nat); rewrite !nth_default_cons in H; omega ].
          rewrite IHus with (limb_widths := lw) by
              (auto using in_cons; rewrite ?bounded_iff; intro j; specialize (H (S j));
               rewrite !nth_default_cons_S in H; assumption).
          repeat f_equal; try ring.
  Qed.

  Lemma nth_default_limb_widths_nonneg : forall i, 0 <= nth_default 0 limb_widths i.
  Proof using Type*.
    intros; apply nth_default_preserves_properties; auto; omega.
  Qed. Hint Resolve nth_default_limb_widths_nonneg.

  Lemma decode_firstn_pow2_mod : forall us i,
    (i <= length us)%nat ->
    length us = length limb_widths ->
    bounded limb_widths us ->
    BaseSystem.decode' base (firstn i us) = Z.pow2_mod (BaseSystem.decode' base us) (sum_firstn limb_widths i).
  Proof using Type*.
    intros us i H H0 H1; induction i;
    repeat match goal with
           | |- _ => rewrite sum_firstn_0, BaseSystemProofs.decode_nil, Z.pow2_mod_0_r; reflexivity
           | |- _ => progress distr_length
           | |- _ => progress autorewrite with simpl_firstn
           | |- _ => rewrite firstn_succ with (d := 0)
           | |- _ => rewrite BaseSystemProofs.set_higher
           | |- _ => rewrite nth_default_base
           | |- _ => rewrite IHi
           | |- _ => rewrite <-Z.lor_shiftl by (rewrite ?Z.pow2_mod_spec; try apply Z.mod_pos_bound; zero_bounds)
           | |- context[min ?x ?y] => (rewrite Nat.min_l by omega || rewrite Nat.min_r by omega)
           | |- context[2 ^ ?a * _] => rewrite (Z.mul_comm (2 ^ a)); rewrite <-Z.shiftl_mul_pow2
           | |- _ => solve [auto]
           | |- _ => lia
           end.
    rewrite digit_select by assumption; apply Z.bits_inj'.
    repeat match goal with
           | |- _ => progress intros
           | |- _ => progress autorewrite with Ztestbit
           | |- _ => rewrite Z.testbit_pow2_mod by (omega || trivial)
           | |- _ => break_if; try omega
           | H : ?a < ?b |- context[Z.testbit _ (?a - ?b)] =>
             rewrite (Z.testbit_neg_r _ (a-b)) by omega
           | |- _ => reflexivity
           | |- _ => solve [f_equal; ring]
           | |- _ => rewrite sum_firstn_succ_default in *;
                       pose proof (nth_default_limb_widths_nonneg i); omega
           end.
  Qed.

  Lemma testbit_decode_firstn_high : forall us i n,
    (i <= length us)%nat ->
    length us = length limb_widths ->
    bounded limb_widths us ->
    sum_firstn limb_widths i <= n ->
    Z.testbit (BaseSystem.decode base (firstn i us)) n = false.
  Proof using Type*.
    repeat match goal with
           | |- _ => progress intros
           | |- _ => progress autorewrite with Ztestbit
           | |- _ => rewrite decode_firstn_pow2_mod
           | |- _ => rewrite Z.testbit_pow2_mod
           | |- _ => break_if
           | |- _ => assumption
           | |- _ => solve [auto]
           | H : ?a <= ?b |- 0 <= ?b => assert (0 <= a) by (omega || auto); omega
           end.
  Qed.

  Lemma testbit_decode_high : forall us n,
    length us = length limb_widths ->
    bounded limb_widths us ->
    sum_firstn limb_widths (length us) <= n ->
    Z.testbit (BaseSystem.decode base us) n = false.
  Proof using Type*.
    intros us n H H0 H1.
    erewrite <-(firstn_all _ us) by reflexivity.
    auto using testbit_decode_firstn_high.
  Qed.

  (** TODO: Figure out how to automate and clean up this proof *)
  Lemma decode_nonneg : forall us,
    length us = length limb_widths ->
    bounded limb_widths us ->
    0 <= BaseSystem.decode base us.
  Proof using Type*.
    intros us H H0.
    unfold bounded, BaseSystem.decode, BaseSystem.decode' in *; simpl in *.
    pose 0 as zero.
    assert (0 <= zero) by reflexivity.
    replace base with (map (Z.mul (two_p zero)) base)
      by (etransitivity; [ | apply map_id ]; apply map_ext; auto with zarith).
    clearbody zero.
    revert dependent zero.
    generalize dependent limb_widths.
    induction us as [|u us IHus]; intros [|w limb_widths'] ?? Hbounded ??; simpl in *;
      try (reflexivity || congruence).
    pose proof (Hbounded 0%nat) as Hbounded0.
    pose proof (fun n => Hbounded (S n)) as HboundedS.
    unfold nth_default, nth_error in Hbounded0.
    unfold nth_default in HboundedS.
    rewrite map_map.
    unfold BaseSystem.accumulate at 1; simpl.
    assert (0 < two_p zero) by (rewrite two_p_equiv; auto with zarith).
    replace (map (fun x => two_p zero * (two_p w * x)) (base_from_limb_widths limb_widths')) with (map (Z.mul (two_p (zero + w))) (base_from_limb_widths limb_widths'))
      by (apply map_ext; rewrite two_p_is_exp by auto with zarith omega; auto with zarith).
    change 0 with (0 + 0) at 1.
    apply Z.add_le_mono; simpl in *; auto with zarith.
  Qed.

  Lemma decode_upper_bound : forall us,
    length us = length limb_widths ->
    bounded limb_widths us ->
    0 <= BaseSystem.decode base us < upper_bound limb_widths.
  Proof using Type*.
    cbv [upper_bound]; intros us H H0.
    split.
    { apply decode_nonneg; auto. }
    { apply Z.testbit_false_bound; auto; intros.
      rewrite testbit_decode_high; auto;
        replace (length us) with (length limb_widths); try omega. }
  Qed.

  Lemma decode_shift_app : forall us0 us1, (length (us0 ++ us1) <= length limb_widths)%nat ->
    BaseSystem.decode base (us0 ++ us1) = (BaseSystem.decode (base_from_limb_widths (firstn (length us0) limb_widths)) us0) + ((BaseSystem.decode (base_from_limb_widths (skipn (length us0) limb_widths)) us1) << sum_firstn limb_widths (length us0)).
  Proof using Type*.
    unfold BaseSystem.decode; intros us0 us1 ?.
    assert (0 <= sum_firstn limb_widths (length us0)) by auto using sum_firstn_nonnegative.
    rewrite BaseSystemProofs.decode'_splice; autorewrite with push_firstn.
    apply Z.add_cancel_l.
    autorewrite with pull_base_from_limb_widths Zshift_to_pow zsimplify.
    rewrite BaseSystemProofs.decode'_map_mul, two_p_correct; nia.
  Qed.

  Lemma decode_shift : forall us u0, (length (u0 :: us) <= length limb_widths)%nat ->
    BaseSystem.decode base (u0 :: us) = u0 + ((BaseSystem.decode (base_from_limb_widths (tl limb_widths)) us) << (nth_default 0 limb_widths 0)).
  Proof using Type*.
    intros us u0 H; etransitivity; [ apply (decode_shift_app (u0::nil)); assumption | ].
    transitivity (u0 * 1 + 0 + ((BaseSystem.decode (base_from_limb_widths (tl limb_widths)) us) << (nth_default 0 limb_widths 0 + 0))); [ | autorewrite with zsimplify; reflexivity ].
    destruct limb_widths; distr_length; reflexivity.
  Qed.

  Lemma upper_bound_nil : upper_bound nil = 1.
  Proof using Type. reflexivity. Qed.

  Lemma upper_bound_cons x xs : 0 <= x -> 0 <= sum_firstn xs (length xs) -> upper_bound (x::xs) = 2^x * upper_bound xs.
  Proof using Type.
    intros Hx Hxs.
    unfold upper_bound; simpl.
    autorewrite with simpl_sum_firstn pull_Zpow.
    reflexivity.
  Qed.

  Lemma upper_bound_app xs ys : 0 <= sum_firstn xs (length xs) -> 0 <= sum_firstn ys (length ys) -> upper_bound (xs ++ ys) = upper_bound xs * upper_bound ys.
  Proof using Type.
    intros Hxs Hys.
    unfold upper_bound; simpl.
    autorewrite with distr_length simpl_sum_firstn pull_Zpow.
    reflexivity.
  Qed.

End Pow2BaseProofs.
Hint Rewrite base_from_limb_widths_cons base_from_limb_widths_nil : push_base_from_limb_widths.
Hint Rewrite <- base_from_limb_widths_cons : pull_base_from_limb_widths.

Hint Rewrite <- @firstn_base_from_limb_widths : push_base_from_limb_widths.
Hint Rewrite <- @firstn_base_from_limb_widths : pull_firstn.
Hint Rewrite @firstn_base_from_limb_widths : pull_base_from_limb_widths.
Hint Rewrite @firstn_base_from_limb_widths : push_firstn.
Hint Rewrite <- @skipn_base_from_limb_widths : push_base_from_limb_widths.
Hint Rewrite <- @skipn_base_from_limb_widths : pull_skipn.
Hint Rewrite @skipn_base_from_limb_widths : pull_base_from_limb_widths.
Hint Rewrite @skipn_base_from_limb_widths : push_skipn.

Hint Rewrite @base_from_limb_widths_length : distr_length.
Hint Rewrite @upper_bound_nil @upper_bound_cons @upper_bound_app using solve [ eauto with znonzero ] : push_upper_bound.
Hint Rewrite <- @upper_bound_cons @upper_bound_app using solve [ eauto with znonzero ] : pull_upper_bound.

Section UniformBase.
  Context {width : Z} (limb_width_nonneg : 0 <= width).
  Context (limb_widths : list Z)
    (limb_widths_uniform : forall w, In w limb_widths -> w = width).
  Local Notation base := (base_from_limb_widths limb_widths).

   Lemma bounded_uniform : forall us, (length us <= length limb_widths)%nat ->
     (bounded limb_widths us <-> (forall u, In u us -> 0 <= u < 2 ^ width)).
   Proof using Type*.
     cbv [bounded]; intros us H; split; intro A; [ intros u H0 | intros i ].
     + let G := fresh "G" in
       match goal with H : In _ us |- _ =>
         eapply In_nth in H; destruct H as [x G]; destruct G as [? G];
         rewrite <-nth_default_eq in G; rewrite <-G end.
       specialize (A x).
       split; try eapply A.
       eapply Z.lt_le_trans; try apply A.
       apply nth_default_preserves_properties; [ | apply Z.pow_le_mono_r; omega ] .
       intros; apply Z.eq_le_incl.
       f_equal; auto.
     + apply nth_default_preserves_properties_length_dep;
         try solve [apply nth_default_preserves_properties; split; zero_bounds; rewrite limb_widths_uniform; auto || omega].
      intros; apply nth_default_preserves_properties_length_dep; try solve [intros; omega].
       let x := fresh "x" in intro x; intros;
         replace x with width; try symmetry; auto.
   Qed.

  Lemma uniform_limb_widths_nonneg : forall w, In w limb_widths -> 0 <= w.
  Proof using Type*.
    intros w H.
    replace w with width by (symmetry; auto).
    assumption.
  Qed.

  Lemma nth_default_uniform_base_full : forall i,
      nth_default 0 limb_widths i = if lt_dec i (length limb_widths)
                                    then width else 0.
  Admitted.

  Lemma nth_default_uniform_base : forall i, (i < length limb_widths)%nat ->
      nth_default 0 limb_widths i = width.
  Proof using Type*.
    intros; rewrite nth_default_uniform_base_full.
    edestruct lt_dec; omega.
  Qed.

  Lemma sum_firstn_uniform_base : forall i, (i <= length limb_widths)%nat ->
                                            sum_firstn limb_widths i = Z.of_nat i * width.
  Proof using limb_widths_uniform.
    clear limb_width_nonneg. (* clear this before induction so we don't depend on this *)
    induction limb_widths as [|x xs IHxs]; (intros [|i] ?);
      simpl @length in *;
      autorewrite with simpl_sum_firstn push_Zof_nat zsimplify;
      try reflexivity;
      try omega.
    assert (x = width) by auto with datatypes; subst.
    rewrite IHxs by auto with datatypes omega; omega.
  Qed.

  Lemma sum_firstn_uniform_base_strong : forall i, (length limb_widths <= i)%nat ->
                                            sum_firstn limb_widths i = Z.of_nat (length limb_widths) * width.
  Proof using limb_widths_uniform.
    intros; rewrite sum_firstn_all, sum_firstn_uniform_base by omega; reflexivity.
  Qed.

  Lemma upper_bound_uniform : upper_bound limb_widths = 2^(Z.of_nat (length limb_widths) * width).
  Proof using limb_widths_uniform.
    unfold upper_bound; rewrite sum_firstn_uniform_base_strong by omega; reflexivity.
  Qed.

  (* TODO : move *)
  Lemma decode_truncate_base : forall us bs, BaseSystem.decode bs us = BaseSystem.decode (firstn (length us) bs) us.
  Proof using Type.
    clear.
    induction us as [|a us IHus]; intros bs.
    + rewrite !BaseSystemProofs.decode_nil; reflexivity.
    + distr_length.
      destruct bs.
      - rewrite firstn_nil, !BaseSystemProofs.decode_base_nil; reflexivity.
      - rewrite firstn_cons, !BaseSystemProofs.peel_decode.
        f_equal.
        apply IHus.
  Qed.

  (* TODO : move *)
  Lemma tl_repeat : forall {A} xs n (x : A), (forall y, In y xs -> y = x) ->
                                             (n < length xs)%nat ->
                                             firstn n xs = firstn n (tl xs).
  Proof using Type.
    intros A xs n x H H0.
    erewrite (repeat_spec_eq xs) by first [ eassumption | reflexivity ].
    rewrite ListUtil.tl_repeat.
    autorewrite with push_firstn.
    apply f_equal; omega *.
  Qed.

  Lemma decode_tl_base : forall us, (length us < length limb_widths)%nat ->
      BaseSystem.decode base us = BaseSystem.decode (base_from_limb_widths (tl limb_widths)) us.
  Proof using limb_widths_uniform.
    intros.
    match goal with |- BaseSystem.decode ?b1 _ = BaseSystem.decode ?b2 _ =>
      rewrite (decode_truncate_base _ b1), (decode_truncate_base _ b2) end.
    rewrite !firstn_base_from_limb_widths.
    do 2 f_equal.
    eauto using tl_repeat.
  Qed.

  Lemma decode_shift_uniform_tl : forall us u0, (length (u0 :: us) <= length limb_widths)%nat ->
    BaseSystem.decode base (u0 :: us) = u0 + ((BaseSystem.decode (base_from_limb_widths (tl limb_widths)) us) << width).
  Proof using Type*.
    intros.
    rewrite <- (nth_default_uniform_base 0) by distr_length.
    rewrite decode_shift by auto using uniform_limb_widths_nonneg.
    reflexivity.
  Qed.

  Lemma decode_shift_uniform_app : forall us0 us1, (length (us0 ++ us1) <= length limb_widths)%nat ->
    BaseSystem.decode base (us0 ++ us1) = (BaseSystem.decode (base_from_limb_widths (firstn (length us0) limb_widths)) us0) + ((BaseSystem.decode (base_from_limb_widths (skipn (length us0) limb_widths)) us1) << (Z.of_nat (length us0) * width)).
  Proof using Type*.
    intros.
    rewrite <- sum_firstn_uniform_base by (distr_length; omega).
    rewrite decode_shift_app by auto using uniform_limb_widths_nonneg.
    reflexivity.
  Qed.
End UniformBase.


From FormalSystems Require Export Imp.Syntax.
From FormalSystems Require Imp.Smallstep.
From FormalSystems Require Imp.Bigstep.

Lemma Bigstep_Smallstep_AExp :
  forall (s : State) (a : AExp) (n : nat),
    Bigstep.AEval a s n <-> Smallstep.AEvals s a (AConst n).
Proof.
  split; intro.
    apply Bigstep.AEval_aeval in H. apply Smallstep.aeval_AEvals. assumption.
    apply Smallstep.AEvals_aeval in H. apply Bigstep.aeval_AEval. assumption.
Qed.

Lemma Bigstep_Smallstep_BExp :
  forall (s : State) (e : BExp) (b : bool),
    Bigstep.BEval e s b <-> Smallstep.BEvals s e (BConst b).
Proof.
  split; intro.
    apply Bigstep.BEval_beval in H. apply Smallstep.beval_BEvals. assumption.
    apply Smallstep.BEvals_beval in H. apply Bigstep.beval_BEval. assumption.
Qed.

Lemma Bigstep_Smallstep_Com :
  forall (c : Com) (s1 s2 : State),
    Bigstep.CEval c s1 s2 <-> Smallstep.CEvals (c, s1) (Skip, s2).
Proof.
  split; intro.
    apply Bigstep.CEval_ceval in H. destruct H as [n H].
      eapply Smallstep.ceval_CEvals. eassumption.
    apply Smallstep.CEvals_ceval in H. destruct H as [n H].
      apply Bigstep.ceval_CEval with n. assumption.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sum of Data Structures                                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibBool.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Fixing implicit types *)

Arguments inl {A B}.
Arguments inr {A B}.

(* ********************************************************************** *)
(** * Inhabited *)

Instance sum_inhab_left : forall `{Inhab A} B, Inhab (A + B).
Proof using. intros. apply (prove_Inhab (inl arbitrary)). Qed.
Instance sum_inhab_right : forall `{Inhab B} A, Inhab (A + B).
Proof using. intros. apply (prove_Inhab (inr arbitrary)). Qed.

Definition sum_inhab : forall `{Inhab A, Inhab B}, Inhab (A + B).
Proof using. typeclass. Qed.

(* ********************************************************************** *)
(** * Operations *)

Section IsIn.
Variables (A B : Type).
Implicit Type x : A + B.

Definition is_inl x :=
  match x with
  | inl _ => true
  | inr _ => false
  end.

Definition is_inr x :=
  match x with
  | inl _ => false
  | inr _ => true
  end.

Lemma is_inl_neg_is_inr : forall x,
  is_inl x = ! (is_inr x).
Proof using. intros x. destruct~ x. Qed.

Lemma is_inr_neg_is_inl : forall x,
  is_inr x = ! (is_inl x).
Proof using. intros x. destruct~ x. Qed.

End IsIn.

(* ********************************************************************** *)
(** * Projections *)

(*-----------------------------------------------------*)
(** ** Stripping of the branch tag *)

Section Get.
Variables (A1 A2 : Type) (DA1:Inhab A1) (DA2:Inhab A2).
Implicit Types x : A1+A2.

Definition get21 x :=
  match x with
  | inl x1 => x1
  | inr x2 => arbitrary
  end.

Definition get22 x :=
  match x with
  | inl x1 => arbitrary
  | inr x2 => x2
  end.

End Get.

Arguments get21 {A1 A2 DA1}.
Arguments get22 {A1 A2 DA2}.

(*-----------------------------------------------------*)
(** ** Lifting functions over sum types *)

Section Fget.
Variables (A1 A2 B1 B2 : Type)
  (DB1:Inhab B1) (DB2:Inhab B2).
Implicit Types f : A1+A2->B1+B2.

Definition func_get21 f :=
  fun x => get21 (f (inl x)).
Definition func_get22 f :=
  fun x => get22 (f (inr x)).

End Fget.

Arguments func_get21 {A1 A2 B1 B2 DB1}.
Arguments func_get22 {A1 A2 B1 B2 DB2}.


From Hammer Require Import Hammer.

Require Export List.
Require Export Sorted.
Require Export Setoid Basics Morphisms.
Set Implicit Arguments.
Unset Strict Implicit.

Section Type_with_equality.
Variable A : Type.
Variable eqA : A -> A -> Prop.

Inductive InA (x : A) : list A -> Prop :=
| InA_cons_hd : forall y l, eqA x y -> InA x (y :: l)
| InA_cons_tl : forall y l, InA x l -> InA x (y :: l).

Hint Constructors InA.

Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l.
Proof. hammer_hook "SetoidList" "SetoidList.InA_altdef".   split; induction 1; auto. Qed.

Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l.
Proof. hammer_hook "SetoidList" "SetoidList.InA_cons".
intuition. invlist InA; auto.
Qed.

Lemma InA_nil : forall x, InA x nil <-> False.
Proof. hammer_hook "SetoidList" "SetoidList.InA_nil".
intuition. invlist InA.
Qed.

Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l.
Proof. hammer_hook "SetoidList" "SetoidList.InA_alt".
intros; rewrite InA_altdef, Exists_exists; firstorder.
Qed.

Inductive NoDupA : list A -> Prop :=
| NoDupA_nil : NoDupA nil
| NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l).

Hint Constructors NoDupA.

Lemma NoDupA_altdef : forall l,
NoDupA l <-> ForallOrdPairs (complement eqA) l.
Proof. hammer_hook "SetoidList" "SetoidList.NoDupA_altdef".
split; induction 1; constructor; auto.
rewrite Forall_forall. intros b Hb.
intro Eq; elim H. rewrite InA_alt. exists b; auto.
rewrite InA_alt; intros (a' & Haa' & Ha').
rewrite Forall_forall in H. exact (H a' Ha' Haa').
Qed.

Definition inclA l l' := forall x, InA x l -> InA x l'.
Definition equivlistA l l' := forall x, InA x l <-> InA x l'.

Lemma incl_nil l : inclA nil l.
Proof. hammer_hook "SetoidList" "SetoidList.incl_nil".   intro. intros. inversion H. Qed.
Hint Resolve incl_nil : list.

Inductive eqlistA : list A -> list A -> Prop :=
| eqlistA_nil : eqlistA nil nil
| eqlistA_cons : forall x x' l l',
eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l').

Hint Constructors eqlistA.

Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'.
Proof. hammer_hook "SetoidList" "SetoidList.eqlistA_altdef".   split; induction 1; auto. Qed.

Hypothesis eqA_equiv : Equivalence eqA.
Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv).
Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv).
Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv).

Hint Resolve eqarefl eqatrans.
Hint Immediate eqasym.

Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA.

Global Instance equivlist_equiv : Equivalence equivlistA.
Proof. hammer_hook "SetoidList" "SetoidList.equivlist_equiv".
firstorder.
Qed.

Global Instance eqlistA_equiv : Equivalence eqlistA.
Proof. hammer_hook "SetoidList" "SetoidList.eqlistA_equiv".
constructor; red.
induction x; auto.
induction 1; auto.
intros x y z H; revert z; induction H; auto.
inversion 1; subst; auto. invlist eqlistA; eauto with *.
Qed.

Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA.
Proof. hammer_hook "SetoidList" "SetoidList.eqlistA_equivlistA".
intros x x' H. induction H.
intuition.
red; intros.
rewrite 2 InA_cons.
rewrite (IHeqlistA x0), H; intuition.
Qed.

Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA.
Proof. hammer_hook "SetoidList" "SetoidList.InA_compat".
intros x x' Hxx' l l' Hll'. rewrite (Hll' x).
rewrite 2 InA_alt; firstorder.
Qed.

Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l.
Proof. hammer_hook "SetoidList" "SetoidList.InA_eqA".
intros l x y H H'. rewrite <- H. auto.
Qed.
Hint Immediate InA_eqA.

Lemma In_InA : forall l x, In x l -> InA x l.
Proof. hammer_hook "SetoidList" "SetoidList.In_InA".
simple induction l; simpl; intuition.
subst; auto.
Qed.
Hint Resolve In_InA.

Lemma InA_split : forall l x, InA x l ->
exists l1 y l2, eqA x y /\ l = l1++y::l2.
Proof. hammer_hook "SetoidList" "SetoidList.InA_split".
induction l; intros; inv.
exists (@nil A); exists a; exists l; auto.
destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))).
exists (a::l1); exists y; exists l2; auto.
split; simpl; f_equal; auto.
Qed.

Lemma InA_app : forall l1 l2 x,
InA x (l1 ++ l2) -> InA x l1 \/ InA x l2.
Proof. hammer_hook "SetoidList" "SetoidList.InA_app".
induction l1; simpl in *; intuition.
inv; auto.
elim (IHl1 l2 x H0); auto.
Qed.

Lemma InA_app_iff : forall l1 l2 x,
InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2.
Proof. hammer_hook "SetoidList" "SetoidList.InA_app_iff".
split.
apply InA_app.
destruct 1; generalize H; do 2 rewrite InA_alt.
destruct 1 as (y,(H1,H2)); exists y; split; auto.
apply in_or_app; auto.
destruct 1 as (y,(H1,H2)); exists y; split; auto.
apply in_or_app; auto.
Qed.

Lemma InA_rev : forall p m,
InA p (rev m) <-> InA p m.
Proof. hammer_hook "SetoidList" "SetoidList.InA_rev".
intros; do 2 rewrite InA_alt.
split; intros (y,H); exists y; intuition.
rewrite In_rev; auto.
rewrite <- In_rev; auto.
Qed.

Lemma InA_singleton x y : InA x (y::nil) <-> eqA x y.
Proof. hammer_hook "SetoidList" "SetoidList.InA_singleton".
rewrite InA_cons, InA_nil; tauto.
Qed.

Lemma InA_double_head x y l :
InA x (y :: y :: l) <-> InA x (y :: l).
Proof. hammer_hook "SetoidList" "SetoidList.InA_double_head".
rewrite !InA_cons; tauto.
Qed.

Lemma InA_permute_heads x y z l :
InA x (y :: z :: l) <-> InA x (z :: y :: l).
Proof. hammer_hook "SetoidList" "SetoidList.InA_permute_heads".
rewrite !InA_cons; tauto.
Qed.

Lemma InA_app_idem x l : InA x (l ++ l) <-> InA x l.
Proof. hammer_hook "SetoidList" "SetoidList.InA_app_idem".
rewrite InA_app_iff; tauto.
Qed.

Section NoDupA.

Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' ->
(forall x, InA x l -> InA x l' -> False) ->
NoDupA (l++l').
Proof. hammer_hook "SetoidList" "SetoidList.NoDupA_app".
induction l; simpl; auto; intros.
inv.
constructor.
rewrite InA_alt; intros (y,(H4,H5)).
destruct (in_app_or _ _ _ H5).
elim H2.
rewrite InA_alt.
exists y; auto.
apply (H1 a).
auto.
rewrite InA_alt.
exists y; auto.
apply IHl; auto.
intros.
apply (H1 x); auto.
Qed.

Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l).
Proof. hammer_hook "SetoidList" "SetoidList.NoDupA_rev".
induction l.
simpl; auto.
simpl; intros.
inv.
apply NoDupA_app; auto.
constructor; auto.
intro; inv.
intros x.
rewrite InA_alt.
intros (x1,(H2,H3)).
intro; inv.
destruct H0.
rewrite <- H4, H2.
apply In_InA.
rewrite In_rev; auto.
Qed.

Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l').
Proof. hammer_hook "SetoidList" "SetoidList.NoDupA_split".
induction l; simpl in *; intros; inv; auto.
constructor; eauto.
contradict H0.
rewrite InA_app_iff in *.
rewrite InA_cons.
intuition.
Qed.

Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l').
Proof. hammer_hook "SetoidList" "SetoidList.NoDupA_swap".
induction l; simpl in *; intros; inv; auto.
constructor; eauto.
assert (H2:=IHl _ _ H1).
inv.
rewrite InA_cons.
red; destruct 1.
apply H0.
rewrite InA_app_iff in *; rewrite InA_cons; auto.
apply H; auto.
constructor.
contradict H0.
rewrite InA_app_iff in *; rewrite InA_cons; intuition.
eapply NoDupA_split; eauto.
Qed.

Lemma NoDupA_singleton x : NoDupA (x::nil).
Proof. hammer_hook "SetoidList" "SetoidList.NoDupA_singleton".
repeat constructor. inversion 1.
Qed.

End NoDupA.

Section EquivlistA.

Global Instance equivlistA_cons_proper:
Proper (eqA ==> equivlistA ==> equivlistA) (@cons A).
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_cons_proper".
intros ? ? E1 ? ? E2 ?; now rewrite !InA_cons, E1, E2.
Qed.

Global Instance equivlistA_app_proper:
Proper (equivlistA ==> equivlistA ==> equivlistA) (@app A).
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_app_proper".
intros ? ? E1 ? ? E2 ?. now rewrite !InA_app_iff, E1, E2.
Qed.

Lemma equivlistA_cons_nil x l : ~ equivlistA (x :: l) nil.
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_cons_nil".
intros E. now eapply InA_nil, E, InA_cons_hd.
Qed.

Lemma equivlistA_nil_eq l : equivlistA l nil -> l = nil.
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_nil_eq".
destruct l.
- trivial.
- intros H. now apply equivlistA_cons_nil in H.
Qed.

Lemma equivlistA_double_head x l : equivlistA (x :: x :: l) (x :: l).
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_double_head".
intro. apply InA_double_head.
Qed.

Lemma equivlistA_permute_heads x y l :
equivlistA (x :: y :: l) (y :: x :: l).
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_permute_heads".
intro. apply InA_permute_heads.
Qed.

Lemma equivlistA_app_idem l : equivlistA (l ++ l) l.
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_app_idem".
intro. apply InA_app_idem.
Qed.

Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y ->
NoDupA (x::l) -> NoDupA (l1++y::l2) ->
equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2).
Proof. hammer_hook "SetoidList" "SetoidList.equivlistA_NoDupA_split".
intros; intro a.
generalize (H2 a).
rewrite !InA_app_iff, !InA_cons.
inv.
assert (SW:=NoDupA_swap H1). inv.
rewrite InA_app_iff in H0.
split; intros.
assert (~eqA a x) by (contradict H3; rewrite <- H3; auto).
assert (~eqA a y) by (rewrite <- H; auto).
tauto.
assert (OR : eqA a x \/ InA a l) by intuition. clear H6.
destruct OR as [EQN|INA]; auto.
elim H0.
rewrite <-H,<-EQN; auto.
Qed.

End EquivlistA.

Section Fold.

Variable B:Type.
Variable eqB:B->B->Prop.
Variable st:Equivalence eqB.
Variable f:A->B->B.
Variable i:B.
Variable Comp:Proper (eqA==>eqB==>eqB) f.

Lemma fold_right_eqlistA :
forall s s', eqlistA s s' ->
eqB (fold_right f i s) (fold_right f i s').
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_eqlistA".
induction 1; simpl; auto with relations.
apply Comp; auto.
Qed.

Section Fold_With_Restriction.
Variable R : A -> A -> Prop.
Hypothesis R_sym : Symmetric R.
Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.

Lemma ForallOrdPairs_inclA : forall l l',
NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'.
Proof. hammer_hook "SetoidList" "SetoidList.ForallOrdPairs_inclA".
induction l' as [|x l' IH].
constructor.
intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto.
rewrite Forall_forall; intros y Hy.
assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto).
apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx').
assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto).
apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy').
rewrite Hxx', Hyy'.
destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto.
absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto.
Qed.

Definition transpose (f : A -> B -> B) :=
forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)).

Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) :=
forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)).

Variable TraR :transpose_restr R f.

Lemma fold_right_commutes_restr :
forall s1 s2 x, ForallOrdPairs R (s1++x::s2) ->
eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_commutes_restr".
induction s1; simpl; auto; intros.
reflexivity.
transitivity (f a (f x (fold_right f i (s1++s2)))).
apply Comp; auto.
apply IHs1.
invlist ForallOrdPairs; auto.
apply TraR.
invlist ForallOrdPairs; auto.
rewrite Forall_forall in H0; apply H0.
apply in_or_app; simpl; auto.
Qed.

Lemma fold_right_equivlistA_restr :
forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_equivlistA_restr".
simple induction s.
destruct s'; simpl.
intros; reflexivity.
unfold equivlistA; intros.
destruct (H2 a).
assert (InA a nil) by auto; inv.
intros x l Hrec s' N N' F E; simpl in *.
assert (InA x s') by (rewrite <- (E x); auto).
destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
subst s'.
transitivity (f x (fold_right f i (s1++s2))).
apply Comp; auto.
apply Hrec; auto.
inv; auto.
eapply NoDupA_split; eauto.
invlist ForallOrdPairs; auto.
eapply equivlistA_NoDupA_split; eauto.
transitivity (f y (fold_right f i (s1++s2))).
apply Comp; auto. reflexivity.
symmetry; apply fold_right_commutes_restr.
apply ForallOrdPairs_inclA with (x::l); auto.
red; intros; rewrite E; auto.
Qed.

Lemma fold_right_add_restr :
forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s ->
equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_add_restr".
intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto.
Qed.

End Fold_With_Restriction.

Variable Tra :transpose f.

Lemma fold_right_commutes : forall s1 s2 x,
eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_commutes".
induction s1; simpl; auto; intros.
reflexivity.
transitivity (f a (f x (fold_right f i (s1++s2)))); auto.
apply Comp; auto.
Qed.

Lemma fold_right_equivlistA :
forall s s', NoDupA s -> NoDupA s' ->
equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_equivlistA".
intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True);
repeat red; auto.
apply ForallPairs_ForallOrdPairs; try red; auto.
Qed.

Lemma fold_right_add :
forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s ->
equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_add".
intros; apply (@fold_right_equivlistA s' (x::s)); auto.
Qed.

End Fold.

Section Fold2.

Variable B:Type.
Variable eqB:B->B->Prop.
Variable st:Equivalence eqB.
Variable f:A->B->B.
Variable Comp:Proper (eqA==>eqB==>eqB) f.

Lemma fold_right_eqlistA2 :
forall s s' (i j:B) (heqij: eqB i j) (heqss': eqlistA s s'),
eqB (fold_right f i s) (fold_right f j s').
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_eqlistA2".
intros s.
induction s;intros.
- inversion heqss'.
subst.
simpl.
assumption.
- inversion heqss'.
subst.
simpl.
apply Comp.
+ assumption.
+ apply IHs;assumption.
Qed.

Section Fold2_With_Restriction.

Variable R : A -> A -> Prop.
Hypothesis R_sym : Symmetric R.
Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.

Definition transpose2 (f : A -> B -> B) :=
forall (x y : A) (z z': B), eqB z z' -> eqB (f x (f y z)) (f y (f x z')).

Definition transpose_restr2 (R : A -> A -> Prop)(f : A -> B -> B) :=
forall (x y : A) (z z': B), R x y -> eqB z z' -> eqB (f x (f y z)) (f y (f x z')).

Variable TraR :transpose_restr2 R f.

Lemma fold_right_commutes_restr2 :
forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) ->
eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_commutes_restr2".
induction s1; simpl; auto; intros.
- apply Comp.
+ destruct eqA_equiv. apply Equivalence_Reflexive.
+ eapply fold_right_eqlistA2.
* assumption.
* reflexivity.
- transitivity (f a (f x (fold_right f j (s1++s2)))).
apply Comp; auto.
eapply IHs1.
assumption.
invlist ForallOrdPairs; auto.
apply TraR.
invlist ForallOrdPairs; auto.
rewrite Forall_forall in H0; apply H0.
apply in_or_app; simpl; auto.
reflexivity.
Qed.

Lemma fold_right_equivlistA_restr2 :
forall s s' i j,
NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
equivlistA s s' -> eqB i j ->
eqB (fold_right f i s) (fold_right f j s').
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_equivlistA_restr2".
simple induction s.
destruct s'; simpl.
intros. assumption.
unfold equivlistA; intros.
destruct (H2 a).
assert (InA a nil) by auto; inv.
intros x l Hrec s' i j N N' F E eqij; simpl in *.
assert (InA x s') by (rewrite <- (E x); auto).
destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
subst s'.
transitivity (f x (fold_right f j (s1++s2))).
- apply Comp; auto.
apply Hrec; auto.
inv; auto.
eapply NoDupA_split; eauto.
invlist ForallOrdPairs; auto.
eapply equivlistA_NoDupA_split; eauto.
- transitivity (f y (fold_right f i (s1++s2))).
+ apply Comp; auto.
symmetry.
apply fold_right_eqlistA2.
* assumption.
* reflexivity.
+ symmetry.
apply fold_right_commutes_restr2.
symmetry.
assumption.
apply ForallOrdPairs_inclA with (x::l); auto.
red; intros; rewrite E; auto.
Qed.

Lemma fold_right_add_restr2 :
forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s ->
equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_add_restr2".
intros; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto.
Qed.

End Fold2_With_Restriction.

Variable Tra :transpose2 f.

Lemma fold_right_commutes2 : forall s1 s2 i x x',
eqA x x' ->
eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_commutes2".
induction s1;simpl;intros.
- apply Comp;auto.
reflexivity.
- transitivity (f a (f x' (fold_right f i (s1++s2)))); auto.
+ apply Comp;auto.
+ apply Tra.
reflexivity.
Qed.

Lemma fold_right_equivlistA2 :
forall s s' i j, NoDupA s -> NoDupA s' -> eqB i j ->
equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s').
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_equivlistA2".
red in Tra.
intros; apply fold_right_equivlistA_restr2 with (R:=fun _ _ => True);
repeat red; auto.
apply ForallPairs_ForallOrdPairs; try red; auto.
Qed.

Lemma fold_right_add2 :
forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s ->
equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
Proof. hammer_hook "SetoidList" "SetoidList.fold_right_add2".
intros.
replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto.
eapply fold_right_equivlistA2;auto.
Qed.

End Fold2.

Section Remove.

Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.

Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }.
Proof. hammer_hook "SetoidList" "SetoidList.InA_dec".
induction l.
right; auto.
intro; inv.
destruct (eqA_dec x a).
left; auto.
destruct IHl.
left; auto.
right; intro; inv; contradiction.
Defined.

Fixpoint removeA (x : A) (l : list A) : list A :=
match l with
| nil => nil
| y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl)
end.

Lemma removeA_filter : forall x l,
removeA x l = filter (fun y => if eqA_dec x y then false else true) l.
Proof. hammer_hook "SetoidList" "SetoidList.removeA_filter".
induction l; simpl; auto.
destruct (eqA_dec x a); auto.
rewrite IHl; auto.
Qed.

Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y.
Proof. hammer_hook "SetoidList" "SetoidList.removeA_InA".
induction l; simpl; auto.
split.
intro; inv.
destruct 1; inv.
intros.
destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto.
rewrite IHl; split; destruct 1; split; auto.
inv; auto.
destruct H0; transitivity a; auto.
split.
intro; inv.
split; auto.
contradict Hnot.
transitivity y; auto.
rewrite (IHl x y) in H0; destruct H0; auto.
destruct 1; inv; auto.
right; rewrite IHl; auto.
Qed.

Lemma removeA_NoDupA :
forall s x, NoDupA s ->  NoDupA (removeA x s).
Proof. hammer_hook "SetoidList" "SetoidList.removeA_NoDupA".
simple induction s; simpl; intros.
auto.
inv.
destruct (eqA_dec x a); simpl; auto.
constructor; auto.
rewrite removeA_InA.
intuition.
Qed.

Lemma removeA_equivlistA : forall l l' x,
~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l').
Proof. hammer_hook "SetoidList" "SetoidList.removeA_equivlistA".
unfold equivlistA; intros.
rewrite removeA_InA.
split; intros.
rewrite <- H0; split; auto.
contradict H.
apply InA_eqA with x0; auto.
rewrite <- (H0 x0) in H1.
destruct H1.
inv; auto.
elim H2; auto.
Qed.

End Remove.

Variable ltA : A -> A -> Prop.
Hypothesis ltA_strorder : StrictOrder ltA.
Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA.

Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder).

Hint Resolve sotrans.

Notation InfA:=(lelistA ltA).
Notation SortA:=(sort ltA).

Hint Constructors lelistA sort.

Lemma InfA_ltA :
forall l x y, ltA x y -> InfA y l -> InfA x l.
Proof. hammer_hook "SetoidList" "SetoidList.InfA_ltA".
destruct l; constructor. inv; eauto.
Qed.

Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA.
Proof using eqA_equiv ltA_compat. hammer_hook "SetoidList" "SetoidList.InfA_compat".
intros x x' Hxx' l l' Hll'.
inversion_clear Hll'.
intuition.
split; intro; inv; constructor.
rewrite <- Hxx', <- H; auto.
rewrite Hxx', H; auto.
Qed.

Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l.
Proof using eqA_equiv ltA_compat. hammer_hook "SetoidList" "SetoidList.InfA_eqA".
intros H; now rewrite H.
Qed.
Hint Immediate InfA_ltA InfA_eqA.

Lemma SortA_InfA_InA :
forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x.
Proof. hammer_hook "SetoidList" "SetoidList.SortA_InfA_InA".
simple induction l.
intros. inv.
intros. inv.
setoid_replace x with a; auto.
eauto.
Qed.

Lemma In_InfA :
forall l x, (forall y, In y l -> ltA x y) -> InfA x l.
Proof. hammer_hook "SetoidList" "SetoidList.In_InfA".
simple induction l; simpl; intros; constructor; auto.
Qed.

Lemma InA_InfA :
forall l x, (forall y, InA y l -> ltA x y) -> InfA x l.
Proof. hammer_hook "SetoidList" "SetoidList.InA_InfA".
simple induction l; simpl; intros; constructor; auto.
Qed.

Lemma InfA_alt :
forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)).
Proof. hammer_hook "SetoidList" "SetoidList.InfA_alt".
split.
intros; eapply SortA_InfA_InA; eauto.
apply InA_InfA.
Qed.

Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2).
Proof. hammer_hook "SetoidList" "SetoidList.InfA_app".
induction l1; simpl; auto.
intros; inv; auto.
Qed.

Lemma SortA_app :
forall l1 l2, SortA l1 -> SortA l2 ->
(forall x y, InA x l1 -> InA y l2 -> ltA x y) ->
SortA (l1 ++ l2).
Proof. hammer_hook "SetoidList" "SetoidList.SortA_app".
induction l1; simpl in *; intuition.
inv.
constructor; auto.
apply InfA_app; auto.
destruct l2; auto.
Qed.

Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l.
Proof. hammer_hook "SetoidList" "SetoidList.SortA_NoDupA".
simple induction l; auto.
intros x l' H H0.
inv.
constructor; auto.
intro.
apply (StrictOrder_Irreflexive x).
eapply SortA_InfA_InA; eauto.
Qed.

Section EqlistA.

Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'.
Proof. hammer_hook "SetoidList" "SetoidList.eqlistA_length".
induction 1; auto; simpl; congruence.
Qed.

Global Instance app_eqlistA_compat :
Proper (eqlistA==>eqlistA==>eqlistA) (@app A).
Proof. hammer_hook "SetoidList" "SetoidList.app_eqlistA_compat".
repeat red; induction 1; simpl; auto.
Qed.

Lemma eqlistA_app : forall l1 l1' l2 l2',
eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2').
Proof. hammer_hook "SetoidList" "SetoidList.eqlistA_app".
intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity.
Qed.

Lemma eqlistA_rev_app : forall l1 l1',
eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' ->
eqlistA ((rev l1)++l2) ((rev l1')++l2').
Proof. hammer_hook "SetoidList" "SetoidList.eqlistA_rev_app".
induction 1; auto.
simpl; intros.
do 2 rewrite app_ass; simpl; auto.
Qed.

Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A).
Proof. hammer_hook "SetoidList" "SetoidList.rev_eqlistA_compat".
repeat red. intros.
rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)).
apply eqlistA_rev_app; auto.
Qed.

Lemma eqlistA_rev : forall l1 l1',
eqlistA l1 l1' -> eqlistA (rev l1) (rev l1').
Proof. hammer_hook "SetoidList" "SetoidList.eqlistA_rev".
apply rev_eqlistA_compat.
Qed.

Lemma SortA_equivlistA_eqlistA : forall l l',
SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'.
Proof. hammer_hook "SetoidList" "SetoidList.SortA_equivlistA_eqlistA".
induction l; destruct l'; simpl; intros; auto.
destruct (H1 a); assert (InA a nil) by auto; inv.
destruct (H1 a); assert (InA a nil) by auto; inv.
inv.
assert (forall y, InA y l -> ltA a y).
intros; eapply SortA_InfA_InA with (l:=l); eauto.
assert (forall y, InA y l' -> ltA a0 y).
intros; eapply SortA_InfA_InA with (l:=l'); eauto.
clear H3 H4.
assert (eqA a a0).
destruct (H1 a).
destruct (H1 a0).
assert (InA a (a0::l')) by auto. inv; auto.
assert (InA a0 (a::l)) by auto. inv; auto.
elim (StrictOrder_Irreflexive a); eauto.
constructor; auto.
apply IHl; auto.
split; intros.
destruct (H1 x).
assert (InA x (a0::l')) by auto. inv; auto.
rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto.
destruct (H1 x).
assert (InA x (a::l)) by auto. inv; auto.
rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto.
Qed.

End EqlistA.

Section Filter.

Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l).
Proof. hammer_hook "SetoidList" "SetoidList.filter_sort".
induction l; simpl; auto.
intros; inv; auto.
destruct (f a); auto.
constructor; auto.
apply In_InfA; auto.
intros.
rewrite filter_In in H; destruct H.
eapply SortA_InfA_InA; eauto.
Qed.
Arguments eq {A} x _.

Lemma filter_InA : forall f, Proper (eqA==>eq) f ->
forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
Proof. hammer_hook "SetoidList" "SetoidList.filter_InA".
clear sotrans ltA ltA_strorder ltA_compat.
intros; do 2 rewrite InA_alt; intuition.
destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition.
destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition.
rewrite (H _ _ H0); auto.
destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition.
rewrite <- (H _ _ H0); auto.
Qed.

Lemma filter_split :
forall f, (forall x y, f x = true -> f y = false -> ltA x y) ->
forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l.
Proof. hammer_hook "SetoidList" "SetoidList.filter_split".
induction l; simpl; intros; auto.
inv.
rewrite IHl at 1; auto.
case_eq (f a); simpl; intros; auto.
assert (forall e, In e l -> f e = false).
intros.
assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)).
case_eq (f e); simpl; intros; auto.
elim (StrictOrder_Irreflexive e).
transitivity a; auto.
replace (List.filter f l) with (@nil A); auto.
generalize H3; clear; induction l; simpl; auto.
case_eq (f a); auto; intros.
rewrite H3 in H; auto; try discriminate.
Qed.

End Filter.
End Type_with_equality.

Hint Constructors InA eqlistA NoDupA sort lelistA.

Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _.
Arguments equivlistA_nil_eq {A} eqA {eqA_equiv} l _.

Section Find.

Variable A B : Type.
Variable eqA : A -> A -> Prop.
Hypothesis eqA_equiv : Equivalence eqA.
Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.

Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B :=
match l with
| nil => None
| (a,b)::l => if f a then Some b else findA f l
end.

Lemma findA_NoDupA :
forall l a b,
NoDupA (fun p p' => eqA (fst p) (fst p')) l ->
(InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <->
findA (fun a' => if eqA_dec a a' then true else false) l = Some b).
Proof. hammer_hook "SetoidList" "SetoidList.findA_NoDupA".
set (eqk := fun p p' : A*B => eqA (fst p) (fst p')).
set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p').
induction l; intros; simpl.
split; intros; try discriminate.
invlist InA.
destruct a as (a',b'); rename a0 into a.
invlist NoDupA.
split; intros.
invlist InA.
compute in H2; destruct H2. subst b'.
destruct (eqA_dec a a'); intuition.
destruct (eqA_dec a a') as [HeqA|]; simpl.
contradict H0.
revert HeqA H2; clear - eqA_equiv.
induction l.
intros; invlist InA.
intros; invlist InA; auto.
destruct a0.
compute in H; destruct H.
subst b.
left; auto.
compute.
transitivity a; auto. symmetry; auto.
rewrite <- IHl; auto.
destruct (eqA_dec a a'); simpl in *.
left; split; simpl; congruence.
right. rewrite IHl; auto.
Qed.

End Find.

Definition compat_bool {A} (eqA:A->A->Prop)(f:A->bool) :=
Proper (eqA==>Logic.eq) f.

Definition compat_nat {A} (eqA:A->A->Prop)(f:A->nat) :=
Proper (eqA==>Logic.eq) f.

Definition compat_P {A} (eqA:A->A->Prop)(P:A->Prop) :=
Proper (eqA==>impl) P.

Definition compat_op {A B} (eqA:A->A->Prop)(eqB:B->B->Prop)(f:A->B->B) :=
Proper (eqA==>eqB==>eqB) f.


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

(** * Finite sets library *)

(** This functor derives additional facts from [MSetInterface.S]. These
  facts are mainly the specifications of [MSetInterface.S] written using
  different styles: equivalence and boolean equalities.
  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
*)

Require Import DecidableTypeEx.
Require Export MSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** First, a functor for Weak Sets in functorial version. *)

Module WFactsOn (Import E : DecidableType)(Import M : WSetsOn E).

Notation eq_dec := E.eq_dec.
Definition eqb x y := if eq_dec x y then true else false.

(** * Specifications written using implications :
      this used to be the default interface. *)

Section ImplSpec.
Variable s s' : t.
Variable x y : elt.

Lemma In_1 : E.eq x y -> In x s -> In y s.
Proof. intros E; rewrite E; auto. Qed.

Lemma mem_1 : In x s -> mem x s = true.
Proof. intros; apply <- mem_spec; auto. Qed.
Lemma mem_2 : mem x s = true -> In x s.
Proof. intros; apply -> mem_spec; auto. Qed.

Lemma equal_1 : Equal s s' -> equal s s' = true.
Proof. intros; apply <- equal_spec; auto. Qed.
Lemma equal_2 : equal s s' = true -> Equal s s'.
Proof. intros; apply -> equal_spec; auto. Qed.

Lemma subset_1 : Subset s s' -> subset s s' = true.
Proof. intros; apply <- subset_spec; auto. Qed.
Lemma subset_2 : subset s s' = true -> Subset s s'.
Proof. intros; apply -> subset_spec; auto. Qed.

Lemma is_empty_1 : Empty s -> is_empty s = true.
Proof. intros; apply <- is_empty_spec; auto. Qed.
Lemma is_empty_2 : is_empty s = true -> Empty s.
Proof. intros; apply -> is_empty_spec; auto. Qed.

Lemma add_1 : E.eq x y -> In y (add x s).
Proof. intros; apply <- add_spec. auto with relations. Qed.
Lemma add_2 : In y s -> In y (add x s).
Proof. intros; apply <- add_spec; auto. Qed.
Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto with relations. Qed.

Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
Proof. intros; rewrite remove_spec; intuition. Qed.
Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
Proof. intros; apply <- remove_spec; auto with relations. Qed.
Lemma remove_3 : In y (remove x s) -> In y s.
Proof. rewrite remove_spec; intuition. Qed.

Lemma singleton_1 : In y (singleton x) -> E.eq x y.
Proof. rewrite singleton_spec; auto with relations. Qed.
Lemma singleton_2 : E.eq x y -> In y (singleton x).
Proof. rewrite singleton_spec; auto with relations. Qed.

Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
Proof. rewrite union_spec; auto. Qed.
Lemma union_2 : In x s -> In x (union s s').
Proof. rewrite union_spec; auto. Qed.
Lemma union_3 : In x s' -> In x (union s s').
Proof. rewrite union_spec; auto. Qed.

Lemma inter_1 : In x (inter s s') -> In x s.
Proof. rewrite inter_spec; intuition. Qed.
Lemma inter_2 : In x (inter s s') -> In x s'.
Proof. rewrite inter_spec; intuition. Qed.
Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
Proof. rewrite inter_spec; intuition. Qed.

Lemma diff_1 : In x (diff s s') -> In x s.
Proof. rewrite diff_spec; intuition. Qed.
Lemma diff_2 : In x (diff s s') -> ~ In x s'.
Proof. rewrite diff_spec; intuition. Qed.
Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
Proof. rewrite diff_spec; auto. Qed.

Variable f : elt -> bool.
Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).

Lemma filter_1 : compatb f -> In x (filter f s) -> In x s.
Proof. intros P; rewrite filter_spec; intuition. Qed.
Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true.
Proof. intros P; rewrite filter_spec; intuition. Qed.
Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s).
Proof. intros P; rewrite filter_spec; intuition. Qed.

Lemma for_all_1 : compatb f ->
      For_all (fun x => f x = true) s -> for_all f s = true.
Proof. intros; apply <- for_all_spec; auto. Qed.
Lemma for_all_2 : compatb f ->
      for_all f s = true -> For_all (fun x => f x = true) s.
Proof. intros; apply -> for_all_spec; auto. Qed.

Lemma exists_1 : compatb f ->
      Exists (fun x => f x = true) s -> exists_ f s = true.
Proof. intros; apply <- exists_spec; auto. Qed.

Lemma exists_2 : compatb f ->
      exists_ f s = true -> Exists (fun x => f x = true) s.
Proof. intros; apply -> exists_spec; auto. Qed.

Lemma elements_1 : In x s -> InA E.eq x (elements s).
Proof. intros; apply <- elements_spec1; auto. Qed.
Lemma elements_2 : InA E.eq x (elements s) -> In x s.
Proof. intros; apply -> elements_spec1; auto. Qed.

End ImplSpec.

Notation empty_1 := empty_spec (only parsing).
Notation fold_1 := fold_spec (only parsing).
Notation cardinal_1 := cardinal_spec (only parsing).
Notation partition_1 := partition_spec1 (only parsing).
Notation partition_2 := partition_spec2 (only parsing).
Notation choose_1 := choose_spec1 (only parsing).
Notation choose_2 := choose_spec2 (only parsing).
Notation elements_3w := elements_spec2w (only parsing).

Hint Resolve mem_1 equal_1 subset_1 empty_1
    is_empty_1 choose_1 choose_2 add_1 add_2 remove_1
    remove_2 singleton_2 union_1 union_2 union_3
    inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1
    partition_1 partition_2 elements_1 elements_3w
    : set.
Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3
    remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2
    filter_1 filter_2 for_all_2 exists_2 elements_2
    : set.

(** * Specifications written using equivalences :
      this is now provided by the default interface. *)

Section IffSpec.
Variable s s' s'' : t.
Variable x y z : elt.

Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
Proof.
intros E; rewrite E; intuition.
Qed.

Lemma mem_iff : In x s <-> mem x s = true.
Proof. apply iff_sym, mem_spec. Qed.

Lemma not_mem_iff : ~In x s <-> mem x s = false.
Proof.
rewrite <-mem_spec; destruct (mem x s); intuition.
Qed.

Lemma equal_iff : s[=]s' <-> equal s s' = true.
Proof. apply iff_sym, equal_spec. Qed.

Lemma subset_iff : s[<=]s' <-> subset s s' = true.
Proof. apply iff_sym, subset_spec. Qed.

Lemma empty_iff : In x empty <-> False.
Proof. intuition; apply (empty_spec H). Qed.

Lemma is_empty_iff : Empty s <-> is_empty s = true.
Proof. apply iff_sym, is_empty_spec. Qed.

Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
Proof. rewrite singleton_spec; intuition. Qed.

Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
Proof. rewrite add_spec; intuition. Qed.

Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
Proof. rewrite add_spec; intuition. elim H; auto with relations. Qed.

Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
Proof. rewrite remove_spec; intuition. Qed.

Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
Proof. rewrite remove_spec; intuition. Qed.

Variable f : elt -> bool.

Lemma for_all_iff : Proper (E.eq==>Logic.eq) f ->
  (For_all (fun x => f x = true) s <-> for_all f s = true).
Proof. intros; apply iff_sym, for_all_spec; auto. Qed.

Lemma exists_iff : Proper (E.eq==>Logic.eq) f ->
  (Exists (fun x => f x = true) s <-> exists_ f s = true).
Proof. intros; apply iff_sym, exists_spec; auto. Qed.

Lemma elements_iff : In x s <-> InA E.eq x (elements s).
Proof. apply iff_sym, elements_spec1. Qed.

End IffSpec.

Notation union_iff := union_spec (only parsing).
Notation inter_iff := inter_spec (only parsing).
Notation diff_iff := diff_spec (only parsing).
Notation filter_iff := filter_spec (only parsing).

(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)

Ltac set_iff :=
 repeat (progress (
  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff
  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
  || rewrite empty_iff)).

(**  * Specifications written using boolean predicates *)

Section BoolSpec.
Variable s s' s'' : t.
Variable x y z : elt.

Lemma mem_b : E.eq x y -> mem x s = mem y s.
Proof.
intros.
generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
destruct (mem x s); destruct (mem y s); intuition.
Qed.

Lemma empty_b : mem y empty = false.
Proof.
generalize (empty_iff y)(mem_iff empty y).
destruct (mem y empty); intuition.
Qed.

Lemma add_b : mem y (add x s) = eqb x y || mem y s.
Proof.
generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
Qed.

Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
Proof.
intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
destruct (mem y s); destruct (mem y (add x s)); intuition.
Qed.

Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
Proof.
generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
Qed.

Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
Proof.
intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
destruct (mem y s); destruct (mem y (remove x s)); intuition.
Qed.

Lemma singleton_b : mem y (singleton x) = eqb x y.
Proof.
generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
Qed.

Lemma union_b : mem x (union s s') = mem x s || mem x s'.
Proof.
generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
Qed.

Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
Proof.
generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
Qed.

Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
Proof.
generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
Qed.

Lemma elements_b : mem x s = existsb (eqb x) (elements s).
Proof.
generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
rewrite InA_alt.
destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
symmetry.
rewrite H1.
destruct H0 as (H0,_).
destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
exists a; intuition.
unfold eqb; destruct (eq_dec x a); auto.
rewrite <- H.
rewrite H0.
destruct H1 as (H1,_).
destruct H1 as (a,(Ha1,Ha2)); [intuition|].
exists a; intuition.
unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
Qed.

Variable f : elt->bool.

Lemma filter_b : Proper (E.eq==>Logic.eq) f -> mem x (filter f s) = mem x s && f x.
Proof.
intros.
generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
Qed.

Lemma for_all_b : Proper (E.eq==>Logic.eq) f ->
  for_all f s = forallb f (elements s).
Proof.
intros.
generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
unfold For_all.
destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
rewrite <- H1; intros.
destruct H0 as (H0,_).
rewrite (H2 x0) in H3.
rewrite (InA_alt E.eq x0 (elements s)) in H3.
destruct H3 as (a,(Ha1,Ha2)).
rewrite (H _ _ Ha1).
apply H0; auto.
symmetry.
rewrite H0; intros.
destruct H1 as (_,H1).
apply H1; auto.
rewrite H2.
rewrite InA_alt. exists x0; split; auto with relations.
Qed.

Lemma exists_b : Proper (E.eq==>Logic.eq) f ->
  exists_ f s = existsb f (elements s).
Proof.
intros.
generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
unfold Exists.
destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
rewrite <- H1; intros.
destruct H0 as (H0,_).
destruct H0 as (a,(Ha1,Ha2)); auto.
exists a; split; auto.
rewrite H2; rewrite InA_alt; exists a; auto with relations.
symmetry.
rewrite H0.
destruct H1 as (_,H1).
destruct H1 as (a,(Ha1,Ha2)); auto.
rewrite (H2 a) in Ha1.
rewrite (InA_alt E.eq a (elements s)) in Ha1.
destruct Ha1 as (b,(Hb1,Hb2)).
exists b; auto.
rewrite <- (H _ _ Hb1); auto.
Qed.

End BoolSpec.

(** * Declarations of morphisms with respects to [E.eq] and [Equal] *)

Instance In_m : Proper (E.eq==>Equal==>iff) In.
Proof.
unfold Equal; intros x y H s s' H0.
rewrite (In_eq_iff s H); auto.
Qed.

Instance Empty_m : Proper (Equal==>iff) Empty.
Proof.
repeat red; unfold Empty; intros s s' E.
setoid_rewrite E; auto.
Qed.

Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty.
Proof.
intros s s' H.
generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff.
destruct (is_empty s); destruct (is_empty s'); intuition.
Qed.

Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem.
Proof.
intros x x' Hx s s' Hs.
generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff.
destruct (mem x s), (mem x' s'); intuition.
Qed.

Instance singleton_m : Proper (E.eq==>Equal) singleton.
Proof.
intros x y H a. rewrite !singleton_iff, H; intuition.
Qed.

Instance add_m : Proper (E.eq==>Equal==>Equal) add.
Proof.
intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition.
Qed.

Instance remove_m : Proper (E.eq==>Equal==>Equal) remove.
Proof.
intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition.
Qed.

Instance union_m : Proper (Equal==>Equal==>Equal) union.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
Qed.

Instance inter_m : Proper (Equal==>Equal==>Equal) inter.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
Qed.

Instance diff_m : Proper (Equal==>Equal==>Equal) diff.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
Qed.

Instance Subset_m : Proper (Equal==>Equal==>iff) Subset.
Proof.
unfold Equal, Subset; firstorder.
Qed.

Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2.
generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff.
destruct (subset s1 s2); destruct (subset s1' s2'); intuition.
Qed.

Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2.
generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff.
destruct (equal s1 s2); destruct (equal s1' s2'); intuition.
Qed.

Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *)
Proof. firstorder. Qed.

Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid.
Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid.

Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1.
Proof.
  simpl_relation. eauto with set.
Qed.

Instance Empty_s_m : Proper (Subset-->impl) Empty.
Proof. firstorder. Qed.

Instance add_s_m : Proper (E.eq==>Subset++>Subset) add.
Proof.
intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition.
Qed.

Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove.
Proof.
intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition.
Qed.

Instance union_s_m : Proper (Subset++>Subset++>Subset) union.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
Qed.

Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
Qed.

Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
Qed.

(* [fold], [filter], [for_all], [exists_] and [partition] requires
  some knowledge on [f] in order to be known as morphisms. *)

Generalizable Variables f.

Instance filter_equal : forall `(Proper _ (E.eq==>Logic.eq) f),
 Proper (Equal==>Equal) (filter f).
Proof.
intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
Qed.

Instance filter_subset : forall `(Proper _ (E.eq==>Logic.eq) f),
 Proper (Subset==>Subset) (filter f).
Proof.
intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
Qed.

Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) ->
 forall s s', s[=]s' -> filter f s [=] filter f' s'.
Proof.
intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto.
rewrite Hff', Hss'; intuition.
red; red; intros; rewrite <- 2 Hff'; auto.
Qed.

(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid
   structures on [list elt] and [option elt]. *)

(* Later:
Add Morphism cardinal ; cardinal_m.
*)

End WFactsOn.

(** Now comes variants for self-contained weak sets and for full sets.
    For these variants, only one argument is necessary. Thanks to
    the subtyping [WS<=S], the [Facts] functor which is meant to be
    used on modules [(M:S)] can simply be an alias of [WFacts]. *)

Module WFacts (M:WSets) := WFactsOn M.E M.
Module Facts := WFacts.


From Undecidability Require Import TM.Util.Prelim.
Require Import Coq.Lists.List.
Require Import Undecidability.Shared.Libs.PSL.Bijection. (* [injective] *)

(* * Codable Class **)

(* Class of minimally codable types *)
Class codable (sig: Type) (X: Type) := {
  encode : X -> list sig;
}.
Arguments encode {sig} {X} {_}.

(* either the type or the alphabet must be know at head: *)
Hint Mode codable - ! : typeclass_instances.
Hint Mode codable ! - : typeclass_instances.

(* right side must be fully known, left side at head *)
Hint Mode Retract ! + : typeclass_instances.

(* (* Both sides must be known at head. *)
Hint Mode Retract ! - : typeclass_instances.
Hint Mode Retract - ! : typeclass_instances. *)

Hint Extern 4 (codable (FinType(EqType ?sigX)) ?X) => cbn : typeclass_instances.

(* We often use the above coercion to write [cX x] instead of [encode x], because [encode x] can be ambigious, see [Encode_map] *)
Coercion encode : codable >-> Funclass.

Definition size (sig X : Type) (cX : codable sig X) (x : X) := length (cX x).
Arguments size {sig X cX} x, {_ _} _ _ (*legacy with two arguments*).

(* Hint database for encoding compatibility lemmas. For example, size functions are usually parametrised over an encoding. It doesn't matter for the size, whether we apply [Encode_map] on this encoding. This kind of lemmas is encodable in this HintDb. *)
Create HintDb encode_comp.

Ltac simpl_comp := autorewrite with encode_comp.

Instance Encode_unit : codable Empty_set unit :=
  {|
    encode x := nil
  |}.

Lemma Encode_unit_hasSize (t:unit) :
  size t = 0.
Proof. cbn. reflexivity. Qed.

Lemma Encode_unit_injective : injective Encode_unit.
Proof. now intros [] [] _. Qed.

Instance Encode_bool : codable bool bool:=
  {|
    encode x := [x]
  |}.

Lemma Encode_bool_hasSize (b:bool) :
  size Encode_bool b = 1.
Proof. cbn. reflexivity. Qed.

Lemma Encode_bool_injective : injective Encode_bool.
Proof. intros [ | ] [ | ] H; cbn in *; congruence. Qed.

Instance Encode_Fin n : codable (Fin.t n) (Fin.t n):=
  {|
    encode i := [i]
  |}.

Lemma Encode_Fin_hasSize n i :
  size (Encode_Fin n) i = 1.
Proof. cbn. reflexivity. Qed.

Lemma Encode_Fin_injective n : injective (Encode_Fin n).
Proof. intros i1 i2. cbn. congruence. Qed.

(*
Compute encode true.
(* This works thanks to the coercion above *)
Compute Encode_bool true.
Compute encode tt.
Check encode Fin0.
Compute encode Fin0 : list (Fin.t 10).
*)

Section Encode_Finite.
  Variable sig : finType.

  (* This instance is not declared globally, because of overlaps *)
  Local Instance Encode_Finite : codable sig sig :=
    {|
      encode x := [x];
    |}.

  Lemma Encode_Finite_hasSize f :
    size Encode_Finite f = 1.
  Proof. reflexivity. Qed.

  Lemma Encode_Finite_injective : injective Encode_Finite.
  Proof. intros x1 x2. cbn. congruence. Qed.

End Encode_Finite.

(* [Encode_map] is no longer an instance for [codable] *)

Section Encode_map.
  Variable (X : Type).
  Variable (sig tau : Type).
  Hypothesis (cX : codable sig X).

  Variable inj : Retract sig tau.

  Definition Encode_map : codable tau X :=
    {|
      encode x := map Retr_f (encode x);
    |}.

  Lemma Encode_map_hasSize x :
    size Encode_map x =size x.
  Proof. cbn. now rewrite map_length. Qed.

  Lemma Encode_map_injective :
    injective cX -> injective Encode_map.
  Proof. intros H. hnf in H; hnf. cbn in *. intros x1 x2 ? % map_injective; auto. apply retract_f_injective. Qed.

End Encode_map.

(* Hint Rewrite Encode_map_hasSize : encode_comp. *)

Section Encode_map_comp.
  Variable (X : Type).
  Variable (sig1 sig2 sig3 : Type).
  Variable (cX : codable sig1 X).
  Variable (I1 : Retract sig1 sig2) (I2 : Retract sig2 sig3).

  Lemma Encode_map_id x :
    Encode_map cX (Retract_id _) x = cX x.
  Proof. cbn. now rewrite map_id. Qed.

  Lemma Encode_map_comp x :
    Encode_map (Encode_map cX I1) I2 x = Encode_map cX (ComposeRetract I2 I1) x.
  Proof. cbn. rewrite List.map_map. reflexivity. Qed.

End Encode_map_comp.

Hint Rewrite Encode_map_id Encode_map_comp : encode_comp.

(* Builds simple retract functions like [sigSum -> option sigX] in the form
[fun x => match x with constructor_name y => Retr_g y | _ => None] *)

Local Hint Mode Retract - - : typeclass_instances.
Ltac build_simple_retract_g :=
  once lazymatch goal with
  | [ |- ?Y -> option ?X ] =>
    (* idtac "Retract function" X Y; *)
    let x := fresh "x" in
    intros x; destruct x; intros; try solve [now apply Retr_g ]; right
  end.

Ltac build_simple_retract :=
  once lazymatch goal with
  | [ |- Retract ?X ?Y ] =>
    (* idtac "Retract from" X "to" Y; *)
    let x := fresh "x" in
    let y := fresh "y" in
    let f := (eval simpl in (ltac:(intros x; constructor; now apply Retr_f) : X -> Y)) in
    (* idtac "f:" f; *)
    let g := (eval simpl in (ltac:(build_simple_retract_g) : Y -> option X)) in
    (* idtac "g:" g; *)
    apply Build_Retract with (Retr_f := f) (Retr_g := g);
    abstract now hnf; intros x y; split;
    [ destruct y; try congruence; now intros -> % retract_g_inv
    | now intros ->; now retract_adjoint
    ]
  end
.

Ltac build_eq_dec :=
  let x := fresh "x" in
  let y := fresh "y" in
  intros x y; hnf; decide equality;
  apply Dec; auto.

Lemma countMap_injective (X Y : eqType) (x : X) (A : list X) (f : X -> Y) :
  (forall x y, f x = f y -> x = y) ->
  BasicDefinitions.count (map f A) (f x) = BasicDefinitions.count A x.
Proof.
  intros HInj. revert x. induction A as [ | a A IH]; intros; cbn in *; auto.
  decide (f x = f a) as [ -> % HInj | He].
  - decide (a = a) as [_ | Ha]; auto. congruence.
  - decide (x = a) as [-> | Hx]; auto. congruence.
Qed.

Lemma countMap_zero (X Y : eqType) (A : list X) (y : Y) (f : X -> Y) :
  (forall x, f x <> y) ->
  BasicDefinitions.count (map f A) y = 0.
Proof.
  revert y. induction A as [ | a A IH]; intros; cbn in *; auto.
  decide (y = f a) as [-> | ?]; auto. now contradiction (H a).
Qed.

Section Encode_sum.
  Variable (X Y : Type).
  Inductive sigSum (sigX sigY : Type) : Type :=
  | sigSum_X (s : sigX)
  | sigSum_Y (s : sigY)
  | sigSum_inl
  | sigSum_inr
  .

  Arguments sigSum_inl {sigX sigY}. Arguments sigSum_inr {sigX sigY}. Arguments sigSum_X {sigX sigY}. Arguments sigSum_Y {sigX sigY}.

  Global Instance Retract_sigSum_X (sigX sigY tau : Type) (f : Retract sigX tau) : Retract sigX (sigSum tau sigY).
  Proof. build_simple_retract. Defined. (* because definition *)
  Global Instance Retract_sigSum_Y (sigX sigY tau : Type) (f : Retract sigY tau) : Retract sigY (sigSum sigX tau).
  Proof. build_simple_retract. Defined. (* because definition *)

  Global Instance sigSum_dec (sigX sigY : Type) (decX: eq_dec sigX) (decY: eq_dec sigY) :
    eq_dec (sigSum sigX sigY) := ltac:(build_eq_dec).

  Global Instance sigSum_fin (sigX sigY : finType) : finTypeC (EqType (sigSum sigX sigY)).
  Proof.
    split with (enum := sigSum_inl :: sigSum_inr :: map sigSum_X enum ++ map sigSum_Y enum). intros [x|y| | ]; cbn; f_equal.
    - rewrite <- !countSplit.
      erewrite countMap_injective.
      + rewrite enum_ok. rewrite countMap_zero. lia. congruence.
      + eapply (retract_f_injective) with (I := Retract_sigSum_X sigY (Retract_id _)).
    - rewrite <- !countSplit.
      erewrite countMap_injective.
      + rewrite enum_ok. rewrite countMap_zero. lia. congruence.
      + eapply (retract_f_injective) with (I := Retract_sigSum_Y sigX (Retract_id _)).
    - rewrite <- !countSplit. rewrite !countMap_zero. lia. all: congruence.
    - rewrite <- !countSplit. rewrite !countMap_zero. lia. all: congruence.
  Qed.

  Variable (sigX sigY : Type).
  Hypothesis (cX : codable sigX X) (cY : codable sigY Y).

  Global Instance Encode_sum : codable (sigSum sigX sigY) (X+Y) :=
    {|
      encode s := match s with
                  | inl x => sigSum_inl :: (Encode_map _ _ x)
                  | inr y => sigSum_inr :: (Encode_map _ _ y)
                  end
    |}.

  Definition Encode_sum_size (s:X+Y) :=
    match s with
       | inl x => S (size x)
       | inr y => S (size y)
    end.

  Lemma Encode_sum_hasSize s :
    size Encode_sum s = Encode_sum_size s.
  Proof. cbn. destruct s; cbn; cbv [Encode_sum_size]; rewrite map_length; reflexivity. Qed.

  Lemma Encode_sum_injective : injective cX -> injective cY -> injective Encode_sum.
  Proof.
    intros HX HY. intros [ x1 | y1 ] [ x2 | y2] H; cbn in *; inv H; f_equal.
    - apply map_injective in H1; auto. congruence.
    - apply map_injective in H1; auto. congruence.
  Qed.

End Encode_sum.

Arguments sigSum_inl {sigX sigY}. Arguments sigSum_inr {sigX sigY}. Arguments sigSum_X {sigX sigY}. Arguments sigSum_Y {sigX sigY}.
Hint Extern 4 (finTypeC (EqType (sigSum _ _))) => eapply sigSum_fin : typeclass_instances.
(* Check FinType (EqType (sigSum bool bool)). *)

Lemma cons_injective (X : Type) (x1 x2 : X) (l1 l2 : list X) :
  x1 :: l1 = x2 :: l2 -> x1 = x2 /\ l1 = l2.
Proof. intros H. inv H. auto. Qed.

Lemma map_app_map_seperate (X Y Z : Type) (f : X -> Z) (g : Y -> Z) (x1 x2 : list X) (y1 y2 : list Y) :
  injective f -> injective g ->
  (forall x y, f x <> g y) ->
  map f x1 ++ map g y1 = map f x2 ++ map g y2 ->
  x1 = x2 /\ y1 = y2.
Proof.
  intros Hf Hg Hfg. revert x2 y1 y2. induction x1 as [ | x x1 IH]; intros x2 y1 y2 HApp; cbn in *.
  - apply map_eq_app in HApp as (l1&l2&->&HApp1&HApp2). apply map_injective in HApp2 as ->; auto.
    destruct x2, l1; cbn in *; auto; inv HApp1. exfalso. eapply Hfg; eauto.
  - destruct x2 as [ | x' x2]; cbn in *.
    + exfalso. destruct y2; cbn in *; inv HApp. eapply Hfg; eauto.
    + apply cons_injective in HApp as [-> % Hf HApp]. apply IH in HApp as [-> ->]. auto.
Qed.

(* If [X] is encodable over [sigX] and [Y] over [sigY]. *)
Section Encode_pair.

  Inductive sigPair (sigX sigY : Type) : Type :=
  | sigPair_X (s : sigX)
  | sigPair_Y (s : sigY)
  .

  Arguments sigPair_X {sigX sigY}. Arguments sigPair_Y {sigX sigY}.

  Global Instance Retract_sigPair_X (sigX sigY tau : Type) (f : Retract sigX tau) : Retract sigX (sigPair tau sigY).
  Proof. build_simple_retract. Defined. (* because definition *)
  Global Instance Retract_sigPair_Y (sigX sigY tau : Type) (f : Retract sigY tau) : Retract sigY (sigPair sigX tau).
  Proof. build_simple_retract. Defined. (* because definition *)

  Global Instance sigPair_dec (sigX sigY : Type) (decX: eq_dec sigX) (decY: eq_dec sigY) :
    eq_dec (sigPair sigX sigY) := ltac:(build_eq_dec).

  Global Instance sigPair_fin (sigX sigY : finType) : finTypeC (EqType (sigPair sigX sigY)).
  Proof.
    split with (enum := map sigPair_X enum ++ map sigPair_Y enum). intros [x|y]; cbn; f_equal.
    - rewrite <- !countSplit.
      erewrite countMap_injective.
      + rewrite enum_ok. rewrite countMap_zero. lia. congruence.
      + eapply (retract_f_injective) with (I := Retract_sigPair_X sigY (Retract_id _)).
    - rewrite <- !countSplit.
      erewrite countMap_injective.
      + rewrite enum_ok. rewrite countMap_zero. lia. congruence.
      + eapply (retract_f_injective) with (I := Retract_sigPair_Y sigX (Retract_id _)).
  Qed.

  Variable (sigX sigY: Type) (X Y: Type) (cX : codable sigX X) (cY : codable sigY Y).

  Global Instance Encode_pair : codable (sigPair sigX sigY) (X*Y) :=
    {|
      encode '(x,y) := Encode_map _ _ x ++ Encode_map _ _ y;
    |}.

  Definition Encode_pair_size (p : X * Y) := let (x, y) := p in size x + size y.

  Lemma Encode_pair_hasSize p : size Encode_pair p = Encode_pair_size p.
  Proof. destruct p; cbn; now rewrite app_length, !map_length. Qed.

  Lemma Encode_pair_injective : injective cX -> injective cY -> injective Encode_pair.
  Proof.
    intros HX HY. intros [x1 y1] [x2 y2] H; cbn in *.
    apply map_app_map_seperate in H as [-> % HX -> % HY]; auto; congruence.
  Qed.

End Encode_pair.

Arguments sigPair_X {sigX sigY}. Arguments sigPair_Y {sigX sigY}.

Hint Extern 4 (finTypeC (EqType (sigPair _ _))) => eapply sigPair_fin : typeclass_instances.
(* Check FinType (EqType (sigPair bool bool)). *)

(* Compute Encode_pair Encode_bool (Encode_sum Encode_unit Encode_bool) (true, inl tt). *)

(* Check _ : codable (sigPair bool (sigSum Empty_set bool)) unit. *)

Section Encode_option.

  Inductive sigOption (sigX: Type) : Type :=
  | sigOption_X (s : sigX)
  | sigOption_None
  | sigOption_Some
  .

  Arguments sigOption_Some {sigX}. Arguments sigOption_None {sigX}. Arguments sigOption_X {sigX}.

  Global Instance Retract_sigOption_X (sig tau : Type) (retr : Retract sig tau) : Retract sig (sigOption tau).
  Proof. build_simple_retract. Defined. (* because definition *)

  Global Instance sigOption_dec sigX (decX : eq_dec sigX) :
    eq_dec (sigOption sigX) := ltac:(build_eq_dec).

  Global Instance sigOption_fin (sigX : finType) : finTypeC (EqType (sigOption sigX)).
  Proof.
    split with (enum := sigOption_Some :: sigOption_None :: map sigOption_X enum).
    intros [x| | ]; cbn; f_equal.
    - rewrite countMap_injective. 2: apply retract_f_injective with (I := Retract_sigOption_X (Retract_id _)).
      now apply enum_ok.
    - rewrite countMap_zero. lia. congruence.
    - rewrite countMap_zero. lia. congruence.
  Qed.

  Variable (sigX: Type) (X: Type) (cX : codable sigX X).

  Global Instance Encode_option : codable (sigOption sigX) (option X) :=
    {|
      encode o := match o with
                  | None => [sigOption_None]
                  | Some x => sigOption_Some :: Encode_map _ _ x
                  end;
    |}.

  Definition Encode_option_size (o : option X) :=
    match o with
    | None => 1
    | Some x => S (size x)
    end.

  Lemma Encode_option_hasSize o : size o = Encode_option_size o.
  Proof. destruct o; cbn; f_equal; now rewrite map_length. Qed.

  Lemma Encode_option_injective : injective cX -> injective Encode_option.
  Proof.
    intros HX. intros [ x1 | ] [ x2 | ] H; inv H; auto. f_equal. apply map_injective in H1.
    - now apply HX in H1.
    - congruence.
  Qed.

End Encode_option.

Arguments sigOption_Some {sigX}. Arguments sigOption_None {sigX}. Arguments sigOption_X {sigX}.

Hint Extern 4 (finTypeC (EqType (sigOption _))) => eapply sigOption_fin : typeclass_instances.
(* Check FinType (EqType (sigOption bool)). *)

(* Compute Encode_option Encode_bool None. *)
(* Compute Encode_option Encode_bool (Some false). *)

Lemma app_seperate (X : Type) (xs1 xs2 ys1 ys2 : list X) (s1 s2 : X) :
  (~ In s1 xs2) ->
  (~ In s2 xs1) ->
  xs1 ++ s1 :: ys1 = xs2 ++ s2 :: ys2 ->
  xs1 = xs2 /\ s1 = s2 /\ ys1 = ys2.
Proof.
  revert xs2 ys1 ys2 s1 s2. induction xs1 as [ | x1 xs1 IH]; intros xs2 ys1 ys2 s1 s2; intros H1 H2; intros Heq; cbn in *.
  - destruct xs2 as [ | x2 xs2]; cbn in *.
    + inv Heq. auto.
    + inv Heq. exfalso. apply H1. auto.
  - destruct xs2 as [ | x2 xs2]; cbn in *.
    + inv Heq. exfalso. apply H2. auto.
    + apply cons_injective in Heq as [-> Heq].
      enough (xs1 = xs2 /\ s1 = s2 /\ ys1 = ys2) as (->&->&->) by auto.
      apply IH; auto.
Qed.

(* TODO: ~> Base *)
Lemma skipn_0 (A:Type) (xs : list A) : skipn 0 xs = xs. Proof. reflexivity. Qed.

(* TODO: ~> Base *)
Lemma skipn_tl (A:Type) (xs : list A) (n : nat) : skipn (S n) xs = skipn n (tl xs).
Proof. induction n; cbn; destruct xs; auto. Qed.

Section Encode_list.

  Inductive sigList (sigX : Type) : Type :=
  | sigList_X (s : sigX)
  | sigList_nil
  | sigList_cons
  .

  Arguments sigList_nil {sigX}. Arguments sigList_cons {sigX}. Arguments sigList_X {sigX}.

  Global Instance Retract_sigList_X (sig tau : Type) (retr : Retract sig tau) : Retract sig (sigList tau).
  Proof. build_simple_retract. Defined. (* because definition *)

  Global Instance sigList_dec sigX (decX : eq_dec sigX) :
    eq_dec (sigList sigX) := ltac:(build_eq_dec).

  Global Instance sigList_fin (sigX : finType) : finTypeC (EqType (sigList sigX)).
  Proof.
    split with (enum := sigList_nil :: sigList_cons :: map sigList_X enum).
    intros [x| | ]; cbn; f_equal.
    - rewrite countMap_injective. 2: apply retract_f_injective with (I := Retract_sigList_X (Retract_id _)).
      now apply enum_ok.
    - rewrite countMap_zero. lia. congruence.
    - rewrite countMap_zero. lia. congruence.
  Qed.

  Variable sigX: Type.
  Variable (X : Type) (cX : codable sigX X).

  Fixpoint encode_list (xs : list X) : list (sigList sigX) :=
    match xs with
    | nil => [sigList_nil]
    | x :: xs' => sigList_cons :: Encode_map _ _ x ++ encode_list xs'
    end.

  Lemma encode_list_concat l:
    encode_list l = concat (map (fun t => sigList_cons :: map sigList_X (encode t)) l) ++[sigList_nil].
  Proof.
    induction l;cbn. reflexivity.
    rewrite IHl. cbn. now autorewrite with list.
  Qed.

  Global Instance Encode_list : codable (sigList sigX) (list X) :=
    {|
      encode := encode_list;
    |}.

  Lemma encode_list_app (xs ys : list X) :
    encode_list (xs ++ ys) = removelast (encode_list xs) ++ encode_list ys.
  Proof.
    revert ys. induction xs; intros; cbn in *; f_equal.
    rewrite IHxs. rewrite app_assoc, app_comm_cons; f_equal.
    destruct (map (fun x : sigX => sigList_X x) (cX a)) eqn:E; cbn.
    - destruct xs; cbn; auto.
    - f_equal. destruct (cX a) eqn:E2; cbn in E. congruence.
      rewrite removelast_app.
      + destruct (l ++ encode_list xs) eqn:E3; cbn; auto.
        apply app_eq_nil in E3 as (E3&E3'). destruct xs; inv E3'.
      + destruct xs; cbn; congruence.
  Qed.

  Corollary Encode_list_app (xs ys : list X) :
    Encode_list (xs ++ ys) = removelast (Encode_list xs) ++ Encode_list ys.
  Proof. cbn. now apply encode_list_app. Qed.

  Lemma encode_list_neq_nil (xs : list X) :
    encode_list xs <> nil.
  Proof. destruct xs; cbn; congruence. Qed.

  Corollary Encode_list_neq_nil (xs : list X) :
    Encode_list xs <> nil.
  Proof. cbn. apply encode_list_neq_nil. Qed.

  Lemma encode_list_remove (xs : list X) :
    removelast (encode_list xs) ++ [sigList_nil] = encode_list xs.
  Proof.
    induction xs.
    - reflexivity.
    - cbn [encode_list].
      change (sigList_cons :: Encode_map _ _ a ++ encode_list xs)
        with ((sigList_cons :: Encode_map _ _ a) ++ encode_list xs).
      rewrite removelast_app by apply encode_list_neq_nil.
      rewrite <- app_assoc. f_equal. auto.
  Qed.

  Corollary Encode_list_remove (xs : list X) :
    removelast (Encode_list xs) ++ [sigList_nil] = Encode_list xs.
  Proof. cbn. apply encode_list_remove. Qed.

  Fixpoint Encode_list_size (xs : list X) : nat :=
    match xs with
    | nil => 1
    | x :: xs' => S (size x + Encode_list_size xs')
    end.

  Lemma Encode_list_hasSize (xs : list X) : size xs = Encode_list_size xs.
  Proof.
    induction xs as [ | x xs IH]; cbn; f_equal.
    rewrite app_length, !map_length. fold (size x). now rewrite <- IH.
  Qed.

  Lemma Encode_list_hasSize_skipn (xs : list X) (n : nat) :
    Encode_list_size (skipn n xs) <= Encode_list_size xs.
  Proof.
    revert n. induction xs as [ | x xs' IH]; intros n.
    - cbn. rewrite skipn_nil. cbn. reflexivity.
    - cbn. destruct n.
      + rewrite skipn_0. cbn. reflexivity.
      + cbn. rewrite IH. lia.
  Qed.

  Lemma Encode_list_hasSize_ge1 (xs : list X) :
    1 <= Encode_list_size xs.
  Proof. induction xs; cbn; lia. Qed.

  Lemma Encode_list_hasSize_app (xs ys : list X) :
    Encode_list_size (xs ++ ys) = Encode_list_size xs + Encode_list_size ys - 1.
  Proof.
    induction xs as [ | x xs IH] in xs,ys|-*; cbn.
    - lia.
    - rewrite IH. enough (1 <= Encode_list_size xs) by lia. apply Encode_list_hasSize_ge1.
  Qed.

  Lemma encode_list_eq_nil (xs : list X) : encode_list xs = [sigList_nil] -> xs = nil.
  Proof. destruct xs; cbn; congruence. Qed.

  Lemma encode_list_injective : injective cX -> injective encode_list.
  Proof.
    intros HX. hnf in *. intros xs. induction xs as [ | x xs IH]; intros ys H; cbn in *.
    - symmetry in H. apply encode_list_eq_nil in H. auto.
    - destruct ys as [ | y ys]; cbn in *.
      + inv H.
      + apply cons_injective in H as [_ H].
        destruct xs as [ | x' xs]; cbn in *.
        * destruct ys as [ | y' ys]; cbn in *.
          -- apply app_inj_tail in H as [H _]. apply map_injective in H; auto. now apply HX in H as ->. congruence.
          -- exfalso. apply app_seperate in H as (H1&H2&H3); cbn; auto.
             ++ congruence.
             ++ intros (?&?&?) % in_map_iff. congruence.
             ++ intros (?&?&?) % in_map_iff. congruence.
        * destruct ys as [ | y' ys]; cbn in *.
          -- exfalso. eapply app_seperate in H as (H1&H2&H3); cbn; auto.
             ++ congruence.
             ++ intros (?&?&?) % in_map_iff. congruence.
             ++ intros (?&?&?) % in_map_iff. congruence.
          -- apply app_seperate in H as (H1&H2&H3).
             ++ apply map_injective, HX in H1 as ->; auto. 2: congruence.
                specialize (IH (y' :: ys)). spec_assert IH by (cbn; f_equal; auto). rewrite IH. auto.
             ++ intros (?&?&?) % in_map_iff. congruence.
             ++ intros (?&?&?) % in_map_iff. congruence.
  Qed.

  Lemma Encode_list_injective : injective cX -> injective Encode_list.
  Proof. apply encode_list_injective. Qed.

End Encode_list.

Arguments sigList_nil {sigX}. Arguments sigList_cons {sigX}. Arguments sigList_X {sigX}.

Hint Extern 4 (finTypeC (EqType (sigList _))) => eapply sigList_fin : typeclass_instances.
(* Check FinType(EqType (sigList bool)). *)

(* Compute Encode_list Encode_bool (nil). *)
(* This cannot reduce to [sigList_cons :: sigList_X true :: Encode_list _] *)
(* Eval cbn in Encode_list Encode_bool (true :: _). *)
(* Compute Encode_list Encode_bool (true :: false :: nil). *)

Section Encode_nat.

  Inductive sigNat : Type :=
  | sigNat_O
  | sigNat_S.

  Global Instance sigNat_eq : eq_dec sigNat.
  Proof. unfold dec. decide equality. Defined. (* because definition *)

  Global Instance sigNat_fin : finTypeC (EqType sigNat).
  Proof. split with (enum := [sigNat_O; sigNat_S]). intros [ | ]; cbn; reflexivity. Qed.

  Global Instance Encode_nat : codable sigNat nat :=
    {|
      encode n := repeat sigNat_S n ++ [sigNat_O];
    |}.

  Lemma Encode_nat_hasSize n : size n = S n.
  Proof. cbn. rewrite app_length, repeat_length. cbn. lia. Qed.

  Corollary Encode_nat_eq_nil n :
    Encode_nat n <> nil.
  Proof. intros H % length_zero_iff_nil. fold (size n) in H. rewrite Encode_nat_hasSize in H. lia. Qed.

  Lemma Encode_nat_injective : injective Encode_nat.
  Proof.
    cbn. hnf. intros n1. induction n1; intros n2 H; cbn in *.
    - destruct n2; cbn in *; congruence.
    - destruct n2; cbn in *; try congruence. f_equal. inv H. eapply IHn1. auto.
  Qed.

End Encode_nat.

(* Check FinType(EqType sigNat). *)

(* Test Playground *)

(*
Compute encode (Some true).
Eval cbv in encode None.

Compute encode false.
Compute encode true.

Compute encode (repeat tt 42).
Compute encode 42.

Compute encode (tt, tt).

Compute encode (inl 42).
Compute encode (inr 42).

Compute Encode_pair Encode_nat Encode_nat (1, 2).
Compute encode (1,2).

Compute encode [4;5].
Compute encode (Some 4) ++ encode (Some 5) ++ encode None.

Compute encode ([tt;tt;tt], tt).
*)