Require Import Lia.
Require Import List.
Require Import PeanoNat.
Import Nat Le Lt.
Import ListNotations.
Require Import Compare_dec.
Require Import Coq.Program.Wf.
Require Import Wf_nat.
Require Import IndefiniteDescription.
Require Import ClassicalDescription.
Require Import Sequences.
Require Import Tree.
Require Import CPO.
Require Import FuncDef.

Fixpoint f2l{A : Type} (n : nat)( f : nat -> A) : list A :=
match n with
|0 => []
|S m => (f 0) :: (f2l m (fun i => f (S i)))
end.

Lemma f2l_length{A: Type} : forall n (f : nat ->A),  length (f2l n f) = n.
Proof.
induction n; intro f; auto.
cbn.
rewrite IHn; auto.
Qed.

Lemma f2l_elts{A : Type} : forall n (f: nat -> A) i d,
    i < n -> nth i (f2l n f) d = f i.
Proof.
induction n; intros f i d Hlt; try lia.
destruct i; auto.
cbn.
rewrite IHn; auto ; lia.
Qed.

Definition f2l_dep{A : Type} (n : nat)(f  : forall i,  i < n -> A)(d:A) : list A :=
f2l n
    (fun k =>
       match (le_lt_dec n k ) with
         |left _   => d
         |right p => f k p
       end).

Lemma f2l_dep_length{A: Type} :
  forall n (f  : forall i,  i < n -> A) d,   length (f2l_dep n f d) = n.
Proof.
intros n f d.
unfold f2l_dep.
rewrite f2l_length; auto.
Qed.

Lemma f2l_dep_elts{A : Type} :
  forall n (f:  forall i,  i < n -> A) i d(Hlt:   i < n),
    nth i (f2l_dep n f d) d = f i Hlt.
Proof.
intros n f i d Hlt.
unfold f2l_dep.
rewrite f2l_elts; auto.
destruct ( le_lt_dec n i) ; try lia.
f_equal.
erewrite proof_irrelevance; eauto.
Qed.

Lemma list_max_rev : forall l, list_max l = list_max (rev l).
Proof.
induction l ; auto.
cbn [rev].
replace (a :: l) with ([a] ++ l); auto.
do 2 rewrite list_max_app.
rewrite IHl.
apply Max.max_comm.
Qed.

Module FmirrorMod(TM : TypeMod).
Import TM.
Module F := FtreeMod TM.
Import F.
Import Tree.

Obligation Tactic := idtac.
Program Fixpoint fmirror (t : (Ftree(A :=A))) {measure (height t)}: Ftree(A :=A) :=
  match t with
     | ftree a l =>  ftree a (
                          f2l_dep (length l)
                                  (fun n _ => fmirror (nth n (rev l) F.bot))
                                  F.bot )
    |  bot => bot
  end.
Next Obligation.
intros t Hall a l Heq n Hlt.
rewrite <- Heq.
cbn.
apply le_n_S.
rewrite rev_nth; auto.
apply max_list_max; lia.
Qed.

Next Obligation.
intros.
apply well_founded_ltof.
Qed.

Lemma fmirror_eta : forall t, fmirror t =
    match t with
     | ftree a l =>  ftree a (
                             f2l_dep (length l)
                                     (fun n _ => fmirror (nth n (rev l ) bot))
                                     bot )
  |  bot => bot

  end.
Proof.
intro t.
destruct t.
*
  unfold fmirror.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; auto.
*
  unfold fmirror.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; auto.
Qed.

