Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith.
Require Coq.Vectors.Vector.

(* Typeclasses for ensuring that a string is included
   in a list (i.e. a set of method names). This allows
   us to omit a default case (method not found) for method
   lookups. *)

Section BoundedIndex.

  Context {A : Type}.

  Class IndexBound n
        (a : A)
        (Bound : Vector.t A n)
    :=
      { ibound : Fin.t n;
        boundi : Vector.nth Bound ibound = a
      }.

  Global Arguments ibound {n a Bound} IndexBound.
  Global Arguments IndexBound {n} a Bound.

  Record BoundedIndex
         (n : nat)
         (Bound : Vector.t A n) :=
    { bindex : A;
      indexb : IndexBound bindex Bound
    }.

  Import Coq.Vectors.VectorDef.VectorNotations.

  Definition BoundedIndex_nil
             (AnyT : Type)
             (idx : BoundedIndex 0 [])
  : AnyT.
  Proof.
    destruct idx as [idx [n] nth_n].
    inversion n.
  Qed.

  Global Arguments indexb {n Bound} b.
  Global Arguments bindex {n Bound} b.
  Global Arguments BoundedIndex {n} Bound.

  Lemma indexb_ibound_eq :
    forall n Bound (bidx bidx' : BoundedIndex (n := n) Bound),
      ibound (indexb bidx) = ibound (indexb bidx') ->
      bindex bidx = bindex bidx'.
  Proof.
    intros; induction Bound; simpl in *.
    - apply BoundedIndex_nil; auto.
    - destruct bidx as [bindex [n'] nth_n];
      destruct bidx' as [bindex' [n''] nth_n']; simpl in *; subst.
      congruence.
  Qed.

  Section Bounded_Index_Dec_Eq.
  (* If equality on A is decideable, so is equality
     on bounded indices in A. *)
    Variable A_eq_dec :
      forall a a' : A, {a = a'} + {a <> a'}.

    Require Import Coq.Logic.Eqdep_dec.

    Program Definition Opt_A_eq_dec (a a' : option A) :
      {a = a'} + {a <> a'} :=
      match a as a, a' as a' return {a = a'} + {a <> a'} with
          | Some a, Some a' => if A_eq_dec a a' then left _ else right _
          | None, None => left _
          | _, _ => right _
      end.

    (*Definition K_Opt_A :
      forall (a : option A) (P: a = a -> Prop),
          P (refl_equal a) -> forall p : a = a, P p :=
      K_dec_set Opt_A_eq_dec.

    Definition UIP_Opt_A  :
      forall (a : option A) (Q : option A -> Type)
             (x : Q a) (h : a = a),
        x = eq_rect a Q x a h.
      intros; eapply K_Opt_A with (p := h); reflexivity.
    Defined.

    Lemma eq_proofs_unicity_Opt_A
      : forall (a a' : option A) (p1 p2 : a = a'), p1 = p2.
      apply eq_proofs_unicity; intros.
      destruct (Opt_A_eq_dec x y); auto.
    Defined. *)

    Corollary idx_ibound_eq
    : forall n Bound (idx idx' : BoundedIndex (n := n) Bound),
        ibound (indexb idx) = ibound (indexb idx') ->
        idx = idx'.
    Proof.
      intros; generalize (indexb_ibound_eq _ _ idx idx' H);
      destruct idx as [idx [n'] In_n'];
        destruct idx' as [idx' [n''] In_n'' ]; intros;
        simpl in *; subst; f_equal.
    Qed.

    Corollary idx_ibound_neq
    : forall n Bound (idx idx' : BoundedIndex (n := n) Bound),
        ibound (indexb idx) <> ibound (indexb idx') ->
        idx <> idx'.
    Proof.
      intros; destruct idx as [idx [n'] In_n' ];
        destruct idx' as [idx' [n''] In_n'' ]; intros;
        simpl in *; subst.
      unfold not; intros; apply H; injection H0; auto.
    Qed.

    Definition fin_eq_dec {m} (n n' : Fin.t m)
      : {n = n'} + {n <> n'}.
    Proof.
      eapply Fin.rect2 with (P := fun m (n n' : Fin.t m)
                                  => {n = n'} + {n <> n'}).
      - left; reflexivity.
      - right; intro; discriminate.
      - right; intro; discriminate.
      - destruct 1; subst.
        + left; reflexivity.
        + right; intro H; apply Fin.FS_inj in H; eauto.
    Defined.

    Corollary BoundedIndex_eq_dec n Bound :
      forall idx idx' : BoundedIndex (n := n) Bound,
        {idx = idx'} + {idx <> idx'}.
    Proof.
      intros; destruct (fin_eq_dec (ibound (indexb idx)) (ibound (indexb idx'))).
      - left; auto using idx_ibound_eq.
      - right; auto using idx_ibound_neq.
    Defined.

    End Bounded_Index_Dec_Eq.

End BoundedIndex.

Ltac Build_nth_IndexBound n A a As As' m :=
  match n with
  | S ?n' =>
    (let check := constr:(eq_refl : a = Vector.hd As') in (* Check if the terms match *)
     exact (@Build_IndexBound A _ a As (Fin.R m (@Fin.F1 n'))
                              (@eq_refl A a)))
      ||
      let As'' := eval simpl in (Vector.tl As') in
          Build_nth_IndexBound n' A a As As'' (S m)
  end.

Hint Extern 0 (@IndexBound ?A ?n ?a ?As) =>
let n' := eval compute in n in
    Build_nth_IndexBound n' A a As As 0 : typeclass_instances.

(*
Import Coq.Vectors.VectorDef.VectorNotations.

Fixpoint foo (n : nat) : Vector.t nat (S n) :=
  match n with
  | 0 => 0 :: []
  | S n' => (S n') * (S n') * (S n') :: (foo n')
  end.

Definition foo100 := Eval simpl in foo 20.

Definition baz := Eval simpl in 3 * 3 * 3.

Definition bar : IndexBound baz foo100.
Proof.
  Unset Ltac Debug.
  Time eauto with typeclass_instances.
Defined. *)

Definition BoundedString {n} := @BoundedIndex string n.
Definition BoundedString_eq_dec
           {n}
           {Bound}
           (bidx bidx' : BoundedString Bound)
: {bidx = bidx'} + {bidx <> bidx'} :=
  BoundedIndex_eq_dec n Bound bidx bidx'.

Notation "`` A" :=
  ({| bindex := A%string |}) (at level 0, format "`` A").

Section ithIndexBound.

  Require Import Fiat.Common.ilist.
  Import Coq.Vectors.VectorDef.VectorNotations.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type}.

  Lemma None_neq_Some
  : forall (AnyT AnyT' : Type) (a : AnyT),
      None = Some a -> AnyT'.
  Proof.
    intros; discriminate.
  Qed.

  Definition nth_Bounded
             {n}
             (Bound : Vector.t A n)
             (idx : BoundedIndex Bound)
    : A := Vector.nth Bound (ibound (indexb idx)).

  Definition ith_Bounded
             {m}
             {B : A -> Type}
             {Bound : Vector.t A m}
             (il : ilist Bound)
             (idx : BoundedIndex Bound)
    : B (Vector.nth Bound (ibound (indexb idx))) :=
    ith il (ibound (indexb idx)) .

  Lemma ith_Bounded_imap
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist Bound),
      f _ (ith_Bounded il idx) =
      ith_Bounded (imap _ _ f Bound il) idx.
  Proof.
    unfold ith_Bounded; simpl; intros; eapply ith_imap.
  Qed.

  Definition replace_BoundedIndex
             {m}
           {B : A -> Type}
           (Bound : Vector.t A m)
           (il : ilist Bound)
           (idx : BoundedIndex Bound)
           (new_b : B (nth_Bounded idx))
  : ilist Bound :=
    replace_Index Bound il (ibound (indexb idx)) new_b.

  Lemma ith_replace_BoundIndex_neq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist Bound)
      (idx idx' : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx')),
      idx <> idx'
      -> ith_Bounded (replace_BoundedIndex il idx' new_b) idx =
         ith_Bounded il idx.
  Proof.
    unfold ith_Bounded; simpl; intros; eapply ith_replace_Index_neq.
    eauto using idx_ibound_eq.
  Qed.

  Lemma ith_replace_BoundIndex_eq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist Bound)
      (idx : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx)),
      ith_Bounded (replace_BoundedIndex il idx new_b) idx = new_b.
  Proof.
    unfold ith_Bounded; simpl; intros; eapply ith_replace_Index_eq.
  Qed.

  Lemma ilist_eq {m} {B : A -> Type}
  : forall (Bound : Vector.t A m)
           (il il' : ilist (B := B) Bound),
      (forall idx, ith_Bounded il idx = ith_Bounded il' idx) -> il = il'.
  Proof.
    induction Bound; intros.
    - rewrite (ilist_invert _ il), (ilist_invert _ il'); reflexivity.
    - destruct il; destruct il'; simpl in *.
      f_equal.
      + generalize (H {| bindex := h |});
        unfold ith_Bounded; simpl; auto.
      + apply IHBound; intros.
        exact (H {| bindex := bindex idx;
                   indexb := @Build_IndexBound
                               _
                               (S n)
                               (bindex idx)
                               (h :: Bound)
                               (Fin.FS (ibound (indexb idx)))
                               (@boundi _ _ _ _ (indexb idx))
                |}).
  Qed.

  Global Arguments imap {A B B'} f {n} {As} il.
  Global Arguments BoundedIndex_eq_dec {_ _ _} _ _.

  Lemma imap_replace_BoundedIndex
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx'', B idx'' -> B' idx'')
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist Bound)
           b,
      imap f (replace_BoundedIndex il idx b) =
      replace_BoundedIndex (imap f il) idx (f _ b).
  Proof.
    intros; apply ilist_eq; intros.
    destruct (BoundedIndex_eq_dec idx idx0); subst;
    rewrite <- ith_Bounded_imap.
    - repeat rewrite ith_replace_BoundIndex_eq; reflexivity.
    - repeat rewrite ith_replace_BoundIndex_neq; auto.
      rewrite <- ith_Bounded_imap; auto.
  Qed.

End ithIndexBound.

Section ithIndexBound2.

  Require Import Fiat.Common.ilist2.
  Import Coq.Vectors.VectorDef.VectorNotations.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type}.

  Definition ith_Bounded2
             {m}
             {B : A -> Type}
             {Bound : Vector.t A m}
             (il : ilist2 Bound)
             (idx : BoundedIndex Bound)
    : B (Vector.nth Bound (ibound (indexb idx))) :=
    ith2 il (ibound (indexb idx)) .

  Lemma ith_Bounded_imap2
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist2 Bound),
      f _ (ith_Bounded2 il idx) =
      ith_Bounded2 (imap2 _ _ f Bound il) idx.
  Proof.
    unfold ith_Bounded2; simpl; intros; eapply ith_imap2.
  Qed.

  Definition replace_BoundedIndex2
             {m}
           {B : A -> Type}
           (Bound : Vector.t A m)
           (il : ilist2 Bound)
           (idx : BoundedIndex Bound)
           (new_b : B (nth_Bounded idx))
  : ilist2 Bound :=
    replace_Index2 Bound il (ibound (indexb idx)) new_b.

  Lemma ith_replace_BoundIndex2_neq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist2 Bound)
      (idx idx' : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx')),
      idx <> idx'
      -> ith_Bounded2 (replace_BoundedIndex2 il idx' new_b) idx =
         ith_Bounded2 il idx.
  Proof.
    unfold ith_Bounded2; simpl; intros; eapply ith_replace2_Index_neq.
    eauto using idx_ibound_eq.
  Qed.

  Lemma ith_replace_BoundIndex2_eq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist2 Bound)
      (idx : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx)),
      ith_Bounded2 (replace_BoundedIndex2 il idx new_b) idx = new_b.
  Proof.
    unfold ith_Bounded2; simpl; intros; eapply ith_replace2_Index_eq.
  Qed.

  Lemma ilist2_eq {m} {B : A -> Type}
  : forall (Bound : Vector.t A m)
           (il il' : ilist2 (B := B) Bound),
      (forall idx, ith_Bounded2 il idx = ith_Bounded2 il' idx) -> il = il'.
  Proof.
    induction Bound; intros.
    - rewrite (ilist2_invert _ il), (ilist2_invert _ il'); reflexivity.
    - destruct il; destruct il'; simpl in *.
      f_equal.
      + generalize (H {| bindex := h |});
        unfold ith_Bounded2; simpl; auto.
      + apply IHBound; intros.
        exact (H {| bindex := bindex idx;
                   indexb := @Build_IndexBound
                               _
                               (S n)
                               (bindex idx)
                               (h :: Bound)
                               (Fin.FS (ibound (indexb idx)))
                               (@boundi _ _ _ _ (indexb idx))
                |}).
  Qed.

  Global Arguments imap2 {A B B'} f {n} {As} il.

  Lemma imap_replace2_BoundedIndex
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx'', B idx'' -> B' idx'')
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist2 Bound)
           b,
      imap2 f (replace_BoundedIndex2 il idx b) =
      replace_BoundedIndex2 (imap2 f il) idx (f _ b).
  Proof.
    intros; apply ilist2_eq; intros.
    destruct (BoundedIndex_eq_dec idx idx0); subst;
    rewrite <- ith_Bounded_imap2.
    - repeat rewrite ith_replace_BoundIndex2_eq; reflexivity.
    - repeat rewrite ith_replace_BoundIndex2_neq; auto.
      rewrite <- ith_Bounded_imap2; auto.
  Qed.

End ithIndexBound2.

(*Section i2thIndexBound.

  Require Import Fiat.Common.i2list.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type} {D : Set}.
  Variable (projAD : A -> D).

  (* Given a [BoundedIndex] for a list [Bound], we can always return
     an element of a list indexed by [Bound]. *)

  Definition i2th_Bounded
          {B : A -> Type}
          {C : forall a, B a -> Type}
          {As}
          (Bs : ilist B As)
          (Cs : i2list C Bs)
          (idx : BoundedIndex (map projAD As))
  : C (nth_Bounded _ As idx) (ith_Bounded projAD Bs idx) :=
    ith_Bounded_rect projAD (fun _ _ _ => C) idx Bs
                           (i2th_error' Cs (ibound idx)).

  (*Lemma ith_Bounded_imap
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist B Bound),
      f _ (ith_Bounded il idx) =
      ith_Bounded (imap B' f il) idx.
  Proof.
    intros.
    eapply ith_Bounded_ind2 with (idx0 := idx) (il0 := il) (il' := imap B' f il).
    destruct idx as [idx [n nth_n] ]; simpl in *; subst.
    revert Bound nth_n il;
      induction n; destruct Bound; simpl; eauto;
    intros; icons_invert; simpl; auto.
  Qed. *)

  (* We can lift [C (ith_Bounded idx)] to a dependent option. *)
  Definition Some_Dep_Option_elim_P
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (Bs : ilist B As)
             (idx : BoundedIndex (map projAD As))
             (c_opt : C (nth_Bounded projAD As idx) (ith_Bounded projAD Bs idx))
  : Dep_Option_elim_P C (ith_error Bs (ibound idx)) :=
    match (nth_error As (ibound idx)) as e return
          forall nth_n
                 (b : B (@nth_Bounded' _ _ _ _ _ e nth_n))
                 b_opt,
            ith_error_eq_P projAD As idx
                           b_opt
                           nth_n
                           b
            -> C _ b
            -> Dep_Option_elim_P C (a_opt := e) b_opt with
      | Some a => fun nth_n b b_opt b_eq c =>
                    match b_eq in _ = b'
                          return C _ b' -> _ with
                      | eq_refl => fun c => c
                    end c
      | None => fun nth_n b b_opt b_eq c => I
    end (nth_error_map _ _ _ (boundi idx))
        _ _ (ith_error_eq _ _ _) c_opt.

  Definition replace_BoundedIndex2
           {B : A -> Type}
           {C : forall a, B a -> Type}
           {As}
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (idx : BoundedIndex (map projAD As))
           (new_c : C _ (ith_Bounded projAD Bs idx))
  : i2list C Bs :=
    replace_Index2' (ibound idx) Cs
                   (Some_Dep_Option_elim_P Bs idx new_c).

  Definition Dep_Option_elim2_P2
             {B : A -> Type}
             {C C' : forall a, B a -> Type}
             (P : forall a b, C a b -> C' a b -> Prop)
             (a_opt : option A)
    := match a_opt return
             forall (b : Dep_Option B a_opt),
               Dep_Option_elim_P C (a_opt := a_opt) b
               -> Dep_Option_elim_P C' (a_opt := a_opt) b -> Prop with
         | Some a => fun b => P a (Dep_Option_elim b)
         | None => fun _ _ _ => True
       end .

  Lemma Dep_Option_elim2_P2_refl
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall a_opt b_opt c_opt,
      Dep_Option_elim2_P2 (fun (a : A) (b : B a) (c c' : C a b) => c = c')
                          (a_opt := a_opt) b_opt c_opt c_opt.
    unfold Dep_Option_elim2_P2; destruct a_opt; eauto.
  Qed.

  Definition i2th_error_eq_P
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (idx : BoundedIndex (map projAD As))
             (a_opt : option A)
             (b_opt : Dep_Option B a_opt)
             (c_opt : Dep_Option_elim_P C b_opt)
             (e_eq : option_map projAD a_opt = Some (bindex idx))
             (c_opt' : C (nth_Bounded' projAD As a_opt e_eq)
                         (ith_Bounded' projAD As e_eq b_opt))
  : Type :=
      match a_opt as a_opt'
        return
        forall (b_opt : Dep_Option B a_opt')
               (e_eq : option_map projAD a_opt' = Some (bindex idx)),
          Dep_Option_elim_P C b_opt ->
          C (nth_Bounded' projAD As a_opt' e_eq)
            (ith_Bounded' projAD As e_eq b_opt)
          -> Type
      with
        | Some a =>
          fun b_opt e_eq c_opt c_opt' => c_opt = c_opt'
        | None => fun b_opt e_eq c_opt c_opt' => True
      end b_opt e_eq c_opt c_opt'.

    Lemma ilist_invert' {B} (As : list A) (il : ilist B As) :
      match As as As' return ilist B As' -> Type with
        | a :: As' => fun il => { b : _ & {il' : _ & il = icons a b il'}}
        | nil => fun il => il = inil _
      end il.
    Proof.
      destruct il; eauto.
    Qed.

    Lemma i2th_error_eq
          {B : A -> Type}
          {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist B As)
             (Cs : i2list C Bs),
        i2th_error_eq_P As idx
        (ith_error Bs (ibound idx))
        (i2th_error' Cs (ibound idx))
        (nth_error_map _ _ _ (boundi idx))
        (i2th_Bounded Cs idx).
    Proof.
      unfold i2th_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Cs; simpl; eauto.
      intros; generalize (IHn As idx In_n (ilist_tl Bs) Cs); intro H';
      unfold i2th_Bounded, ith_Bounded_rect; simpl; eauto.
    Qed.

    Definition i2th_error_eq'
               {B : A -> Type}
               {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist B As)
             (c : C (nth_Bounded _ As idx) (ith_Bounded _ Bs idx)),
        i2th_error_eq_P As idx (ith_error Bs (ibound idx))
                        (Some_Dep_Option_elim_P Bs idx c)
                        (nth_error_map projAD (ibound idx) As (boundi idx)) c.
    Proof.
      unfold i2th_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Bs; simpl; eauto.
      generalize (IHn As idx In_n Bs);
      unfold i2th_Bounded, ith_Bounded_rect; simpl; eauto.
    Qed.

    Program Definition i2th_Bounded_ind
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist B As) (Cs : i2list C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
    : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (c : C' (nth_Bounded _ As idx) (ith_Bounded _ Bs idx)),
        Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith_error Bs (ibound idx))
                          (i2th_error' Cs (ibound idx))
                          (Some_Dep_Option_elim_P Bs idx c)
        -> P As Bs Cs idx _ (ith_Bounded _ Bs idx) (i2th_Bounded Cs idx) c
      := fun As idx Bs Cs c H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith_Bounded' projAD As e_eq b_opt)),
                 i2th_error_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith_error Bs (ibound idx))
             (i2th_error' Cs (ibound idx))
             (Some_Dep_Option_elim_P _ _ c)
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error_eq _ _) (i2th_error_eq' _ _ _) H.

    Program Definition i2th_Bounded_ind2
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist B As) (Cs : i2list C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
  : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (Cs' : i2list C' Bs),
      Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith_error Bs (ibound idx))
                          (i2th_error' Cs (ibound idx))
                          (i2th_error' Cs' (ibound idx))
      -> P As Bs Cs idx _ (ith_Bounded _ Bs idx)
           (i2th_Bounded Cs idx)
           (i2th_Bounded Cs' idx)
      := fun As idx Bs Cs Cs' H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith_Bounded' projAD As e_eq b_opt)),
                 i2th_error_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith_error Bs (ibound idx))
             (i2th_error' Cs (ibound idx))
             (i2th_error' Cs' (ibound idx))
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error_eq _ _) (i2th_error_eq _ _) H.

    Definition Dep_Option_elim2_T2
             {B : A -> Type}
             {C C' : forall a, B a -> Type}
             (P : forall a b, C a b -> C' a b -> Type)
             (a_opt : option A)
    := match a_opt return
             forall (b : Dep_Option B a_opt),
               Dep_Option_elim_P C (a_opt := a_opt) b
               -> Dep_Option_elim_P C' (a_opt := a_opt) b -> Type with
         | Some a => fun b => P a (Dep_Option_elim b)
         | None => fun _ _ _ => True
       end .

    Program Definition i2th_Bounded_rect
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist B As) (Cs : i2list C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Type)
    : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (c : C' (nth_Bounded _ As idx) (ith_Bounded _ Bs idx)),
        Dep_Option_elim2_T2 (P As Bs Cs idx)
                          (ith_error Bs (ibound idx))
                          (i2th_error' Cs (ibound idx))
                          (Some_Dep_Option_elim_P Bs idx c)
        -> P As Bs Cs idx _ (ith_Bounded _ Bs idx) (i2th_Bounded Cs idx) c
      := fun As idx Bs Cs c H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith_Bounded' projAD As e_eq b_opt)),
                 i2th_error_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_T2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith_error Bs (ibound idx))
             (i2th_error' Cs (ibound idx))
             (Some_Dep_Option_elim_P _ _ c)
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error_eq _ _) (i2th_error_eq' _ _ _) H.

  Variable D_eq_dec : forall d d' : D, {d = d'} + {d <> d'}.

  Lemma i2th_replace_BoundIndex_neq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist B As)
      (Cs : i2list C Bs)
      (idx idx' : BoundedIndex (map projAD As))
      (new_c : C _ (ith_Bounded projAD Bs idx')),
      idx <> idx'
      -> i2th_Bounded (replace_BoundedIndex2 Cs idx' new_c) idx =
         i2th_Bounded Cs idx.
  Proof.
    intros.
    eapply (i2th_Bounded_ind2
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace_BoundedIndex2.
    rewrite i2th_replace_Index'_neq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed.

  Lemma i2th_replace_BoundIndex_eq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist B As)
      (Cs : i2list C Bs)
      (idx : BoundedIndex (map projAD As))
      (new_c : C _ (ith_Bounded projAD Bs idx)),
      i2th_Bounded (replace_BoundedIndex2 Cs idx new_c) idx =
      new_c.
  Proof.
    intros.
    eapply (i2th_Bounded_ind
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace_BoundedIndex2.
    rewrite i2th_replace_Index'_eq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed.

End i2thIndexBound.

Section ith2IndexBound.

  Require Import Fiat.Common.ilist2.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type} {C : Set}.
  Variable (projAC : A -> C).

  (* Given a [BoundedIndex] for a list [Bound], we can always return
     an element of a list indexed by [Bound]. *)

  Definition ith2_Bounded'
          {B : A -> Type}
          (As : list A)
          (d : C)
          (a_opt : option A)
  : forall (nth_n : option_map projAC a_opt = Some d),
      Dep_Option B a_opt
      -> B (nth_Bounded' projAC As a_opt nth_n) :=
    match a_opt as a'
          return
          forall (f : option_map projAC a' = Some d),
            Dep_Option B a' ->
            B (nth_Bounded' projAC As _ f) with
      | Some a => fun nth_n b => Dep_Option_elim b
      | None => fun nth_n b => None_neq_Some _ nth_n
    end.

  Definition ith2_Bounded
          {B : A -> Type}
          {Bound}
          (il : ilist2 B Bound)
          (idx : BoundedIndex (map projAC Bound))
  : B (nth_Bounded projAC Bound idx) :=
    ith2_Bounded' Bound (nth_error_map _ _ _ (boundi idx))
                 (ith2_error il (ibound idx)).

  (*match (nth_error Bound (ibound idx)) as a'
                  return
                  Dep_Option B a' ->
                  forall (f : option_map _ a' = Some (bindex idx)),
                    B (nth_Bounded' Bound _ f) with
        | Some a => fun b _ => Dep_Option_elim b
        | None => fun _ f => None_neq_Some _ f
    end (ith2_error il (ibound idx)) (nth_error_map _ _ (boundi idx)). *)

  (* To build a reasoning principle for ith2_Bounded, we need to
     show that option types are shuffled around by [Dep_Option_elim] *)
    Definition ith2_error_eq_P
               {B : A -> Type}
               (Bound : list A)
               (idx : BoundedIndex (map projAC Bound))
               e' b c d :=
      match e' as e'
        return
        (Dep_Option B e' ->
         forall c : option_map _ e' = Some (bindex idx),
           B (nth_Bounded' projAC Bound _ c) -> Type)
      with
        | Some e =>
          fun b c d => Dep_Option_elim b = d
        | None => fun b c d => True
      end b c d.

    Lemma ith2_error_eq
          {B : A -> Type}
    : forall (Bound : list A)
             (idx : BoundedIndex (map projAC Bound))
              (il : ilist2 B Bound),
        ith2_error_eq_P Bound idx
        (ith2_error il (ibound idx))
        (nth_error_map _ _ _ (boundi idx))
        (ith2_Bounded il idx).
    Proof.
      unfold ith2_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert n In_n; induction Bound; destruct n;
      simpl; eauto; intros.
      eapply IHBound.
    Defined.

    (* [ith2_Bounded_rect] builds a function whose type depends
     on [ith2_Bounded] by reducing to a case with [ith2_error],
     which is easier to work/reason with. *)

    Definition ith2_Bounded_rect
            {B : A -> Type}
        (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As -> forall a : A, B a -> Type)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound),
      Dep_Option_elim_P (P Bound idx il) (ith2_error il (ibound idx))
      -> P Bound idx il _ (ith2_Bounded il idx) :=
      fun Bound idx il =>
                match (nth_error Bound (ibound idx)) as e
                      return
                      forall (b : Dep_Option B e)
                             (c : option_map _ e = Some (bindex idx))
                             d,
                        (ith2_error_eq_P Bound idx b c d)
                        -> Dep_Option_elim_P (P Bound idx il) b ->
                        P _ _ _ (@nth_Bounded' _ _ projAC _ _ e c) d with
                  | Some a => fun b e_eq d c_eq =>
                                match c_eq with
                                  | eq_refl => fun b_opt => b_opt
                                end
                  | None => fun _ e_eq _ _ _ => None_neq_Some _ e_eq
                end (ith2_error il (ibound idx))
                    _
                    (ith2_Bounded il idx)
                    (ith2_error_eq idx il).

    Definition ith2_Bounded_rect2
               {B B' : A -> Type}
        (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As
                        -> ilist2 B' As
                        -> forall a : A, B a -> B' a -> Type)
        (Bound : list A)
        (idx : BoundedIndex (map projAC Bound))
        (il : ilist2 B Bound)
        (il' : ilist2 B' Bound)
    : Dep_Option_elim_T2 (P Bound idx il il')
                         (ith2_error il (ibound idx))
                         (ith2_error il' (ibound idx))
      -> P Bound idx il il' _
           (ith2_Bounded il idx)
           (ith2_Bounded il' idx) :=
      match (nth_error Bound (ibound idx)) as e
                 return
                 forall (b : Dep_Option B e)
                        (b' : Dep_Option B' e)
                        (c : option_map _ e = Some (bindex idx))
                        d d',
                   (ith2_error_eq_P Bound idx b c d)
                   -> (ith2_error_eq_P Bound idx b' c d')
                   -> Dep_Option_elim_T2 (P Bound idx il il') b b' ->
                   P _ _ _ _ (@nth_Bounded' _ _ projAC _ _ _ c) d d' with
        | Some a => fun b b' e_eq d d' d_eq d'_eq =>
                      match d_eq, d'_eq with
                        | eq_refl, eq_refl => fun b_opt => b_opt
                      end
        | None => fun b b' e_eq d d' d_eq d'_eq => None_neq_Some _ e_eq
           end (ith2_error il (ibound idx))
               (ith2_error il' (ibound idx) )
               _
               (ith2_Bounded il idx)
               (ith2_Bounded il' idx)
               (ith2_error_eq idx il)
               (ith2_error_eq idx il').

    (* [ith2_Bounded_ind] builds a proof whose type depends
     on both [nth_Bounded] and an occurence of [ith2_Bounded] by reducing
     it to a case with an [ith2_error], which is easier to reason with. *)

    Program Definition ith2_Bounded_ind
            {B B' : A -> Type}
            (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As
                        -> forall a : A, B a -> B' a -> Prop)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (b : B' (nth_Bounded projAC Bound idx)),
      Dep_Option_elim_P2 (P Bound idx il) (ith2_error il (ibound idx))
                      (Some_Dep_Option projAC Bound idx b)
      -> P Bound idx il _ (ith2_Bounded il idx) b :=
      fun Bound idx il b =>
        match (nth_error Bound (ibound idx)) as e
              return
              forall (b : Dep_Option B e)
                     (b' : Dep_Option B' e)
                     (c : option_map _ e = Some (bindex idx))
                     d d',
                (ith2_error_eq_P Bound idx b c d)
                -> (ith2_error_eq_P Bound idx b' c d')
                -> Dep_Option_elim_P2 (P Bound idx il) b b' ->
                P _ _ _ (@nth_Bounded' _ _ projAC _ _ _ c) d d' with
          | Some a => _
          | None => _
        end (ith2_error il (ibound idx))
            (Some_Dep_Option projAC Bound idx b)
            _
            (ith2_Bounded il idx)
            b
            (ith2_error_eq idx il)
            _.
    Next Obligation.
      unfold ith2_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert n In_n b; clear.
      induction Bound; destruct n; simpl; intros; eauto.
      unfold Some_Dep_Option; simpl.
      intros; eapply IHBound.
    Qed.

    (* [ith2_Bounded_ind2] builds a proof whose type depends
     on *two* occurences of [ith2_Bounded] by reducing  it to a case
     with two [ith2_error]s, which is easier to reason with. *)

    Program Definition ith2_Bounded_ind2
            {B B' : A -> Type}
            (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As
                        -> forall a : A, B a -> B' a -> Prop)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (il' : ilist2 B' Bound),
      Dep_Option_elim_P2 (P Bound idx il)
                      (ith2_error il (ibound idx))
                      (ith2_error il' (ibound idx) )
      -> P Bound idx il _ (ith2_Bounded il idx) (ith2_Bounded il' idx) :=
    fun Bound idx il il' =>
      match (nth_error Bound (ibound idx)) as e
                 return
                 forall (b : Dep_Option B e)
                        (b' : Dep_Option B' e)
                        (c : option_map _ e = Some (bindex idx))
                        d d',
                   (ith2_error_eq_P Bound idx b c d)
                   -> (ith2_error_eq_P Bound idx b' c d')
                   -> Dep_Option_elim_P2 (P Bound idx il) b b' ->
                   P _ _ _ (@nth_Bounded' _ _ projAC _ _ _ c) d d' with
          | Some a => _
          | None => _
           end (ith2_error il (ibound idx))
               (ith2_error il' (ibound idx) )
               _
               (ith2_Bounded il idx)
               (ith2_Bounded il' idx)
               (ith2_error_eq idx il)
               (ith2_error_eq idx il').

    Program Definition ith2_Bounded_ind3
            {B B' B'' : A -> Type}
            (P : forall As,
                   BoundedIndex (map projAC As)
                   -> ilist2 B As
                   -> ilist2 B' As
                   -> ilist2 B'' As
                   -> forall a : A,
                        B a -> B' a -> B'' a -> Prop)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (il' : ilist2 B' Bound)
           (il'' : ilist2 B'' Bound),
      Dep_Option_elim_P3 (P Bound idx il il' il'')
                      (ith2_error il (ibound idx))
                      (ith2_error il' (ibound idx))
                      (ith2_error il'' (ibound idx))
      -> P Bound idx il il' il'' _
           (ith2_Bounded il idx)
           (ith2_Bounded il' idx)
           (ith2_Bounded il'' idx) :=
    fun Bound idx il il' il'' =>
      match (nth_error Bound (ibound idx)) as e
                 return
                 forall (b : Dep_Option B e)
                        (b' : Dep_Option B' e)
                        (b'' : Dep_Option B'' e)
                        (c : option_map _ e = Some (bindex idx))
                        d d' d'',
                   (ith2_error_eq_P Bound idx b c d)
                   -> (ith2_error_eq_P Bound idx b' c d')
                   -> (ith2_error_eq_P Bound idx b'' c d'')
                   -> Dep_Option_elim_P3 (P Bound idx il il' il'') b b' b'' ->
                   P Bound idx il il' il''
                     (@nth_Bounded' _ _ _ _ _ _ c)
                     d d' d'' with
          | Some a => _
          | _  => _
           end (ith2_error il (ibound idx))
               (ith2_error il' (ibound idx) )
               (ith2_error il'' (ibound idx) )
               _
               (ith2_Bounded il idx)
               (ith2_Bounded il' idx)
               (ith2_Bounded il'' idx)
               (ith2_error_eq idx il)
               (ith2_error_eq idx il')
               (ith2_error_eq idx il'').

  Lemma ith2_Bounded_imap
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound),
      f _ (ith2_Bounded il idx) =
      ith2_Bounded (imap2 B' f il) idx.
  Proof.
    intros.
    eapply ith2_Bounded_ind2 with (idx0 := idx) (il0 := il) (il' := imap2 B' f il).
    destruct idx as [idx [n nth_n] ]; simpl in *; subst.
    revert Bound nth_n il;
      induction n; destruct Bound; simpl; eauto;
    intros; icons2_invert; simpl; auto.
  Qed.

  Definition replace2_BoundedIndex
           {B : A -> Type}
           (Bound : list A)
           (il : ilist2 B Bound)
           (idx : BoundedIndex (map projAC Bound))
           (new_b : B (nth_Bounded projAC Bound idx))
  : ilist2 B Bound :=
    replace_Index2 (ibound idx) il (Dep_Option_elim (Some_Dep_Option _ _ _ new_b)).

  Variable C_eq_dec : forall c c' : C, {c = c'} + {c <> c'}.

  Lemma ith2_replace_BoundIndex_neq
        {B : A -> Type}
  : forall
      (Bound : list A)
      (il : ilist2 _ Bound)
      (idx idx' : BoundedIndex (map projAC Bound))
      (new_b : B (nth_Bounded projAC Bound idx')),
      idx <> idx'
      -> ith2_Bounded (replace2_BoundedIndex il idx' new_b) idx =
         ith2_Bounded il idx.
  Proof.
    intros.
    eapply ith2_Bounded_ind2 with (idx0 := idx) (il0 := replace2_BoundedIndex il idx' new_b)
                                                (il' := il).
    eapply ith2_replace_Index2_neq; eauto using idx_ibound_eq.
  Qed.

  Lemma ith2_replace_BoundIndex_eq
        {B : A -> Type}
  : forall
      (Bound : list A)
      (il : ilist2 _ Bound)
      (idx : BoundedIndex (map projAC Bound))
      (new_b : B (nth_Bounded projAC Bound idx)),
      ith2_Bounded (replace2_BoundedIndex il idx new_b) idx = new_b.
  Proof.
    intros.
    eapply ith2_Bounded_ind with (idx0 := idx)
                                  (il0 := replace2_BoundedIndex il idx new_b)
                                  (P := fun Bound idx il a il' b => il' = b).
    eapply ith2_replace_Index2_eq; eauto.
  Qed.

  Lemma ith2_replace_BoundedIndex_ind
        {B : A -> Type}
        (P : forall As (idx : BoundedIndex (map projAC As)),
               B (nth_Bounded projAC As idx)
               -> B (nth_Bounded projAC As idx) -> Prop)
  : forall (Bound : list A)
           (idx idx' : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (new_b : B (nth_Bounded projAC Bound idx')),
      (forall idx :  BoundedIndex (map projAC Bound),
         ibound idx <> ibound idx'
         -> P _ idx (ith2_Bounded il idx)
              (ith2_Bounded il idx))
      -> P _ idx' (ith2_Bounded il idx') new_b
      -> P _ idx
           (ith2_Bounded il idx)
           (ith2_Bounded (replace2_BoundedIndex il idx' new_b) idx).
  Proof.
    intros.
    destruct (BoundedIndex_eq_dec C_eq_dec idx idx'); subst.
    + rewrite ith2_replace_BoundIndex_eq; assumption.
    + rewrite ith2_replace_BoundIndex_neq;
      unfold not; eauto using idx_ibound_eq.
  Qed.

  Lemma ilist2_eq {B : A -> Type}
  : forall (Bound : list A)
           (il il' : ilist2 B Bound),
      (forall idx, ith2_Bounded il idx = ith2_Bounded il' idx) -> il = il'.
  Proof.
    induction Bound; intros.
    - rewrite (ilist2_invert il), (ilist2_invert il'); reflexivity.
    - icons2_invert; f_equal.
      generalize (H {| bindex := projAC a;
                       indexb := IndexBound_head _ _  |}).
      unfold ith2_Bounded; simpl; auto.
      apply IHBound; intros.
      generalize (H  {| bindex := bindex idx;
                       indexb := @IndexBound_tail _ _ _ _ (indexb idx) |}).
      unfold ith2_Bounded; simpl; auto.
  Qed.

  Lemma imap2_replace2_BoundedIndex
        {B B' : A -> Type}
  : forall (f : forall idx'', B idx'' -> B' idx'')
           (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           b,
      imap2 B' f (replace2_BoundedIndex il idx b) =
      replace2_BoundedIndex (imap2 B' f il) idx (f _ b).
  Proof.
    intros; apply ilist2_eq; intros.
    destruct (BoundedIndex_eq_dec C_eq_dec idx idx0); subst;
    rewrite <- ith2_Bounded_imap.
    - repeat rewrite ith2_replace_BoundIndex_eq; reflexivity.
    - repeat rewrite ith2_replace_BoundIndex_neq; auto.
      rewrite <- ith2_Bounded_imap; auto.
  Qed.

End ith2IndexBound.

Section i2th2IndexBound.

  Require Import Fiat.Common.i2list2.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type} {D : Set}.
  Variable (projAD : A -> D).

  (* Given a [BoundedIndex] for a list [Bound], we can always return
     an element of a list indexed by [Bound]. *)

  Definition i2th2_Bounded
          {B B' : A -> Type}
          {C : forall a, B a -> B' a -> Type}
          {As}
          (Bs : ilist B As)
          (Bs' : ilist B' As)
          (Cs : i2list2 C Bs Bs')
          (idx : BoundedIndex (map projAD As))
  : C (nth_Bounded _ As idx)
      (ith_Bounded projAD Bs idx)
      (ith_Bounded projAD Bs' idx) :=
    ith_Bounded_rect2 projAD (fun _ _ _ _ => C) idx Bs Bs'
                       (i2th_error2' Cs (ibound idx)).

  (*Definition Some_Dep_Option_elim_P2
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (Bs : ilist2 B As)
             (idx : BoundedIndex (map projAD As))
             (c_opt : C (nth_Bounded projAD As idx) (ith2_Bounded projAD Bs idx))
  : Dep_Option_elim_P C (ith2_error Bs (ibound idx)) :=
    match (nth_error As (ibound idx)) as e return
          forall nth_n
                 (b : B (@nth_Bounded' _ _ _ _ _ e nth_n))
                 b_opt,
            ith_error_eq_P projAD As idx
                           b_opt
                           nth_n
                           b
            -> C _ b
            -> Dep_Option_elim_P C (a_opt := e) b_opt with
      | Some a => fun nth_n b b_opt b_eq c =>
                    match b_eq in _ = b'
                          return C _ b' -> _ with
                      | eq_refl => fun c => c
                    end c
      | None => fun nth_n b b_opt b_eq c => I
    end (nth_error_map _ _ _ (boundi idx))
        _ _ (ith2_error_eq _ _ _) c_opt.

  Definition replace2_BoundedIndex2
           {B : A -> Type}
           {C : forall a, B a -> Type}
           {As}
           (Bs : ilist2 B As)
           (Cs : i2list2 C Bs)
           (idx : BoundedIndex (map projAD As))
           (new_c : C _ (ith2_Bounded projAD Bs idx))
  : i2list2 C Bs :=
    replace_2Index2' (ibound idx) Cs
                   (Some_Dep_Option_elim_P2 Bs idx new_c).

  Definition Dep_Option_2elim2_P2
             {B : A -> Type}
             {C C' : forall a, B a -> Type}
             (P : forall a b, C a b -> C' a b -> Prop)
             (a_opt : option A)
    := match a_opt return
             forall (b : Dep_Option B a_opt),
               Dep_Option_elim_P C (a_opt := a_opt) b
               -> Dep_Option_elim_P C' (a_opt := a_opt) b -> Prop with
         | Some a => fun b => P a (Dep_Option_elim b)
         | None => fun _ _ _ => True
       end .

  Lemma Dep_Option_2elim2_P2_refl
        {B : A -> Type}
        {C C' : forall a, B a -> Type}
  : forall a_opt b_opt c_opt,
      Dep_Option_2elim2_P2 (fun (a : A) (b : B a) (c c' : C a b) => c = c')
                          (a_opt := a_opt) b_opt c_opt c_opt.
    unfold Dep_Option_2elim2_P2; destruct a_opt; eauto.
  Qed.

  Definition i2th_error2_eq_P
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (idx : BoundedIndex (map projAD As))
             (a_opt : option A)
             (b_opt : Dep_Option B a_opt)
             (c_opt : Dep_Option_elim_P C b_opt)
             (e_eq : option_map projAD a_opt = Some (bindex idx))
             (c_opt' : C (nth_Bounded' projAD As a_opt e_eq)
                         (ith2_Bounded' projAD As e_eq b_opt))
  : Type :=
      match a_opt as a_opt'
        return
        forall (b_opt : Dep_Option B a_opt')
               (e_eq : option_map projAD a_opt' = Some (bindex idx)),
          Dep_Option_elim_P C b_opt ->
          C (nth_Bounded' projAD As a_opt' e_eq)
            (ith2_Bounded' projAD As e_eq b_opt)
          -> Type
      with
        | Some a =>
          fun b_opt e_eq c_opt c_opt' => c_opt = c_opt'
        | None => fun b_opt e_eq c_opt c_opt' => True
      end b_opt e_eq c_opt c_opt'.

    Lemma i2th_error2_eq
          {B : A -> Type}
          {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist2 B As)
             (Cs : i2list2 C Bs),
        i2th_error2_eq_P As idx
        (ith2_error Bs (ibound idx))
        (i2th_error2' Cs (ibound idx))
        (nth_error_map _ _ _ (boundi idx))
        (i2th2_Bounded Cs idx).
    Proof.
      unfold i2th_error2_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Cs; simpl; eauto.
      intros; generalize (IHn As idx In_n (ilist2_tl Bs) Cs); intro H';
      unfold i2th_Bounded, ith2_Bounded_rect; simpl; eauto.
    Qed.

    Definition i2th_error2_eq'
               {B : A -> Type}
               {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist2 B As)
             (c : C (nth_Bounded _ As idx) (ith2_Bounded _ Bs idx)),
        i2th_error2_eq_P As idx (ith2_error Bs (ibound idx))
                        (Some_Dep_Option_elim_P2 Bs idx c)
                        (nth_error_map projAD (ibound idx) As (boundi idx)) c.
    Proof.
      unfold i2th_error2_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Bs; simpl; eauto.
      generalize (IHn As idx In_n Bs);
      unfold i2th_Bounded, ith2_Bounded_rect; simpl; eauto.
    Qed.

    Program Definition i2th_Bounded2_ind
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist2 B As) (Cs : i2list2 C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
    : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist2 B As)
           (Cs : i2list2 C Bs)
           (c : C' (nth_Bounded _ As idx) (ith2_Bounded _ Bs idx)),
        Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith2_error Bs (ibound idx))
                          (i2th_error2' Cs (ibound idx))
                          (Some_Dep_Option_elim_P2 Bs idx c)
        -> P As Bs Cs idx _ (ith2_Bounded _ Bs idx) (i2th2_Bounded Cs idx) c
      := fun As idx Bs Cs c H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith2_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith2_Bounded' projAD As e_eq b_opt)),
                 i2th_error2_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error2_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith2_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith2_error Bs (ibound idx))
             (i2th_error2' Cs (ibound idx))
             (Some_Dep_Option_elim_P2 _ _ c)
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error2_eq _ _) (i2th_error2_eq' _ _ _) H.

    Program Definition i2th_Bounded2_ind2
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist2 B As) (Cs : i2list2 C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
  : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist2 B As)
           (Cs : i2list2 C Bs)
           (Cs' : i2list2 C' Bs),
      Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith2_error Bs (ibound idx))
                          (i2th_error2' Cs (ibound idx))
                          (i2th_error2' Cs' (ibound idx))
      -> P As Bs Cs idx _ (ith2_Bounded _ Bs idx)
           (i2th2_Bounded Cs idx)
           (i2th2_Bounded Cs' idx)
      := fun As idx Bs Cs Cs' H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith2_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith2_Bounded' projAD As e_eq b_opt)),
                 i2th_error2_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error2_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith2_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith2_error Bs (ibound idx))
             (i2th_error2' Cs (ibound idx))
             (i2th_error2' Cs' (ibound idx))
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error2_eq _ _) (i2th_error2_eq _ _) H.

  Variable D_eq_dec : forall d d' : D, {d = d'} + {d <> d'}.

  Lemma i2th_replace2_BoundIndex_neq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist2 B As)
      (Cs : i2list2 C Bs)
      (idx idx' : BoundedIndex (map projAD As))
      (new_c : C _ (ith2_Bounded projAD Bs idx')),
      idx <> idx'
      -> i2th2_Bounded (replace2_BoundedIndex2 Cs idx' new_c) idx =
         i2th2_Bounded Cs idx.
  Proof.
    intros.
    pose (i2th_Bounded2_ind2 (B := B) (C' := C)
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace2_BoundedIndex2.
    unfold i2th2_Bounded.
    rewrite i2th_replace_2Index2'_neq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed.

  Lemma i2th_replace2_BoundIndex_eq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist2 B As)
      (Cs : i2list2 C Bs)
      (idx : BoundedIndex (map projAD As))
      (new_c : C _ (ith2_Bounded projAD Bs idx)),
      i2th2_Bounded (replace2_BoundedIndex2 Cs idx new_c) idx =
      new_c.
  Proof.
    intros.
    eapply (i2th_Bounded2_ind
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace2_BoundedIndex2.
    rewrite i2th_replace_2Index2'_eq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed. *)

End i2th2IndexBound. *)

Ltac subst_strings :=
  repeat match goal with
           | [ H : string |- _ ] => subst H
           | [ H : BoundedIndex _ |- _ ] => subst H
         end.

Ltac pose_string_ids :=
  subst_strings;
  repeat match goal with
           | |- context [String ?R ?R'] =>
             let str := fresh "StringId" in
             set (String R R') as str in *
           (*| |- context [ ``(?R) ] =>
             let idx := fresh in
             set ``(R) as fresh in * *)
         end.

Arguments BoundedString [_] _.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** This file describes an interface [NUM] for abstract numbers and a
    functor that gives properties about them. One specificity of this
    interface is that we require an implemantation of both FSet and
    FMap on our numbers.

    This interface is then instanciated with positive, and we are able
    to use positive maps in our development.

    In [NUMUTILS] we define a tactic [num_lia] (and its couterparts
    [num_lia_false]), that reflects equalities and inequalities from
    [num] into [nat] and then calls [lia]. This tactic is implemented
    with autorewrite libraires.

    In [NUMUTILS], we also define tactics [num_analyse] and [num_prop]
    which respectively performs case analysis on function calls, and
    reflection from boolean functions into the underlying
    relations. (See [BoolView.v] for more details)
*)

Require Import Common.
Require Import BoolView.
Require Import MyFSets MyFSetProperties MyFMapProperties FSetPositive FMapPositive.

Set Implicit Arguments.

(** * The [NUM] interface  *)
Module Type NUM.

  Parameter num : Type.

  Parameter nat_of_num : num -> nat.
  Parameter num_of_nat : nat -> num.

  Parameter leb : num -> num -> bool.
  Parameter ltb : num -> num -> bool.
  Parameter eqb : num -> num -> bool.
  Parameter compare : num -> num -> comparison.

  Parameter le : num -> num -> Prop.
  Parameter lt : num -> num -> Prop.

  Parameter S : num -> num.
  Parameter max: num -> num -> num.

  Parameter fold_num : forall A, (num -> A -> A) -> num -> A -> A.
  Parameter fold_num_sum : forall E T, (num -> T -> T + E) -> num -> T -> (T + E).

  Parameter pi0: num -> num.
  Parameter pi1: num -> num.
  Parameter pimatch: num -> num + num.

  Declare Module NumOTA: OrderedTypeAlt with Definition t := num.
  Declare Module NumSet: FSetInterface.S with Definition E.t := num.
  Declare Module NumMap: FMapInterface.S with Definition E.t := num.

  Parameter code: NumSet.t -> num.

  Notation "0" := (num_of_nat O).
  Notation "n < m" := (lt n m) (at level 70).
  Notation "n <= m" := (le n m) (at level 70).

  (* bijection with nat  *)
  Axiom id_num : forall n, num_of_nat (nat_of_num n) = n.
  Axiom id_nat : forall n, nat_of_num (num_of_nat n) = n.

  (* specification of the boolean operations w.r.t. the predicates *)
  Axiom le_spec : forall n m, reflect (le n m) (leb n m).
  Axiom lt_spec : forall n m, reflect (lt n m) (ltb n m).
  Axiom eq_spec : forall n m, reflect (n = m)  (eqb n m).
  Axiom compare_spec : forall n m, BoolView.compare_spec eq lt n m (compare n m).

  (* specification of operations and predicates, w.r.t. nat *)
  Axiom S_nat_spec : forall n, nat_of_num (S n) = Datatypes.S (nat_of_num n).
  Axiom max_spec : forall n m, nat_of_num (max n m) = Max.max (nat_of_num n) (nat_of_num m).
  Axiom le_nat_spec : forall n m, n <= m <-> (nat_of_num n <= nat_of_num m)%nat.
  Axiom lt_nat_spec : forall n m, n <  m <-> (nat_of_num n <  nat_of_num m)%nat.

  (* specifications of the equalities on maps and sets *)
  Axiom set_eq_spec : forall x y, NumSet.E.eq x y <-> x = y.
  Axiom map_eq_spec : forall x y, NumMap.E.eq x y <-> x = y.

  (* fold_num specification *)
  Axiom fold_num_O: forall A (a: A) f, fold_num f 0 a = a.
  Axiom fold_num_S: forall A (a: A) f n, fold_num f (S n) a = fold_num f n (f n a).

  (* fold_num_sum specification *)
  Axiom fold_num_sum_O: forall E T a f, @fold_num_sum E T f 0 a = inl a.
  Axiom fold_num_sum_S: forall E T a f n, @fold_num_sum E T f (S n) a =
    match f n a with
      | inl a => fold_num_sum f n a
      | e => e
    end.

  (* pi/match specification *)
  Axiom match_pi0: forall n, pimatch (pi0 n) = inl n.
  Axiom match_pi1: forall n, pimatch (pi1 n) = inr n.
  Axiom lt_pi0: forall n m, n < m -> pi0 n < pi0 m.
  Axiom lt_pi1: forall n m, n < m -> pi1 n < pi1 m.

End NUM.

(** * Notations, lemmas and tactics derivable from the [NUM] interface *)
Module NumUtils (N : NUM).
  Export N.
  Module NumSetProps := MySetProps NumSet.
  Module NumMapProps := MyMapProps NumMap.

  Notation "0" := (num_of_nat O) : num_scope.
  Notation "1" := (num_of_nat 1) : num_scope.
  Notation "2" := (num_of_nat 2) : num_scope.
  Notation "3" := (num_of_nat 3) : num_scope.
  Notation "5" := (num_of_nat 5) : num_scope.
  Notation "7" := (num_of_nat 7) : num_scope.

  Notation "n < m" := (lt n m) (at level 70) : num_scope.
  Notation "n <= m" := (le n m) (at level 70) : num_scope.

  Open Scope num_scope.
  Bind Scope num_scope with num.

  (* TODO: the following instances could be in the standard library *)
  Instance le_preorder: PreOrder le.
  Proof.
    constructor.
    intros x; unfold Pos.le. rewrite le_nat_spec. auto with arith.
    intros x y z Hxy Hyz. rewrite le_nat_spec in *. apply (le_trans _ (nat_of_num y)); auto.
  Qed.

  Instance lt_transitive: Transitive lt.
  Proof.
    intros x y z Hxy Hyz. rewrite lt_nat_spec in *. apply (lt_trans _ (nat_of_num y)); auto.
  Qed.

  Lemma num_peano_rec :
    forall (P : num -> Type), P (num_of_nat O) -> (forall p, P p -> P (S p)) -> forall p, P p.
  Proof.
    intros P H IH p.
    rewrite <- id_num.
    generalize (nat_of_num p) as n. clear p.
    intros.
    induction n.
    apply H.
    rewrite <- (id_nat n). rewrite <- S_nat_spec. rewrite id_num. apply IH. auto.
  Qed.

  Lemma eq_nat_spec : forall n m, n = m <-> nat_of_num n = nat_of_num m.
  Proof.
    intuition subst. reflexivity.
    setoid_rewrite <- id_num. rewrite H. reflexivity.
  Qed.

  Coercion num_of_nat : nat >-> num.
  Coercion nat_of_num : num >-> nat.

  Lemma pi0_inj: forall i j, pi0 i = pi0 j -> i = j.
  Proof.
    intros. cut (@inl num num i = @inl num num j). intro H'. injection H'. auto.
    rewrite <- match_pi0, H. apply match_pi0.
  Qed.

  Lemma pi1_inj: forall i j, pi1 i = pi1 j -> i = j.
  Proof.
    intros. cut (@inr num num i = @inr num num j). intro H'. injection H'. auto.
    rewrite <- match_pi1, H. apply match_pi1.
  Qed.

  Instance fold_num_compat' {A} {R} `{E: Equivalence A R}:
  Proper (pointwise_relation num (R ==> R) ==> pointwise_relation num (R ==> R)) (@fold_num A).
  Proof.
    intros f g H n. induction n using num_peano_rec; intros a b H'; simpl.
    rewrite 2fold_num_O. assumption.
    rewrite 2fold_num_S. apply IHn, H, H'.
  Qed.

  Instance fold_num_compat T: Proper
    (pointwise_relation num (pointwise_relation T (@eq T))
      ==>
     pointwise_relation num (pointwise_relation T (@eq T))) (@fold_num T).
  Proof.
    unfold pointwise_relation.
    intros f g H n. induction n using num_peano_rec; intro a; simpl.
     rewrite 2fold_num_O. reflexivity.
     rewrite 2fold_num_S. rewrite IHn. rewrite H. reflexivity.
  Qed.

  (** * num_analyse : destroys the boolean expressions *)

  Instance eqb_view : Type_View eqb := { type_view := eq_spec }.
  Instance leb_view : Type_View leb := { type_view := le_spec }.
  Instance ltb_view : Type_View ltb := { type_view := lt_spec }.

  Ltac num_analyse :=
    repeat first [ type_view eqb | type_view leb | type_view ltb ].

  (** * num_prop : transforms atoms like [leb x y = true] into [le x y] *)
  Lemma leb_true : forall x y, leb x y = true <-> le x y.
  Proof. intros. case le_spec; intuition discriminate. Qed.
  Lemma leb_false : forall x y, leb x y = false <-> lt y x.
  Proof.
    intros. rewrite eq_not_negb. rewrite leb_true.
    rewrite le_nat_spec, lt_nat_spec. lia.
  Qed.
  Lemma ltb_true : forall x y, ltb x y = true <-> lt x y.
  Proof. intros. case lt_spec; intuition discriminate. Qed.
  Lemma ltb_false : forall x y, ltb x y = false <-> le y x.
  Proof.
    intros. rewrite eq_not_negb. rewrite ltb_true.
    rewrite le_nat_spec, lt_nat_spec. lia.
  Qed.
  Lemma eqb_true : forall x y, eqb x y = true <-> x = y.
  Proof. intros. case eq_spec; intuition discriminate. Qed.
  Lemma eqb_false : forall x y, eqb x y = false <-> x <> y.
  Proof. intros. case eq_spec; intuition. Qed.

  Lemma eq_num_dec: forall (n m: num), {n=m} + {n<>m}.
  Proof.
    intros n m. case_eq (eqb n m); intro H.
     rewrite eqb_true in H. auto.
     rewrite eqb_false in H. auto.
  Qed.

  Hint Rewrite
    leb_true leb_false
    ltb_true ltb_false
    eqb_true eqb_false : num_prop.

  Ltac num_prop := autorewrite with num_prop in *.

  Lemma eqb_refl: forall x, eqb x x = true.
  Proof. intro. num_prop. reflexivity. Qed.
  Lemma leb_refl: forall x, leb x x = true.
  Proof. intro. num_prop. reflexivity. Qed.
  Hint Rewrite  eqb_refl leb_refl id_nat id_num: bool_simpl.

  (** * num_lia : injects every prop about nums into equivalent props about nats, then call lia*)
  Lemma num_of_nat_comm : forall x y, x = num_of_nat y <-> nat_of_num x = y.
  Proof.
    intros x y. split; [intros -> | intros <-].
    rewrite id_nat. reflexivity.
    rewrite id_num. reflexivity.
  Qed.

  Lemma nat_of_num_comm : forall x y, num_of_nat y = x <-> y = nat_of_num x .
  Proof.
    intros x y. split; [intros <- | intros ->].
    rewrite id_nat. reflexivity.
    rewrite id_num. reflexivity.
  Qed.

  Hint Rewrite eq_nat_spec le_nat_spec lt_nat_spec S_nat_spec max_spec : num_lia.
  Hint Rewrite nat_of_num_comm num_of_nat_comm : num_lia .
  Hint Rewrite id_nat id_num : num_lia.

  Ltac num_simpl := autorewrite with num_lia in *.
  Ltac num_lia := num_simpl; intuition (subst; lia).
  Ltac num_lia_false := exfalso; num_lia.

  Lemma eqb_eq_nat_bool: forall i j,
    eqb i j = eq_nat_bool (nat_of_num i) (nat_of_num j).
  Proof.
    intros. num_analyse. subst. bool_simpl. reflexivity.
    symmetry. nat_prop. num_lia.
  Qed.

  Lemma numseteqb_eq_nat_bool: forall i j,
    NumSetProps.eqb i j = eq_nat_bool (nat_of_num i) (nat_of_num j).
  Proof.
    intros. rewrite <- eqb_eq_nat_bool. unfold NumSetProps.eqb. destruct (NumSetProps.P.Dec.F.eq_dec i j).
    rewrite set_eq_spec in e. subst. bool_simpl. reflexivity.
    rewrite set_eq_spec in n. symmetry. num_prop. auto.
  Qed.
  Hint Rewrite numseteqb_eq_nat_bool : bool_simpl.

  Lemma le_antisym: forall n m: num, n <= m -> m <= n -> n = m.
  Proof. intros. num_lia. Qed.

End NumUtils.

(** * Instance of [NUM] with [positive] as base type *)
Module Positive <: NUM.
  Definition num := positive.
  Definition nat_of_num n := pred (nat_of_P n).
  Definition num_of_nat := P_of_succ_nat.
  Definition le := Pos.le.
  Definition lt := Pos.lt.
  Definition compare := Pos.compare.

  Definition leb (n m: num) :=
    match Pos.compare n m with
      | Gt => false
      | _ => true
    end.
  Definition ltb (n m: num) :=
    match Pos.compare n m with
      | Lt => true
      | _ => false
    end.
  Definition eqb := eq_pos_bool.

  Definition S := Pos.succ.
  Definition max := Pos.max.
  Definition fold_num T (f: num -> T -> T) :=
    Prect (fun _ => T -> T) (fun acc => acc) (fun a aux acc => aux (f a acc)).

  Fixpoint PeanoView_sum_iter E T (f: positive -> T -> T + E) p (q: PeanoView p) a :=
    match q with
      | PeanoOne => inl a
      | PeanoSucc p q =>
        match f p a with
          | inl a => PeanoView_sum_iter f q a
          | e => e
        end
    end.
  Definition fold_num_sum E T (f: num -> T -> T + E) p a :=  PeanoView_sum_iter f (peanoView p) a.

  Definition pi0 := xO.
  Definition pi1 := xI.
  Definition pimatch i := match i with xO i => inl i | xI i => inr i | xH => inl xH end.

  (* bijection with nat  *)
  Lemma id_num : forall n, num_of_nat (nat_of_num n) = n.
  Proof.
      intros n.
      unfold nat_of_num.
      pattern n.
      apply Pcase. simpl. reflexivity.
      clear n. intros n. replace (nat_of_P (Pos.succ n)) with (Datatypes.S (nat_of_P n)). simpl.
      apply P_of_succ_nat_o_nat_of_P_eq_succ.
      symmetry; apply nat_of_P_succ_morphism.
  Qed.

  Lemma id_nat : forall n, nat_of_num (num_of_nat n) = n.
  Proof.
    intros n.
    unfold nat_of_num.
    assert (Hn : 0 < nat_of_P (num_of_nat n) ). apply lt_O_nat_of_P.
    assert (forall s n, 0 <s -> s = Datatypes.S n -> pred s = n). intros. lia.
    apply H. auto.
    apply nat_of_P_o_P_of_succ_nat_eq_succ.
  Qed.

  (* specification of the boolean operations w.r.t. the predicates *)
  Lemma le_spec : forall n m, reflect (le n m) (leb n m).
  Proof.
    intros n m; unfold leb.
    case_eq (Pos.compare n m); intro H; try constructor.
    apply Pcompare_Eq_eq in H. subst.  unfold le,Pos.le,Pos.compare. rewrite Pcompare_refl. intro; discriminate.
    unfold le. unfold Pos.le. rewrite H. intro; discriminate.
    apply ZC1 in H. unfold le, Pos.le. apply ZC2 in H. rewrite H. intro. tauto_false.
  Qed.
  Lemma lt_spec : forall n m, reflect (lt n m) (ltb n m).
  Proof.
    intros n m; unfold ltb.
    case_eq (Pos.compare n m); intro H; try constructor.
    intro H'. apply Pcompare_Eq_eq in H. subst. refine (Pos.lt_irrefl _ H').
    auto.
    intro H'. apply ZC1 in H. assert (H'' := Pos.lt_trans _ _ _ H H'). refine (Pos.lt_irrefl _ H'').
  Qed.
  Definition eq_spec := eq_pos_spec.
  Lemma compare_spec : forall n m, BoolView.compare_spec eq lt n m (compare n m).
  Proof.
   intros.
   case_eq (compare n m); intro H;  constructor.
   apply Pcompare_Eq_eq. apply H.
   apply H.

   unfold compare in H.
   apply ZC1. auto.
  Qed.

  (* specification of operations and predicates, w.r.t. nat *)
  Lemma S_nat_spec : forall n, nat_of_num (S n) = Datatypes.S (nat_of_num n).
  Proof.
    intros n.
    unfold nat_of_num. rewrite nat_of_P_succ_morphism. simpl.
    assert (H := lt_O_nat_of_P n).
    lia.
  Qed.
  Lemma le_nat_spec : forall n m, le n m <-> (nat_of_num n <= nat_of_num m)%nat.
  Proof.
    intros x y.
    assert (Hx := lt_O_nat_of_P x).
    assert (Hy := lt_O_nat_of_P y).

    split; intro H.
      assert (H' : ~nat_of_P x > nat_of_P y). unfold Pos.le in H. intro H'.
      apply H.
      apply nat_of_P_gt_Gt_compare_complement_morphism. auto.
      unfold nat_of_num .
      lia.

      intro H'.
      apply nat_of_P_gt_Gt_compare_morphism in H'.
      unfold nat_of_num in H.
      lia.
  Qed.

  Lemma lt_nat_spec : forall n m, lt n m <-> (nat_of_num n <  nat_of_num m)%nat.
  Proof.
    intros x y.
    assert (Hx := lt_O_nat_of_P x).
    assert (Hy := lt_O_nat_of_P y).

    split; intro.
    assert (nat_of_P x < nat_of_P y).
    apply    nat_of_P_lt_Lt_compare_morphism. apply H.
    unfold nat_of_num.
    lia.

    apply nat_of_P_lt_Lt_compare_complement_morphism.
    unfold nat_of_num in H.
    lia.
  Qed.

  Lemma max_spec : forall n m, nat_of_num (max n m) = Max.max (nat_of_num n) (nat_of_num m).
  Proof.
    intros n m. unfold max, Pos.max. fold (compare n m). destruct (compare_spec n m).
     rewrite Max.max_r; trivial. apply lt_le_weak. rewrite <- lt_nat_spec. assumption.
     subst. rewrite Max.max_r; trivial.
     rewrite Max.max_l; trivial. apply lt_le_weak. rewrite <- lt_nat_spec. assumption.
  Qed.

  (* fold_num specification *)
  Lemma fold_num_O: forall A (a: A) f, fold_num f xH a = a.
  Proof. reflexivity. Qed.

  Lemma fold_num_S: forall A (a: A) f n, fold_num f (S n) a = fold_num f n (f n a).
  Proof.
    intros. unfold fold_num at 1. rewrite Prect_succ. reflexivity.
  Qed.

  (* fold_num_sum specification *)
  Lemma fold_num_sum_O: forall E T a f, @fold_num_sum E T f (num_of_nat 0) a = inl a.
  Proof. intros. reflexivity. Qed.

  Lemma fold_num_sum_S: forall E T a f n, @fold_num_sum E T f (S n) a =
    match f n a with
      | inl a => fold_num_sum f n a
      | e => e
    end.
  Proof.
    intros. unfold fold_num_sum.
    replace (peanoView (S n)) with (PeanoSucc n (peanoView n)). reflexivity.
    apply PeanoViewUnique.
  Qed.

  (* pi/match specification *)
  Lemma match_pi0: forall n, pimatch (pi0 n) = inl n. Proof. reflexivity. Qed.
  Lemma match_pi1: forall n, pimatch (pi1 n) = inr n. Proof. reflexivity. Qed.

  Lemma lt_pi0: forall n m, lt n m -> lt (pi0 n) (pi0 m).
  Proof. intros n m. setoid_rewrite lt_nat_spec. unfold pi0, nat_of_num. rewrite 2 nat_of_P_xO. lia. Qed.
  Lemma lt_pi1: forall n m, lt n m -> lt (pi1 n) (pi1 m).
  Proof. intros n m. setoid_rewrite lt_nat_spec. unfold pi1, nat_of_num. rewrite 2 nat_of_P_xI. lia. Qed.

  Module NumOTA := Pos_as_OTA.
(*   Module NumSet' := FSetList.Make Pos_as_OT. Module NumSet := FSetHide NumSet'.  *)
  Module NumSet' := FSetPositive.PositiveSet. Module NumSet := FSetHide NumSet'.
  Module NumMap' := FMapPositive.PositiveMap. Module NumMap := FMapHide NumMap'.

  Local Open Scope positive_scope.
  Definition triangle k i := (*  k*(k-1)/2 + i  *)
    match k with
      | 1 => i
      | k'~0 => k'*Pdouble_minus_one k'+i
      | k'~1 => k'*k+i
    end.
  Definition enc i j := triangle (Pos.pred (i+j)) i.
  Fixpoint code (x: NumSet.t): num :=
    match x with
      | NumSet'.Leaf => 1
      | NumSet'.Node l true  r => enc (code l) (code r)~0
      | NumSet'.Node l false r => enc (code l) (code r)~1
    end.

  (* we need this tactic to substitute some positive equalities *)
  Ltac psubst :=
    (repeat match goal with
              | H: Pos_as_OTA.compare _ _ = Eq |- _ => apply Pos_as_OTA.reflect in H
            end); subst.

  (* and this hints to automatically prove some trivial facts, by reflexivity *)
Global   Hint Extern 0 (Pos_as_OTA.compare _ _ = Eq) => apply Pos_as_OT.eq_refl : core.

  Lemma pcompare_prop: forall x y, Pos_as_OTA.compare x y = Eq <-> x = y.
  Proof. intros. intuition; psubst; trivial. Qed.
  Hint Rewrite pcompare_prop : num_prop.

  (* specifications of the equalities on maps and sets *)
  Lemma set_eq_spec : forall x y, NumSet.E.eq x y <-> x = y.
  Proof. intros. reflexivity. Qed.
  Lemma map_eq_spec : forall x y, NumMap.E.eq x y <-> x = y.
  Proof. intros. reflexivity. Qed.

End Positive.

Module PositiveUtils := NumUtils Positive.


(** Adapted from "Elements of Set Theory" Chapter 5 **)
(** Coq coding by choukh, July 2020 **)

Require Export ZFC.Elements.EST5_3.
Require Import ZFC.Lib.FuncFacts.

Local Ltac nz := try (apply nzIntE1; assumption).
Local Ltac mr := apply intMul_ran; nauto.
Local Ltac ar := apply intAdd_ran; nauto.
Local Ltac amr := apply intAdd_ran; apply intMul_ran; nauto.
Local Ltac nzmr := apply nzIntMul_ranI; nauto.

(*** EST第五章4：有理数的序，整数嵌入，关于逆元的运算律 ***)

Close Scope Rat_scope.
Open Scope Int_scope.

Lemma intPos_sn : ∀ n, intPos (Int (S n)).
Proof with nauto.
  intros. apply intLt... rewrite add_0_r, add_0_r...
  apply suc_has_0. apply embed_ran.
Qed.
Global Hint Immediate intPos_sn : number_hint.

Lemma intNeg_sn : ∀ n, intNeg (-Int (S n)).
Proof. intros. apply intPos_neg. nauto. Qed.
Global Hint Immediate intNeg_sn : number_hint.

Lemma intMul_pos_prd : ∀a b ∈ ℤ,
  intPos a → intPos b → intPos (a ⋅ b).
Proof with nauto.
  intros a Ha b Hb Hpa Hpb. unfold intPos.
  rewrite <- (intMul_0_l b)...
  apply intMul_preserve_lt...
Qed.

Lemma intMul_pos_factor : ∀a b ∈ ℤ,
  intPos b → intPos (a ⋅ b) → intPos a.
Proof with neauto.
  intros a Ha b Hb Hpb Hpp.
  destruct (classic (a = Int 0)).
  - subst a. exfalso. rewrite intMul_0_l in Hpp...
    eapply intLt_irrefl...
  - apply intLt_connected in H as []... exfalso.
    eapply intMul_preserve_lt in H...
    rewrite intMul_0_l in H...
    eapply intLt_irrefl. eapply intLt_trans...
Qed.

Lemma intMul_neg_factor : ∀a b ∈ ℤ,
  intPos b → intNeg (a ⋅ b) → intNeg a.
Proof with neauto.
  intros a Ha b Hb Hpb Hpp.
  destruct (classic (a = Int 0)).
  - subst a. exfalso. rewrite intMul_0_l in Hpp...
    eapply intLt_irrefl...
  - apply intLt_connected in H as []... exfalso.
    eapply intMul_preserve_lt in H.
    apply H in Hpb as Hc.
    rewrite (intMul_comm b), intMul_0_l in Hc...
    eapply intLt_irrefl. eapply intLt_trans... nauto. auto. auto.
Qed.

Lemma pQuotE_ratPosDenom : ∀r ∈ ℚ, ∃a ∈ ℤ, ∃b ∈ ℤ',
  r = [<a, b>]~ ∧ intPos b.
Proof with nauto.
  intros r Hr.
  apply pQuotE in Hr as [a [Ha [b [Hb Hr]]]]. subst.
  apply nzIntE0 in Hb as Hb0.
  apply intLt_connected in Hb0 as [Hnb|Hpb]; nz...
  - assert (Hnaz: -a ∈ ℤ) by (apply intAddInv_ran; auto).
    assert (Hnbz: -b ∈ ℤ') by (apply intAddInv_inzInt; auto).
    exists (-a). split... exists (-b). split...
    split. apply rat_ident... rewrite intMul_addInv_lr; nz...
    apply intNeg_pos...
  - exists a. split... exists b. split...
Qed.

(** 有理数的序 **)

Lemma rat_orderable : ∀ a b a' b' c d c' d',
  intPos b → intPos d → intPos b' → intPos d' →
  <a, b> ~ <a', b'> → <c, d> ~ <c', d'> →
  a ⋅ d <𝐳 c ⋅ b ↔ a' ⋅ d' <𝐳 c' ⋅ b'.
Proof.
  intros * Hpb Hpd Hpb' Hpd' H1 H2.
  apply planeEquivE2 in H1 as [H1 [Ha [Hb [Ha' Hb']]]].
  apply planeEquivE2 in H2 as [H2 [Hc [Hd [Hc' Hd']]]].
  assert (Had: a⋅d ∈ ℤ) by (mr;nz).
  assert (Hcb: c⋅b ∈ ℤ) by (mr;nz).
  assert (Hb'd': b'⋅d' ∈ ℤ) by (mr;nz).
  assert (Hpb'd': intPos (b'⋅d')) by (apply intMul_pos_prd; auto; nz).
  rewrite (intMul_preserve_lt _ Had _ Hcb _ Hb'd' Hpb'd').
  rewrite (intMul_assoc a), (intMul_comm d), (intMul_assoc b'),
    <- (intMul_assoc a), (intMul_assoc c), (intMul_comm b),
    (intMul_comm b'), (intMul_assoc d'), <- (intMul_assoc c),
    H1, H2, (intMul_assoc a'), (intMul_comm b), (intMul_assoc d'),
    <- (intMul_assoc a'), (intMul_comm d), (intMul_assoc c'),
    (intMul_comm d), (intMul_assoc b'), <- (intMul_assoc c');
    [|auto;nz;mr;nz..].
  assert (Ha'd': a'⋅d' ∈ ℤ) by (mr;nz).
  assert (Hc'b': c'⋅b' ∈ ℤ) by (mr;nz).
  assert (Hbd: b⋅d ∈ ℤ) by (mr;nz).
  assert (Hpbd: intPos (b⋅d)) by (apply intMul_pos_prd; auto; nz).
  erewrite <- (intMul_preserve_lt _ Ha'd' _ Hc'b' _ Hbd Hpbd).
  reflexivity.
Qed.

(* 有理数的小于关系 *)
Definition RatLt : set := BinRel ℚ (λ r s,
  let u := RatProj r in let v := RatProj s in
  let a := π1 u in let b := π2 u in
  let c := π1 v in let d := π2 v in
  a ⋅ d <𝐳 c ⋅ b
).
Notation "a <𝐪 b" := (<a, b> ∈ RatLt) (at level 70).

Lemma ratLtI : ∀a ∈ ℤ, ∀b ∈ ℤ', ∀c ∈ ℤ, ∀d ∈ ℤ',
  intPos b → intPos d →
  a ⋅ d <𝐳 c ⋅ b → [<a, b>]~ <𝐪 [<c, d>]~.
Proof with eauto.
  intros a Ha b Hb c Hc d Hd Hpb Hpd Hlt.
  apply binRelI. apply pQuotI... apply pQuotI...
  pose proof (ratProj a Ha b Hb)
    as [a' [Ha' [b' [Hb' [H11 [H12 [_ Hpb']]]]]]].
  pose proof (ratProj c Hc d Hd)
    as [c' [Hc' [d' [Hd' [H21 [H22 [_ Hpd']]]]]]].
  pose proof ratEquiv_equiv as [_ [_ [Hsym _]]].
  rewrite H11, H21. simpl. zfc_simple.
  eapply rat_orderable; revgoals...
Qed.

Lemma ratLtE : ∀ r s, r <𝐪 s → ∃a ∈ ℤ, ∃b ∈ ℤ', ∃c ∈ ℤ, ∃d ∈ ℤ',
  intPos b ∧ intPos d ∧
  r = [<a, b>]~ ∧ s = [<c, d>]~ ∧ a ⋅ d <𝐳 c ⋅ b.
Proof with eauto.
  intros r s Hlt. apply SepE in Hlt as [H1 H2].
  apply CPrdE2 in H1 as [Hr Hs]. zfc_simple.
  apply pQuotE_ratPosDenom in Hr as [a [Ha [b [Hb [Hr Hpb]]]]].
  apply pQuotE_ratPosDenom in Hs as [c [Hc [d [Hd [Hs Hpd]]]]]. subst.
  exists a. split... exists b. split...
  exists c. split... exists d. split... repeat split...
  pose proof (ratProj a Ha b Hb)
    as [a' [Ha' [b' [Hb' [H11 [H12 [_ Hpb']]]]]]].
  pose proof (ratProj c Hc d Hd)
    as [c' [Hc' [d' [Hd' [H21 [H22 [_ Hpd']]]]]]].
  rewrite H11, H21 in H2. simpl in H2. zfc_simple.
  eapply rat_orderable; revgoals...
Qed.

Lemma ratLt : ∀a ∈ ℤ, ∀b ∈ ℤ', ∀c ∈ ℤ, ∀d ∈ ℤ',
  intPos b → intPos d →
  [<a, b>]~ <𝐪 [<c, d>]~ ↔ a ⋅ d <𝐳 c ⋅ b.
Proof with eauto.
  intros a Ha b Hb c Hc d Hd Hpb Hpd. split; intros.
  - apply SepE in H as [H1 H2].
    apply CPrdE2 in H1 as [Hr Hs]. zfc_simple.
    pose proof (ratProj a Ha b Hb)
      as [a' [Ha' [b' [Hb' [H11 [H12 [_ Hpb']]]]]]].
    pose proof (ratProj c Hc d Hd)
      as [c' [Hc' [d' [Hd' [H21 [H22 [_ Hpd']]]]]]].
    rewrite H11, H21 in H2. simpl in H2. zfc_simple.
    eapply rat_orderable; revgoals...
  - apply ratLtI...
Qed.

Lemma ratNeqE : ∀a ∈ ℤ, ∀b ∈ ℤ', ∀c ∈ ℤ, ∀d ∈ ℤ',
  [<a, b>]~ ≠ [<c, d>]~ → a ⋅ d ≠ c ⋅ b.
Proof with auto.
  intros a Ha b Hb c Hc d Hd Hnq Heq.
  apply Hnq. apply rat_ident...
Qed.

Lemma ratLt_trans : tranr RatLt.
Proof with auto.
  intros x y z H1 H2.
  assert (H1' := H1). assert (H2' := H2).
  apply ratLtE in H1' as [a [Ha [b [Hb [c [Hc [d [Hd
    [Hpb [Hpd [Hx [Hy _]]]]]]]]]]]].
  apply ratLtE in H2' as [_ [_ [_ [_ [e [He [f [Hf
    [_ [Hpf [_ [Hz _]]]]]]]]]]]]. subst x y z.
  apply ratLt in H1... apply ratLt in H2... apply ratLt...
  assert (H1': a ⋅ d ⋅ f <𝐳 c ⋅ b ⋅ f)
    by (apply intMul_preserve_lt; auto; nz; mr; nz).
  assert (H2': c ⋅ f ⋅ b <𝐳 e ⋅ d ⋅ b)
    by (apply intMul_preserve_lt; auto; nz; mr; nz).
  rewrite
    (intMul_assoc a), (intMul_comm d), <- (intMul_assoc a),
    (intMul_assoc c), (intMul_comm b), <- (intMul_assoc c)
    in H1'; nz...
  rewrite
    (intMul_assoc e), (intMul_comm d), <- (intMul_assoc e)
    in H2'; nz...
  eapply intMul_preserve_lt; revgoals; [
    eapply intLt_trans; revgoals|..
  ]; try eassumption; nz; mr; nz.
Qed.

Lemma ratLt_irrefl : irrefl RatLt.
Proof with eauto.
  intros r Hlt. assert (H := Hlt). apply ratLtE in H
    as [a [Ha [b [Hb [_ [_ [_ [_ [Hpb [_ [Hr _]]]]]]]]]]].
  subst r. apply ratLt in Hlt... eapply intLt_irrefl...
Qed.

Lemma ratLt_connected : connected RatLt ℚ.
Proof with auto.
  intros x Hx y Hy Hnq.
  apply pQuotE_ratPosDenom in Hx as [a [Ha [b [Hb [Hx Hpb]]]]].
  apply pQuotE_ratPosDenom in Hy as [c [Hc [d [Hd [Hy Hpd]]]]].
  subst x y. apply ratNeqE in Hnq...
  apply intLt_connected in Hnq as []; [| |mr;nz..].
  + left. apply ratLtI...
  + right. apply ratLtI...
Qed.

Lemma ratLt_trich : trich RatLt ℚ.
Proof.
  eapply trich_iff. apply binRel_is_binRel.
  apply ratLt_trans. split.
  apply ratLt_irrefl. apply ratLt_connected.
Qed.

Theorem ratLt_linearOrder : linearOrder RatLt ℚ.
Proof.
  split. apply binRel_is_binRel. split.
  apply ratLt_trans. apply ratLt_trich.
Qed.

Close Scope Int_scope.
Open Scope Rat_scope.

Definition ratPos : set → Prop := λ r, Rat 0 <𝐪 r.
Definition ratNeg : set → Prop := λ r, r <𝐪 Rat 0.

Lemma rat_neq_0 : ∀r ∈ ℚ, ratPos r ∨ ratNeg r → r ≠ Rat 0.
Proof.
  intros r Hr [Hpr|Hnr]; intros H; subst;
  eapply ratLt_irrefl; eauto.
Qed.

Lemma ratPos_intPos : ∀a ∈ ℤ, ∀b ∈ ℤ',
  intPos b → ratPos ([<a, b>]~) → intPos a.
Proof with nauto.
  intros a Ha b Hb Hpb Hpr. apply ratLt in Hpr...
  rewrite intMul_0_l, intMul_1_r in Hpr... nz.
Qed.

Lemma ratLt_addInv : ∀ q r ∈ ℚ, q <𝐪 r ↔ -r <𝐪 -q.
Proof with auto.
  intros q Hq r Hr.
  apply pQuotE_ratPosDenom in Hq as [a [Ha [b [Hb [Hp Hpb]]]]].
  apply pQuotE_ratPosDenom in Hr as [c [Hc [d [Hd [Hq Hpd]]]]].
  subst q r. split; intros.
  - apply ratLt in H...
    rewrite ratAddInv, ratAddInv... apply ratLt...
    apply intAddInv_ran... apply intAddInv_ran...
    rewrite intMul_addInv_l, intMul_addInv_l; nz...
    apply intLt_addInv in H; auto; mr; nz.
  - rewrite ratAddInv, ratAddInv in H... apply ratLt in H...
    rewrite intMul_addInv_l, intMul_addInv_l in H; nz...
    apply ratLt... apply intLt_addInv; auto; mr; nz.
    apply intAddInv_ran... apply intAddInv_ran...
Qed.

Lemma ratLt_mulInv : ∀ q r ∈ ℚ, ratPos q → q <𝐪 r → r⁻¹ <𝐪 q⁻¹.
Proof with neauto.
  intros q Hq r Hr Hpq H.
  apply pQuotE_ratPosDenom in Hq as [a [Ha [b [Hb [Hp Hpb]]]]].
  apply pQuotE_ratPosDenom in Hr as [c [Hc [d [Hd [Hq Hpd]]]]].
  subst q r. apply ratLt in H...
  assert (Hpa: intPos a). { eapply ratPos_intPos; revgoals... }
  assert (Ha': a ∈ ℤ'). { apply nzIntI0... apply int_neq_0... }
  assert (Hpad: intPos (a ⋅ d)%z) by (apply intMul_pos_prd; nz; auto).
  assert (Hpcb: intPos (c ⋅ b)%z) by (eapply intLt_trans; eauto).
  assert (Hpc: intPos c) by (eapply intMul_pos_factor; revgoals; eauto; nz).
  assert (Hc': c ∈ ℤ'). { apply nzIntI0... apply int_neq_0... }
  rewrite ratMulInv, ratMulInv... apply ratLt; nz...
  rewrite intMul_comm, (intMul_comm b); nz...
Qed.

Lemma ratPos_rat : ∀ r, ratPos r → r ∈ ℚ.
Proof with auto.
  intros. apply SepE in H as [H _].
  apply CPrdE2 in H as []...
Qed.

Lemma ratNeg_rat : ∀ r, ratNeg r → r ∈ ℚ.
Proof with auto.
  intros. apply SepE in H as [H _].
  apply CPrdE2 in H as []...
Qed.

Lemma ratPos_neg : ∀ r, ratPos r → ratNeg (-r).
Proof with nauto.
  intros. assert (Hr: r ∈ ℚ) by (apply ratPos_rat; auto).
  apply ratLt_addInv... apply ratAddInv_ran...
  rewrite ratAddInv_0, ratAddInv_double...
Qed.

Lemma ratNeg_pos : ∀ r, ratNeg r → ratPos (-r).
Proof with nauto.
  intros. assert (Hr: r ∈ ℚ) by (apply ratNeg_rat; auto).
  rewrite (ratLt_addInv _ Hr _ (rat_n 0)) in H.
  rewrite ratAddInv_0 in H...
Qed.

Lemma ratPos_mulInv : ∀ r, ratPos r → ratPos r⁻¹.
Proof with neauto.
  intros. assert (Hr: r ∈ ℚ) by (apply ratPos_rat; auto).
  apply pQuotE_ratPosDenom in Hr as [a [Ha [b [Hb' [Hp Hpb]]]]].
  assert (Hb: b ∈ ℤ) by (apply nzIntE1; auto).
  subst. apply ratLt in H...
  rewrite intMul_0_l, intMul_1_r in H...
  assert (Ha': a ∈ ℤ'). {
    apply nzIntI0... intros Heq. rewrite Heq in H.
    eapply intLt_irrefl...
  }
  rewrite ratMulInv... apply ratLt...
  rewrite intMul_0_l, intMul_1_r...
Qed.

Lemma ratPos_sm_sn : ∀ m n, ratPos ([<Int (S m), Int (S n)>]~).
Proof with nauto.
  intros. apply ratLt...
  rewrite intMul_0_l, intMul_1_r... apply intPos_sn.
Qed.
Global Hint Immediate ratPos_sm_sn : number_hint.

Lemma ratPos_sn : ∀ n, ratPos (Rat (S n)).
Proof. intros. unfold Rat. nauto. Qed.
Global Hint Immediate ratPos_sn : number_hint.

Lemma ratNeg_sn : ∀ n, ratNeg (-Rat (S n)).
Proof. intros. apply ratPos_neg. nauto. Qed.
Global Hint Immediate ratNeg_sn : number_hint.

Lemma ratPos_r_sn : ∀ n, ratPos (Rat (S n))⁻¹.
Proof. intros n. unfold Rat. rewrite ratMulInv; nauto. Qed.
Global Hint Immediate ratPos_r_sn : number_hint.

Notation "r ≤ s" := (r <𝐪 s ∨ r = s) (at level 70) : Rat_scope.
Notation "r ≥ s" := (s ≤ r) (only parsing, at level 70): Rat_scope.

Definition ratNonNeg : set → Prop := λ r, r ≥ Rat 0.
Definition ratNonPos : set → Prop := λ r, r ≤ Rat 0.

Lemma ratNonNeg_not_neg : ∀r ∈ ℚ, ¬ ratNeg r ↔ ratNonNeg r.
Proof with neauto.
  intros r Hr. split; intros.
  - contra.
    apply not_or_and in H0 as [].
    apply ratLt_connected in H1 as []...
  - intros Hn. destruct H.
    + eapply ratLt_irrefl. eapply ratLt_trans...
    + subst. eapply ratLt_irrefl...
Qed.

Lemma ratNeg_not_nonNeg : ∀r ∈ ℚ, ¬ ratNonNeg r ↔ ratNeg r.
Proof with neauto.
  intros r Hr. split; intros.
  - contra.
    apply ratNonNeg_not_neg in H0...
  - intros Hnn. eapply ratNonNeg_not_neg...
Qed.

Lemma ratNonPos_not_pos : ∀r ∈ ℚ, ¬ ratPos r ↔ ratNonPos r.
Proof with neauto.
  intros r Hr. split; intros.
  - contra.
    apply not_or_and in H0 as [].
    apply ratLt_connected in H1 as []...
  - intros Hp. destruct H.
    + eapply ratLt_irrefl. eapply ratLt_trans...
    + subst. eapply ratLt_irrefl...
Qed.

Lemma ratPos_not_nonPos : ∀r ∈ ℚ, ¬ ratNonPos r ↔ ratPos r.
Proof with neauto.
  intros r Hr. split; intros.
  - contra.
    apply ratNonPos_not_pos in H0...
  - intros Hnp. eapply ratNonPos_not_pos...
Qed.

(* 有理数绝对值 *)
Definition RatAbs : set → set := λ r,
  match (ixm (ratPos (-r))) with
  | inl _ => -r
  | inr _ => r
  end.
Notation "| r |" := (RatAbs r) (at level 40) : Rat_scope.

Lemma ratAbs_geq_0 : ∀r ∈ ℚ, ratNonNeg (|r|).
Proof with neauto.
  intros r Hr. unfold RatAbs.
  destruct (ixm (ratPos (-r))) as [H|H].
  - destruct (classic (r = Rat 0)).
    + right. rewrite H0, ratAddInv_0...
    + apply ratLt_connected in H0 as []... left...
      apply ratPos_neg in H0. exfalso.
      eapply ratLt_irrefl. eapply ratLt_trans...
  - destruct (classic (r = Rat 0)). right...
    apply ratLt_connected in H0 as []...
    exfalso. apply H. apply ratNeg_pos... left...
Qed.

Close Scope Rat_scope.
Open Scope Int_scope.

Theorem ratAdd_preserve_lt : ∀ r s t ∈ ℚ,
  r <𝐪 s ↔ (r + t <𝐪 s + t)%q.
Proof with auto.
  intros r Hr s Hs t Ht.
  apply pQuotE_ratPosDenom in Hr as [a [Ha [b [Hb [Hr Hpb]]]]].
  apply pQuotE_ratPosDenom in Hs as [c [Hc [d [Hd [Hs Hpd]]]]].
  apply pQuotE_ratPosDenom in Ht as [e [He [f [Hf [Ht Hpf]]]]].
  subst r s t. rewrite (ratLt a Ha b Hb c Hc d Hd Hpb Hpd).
  rewrite ratAdd_a_b_c_d, ratAdd_a_b_c_d...
  assert (Hz1: a⋅f + e⋅b ∈ ℤ) by (amr;nz).
  assert (Hz2: b⋅f ∈ ℤ') by nzmr.
  assert (Hz3: c⋅f + e⋅d ∈ ℤ) by (amr;nz).
  assert (Hz4: d⋅f ∈ ℤ') by nzmr.
  assert (Hpbf: intPos (b⋅f)) by (apply intMul_pos_prd; nz; auto).
  assert (Hpdf: intPos (d⋅f)) by (apply intMul_pos_prd; nz; auto).
  rewrite (ratLt _ Hz1 _ Hz2 _ Hz3 _ Hz4 Hpbf Hpdf).
  rewrite intMul_distr', intMul_distr'; [|mr;nz..].
  assert (Hzf: f ∈ ℤ) by nz.
  rewrite
    (intMul_assoc a), (intMul_comm f),
    (intMul_assoc d), <- (intMul_assoc a),
    (intMul_assoc c), (intMul_comm f Hzf (b⋅f)),
    (intMul_assoc b), <- (intMul_assoc c),
    (intMul_assoc e), (intMul_comm b),
    (intMul_assoc d), <- (intMul_assoc e), (intMul_comm b);
      nz; [|try mr;nz;auto..].
  assert (Hz5: (a⋅d)⋅(f⋅f) ∈ ℤ) by (apply intMul_ran; mr;nz).
  assert (Hz6: (c⋅b)⋅(f⋅f) ∈ ℤ) by (apply intMul_ran; mr;nz).
  assert (Hz7: (e⋅d)⋅(f⋅b) ∈ ℤ) by (apply intMul_ran; mr;nz).
  rewrite <- (intAdd_preserve_lt _ Hz5 _ Hz6 _ Hz7).
  apply intMul_preserve_lt; revgoals; [|mr;nz..].
  apply intMul_pos_prd...
Qed.

Theorem ratMul_preserve_lt : ∀ r s t ∈ ℚ,
  ratPos t → r <𝐪 s ↔ (r ⋅ t <𝐪 s ⋅ t)%q.
Proof with nauto.
  cut (∀ r s t ∈ ℚ, ratPos t → r <𝐪 s → (r ⋅ t <𝐪 s ⋅ t)%q).
  intros Hright r Hr s Hs t Ht Hpt. split; intros Hlt.
  apply Hright... destruct (classic (r = s)).
  subst. exfalso. eapply ratLt_irrefl; eauto.
  apply ratLt_connected in H as []... exfalso.
  apply (Hright s Hs r Hr t Ht Hpt) in H.
  eapply ratLt_irrefl. eapply ratLt_trans; eauto.
  intros r Hr s Hs t Ht Hpt Hlt.
  apply pQuotE_ratPosDenom in Hr as [a [Ha [b [Hb [Hr Hpb]]]]].
  apply pQuotE_ratPosDenom in Hs as [c [Hc [d [Hd [Hs Hpd]]]]].
  apply pQuotE_ratPosDenom in Ht as [e [He [f [Hf [Ht Hpf]]]]]. subst.
  apply ratLt in Hpt... rewrite intMul_0_l, intMul_1_r in Hpt; nz...
  apply ratLt in Hlt... rewrite ratMul_a_b_c_d, ratMul_a_b_c_d...
  apply ratLt. mr. nzmr. mr. nzmr.
  apply intMul_pos_prd; nz... apply intMul_pos_prd; nz...
  rewrite
    (intMul_assoc a), (intMul_comm e),
    (intMul_assoc d), <- (intMul_assoc a),
    (intMul_assoc c), (intMul_comm e),
    (intMul_assoc b), <- (intMul_assoc c);
      nz; auto; [|mr;nz..].
  apply intMul_preserve_lt... mr;nz. mr;nz. mr;nz.
  apply intMul_pos_prd; nz...
Qed.

Close Scope Int_scope.
Open Scope Rat_scope.

Corollary ratAdd_preserve_lt' : ∀ r s t ∈ ℚ,
  r <𝐪 s ↔ (t + r <𝐪 t + s)%q.
Proof with auto.
  intros r Hr s Hs t Ht.
  rewrite ratAdd_comm, (ratAdd_comm t)...
  apply ratAdd_preserve_lt...
Qed.

Corollary ratAdd_preserve_lt_trans : ∀ q r s t ∈ ℚ,
  q <𝐪 r → s <𝐪 t → q + s <𝐪 r + t.
Proof with auto.
  intros q Hq r Hr s Hs t Ht H1 H2.
  apply (ratAdd_preserve_lt q Hq r Hr s Hs) in H1.
  apply (ratAdd_preserve_lt s Hs t Ht r Hr) in H2.
  rewrite (ratAdd_comm s), (ratAdd_comm t) in H2...
  eapply ratLt_trans; eauto.
Qed.

Corollary ratMul_preserve_lt' : ∀ r s t ∈ ℚ,
  ratPos t → r <𝐪 s ↔ t ⋅ r <𝐪 t ⋅ s.
Proof with auto.
  intros r Hr s Hs t Ht.
  rewrite ratMul_comm, (ratMul_comm t)...
  apply ratMul_preserve_lt...
Qed.

Corollary ratMul_preserve_lt_trans : ∀ q r s t ∈ ℚ,
  ratPos r → ratPos s → q <𝐪 r → s <𝐪 t → q ⋅ s <𝐪 r ⋅ t.
Proof with auto.
  intros q Hq r Hr s Hs t Ht Hpr Hps H1 H2.
  apply (ratMul_preserve_lt q Hq r Hr s Hs) in H1...
  apply (ratMul_preserve_lt s Hs t Ht r Hr) in H2...
  rewrite (ratMul_comm s), (ratMul_comm t) in H2...
  eapply ratLt_trans; eauto.
Qed.

Theorem ratAdd_cancel : ∀ r s t ∈ ℚ, r + t = s + t → r = s.
Proof with eauto.
  intros r Hr s Hs t Ht Heq.
  assert (r + t - t = s + t - t) by congruence.
  rewrite ratAdd_assoc, (ratAdd_assoc s) in H...
  rewrite ratAddInv_annih, ratAdd_0_r, ratAdd_0_r in H...
  apply ratAddInv_ran... apply ratAddInv_ran...
Qed.

Corollary ratAdd_cancel' : ∀ r s t ∈ ℚ, t + r = t + s → r = s.
Proof with eauto.
  intros r Hr s Hs t Ht Heq.
  eapply ratAdd_cancel...
  rewrite ratAdd_comm, (ratAdd_comm s)...
Qed.

Theorem ratMul_cancel : ∀ r s ∈ ℚ, ∀ t ∈ ℚ', r ⋅ t = s ⋅ t → r = s.
Proof with eauto.
  intros r Hr s Hs t Ht' Heq.
  assert (r ⋅ t / t = s ⋅ t / t) by congruence.
  assert (Ht: t ∈ ℚ) by (apply nzRatE1; auto).
  assert (Hrt: t⁻¹ ∈ ℚ) by (apply nzRatE1; apply ratMulInv_ran; auto).
  rewrite (ratMul_assoc r), (ratMul_assoc s) in H...
  rewrite ratMulInv_annih, ratMul_1_r, ratMul_1_r in H...
Qed.

Corollary ratMul_cancel' : ∀ r s ∈ ℚ, ∀ t ∈ ℚ', t ⋅ r = t ⋅ s → r = s.
Proof with eauto.
  intros r Hr s Hs t Ht Heq.
  eapply ratMul_cancel...
  rewrite ratMul_comm, (ratMul_comm s); auto; apply nzRatE1...
Qed.

Corollary ratMul_preserve_le : ∀ r s t ∈ ℚ,
  ratPos t → r ≤ s ↔ r ⋅ t ≤ s ⋅ t.
Proof with auto.
  intros r Hr s Hs t Ht Hpt. split; intros [Hlt|Heq].
  - left. apply ratMul_preserve_lt...
  - right. subst...
  - left. apply ratMul_preserve_lt in Hlt...
  - right. apply ratMul_cancel in Heq...
    apply nzRatI0... apply rat_neq_0...
Qed.

Lemma ratAdd_pos_sum : ∀ r s ∈ ℚ,
  ratPos r → ratPos s → ratPos (r + s).
Proof with nauto.
  intros r Hr s Hs Hnr Hns.
  unfold ratPos. rewrite <- (ratAdd_0_r (Rat 0))...
  apply ratAdd_preserve_lt_trans...
Qed.

Lemma ratAdd_neg_sum : ∀ r s ∈ ℚ,
  ratNeg r → ratNeg s → ratNeg (r + s).
Proof with nauto.
  intros r Hr s Hs Hnr Hns.
  unfold ratNeg. rewrite <- (ratAdd_0_r (Rat 0))...
  apply ratAdd_preserve_lt_trans...
Qed.

Lemma ratAdd_nonNeg_sum : ∀ p q ∈ ℚ,
  ratNonNeg p → ratNonNeg q → ratNonNeg (p + q).
Proof with nauto.
  intros p Hp q Hq Hnnp Hnnq.
  destruct (classic (p = Rat 0 ∨ q = Rat 0)).
  - destruct H; subst.
    rewrite ratAdd_0_l... rewrite ratAdd_0_r...
  - apply not_or_and in H as [].
    destruct Hnnp; destruct Hnnq; [|exfalso; auto..].
    left. apply ratAdd_pos_sum...
Qed.

Lemma ratMul_pos_prd : ∀ p q ∈ ℚ,
  ratPos p → ratPos q → ratPos (p ⋅ q).
Proof with nauto.
  intros p Hp q Hq Hpp Hpq. unfold ratPos.
  rewrite <- (ratMul_0_l q)...
  apply ratMul_preserve_lt...
Qed.

Lemma ratMul_neg_prd : ∀ p q ∈ ℚ,
  ratPos p → ratNeg q → ratNeg (p ⋅ q).
Proof with nauto.
  intros p Hp q Hq Hpp Hnq.
  unfold ratNeg. rewrite ratMul_comm, <- (ratMul_0_l p)...
  apply ratMul_preserve_lt...
Qed.

Lemma ratMul_nonNeg_prd : ∀ p q ∈ ℚ,
  ratNonNeg p → ratNonNeg q → ratNonNeg (p ⋅ q).
Proof with nauto.
  intros p Hp q Hq Hnnp Hnnq.
  destruct (classic (p = Rat 0 ∨ q = Rat 0)).
  - destruct H; subst.
    rewrite ratMul_0_l... rewrite ratMul_0_r_r...
  - apply not_or_and in H as [].
    destruct Hnnp; destruct Hnnq; [|exfalso; auto..].
    left. apply ratMul_pos_prd...
Qed.

(** 整数嵌入 **)
Definition IntEmbed := Func ℤ ℚ (λ a, [<a, Int 1>]~).

Theorem intEmbed_function : IntEmbed: ℤ ⇒ ℚ.
Proof.
  apply meta_function.
  intros x Hx. apply pQuotI; nauto.
Qed.

Corollary intEmbed_ran : ∀a ∈ ℤ, IntEmbed[a] ∈ ℚ.
Proof with auto.
  pose proof intEmbed_function as [Hf [Hd Hr]].
  intros a Ha. apply Hr. eapply ranI.
  apply func_correct... rewrite Hd...
Qed.

Theorem intEmbed_injective : injective IntEmbed.
Proof with nauto.
  apply meta_injection. intros x Hx. apply pQuotI...
  intros x1 Hx1 x2 Hx2 Heq. apply rat_ident in Heq...
  rewrite intMul_1_r, intMul_1_r in Heq...
Qed.

Lemma intEmbed_a : ∀a ∈ ℤ, IntEmbed[a] = [<a, Int 1>]~.
Proof with nauto.
  intros a Ha. unfold IntEmbed. rewrite meta_func_ap...
  apply intEmbed_function.
Qed.

Theorem intEmbed : ∀ n : nat, IntEmbed[Int n] = Rat n.
Proof. intros. rewrite intEmbed_a; nauto. Qed.

Lemma intEmbed_addInv : ∀a ∈ ℤ, IntEmbed[(-a)%z] = -[<a, Int 1>]~.
Proof with nauto.
  intros a Ha. rewrite intEmbed_a, ratAddInv...
  apply intAddInv_ran...
Qed.

Theorem intEmbed_add : ∀ a b ∈ ℤ,
  IntEmbed[(a + b)%z] = IntEmbed[a] + IntEmbed[b].
Proof with nauto.
  intros a Ha b Hb.
  repeat rewrite intEmbed_a; [|auto;ar..].
  rewrite ratAdd_a_b_c_d...
  rewrite intMul_1_r, intMul_1_r, intMul_1_r...
Qed.

Theorem intEmbed_mul : ∀ a b ∈ ℤ,
  IntEmbed[(a ⋅ b)%z] = IntEmbed[a] ⋅ IntEmbed[b].
Proof with nauto.
  intros a Ha b Hb.
  repeat rewrite intEmbed_a; [|auto;mr..].
  rewrite ratMul_a_b_c_d, intMul_1_r...
Qed.

Theorem intEmbed_lt : ∀ a b ∈ ℤ,
  a <𝐳 b ↔ IntEmbed[a] <𝐪 IntEmbed[b].
Proof with auto.
  intros a Ha b Hb.
  repeat rewrite intEmbed_a...
  pose proof (int_sn 0) as Hz1.
  pose proof (intPos_sn 0) as Hp1.
  rewrite (ratLt a Ha (Int 1) Hz1 b Hb (Int 1) Hz1 Hp1 Hp1).
  rewrite intMul_1_r, intMul_1_r... reflexivity.
Qed.

Theorem intEmbed_div : ∀a ∈ ℤ, ∀b ∈ ℤ',
  [<a, b>]~ = IntEmbed[a] / IntEmbed[b].
Proof with nauto.
  intros a Ha b Hb.
  repeat rewrite intEmbed_a; nz...
  rewrite ratMulInv, ratMul_a_b_c_d...
  rewrite intMul_1_r, intMul_1_l; nz...
Qed.

Close Scope Rat_scope.
Open Scope Int_scope.

(** 关于逆元的运算律 **)

Lemma intAddInv_sum : ∀ a b ∈ ℤ, -(a + b) = -a - b.
Proof with auto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hd]]]]. subst b.
  rewrite intAddInv, intAddInv, intAdd_m_n_p_q,
    intAdd_m_n_p_q, intAddInv; auto; apply add_ran...
Qed.

Lemma intAddInv_diff : ∀ a b ∈ ℤ, -(a - b) = b - a.
Proof with auto.
  intros a Ha b Hb.
  rewrite intAddInv_sum, intAddInv_double, intAdd_comm;
    auto; apply intAddInv_ran...
Qed.

Lemma ratAddInv_sum : ∀ r s ∈ ℚ, (-(r + s) = -s - r)%q.
Proof with auto.
  intros r Hr s Hs.
  apply pQuotE in Hr as [a [Ha [b [Hb Hr]]]]. subst r.
  apply pQuotE in Hs as [c [Hc [d [Hd Hs]]]]. subst s.
  assert (H1: a ⋅ d + c ⋅ b ∈ ℤ) by (amr;nz).
  assert (H2: b ⋅ d ∈ ℤ') by nzmr.
  assert (H3: d ⋅ b ∈ ℤ') by nzmr.
  assert (H4: -a ∈ ℤ) by (apply intAddInv_ran; auto).
  assert (H5: -c ∈ ℤ) by (apply intAddInv_ran; auto).
  rewrite ratAddInv, ratAddInv, ratAdd_a_b_c_d,
    ratAdd_a_b_c_d, ratAddInv...
  apply rat_ident... apply intAddInv_ran... amr;nz.
  assert (H6: a ⋅ d ∈ ℤ) by (mr;nz).
  assert (H7: c ⋅ b ∈ ℤ) by (mr;nz).
  rewrite intMul_addInv_l, intMul_distr', intMul_distr',
    intAddInv_sum, (intMul_comm d), intAdd_comm, intMul_addInv_l,
    intMul_addInv_l, intMul_addInv_l, intMul_addInv_l;
    try timeout 1 nz; try timeout 1 auto.
  apply intAddInv_ran; apply intMul_ran; nz...
  apply intAddInv_ran; apply intMul_ran; nz...
  apply intMul_ran; nz... apply intMul_ran; nz...
  rewrite intMul_addInv_l; nz... apply intAddInv_ran...
  rewrite intMul_addInv_l; nz... apply intAddInv_ran...
Qed.

Close Scope Int_scope.
Open Scope Rat_scope.

Lemma ratAddInv_diff : ∀ r s ∈ ℚ, -(r - s) = s - r.
Proof with auto.
  intros r Hr s Hs.
  rewrite ratAddInv_sum, ratAddInv_double, ratAdd_comm;
    auto; apply ratAddInv_ran...
Qed.

Lemma ratMulInv_prd : ∀ r s ∈ ℚ', (r ⋅ s)⁻¹ = r⁻¹ ⋅ s⁻¹.
Proof with auto.
  intros r Hr s Hs.
  apply nzRatE2 in Hr as [a [Ha [b [Hb Hr]]]]. subst r.
  apply nzRatE2 in Hs as [c [Hc [d [Hd Hs]]]]. subst s.
  rewrite ratMulInv, ratMulInv, ratMul_a_b_c_d,
    ratMul_a_b_c_d, ratMulInv; nz; auto; nzmr.
Qed.

Lemma ratMulInv_quot : ∀ r s ∈ ℚ', (r / s)⁻¹ = s / r.
Proof with auto.
  intros r Hr s Hs.
  rewrite ratMulInv_prd, ratMulInv_double, ratMul_comm...
  apply nzRatE1. apply ratMulInv_ran...
  apply nzRatE1... apply ratMulInv_ran...
Qed.

Lemma ratMul_addInv_l : ∀ p q ∈ ℚ, -p ⋅ q = -(p ⋅ q).
Proof with auto.
  intros p Hp q Hq.
  apply pQuotE in Hp as [a [Ha [b [Hb Hp]]]]. subst p.
  apply pQuotE in Hq as [c [Hc [d [Hd Hq]]]]. subst q.
  rewrite ratAddInv, ratMul_a_b_c_d, ratMul_a_b_c_d,
    ratAddInv, intMul_addInv_l... mr. nzmr.
  apply intAddInv_ran...
Qed.

Lemma ratMul_addInv_r : ∀ p q ∈ ℚ, p ⋅ -q = -(p ⋅ q).
Proof with auto.
  intros p Hp q Hq.
  apply pQuotE in Hp as [a [Ha [b [Hb Hp]]]]. subst p.
  apply pQuotE in Hq as [c [Hc [d [Hd Hq]]]]. subst q.
  rewrite ratAddInv, ratMul_a_b_c_d, ratMul_a_b_c_d,
    ratAddInv, intMul_addInv_r... mr. nzmr.
  apply intAddInv_ran...
Qed.

Lemma ratMul_addInv_lr : ∀ p q ∈ ℚ, p ⋅ -q = -p ⋅ q.
Proof with auto.
  intros p Hp q Hq.
  rewrite ratMul_addInv_l, ratMul_addInv_r...
Qed.