From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq tuple div fintype.

(* Set Implicit Arguments. *)
(* Unset Strict Implicit. *)
(* Unset Printing Implicit Defensive. *)

Section States.

Structure state (sType : Type) :=  State {
  sContent : seq sType
}.

Definition mt_state : state False := State _ [::].

Structure world := World {
  wType : Type;
  coherent : state wType -> Prop;
  change : state wType -> state wType
}.

Definition mt_world := World _ (fun s => s = mt_state) (fun x => x).

Goal @coherent mt_world mt_state.
Proof. by done. Qed.

Structure packed_state := PState {
  pType : Type;
  pState : state pType
}.

Definition pstates := seq (nat * packed_state).
Definition worlds := seq (nat * world).

Definition get {T} (x0 : T) (s : seq (nat * T)) l :=
  let: n := find (fun z => fst z == l) s in
  if n < length s then snd (nth (n, x0) s l) else x0.

Definition gets (s : pstates) := get (PState _ mt_state) s.
Definition getw (w : worlds) := get mt_world w.

Definition keys {T} (s : seq (nat * T)) := map (fun e => fst e) s.

(* Pre-coherence, types are equal *)
Definition coh1 (w : worlds) (s : pstates) :=
  keys w = keys s /\
  forall l, pType (gets s l) = wType (getw w l).