Lemma f2l_dep_map :
forall l (f : Ftree(A:=A) -> Ftree(A :=A)), f2l_dep (length l) (fun n _ =>  f (nth n l bot)) bot = map f l.
intros l f.
eapply nth_ext with (d := bot) (d' := f bot).
*
  rewrite f2l_dep_length.
  rewrite map_length; auto.
*
  rewrite f2l_dep_length.
  intros n Hlt.
  rewrite f2l_dep_elts ; auto.
  rewrite map_nth; auto.
Qed.

Lemma fmirror_eta_plus : forall t, fmirror t =
  match t with
  | ftree a l =>ftree a (map fmirror (rev l))
  |  bot => bot
  end.
Proof.
intro t.
rewrite fmirror_eta.
destruct t ; auto.
f_equal.
rewrite <- rev_length.
rewrite f2l_dep_map; auto.
Qed.

Lemma fmirror_eta_bot : fmirror bot = bot.
Proof.
rewrite fmirror_eta; auto.
Qed.

Lemma fmirror_eta_plus_ftree : forall a l,
    fmirror (ftree a l) = ftree a (map fmirror (rev l)).
Proof.
intros a l.
rewrite fmirror_eta_plus; auto.
Qed.

Lemma fmirror_height : forall t,  height (fmirror t) = height t.
Proof.
induction t0 using Ftree_induct.
*
  cbn.
  rewrite fmirror_eta_bot; auto.
*
  rewrite fmirror_eta_plus_ftree.
  cbn.
  f_equal.
  rewrite map_map.
  rewrite map_rev.
  rewrite <- list_max_rev.
  induction l; auto.
  cbn [map height].
  replace ((height (fmirror a0)
     :: map (fun x : Ftree => height (fmirror x))
          l)) with ([height (fmirror a0)]
      ++ map (fun x : Ftree => height (fmirror x))
          l); auto.
  replace (height a0 :: map height l) with ([height a0] ++ map height l); auto.
  do 2 rewrite list_max_app.
  rewrite IHl; auto.
  +
    specialize (H 0).
    cbn in H.
    rewrite H; lia.
  +
    intros n Hlt.
    specialize (H  (S n)).
    cbn in H.
    rewrite H; lia.
Qed.

Lemma fmirror_cut : forall n t,  cut n (fmirror t) = fmirror (cut n t).
Proof.
induction n; intro t; cbn.
*
  rewrite fmirror_eta_bot ; auto.
*
  destruct t.
  +
    rewrite fmirror_eta_bot ; auto.
  +
    do 2 rewrite fmirror_eta_plus_ftree.
    f_equal.
    rewrite map_map.
    repeat rewrite map_rev.
    f_equal.
   induction l ; auto.
   cbn.
   f_equal.
   -
     apply IHn.
   -
     apply IHl.
Qed.

Lemma fmirror_inv : forall t, fmirror (fmirror t) = t.
Proof.
  eapply well_founded_ind with
      (R := fun t1 t2 => height t1 < height t2); [apply well_founded_ltof |].
intros t Hind.
destruct t.
*
  do  2 rewrite fmirror_eta_bot; auto.
*
   do 2 rewrite fmirror_eta_plus_ftree.
   f_equal.
   rewrite map_rev .
   rewrite map_map.
   rewrite map_rev.
   rewrite rev_involutive.
   induction l; auto.
   cbn.
   f_equal.
   +
    apply Hind; cbn; lia.
   +
     rewrite IHl ; auto.
     intros y Hlt.
     apply Hind.
     eapply Nat.lt_le_trans; eauto.
     cbn [height].
     apply le_n_S.
     replace (a0 :: l) with ([a0] ++l); auto.
     rewrite map_app, list_max_app.
     lia.
Qed.

Lemma fmirror_mono : forall t1 t2,  fprefix t1 t2 -> fprefix (fmirror t1) (fmirror t2).
Proof.
intros t1 t2 Hpre.
generalize Hpre; intro Hpre'.
apply fprefix_height in Hpre'.
unfold fprefix in *.
rewrite fmirror_height.
rewrite Hpre at 1.
rewrite fmirror_cut; auto.
Qed.

Lemma fmirror_asc : forall (q : Seq (A := Ftree)),
    ascending fprefix q -> ascending fprefix (fun n => fmirror (q n)).
Proof.
intros q Hasc.
rewrite  subsequence_iff_ascending;
  [| apply fprefix_refl | apply fprefix_trans | apply fprefix_antisym].
rewrite  subsequence_iff_ascending in Hasc;
  [| apply fprefix_refl | apply fprefix_trans | apply fprefix_antisym].
destruct Hasc as (Hinc & (q' & (f & Hfi & Hall) & Hsi)).
split.
*
  intro n.
  apply fmirror_mono, Hinc.
*
  exists (fun n => fmirror (q' n)).
  split.
  +
    exists f; split; auto.
    intro n.
    now rewrite Hall.
  +
    destruct Hsi as (Hi & Hn).
    split.
    -
      intro n.
      apply fmirror_mono, Hi.
   -
     intros n Heq.
     apply (Hn n).
     apply f_equal with (f := fmirror) in Heq.
     now do 2 rewrite fmirror_inv in Heq.
Qed.

 Fixpoint fpos (p : list nat) (t : Ftree) : option A :=
match p with
  [] =>
  match t with
    bot => None
   | ftree a _ => Some a
  end
| n :: p' =>
   match t with
    bot => None
   | ftree _ l =>
     if le_lt_dec (length l) n then None else
     fpos p' (nth n l bot)
  end
end.

Fixpoint fpos_sym (p : list nat) (t : Ftree) : option A :=
match p with
  [] =>
  match t with
    bot => None
   | ftree a _ => Some a
  end
| n :: p' =>
   match t with
    bot => None
   | ftree _ l =>
     if  le_lt_dec (length l) n then None else
       fpos_sym p' (nth (length l - (S n)) l bot)
  end
end.

Lemma fmirror_fpos : forall p t,  fpos p (fmirror t) = fpos_sym p t.
Proof.
induction p; intros t.
*
  destruct t.
  +
    rewrite fmirror_eta_bot ; auto.
  +
    rewrite fmirror_eta_plus_ftree; auto.
 *
   destruct t.
   +
     rewrite fmirror_eta_bot ; auto.
   +
      rewrite fmirror_eta_plus_ftree.
      cbn.
      rewrite map_length, rev_length.
      destruct (le_lt_dec (length l) a); auto.
      rewrite <- IHp.
      replace (nth a (map fmirror (rev l)) bot) with
          (nth a (map fmirror (rev l)) (fmirror bot)) ; [| rewrite fmirror_eta_bot; auto].
      rewrite map_nth.
      rewrite rev_nth; auto.
Qed.

Lemma fpos_fprefix :
  forall p t t',  length p < height t ->  fprefix t t' ->
                  fpos p t' = fpos p t.
Proof.
induction p ; intros t t' Hle1 Hle2.
*
  generalize Hle2 ; intros Hh; apply fprefix_height in Hh.
  unfold fprefix in Hle2.
  rewrite Hle2.
  destruct t; cbn in Hle1; try lia.
  destruct t'; cbn in Hh; try lia; auto.
*
  generalize Hle2 ; intros Hh; apply fprefix_height in Hh.
  destruct t; cbn in Hle1; try lia.
  destruct t'; cbn in Hh; try lia.
  inversion Hle2; subst.
  cbn.
  rewrite map_length.
  destruct (le_lt_dec (length l0) a); auto.
  replace  (nth a
       (map
          (cut
             (list_max (map height l)))
          l0) bot) with  (nth a
       (map
          (cut
             (list_max (map height l)))
          l0) (cut (list_max (map height l)) bot));
    [|destruct (list_max (map height l)); auto].
  rewrite map_nth.
  apply lt_S_n in Hle1.
  apply le_S_n in Hh.
  destruct (le_lt_dec ((list_max (map height l))) (height (nth a l0 bot))).
  +
    eapply IHp.
    -
      rewrite cut_below_height; auto.
    -
      unfold fprefix.
      rewrite cut_below_height; auto.
  +
    rewrite cut_above_height; auto ; lia.
Qed.

Lemma fpos_sym_fprefix :
  forall p t t',  length p < height t ->  fprefix t t' ->
                  fpos_sym p t' = fpos_sym p t.
Proof.
intros p t t' Hlt Hle.
do 2 rewrite <- fmirror_fpos.
apply fpos_fprefix.
*
  rewrite fmirror_height; auto.
*
  apply fmirror_mono; auto.
Qed.

End FmirrorMod.

Module NatTypeMod <: TypeMod.
Definition A := nat.
End NatTypeMod.

Module TreeDom := FtreeMod NatTypeMod.
Module TreeRan := FtreeMod NatTypeMod.

Module ProductiveMirrorMod <: ProductiveFuncMod TreeDom TreeRan.

Module Export CPO1 :=CPOMod TreeDom.
Module Export CPO2 :=CPOMod TreeRan.

Module FM := FmirrorMod NatTypeMod.
Import FM.

Definition fc : TreeDom.Cc -> TreeDom.Cc := fmirror.

Lemma fc_mono :
  forall x y,  TreeDom.ordc x y -> TreeRan.ordc (fc x) (fc y).
Proof.
intros x y HD.
now apply fmirror_mono.
Qed.

Lemma increasing_image :
  forall q,  increasing TreeDom.ordc q ->
               increasing  TreeRan.ordc (fun n =>  fc (q n)).
Proof.
intros q Hi n.
apply fc_mono, Hi.
Qed.

Lemma fc_prod : forall (q: Seq (A := TreeDom.Cc))
                       (Hi : increasing TreeDom.ordc q),
    CPO1.is_cls(CPO1.lim (fun n => CPO1.elt (q n))
                         (CPO1.map_elt_increasing _ Hi)) ->
    CPO2.is_cls(CPO2.lim (fun n => CPO2.elt (fc (q n)))
               (CPO2.map_elt_increasing  _ (increasing_image _ Hi))).
intros q Hi Hc.
unfold fc.
remember ((lim (fun n : nat => elt (fmirror (q n)))
       (map_elt_increasing
          (fun n : nat => fmirror (q n))
          (increasing_image q Hi)))) as c.
destruct c; try constructor.
exfalso.
unfold lim in Heqc.
destruct (excluded_middle_informative
             (stabilizing
                (fun n : nat =>
                   elt (fmirror (q n))))) ; try discriminate.
clear Heqc.
unfold CPO1.lim in Hc.
destruct (excluded_middle_informative
             (stabilizing (fun n : nat => CPO1.elt (q n)))).
*
  destruct ( constructive_indefinite_description _ s0).
  destruct x; try inversion Hc.
  destruct s1 as (n & Hall).
  specialize (Hall _ (le_refl _)).
  discriminate.
*
  clear Hc.
  apply n; clear n.
  destruct s as (a & n & Hall).
  destruct a.
  +
    unfold stabilizing.
    exists (CPO1.elt (fmirror e0)), n.
    intros m Hle.
    f_equal.
    specialize (Hall _ Hle).
    injection Hall; clear Hall; intro Hall; subst.
    now rewrite fmirror_inv.
  +
    specialize (Hall _ (le_refl _)).
    discriminate.
Qed.

End ProductiveMirrorMod.

Module MirrorProperties.
Module MD := FuncDefMod TreeDom TreeRan ProductiveMirrorMod.
Import MD.
Import TreeDom TreeRan ProductiveMirrorMod.
Module FM := FmirrorMod NatTypeMod.
Import FM.
Definition mirror := f.

Definition rpos (p : list nat) (c : CPO2.EC.EqClass) : option nat:=
  fpos p (proj1_sig (CPO2.EC.representative c)
         (proj1_sig (constructive_indefinite_description _
                                          (CPO2.SEM.ascending_mu_unbounded_alt
                                            (CPO2.EC.representative c)   (S (length p)))))).

Lemma rpos_fpos :
  forall p c,  exists k,  mu (proj1_sig (CPO2.EC.representative c) k) >= S (length p) /\
                rpos p c = fpos p (proj1_sig (CPO2.EC.representative c) k).
Proof.
intros p c.
remember  (EC.representative c) as q.
destruct q as (q & Ha).
cbn.
unfold rpos.
cbn.
exists
         (proj1_sig
            (constructive_indefinite_description
               (fun n : nat =>
                mu
                  (proj1_sig
                     (EC.representative
                     c) n) >=
                S (length p))
               (SEM.ascending_mu_unbounded_alt
                  (EC.representative
                     c)
                  (S (length p))))).
split; auto.
*
  remember ((constructive_indefinite_description
       (fun n : nat =>
        mu (proj1_sig (EC.representative c) n) >=
        S (length p))
       (SEM.ascending_mu_unbounded_alt
          (EC.representative c)
          (S (length p))))) as c'.
  destruct c' as (k & Hk).
  cbn.
  clear Heqc'.
  now rewrite <- Heqq in Hk.
*
  now rewrite <- Heqq.
Qed.

Definition pos (p : list nat) (c:CPO2.C) : option nat :=
  match c with
  | CPO2.elt e => fpos p e
  | CPO2.cls c => rpos p c
  end.

Definition rpos_sym (p : list nat) (c : CPO1.EC.EqClass) : option nat:=
  fpos_sym p ((proj1_sig (CPO1.EC.representative c))
             (proj1_sig (constructive_indefinite_description _
                                                             (CPO1.SEM.ascending_mu_unbounded_alt
                                                                (CPO1.EC.representative c) (S (length p)))))).

Lemma rpos_sym_fpos_sym :
  forall p c,  exists k,  mu (proj1_sig (CPO1.EC.representative c) k) >= S (length p) /\
                rpos_sym p c = fpos_sym p (proj1_sig (CPO1.EC.representative c) k).
Proof.
intros p c.
remember  (CPO1.EC.representative c) as q.
destruct q as (q & Ha).
cbn.
unfold rpos_sym.
cbn.
exists
         (proj1_sig
            (constructive_indefinite_description
               (fun n : nat =>
                mu
                  (proj1_sig
                     (CPO1.EC.representative
                     c) n) >=
                S (length p))
               (CPO1.SEM.ascending_mu_unbounded_alt
                  (CPO1.EC.representative
                     c)
                  (S (length p))))).
split; auto.
*
  remember ((constructive_indefinite_description
       (fun n : nat =>
        mu (proj1_sig (CPO1.EC.representative c) n) >=
        S (length p))
       (CPO1.SEM.ascending_mu_unbounded_alt
          (CPO1.EC.representative c)
          (S (length p))))) as c'.
  destruct c' as (k & Hk).
  cbn.
  clear Heqc'.
  now rewrite <- Heqq in Hk.
*
   now rewrite <- Heqq.
Qed.

Definition pos_sym (p : list nat) (c:CPO1.C) : option nat :=
  match c with
  | CPO1.elt e => fpos_sym p e
  | CPO1.cls c => rpos_sym p c
  end.

Lemma mirror_pos : forall p t,  pos p (mirror t) = pos_sym p t.
Proof.
intros p t.
destruct t.
*
  cbn.
  apply ProductiveMirrorMod.FM.fmirror_fpos.
*
  cbn.
 remember (CPO1.EC.representative ec) as q.
 destruct q as (q & Ha).
 cbn.
 destruct (rpos_fpos p  (CPO2.EC.class_of
       (exist (ascending ordc)
          (fun n : nat => fc (q n))
          (fc_prod_asc q Ha)))) as (k1 & Hm1 & Heq1).

 unfold Cc, Seq in *.
 rewrite Heq1.
 destruct (rpos_sym_fpos_sym  p ec) as (k1' & Hm1' & Heq'1).
 rewrite <-  Heqq in *.
 cbn in *.
 rewrite Heq'1.
 unfold fc in *.
 clear Heq1 Heq'1 Heqq.
 generalize (EC.sim_representative   (exist
                                (ascending ordc)
                                (fun n : nat =>
                                 ProductiveMirrorMod.FM.fmirror
                                   (q n))
                                (fc_prod_asc q Ha))); intro Hsim.
 unfold Cc, Seq in *.
 cbn.
remember   (EC.representative
              (EC.class_of
                 (@exist
                    (forall _ : nat,
                     @Ftree NatTypeMod.A)
                    (@ascending (@Ftree NatTypeMod.A)
                       ordc)
                    (fun n : nat =>
                     ProductiveMirrorMod.FM.fmirror
                       (q n)) (fc_prod_asc q Ha)))) as r.
destruct r  as (r & Har).
cbn in *.
destruct  (Hsim (S (length p))) as (x & (n & Ho1 & Ho2 & Hge)).
remember (k1 + k1' + n) as N.
unfold ordc, mu in *.
replace height with F.height in *; auto.
assert (Heq1 : fpos p (r N) = fpos p (r k1)).
{
  eapply fpos_fprefix; try lia.
  apply increasing_alt;
    [apply fprefix_refl | apply fprefix_trans | apply fprefix_antisym | now destruct Har | lia ].
}
rewrite <- Heq1.
assert (Heq2 : fpos p (r N) = fpos p x ).
{
  eapply fpos_fprefix; try lia.
  apply fprefix_trans with (t2 := r n); auto.
  apply increasing_alt;
    [apply fprefix_refl | apply fprefix_trans | apply fprefix_antisym | now destruct Har | lia ].
}
rewrite Heq2.
assert (Heq3 : fpos p (ProductiveMirrorMod.FM.fmirror (q N)) = fpos p x).
{
  eapply fpos_fprefix; try lia.
  apply fprefix_trans with (t2 := (ProductiveMirrorMod.FM.fmirror
             (q n))); auto.
  eapply increasing_alt with (q0:= fun n => (ProductiveMirrorMod.FM.fmirror (q n)))(i := n)(j := N);
    [apply fprefix_refl | apply fprefix_trans | apply fprefix_antisym |  | lia ].
  intro z.
  replace fprefix with ProductiveMirrorMod.FM.F.fprefix; auto.
  apply ProductiveMirrorMod.FM.fmirror_mono.
  destruct Ha as (Hi & Hns).
  apply Hi.
}
rewrite <- Heq3.
rewrite ProductiveMirrorMod.FM.fmirror_fpos.
replace (ProductiveMirrorMod.FM.fpos_sym) with fpos_sym in *; auto.
eapply fpos_sym_fprefix; try lia.
  apply increasing_alt;
    [apply fprefix_refl | apply fprefix_trans | apply fprefix_antisym | now destruct Ha | lia].
Qed.

End MirrorProperties.


Require Import ZArith_base Lia.
Require Import QArith Qabs.
Require Import Setoid SetoidClass Morphisms.

Require Import Rcauchy_lemmas.

Definition R := nat -> Q.
Local Open Scope Q_scope.

Definition Req u v :=
  forall ε, ε > 0 -> exists N:nat, forall n m, (n > N)%nat -> (m > N)%nat ->
      Qabs (u n - v m) < ε.

Lemma equiv_trans : Transitive Req.
intros x y z H1 H2 ε ?.
assert (Hε : (ε * (1#2)) > 0).
apply Qdiv_pos.
assumption.

destruct (H1 (ε * (1#2)) Hε) as [N₁ H₁].
destruct (H2 (ε * (1#2)) Hε) as [N₂ H₂].
exists (Max.max N₁ N₂).
intros n m Hn Hm.
apply Qle_lt_trans with (Qabs ((x n - y m) + (y m - z m))).
setoid_replace (x n - y m + (y m - z m)) with (x n - z m); [|ring].
apply Qle_refl.
apply Qle_lt_trans with ((Qabs (x n - y m)) + (Qabs (y m - z m))).
eapply Qabs_triangle.
setoid_replace ε with (ε * (1#2) + ε*(1#2)); [|field].
assert (Qabs (x n - y m) < ε * (1#2)).
apply H₁.
apply le_lt_trans with (Max.max N₁ N₂); [ apply Max.le_max_l | assumption].
apply le_lt_trans with (Max.max N₁ N₂); [ apply Max.le_max_l | assumption].
assert (Qabs (y m - z m) < ε * (1#2)).
apply H₂.
apply le_lt_trans with (Max.max N₂ N₁); [ apply Max.le_max_l | rewrite Max.max_comm; assumption].
apply le_lt_trans with (Max.max N₂ N₁); [ apply Max.le_max_l | rewrite Max.max_comm; assumption].
auto with qarith.
apply Qplus_lt_morphism; assumption.
Qed.

Lemma equiv_sym : Symmetric Req.
intros x y H.
intros ε Hpos.
destruct (H ε Hpos) as [N Hε].
exists N.
intros.
setoid_replace (y n - x m) with (- (x m - y n)).
rewrite Qabs_opp.
apply Hε; assumption.
ring.
Qed.

Add Parametric Relation : R Req
   symmetry proved by equiv_sym
   transitivity proved by equiv_trans
 as Req_per.
Instance defaut_relation_Req : DefaultRelation Req.
Defined.

Program Instance R_partial_setoid : PartialSetoid R := {
  pequiv := Req
}.

Declare Scope R_scope.
Delimit Scope R_scope with R.
Local Open Scope R_scope.

Definition R0 : R := fun _ => 0%Q.
Definition R1 : R := fun _ => 1%Q.
Definition Rplus (u v : R) : R := fun n => (u n) + (v n).
Definition Rmult (u v : R) : R := fun n => (u n) * (v n).
Definition Ropp (u : R) : R := fun n => - (u n).
Definition Rabs (u : R) := fun n => Qabs (u n).
Definition Rpositive (u : R) := exists v, u =~= v /\ forall n, (v n > 0)%Q.
Definition Rlt u v := Rpositive (Rplus v (Ropp u)).

Definition Rinv u (H : ~(u =~= R0)) := fun n => Qinv (u n).

Infix "+" := Rplus : R_scope.
Infix "*" := Rmult : R_scope.
Notation "- x" := (Ropp x) : R_scope.
Notation "/ x H" := (Rinv x H) (at level 100) : R_scope.
Infix "<" := Rlt : R_scope.

(* A bit too much... why omega can't do that ? *)
Ltac max_solve trm := match trm with
    O => fail
 | S ?p =>
       eassumption
    || (eapply Max.le_max_l; max_solve p)
    || (eapply Max.le_max_r; max_solve p)
    || eauto with zarith
    || (eapply le_lt_trans; max_solve p)
    || (rewrite Max.max_comm; max_solve p)
   end.
Tactic Notation "max_solve" := max_solve 6%nat.

Add Morphism Rplus with signature (Req ==> Req ==> Req) as Rplus_comp.
intros u₁ u₂ H1 v₁ v₂ H2.
intros ε Hpos.
assert (Hε : (ε * (1#2)) > 0).
apply Qdiv_pos.
assumption.
destruct (H1 (ε*(1#2)) Hε)%Q as [N₁ H₁]; clear H1.
destruct (H2 (ε*(1#2))%Q Hε) as [N₂ H₂]; clear H2.
exists (Max.max N₁ N₂).
intros n m Hn Hm.
unfold Rplus.
setoid_replace (u₁ n + v₁ n - (u₂ m + v₂ m))%Q with ((u₁ n - u₂ m) + (v₁ n - v₂ m))%Q;[|ring].
apply Qle_lt_trans with ((Qabs (u₁ n - u₂ m)) + (Qabs (v₁ n - v₂ m)))%Q.
apply Qabs_triangle.
setoid_replace ε with (ε * (1#2) + ε*(1#2))%Q; [|field].
apply Qplus_lt_morphism.
apply H₁; max_solve.
apply H₂; eapply le_lt_trans; try eapply Max.le_max_r; eauto with arith.
Qed.

Fixpoint bounded_abs_max u n := match n with
   O => Qabs (u O)
 | S p => Qmax (bounded_abs_max u p) (Qabs (u p))
end.

Lemma bounded_correct:
  forall u N n, (n < N)%nat -> (Qabs (u n) <= (bounded_abs_max u N))%Q.
intros u N n Hn.
induction N; simpl.
inversion Hn.

inversion Hn.
rewrite Qmax_comm.

apply le_Qmax.
apply Qle_refl.
apply le_Qmax.
apply IHN.
lia.
Qed.

Lemma bounded :
  forall u v:R, u =~= u -> exists M, forall n:nat, (Qabs (u n) <= M)%Q.
intros.
destruct (H 1%Q) as [N HN].
auto with qarith.
exists (Qmax (bounded_abs_max u (S N)) (Qabs (u (S N)) + 1))%Q.
intros n.
elim (le_lt_dec n N); intros Hdec.
apply le_Qmax.
apply bounded_correct.
lia.
rewrite Qmax_comm.
apply le_Qmax.
assert (Qabs (u n) - Qabs(u (S N)) <= 1).
apply Qle_trans with (Qabs (u n - u(S N))).
apply Qabs_triangle_reverse.
apply Qlt_le_weak.
apply HN.
assumption.
lia.
rewrite Qplus_comm.
setoid_replace (Qabs (u n)) with
               ((Qabs (u n) - Qabs (u (S N))) + Qabs (u (S N)))%Q;[|ring].
apply Qplus_le_compat.
assumption.
apply Qle_refl.
Qed.

Add Morphism Rmult with signature (Req ==> Req ==> Req) as Rmult_comp.
intros u₁ u₂ H1 v₁ v₂ H2.
intros ε Hpos.

assert (EC : (exists C, forall n, Qabs (u₁ n) < C /\ Qabs (u₂ n) < C /\ Qabs (v₁ n) < C /\ Qabs (v₂ n) < C)%Q).
(** skip at first read **)
assert (EA₁ :(exists A₁, forall n, Qabs (u₁ n) < A₁)%Q).
destruct (bounded u₁ u₁) as [A₁ HA₁].
eapply transitivity; [|symmetry];eassumption.
exists (A₁ + 1)%Q.
intros n; eapply Qle_lt_trans.
eapply HA₁.
setoid_replace A₁ with (A₁ + 0)%Q at 1; [|ring].
apply Qplus_le_lt_compat; auto with qarith.
destruct EA₁ as [A₁ HA₁].
assert (EA₂ :(exists A₂, forall n, Qabs (u₂ n) < A₂)%Q).
destruct (bounded u₂ u₂) as [A₂ HA₂].
eapply transitivity; [symmetry|];eassumption.
exists (A₂ + 1)%Q.
intros n; eapply Qle_lt_trans.
eapply HA₂.
setoid_replace A₂ with (A₂ + 0)%Q at 1; [|ring].
apply Qplus_le_lt_compat; auto with qarith.
destruct EA₂ as [A₂ HA₂].

assert (EB₁ :(exists B₁, forall n, Qabs (v₁ n) < B₁)%Q).
destruct (bounded v₁ v₁) as [B₁ HB₁].
eapply transitivity; [|symmetry];eassumption.
exists (B₁ + 1)%Q.
intros n; eapply Qle_lt_trans.
eapply HB₁.
setoid_replace B₁ with (B₁ + 0)%Q at 1; [|ring].
apply Qplus_le_lt_compat; auto with qarith.
destruct EB₁ as [B₁ HB₁].
assert (EB₂ :(exists B₂, forall n, Qabs (v₂ n) < B₂)%Q).
destruct (bounded v₂ v₂) as [B₂ HB₂].
eapply transitivity; [symmetry|];eassumption.
exists (B₂ + 1)%Q.
intros n; eapply Qle_lt_trans.
eapply HB₂.
setoid_replace B₂ with (B₂ + 0)%Q at 1; [|ring].
apply Qplus_le_lt_compat; auto with qarith.
destruct EB₂ as [B₂ HB₂].
exists (Qmax (Qmax A₁ A₂) (Qmax B₁ B₂)).
intros n.
let rec t trm := match trm with
    O => fail
 | S ?p =>
   first [ apply HA₁ | apply HA₂ | apply HB₁ | apply HB₂  | apply lt_Qmax; t p| rewrite Qmax_comm; t p]
end in repeat split; t 6%nat.
(** Ok, you can continue your reading here. *)
destruct EC as [C HC].
assert (Hpos_C : C > 0).
apply Qle_lt_trans with (Qabs (u₁ O)).
apply Qabs_nonneg.
elim (HC O); intuition.
assert (Hpos_complique : (ε * (Qinv C)*(1#3)) > 0).
apply Qdiv_pos.
apply Qmult_pos_compat.
assumption.
apply Qinv_lt_0_compat.
assumption.
destruct (H1 (ε * (Qinv C)*(1#3))%Q Hpos_complique) as [N₁ H₁]; clear H1.
destruct (H2 (ε * (Qinv C)*(1#3))%Q Hpos_complique) as [N₂ H₂]; clear H2.
exists (Max.max N₁ N₂).
intros n m Hn Hm.
unfold Rmult.
setoid_replace (u₁ n * v₁ n - u₂ m * v₂ m)
               with (u₁ n * (v₁ n - v₂ m) + v₂ m * (u₁ n - u₂ m))%Q; [|ring].
eapply Qle_lt_trans.
eapply Qabs_triangle.
do 2 rewrite Qabs_Qmult.
apply Qle_lt_trans with
    ((C * (ε * / C * (1 # 3))+ (C * (ε * / C * (1 # 3)))))%Q.
apply Qplus_le_morphism; (apply Qmult_pos_le_compat; (split; [ apply Qabs_nonneg | ])).
elim (HC n); intuition.
apply Qlt_le_weak; apply H₂; eapply le_lt_trans; try eapply Max.le_max_r; eauto with arith.
elim (HC m); intuition.
apply Qlt_le_weak; apply H₁; max_solve.
setoid_replace (C * (ε * / C * (1 # 3)) + C * (ε * / C * (1 # 3)))%Q
               with ((2#3)*ε)%Q.
setoid_replace ε with (1*ε)%Q at 2.
apply Qmult_lt_compat_r.
assumption.
auto with qarith.
field.
field.
intro Abs; rewrite Abs in Hpos_C.
inversion Hpos_C.
Qed.

Lemma far_from_zero :
  forall u:R, u =~= u -> ~(u =~= R0) -> exists N, forall n:nat, (n > N)%nat -> (Qabs (u n) > 0)%Q.
(* Il faut EM pour prouver ça. *)
Admitted.

(* This is the most difficult thing I have ever written with setoids. *)
Definition sign_rinv : relation (forall x:R, ~(x=~=R0) -> R).
refine (respectful_hetero R R (fun x => ~(x =~= R0) -> R) (fun x => ~(x =~= R0) -> R)
           Req
           _).
intros x y.
refine (respectful_hetero (~(x =~= R0)) (~(y =~= R0)) (fun _ => R) (fun _ => R)
           (fun x y => True) (fun _ _ => Req)).
Defined.

(* It's complicated. Ok. But no body has to understand it.
   The important thing is that the following morphism just say
   what we want it to say. *)
Instance Rinv_comp : Proper sign_rinv Rinv.
intros u v Huv π₁ π₂ _.
intros ε Hpos.

destruct (far_from_zero u) as [Nu].
eapply transitivity;[|symmetry];eassumption.
assumption.
destruct (far_from_zero v) as [Nv].
eapply transitivity;[symmetry|];eassumption.
assumption.
exists (Max.max Nu Nv).
intros n m Hn Hm.
unfold Rinv.

Admitted.


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

Set Implicit Arguments.
Require Import BinPos.
Require Export List.
Require Export ListTactics.
Open Local Scope positive_scope.

Section MakeBinList.
 Variable A : Type.
 Variable default : A.

 Fixpoint jump (p:positive) (l:list A) {struct p} : list A :=
  match p with
  | xH => tail l
  | xO p => jump p (jump p l)
  | xI p  => jump p (jump p (tail l))
  end.

 Fixpoint nth (p:positive) (l:list A) {struct p} : A:=
  match p with
  | xH => hd default l
  | xO p => nth p (jump p l)
  | xI p => nth p (jump p (tail l))
  end.

 Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
 Proof.
  induction j;simpl;intros.
  repeat rewrite IHj;trivial.
  repeat rewrite IHj;trivial.
  trivial.
 Qed.

 Lemma jump_Psucc : forall j l,
  (jump (Psucc j) l) = (jump 1 (jump j l)).
 Proof.
  induction j;simpl;intros.
  repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial.
  repeat rewrite jump_tl;trivial.
  trivial.
 Qed.

 Lemma jump_Pplus : forall i j l,
  (jump (i + j) l) = (jump i (jump j l)).
 Proof.
  induction i;intros.
  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
  repeat rewrite IHi.
  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
  repeat rewrite IHi;trivial.
  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
 Qed.

 Lemma jump_Pdouble_minus_one : forall i l,
  (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
 Proof.
  induction i;intros;simpl.
  repeat rewrite jump_tl;trivial.
  rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial.
  trivial.
 Qed.

 Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l).
 Proof.
  induction p;simpl;intros.
  rewrite <-jump_tl;rewrite IHp;trivial.
  rewrite <-jump_tl;rewrite IHp;trivial.
  trivial.
 Qed.

 Lemma nth_Pdouble_minus_one :
  forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
 Proof.
  induction p;simpl;intros.
  repeat rewrite jump_tl;trivial.
  rewrite jump_Pdouble_minus_one.
  repeat rewrite <- jump_tl;rewrite IHp;trivial.
  trivial.
 Qed.

End MakeBinList.


(*===========================================================================
  Properties of bit vectors
  ===========================================================================*)
From Coq
    Require Import ZArith.ZArith.
(*Require Import common.tuplehelp common.nathelp.*)
Require Import mathcomp.ssreflect.ssreflect.

From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype tuple div zmodp ssralg.
Require Import ssrextra.nat ssrextra.tuple.
Require Import spec.spec.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma trivialBits (p q: BITS 0) : p = q.
Proof. by rewrite (tuple0 p) (tuple0 q). Qed.

(*---------------------------------------------------------------------------
    Properties of conversion to and from natural numbers.
  ---------------------------------------------------------------------------*)
Lemma toNatCons n b (p:BITS n) : toNat (consB b p) = b + (toNat p).*2.
Proof. done. Qed.

Lemma toNatNil (p:BITS 0) : toNat p = 0.
Proof. by rewrite (tuple0 p). Qed.

(* toNat is left-inverse to fromNat *)
Lemma toNatK n : cancel (@toNat n) (@fromNat n).
Proof. induction n; first (move => p; apply trivialBits).
+ case/tupleP => b x. rewrite toNatCons/fromNat-/fromNat /= half_bit_double.
rewrite IHn oddD odd_double. by case b.
Qed.

(* Hence toNat is injective *)
Definition toNat_inj n := can_inj (@toNatK n).

(* toNat result is bounded *)
Lemma toNatBounded n : forall (p: BITS n), toNat p < 2^n.
Proof. induction n. move => p. by rewrite toNatNil.
case/tupleP => [b p].
rewrite expnS mul2n toNatCons.
case b.
+ rewrite ltn_Sdouble. apply IHn.
+ rewrite ltn_double. apply IHn.
Qed.

Lemma toNat_fromNatBounded n : forall m, m < 2^n -> toNat (fromNat (n:=n) m) = m.
Proof. induction n.
+ rewrite expn0. by case.
+ rewrite expnS. move => m.  specialize (IHn m./2).
  move => LT.
  assert (m./2 < 2^n).
  rewrite -ltn_double. rewrite -(odd_double_half m) mul2n in LT.
  rewrite -(ltn_add2l (odd m)).
  by apply ltn_addl.
  specialize (IHn H).
  rewrite /toNat-/toNat/=.
  rewrite /toNat/= in IHn. rewrite IHn.
  by rewrite odd_double_half.
Qed.

Lemma fromNatBounded_eq m1 m2 n : m1 < 2^n -> m2 < 2^n ->
  (m1==m2) = (fromNat (n:=n) m1 == fromNat m2).
Proof. move => B1 B2.
case E: (m1 == m2);
case E': (#m1 == #m2) => //. by rewrite (eqP E) eq_refl in E'.
rewrite -(toNat_fromNatBounded B1) -(toNat_fromNatBounded B2) in E.
by rewrite (eqP E') eq_refl in E.
Qed.

Lemma fromNatHalf n m : cons_tuple (odd m) (fromNat (n:=n) m./2) = fromNat m.
Proof. done. Qed.

Lemma fromNat_wrap n : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + 2^n).
Proof. induction n => //.
rewrite expnS.
move => m.
case ODD: (odd m); rewrite /fromNat-/fromNat /=ODD oddD oddM/=ODD/= halfD ODD/=.
specialize (IHn m./2). by rewrite oddM/= add0n mul2n doubleK IHn.
specialize (IHn m./2). by rewrite add0n mul2n doubleK IHn.
Qed.

Lemma fromNat_wrapMany n c : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + c * 2^n).
Proof. induction c => m. by rewrite mul0n addn0.
rewrite mulSn (addnC (2^n)) addnA fromNat_wrap. rewrite IHc.
by rewrite -addnA (addnC (2^n)) addnA.
Qed.

Lemma toNat_mod n (p:BITS n): toNat p = toNat p %% 2^n.
Proof. rewrite modn_small => //. apply toNatBounded. Qed.

Lemma toNat_fromNat n m : @toNat n (fromNat m) = m %% 2^n.
Proof. have H:= divn_eq m (2^n). rewrite {1}H.
have HH:= @fromNat_wrapMany n (m %/ 2^n) (m %% 2^n). rewrite addnC in HH. rewrite -HH.
rewrite toNat_fromNatBounded. done. apply ltn_pmod. apply expn_gt0. Qed.

(* TODO: remove *)
Lemma splitTuple {X n} {a b:X} {c d:n.-tuple X} : cons_tuple a c = cons_tuple b d -> a = b /\ c = d.
Proof. move => H. split. by inversion H. apply val_inj. by inversion H. Qed.

Lemma fromNat_succn n : forall b c, @fromNat n b = fromNat c -> @fromNat n (b.+1) = fromNat(c.+1).
Proof. induction n => //.
move => b c EQ. rewrite /fromNat-/fromNat. rewrite /fromNat-/fromNat in EQ.
elim: (splitTuple EQ) => [EQ1 EQ2]. simpl in EQ1. simpl in EQ2.
specialize (IHn _ _ EQ2). rewrite/= !uphalf_half /=EQ1.
case ODD: (odd c). + by rewrite !add1n IHn. + by rewrite !add0n EQ2.
Qed.

Lemma fromNat_addn n : forall a b c, @fromNat n b = fromNat c -> @fromNat n (a+b) = fromNat(a+c).
Proof. induction a => //.
move => b c EQ. rewrite -addn1 -!addnA !add1n. apply IHa. by apply fromNat_succn.
Qed.

Lemma toZp_fromNat n m : toZp (fromNat (n:=n.+1) m) = (m%:R)%R.
Proof. apply val_inj.
rewrite /toZp toNat_fromNat Zp_nat.
rewrite /=Zp_cast; last apply pow2_gt1.
by rewrite modn_mod.
Qed.

Lemma toZpAux_fromNat n c : toZpAux (m:=n.+1) (fromNat (n:=n.+1) c) = (c%:R)%R.
Proof. apply val_inj.
rewrite /toZpAux toNat_fromNat Zp_nat.
rewrite /=Zp_cast; last apply pow2_gt1.
by rewrite modn_mod.
Qed.

#[export]
Hint Rewrite toZp_fromNat toZpAux_fromNat : ZpHom.

Lemma toNat_droplsb n (p: BITS n.+1) : toNat (droplsb p) = (toNat p)./2.
Proof. case/tupleP: p => [b p]. rewrite /droplsb/splitlsb beheadCons theadCons.
by rewrite toNatCons/= half_bit_double.
Qed.

Lemma toNatCat m n (p : BITS m) (q: BITS n) :
  toNat (p ## q) = toNat p * 2^n + toNat q.
Proof.
elim: n q; first by move=> q; rewrite (tuple0 q) addn0 expn0 muln1.
move=> n IHn; case/tupleP => [b q].
rewrite /catB catCons !toNatCons IHn expnS -!muln2; ring.
Qed.

(*---------------------------------------------------------------------------
    Properties of conversion to and from 'Z_(2^n)
  ---------------------------------------------------------------------------*)

(* This only holds for n.+1 because 'Z_1 actually has two elements - it's
   definitionally the same as 'Z_2 in order to force a ring structure. See zmodp
   for more details *)
Lemma fromZpK n : cancel (@fromZp n.+1) (@toZp n.+1).
Proof.
  move => x. rewrite /toZp/fromZp. rewrite  toNat_fromNat modn_small. apply valZpK.
  destruct x. simpl. rewrite Zp_cast in i => //.
  apply pow2_gt1.
Qed.

Lemma toZpK n : cancel (@toZp n) (@fromZp n).
Proof. case E: (n == 0).
+ rewrite /cancel. rewrite (eqP E). move => x. apply trivialBits.
+ move => x. rewrite /fromZp/toZp/=.
  rewrite Zp_cast. by rewrite (modn_small (toNatBounded _)) toNatK.
  apply negbT in E. destruct n => //. apply pow2_gt1.
Qed.

Lemma toZp_inj n : injective (@toZp n).
Proof. apply (can_inj (@toZpK _)). Qed.

Lemma fromZp_inj n : injective (@fromZp n.+1).
Proof. apply (can_inj (@fromZpK _)). Qed.

Lemma toZp_eq n (x y: BITS n) : (x == y) = (toZp x == toZp y).
Proof. destruct n. by rewrite (tuple0 x) (tuple0 y).
case E: (toZp x == toZp y).
rewrite (toZp_inj (eqP E)). by rewrite eq_refl.
apply (contraFF (b:=false)) => // => H.
rewrite (eqP H) (eq_refl) in E. done.
Qed.

Corollary toZp_neq n (x y: BITS n) : (x != y) = (toZp x != toZp y).
Proof. by rewrite toZp_eq. Qed.

(*---------------------------------------------------------------------------
    Properties of bit get and set
  ---------------------------------------------------------------------------*)

Lemma setBitThenGetSame n : forall (p: BITS n) i b, i<n -> getBit (setBit p i b) i = b.
Proof.
induction n => //.
case/tupleP => [b' p]. move => i b LT.
destruct i => //.
simpl. rewrite theadCons beheadCons. assert (LT' : i < n) by done.
rewrite /getBit/=. apply IHn; done.
Qed.

Lemma setBitThenGetDistinct n :
  forall (p: BITS n) i i' b, i<n -> i'<n -> i<>i' -> getBit (setBit p i b) i' = getBit p i'.
Proof.
induction n => //.
case/tupleP => [b' p]. move => i i' b LT LT' NEQ.
destruct i.
(* i = 0 *) simpl. rewrite beheadCons. destruct i' => //.
(* i <> 0 *)
destruct i' => //.
rewrite /= theadCons beheadCons /getBit/=.
assert (lt : i < n) by done.
assert (lt' : i' < n) by done.
assert (neq' : i <> i') by  intuition.
specialize (IHn p _ _ b lt lt' neq'). apply IHn.
Qed.

Lemma getBit_joinmsb :
  forall n (bs: BITS n) k,
    k <= n ->
    getBit (joinmsb (false , bs)) k = getBit bs k.
Proof.
  elim=> [|n IHn] bs k leq_k_n.
  - (* Case: n ~ 0 *)
    rewrite leqn0 in leq_k_n.
    move/eqP: leq_k_n=> ->.
    by rewrite !tuple0.
  - (* Case: n ~ n.+1 *)
    case/tupleP: bs=> [b bs].
    case: k leq_k_n => [|k leq_k_n].
    + (* Case: k ~ 0 *)
      by trivial.
    + (* Case: k ~ k.+1 *)
      rewrite /joinmsb/splitlsb tuple.beheadCons
              tuple.theadCons -/joinmsb /joinlsb //=.
      by apply: IHn; assumption.
Qed.

Lemma getBit_dropmsb:
  forall n (bs : BITS n.+1) k, k < n ->
    getBit (dropmsb bs) k = getBit bs k.
Proof.
  elim=> // n /= IHn /tupleP[b bs] k le_k.
  rewrite /dropmsb /splitmsb /=
          tuple.theadCons tuple.beheadCons /=
          -/splitmsb.
  set cr := splitmsb bs; rewrite (surjective_pairing cr).
  have ->: ((cr.1, joinlsb (cr.2, b))).2 = joinlsb (dropmsb bs, b)
    by rewrite /dropmsb.
  case: k le_k => // k le_k.
  + (* k ~ k + 1 *)
    have H: forall bs', getBit (joinlsb (bs', b)) k.+1 = getBit bs' k by compute.
    by rewrite !H; auto with arith.
Qed.

(*---------------------------------------------------------------------------
    Properties of all zeroes and all ones
  ---------------------------------------------------------------------------*)
Lemma fromNat0 n : #0 = zero n.
Proof. induction n; first apply trivialBits.
+ rewrite /zero /copy. rewrite /zero /copy in IHn. by rewrite /fromNat-/fromNat IHn nseqCons.
Qed.

Lemma count_ones:
  forall n, (count_mem true (ones n)) = n.
Proof.
  elim=> //=.
  auto with arith.
Qed.

Lemma getBit_zero:
  forall n k, getBit (n := n) #0 k = false.
Proof.
  move=> n k.
  rewrite fromNat0 /zero /copy /getBit nth_nseq if_same //.
Qed.

Lemma getBit_ones:
  forall n k, k < n -> getBit (ones n) k = true.
Proof.
  move=> n k le_k.
  by rewrite /getBit nth_nseq le_k.
Qed.

Lemma toNat_zero n : toNat (zero n) = 0.
Proof. induction n => //. rewrite /toNat/=. rewrite /toNat in IHn. by rewrite IHn. Qed.

Corollary toNat_fromNat0 n : @toNat n #0 = 0.
Proof. by rewrite fromNat0 toNat_zero. Qed.

Lemma msb_zero n : msb (zero n) = false.
Proof. by induction n. Qed.

Lemma toNat_ones_succ n : (toNat (ones n)).+1 = 2^n.
Proof. induction n => //.
rewrite /toNat/=. rewrite /toNat/= in IHn.
by rewrite expnS mul2n addnC addn1 -doubleS IHn.
Qed.

Corollary toNat_ones n : toNat (ones n) = (2^n).-1.
Proof. by rewrite -toNat_ones_succ succnK. Qed.

Lemma msb_ones n : msb (ones n.+1) = true.
Proof. by induction n. Qed.

Lemma toZp_zero n : toZp (zero n) = 0%R.
Proof. rewrite /toZp toNat_zero. by apply val_inj. Qed.

Lemma toZpAux_zero m n : toZpAux (m:=m) (zero n) = 0%R.
Proof. rewrite /toZpAux toNat_zero. by apply val_inj. Qed.

Lemma toZp_ones n : toZp (ones n.+1) = (-1)%R.
Proof. rewrite /toZp toNat_ones. apply val_inj.
rewrite /= Zp_cast; last apply pow2_gt1.
rewrite -subn1. replace (1 %% 2^n.+1) with 1 => //.
by rewrite modn_small; last apply pow2_gt1.
Qed.

#[export]
Hint Rewrite toZpK fromZpK toZp_zero toZpAux_zero toZp_ones : ZpHom.

(*---------------------------------------------------------------------------
    Properties of joinmsb and splitmsb
  ---------------------------------------------------------------------------*)

Lemma toNat_joinmsb n : forall c (p: BITS n), toNat (joinmsb (c, p)) = c * 2^n + toNat p.
Proof. induction n.
+ move => c p. by rewrite /joinmsb (tuple0 p) expn0 muln1.
+ move => c. case/tupleP => [b p].
  rewrite /joinmsb-/joinmsb /splitlsb theadCons beheadCons !toNatCons expnS IHn.
  by rewrite doubleD addnCA -mul2n mulnCA.
Qed.

Lemma toNat_joinmsb0 n (p: BITS n) : toNat (joinmsb0 p) = toNat p.
Proof. by rewrite toNat_joinmsb. Qed.

Lemma splitmsb_fromNat n :
  forall m, splitmsb (n:=n) (fromNat m) = (odd (m %/ 2^n), fromNat m).
Proof. induction n => m.
+ by rewrite /dropmsb/=beheadCons!theadCons expn0 divn1.
+ rewrite expnS. rewrite /fromNat-/fromNat/=.
  rewrite /joinlsb !beheadCons!theadCons fromNatHalf. specialize (IHn m./2). rewrite IHn.
  by rewrite -divn2 -divnMA.
Qed.

Corollary dropmsb_fromNat n m : dropmsb (n:=n) (fromNat m) = (fromNat m).
Proof. by rewrite /dropmsb splitmsb_fromNat. Qed.

Corollary toNat_dropmsb n (p: BITS n.+1) : toNat (dropmsb p) = toNat p %% 2^n.
Proof. rewrite -{1}(toNatK p). rewrite dropmsb_fromNat. by rewrite toNat_fromNat. Qed.

Lemma toZp_joinmsb0 n (p: BITS n) : toZp (joinmsb0 p) = toZpAux p.
Proof. apply val_inj.
rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1.
by rewrite toNat_joinmsb0.
Qed.

Lemma toZp_dropmsb n (p: BITS n.+2) : toZp (n:=n.+1) (dropmsb p) = toZpAux (m:=n.+1) p.
Proof.
apply val_inj.
rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1.
rewrite toNat_dropmsb.
by rewrite modn_mod.
Qed.

#[export]
Hint Rewrite toZp_joinmsb0 toZp_dropmsb : ZpHom.

Lemma splitmsbK n : cancel (@splitmsb n) (@joinmsb n).
Proof. induction n.
+ case/tupleP => [b p]. by rewrite (tuple0 p).
+ case/tupleP => [b p]. rewrite /= beheadCons theadCons. specialize (IHn p).
case E: (splitmsb p) => [b' p'].
rewrite beheadCons theadCons.
rewrite E in IHn. by rewrite IHn.
Qed.

Lemma joinmsbK n : cancel (@joinmsb n) (@splitmsb n).
Proof. induction n.
+ move => [b p]. by rewrite !(tuple0 p) /= theadCons beheadCons.
+ move => [c p]. case/tupleP: p => [b p].
  by rewrite /= !theadCons !beheadCons IHn.
Qed.

Corollary dropmsb_joinmsb n b (p:BITS n) : dropmsb (joinmsb (b, p)) = p.
Proof. by rewrite /dropmsb joinmsbK. Qed.

Lemma splitlsbK n : cancel (@splitlsb n) (@joinlsb n).
Proof. case/tupleP => [b p]. by rewrite /splitlsb beheadCons theadCons. Qed.

Lemma joinlsbK n : cancel (@joinlsb n) (@splitlsb n).
Proof. move => [p b]. by rewrite /joinlsb /splitlsb beheadCons theadCons. Qed.

Lemma toNat_joinlsb n (p:BITS n) b : toNat (joinlsb (p, b)) = b + (toNat p).*2.
Proof. done. Qed.

(* Totally ridiculous proof *)
Lemma splitmsb_rev n : forall (b: BITS n.+1) hi (lo:BITS n),
   splitmsb b = (hi,lo) -> rev b = hi::rev lo.
Proof. induction n => b hi lo/=.
+ move => [<- <-] {lo}/=. case/tupleP:b => [b u]//=. by rewrite tuple0/=.
+ move => H.
specialize (IHn (behead_tuple b) hi).
destruct (splitmsb (behead_tuple b)).
injection H => [H1 H2] {H}. rewrite H2 {H2} in IHn.
specialize (IHn b1 refl_equal). rewrite -H1/=.
case/tupleP E: b => [b' u]/=. rewrite E/= in IHn.
by rewrite 2!rev_cons IHn rcons_cons.
Qed.

(*---------------------------------------------------------------------------
    Properties of concatenation and splitting of bit strings
  ---------------------------------------------------------------------------*)
Lemma high_catB n2 n1 (p:BITS n1) (q:BITS n2) : high n1 (p ## q) = p.
Proof. induction n2.
- rewrite /high (tuple0 q). by apply catNil.
- case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. apply IHn2.
Qed.

Lemma low_catB n2 n1 (p:BITS n1) (q:BITS n2) : low n2 (p ## q) = q.
Proof. induction n2; first apply trivialBits.
case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. by rewrite IHn2.
Qed.

Lemma low_fromNat n2 n1: forall m, low n2 (fromNat (n:=n2+n1) m) = fromNat (n:=n2) m.
Proof. induction n2 => m //. by rewrite /= /joinlsb !beheadCons !theadCons/= IHn2. Qed.

Lemma split2eta : forall n2 n1 p, let (p1,p2) := split2 n1 n2 p in p = p1 ## p2.
Proof. unfold split2. induction n2.
- move =>n1 p. by rewrite /catB catNil.
- move => n1. case/tupleP => x p. rewrite /= (IHn2 n1 p).
rewrite beheadCons theadCons high_catB low_catB. by rewrite /catB catCons. Qed.

Lemma split2app n2 n1 p1 p2 : split2 n1 n2 (p1 ## p2) = (p1,p2).
Proof. by rewrite /split2 high_catB low_catB. Qed.

Lemma split3app n3 n2 n1 p1 p2 p3 : split3 n1 n2 n3 (p1 ## p2 ## p3) = (p1,p2,p3).
Proof. by rewrite /split3 !split2app. Qed.

Lemma split4app n4 n3 n2 n1 p1 p2 p3 p4 :
  split4 n1 n2 n3 n4 (p1 ## p2 ## p3 ## p4) = (p1,p2,p3,p4).
Proof. by rewrite /split4 !split2app. Qed.

Lemma split3eta n3 n2 n1 p: match split3 n1 n2 n3 p with (p1,p2,p3) => p1 ## p2 ## p3 end = p. Proof. rewrite /split3 /=. by rewrite -!split2eta. Qed.

Lemma split4eta n4 n3 n2 n1 p:
  match split4 n1 n2 n3 n4 p with (p1,p2,p3,p4) => p1 ## p2 ## p3 ## p4 end = p.
Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed.

Lemma split4eta' n4 n3 n2 n1 p:
  let: (p1,p2,p3,p4) := split4 n1 n2 n3 n4 p in p1 ## p2 ## p3 ## p4 = p.
Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed.

Lemma catB_inj n1 n2 (p1 q1: BITS n1) (p2 q2: BITS n2) :
  p1 ## p2 = q1 ## q2 -> p1 = q1 /\ p2 = q2.
Proof.
move => EQ.
have H1 := high_catB p1 p2.
have H2 := high_catB q1 q2.
have L1 := low_catB p1 p2.
have L2 := low_catB q1 q2.
split. by rewrite -H1 -H2 EQ.
by rewrite -L1 -L2 EQ.
Qed.

Lemma toNat_low n1 n2 (p: BITS (n1+n2)) : toNat (low n1 p) = toNat p %% 2^n1.
Proof. by rewrite -{1}(toNatK p) low_fromNat toNat_fromNat. Qed.

Lemma allBitsEq n (p q: BITS n) : (forall i, i < n -> getBit p i = getBit q i) -> p = q.
Proof. induction n. by rewrite (tuple0 p) (tuple0 q).
case/tupleP: p => [b p].
case/tupleP: q => [c q].
move => H. have H0:= H 0. rewrite /getBit/= in H0. rewrite H0 => //.
rewrite (IHn p q). done.
move => i LT. apply (H i.+1 LT).
Qed.

Lemma lowBitsEq n1 n2 (p q: BITS (n1+n2)) :
  (forall i, i < n1 -> getBit p i = getBit q i) <-> low n1 p = low n1 q.
Proof. induction n1 => //=.
case/tupleP: p => [b p]. fold plus in p.
case/tupleP: q => [c q]. fold plus in q.
rewrite 2!beheadCons 2!theadCons /getBit/=. split => H.
+ have H0:= H 0. rewrite /= in H0. rewrite H0 => //.
  rewrite (proj1 (IHn1 p q)). done. move => i LT. apply (H i.+1 LT).
+ move => i LT. destruct i. by injection H.
  injection H => H1 H2. subst. apply (IHn1 p q). apply val_inj. apply H1. apply LT.
Qed.

Lemma highBitsEq n1 n2 (p q: BITS (n1+n2)) :
  (forall i, n1 <= i -> getBit p i = getBit q i) <-> high n2 p = high n2 q.
Proof. induction n1 => /=.
split.
have ABE := @allBitsEq _ p q. move => H. apply: ABE. move => i H'. rewrite H => //.
by move => ->.
case/tupleP: p => [b p]. fold plus in p.
case/tupleP: q => [c q]. fold plus in q.
rewrite 2!beheadCons /getBit/=. split => H.
+ apply IHn1. move => i LE. apply (H i.+1 LE).
+ have IH' := (proj2 (IHn1 p q)). case => // i. by apply IH'.
Qed.

Lemma getBit_low n1: forall n2 (p: BITS (n1+n2)) i,
  getBit (low n1 p) i = if i < n1 then getBit p i else false.
Proof. induction n1 => // n2 p i. destruct i => //. case/tupleP: p => [b p].
rewrite /getBit/joinlsb/= beheadCons theadCons. destruct i => //. apply IHn1.
Qed.

Lemma getBit_high n1: forall n2 (p: BITS (n1+n2)) i,
  getBit (high n2 p) i = getBit p (i+n1).
Proof. induction n1 => // n2 p i. by rewrite addn0.
rewrite addnS. case/tupleP: p => [b p]. apply IHn1. Qed.

Lemma getBit_catB n1 n2 (p:BITS n1) (q:BITS n2) :
  forall i, getBit (p ## q) i = if i < n2 then getBit q i else getBit p (i-n2).
Proof. induction n2 => // i.
rewrite (tuple0 q). destruct i => //.
case/tupleP: q => [b q] //. destruct i => //. apply IHn2.
Qed.

Lemma sliceEq n1 n2 n3 (p q: BITS (n1+n2+n3)) :
  (forall i, n1 <= i < n1+n2 -> getBit p i = getBit q i) <->
  slice n1 n2 n3 p = slice n1 n2 n3 q.
Proof. rewrite /slice/split3/split2.
rewrite <-highBitsEq. split.
move => H1 i LE. rewrite 2!getBit_low.
case LT: (i < (n1+n2)) => //.
- apply H1. by rewrite LE LT.
move => H i. move/andP => [LE LT].
specialize (H i LE). by rewrite 2!getBit_low LT in H.
Qed.

Lemma getUpdateSlice n1 n2 n3 (p: BITS (n1+n2+n3)) (q: BITS n2) :
  slice n1 n2 n3 (updateSlice _ _ _ p q) = q.
Proof. rewrite /slice/updateSlice/split3/split2.
by rewrite low_catB high_catB.
Qed.

Lemma bitsToBytesK n : cancel (@bitsToBytes n) (@bytesToBits n).
Proof. induction n.
+ move => x. by rewrite (tuple0 _) (tuple0 x).
+ move => xs. rewrite /bitsToBytes-/bitsToBytes.
rewrite /splitAtByte. rewrite (split2eta xs) split2app.
by rewrite /bytesToBits-/bytesToBits beheadCons theadCons IHn.
Qed.

Lemma bytesToBitsK n : cancel (@bytesToBits n) (@bitsToBytes n).
Proof. induction n.
+ move => x. by rewrite (tuple0 _) (tuple0 x).
+ move => xs. rewrite /bitsToBytes-/bitsToBytes/splitAtByte.
rewrite (split2eta (bytesToBits xs)) split2app.
case/tupleP: xs => [x xs].
rewrite /bytesToBits-/bytesToBits beheadCons theadCons.
by rewrite high_catB IHn low_catB. Qed.

(*---------------------------------------------------------------------------
    Zero and sign extension
  ---------------------------------------------------------------------------*)

Lemma signExtendK extra n : pcancel (@signExtend extra n) (signTruncate extra).
Proof. move => p. rewrite /signExtend /signTruncate split2app.
case: (msb p).
+ by rewrite /ones eq_refl.
+ by rewrite /zero eq_refl.
Qed.

Lemma signTruncateK extra n p q :
  signTruncate extra (n:=n) p = Some q ->
  signExtend extra (n:=n) q = p.
Proof. rewrite /signTruncate/signExtend.
rewrite (split2eta p) split2app.
case P: (_ || _) => // H.
have EQ: low n.+1 p = q by congruence. subst.
case M: (msb _).
+ rewrite M andTb andFb orbF in P. by rewrite (eqP P).
+ rewrite M andTb andFb orFb in P. by rewrite (eqP P).
Qed.

Lemma zeroExtendK extra n : pcancel (@zeroExtend extra n) (zeroTruncate extra).
Proof. move => p. by rewrite /zeroExtend/zeroTruncate split2app eq_refl. Qed.

Lemma zeroTruncateK extra n p q :
  zeroTruncate extra (n:=n) p = Some q ->
  zeroExtend extra (n:=n) q = p.
Proof. rewrite /zeroTruncate/zeroExtend.
rewrite (split2eta p) split2app.
case P: (high extra p == zero extra) => // H.
have EQ: low n p = q by congruence. subst.
by rewrite (eqP P).
Qed.

Lemma toNat_zeroExtend extra n (p: BITS n) : toNat (zeroExtend extra p) = toNat p.
Proof. rewrite /zeroExtend. rewrite toNatCat. by rewrite toNat_zero. Qed.

Lemma toNat_zeroExtendAux extra n (p: BITS n) : toNat (zeroExtendAux extra p) = toNat p.
Proof. induction extra => //. by rewrite /= toNat_joinmsb0 IHextra. Qed.

Lemma zeroExtend_fromNat extra n m :
  m < 2^n ->
  zeroExtend extra (fromNat (n:=n) m) = #m.
Proof. move => LT.
apply toNat_inj. rewrite toNat_zeroExtend. rewrite toNat_fromNatBounded => //.
rewrite toNat_fromNatBounded => //.
rewrite expnD.
apply (leq_trans LT). apply leq_pmulr. apply expn_gt0.
Qed.

Lemma msbNonNil n (p: BITS n.+1) b : msb p = last b p.
Proof. by case/tupleP: p => b' q. Qed.

Lemma splitmsb_msb n (p:BITS n.+1) : (splitmsb p).1 = msb p.
Proof. induction n.
+ case/tupleP: p => b q. by rewrite (tuple0 q)/= theadCons.
+ case/tupleP: p => b q. rewrite /= beheadCons theadCons. case E: (splitmsb q) => [b' q'].
specialize (IHn q). rewrite E/= in IHn. simpl. rewrite (msbNonNil q b) in IHn. by subst.
Qed.

Lemma signExtend_fromNat extra n m :
  m < 2^n ->
  signExtend extra (fromNat (n:=n.+1) m) = #m.
Proof. move => LT.
unfold signExtend. rewrite -splitmsb_msb.
rewrite splitmsb_fromNat. simpl.
rewrite divn_small => //. simpl.
replace (copy extra false ## (fromNat (n:=n.+1) m)) with (zeroExtend extra (fromNat (n:=n.+1) m)). apply zeroExtend_fromNat. rewrite expnS.
apply: (ltn_trans LT). apply ltn_Pmull => //. apply expn_gt0.
done.
Qed.

(*---------------------------------------------------------------------------
    Properties of equality
  ---------------------------------------------------------------------------*)

Lemma iffBool (b1 b2:bool) : (b1 <-> b2) -> b1==b2.
Proof. destruct b1; destruct b2; intuition. Qed.

Lemma bitsEq_nat n {b1 b2: BITS n} :  (b1 == b2) = (toNat b1 == toNat b2).
Proof. suff: b1 == b2 <-> (toNat b1 == toNat b2).

move => H. assert (H' := iffBool H). apply (eqP H').
split. move => H. rewrite (eqP H). done.
move => H. assert (EQ:toNat b1 = toNat b2) by apply (eqP H). by rewrite (toNat_inj EQ).
Qed.


Require Export ZArith.
Require Export PosAux.
Require Export List.
Require Export Bool.

Module Type MAPLIST.

  Parameter t : Type -> Type.
  Parameter key : Set.
  Parameter eq_key : key -> key -> bool.
  Parameter eq_key_spec :
      forall k1 k2, if eq_key k1 k2 then k1 = k2 else k1 <> k2.

  Parameter key_dec : forall k1 k2:key, k1=k2 \/ ~k1=k2.

  Parameter get : forall A:Type, t A -> key -> option A.
  Parameter update : forall A:Type, t A -> key -> A -> t A.

  Parameter get_update1 : forall A t k v,
    get A (update A t k v) k = Some v.
  Parameter get_update2 : forall A t k1 k2 v,
    k1 <> k2 ->
    get A (update A t k2 v) k1 = get A t k1.

  Parameter empty : forall (A:Type), t A.
  Parameter get_empty : forall A k, get A (empty A) k = None.

  Parameter fold : forall (A B:Type),
   (key->A->B->B) -> t A -> B -> B.

  Parameter dom : forall A, t A -> list key.
  Parameter in_dom_get_some : forall A m p,
    In p (dom A m) -> get A m p <> None.
  Parameter get_some_in_dom : forall A m p,
    get A m p <> None -> In p (dom A m).
  Parameter domain_inv : forall A m v p,
    In p (dom A m) -> dom A (update A m p v) = dom A m.

  Parameter for_all : forall A : Type, (key -> A -> bool) -> t A -> bool.
  Parameter for_all_true : forall (A : Type) (test:key -> A -> bool) (m : t A),
    for_all A test m = true -> forall k a, get A m k = Some a -> test k a = true.

  Definition Empty (A:Type) (t:t A) : Prop :=
    forall k, get A t k = None.

  Implicit Arguments get.
  Implicit Arguments update.
  Implicit Arguments empty.
  Implicit Arguments fold.
  Implicit Arguments dom.
  Implicit Arguments Empty.

End MAPLIST.

Module MapList_Base <: MAPLIST with Definition key:=N.

  Definition key := N.
  Definition t A := list (key * A).
  Definition eq_key := Neq.
  Lemma eq_key_spec : forall k1 k2, if eq_key k1 k2 then k1 = k2 else k1 <> k2.
  Proof. exact Neq_spec. Qed.

  Lemma key_dec : forall k1 k2:key, k1=k2 \/ ~k1=k2.
  Proof.
   intros k1 k2;generalize (eq_key_spec k1 k2);destruct (eq_key k1 k2);auto.
  Qed.

  Fixpoint get (A:Type) (l:t A) (k:key) :=
    match l with
      | nil => None
      | h :: t => if Neq k (fst h) then Some (snd h) else get A t k
    end.

  Fixpoint update (A:Type) (l:t A) (k:N) (v:A) : t A :=
    match l with
      | nil => (k, v) :: nil
      | h :: t => if Neq k (fst h) then (k, v) :: t else h :: (update A t k v)
    end.

  Lemma get_update1 : forall A t k v,
    get A (update A t k v) k = Some v.
  Proof.
    induction t0; intros.
    simpl. rewrite Neq_refl. auto.
    simpl.
    generalize (Neq_spec k (fst a));destruct (Neq k (fst a)) eqn:Heq; intros.
    simpl. rewrite Neq_refl; auto.
    simpl. rewrite Heq. apply IHt0.
  Qed.

  Lemma get_update2 : forall A t k1 k2 v,
    k1 <> k2 ->
    get A (update A t k2 v) k1 = get A t k1.
  Proof.
    induction t0; intros.
    simpl. generalize (Neq_spec k1 k2);destruct (Neq k1 k2) eqn:Heq; intros; auto.
      contradiction.
    simpl.
    generalize (Neq_spec k2 (fst a));destruct (Neq k2 (fst a)) eqn:Heq; intros.
    simpl.
    generalize (Neq_spec k1 k2);destruct (Neq k1 k2) eqn:Heq'; intros. contradiction.
    generalize (Neq_spec k1 (fst a));destruct (Neq k1 (fst a)) eqn:Heq''; intros.
    rewrite <- H0 in H2; contradiction.
    auto.
    simpl.
    generalize (Neq_spec k1 (fst a));destruct (Neq k1 (fst a)) eqn:Heq''; intros; auto.
  Qed.

  Definition empty (A:Type) := @nil (key * A).
  Lemma get_empty : forall A k, get A (empty A) k = None.
  Proof.
    unfold empty. auto.
  Qed.

  Definition fold (A B:Type) (f:key->A->B->B) (l:t A) (acc:B) :=
    fold_right (fun (pa : key * A) (b0 : B) => let (p0, a) := pa in f p0 a b0) acc l.

  Fixpoint dom (A:Type) (l:t A) :=
    match l with
      | nil => nil
      | h :: t => (fst h) :: (dom A t)
    end.

  Lemma in_dom_get_some_aux : forall A m p, get A m p = None -> ~In p (dom A m).
  Proof.
    induction m.
    unfold not; intros. inversion H0.
    unfold not; simpl; intros.
    generalize (Neq_spec (fst a) p); destruct (Neq (fst a) p) eqn:Heq; intros.
    subst. rewrite Neq_refl in H. inversion H.
    rewrite Neq_sym in Heq.
    rewrite Heq in H. apply IHm in H. inversion H0; auto.
  Qed.

  Lemma in_dom_get_some : forall A m p,
    In p (dom A m) -> get A m p <> None.
  Proof.
    unfold not; intros.
    apply in_dom_get_some_aux in H0. auto.
  Qed.

  Lemma in_dom_get_some' : forall A m p,
    In p (dom A m) -> exists v, get A m p = Some v.
  Proof.
    intros. apply in_dom_get_some in H.
    destruct (get A m p). exists a; auto.
      apply False_ind; auto.
  Qed.

  Lemma get_some_in_dom' : forall A m p v,
    get A m p = Some v -> In p (dom A m).
  Proof.
    induction m.
    intros. inversion H.
    intros. inversion H.
    destruct (Neq p (fst a)) eqn:Heq.
    left. generalize (Neq_spec p (fst a)). rewrite Heq; intros; subst; auto.
    right; apply IHm with (v:=v); auto.
  Qed.

  Lemma get_some_in_dom : forall A m p,
    get A m p <> None -> In p (dom A m).
  Proof.
    intros.
    assert (exists v, get A m p = Some v). destruct (get A m p). exists a; auto.
      apply False_ind; auto.
    destruct H0. apply get_some_in_dom' in H0; auto.
  Qed.

  Lemma domain_inv : forall A m v p,
    In p (dom A m) -> dom A (update A m p v) = dom A m.
  Proof.
    induction m; intros.
    inversion H.
    simpl.
    generalize (Neq_spec (fst a) p); destruct (Neq (fst a) p) eqn:Heq; intros.
    subst. rewrite Neq_refl; auto.
    inversion H. contradiction.
    rewrite Neq_sym in Heq; rewrite Heq. simpl.
    apply IHm with (v:=v) in H1; rewrite H1; auto.
  Qed.

  Fixpoint for_all (A:Type) (f:key -> A -> bool) (l:t A) :=
    match l with
      | nil => true
      | (k, v) :: l' => (f k v) && (for_all A f l')
    end.

  Lemma for_all_true : forall (A : Type) (test:key -> A -> bool) (m : t A),
    for_all A test m = true -> forall k a, get A m k = Some a -> test k a = true.
  Proof.
    induction m; simpl; intros.
    inversion H0. destruct a.
    elim (andb_prop _ _ H); intros; auto.
    simpl in H0.
    generalize (Neq_spec k k0); destruct (Neq k k0) eqn:Heq; intros.
    inversion H0. subst. auto.
    apply IHm; auto.
  Qed.

  Definition Empty (A:Type) (t:t A) : Prop :=
    forall k, get A t k = None.

  Implicit Arguments get.
  Implicit Arguments update.
  Implicit Arguments empty.
  Implicit Arguments fold.
  Implicit Arguments dom.
  Implicit Arguments for_all.

End MapList_Base.

Module MapList <: MAPLIST  with Definition key := N := MapList_Base.


Require Import Crypto.Util.Relations Crypto.Util.Tactics Crypto.Util.Notations.
Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms.
Require Import Crypto.Algebra Crypto.Algebra.Ring Crypto.Algebra.IntegralDomain.
Require Coq.setoid_ring.Field_theory.

Section Field.
  Context {T eq zero one opp add mul sub inv div} `{@field T eq zero one opp add sub mul inv div}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Notation "0" := zero. Local Notation "1" := one.
  Local Infix "+" := add. Local Infix "*" := mul.

  Lemma right_multiplicative_inverse : forall x : T, ~ eq x zero -> eq (mul x (inv x)) one.
  Proof.
    intros. rewrite commutative. auto using left_multiplicative_inverse.
  Qed.

  Lemma left_inv_unique x ix : ix * x = one -> ix = inv x.
  Proof.
    intro Hix.
    assert (ix*x*inv x = inv x).
    - rewrite Hix, left_identity; reflexivity.
    - rewrite <-associative, right_multiplicative_inverse, right_identity in H0; trivial.
      intro eq_x_0. rewrite eq_x_0, Ring.mul_0_r in Hix.
      apply (zero_neq_one(eq:=eq)). assumption.
  Qed.
  Definition inv_unique := left_inv_unique.

  Lemma right_inv_unique x ix : x * ix = one -> ix = inv x.
  Proof. rewrite commutative. apply left_inv_unique. Qed.

  Lemma div_one x : div x one = x.
  Proof.
    rewrite field_div_definition.
    rewrite <-(inv_unique 1 1); apply monoid_is_right_identity.
  Qed.

  Lemma mul_cancel_l_iff : forall x y, y <> 0 ->
                                       (x * y = y <-> x = one).
  Proof.
    intros.
    split; intros.
    + rewrite <-(right_multiplicative_inverse y) by assumption.
      rewrite <-H1 at 1; rewrite <-associative.
      rewrite right_multiplicative_inverse by assumption.
      rewrite right_identity.
      reflexivity.
    + rewrite H1; apply left_identity.
  Qed.

  Lemma field_theory_for_stdlib_tactic : Field_theory.field_theory 0 1 add mul sub opp div inv eq.
  Proof.
    constructor.
    { apply Ring.ring_theory_for_stdlib_tactic. }
    { intro H01. symmetry in H01. auto using (zero_neq_one(eq:=eq)). }
    { apply field_div_definition. }
    { apply left_multiplicative_inverse. }
  Qed.

  Context {eq_dec:DecidableRel eq}.

  Global Instance is_mul_nonzero_nonzero : @is_zero_product_zero_factor T eq 0 mul.
  Proof.
    split. intros x y Hxy.
    eapply not_not; try typeclasses eauto; []; intuition idtac; eapply (zero_neq_one(eq:=eq)).
    transitivity ((inv y * (inv x * x)) * y).
    - rewrite <-!associative, Hxy, !Ring.mul_0_r; reflexivity.
    - rewrite left_multiplicative_inverse, right_identity, left_multiplicative_inverse by trivial.
      reflexivity.
  Qed.

  Global Instance integral_domain : @integral_domain T eq zero one opp add sub mul.
  Proof.
    split; auto using field_commutative_ring, field_is_zero_neq_one, is_mul_nonzero_nonzero.
  Qed.
End Field.

Lemma isomorphism_to_subfield_field
      {T EQ ZERO ONE OPP ADD SUB MUL INV DIV}
      {Equivalence_EQ: @Equivalence T EQ}
      {Proper_OPP:Proper(EQ==>EQ)OPP}
      {Proper_ADD:Proper(EQ==>EQ==>EQ)ADD}
      {Proper_SUB:Proper(EQ==>EQ==>EQ)SUB}
      {Proper_MUL:Proper(EQ==>EQ==>EQ)MUL}
      {Proper_INV:Proper(EQ==>EQ)INV}
      {Proper_DIV:Proper(EQ==>EQ==>EQ)DIV}
      {R eq zero one opp add sub mul inv div} {fieldR:@field R eq zero one opp add sub mul inv div}
      {phi}
      {eq_phi_EQ: forall x y, eq (phi x) (phi y) -> EQ x y}
      {neq_zero_one : (not (EQ ZERO ONE))}
      {phi_opp : forall a, eq (phi (OPP a)) (opp (phi a))}
      {phi_add : forall a b, eq (phi (ADD a b)) (add (phi a) (phi b))}
      {phi_sub : forall a b, eq (phi (SUB a b)) (sub (phi a) (phi b))}
      {phi_mul : forall a b, eq (phi (MUL a b)) (mul (phi a) (phi b))}
      {phi_inv : forall a, eq (phi (INV a)) (inv (phi a))}
      {phi_div : forall a b, eq (phi (DIV a b)) (div (phi a) (phi b))}
      {phi_zero : eq (phi ZERO) zero}
      {phi_one : eq (phi ONE) one}
  : @field T EQ ZERO ONE OPP ADD SUB MUL INV DIV.
Admitted. (* TODO: remove all uses of this theorem *)

Lemma equivalent_operations_field
      {T EQ ZERO ONE OPP ADD SUB MUL INV DIV}
      {EQ_equivalence : Equivalence EQ}
      {zero one opp add sub mul inv div}
      {fieldR:@field T EQ zero one opp add sub mul inv div}
      {EQ_opp : forall a, EQ (OPP a) (opp a)}
      {EQ_inv : forall a, EQ (INV a) (inv a)}
      {EQ_add : forall a b, EQ (ADD a b) (add a b)}
      {EQ_sub : forall a b, EQ (SUB a b) (sub a b)}
      {EQ_mul : forall a b, EQ (MUL a b) (mul a b)}
      {EQ_div : forall a b, EQ (DIV a b) (div a b)}
      {EQ_zero : EQ ZERO zero}
      {EQ_one : EQ ONE one}
  : @field T EQ ZERO ONE OPP ADD SUB MUL INV DIV.
Proof. Admitted. (* TODO: remove all uses of this theorem *)

Section Homomorphism.
  Context {F EQ ZERO ONE OPP ADD MUL SUB INV DIV} `{@field F EQ ZERO ONE OPP ADD SUB MUL INV DIV}.
  Context {K eq zero one opp add mul sub inv div} `{@field K eq zero one opp add sub mul inv div}.
  Context {phi:F->K}.
  Local Infix "=" := eq. Local Infix "=" := eq : type_scope.
  Context `{@Ring.is_homomorphism F EQ ONE ADD MUL K eq one add mul phi}.

  Lemma homomorphism_multiplicative_inverse
    : forall x, not (EQ x ZERO)
                -> phi (INV x) = inv (phi x).
  Proof.
    intros.
    eapply inv_unique.
    rewrite <-Ring.homomorphism_mul.
    rewrite left_multiplicative_inverse; auto using Ring.homomorphism_one.
  Qed.

  Lemma homomorphism_multiplicative_inverse_complete
        { EQ_dec : DecidableRel EQ }
    : forall x, (EQ x ZERO -> phi (INV x) = inv (phi x))
                -> phi (INV x) = inv (phi x).
  Proof.
    intros x ?; destruct (dec (EQ x ZERO)); auto using homomorphism_multiplicative_inverse.
  Qed.

  Lemma homomorphism_div
    : forall x y, not (EQ y ZERO)
                  -> phi (DIV x y) = div (phi x) (phi y).
  Proof.
    intros. rewrite !field_div_definition.
    rewrite Ring.homomorphism_mul, homomorphism_multiplicative_inverse;
      (eauto || reflexivity).
  Qed.

  Lemma homomorphism_div_complete
        { EQ_dec : DecidableRel EQ }
    : forall x y, (EQ y ZERO -> phi (INV y) = inv (phi y))
                  -> phi (DIV x y) = div (phi x) (phi y).
  Proof.
    intros. rewrite !field_div_definition.
    rewrite Ring.homomorphism_mul, homomorphism_multiplicative_inverse_complete;
      (eauto || reflexivity).
  Qed.
End Homomorphism.

Section Homomorphism_rev.
  Context {F EQ ZERO ONE OPP ADD SUB MUL INV DIV} {fieldF:@field F EQ ZERO ONE OPP ADD SUB MUL INV DIV}.
  Context {H} {eq : H -> H -> Prop} {zero one : H} {opp : H -> H} {add sub mul : H -> H -> H} {inv : H -> H} {div : H -> H -> H}.
  Context {phi:F->H} {phi':H->F}.
  Local Infix "=" := EQ. Local Infix "=" := EQ : type_scope.
  Context (phi'_phi_id : forall A, phi' (phi A) = A)
          (phi'_eq : forall a b, EQ (phi' a) (phi' b) <-> eq a b)
          {phi'_zero : phi' zero = ZERO}
          {phi'_one : phi' one = ONE}
          {phi'_opp : forall a, phi' (opp a) = OPP (phi' a)}
          (phi'_add : forall a b, phi' (add a b) = ADD (phi' a) (phi' b))
          (phi'_sub : forall a b, phi' (sub a b) = SUB (phi' a) (phi' b))
          (phi'_mul : forall a b, phi' (mul a b) = MUL (phi' a) (phi' b))
          {phi'_inv : forall a, phi' (inv a) = INV (phi' a)}
          (phi'_div : forall a b, phi' (div a b) = DIV (phi' a) (phi' b)).

  Lemma field_and_homomorphism_from_redundant_representation
    : @field H eq zero one opp add sub mul inv div
      /\ @Ring.is_homomorphism F EQ ONE ADD MUL H eq one add mul phi
      /\ @Ring.is_homomorphism H eq one add mul F EQ ONE ADD MUL phi'.
  Proof.
    repeat match goal with
           | [ H : field |- _ ] => destruct H; try clear H
           | [ H : commutative_ring |- _ ] => destruct H; try clear H
           | [ H : ring |- _ ] => destruct H; try clear H
           | [ H : abelian_group |- _ ] => destruct H; try clear H
           | [ H : group |- _ ] => destruct H; try clear H
           | [ H : monoid |- _ ] => destruct H; try clear H
           | [ H : is_commutative |- _ ] => destruct H; try clear H
           | [ H : is_left_multiplicative_inverse |- _ ] => destruct H; try clear H
           | [ H : is_left_distributive |- _ ] => destruct H; try clear H
           | [ H : is_right_distributive |- _ ] => destruct H; try clear H
           | [ H : is_zero_neq_one |- _ ] => destruct H; try clear H
           | [ H : is_associative |- _ ] => destruct H; try clear H
           | [ H : is_left_identity |- _ ] => destruct H; try clear H
           | [ H : is_right_identity |- _ ] => destruct H; try clear H
           | [ H : Equivalence _ |- _ ] => destruct H; try clear H
           | [ H : is_left_inverse |- _ ] => destruct H; try clear H
           | [ H : is_right_inverse |- _ ] => destruct H; try clear H
           | _ => intro
           | _ => split
           | [ H : eq _ _ |- _ ] => apply phi'_eq in H
           | [ |- eq _ _ ] => apply phi'_eq
           | [ H : (~eq _ _)%type |- _ ] => pose proof (fun pf => H (proj1 (@phi'_eq _ _) pf)); clear H
           | [ H : EQ _ _ |- _ ] => rewrite H
           | _ => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_inv, ?phi'_div, ?phi'_phi_id by reflexivity
           | [ H : _ |- _ ] => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_inv, ?phi'_div, ?phi'_phi_id in H by reflexivity
           | _ => solve [ eauto ]
           end.
  Qed.
End Homomorphism_rev.

Ltac guess_field :=
  match goal with
  | |- ?eq _ _ =>  constr:(_:Algebra.field (eq:=eq))
  | |- not (?eq _ _) =>  constr:(_:Algebra.field (eq:=eq))
  | [H: ?eq _ _ |- _ ] =>  constr:(_:Algebra.field (eq:=eq))
  | [H: not (?eq _ _) |- _] =>  constr:(_:Algebra.field (eq:=eq))
  end.

Ltac goal_to_field_equality fld :=
  let eq := match type of fld with Algebra.field(eq:=?eq) => eq end in
  match goal with
  | [ |- eq _ _] => idtac
  | [ |- not (eq ?x ?y) ] => apply not_exfalso; intro; goal_to_field_equality fld
  | _ => exfalso;
         match goal with
         | H: not (eq _ _) |- _ => apply not_exfalso in H; apply H
         | _ => apply (field_is_zero_neq_one(field:=fld))
         end
  end.

Ltac inequalities_to_inverse_equations fld :=
  let eq := match type of fld with Algebra.field(eq:=?eq) => eq end in
  let zero := match type of fld with Algebra.field(zero:=?zero) => zero end in
  let div := match type of fld with Algebra.field(div:=?div) => div end in
  let sub := match type of fld with Algebra.field(sub:=?sub) => sub end in
  repeat match goal with
         | [H: not (eq _ _) |- _ ] =>
           lazymatch type of H with
           | not (eq ?d zero) =>
             unique pose proof (right_multiplicative_inverse(H:=fld) _ H)
           | not (eq zero ?d) =>
             unique pose proof (right_multiplicative_inverse(H:=fld) _ (symmetry(R:=fun a b => not (eq a b)) H))
           | not (eq ?x ?y) =>
             unique pose proof (right_multiplicative_inverse(H:=fld) _ (Ring.neq_sub_neq_zero _ _ H))
           end
         end.

Ltac unique_pose_implication pf :=
  let B := match type of pf with ?A -> ?B => B end in
  match goal with
             | [H:B|-_] => fail 1
             | _ => unique pose proof pf
  end.

Ltac inverses_to_conditional_equations fld :=
  let eq := match type of fld with Algebra.field(eq:=?eq) => eq end in
  let inv := match type of fld with Algebra.field(inv:=?inv) => inv end in
  repeat match goal with
         | |- context[inv ?d] =>
           unique_pose_implication constr:(right_multiplicative_inverse(H:=fld) d)
         | H: context[inv ?d] |- _ =>
           unique_pose_implication constr:(right_multiplicative_inverse(H:=fld) d)
         end.

Ltac clear_hypotheses_with_nonzero_requirements fld :=
  let eq := match type of fld with Algebra.field(eq:=?eq) => eq end in
  let zero := match type of fld with Algebra.field(zero:=?zero) => zero end in
  repeat match goal with
           [H: not (eq _ zero) -> _ |- _ ] => clear H
         end.

Ltac forward_nonzero fld solver_tac :=
  let eq := match type of fld with Algebra.field(eq:=?eq) => eq end in
  let zero := match type of fld with Algebra.field(zero:=?zero) => zero end in
  repeat match goal with
         | [H: not (eq ?x zero) -> _ |- _ ]
           => let H' := fresh in
              assert (H' : not (eq x zero)) by (clear_hypotheses_with_nonzero_requirements; solver_tac); specialize (H H')
         | [H: not (eq ?x zero) -> _ |- _ ]
           => let H' := fresh in
              assert (H' : not (eq x zero)) by (clear H; solver_tac); specialize (H H')
         end.

Ltac divisions_to_inverses fld :=
  rewrite ?(field_div_definition(field:=fld)) in *.

Ltac fsatz_solve_on fld :=
  goal_to_field_equality fld;
  forward_nonzero fld ltac:(fsatz_solve_on fld);
  nsatz;
  solve_debugfail ltac:(IntegralDomain.solve_constant_nonzero).

Ltac fsatz_solve :=
  let fld := guess_field in
  fsatz_solve_on fld.

Ltac fsatz_prepare_hyps_on fld :=
  divisions_to_inverses fld;
  inequalities_to_inverse_equations fld;
  inverses_to_conditional_equations fld;
  forward_nonzero fld ltac:(fsatz_solve_on fld).

Ltac fsatz_prepare_hyps :=
  let fld := guess_field in
  fsatz_prepare_hyps_on fld.

Ltac fsatz :=
  let fld := guess_field in
  fsatz_prepare_hyps_on fld;
  fsatz_solve_on fld.

Section FieldSquareRoot.
  Context {T eq zero one opp add mul sub inv div} `{@field T eq zero one opp add sub mul inv div} {eq_dec:DecidableRel eq}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Infix "+" := add. Local Infix "*" := mul.
  Lemma only_two_square_roots_choice x y z : x * x = z -> y * y = z -> x = y \/ x = opp y.
  Proof.
    intros.
    setoid_rewrite <-sub_zero_iff.
    eapply zero_product_zero_factor.
    fsatz.
  Qed.
End FieldSquareRoot.