Definition cast (t t' : Type) (r : t = t') (e : t) : t' :=
  match r in (_ = t') return t' with erefl => e end.

Require Import Eqdep.
Definition castK m (r : m = m) (e : m) : cast _ _ r e = e.
Proof. by move: r; apply: Streicher_K. Qed.

Lemma cohE w s : coh1 w s ->
                 forall l, state (pType (gets s l)) = state (wType (getw w l)).
Proof. by case=>C1 C2  l; move: (C2 l)=>->. Qed.

(* Since we know that the state's type is the same as the world's, we can assure it's coherent *)
Definition coh2 (w : worlds) (s : pstates) (C1 :  coh1 w s):=
  forall l, @coherent (getw w l) (cast _ _ (cohE _ _ C1 l) (pState (gets s l))).

(* Overall coherence is a dependent product. *)
Definition coh (w : worlds) (s : pstates) := exists C1: coh1 w s, coh2 _ _ C1.

Lemma get_mt {T} (x0 : T) l : get x0 [::] l = x0.
Proof. by []. Qed.

(* Okay, now let's prove something trivial *)

(* REM: The following proof works if we just evaluate gets [::] l: *)
Lemma coh_empty : coh [::] [::].
Proof.
have C1: coh1 [::] [::] by [].
exists C1=>l.
by simpl; apply: castK.
Qed.

Set Injection On Proofs.

(* A simpler version of the same goal, with "get" stripped off *)
Lemma X : forall (G : state (pType {| pType := False; pState := mt_state |}) = state False),
    cast (state (pType {| pType := False; pState := mt_state |}))
         (state False) G mt_state = mt_state.
have E: pType {| pType := False; pState := mt_state |} = False by [].
rewrite /cast.

injection E.

(* Okay, how can we now rewrite the equality in the type of G without
   reducing it explicitly? *)

Lemma Y : forall l (C1 : coh1 [::] [::]),
  coherent (get mt_world [::] l)
    (cast (state (pType (get {| pType := False; pState := mt_state |} [::] l)))
       (state (wType (get mt_world [::] l))) (cohE [::] [::] C1 l)
       (pState (get {| pType := False; pState := mt_state |} [::] l))).
move=>l C1.
move: (get_mt {| pType := False; pState := mt_state |} l) => H.

(*

"injection" is Coq's standard tactic, ssreflect's version would be
"case". See ssrfelect manual for the explanation of the relation
vetween the two (https://hal.inria.fr/inria-00258384)

After trying it, the following cryptic message is given:

"Error: No information can be deduced from this equality and the
injectivity of constructors. This may be because the terms are
convertible, or due to pattern matching restrictions in the sort
Prop."

Perhaps, we should investigate how the injection works here. According
to Adam's page

http://adam.chlipala.net/itp/tactic-reference.html

the equality shoud be indeed between elements of two constructors,
but, here there are no constructors, jsut the equality.

*)

injection H.

Defined.
Print X.

(* However, an attempt to prove it by rewriting gloriously fails: *)
Lemma coh_empty' : coh [::] [::].
Proof.
have C1: coh1 [::] [::] by [].
exists C1=>l.
(* let's now do some rewriting in the goal, but no simplification: *)
rewrite /gets/getw.

(* The following rewriting should fire in the goal, although it
doesn't, and fails on the dependent error. *)

(*

(* ssreflect rewriting fails*)
rewrite get_mt.

*)

(*

(* And so does Coq's dependent rewiriting *)

have X: get mt_world [::] l = mt_world by apply: get_mt.
dependent rewrite -> X.

 *)

Admitted.

Lemma get_cat {T} (x0 : T) (s1 s2 : seq (nat * T)) l :
  get x0 (s1 ++ s2) l = if l \in keys s1 then get x0 s1 l else get x0 s2 l.
Proof.
(* OKay, this should be true, but I'm too lazy to prove it now *)
Admitted.

(* Let's prove something more complicated. *)
Lemma coh_cat w1 w2 s1 s2 :
  coh w1 s1 -> coh w2 s2 -> coh (w1 ++ w2) (s1 ++ s2).
Proof.
move=>C1 C2.
have X1: keys (w1 ++ w2) = keys (s1 ++ s2).
- case: C1; case=>H1 _ _; case: C2; case=>H2 _ _.
  by rewrite /keys in H1 H2 *; rewrite !map_cat H1 H2.
have X2: coh1 (w1 ++ w2) (s1 ++ s2).
- split=>// l; rewrite /gets/getw.
  case: C1; case=>H1 G1 _; case: C2; case=>H2 G2 _.
  by rewrite !get_cat H1; case: ifP=>H; [apply: G1 | apply:G2].
(* Now the real fun begins. *)
exists X2=>l; rewrite /gets/getw.

(* Two direct equalities we would like to use for rewriting *)
have Es: get (PState _ mt_state) (s1 ++ s2) l =
   if l \in keys s1 then get (PState _ mt_state) s1 l else get (PState _ mt_state) s2 l
by rewrite get_cat.

have Ew: get mt_world (w1 ++ w2) l =
   if l \in keys s1 then get mt_world w1 l else get mt_world w2 l
by rewrite get_cat; case: (C1); case=>H1 G1 _; rewrite H1.

(* Butwe can't because of the depented type error! *)
rewrite Ew.

End States.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(* Transformation of
     List of Pairs (id, T)
   into
     Maps from id to T (FMap interface)

   Last Update: Wed, 14 June 2017
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..".

Require Import ConceptParams.AuxTactics.LibTactics.
Require Import ConceptParams.AuxTactics.BasicTactics.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Bool.Bool.

Require Import Coq.Structures.Equalities.
Require Import Coq.FSets.FMapFacts.
Require Import Coq.FSets.FMapInterface.
Require Import Coq.FSets.FMapAVL.

(* ***************************************************************** *)
(** * List-of-Pairs-to-Map

      ([FMap] based transformations of [List of Pair]) *)

(** Module with definitions and properties of functions
    that transform lists of pairs into maps.
 *)
(* ***************************************************************** *)
(* ***************************************************************** *)

(* ################################################################# *)
(** ** Auxiliary Module Types for Ordering *)
(* ################################################################# *)

(** Original [DecidableType] Module (used in weak FMaps)
 ** together with usual equality. *)

Module Type UsualDecidableTypeOrig <: UsualDecidableType.
  Include UsualDecidableType.
  Parameter eq_refl : forall x : t, eq x x.
  Parameter eq_sym : forall x y : t, eq x y -> eq y x.
  Parameter eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
End UsualDecidableTypeOrig.

(** Original [OrderedType] Module (used in FMaps)
 ** together with decidable usual equality. *)

Module Type UsualOrderedTypeOrig
<: OrderedType <: UsualDecidableType <: UsualDecidableTypeOrig.
  (*Include UsualDecidableType. *)
  Include UsualDecidableTypeOrig.
  Parameter lt : t -> t -> Prop.
  Parameter lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Parameter lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Parameter compare : forall x y : t, Compare lt eq x y.
End UsualOrderedTypeOrig.

(* ################################################################# *)
(** ** Module Type [ListPair2FMapW] *)
(* ################################################################# *)

(** [ListPair2FMapW] functor takes [id_UOT : UsualOrderedType] module,
    a compatible [id_Map : FMapInterface.WS] module,
    which provides a finite map for type [id_UOT.t] of "identifiers". *)

Module Type ListPair2FMapW
       (id_UDTOrig : UsualDecidableTypeOrig)
       (id_Map : FMapInterface.WS
           with Definition E.t := id_UDTOrig.t
           with Definition E.eq := id_UDTOrig.eq)
(* See some comments in [MListPair2FMapW]. *)
.

  (** Ordering of ids *)
  Module IdDT := id_UDTOrig.

  (** FMap of ids *)
  Module IdMap := id_Map.

  (** Type of Identificators *)
  Definition id : Type := IdMap.key.

  (** Type of Map-of-Identifiers *)
  Definition id_map := IdMap.t.

(* ================================================================= *)
(** *** Main Functions *)
(* ================================================================= *)

  (** [map_from_list] builds a map [id -> A] from
   ** the list of pairs [id * A]. *)
  Parameter map_from_list : forall {A : Type}, list (id * A) -> id_map A.

  Definition get_ids {A : Type} (xs : list (id * A)) : list id :=
    map fst xs.

(* ================================================================= *)
(** *** Main Definitions *)
(* ================================================================= *)

  Parameter eq_list_map : forall {A : Type},
      list (id * A) -> id_map A -> Prop.

(* ================================================================= *)
(** *** Properties *)
(* ================================================================= *)

  Module Props.

(* ----------------------------------------------------------------- *)
(** *** Props about List.In and IdMap.In  *)
(* ----------------------------------------------------------------- *)

    Axiom in_map_from_list__id_in_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val),
        IdMap.MapsTo nm tp (map_from_list pnds) ->
        List.In nm (get_ids pnds).

    Axiom in_map_from_list__in_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val),
        IdMap.MapsTo nm tp (map_from_list pnds) ->
        List.In (nm, tp) pnds.

    Axiom in_list_no_id_dup__in_map_from_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val),
        List.In (nm, tp) pnds ->
        NoDup (get_ids pnds) ->
        IdMap.MapsTo nm tp (map_from_list pnds).

    Axiom in_ids__in_map_from_list :
      forall (val : Type) (pnds : list (id * val)) (nm : id),
        List.In  nm (get_ids pnds) ->
        IdMap.In nm (map_from_list pnds).

    Axiom map_from_list__find_cons___true :
      forall (val : Type) (nm : id) (tp : val)
             (pnds : list (id * val)),
        ~ List.In nm (get_ids pnds) ->
        IdMap.find nm (map_from_list ((nm, tp) :: pnds)) = Some tp.

    Axiom map_from_list_cons__preserves_mapping :
      forall (val : Type) (pnds : list (id * val))
             (nm nm': id) (tp tp': val),
      IdMap.MapsTo nm tp (map_from_list pnds) ->
      IdMap.MapsTo nm tp (map_from_list ((nm', tp') :: pnds)).

(* ----------------------------------------------------------------- *)
(** *** Props about Length and Cardinal  *)
(* ----------------------------------------------------------------- *)

    Axiom map_from_list__length_cardinal_eq :
      forall (val : Type) (pnds : list (id * val)),
        NoDup (get_ids pnds) ->
        length pnds
        = IdMap.cardinal (elt:=val) (map_from_list pnds).

(* ----------------------------------------------------------------- *)
(** *** Equality of List and Map  *)
(* ----------------------------------------------------------------- *)

    Axiom elem_in_map_eq_length__elem_in_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val) (CT : id_map val),
        Forall
          (fun pnd : id * val =>
             match pnd with
             | (f, T) => IdMap.find f CT = Some T
             end)
          pnds ->
        NoDup (get_ids pnds) ->
        length pnds = IdMap.cardinal (elt:=val) CT ->
        IdMap.MapsTo nm tp CT ->
        List.In (nm, tp) pnds.

    Axiom eq_list_map__same_list__eq_maps :
      forall (val : Type) (ps : list (id * val)) (mp1 mp2 : id_map val),
        eq_list_map ps mp1 ->
        eq_list_map ps mp2 ->
        IdMap.Equal mp1 mp2.

    Axiom eq_list_map_from_list :
      forall (val : Type) (ps : list (id * val)),
        List.NoDup (get_ids ps) ->
        eq_list_map ps (map_from_list ps).

    Axiom eq_list_map__iff :
      forall (val : Type) (ps : list (id * val)) (mp : id_map val),
        eq_list_map ps mp ->
        forall x v,
          List.In (x, v) ps <-> IdMap.MapsTo x v mp.

  End Props.

End ListPair2FMapW.

(* ################################################################# *)
(** ** Module [MListPair2FMapW] (weak interface of [FMap]) *)
(** Transformation of list of pairs into
 ** a weak FMap and its properties. *)
(* ################################################################# *)

Module MListPair2FMapW
       (id_UDTOrig : UsualDecidableTypeOrig)
       (id_Map : FMapInterface.WS
           with Definition E.t := id_UDTOrig.t
           with Definition E.eq := id_UDTOrig.eq)
<: ListPair2FMapW id_UDTOrig id_Map

(* More concrete version below does not work, as, for example,
 * FMapAVL.Make removes information about [eq_equiv]
 * due to opaque typing. *)

(*       (id_Map : FMapInterface.WS with Module E := id_UDTOrig) *)
.

  (** Ordering of ids *)
  Module IdDT := id_UDTOrig.

  (** FMap of ids *)
  Module IdMap := id_Map.

  (** Type of Identificators *)
  Definition id : Type := IdMap.key. (*IdDT.t.*)

  (** Type of Map-of-Identifiers *)
  Definition id_map := IdMap.t.

(* ----------------------------------------------------------------- *)
(** *** Helper Functions *)
(* ----------------------------------------------------------------- *)

  Import IdMap.
  Module HelperFuns.

    Definition map_from_list' {A : Type} (xs : list (id * A))
               (m : id_map A) : id_map A
      := fold_left
           (fun m xv => match xv with (x, v) => add x v m end)
           xs m.
    Hint Unfold map_from_list'.

  End HelperFuns.

(* ================================================================= *)
(** *** Main Functions *)
(* ================================================================= *)

  (** [map_from_list] builds a map [id -> A] from
   ** the list of pairs [id * A]. *)
  Definition map_from_list {A : Type} (xs : list (id * A)) : id_map A
    := HelperFuns.map_from_list' xs (empty A).
  Hint Unfold map_from_list.

  Definition get_ids {A : Type} (ps : list (id * A)) : list id
      := List.map fst ps.

(* ================================================================= *)
(** *** Main Definitions *)
(* ================================================================= *)

  Definition eq_list_map {A : Type} (xs : list (id * A))
             (mp : id_map A) : Prop :=
    (* All ids are unique *)
    List.NoDup (get_ids xs)
    (* Length is the same *)
    /\ List.length xs = IdMap.cardinal mp
    (* Elements are the same *)
    /\ List.Forall
         (fun p => match p with (nm, v) =>
                     IdMap.find nm mp = Some v
                   end)
         xs.
  Hint Unfold eq_list_map.

(* ================================================================= *)
(** *** Properties *)
(* ================================================================= *)

  Module Props.

    Import HelperFuns.

    Module IdMapFacts := FMapFacts.WFacts IdMap.
    Module IdMapProps := FMapFacts.WProperties IdMap.

    Import IdMapFacts.
    Import IdMapProps.

(* ----------------------------------------------------------------- *)
(** *** Helper Properties *)
(* ----------------------------------------------------------------- *)

    Module Helper.

      Lemma map_from_list'_not_in__preserves_mapping :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          IdMap.MapsTo nm tp m ->
          ~ List.In nm (get_ids pnds) ->
          IdMap.MapsTo nm tp (map_from_list' pnds m).
      Proof.
        intros val pnds. induction pnds as [| pnd pnds' IHpnds'].
        - (* pnds = nil *)
          intros nm tp m Hmaps Hnin. simpl. assumption.
        - (* pnds = pnd :: pnds' *)
          intros nm tp m Hmaps Hin.
          unfold map_from_list' in *. simpl. simpl in IHpnds'.
          apply IHpnds'.
          + (* IdMap.MapsTo nm tp (m += pnd) *)
            destruct pnd as [x v]. destruct (IdDT.eq_dec nm x). subst.
            assert (contra: List.In x (List.map fst ((x, v) :: pnds')))
              by (simpl; left; reflexivity).
            apply Hin in contra. contradiction.
            apply IdMap.add_2. intros H. symmetry in H. apply n in H.
            contradiction.
            assumption.
          + (* ~ List.In nm (map fst pnds') *)
            intros H.
            assert (contra: List.In nm (List.map fst (pnd :: pnds')))
              by (simpl; right; assumption).
            apply Hin in contra. contradiction.
      Qed.

      Lemma map_from_list'__cons_new :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          ~ List.In nm (get_ids pnds) ->
          IdMap.MapsTo nm tp (map_from_list' ((nm, tp) :: pnds) m).
      Proof.
        intros pnds nm tp m. intros Hin.
        simpl. apply map_from_list'_not_in__preserves_mapping.
        apply IdMap.add_1. reflexivity.
      Qed.

      Lemma map_from_list'__ignore_list :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          ~ List.In nm (get_ids pnds) ->
          IdMap.MapsTo nm tp (map_from_list' pnds m) ->
          IdMap.MapsTo nm tp m.
      Proof.
        intros val pnds. induction pnds as [|pnd pnds' IHpnds'].
        - intros. simpl in *. assumption.
        - intros nm tp m Hin Hmaps.
          destruct pnd as [x v]. simpl in *.
          assert (Hin' : ~ List.In nm (List.map fst pnds')).
          { unfold not in *. intros contra.
            apply Hin. tauto. }
          specialize (IHpnds' nm tp (add x v m) Hin' Hmaps).
          apply add_mapsto_iff in IHpnds'.
          inversion IHpnds'.
          tauto.
          tauto.
      Qed.

      Lemma map_from_list'__eq_maps :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m m': id_map val),
          IdMap.Equal m' m ->
          IdMap.MapsTo nm tp (map_from_list' pnds m)
          ->
          IdMap.MapsTo nm tp (map_from_list' pnds m').
      Proof.
        intros val pnds. induction pnds as [|pnd pnds' IHpnds'].
        - (* pnds = nil *)
          intros nm tp m m' Heq Hmaps.
          simpl in *.
          eapply Equal_mapsto_iff; eauto.
        - (* pnds = pnd :: pnds' *)
          intros nm tp m m' Heq Hmaps.
          destruct pnd as [x v]; simpl in *.
          eapply IHpnds'.
          assert (H : IdMap.Equal (add x v m') (add x v m)).
          { apply add_m. apply id_UDTOrig.eq_refl.
            reflexivity. assumption. }
          eassumption.
          assumption.
      Qed.

      Lemma permute_add__eq_maps :
        forall (val : Type)
               (nm x : id) (tp v : val) (m : id_map val),
          x <> nm ->
          IdMap.Equal (add x v (add nm tp m))
                      (add nm tp (add x v m)).
      Proof.
        intros val nm x tp v m Hneq.
        apply Equal_mapsto_iff.
        intros k e. split.
        + intros H1.
          apply add_mapsto_iff in H1; propositional.
          unfold id_UDTOrig.eq in *; subst.
          subst. apply add_mapsto_iff.
          right.
          pose proof (IdDT.eq_dec nm k) as Hid.
          inversion Hid. subst. simpl in *.
          assert (contra : k = k) by reflexivity.
          apply Hneq in contra.
          contradiction.
          split; auto.
          apply add_mapsto_iff.
          left. split; auto.
          unfold id_UDTOrig.eq in *; subst. reflexivity.
          apply add_mapsto_iff in H1; propositional.
          subst. apply add_mapsto_iff.
          left. unfold id_UDTOrig.eq in *; subst.
          split; reflexivity.
          apply add_mapsto_iff.
          right. split; auto.
          apply add_mapsto_iff.
          right. split; auto.
        + intros H1.
          apply add_mapsto_iff in H1; propositional;
            unfold id_UDTOrig.eq in *; subst.
          apply add_mapsto_iff.
          right.
          pose proof (IdDT.eq_dec x k) as Hid.
          inversion Hid; unfold id_UDTOrig.eq in *; subst.
          simpl in *.
          assert (contra : k = k) by reflexivity.
          apply Hneq in contra.
          contradiction.
          split; auto.
          apply add_mapsto_iff.
          left. split; auto.
          unfold id_UDTOrig.eq in *; subst. reflexivity.
          apply add_mapsto_iff in H1; propositional.
          subst. apply add_mapsto_iff.
          left. unfold id_UDTOrig.eq in *; subst.
          split; reflexivity.
          apply add_mapsto_iff.
          right. split; auto.
          apply add_mapsto_iff.
          right. split; auto.
      Qed.

      Lemma map_from_list'__ignore_list_add :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          ~ List.In nm (get_ids pnds) ->
          IdMap.MapsTo nm tp (map_from_list' pnds (add nm tp m)).
      Proof.
        intros val pnds. induction pnds as [|pnd pnds' IHpnds'].
        - intros. simpl.
          apply IdMap.add_1. reflexivity.
        - intros nm tp m H.
          destruct pnd as [x v]. simpl.
          apply map_from_list'__eq_maps with
          (m := (add nm tp (add x v m))).
          apply permute_add__eq_maps.
          simpl in H. unfold not. intros contra.
          eapply or_introl in contra.
          apply H in contra. contradiction.
          apply IHpnds'.
          unfold not in *. intros contra.
          assert (H1 : List.In nm (List.map fst ((x, v) :: pnds')))
            by (simpl; right;  assumption).
          tauto.
      Qed.

      Lemma map_from_list'__any_map :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m m' : id_map val),
          List.In nm (get_ids pnds) ->
          IdMap.MapsTo nm tp (map_from_list' pnds m) ->
          IdMap.MapsTo nm tp (map_from_list' pnds m').
      Proof.
        intros val pnds. induction pnds as [|pnd pnds' IHpnds'].
        - (* pnds = nil *)
          intros nm tp m m' Hin (* Hdup *) Hmaps.
          simpl in Hin. contradiction.
        - (* pnds = pnd :: pnds' *)
          intros nm tp m m' Hin (* Hdup *) Hmaps.
          simpl. simpl in Hmaps.
          destruct pnd as [x v].
          pose proof (in_dec IdDT.eq_dec nm (List.map fst pnds')) as Hindec.
          inversion Hindec as [Hinnm | Hinnm].
          + eapply IHpnds'.
            assumption.
            eassumption.
          + simpl in Hin. inversion Hin.
            { subst.
              pose proof (map_from_list'__ignore_list val
                          pnds' nm tp (add nm v m) Hinnm Hmaps) as Hnm.
              apply add_mapsto_iff in Hnm; propositional.
              subst.
              apply map_from_list'__ignore_list_add.
              assumption. }
            tauto.
      Qed.

      Lemma pair_in_map_from_list'__id_in_list' :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          IdMap.MapsTo nm tp (map_from_list' pnds m) ->
          ~ (IdMap.In nm m) ->
          List.In nm (get_ids pnds).
      Proof.
        intros val pnds.
        induction pnds as [| pnd pnds' IHpnds'].
        - intros. simpl in H.
          apply IdMap.find_1 in H.
          assert (Hfind : IdMap.find (elt:=val) nm m <> None).
          equality.
          rewrite <- in_find_iff in Hfind.
          apply H0 in Hfind. contradiction.
        - intros. destruct pnd as [x v].
          simpl in *.
          destruct (IdDT.eq_dec nm x).
          + equality.
          + right.
            apply IHpnds' with (tp := tp) (m := (add x v m)).
            assumption.
            unfold "~". intro Hin.
            rewrite add_in_iff in Hin.
            inversion Hin. equality.
            apply H0 in H1.
            assumption.
      Qed.

      Lemma pair_in_map_from_list'__in_list_or_map :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          IdMap.MapsTo nm tp (map_from_list' pnds m) ->
          IdMap.MapsTo nm tp m \/ List.In (nm, tp) pnds.
      Proof.
        intros val pnds.
        induction pnds as [| pnd pnds' IHpnds'].
        - (* pnds = nil *)
          intros. simpl in *. tauto.
        - (* pnds = pnd :: pnds' *)
          intros. simpl in *.
          destruct pnd as [x v].
          apply IHpnds' in H.
          destruct H as [Hmap | Hlist].
          + rewrite add_mapsto_iff in Hmap.
            propositional.
            unfold id_UDTOrig.eq in *; subst. tauto.
          + tauto.
      Qed.

      Lemma pair_in_map_from_list'__pair_in_list :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          IdMap.MapsTo nm tp (map_from_list' pnds m) ->
          ~ (IdMap.In nm m) ->
          List.In (nm, tp) pnds.
      Proof.
        intros val pnds nm tp m Hmaps Hin.
        apply pair_in_map_from_list'__in_list_or_map in Hmaps.
        destruct Hmaps as [Hmap | Hlist].
        - apply find_1 in Hmap.
          rewrite not_find_in_iff in Hin.
          rewrite Hmap in Hin; inversion Hin.
        - assumption.
      Qed.

      Lemma pair_in_map_from_list'__id_in_list :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val),
          IdMap.MapsTo nm tp (map_from_list' pnds (empty val)) ->
          List.In nm (get_ids pnds).
      Proof.
        intros val pnds nm tp Hmaps.
        apply pair_in_map_from_list'__id_in_list' with (tp := tp) (m := empty val).
        assumption.
        unfold not.
        intros contra. rewrite empty_in_iff in contra.
        assumption.
      Qed.

      Lemma in_list_no_id_dup__in_map_from_list' :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          List.In (nm, tp) pnds ->
          NoDup (get_ids pnds) ->
          IdMap.MapsTo nm tp (map_from_list' pnds m).
      Proof.
        intros val pnds.
        induction pnds as [|pnd pnds' IHpnds'];
          intros; simpl in *.
        - (* pnds = nil *) contradiction.
        - (* pnds = pnd :: pnds' *)
          destruct pnd as [x v].
          destruct H as [Heq | Hin].
          + inversion Heq; subst.
            inversion H0; subst.
            apply map_from_list'__ignore_list_add. assumption.
          + apply IHpnds'. assumption.
            inversion H0. assumption.
      Qed.

      Lemma map_from_list'_preserves_eq :
        forall (val : Type) (pnds : list (id * val))
               (m m' : id_map val),
          IdMap.Equal m m' ->
          IdMap.Equal (map_from_list' pnds m) (map_from_list' pnds m').
      Proof.
        intros val pnds. induction pnds as [|pnd pnds' IHpnds'].
        - (* pnds = nil *)
          intros m m' Heq. simpl.
          assumption.
        - (* pnds = pnd :: pnds' *)
          intros m m' Heq. destruct pnd as [x v].
          simpl.
          apply IHpnds'.
          apply F.add_m; unfold id_UDTOrig.eq in *; subst; tauto.
      Qed.

      Lemma map_from_list_cons_cardinal' :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val) (m : id_map val),
          ~ List.In nm (get_ids pnds) ->
          ~ IdMap.In nm m ->
          IdMap.cardinal (elt:=val) (map_from_list' ((nm, tp) :: pnds) m)
          = S (IdMap.cardinal (elt:=val) (map_from_list' pnds m)).
      Proof.
        intros val pnds. induction pnds as [|pnd pnds' IHpnds'].
        - (* pnds = nil *)
          intros nm tp m Hin Hmap. simpl.
          rewrite <- cardinal_2 with (m' := (add nm tp m))
                                       (x := nm) (e := tp).
          reflexivity.
          assumption.
          unfold Add. intros y.
          reflexivity.
        - (* pnds = pnd :: pnds' *)
          intros nm tp m Hin Hmap. destruct pnd as [x v].
          simpl in *.
          assert (Heq : IdMap.Equal
                          (map_from_list' pnds' (add x v (add nm tp m)))
                          (map_from_list' pnds' (add nm tp (add x v m)))).
          { apply map_from_list'_preserves_eq.
            apply permute_add__eq_maps.
            tauto. }
          rewrite Heq.
          apply IHpnds'.
          tauto.
          unfold not. intros contra.
          rewrite F.add_in_iff in contra.
          inversion contra; tauto.
      Qed.

      Lemma map_from_list_cons_cardinal :
        forall (val : Type) (pnds : list (id * val))
               (nm : id) (tp : val),
          ~ List.In nm (get_ids pnds) ->
          IdMap.cardinal (elt:=val) (map_from_list ((nm, tp) :: pnds))
          = S (IdMap.cardinal (elt:=val) (map_from_list pnds)).
      Proof.
        intros val pnds. induction pnds as [|pnd pnds' IHpnds'].
        - (* pnds = nil *)
          intros nm tp Hin. unfold map_from_list. simpl.
          pose proof (@empty_1 val) as Hem.
          apply cardinal_Empty in Hem.
          assert (Hadd : cardinal (add nm tp (empty val))
                         = S (cardinal (empty val))).
          { apply cardinal_2 with (x := nm) (e := tp).
            intros contra. rewrite F.empty_in_iff in contra.
            contradiction.
            unfold Add. intros y. reflexivity. }
          rewrite Hadd. rewrite Hem. reflexivity.
        - (* pnds = pnd :: pnds' *)
          intros nm tp Hin. destruct pnd as [x v].
          assert
            (Heq : IdMap.cardinal (elt:=val)
                   (map_from_list ((nm, tp) :: (x, v) :: pnds'))
                   = S (IdMap.cardinal (elt:=val) (map_from_list ((x, v) :: pnds')))).
          { change (IdMap.cardinal (elt:=val)
                    (map_from_list' ((nm, tp) :: (x, v) :: pnds') (empty val))
                    =
                    S (IdMap.cardinal (elt:=val)
                       (map_from_list' ((x, v) :: pnds') (empty val)))).
            apply map_from_list_cons_cardinal'.
            assumption.
            unfold not. intros contra.
            rewrite F.empty_in_iff in contra.
            tauto. }
          rewrite Heq.
          unfold map_from_list in *. reflexivity.
      Qed.

      Lemma list_elems_in_map__remove_unused :
        forall (val : Type) (pnds : list (id * val))
               (f : id) (CT CT' : id_map val),
          Forall
            (fun pnd : id * val =>
               match pnd with
               | (f, T) => find f CT = Some T
               end) pnds ->
          ~ List.In f (get_ids pnds) ->
          CT' = IdMap.remove (elt:=val) f CT ->
          Forall
            (fun pnd : id * val =>
               match pnd with
               | (f0, T0) => find f0 CT' = Some T0
               end) pnds.
      Proof.
        intros val pnds. induction pnds as [| pnd pnds' IHpnds' ].
        - (* pnds = nil *)
          intros f CT CT' Htypes Hin Heq.
          constructor.
        - (* pnds = pnd :: pnds' *)
          intros f CT CT' Htypes Hin Heq.
          destruct pnd as [nm tp]. simpl in *.
          inversion Htypes; clear Htypes; subst.
          apply Forall_cons.
          + pose proof (IdDT.eq_dec nm f).
            inversion H.
            { eapply or_introl in H0.
              eapply Hin in H0. contradiction. }
            clear H.
            apply F.find_mapsto_iff.
            apply F.remove_mapsto_iff.
            split. equality.
            apply F.find_mapsto_iff. assumption.
          + apply IHpnds' with (f := f) (CT := CT).
            assumption.
            unfold not. intros contra.
            eapply or_intror in contra.
            apply Hin in contra. contradiction.
            reflexivity.
      Qed.

    End Helper.

(* ================================================================= *)
(** *** Main Properties *)
(* ================================================================= *)

    Theorem map_from_list_nil__cardinal :
      forall (val : Type),
      IdMap.cardinal (@map_from_list val []) = 0.
    Proof.
      intros. unfold map_from_list; simpl.
      apply cardinal_1. apply empty_1.
    Qed.

(* ----------------------------------------------------------------- *)
(** *** Props about List.In and IdMap.In  *)
(* ----------------------------------------------------------------- *)

    Theorem in_map_from_list__id_in_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val),
        IdMap.MapsTo nm tp (map_from_list pnds) ->
        List.In nm (get_ids pnds).
    Proof.
      intros val pnds nm tp H.
      change (MapsTo nm tp (map_from_list' pnds (empty val))) in H.
      apply Helper.pair_in_map_from_list'__id_in_list with (tp := tp).
      assumption.
    Qed.

    Theorem in_map_from_list__in_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val),
        IdMap.MapsTo nm tp (map_from_list pnds) ->
        List.In (nm, tp) pnds.
    Proof.
      intros val pnds nm tp H.
      change (MapsTo nm tp (map_from_list' pnds (empty val))) in H.
      apply Helper.pair_in_map_from_list'__pair_in_list
        with (m := empty val). assumption.
      intros contra. rewrite empty_in_iff in contra.
      contradiction.
    Qed.

    Theorem in_list_no_id_dup__in_map_from_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val),
        List.In (nm, tp) pnds ->
        NoDup (get_ids pnds) ->
        IdMap.MapsTo nm tp (map_from_list pnds).
    Proof.
      intros.
      apply Helper.in_list_no_id_dup__in_map_from_list'; assumption.
    Qed.

    Theorem in_ids__in_map_from_list :
      forall (val : Type) (pnds : list (id * val)) (nm : id),
        List.In  nm (get_ids pnds) ->
        IdMap.In nm (map_from_list pnds).
    Proof.
      intros val pnds.
      induction pnds as [| [n' d'] pnds' IHpnds'].
      - intros. inversion H.
      - intros nm Hnmin.
        simpl in Hnmin. destruct Hnmin as [Hnmin | Hnmin].
        + subst. remember (get_ids pnds') as ids.
          assert (Hdec : {List.In nm ids} + {~ List.In nm ids}).
          { apply List.in_dec. apply IdDT.eq_dec. }
          destruct Hdec as [Hdec | Hdec].
          * specialize (IHpnds' nm Hdec).
            unfold map_from_list. simpl.
            unfold map_from_list in IHpnds'.
            unfold In in *.
            destruct IHpnds' as [v Hmaps].
            exists v.
            apply Helper.map_from_list'__any_map with (empty val).
            subst ids. assumption. assumption.
          * unfold map_from_list.
            unfold In. exists d'.
            apply Helper.map_from_list'__cons_new. subst ids. assumption.
        + specialize (IHpnds' nm Hnmin).
          unfold map_from_list. simpl.
          unfold map_from_list in IHpnds'.
          unfold In in *.
          destruct IHpnds' as [v Hmaps].
          exists v.
          apply Helper.map_from_list'__any_map with (empty val).
          assumption. assumption.
    Qed.

    Theorem map_from_list__find_cons___true :
      forall (val : Type) (nm : id) (tp : val)
             (pnds : list (id * val)),
        ~ List.In nm (get_ids pnds) ->
        find nm (map_from_list ((nm, tp) :: pnds)) = Some tp.
    Proof.
      intros val nm tp pnds. intros Hin.
      apply IdMap.find_1.
      apply Helper.map_from_list'__cons_new. auto.
    Qed.

    Theorem map_from_list_cons__preserves_mapping :
      forall (val : Type) (pnds : list (id * val))
             (nm nm': id) (tp tp': val),
      IdMap.MapsTo nm tp (map_from_list pnds) ->
      IdMap.MapsTo nm tp (map_from_list ((nm', tp') :: pnds)).
    Proof.
      intros val pnds nm nm' tp tp' H.
      change (IdMap.MapsTo nm tp
             (map_from_list' ((nm', tp') :: pnds) (IdMap.empty val))).
      change (IdMap.MapsTo nm tp
             (map_from_list' pnds (IdMap.empty val))) in H.
      simpl.
      apply Helper.map_from_list'__any_map with (m := IdMap.empty val).
      apply Helper.pair_in_map_from_list'__id_in_list with (tp := tp).
      assumption. assumption.
    Qed.

(* ----------------------------------------------------------------- *)
(** *** Props about Length and Cardinal  *)
(* ----------------------------------------------------------------- *)

    Theorem map_from_list__length_cardinal_eq :
      forall (val : Type) (pnds : list (id * val)),
        NoDup (get_ids pnds) ->
        length pnds
        = IdMap.cardinal (elt:=val) (map_from_list pnds).
    Proof.
      intros val pnds Hdup.
      induction pnds as [| pnd pnds' IHpnds'].
      - (* nil *)
        unfold map_from_list; simpl.
        symmetry. apply cardinal_1. apply empty_1.
      - (* pnds = pnd :: pnds' *)
        destruct pnd as [nm tp]. simpl.
        rewrite Helper.map_from_list_cons_cardinal.
        apply f_equal.
        apply IHpnds'.
        inversion Hdup; tauto.
        inversion Hdup; tauto.
    Qed.

(* ----------------------------------------------------------------- *)
(** *** Equality of List and Map  *)
(* ----------------------------------------------------------------- *)

    Theorem elem_in_map_eq_length__elem_in_list :
      forall (val : Type) (pnds : list (id * val))
             (nm : id) (tp : val) (CT : id_map val),
        Forall
          (fun pnd : id * val =>
             match pnd with
             | (f, T) => find f CT = Some T
             end)
          pnds ->
        NoDup (get_ids pnds) ->
        length pnds = IdMap.cardinal (elt:=val) CT ->
        IdMap.MapsTo nm tp CT ->
        List.In (nm, tp) pnds.
    Proof.
      intros val pnds. induction pnds as [| pnd pnds' IHpnds' ].
      - (* npds = nil *)
        intros nm tp CT Htypes Hdup Hcard Hmaps. simpl in *.
        symmetry in Hcard. apply cardinal_Empty in Hcard.
        unfold IdMap.Empty in *.
        apply Hcard in Hmaps; contradiction.
      - (* pnds = pnd :: pnds' *)
        intros nm tp CT Htypes Hdup Hcard Hmaps.
        inversion Htypes; subst; simpl in *. clear Htypes.
        destruct pnd as [f T].
        simpl in Hdup. inversion Hdup. subst.
        assert (Hfind := Hmaps).
        rewrite (F.find_mapsto_iff CT nm tp) in Hfind.
        pose proof (IdDT.eq_dec f nm).
        inversion H; clear H.
        + subst.
          rewrite -> H1 in Hfind. inversion Hfind.
          left; trivial.
        + right.
          (* To apply IH, we need smaller map *)
          remember (IdMap.remove f CT) as CT'.
          apply IHpnds' with (CT := CT').
          subst CT'.
          apply Helper.list_elems_in_map__remove_unused
          with (f := f) (CT := CT); trivial.
          assumption.
          assert (Hnotin : ~ IdMap.In f CT').
          { subst. intros contra.
            apply F.remove_in_iff in contra.
            inversion contra; unfold id_UDTOrig.eq in *; subst; tauto. }
          assert (Hcard' : IdMap.cardinal (elt:=val) CT
                           = S (IdMap.cardinal (elt:=val) CT')).
          { apply cardinal_2 with (x := f) (e := T).
            assumption. unfold Add. subst.
            intros y.
            pose proof (IdDT.eq_dec f y) as Hyf. inversion Hyf.
            subst.
            rewrite H1.
            rewrite (F.add_eq_o _ _ (eq_refl y)). reflexivity.
            rewrite (F.add_neq_o _ _ H).
            symmetry. apply F.remove_neq_o. assumption. }
          rewrite <- Hcard in Hcard'.
          inversion Hcard'. reflexivity.
          subst. apply F.remove_neq_mapsto_iff. assumption. assumption.
    Qed.

    Theorem eq_list_map__same_list__eq_maps :
      forall (val : Type) (ps : list (id * val)) (mp1 mp2 : id_map val),
        eq_list_map ps mp1 ->
        eq_list_map ps mp2 ->
        IdMap.Equal mp1 mp2.
    Proof.
      intros val ps mp1 mp2.
      unfold eq_list_map.
      intros [Hdup [Hlen1 Hfind1]] [_ [Hlen2 Hfind2]].
      apply Equal_mapsto_iff.
      intros k v. split; intros Hmaps.
      - (* 1 -> 2 *)
        pose proof (elem_in_map_eq_length__elem_in_list
                      val ps k v mp1 Hfind1 Hdup Hlen1 Hmaps) as Hin.
        assert (Hmp2 := Hfind2).
        rewrite Forall_forall in Hmp2.
        specialize (Hmp2 (k, v) Hin). simpl in Hmp2.
        apply IdMapProps.F.find_mapsto_iff.
        assumption.
      - (* 2 -> 1 *)
        pose proof (elem_in_map_eq_length__elem_in_list
                      val ps k v mp2 Hfind2 Hdup Hlen2 Hmaps) as Hin.
        assert (Hmp1 := Hfind1).
        rewrite Forall_forall in Hmp1.
        specialize (Hmp1 (k, v) Hin). simpl in Hmp1.
        apply IdMapProps.F.find_mapsto_iff.
        assumption.
    Qed.

    Theorem eq_list_map_from_list :
      forall (val : Type) (ps : list (id * val)),
        List.NoDup (get_ids ps) ->
        eq_list_map ps (map_from_list ps).
    Proof.
      intros val ps.
      induction ps as [| p ps' IHps'];
        unfold eq_list_map;
        intros Hdup.
      - (* ps = nil *)
        propositional; simplify.
        symmetry. apply map_from_list_nil__cardinal.
        constructor.
      - (* ps = p :: ps' *)
        propositional; destruct p as [nm v];
        inversion Hdup; subst;
        specialize (IHps' H2); unfold eq_list_map in IHps'.
        + simpl in *.
          pose proof (Helper.map_from_list_cons_cardinal val ps' nm v H1)
            as Hcard.
          rewrite Hcard. apply f_equal.
          propositional.
        + inversion Hdup; subst.
          constructor.
          * apply map_from_list__find_cons___true.
            assumption.
          * propositional.
            apply Forall_impl with
            (P := fun p : key * val =>
                  let (nm, v) := p in find nm (map_from_list ps') = Some v).
            (* cons *)
            intros [nm' v'] Hfind.
            apply IdMap.find_2 in Hfind.
            apply IdMap.find_1.
            apply map_from_list_cons__preserves_mapping. assumption.
            (* rec case *)
            assumption.
    Qed.

    Theorem eq_list_map__iff :
      forall (val : Type) (ps : list (id * val)) (mp : id_map val),
        eq_list_map ps mp ->
        forall x v,
          List.In (x, v) ps <-> IdMap.MapsTo x v mp.
      Proof.
        intros val ps mp Heq.
        unfold eq_list_map in Heq.
        destruct Heq as [Hnodup [Hlen Hforall]].
        intros x v.
        split.
        - (* List.In -> MapsTo *)
          rewrite Forall_forall in Hforall.
          specialize (Hforall (x, v)).
          intros Hin. specialize (Hforall Hin).
          simpl in Hforall. apply F.find_mapsto_iff. assumption.
        - (* MapsTo *)
          intros Hmaps.
          apply elem_in_map_eq_length__elem_in_list with mp;
            try assumption.
      Qed.

  End Props.

End MListPair2FMapW.

(* ################################################################# *)
(** ** Module for [MListPair2MapAVL] *)
(* ################################################################# *)

Module MListPair2FMapAVL (id_UOTOrig : UsualOrderedTypeOrig).
  Module IdMapAVL := FMapAVL.Make id_UOTOrig.
  Module M := MListPair2FMapW id_UOTOrig IdMapAVL.
End MListPair2FMapAVL.


(** ** Common Definitions for Operator Overloading *)

Definition SuchThat(R: Type)(P: R -> Prop) := R.
Existing Class SuchThat.

Notation "'annotate!' x T" := (match x return T with b => b end)
  (at level 10, x at level 0, T at level 0, only parsing).

Notation "'infer!' P" :=
  (match _ as ResType return ResType with
   | ResType =>
       match P with
       | Fun => annotate! (annotate! _ (SuchThat ResType Fun)) ResType
       end
   end)
  (at level 0, P at level 100, only parsing).

Global Hint Extern 1 (SuchThat ?RRef ?FRef) =>
  let R := eval cbv delta [RRef] in RRef in
  let r := open_constr:(_ : R) in
  let G := eval cbv beta delta [RRef FRef] in (FRef r) in
  let t := open_constr:(ltac:(cbv beta; typeclasses eauto) : G) in
  match r with
  | ?y => exact y (* match gets rid of type annotation *)
  end
: typeclass_instances.

Declare Scope oo_scope. (* Operator-overloading notation scope *)

(* syntactic reflexivity, for tests *)
Ltac srefl :=
  lazymatch goal with
  | |- ?x = ?y => constr_eq x y; reflexivity
  end.

(** ** Definition of Overloadable Operators *)

(* In most cases, A=B=R, but for pair types like (nat * Type), we'd get a universe
   inconsistency (while (Type * nat) works), and it might also be useful to allow
   eg A=Z, B=nat, C=Z and have the hints insert a coercion from nat to Z. *)
Class Multiplication{A B R: Type}(a: A)(b: B)(r: R) := {}.
(* Note: a and b are not really outputs, but we still mark them as outputs so that
   (@Multiplication Z Z _ ?evar1 ?evar2 _) can be resolved with (Z.mul ?evar1 ?evar2) *)
Global Hint Mode Multiplication ! ! - - - - : typeclass_instances.
Notation "a * b" := (infer! Multiplication a b) (only parsing) : oo_scope.

Class Addition{A B R: Type}(a: A)(b: B)(r: R) := {}.
Global Hint Mode Addition ! ! - - - - : typeclass_instances.
Notation "a + b" := (infer! Addition a b) (only parsing) : oo_scope.

Class Subtraction{A B R: Type}(a: A)(b: B)(r: R) := {}.
Global Hint Mode Subtraction ! ! - - - - : typeclass_instances.
Notation "a - b" := (infer! Subtraction a b) (only parsing) : oo_scope.

Class Division{A B R: Type}(a: A)(b: B)(r: R) := {}.
Global Hint Mode Division ! ! - - - - : typeclass_instances.
Notation "a / b" := (infer! Division a b) (only parsing) : oo_scope.

Notation "a =? b" := (infer! BoolSpec (a = b) (a <> b))
  (at level 70, only parsing) : oo_scope.

Class BracketGet{A B C: Type}(a: A)(b: B)(c: C) := {}.
Global Hint Mode BracketGet ! ! - - - - : typeclass_instances.
Notation "a [ i ]" := (infer! (BracketGet a i))
  (at level 8, i at level 99, left associativity, only parsing) : oo_scope.

Class BracketSet{R1 R2 Key Value: Type}(r1: R1)(k: Key)(v: Value)(r2: R2) := {}.
Global Hint Mode BracketSet ! - ! + ! ! + - : typeclass_instances.
Notation "a [ i := v ]" := (infer! (BracketSet a i v))
  (at level 8, i at level 99, left associativity, only parsing) : oo_scope.

Class BracketUpdate{R1 R2 K V1 V2: Type}(r1: R1)(k: K)(f: V1 -> V2)(r2: R2) := {}.
Global Hint Mode BracketUpdate ! - ! + + + ! + - : typeclass_instances.
Notation "a [ i ::= f ]" := (infer! (BracketUpdate a i f))
  (at level 8, i at level 99, left associativity, only parsing) : oo_scope.

(* List literal notations from standard library don't work any more, so we use [| ... |].
   Note, though, that this breaks parsing of Ltac like `tac1; [tac2|]`, and separating
   the bracket and bar into two tokens would bring the notation in conflict with
   BracketGet/Set/Update again. *)
Notation "[| x |]" := (cons x nil) (format "[|  x  |]"): oo_scope.
Notation "[| x ; y ; .. ; z |]" :=
  (cons x (cons y .. (cons z nil) .. )) (format "[|  x ;  y ;  .. ;  z  |]") : oo_scope.

(* since list_scope should not be opened when using oo_scope, we add ++ to oo_scope: *)
Infix "++" := Coq.Init.Datatypes.app : oo_scope.

Goal True /\ True.
  split; [ |exact I]. (* space between [ and | is required *)
Abort.

(** ** Common arithmetic operator instances *)

Require Import Coq.ZArith.ZArith.
Require Import coqutil.Map.Interface.
Require Import coqutil.Word.Interface.

#[export] Instance MulNat(a b: nat): Multiplication a b (Nat.mul a b) := {}.
Notation "a * b" := (Nat.mul a b) (only printing) : oo_scope.

#[export] Instance MulN(a b: N): Multiplication a b (N.mul a b) := {}.
Notation "a * b" := (N.mul a b) (only printing) : oo_scope.

#[export] Instance MulZ(a b: Z): Multiplication a b (Z.mul a b) := {}.
Notation "a * b" := (Z.mul a b) (only printing) : oo_scope.

#[export] Instance MulTypeType(a b: Type): Multiplication a b (prod a b) := {}.
#[export] Instance MulTypeSet(a: Type)(b: Set): Multiplication a b (prod a b) := {}.
#[export] Instance MulSetType(a: Set)(b: Type): Multiplication a b (prod a b) := {}.
#[export] Instance MulSetSetSet(a: Set)(b: Set):
  @Multiplication Set Set Set a b (prod a b) | 5 := {}.
#[export] Instance MulSetSetType(a: Set)(b: Set):
  @Multiplication Set Set Type a b (prod a b) | 6 := {}.
Notation "a * b" := (prod a b) (only printing) : oo_scope.

#[export] Instance MulWord{width: Z}{word: word.word width}(a b: word):
  Multiplication a b (word.mul a b) := {}.
Notation "a * b" := (word.mul a b) (only printing) : oo_scope.

#[export] Instance AddNat(a b: nat): Addition a b (Nat.add a b) := {}.
Notation "a + b" := (Nat.add a b) (only printing) : oo_scope.

#[export] Instance AddN(a b: N): Addition a b (N.add a b) := {}.
Notation "a + b" := (N.add a b) (only printing) : oo_scope.

#[export] Instance AddZ(a b: Z): Addition a b (Z.add a b) := {}.
Notation "a + b" := (Z.add a b) (only printing) : oo_scope.

#[export] Instance AddWord{width: Z}{word: word.word width}(a b: word):
  Addition a b (word.add a b) := {}.
Notation "a + b" := (word.add a b) (only printing) : oo_scope.

#[export] Instance SubNat(a b: nat): Subtraction a b (Nat.sub a b) := {}.
Notation "a - b" := (Nat.sub a b) (only printing) : oo_scope.

#[export] Instance SubN(a b: N): Subtraction a b (N.sub a b) := {}.
Notation "a - b" := (N.sub a b) (only printing) : oo_scope.

#[export] Instance SubZ(a b: Z): Subtraction a b (Z.sub a b) := {}.
Notation "a - b" := (Z.sub a b) (only printing) : oo_scope.

#[export] Instance SubWord{width: Z}{word: word.word width}(a b: word):
  Subtraction a b (word.sub a b) := {}.
Notation "a - b" := (word.sub a b) (only printing) : oo_scope.

#[export] Instance DivNat(a b: nat): Division a b (Nat.div a b) := {}.
Notation "a / b" := (Nat.div a b) (only printing) : oo_scope.

#[export] Instance DivN(a b: N): Division a b (N.div a b) := {}.
Notation "a / b" := (N.div a b) (only printing) : oo_scope.

#[export] Instance DivZ(a b: Z): Division a b (Z.div a b) := {}.
Notation "a / b" := (Z.div a b) (only printing) : oo_scope.

(* No division on word for the moment because we'd have to decide between
   signed or unsigned division *)

Require Import coqutil.Decidable. (* already defines several BoolSpec instances *)
Notation "a =? b" := (Nat.eqb a b) (only printing) : oo_scope.
Notation "a =? b" := (Byte.eqb a b) (only printing) : oo_scope.
Notation "a =? b" := (N.eqb a b) (only printing) : oo_scope.
Notation "a =? b" := (Z.eqb a b) (only printing) : oo_scope.

Section TestArith.
  (* Note: this one works by using the notation from nat_scope, which is open by default *)
  Goal forall (x y z: nat), x * y * z = Nat.mul (Nat.mul x y) z. intros. srefl. Abort.

  Local Open Scope bool_scope.
  Local Open Scope oo_scope.
  Local Set Printing Implicit.
  Local Set Printing Coercions.

  Goal Some (fun (m n: nat) => Some (m * n)) <> None. Abort.

  Goal Some (fun (m n: N) => m * n) <> None. Abort.

  Goal Some (forall (x y z: nat), x * y * z = Nat.mul (Nat.mul x y) z) <> None. Abort.

  Goal forall (m1 m2: nat) (n1 n2: N) (z1 z2: Z) (b1 b2: Byte.byte),
      (m1 =? m2) && (n1 =? n2) && (z1 =? z2) && (b1 =? b2) = false.
  Abort.

  Goal forall (m n: N), m * n = N.mul m n. intros. srefl. Abort.

  Goal forall (x y: N), x * y = N.mul x y. intros. srefl. Abort.

  Goal forall (x y z: nat), x * y * z = Nat.mul (Nat.mul x y) z. intros. srefl. Abort.
  Goal forall (x y: N), x * y = N.mul x y. intros. srefl. Abort.
  Goal forall (x y z: N), x * y * z = N.mul (N.mul x y) z. intros. srefl. Abort.
  Goal forall (w x y z: N), w * (x * y) * z = N.mul (N.mul w (N.mul x y)) z.
    intros. srefl.
  Abort.
  Goal forall (x: N), False.
    intros.
    assert_fails (pose (1%nat * x)).
    epose (x * (_ : N)).
    epose ((_ : N) * x).
    epose ((_ : N) * (_ : N) * (_ : N)).
    epose (x * (_ : N) * (_ : N)).
    epose ((_ : N) * x * (_ : N)).
    epose ((_ : N) * (_ : N) * x).
    epose (Some ((_: N) * (_: N))).
    epose (_ * x). (* doesn't infer the operator, but succeeds with (SuchThat ...) type *)
  Abort.

  Goal forall (x y: Z), x * y = y * x. intros. apply Z.mul_comm. Abort.
  Goal forall (x y z: Z), x * (y * z) = x * y * z. intros. apply Z.mul_assoc. Abort.

  Goal nat * Z = prod nat Z. srefl. Abort.
  Goal nat * Type = prod nat Type. srefl. Abort.
  Goal Type * nat = prod Type nat. srefl. Abort.
  Goal nat * Type * Set = prod (prod nat Type) Set. srefl. Abort.

  Context {word: word.word 32} {mem: map.map word Byte.byte}.

  Goal forall (x y: word), x * y = word.mul x y. intros. srefl. Abort.
  Goal forall (x y z: word), x * y * z = word.mul (word.mul x y) z.
    intros. srefl.
  Abort.

  Goal forall (x y z: word), Some (x * y * z) <> None. Abort.
  Goal forall (x y z: word), Some (x + y * z - x) = Some (x + (y * z) - x).
    intros. srefl.
  Abort.

  Goal forall (x y z: word) (a b: Z), False.
    intros.
    epose (cons (x * y) nil).
    epose (Some (x * y - z)).
    epose (cons (x * y) nil).
    epose (cons (y - z) nil).
    epose (x * y - z).
    epose (cons (x * y - z) nil).
    epose ((x * y) 1). (* works, but shelves unsatisfiable typeclass goals *)
    epose (cons (x * y - z) nil).
    epose (cons (x * y - z) (cons (word.of_Z (a - b))
                                   (cons (y + z * (word.of_Z (a * b))) nil))).
  Abort.
End TestArith.

(** ** Data access instances for records *)

(* Given a label l (field name) and a type R, returns a getter that
   projects l out of R *)
Class Getter{Label: Type}(l: Label)(R E: Type) :=
  get: R -> E.
Arguments get {Label} l {R E} {Getter} r.

(* Label, l, R are inputs, E is an output of typeclass search.
   For Label and label, we use `!` instead of `+` to require that just the
   head is not an evar, so that getters of parameterized records whose parameters
   are evars are allowed.
   For R, we conservatively choose `+`, but might relax it to `!` later. *)
Global Hint Mode Getter ! ! + - : typeclass_instances.

#[export]
Instance BracketGetFromGetter{R Label E: Type}(r: R)(label: Label){g: Getter label R E}:
  @BracketGet R Label E r label (@get Label label R E g r) := {}.
Notation "r [ label ]" := (get label r)
  (at level 8, label at level 99, left associativity, only printing) : oo_scope.

(* Given a key k (field name) and a type R1, returns an updater that applies
   a transformation function (of type V1 -> V2) to field k of R1.
   Usually V1=V2 and R1=R2, but some transformers might return a different V2
   than the V1 returned by the getter, which might change the container type
   from R1 to R2.
   Usually, k is a getter of R1, so K = R1->V1, but it might also be a getter
   of a superclass of R1, in which case K = Superclass->V1 *)
Class Updater{K: Type}(k: K)(R1 R2 V1 V2: Type) :=
  update: (V1 -> V2) -> R1 -> R2.
Arguments update {K} k {R1 R2 V1 V2} {Updater}.

(* For K and k, we use `!` instead of `+` to require that just the
   head is not an evar, so that getters of parameterized records whose parameters
   are evars are allowed. *)
Global Hint Mode Updater ! ! + - - - : typeclass_instances.

#[export] Instance BracketUpdateFromUpdater{R1 R2 Label V1 V2: Type}
 (r1: R1)(label: Label)(f: V1 -> V2){u: @Updater Label label R1 R2 V1 V2}:
  @BracketUpdate R1 R2 Label V1 V2 r1 label f (@update Label label R1 R2 V1 V2 u f r1) := {}.
Notation "r [ label ::= f ]" := (update label f r)
  (at level 8, label at level 99, left associativity,
   format "r [ label  ::=  f ]", only printing) : oo_scope.

Require Coq.Program.Basics.

#[export] Instance BracketSetFromUpdater{R1 R2 Label V1 V2: Type}
 (r1: R1)(label: Label)(v: V2){u: @Updater Label label R1 R2 V1 V2}:
  @BracketSet R1 R2 Label V2 r1 label v
              (@update Label label R1 R2 V1 V2 u (Basics.const v) r1) := {}.
Notation "r [ label := v ]" := (update label (Basics.const v) r)
  (at level 8, label at level 99, left associativity,
   format "r [ label  :=  v ]", only printing) : oo_scope.

(* Automatically deriving Updater instances for records *)

Ltac eta X :=
  let s := constr:(ltac:(
        let x := fresh "x" in
        intro x; unshelve eexists;
        [ unshelve econstructor; destruct x | destruct x; reflexivity ])
    : forall x : X, { x' : X | x' = x }) in
  lazymatch s with
  (* `eval cbv beta` would get rid of superfluous eta expansions in each branch that
     were created by `destruct`, but we commment it out because `cbv beta` is called
     again in `setter` *)
  | fun x => exist _ (@?w x) _ => (* eval cbv beta in *) w
  end.

Ltac head t :=
  lazymatch t with
  | ?f _ => head f
  | _ => t
  end.

(* needed for "strong updates" where the type of a field changes, which requires
   changing the corresponding type parameter, so we replace all type parameters
   by underscores, so that they get reinferred *)
Ltac replace_type_args_by_underscores t :=
  (* t is an application of a constructor to a list of arguments, each of which
     either is a type, or an unfolded getter applied to the original record (match) *)
  lazymatch t with
  | ?f ?arg =>
      let f' := replace_type_args_by_underscores f in
      lazymatch arg with
      | match _ with _ => _ end => uconstr:(f' arg) (* arg is an applied getter: keep *)
      | _ => uconstr:(f' _) (* arg is a type: replace by _ so that it's reinferred *)
      end
  | _ => t
  end.

Ltac replace_arg t oldArg newArg :=
  lazymatch t with
  | ?f oldArg => let f' := replace_type_args_by_underscores f in uconstr:(f' newArg)
  | ?f ?a => let f' := replace_arg f oldArg newArg in uconstr:(f' a)
  end.

Ltac derive_record_setter :=
  lazymatch goal with
  | |- @Updater (?R1 -> ?V1) ?getter ?R1 ?R2 ?V1 ?V2 =>
      (* Note: this goal is convertible to `(V1 -> V2) -> R1 -> R2` *)
      let updateV := fresh "updateV" in
      let r := fresh "r" in
      intros updateV r;
      let h := head getter in
      let oldV := eval cbv beta delta [h] in (getter r) in
      let etaR := eta R1 in
      let b := eval cbv beta in (etaR r) in
      let b' := replace_arg b oldV (updateV oldV) in
      exact b'
  end.

Global Hint Extern 5 (@Updater (?R1 -> ?V1) ?getter ?R1' ?R2 ?V1' ?V2) =>
  (* unify is needed if record type takes parameters, because then, the type
     of getter is (Record ?Param -> something maybe depending on ?Param),
     whereas R1' and V1' might be concrete, or different evars *)
  unify R1 R1';
  unify V1 V1';
  derive_record_setter : typeclass_instances.

(* Used to mark A as a subclass of B in order to lift operations of B to A *)
Class Subclass(A B: Type) := {
  coerce: A -> B;
  lift: (B -> B) -> A -> A;
}.

(* `Subclass A B` could be defined for any A that contains a B, but you should
   only define it if you want all getters/setters that apply to B to become also
   applicable to A. Therefore, the following is a Definition rather than an Instance: *)
Definition declare_subclass{Label: Type}(l: Label)(A B: Type)
           {g: Getter l A B}{s: Updater l A A B B}: Subclass A B := {|
  coerce := get l;
  lift := update l;
|}.

#[export] Instance SubGetter{Label: Type}(l: Label)(ROuter RInner E: Type)
         {sub: Subclass ROuter RInner}{getter: Getter l RInner E}: Getter l ROuter E :=
  fun (r: ROuter) => get l (coerce r).

#[export] Instance SubUpdater{Label: Type}(l: Label)(RInner ROuter E: Type)
                            {sub: Subclass ROuter RInner}{u: Updater l RInner RInner E E}
  : Updater l ROuter ROuter E E := fun (f: E -> E) => lift (update l f).

(* If the label is of type (R -> _), it's a projection that we can use as a getter: *)
Global Hint Extern 1 (@Getter (?R -> _) ?label ?R' _) =>
  let h := head R in
  let h' := head R' in
  constr_eq h h';
  unify R R';
  exact label
: typeclass_instances.

(** ** Data access instances for lists *)

Require Import coqutil.Datatypes.Inhabited.
Require Coq.Lists.List coqutil.Datatypes.List.

#[export] Instance BracketGetInList{A: Type}{inh: inhabited A}(l: list A)(i: nat):
  @BracketGet (list A) nat A l i (List.nth i l default) := {}.
Notation "a [ i ]" := (List.nth i a default)
  (at level 8, i at level 99, left associativity, format "a [ i ]", only printing)
: oo_scope.

(* setting a single element in a list *)
#[export] Instance BracketSetInList{A: Type}(l: list A)(i: nat)(x: A):
  @BracketSet (list A) (list A) nat A l i x (List.upd l i x) := {}.
Notation "l [ i := x ]" := (List.upd l i x)
  (at level 8, i at level 99, left associativity,
   format "l [ i  :=  x ]", only printing) : oo_scope.

(* setting multiple elements in a list (disambiguation is type-based) *)
#[export] Instance BracketSetListInList{A: Type}(l: list A)(i: nat)(xs: list A):
  @BracketSet (list A) (list A) nat (list A) l i xs (List.upds l i xs) := {}.
Notation "l [ i := xs ]" := (List.upds l i xs)
  (at level 8, i at level 99, left associativity,
   format "l [ i  :=  xs ]", only printing) : oo_scope.

(** ** Data access instances for maps *)

#[export] Instance BracketGetInMap{K V: Type}{M: map.map K V}(k: K)(m: M):
  @BracketGet (@map.rep K V M) K (option V) m k (@map.get K V M m k) := {}.
Notation "m [ k ]" := (map.get m k)
  (at level 8, k at level 99, left associativity, format "m [ k ]", only printing)
: oo_scope.

#[export] Instance BracketSetInMap{K V: Type}{M: map.map K V}(k: K)(v: V)(m: M):
  @BracketSet (@map.rep K V M) (@map.rep K V M) K V m k v (@map.put K V M m k v) := {}.
Notation "m [ k := v ]" := (map.put m k v)
  (at level 8, k at level 99, left associativity,
   format "m [ k  :=  v ]", only printing) : oo_scope.

Module TestDataAccess.

  Record foo(A: Type)(n: nat) := {
    fieldA: A;
    fieldB: n = n;
    fieldC: bool;
  }.

  Record bar := {
    fieldD: bool;
    fieldE: foo nat 2;
  }.

  Arguments fieldA {_ _}.
  Arguments fieldB {_ _}.
  Arguments fieldC {_ _}.

  Example testFoo(b: bool): foo nat 2 :=
    {| fieldA := 3; fieldB := eq_refl; fieldC := b |}.

  Local Open Scope oo_scope.

  (* Set Printing Implicit. *)

  Goal forall f: foo nat 1, Some (f[fieldA := 2]) <> None. Abort.

  Goal forall f: foo nat 1, f[fieldA := 2] = f[fieldA := 2]. Abort.

  Goal forall b,
      (testFoo b)[fieldA := 2] = {| fieldA := 2; fieldB := eq_refl; fieldC := b |}.
  Proof. intros. reflexivity. Abort.

  Goal forall b, (testFoo b)[fieldA] = 3. intros. reflexivity. Qed.

  Goal forall b, (testFoo b)[fieldA := 3][fieldA] = 3. intros. reflexivity. Qed.

  (*
  Check _[S := 3].
  Check (testFoo true)[S := 3].
  Fail Goal forall (g: foo nat 2 -> nat), (testFoo true)[g := 3] = testFoo true.
  *)

  Goal forall b,
      (testFoo b)[fieldC := true][fieldC := false][fieldA ::= Nat.add 2] =
      (testFoo b)[fieldA ::= Nat.add 1][fieldC := false][fieldA ::= Nat.add 1].
  Proof.
    intros. unfold update. unfold Basics.const. cbn. srefl.
  Qed.

  Goal forall r: foo (foo nat 4) 2,
      r[fieldA := r[fieldA][fieldA ::= Nat.add 1]][fieldA][fieldA] = S r[fieldA][fieldA].
  Proof. intros. reflexivity. Qed.

  Goal forall f: foo bool 1, fieldA f[fieldC ::= andb true] = fieldA f.
  Proof. intros. reflexivity. Qed.

  (* test cases from coq-record-update: *)
  Module SimpleExample.

    Record X := mkX { A: nat; B: nat; C: unit }.

    Definition setAB(a b: nat)(x: X) := x[A := a][B := b].
    Definition updateAB(a b: nat)(x: X) := x[A ::= plus a][B ::= minus b].
  End SimpleExample.

  Module IndexedType.
    Record X {T} := mkX { A: T; B: T; C: unit }.
    Arguments X T : clear implicits.

    Definition setAB T (a b: T) (x: X T) := x [A := a] [B := b].
  End IndexedType.

  Module DependentExample.
    Record X := mkX { T: Type; A: T; B: nat }.

    Definition setB(b: nat)(x: X) := x[B := b].
    (* setting A, whose type depends on a field in X, is not supported yet *)
    (* Definition setA(x: X)(a: T x) := x[A := a]. *)
  End DependentExample.

(*
  Module NestedExample.
    Record C := mkC { n : nat }.
    Record B := mkB { c : C }.
    Record A := mkA { b : B }.

    Definition setNested n' x := x [ b; c; n := n' ].
    Definition updNested f x := x [ b; c; n ::= f ].
  End NestedExample.
*)

  Module SubclassExample.
    Record A := mkA { n: nat }.
    Record A' := mkA' { a: A; m: nat }.

    Local Instance A_sub_A': Subclass A' A := declare_subclass a A' A.

    Definition get_n(x: A'): nat := x[n].
    Definition set_n(x: A')(v: nat): A' := x[n := v].
  End SubclassExample.

  Module TypeParameterExample.
    Record X T := mkX { a: nat; b: T; c: T * T; }.
    Arguments a {T}.
    Arguments b {T}.
    Arguments c {T}.

    Definition set_a (x: X unit) := x[a := 3].
    Definition set_b (x: X unit) := x[b := tt].
    Definition set_b' {T} (x:X T) (v:T) := x[b := v].
    Definition set_c {T} (x:X T) (v:T) := x[c := (v,v)].
  End TypeParameterExample.

  Module TypeParameterChanges.
    Set Implicit Arguments.

    Record X T := mkX { a: nat; b: T; }.
    Arguments a {T}.
    Arguments b {T}.

    Definition set_a (x:X unit) := x[a := 3].
    Definition set_b {T} (x:X T) (v:T) := x[b := v].

    (* type of record changes from `X T1` to `X T2` *)
    Definition strong_update_to_b{T1 T2}(x: X T1)(v: T2): X T2 := x[b := v].
  End TypeParameterChanges.

  Section Tests.
    Context (A: Type) {inh: inhabited A} (xs ys zs: list A) (a b c: A) (i j k: nat)
            (f: A -> A) (g: list A -> list A).

    Goal xs[i] = ys[j]. Abort.
    Goal [| a; b |] = [| b; a |]. Abort.
    Goal [| f a; b |] = [| b; a |]. Abort.
    Goal g nil = nil. Abort.
    Goal g [| f a; b |] = [| b; a |]. Abort.
    Goal g [| a |] = [| xs[i] |]. Abort.

    Goal (g [| a |])[0] = b.  Abort.
  End Tests.
End TestDataAccess.

(* TODO notations for nested updates

Notation "a [ i , j := v ]" := (update i (set j v) a)
  (at level 10, i at level 99, j at level 99, v at level 99,
   left associativity, format "a [ i ,  j  :=  v ]")
    : oo_scope.

Notation "a [ i , j , k := v ]" := (update i (update j (set k v)) a)
  (at level 10, i at level 99, j at level 99, k at level 99, v at level 99,
   left associativity, format "a [ i ,  j ,  k  :=  v ]")
    : oo_scope.

Notation "a [ i , j1 , .. , jn , k := v ]" :=
  (update i (update j1 .. (update jn (set k v)) ..) a)
  (at level 10, i at level 99, j1 at level 99, jn at level 99, k at level 99, v at level 99,
      left associativity, format "a [ i ,  j1 ,  .. ,  jn ,  k  :=  v ]")
    : oo_scope.
*)


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

(** * BigQ: an efficient implementation of rational numbers *)

(** Initial authors: Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)

Require Export BigZ.
Require Import Field Qfield QSig QMake Orders GenericMinMax.

(** We choose for BigQ an implemention with
    multiple representation of 0: 0, 1/0, 2/0 etc.
    See [QMake.v] *)

(** First, we provide translations functions between [BigN] and [BigZ] *)

Module BigN_BigZ <: NType_ZType BigN.BigN BigZ.
 Definition Z_of_N := BigZ.Pos.
 Lemma spec_Z_of_N : forall n, BigZ.to_Z (Z_of_N n) = BigN.to_Z n.
 Proof.
 reflexivity.
 Qed.
 Definition Zabs_N := BigZ.to_N.
 Lemma spec_Zabs_N : forall z, BigN.to_Z (Zabs_N z) = Zabs (BigZ.to_Z z).
 Proof.
 unfold Zabs_N; intros.
 rewrite BigZ.spec_to_Z, Zmult_comm; apply Zsgn_Zabs.
 Qed.
End BigN_BigZ.

(** This allows to build [BigQ] out of [BigN] and [BigQ] via [QMake] *)

Module BigQ <: QType <: OrderedTypeFull <: TotalOrder :=
 QMake.Make BigN BigZ BigN_BigZ <+ !QProperties <+ HasEqBool2Dec
 <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.

(** Notations about [BigQ] *)

Notation bigQ := BigQ.t.

Delimit Scope bigQ_scope with bigQ.
Bind Scope bigQ_scope with bigQ.
Bind Scope bigQ_scope with BigQ.t.
Bind Scope bigQ_scope with BigQ.t_.
(* Bind Scope has no retroactive effect, let's declare scopes by hand. *)
Arguments Scope BigQ.Qz [bigZ_scope].
Arguments Scope BigQ.Qq [bigZ_scope bigN_scope].
Arguments Scope BigQ.to_Q [bigQ_scope].
Arguments Scope BigQ.red [bigQ_scope].
Arguments Scope BigQ.opp [bigQ_scope].
Arguments Scope BigQ.inv [bigQ_scope].
Arguments Scope BigQ.square [bigQ_scope].
Arguments Scope BigQ.add [bigQ_scope bigQ_scope].
Arguments Scope BigQ.sub [bigQ_scope bigQ_scope].
Arguments Scope BigQ.mul [bigQ_scope bigQ_scope].
Arguments Scope BigQ.div [bigQ_scope bigQ_scope].
Arguments Scope BigQ.eq [bigQ_scope bigQ_scope].
Arguments Scope BigQ.lt [bigQ_scope bigQ_scope].
Arguments Scope BigQ.le [bigQ_scope bigQ_scope].
Arguments Scope BigQ.eq [bigQ_scope bigQ_scope].
Arguments Scope BigQ.compare [bigQ_scope bigQ_scope].
Arguments Scope BigQ.min [bigQ_scope bigQ_scope].
Arguments Scope BigQ.max [bigQ_scope bigQ_scope].
Arguments Scope BigQ.eq_bool [bigQ_scope bigQ_scope].
Arguments Scope BigQ.power_pos [bigQ_scope positive_scope].
Arguments Scope BigQ.power [bigQ_scope Z_scope].
Arguments Scope BigQ.inv_norm [bigQ_scope].
Arguments Scope BigQ.add_norm [bigQ_scope bigQ_scope].
Arguments Scope BigQ.sub_norm [bigQ_scope bigQ_scope].
Arguments Scope BigQ.mul_norm [bigQ_scope bigQ_scope].
Arguments Scope BigQ.div_norm [bigQ_scope bigQ_scope].
Arguments Scope BigQ.power_norm [bigQ_scope bigQ_scope].

(** As in QArith, we use [#] to denote fractions *)
Notation "p # q" := (BigQ.Qq p q) (at level 55, no associativity) : bigQ_scope.
Local Notation "0" := BigQ.zero : bigQ_scope.
Local Notation "1" := BigQ.one : bigQ_scope.
Infix "+" := BigQ.add : bigQ_scope.
Infix "-" := BigQ.sub : bigQ_scope.
Notation "- x" := (BigQ.opp x) : bigQ_scope.
Infix "*" := BigQ.mul : bigQ_scope.
Infix "/" := BigQ.div : bigQ_scope.
Infix "^" := BigQ.power : bigQ_scope.
Infix "?=" := BigQ.compare : bigQ_scope.
Infix "==" := BigQ.eq : bigQ_scope.
Notation "x != y" := (~x==y)%bigQ (at level 70, no associativity) : bigQ_scope.
Infix "<" := BigQ.lt : bigQ_scope.
Infix "<=" := BigQ.le : bigQ_scope.
Notation "x > y" := (BigQ.lt y x)(only parsing) : bigQ_scope.
Notation "x >= y" := (BigQ.le y x)(only parsing) : bigQ_scope.
Notation "x < y < z" := (x<y /\ y<z)%bigQ : bigQ_scope.
Notation "x < y <= z" := (x<y /\ y<=z)%bigQ : bigQ_scope.
Notation "x <= y < z" := (x<=y /\ y<z)%bigQ : bigQ_scope.
Notation "x <= y <= z" := (x<=y /\ y<=z)%bigQ : bigQ_scope.
Notation "[ q ]" := (BigQ.to_Q q) : bigQ_scope.

Local Open Scope bigQ_scope.

(** [BigQ] is a field *)

Lemma BigQfieldth :
 field_theory 0 1 BigQ.add BigQ.mul BigQ.sub BigQ.opp
  BigQ.div BigQ.inv BigQ.eq.
Proof.
constructor.
constructor.
exact BigQ.add_0_l. exact BigQ.add_comm. exact BigQ.add_assoc.
exact BigQ.mul_1_l. exact BigQ.mul_comm. exact BigQ.mul_assoc.
exact BigQ.mul_add_distr_r. exact BigQ.sub_add_opp.
exact BigQ.add_opp_diag_r. exact BigQ.neq_1_0.
exact BigQ.div_mul_inv. exact BigQ.mul_inv_diag_l.
Qed.

Lemma BigQpowerth :
 power_theory 1 BigQ.mul BigQ.eq Z_of_N BigQ.power.
Proof.
constructor. intros. BigQ.qify.
replace ([r] ^ Z_of_N n)%Q with (pow_N 1 Qmult [r] n)%Q by (now destruct n).
destruct n. reflexivity.
induction p; simpl; auto; rewrite ?BigQ.spec_mul, ?IHp; reflexivity.
Qed.

Ltac isBigQcst t :=
 match t with
 | BigQ.Qz ?t => isBigZcst t
 | BigQ.Qq ?n ?d => match isBigZcst n with
             | true => isBigNcst d
             | false => constr:false
             end
 | BigQ.zero => constr:true
 | BigQ.one => constr:true
 | BigQ.minus_one => constr:true
 | _ => constr:false
 end.

Ltac BigQcst t :=
 match isBigQcst t with
 | true => constr:t
 | false => constr:NotConstant
 end.

Add Field BigQfield : BigQfieldth
 (decidable BigQ.eqb_correct,
  completeness BigQ.eqb_complete,
  constants [BigQcst],
  power_tac BigQpowerth [Qpow_tac]).

Section TestField.

Let ex1 : forall x y z, (x+y)*z ==  (x*z)+(y*z).
  intros.
  ring.
Qed.

Let ex8 : forall x, x ^ 2 == x*x.
  intro.
  ring.
Qed.

Let ex10 : forall x y, y!=0 -> (x/y)*y == x.
intros.
field.
auto.
Qed.

End TestField.

(** [BigQ] can also benefit from an "order" tactic *)

Module BigQ_Order := !OrdersTac.MakeOrderTac BigQ.
Ltac bigQ_order := BigQ_Order.order.

Section TestOrder.
Let test : forall x y : bigQ, x<=y -> y<=x -> x==y.
Proof. bigQ_order. Qed.
End TestOrder.

(** We can also reason by switching to QArith thanks to tactic
    BigQ.qify. *)

Section TestQify.
Let test : forall x : bigQ, 0+x == 1*x.
Proof. intro x. BigQ.qify. ring. Qed.
End TestQify.