Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e226m5_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e206m5_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e171m19_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e226m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e243m9_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e468m17_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e166m5_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e452m3_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e166m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e489m21_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e166m5_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import init.

Require Export algebra_category.
Require Import linear_sum.

Section UnitalZeroAlgebra.

Context {F : CRingObj} (V : ModuleObj F).

Let U := cring_U F.
Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPA := cring_plus_assoc F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMA := cring_mult_assoc F.
Let UMC := cring_mult_comm F.
Let UMO := cring_mult_lid F.
Let UMD := cring_ldist F.
Let VP := module_plus V.
Let VZ := module_zero V.
Let VN := module_neg V.
Let VPA := module_plus_assoc V.
Let VPC := module_plus_comm V.
Let VPZ := module_plus_lid V.
Let VPN := module_plus_linv V.
Let VSM := module_scalar V.
Let VSMO := module_scalar_id V.
Let VSML := module_scalar_ldist V.
Let VSMR := module_scalar_rdist V.
Let VSMC := module_scalar_comp V.
Local Existing Instances UP UZ UN UPA UPC UPZ UPN UM UO UMA UMC UMO UMD VP VZ VN
    VPA VPC VPZ VPN VSM VSMO VSML VSMR VSMC.

Let UV_module := direct_sum (cring_module F) V.
Let UV := module_V UV_module.
Let UVP := module_plus UV_module.
Let UVZ := module_zero UV_module.
Let UVN := module_neg UV_module.
Let UVPA := module_plus_assoc UV_module.
Let UVPC := module_plus_comm UV_module.
Let UVPZ := module_plus_lid UV_module.
Let UVPN := module_plus_linv UV_module.
Let UVSM := module_scalar UV_module.
Let UVSMO := module_scalar_id UV_module.
Let UVSML := module_scalar_ldist UV_module.
Let UVSMR := module_scalar_rdist UV_module.
Local Existing Instances UVP UVZ UVN UVPA UVPC UVPZ UVPN UVSM UVSMO UVSML UVSMR.

Local Instance unital_zero_mult : Mult UV := {
    mult a b := (fst a * fst b, fst a · snd b + fst b · snd a)
}.

Local Instance unital_zero_mult_assoc : MultAssoc UV.
Proof.
    split.
    intros [a1 a2] [b1 b2] [c1 c2].
    unfold mult; cbn.
    rewrite mult_assoc.
    do 2 rewrite scalar_ldist.
    do 4 rewrite scalar_comp.
    rewrite plus_assoc.
    rewrite (mult_comm a1 c1).
    rewrite (mult_comm b1 c1).
    reflexivity.
Qed.

Local Instance unital_zero_mult_comm : MultComm UV.
Proof.
    split.
    intros [a1 a2] [b1 b2].
    unfold mult; cbn.
    rewrite plus_comm.
    rewrite mult_comm.
    reflexivity.
Qed.

Local Instance unital_zero_ldist : Ldist UV.
Proof.
    split.
    intros [a1 a2] [b1 b2] [c1 c2].
    unfold mult; cbn.
    unfold plus at 1 3 4 5; cbn.
    rewrite ldist, scalar_ldist, scalar_rdist.
    apply f_equal.
    apply plus_4.
Qed.

Local Instance unital_zero_one : One UV := {
    one := (1, 0)
}.

Local Instance unital_zero_mult_lid : MultLid UV.
Proof.
    split.
    intros [a1 a2].
    unfold one, mult; cbn.
    rewrite mult_lid, scalar_id.
    rewrite scalar_ranni, plus_rid.
    reflexivity.
Qed.

Local Instance unital_zero_scalar_lmult : ScalarLMult U UV.
Proof.
    split.
    intros a [u1 u2] [v1 v2].
    unfold scalar_mult, mult; cbn.
    unfold scalar_mult at 1 3 6; cbn.
    rewrite mult_assoc.
    rewrite scalar_ldist.
    do 3 rewrite scalar_comp.
    rewrite (mult_comm a v1).
    reflexivity.
Qed.

Local Instance unital_zero_scalar_rmult : ScalarRMult U UV.
Proof.
    split.
    intros a u v.
    do 2 rewrite (mult_comm u).
    apply scalar_lmult.
Qed.

Definition unital_zero_algebra := make_algebra F UV_module
    unital_zero_mult
    unital_zero_ldist
    ldist_rdist
    unital_zero_mult_assoc
    unital_zero_one
    unital_zero_mult_lid
    mult_lid_rid
    unital_zero_scalar_lmult
    unital_zero_scalar_rmult.

End UnitalZeroAlgebra.


(*https://stackoverflow.com/questions/46838928/nested-recursion-and-program-fixpoint-or-function*)
Require Import Coq.Lists.List.
Import ListNotations.
Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.
Record PSV := MPSV{
 ps : PredSymb;
 psv : nat;
}.

Section tree.
(*Context {A:Type}.*)
Unset Elimination Schemes.
Inductive preTerms :=
|Vari : SetVars -> preTerms
|Node : FSV -> list preTerms -> preTerms.
Set Elimination Schemes.

Inductive isTerm1 : preTerms -> Prop :=
|c1 : forall (v : SetVars), isTerm1 (Vari v)
|c2 : forall (f:FSV)(lt:list preTerms),
 ((fsv f) = (length lt))->
(* (fold_right (fun t => and (isTerm t)) True lt)->*)
  isTerm1 (Node f lt).

Inductive isTerm2 : preTerms -> Prop :=
|c3 : forall (v : SetVars), isTerm2 (Vari v)
|c4 : forall (f:FSV)(lt:list preTerms),
(fold_right (fun t => and (isTerm1 t)) True lt)->
  isTerm2 (Node f lt).

(*
Inductive isTerm : forall (n:nat), preTerms -> Prop :=
|a1 : forall (n:nat) (v : SetVars), isTerm n (Vari v)
|a2 : forall (n:nat) (f:FSV) (lt:list preTerms),
 ((fsv f) = (length lt))->
  (fold_right (fun t => and (isTerm n t)) True lt)->
  isTerm (S n) (Node f lt).*)
Check True.
(*Inductive isTerm (n:nat): preTerms -> Prop :=
|a1 : forall (v : SetVars), isTerm n (Vari v)
|a2 : forall (f:FSV) (lt:list preTerms),
 ((fsv f) = (length lt))->
  (fold_right (fun t => and (isTerm n t)) True lt)->
  isTerm (S n) (Node f lt).*)
Check True.
Fixpoint isTerm' (n:nat) (x : preTerms) {struct n}: Prop
:=match n with
  | 0 => True
  | S n =>
   match x with
   | Vari v => True
   | Node f lp => (and ((length lp)=(fsv f)) (Forall (isTerm' n) lp))
   end
  end.

Definition isTerm (x : preTerms) := forall (n:nat), isTerm' n x.

FSV -> list preTerms -> preTerms.

Section tree_ind.
Context  (P : preTerms -> Prop).
Context  (Q : FSV -> list preTerms -> Prop).
Context  (IH1 : forall s, P (Vari s)).
Context  (IH2 : forall (n : FSV) (ts : list preTerms),
          (fold_right (fun t => and (P t)) True ts) ->
          (Q n ts) ->
          P (Node n ts)).
Fixpoint tree_ind
  (t : preTerms) : P t (*. destruct t.*)
 :=
  match t with
  | Vari v => IH1 v
  | Node n ts =>
    let fix loop ts :=
      match ts return fold_right (fun t' => and (P t')) True ts with
      | [] => I
      | t' :: ts' => conj (tree_ind t') (loop ts')
      end in
    IH2 n ts (loop ts)
  end.
End tree_ind.

(*Fixpoint map_preTerms (f : FSV -> FSV) (t : preTerms ) : preTerms :=
  match t with
  | Node x ts => Node (f x) (map (fun t => preTerms f t) ts)
  end.*)
End tree.
Compute map_tree S (Node 0 ((Node 1 nil) :: (Node 2 nil) :: nil)).
Compute map_tree S (Node 1 [Node 2 []; Node 3 []]).
(*Print tree.*)

(* PUBLIC DOMAIN *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.
Require Import Lia.
Add LoadPath "/home/user/0data/COQ/SHEN/".
Require Export ListForallT.

Definition preTerms := @tree (sum SetVars FSV).


Add LoadPath "C:\td202\GitHub\coq\views".

Require Import SeparationAlgebras.
Require Import SetoidClass.
Require Import Tactics.
Require Import Setof.

Instance defined_morphism {A} `{Setoid A} :
    Proper (equiv ==> equiv) defined.
 destruct x; destruct y.
 firstorder.
Qed.

Section SeparationAlgebraProduct.
  Context A
      {A_setoid : Setoid A}
      (aop :partial_op A)
      {A_SA : SepAlg aop}.
  Context B
      {B_setoid : Setoid B}
      (bop :partial_op B)
      {B_SA : SepAlg bop}.

  Program Instance prod_setoid : Setoid (A*B) :=
    {| equiv := fun c c' =>
      let (a, b) := c in
      let (a', b') := c' in
        a == a' /\ b == b' |}.
  Obligation 1.
   split; cbv.
   destruct x; firstorder.
   destruct x; destruct y; firstorder.
   destruct x; destruct y; destruct z.
   firstorder; rewr auto.
  Qed.

  Program Definition prod_SA_unit : @Setof (A*B) _ :=
    {| elem := (fun c =>
        let (a,b) := c in sa_unit a /\ sa_unit b) |}.
  Obligation 1.
   destruct x; destruct y.
   firstorder; rewr trivial.
  Qed.

  Definition prod_sepop : partial_op (A*B) :=
    fun c c' =>
      let (a, b) := c in
      let (a', b') := c' in
      let a'' := aop a a' in let b'' := bop b b' in
          {|
            defined := defined a'' /\ defined b'';
            val := (val a'', val b'')
          |}.

  Instance prod_sepop_morphism : Proper
          (equiv ==> equiv ==> equiv) prod_sepop.
   repeat intro.
   unfold prod_sepop.
   repeat match goal with
    | c : prod A B |- _ => destruct c
    | P : (_,_) == (_,_) |- _ => destruct P
   end.
   destruct (sa_morph _ _ H _ _ H0).
   destruct (sa_morph _ _ H2 _ _ H1).
   split; simpl; intuition; try rewr auto.
  Qed.

  Lemma prod_sepop_comm : forall c c',
     prod_sepop c c' == prod_sepop c' c.
   intuition.
   generalize (sa_comm a a0).
   generalize (sa_comm b b0).
   split; simpl.
    rewr auto.
    destruct H.
    destruct H0.
    intuition.
  Qed.

  Lemma prod_sepop_assoc : forall c c' c'',
     lift_op prod_sepop (prod_sepop c c') (lift_val c'')
            == lift_op prod_sepop (lift_val c) (prod_sepop c' c'').
   intuition.
   generalize (sa_assoc a a0 a1).
   generalize (sa_assoc b b0 b1).
   intros H H0; split;
    destruct H; destruct H0;
    unfold lift_op in *; simpl in *;
    intuition.
  Qed.

  Lemma prod_sepop_unit_exists : forall c, exists i,
       elem prod_SA_unit i /\ prod_sepop i c == lift_val c.
   intuition.
   destruct (sa_unit_exists a).
   destruct (sa_unit_exists b).
   exists (x,x0).
   simpl; firstorder.
  Qed.

  Lemma prod_sepop_unit_min : forall c c' i,
                elem prod_SA_unit i ->
                    (prod_sepop i c) == lift_val c' ->
                         c == c'.
    intuition.
    destruct i as [ia ib].
    generalize (sa_unit_min b b0 ib).
    generalize (sa_unit_min a a0 ia).
    intros.
    simpl in *; unfold prod_prop_equiv in *; simpl in *.
    intuition.
  Qed.

  Instance prod_SA : SepAlg prod_sepop :=
     {| sa_morph := prod_sepop_morphism;
        sa_comm := prod_sepop_comm;
        sa_assoc := prod_sepop_assoc;
        sa_unit := prod_SA_unit;
        sa_unit_exists := prod_sepop_unit_exists;
        sa_unit_min := prod_sepop_unit_min
     |}.
End SeparationAlgebraProduct.


Require Import ZArith List FourierConcTerm Fourier.

(************************************************************)
(*          Term structure for reflecting terms             *)
(************************************************************)

Inductive term : Type :=
  | Const (_: Z)          (* constant with integer value *)
  | Var (_: nat)          (* variable indexed by nat *)
  | Scal (_: Z) (_: term) (* multiplication by a scalar *)
  | Op (_ : term)         (* opposite *)
  | Plus (_ _ : term)     (* sum *)
  | Minus (_ _ : term)    (* subtraction *).

Inductive equation : Type :=
  | Eq (_ _: term)        (* equality *)
  | Lt (_ _: term)        (* strict inequality *)
  | Le (_ _: term).       (* inequality *)

Section Abs2Conc.

Variable FT: Fmodule.
Variable FA: Faxiom FT.

Open Scope F_scope.

(* reflecting term *)
Fixpoint term_to_T t (env: list (T FT)) {struct t}: (T FT) :=
  match t with Const c => injT FT c
             | Var n => nth n env (injT FT 0)
             | Scal z t1 => z * (term_to_T t1 env)
             | Op t1 => opT FT (term_to_T t1 env)
             | Plus t1 t2 => (term_to_T t1 env) + (term_to_T t2 env)
             | Minus t1 t2 => (term_to_T t1 env) - (term_to_T t2 env)
  end.

(* reflecting a single equation *)
Definition equation_to_T e (env: list (T FT)) :=
  match e with Eq t1 t2 => term_to_T t1 env = term_to_T t2 env
             | Lt t1 t2 => ltT FT (term_to_T t1 env) (term_to_T t2 env)
             | Le t1 t2 => leT FT (term_to_T t1 env) (term_to_T t2 env)
  end.

(* reflecting a list of equations *)
Fixpoint equations_to_T l (env: list (T FT)) {struct l}: Prop :=
  match l with nil => False
             | e::l1 => equation_to_T e env -> equations_to_T l1 env
  end.

Fixpoint full_var (l: list (T FT)) :=
  match l with nil => nil | _ :: l1 => 0::full_var l1 end.

Lemma full_var_length: forall l,
  length (full_var l) = length l.
Proof.
intros l; induction l; simpl; auto.
Qed.

Lemma full_var0: forall l env, list_to_T FT (full_var l) env = injT _ 0.
Proof.
intros l; induction l as [| a l Hrec]; simpl; auto.
intros [| b env]; auto; rewrite Hrec; rewrite scalT_0; auto.
rewrite injT_0_l; auto.
Qed.

Fixpoint mk_var (n: nat) (l: list (T FT)) {struct l} :=
  match l with
    nil => nil
  | _ :: l1 => match n with
                 O => 1::full_var l1
               | S n1 => 0::mk_var n1 l1
               end
  end.

Lemma mk_var_length: forall n l,
  length (mk_var n l) = length l.
Proof.
intros n l; generalize n; induction l; simpl; auto.
intros n1; induction n1; simpl; auto.
rewrite full_var_length; auto.
Qed.

Definition mk_lvar n env := Line (mk_var n env) 0.

Lemma mk_var_cor: forall n env,
   term_to_T (Var n) env = list_to_T _ (mk_var n env) env.
Proof.
simpl.
intros n env; generalize n; induction env as [| e env Hrec];
  simpl; clear n; intros [| n]; simpl; try rewrite injT_0_r; auto.
rewrite full_var0; rewrite injT_0_r; auto; rewrite scalT_1; auto.
rewrite Hrec; rewrite scalT_0; auto; rewrite injT_0_l; auto.
Qed.

Lemma mapsm_length: forall v l,
   length (mapsm v l) = length l.
Proof.
intros v l; induction l; simpl; auto.
Qed.

Definition scal_line v l :=
  match l with
   Line ll c t => Line (mapsm v ll) (v * c) t
  end.

Lemma scal_line_length: forall v l,
   llength (scal_line v l) = llength l.
Proof.
intros v l; induction l; simpl; auto.
apply mapsm_length.
Qed.

Fixpoint plusm (l1 l2: list Z) {struct l1} : list Z :=
  match l1, l2 with
  | nil, nil => nil
  | nil, _ => l2
  | _, nil => l1
  | (v1::l3), (v2::l4) => (v1 + v2)%Z:: plusm l3 l4
  end.

Lemma plusm_length: forall l1 l2 n,
   length l1 = n -> length l2 = n -> length (plusm l1 l2) = n.
Proof.
intros l1; induction l1 as [|a l1 Hrec]; simpl; auto;
  intros [| b l2]; simpl; auto.
intros [|n] H1 H2; try discriminate H1.
rewrite (Hrec l2 n); auto.
Qed.

Lemma plusm_cor: forall l1 l2 env,
  list_to_T FT (plusm l1 l2) env =
   list_to_T _ l1 env + list_to_T _ l2 env.
Proof.
intros l1; induction l1 as [| a l1 Hrec]; intros [| b l2] env;
  simpl; try rewrite injT_0_r; try rewrite injT_0_l; auto.
case env; try rewrite injT_0_r; auto.
intros e env1; rewrite Hrec.
rewrite scalT_plus_l; repeat rewrite plusT_A; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; auto.
Qed.

Definition plus_line l1 l2 t :=
  match l1, l2 with
    Line ll1 c1 _, Line ll2 c2 _ => Line (plusm ll1 ll2) (c1 + c2)%Z t
  end.

Lemma plus_line_length: forall l1 l2 n t,
   llength l1 = n -> llength l2 = n -> llength (plus_line l1 l2 t) = n.
Proof.
intros [l1 c1 t1] [l2 c2 t2] n t Hl1 Hl2; simpl; apply plusm_length; auto.
Qed.

Fixpoint term_to_line t (env: list (T FT)) ty {struct t}: line :=
  match t with Const c => Line (full_var env) c ty
             | Var n => mk_lvar n env ty
             | Scal z t1 => scal_line z (term_to_line t1 env ty)
             | Op t1 => scal_line (-1) (term_to_line t1 env ty)
             | Plus t1 t2 => plus_line (term_to_line t1 env ty)
                                (term_to_line t2 env ty) ty
             | Minus t1 t2 => plus_line (term_to_line t1 env ty)
                                (scal_line (-1) (term_to_line t2 env ty)) ty
  end.

Lemma term_to_line_length : forall t env ty,
  llength (term_to_line t env ty) = length env.
Proof.
intros t; elim t; simpl; auto.
intros; apply full_var_length.
intros; apply mk_var_length.
intros; rewrite scal_line_length; auto.
intros; rewrite scal_line_length; auto.
intros; rewrite (fun x y => plus_line_length x y (length env)); auto.
intros; rewrite (fun x y => plus_line_length x y (length env)); auto.
intros; rewrite scal_line_length; auto.
Qed.

Lemma term_to_line_cor: forall t env ty,
  match term_to_line t env ty with
    Line l c _ =>
      term_to_T t env = list_to_T _ l env + injT _ c
  end.
Proof.
intros t env ty; induction t as [
   c| n | z t1 Hrec | t1 Hrec | t1 Hrec1 t2 Hrec2 | t1 Hrec1 t2 Hrec2]; simpl.
rewrite full_var0; rewrite injT_0_l; auto.
rewrite <- mk_var_cor; rewrite injT_0_r; auto.
generalize Hrec; case term_to_line; simpl;
  intros l1 c1 ty1 HH; rewrite HH; rewrite mapsm_cor; auto;
  rewrite scalT_plus_r; auto; rewrite injT_mul; auto.
rewrite opT_def; auto.
generalize Hrec; case term_to_line; simpl;
  intros l1 c1 ty1 HH; rewrite HH; rewrite mapsm_cor; auto;
  rewrite scalT_plus_r; auto; rewrite <- injT_mul; auto.
generalize Hrec1 Hrec2; do 2 case term_to_line.
  intros l1 c1 ty1 l2 c2 ty2 HH1 HH2; rewrite HH1; rewrite HH2.
  simpl; rewrite plusm_cor.
  repeat rewrite plusT_A; auto; apply f_equal2 with (f := plusT FT); auto.
  rewrite plusT_C; repeat rewrite plusT_A; auto; apply f_equal2 with (f := plusT FT); auto.
  rewrite plusT_C; auto; rewrite injT_plus; auto.
generalize Hrec1 Hrec2; do 2 case term_to_line.
  intros l1 c1 ty1 l2 c2 ty2 HH1 HH2; rewrite HH1; rewrite HH2.
  simpl; rewrite plusm_cor; rewrite mapsm_cor; auto.
  rewrite minusT_def; auto.
  repeat rewrite plusT_A; auto; apply f_equal2 with (f := plusT FT); auto.
  rewrite plusT_C; auto; rewrite scalT_plus_r; auto.
  repeat rewrite plusT_A; auto; apply f_equal2 with (f := plusT FT); auto.
  rewrite plusT_C; auto; rewrite injT_plus; auto; rewrite <- injT_mul; simpl; auto.
Qed.

(* Reflection functions *)
Definition equation_to_P  (e: equation) env : Prop :=
  match e with
    Eq t1 t2  => term_to_T t1 env = term_to_T t2 env
  | Lt t1 t2  => term_to_T t1 env < term_to_T t2 env
  | Le t1 t2  => term_to_T t1 env <= term_to_T t2 env
  end.

Fixpoint equations_to_P  (es: list equation) env {struct es} : Prop :=
  match es with
    nil => False
  | e::es1 => equation_to_P e env ->  equations_to_P es1 env
  end.

(* Translation functions *)
Definition equation_to_line (e: equation) env : line :=
  match e with
    Eq t1 t2 =>
        plus_line (term_to_line t2 env lEq)
                   (scal_line (-1) (term_to_line t1 env lEq)) lEq
  | Le t1 t2 =>
        plus_line (term_to_line t2 env lLe)
                   (scal_line (-1) (term_to_line t1 env lLe)) lLe
  | Lt t1 t2 =>
        plus_line (term_to_line t2 env lLt)
                   (scal_line (-1) (term_to_line t1 env lLt)) lLt
  end.

Fixpoint equations_to_dt (es: list equation) env {struct es} : dt :=
  match es with
    nil => nil
  | e::es1 => equation_to_line e env :: equations_to_dt es1 env
  end.

Lemma equation_to_line_length: forall e env,
  llength (equation_to_line e env) = length env.
Proof.
intros e env; destruct e; simpl; auto;
  try apply plus_line_length; auto;
  try apply term_to_line_length;
  try rewrite scal_line_length;
  apply term_to_line_length.
Qed.

Lemma equations_to_dt_length: forall s env i,
  In i (equations_to_dt s env) -> llength i = length env.
Proof.
intros s env i; induction s as [| t1 t2 s]; simpl; auto.
intros HH; case HH.
intros [HH | HH]; subst; auto.
apply equation_to_line_length; auto.
Qed.

(* Main theorem *)
Lemma equations_cor: forall es env,
  refute (equations_to_dt es env) = true ->
  equations_to_P es env.
Proof.
intros es env H.
assert (H1: ~ Pdt _ (equations_to_dt es env) env).
  apply refute_cor; auto.
  generalize H (equations_to_dt_length es env);
   case equations_to_dt; simpl.
  intros HH; discriminate.
  intros l1 l2 _ HH; generalize (HH l1); case l1; simpl; auto.
generalize H1; clear H H1.
induction es as [| e es Hrec]; simpl.
intros HH; case HH; intros a HH1; inversion HH1.
intros H1 H; apply Hrec; intros H2.
case H1.
intros a; simpl; intros [Ha | Ha]; subst; auto.
destruct e as [t1 t2|t1 t2|t1 t2]; simpl.
generalize H; simpl.
unfold plus_line.
generalize (term_to_line_cor t1 env lEq) (term_to_line_cor t2 env lEq).
do 2 case term_to_line.
intros l1 c1 ty1 l2 c2 ty2 HH1 HH2; rewrite HH1; rewrite HH2.
unfold scal_line, line_to_T; intros HH3.
rewrite plusm_cor; rewrite mapsm_cor; auto.
match goal with |- _ = ?X =>
  replace X with ((list_to_T FT l1 env + injT FT c1) +
                    (-1) * (list_to_T FT l2 env + injT FT c2))
end; auto.
rewrite HH3; rewrite plusT_0; auto.
rewrite scalT_plus_r; auto; rewrite injT_plus; auto; rewrite injT_mul; auto.
repeat rewrite plusT_A; auto; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; auto; repeat rewrite plusT_A; auto;
  apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; auto.
generalize H; simpl.
unfold plus_line.
generalize (term_to_line_cor t1 env lLt) (term_to_line_cor t2 env lLt).
do 2 case term_to_line.
intros l1 c1 ty1 l2 c2 ty2 HH1 HH2; rewrite HH1; rewrite HH2.
unfold scal_line, line_to_T; intros HH3.
rewrite plusm_cor; rewrite mapsm_cor; auto.
apply ltT_cancel_l with (list_to_T _ l2 env + (injT _ c2)); auto.
rewrite injT_0_r; auto.
match goal with |- _ < ?X =>
  replace X with (list_to_T FT l1 env + injT _ c1)
end; auto.
apply sym_equal.
rewrite plusT_C; auto.
repeat rewrite plusT_A; auto; apply f_equal2 with (f := plusT FT); auto.
rewrite (plusT_C _  FA (list_to_T FT l2 env)); auto.
rewrite (plusT_C _ FA (-1 * list_to_T FT l2 env)); auto.
rewrite injT_plus; repeat rewrite plusT_A; auto.
rewrite injT_mul; auto; rewrite plusT_0; auto; rewrite injT_0_r; auto.
rewrite (plusT_C _ FA (-1 * injT _ c2)); auto.
rewrite plusT_0; auto; rewrite injT_0_r; auto.
generalize H; simpl.
unfold plus_line.
generalize (term_to_line_cor t1 env lLe) (term_to_line_cor t2 env lLe).
do 2 case term_to_line.
intros l1 c1 ty1 l2 c2 ty2 HH1 HH2; rewrite HH1; rewrite HH2.
unfold scal_line, line_to_T; intros HH3.
rewrite plusm_cor; rewrite mapsm_cor; auto.
apply leT_cancel_l with (list_to_T _ l2 env + (injT _ c2)); auto.
rewrite injT_0_r; auto.
match goal with |- _ <= ?X =>
  replace X with (list_to_T FT l1 env + injT _ c1)
end; auto.
apply sym_equal.
rewrite plusT_C; auto.
repeat rewrite plusT_A; auto; apply f_equal2 with (f := plusT FT); auto.
rewrite (plusT_C _  FA (list_to_T FT l2 env)); auto.
rewrite (plusT_C _ FA (-1 * list_to_T FT l2 env)); auto.
rewrite injT_plus; repeat rewrite plusT_A; auto.
rewrite injT_mul; auto; rewrite plusT_0; auto; rewrite injT_0_r; auto.
rewrite (plusT_C _ FA (-1 * injT _ c2)); auto.
rewrite plusT_0; auto; rewrite injT_0_r; auto.
Qed.

End Abs2Conc.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Ensembles.
Require Export Relations_1.
Require Export Partial_Order.

Section Bounds.
  Variable U : Type.
  Variable D : PO U.

  Let C := @Carrier_of U D.

  Let R := @Rel_of U D.

  Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
    Upper_Bound_definition :
    In U C x -> (forall y:U, In U B y -> R y x) -> Upper_Bound B x.

  Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop :=
    Lower_Bound_definition :
    In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x.

  Inductive Lub (B:Ensemble U) (x:U) : Prop :=
    Lub_definition :
    Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x.

  Inductive Glb (B:Ensemble U) (x:U) : Prop :=
    Glb_definition :
    Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x.

  Inductive Bottom (bot:U) : Prop :=
    Bottom_definition :
    In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot.

  Inductive Totally_ordered (B:Ensemble U) : Prop :=
    Totally_ordered_definition :
    (Included U B C ->
      forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) ->
    Totally_ordered B.

  Definition Compatible : Relation U :=
    fun x y:U =>
      In U C x ->
      In U C y ->  exists z : _, In U C z /\ Upper_Bound (Couple U x y) z.

  Inductive Directed (X:Ensemble U) : Prop :=
    Definition_of_Directed :
    Included U X C ->
    Inhabited U X ->
    (forall x1 x2:U,
      Included U (Couple U x1 x2) X ->
      exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
    Directed X.

  Inductive Complete : Prop :=
    Definition_of_Complete :
    (exists bot : _, Bottom bot) ->
    (forall X:Ensemble U, Directed X ->  exists bsup : _, Lub X bsup) ->
    Complete.

  Inductive Conditionally_complete : Prop :=
    Definition_of_Conditionally_complete :
    (forall X:Ensemble U,
      Included U X C ->
      (exists maj : _, Upper_Bound X maj) ->
      exists bsup : _, Lub X bsup) -> Conditionally_complete.
End Bounds.

Hint Resolve Totally_ordered_definition Upper_Bound_definition
  Lower_Bound_definition Lub_definition Glb_definition Bottom_definition
  Definition_of_Complete Definition_of_Complete
  Definition_of_Conditionally_complete.

Section Specific_orders.
  Variable U : Type.

  Record Cpo : Type := Definition_of_cpo
    {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}.

  Record Chain : Type := Definition_of_chain
    {PO_of_chain : PO U;
    Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}.

End Specific_orders.


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

Require Export ZArith.
Require Export ZArithRing.
Require Export Morphisms Setoid Bool.

(** * Definition of [Q] and basic properties *)

(** Rationals are pairs of [Z] and [positive] numbers. *)

Record Q : Set := Qmake {Qnum : Z; Qden : positive}.

Delimit Scope Q_scope with Q.
Bind Scope Q_scope with Q.
Arguments Scope Qmake [Z_scope positive_scope].
Open Scope Q_scope.
Ltac simpl_mult := repeat rewrite Zpos_mult_morphism.

(** [a#b] denotes the fraction [a] over [b]. *)

Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope.

Definition inject_Z (x : Z) := Qmake x 1.
Arguments Scope inject_Z [Z_scope].

Notation QDen p := (Zpos (Qden p)).
Notation " 0 " := (0#1) : Q_scope.
Notation " 1 " := (1#1) : Q_scope.

Definition Qeq (p q : Q) := (Qnum p * QDen q)%Z = (Qnum q * QDen p)%Z.
Definition Qle (x y : Q) := (Qnum x * QDen y <= Qnum y * QDen x)%Z.
Definition Qlt (x y : Q) := (Qnum x * QDen y < Qnum y * QDen x)%Z.
Notation Qgt a b := (Qlt b a) (only parsing).
Notation Qge a b := (Qle b a) (only parsing).

Infix "==" := Qeq (at level 70, no associativity) : Q_scope.
Infix "<" := Qlt : Q_scope.
Infix "<=" := Qle : Q_scope.
Notation "x > y" := (Qlt y x)(only parsing) : Q_scope.
Notation "x >= y" := (Qle y x)(only parsing) : Q_scope.
Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope.

(** injection from Z is injective. *)

Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b.
Proof.
 unfold Qeq. simpl. omega.
Qed.

(** Another approach : using Qcompare for defining order relations. *)

Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z.
Notation "p ?= q" := (Qcompare p q) : Q_scope.

Lemma Qeq_alt : forall p q, (p == q) <-> (p ?= q) = Eq.
Proof.
unfold Qeq, Qcompare; intros; split; intros.
rewrite H; apply Zcompare_refl.
apply Zcompare_Eq_eq; auto.
Qed.

Lemma Qlt_alt : forall p q, (p<q) <-> (p?=q = Lt).
Proof.
unfold Qlt, Qcompare, Zlt; split; auto.
Qed.

Lemma Qgt_alt : forall p q, (p>q) <-> (p?=q = Gt).
Proof.
unfold Qlt, Qcompare, Zlt.
intros; rewrite Zcompare_Gt_Lt_antisym; split; auto.
Qed.

Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
Proof.
unfold Qle, Qcompare, Zle; split; auto.
Qed.

Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
Proof.
unfold Qle, Qcompare, Zle.
split; intros; contradict H.
rewrite Zcompare_Gt_Lt_antisym; auto.
rewrite Zcompare_Gt_Lt_antisym in H; auto.
Qed.

Hint Unfold Qeq Qlt Qle : qarith.
Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.

Lemma Qcompare_antisym : forall x y, CompOpp (x ?= y) = (y ?= x).
Proof.
 unfold "?=". intros. apply Zcompare_antisym.
Qed.

Lemma Qcompare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (x ?= y).
Proof.
 intros.
 destruct (x ?= y) as [ ]_eqn:H; constructor; auto.
 rewrite Qeq_alt; auto.
 rewrite Qlt_alt, <- Qcompare_antisym, H; auto.
Qed.

(** * Properties of equality. *)

Theorem Qeq_refl : forall x, x == x.
Proof.
 auto with qarith.
Qed.

Theorem Qeq_sym : forall x y, x == y -> y == x.
Proof.
 auto with qarith.
Qed.

Theorem Qeq_trans : forall x y z, x == y -> y == z -> x == z.
Proof.
unfold Qeq; intros.
apply Zmult_reg_l with (QDen y).
auto with qarith.
transitivity (Qnum x * QDen y * QDen z)%Z; try ring.
rewrite H.
transitivity (Qnum y * QDen z * QDen x)%Z; try ring.
rewrite H0; ring.
Qed.

Hint Resolve Qeq_refl : qarith.
Hint Resolve Qeq_sym : qarith.
Hint Resolve Qeq_trans : qarith.

(** In a word, [Qeq] is a setoid equality. *)

Instance Q_Setoid : Equivalence Qeq.
Proof. split; red; eauto with qarith. Qed.

(** Furthermore, this equality is decidable: *)

Theorem Qeq_dec : forall x y, {x==y} + {~ x==y}.
Proof.
 intros; case (Z_eq_dec (Qnum x * QDen y) (Qnum y * QDen x)); auto.
Defined.

Definition Qeq_bool x y :=
  (Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.

Definition Qle_bool x y :=
  (Zle_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.

Lemma Qeq_bool_iff : forall x y, Qeq_bool x y = true <-> x == y.
Proof.
  unfold Qeq_bool, Qeq; intros.
  symmetry; apply Zeq_is_eq_bool.
Qed.

Lemma Qeq_bool_eq : forall x y, Qeq_bool x y = true -> x == y.
Proof.
  intros; rewrite <- Qeq_bool_iff; auto.
Qed.

Lemma Qeq_eq_bool : forall x y, x == y -> Qeq_bool x y = true.
Proof.
  intros; rewrite Qeq_bool_iff; auto.
Qed.

Lemma Qeq_bool_neq : forall x y, Qeq_bool x y = false -> ~ x == y.
Proof.
  intros x y H; rewrite <- Qeq_bool_iff, H; discriminate.
Qed.

Lemma Qle_bool_iff : forall x y, Qle_bool x y = true <-> x <= y.
Proof.
  unfold Qle_bool, Qle; intros.
  symmetry; apply Zle_is_le_bool.
Qed.

Lemma Qle_bool_imp_le : forall x y, Qle_bool x y = true -> x <= y.
Proof.
  intros; rewrite <- Qle_bool_iff; auto.
Qed.

Theorem Qnot_eq_sym : forall x y, ~x == y -> ~y == x.
Proof.
 auto with qarith.
Qed.

Hint Resolve Qnot_eq_sym : qarith.

(** * Addition, multiplication and opposite *)

(** The addition, multiplication and opposite are defined
   in the straightforward way: *)

Definition Qplus (x y : Q) :=
  (Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y).

Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y).

Definition Qopp (x : Q) := (- Qnum x) # (Qden x).

Definition Qminus (x y : Q) := Qplus x (Qopp y).

Definition Qinv (x : Q) :=
  match Qnum x with
  | Z0 => 0
  | Zpos p => (QDen x)#p
  | Zneg p => (Zneg (Qden x))#p
  end.

Definition Qdiv (x y : Q) := Qmult x (Qinv y).

Infix "+" := Qplus : Q_scope.
Notation "- x" := (Qopp x) : Q_scope.
Infix "-" := Qminus : Q_scope.
Infix "*" := Qmult : Q_scope.
Notation "/ x" := (Qinv x) : Q_scope.
Infix "/" := Qdiv : Q_scope.

(** A light notation for [Zpos] *)

Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.

Lemma Qmake_Qdiv : forall a b, a#b==inject_Z a/inject_Z ('b).
Proof.
intros a b.
unfold Qeq.
simpl.
ring.
Qed.

(** * Setoid compatibility results *)

Instance Qplus_comp : Proper (Qeq==>Qeq==>Qeq) Qplus.
Proof.
  unfold Qeq, Qplus; simpl.
  Open Scope Z_scope.
  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
  simpl_mult; ring_simplify.
  replace (p1 * 'r2 * 'q2) with (p1 * 'q2 * 'r2) by ring.
  rewrite H.
  replace (r1 * 'p2 * 'q2 * 's2) with (r1 * 's2 * 'p2 * 'q2) by ring.
  rewrite H0.
  ring.
  Close Scope Z_scope.
Qed.

Instance Qopp_comp : Proper (Qeq==>Qeq) Qopp.
Proof.
  unfold Qeq, Qopp; simpl.
  Open Scope Z_scope.
  intros x y H; simpl.
  replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring.
  rewrite H;  ring.
  Close Scope Z_scope.
Qed.

Instance Qminus_comp : Proper (Qeq==>Qeq==>Qeq) Qminus.
Proof.
  intros x x' Hx y y' Hy.
  unfold Qminus. rewrite Hx, Hy; auto with qarith.
Qed.

Instance Qmult_comp : Proper (Qeq==>Qeq==>Qeq) Qmult.
Proof.
  unfold Qeq; simpl.
  Open Scope Z_scope.
  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
  intros; simpl_mult; ring_simplify.
  replace (q1 * s1 * 'p2) with (q1 * 'p2 * s1) by ring.
  rewrite <- H.
  replace (p1 * r1 * 'q2 * 's2) with (r1 * 's2 * p1 * 'q2) by ring.
  rewrite H0.
  ring.
  Close Scope Z_scope.
Qed.

Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv.
Proof.
  unfold Qeq, Qinv; simpl.
  Open Scope Z_scope.
  intros (p1, p2) (q1, q2); simpl.
  case p1; simpl.
  intros.
  assert (q1 = 0).
  elim (Zmult_integral q1 ('p2)); auto with zarith.
  intros; discriminate.
  subst; auto.
  case q1; simpl; intros; try discriminate.
  rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
  case q1; simpl; intros; try discriminate.
  rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
  Close Scope Z_scope.
Qed.

Instance Qdiv_comp : Proper (Qeq==>Qeq==>Qeq) Qdiv.
Proof.
  intros x x' Hx y y' Hy; unfold Qdiv.
  rewrite Hx, Hy; auto with qarith.
Qed.

Instance Qcompare_comp : Proper (Qeq==>Qeq==>eq) Qcompare.
Proof.
  unfold Qeq, Qcompare.
  Open Scope Z_scope.
  intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *.
  rewrite <- (Zcompare_mult_compat (q2*s2) (p1*'r2)).
  rewrite <- (Zcompare_mult_compat (p2*r2) (q1*'s2)).
  change ('(q2*s2)) with ('q2 * 's2).
  change ('(p2*r2)) with ('p2 * 'r2).
  replace ('q2 * 's2 * (p1*'r2)) with ((p1*'q2)*'r2*'s2) by ring.
  rewrite H.
  replace ('q2 * 's2 * (r1*'p2)) with ((r1*'s2)*'q2*'p2) by ring.
  rewrite H'.
  f_equal; ring.
  Close Scope Z_scope.
Qed.

Instance Qle_comp : Proper (Qeq==>Qeq==>iff) Qle.
Proof.
  intros p q H r s H'. rewrite 2 Qle_alt, H, H'; auto with *.
Qed.

Instance Qlt_compat : Proper (Qeq==>Qeq==>iff) Qlt.
Proof.
  intros p q H r s H'. rewrite 2 Qlt_alt, H, H'; auto with *.
Qed.

Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool.
Proof.
 intros p q H r s H'; apply eq_true_iff_eq.
 rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith.
Qed.

Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool.
Proof.
 intros p q H r s H'; apply eq_true_iff_eq.
 rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith.
Qed.

(** [0] and [1] are apart *)

Lemma Q_apart_0_1 : ~ 1 == 0.
Proof.
  unfold Qeq; auto with qarith.
Qed.

(** * Properties of [Qadd] *)

(** Addition is associative: *)

Theorem Qplus_assoc : forall x y z, x+(y+z)==(x+y)+z.
Proof.
  intros (x1, x2) (y1, y2) (z1, z2).
  unfold Qeq, Qplus; simpl; simpl_mult; ring.
Qed.

(** [0] is a neutral element for addition: *)

Lemma Qplus_0_l : forall x, 0+x == x.
Proof.
  intros (x1, x2); unfold Qeq, Qplus; simpl; ring.
Qed.

Lemma Qplus_0_r : forall x, x+0 == x.
Proof.
  intros (x1, x2); unfold Qeq, Qplus; simpl.
  rewrite Pmult_comm; simpl; ring.
Qed.

(** Commutativity of addition: *)

Theorem Qplus_comm : forall x y, x+y == y+x.
Proof.
  intros (x1, x2); unfold Qeq, Qplus; simpl.
  intros; rewrite Pmult_comm; ring.
Qed.

(** * Properties of [Qopp] *)

Lemma Qopp_involutive : forall q, - -q == q.
Proof.
  red; simpl; intros; ring.
Qed.

Theorem Qplus_opp_r : forall q, q+(-q) == 0.
Proof.
  red; simpl; intro; ring.
Qed.

(** Injectivity of addition (uses theory about Qopp above): *)

Lemma Qplus_inj_r (x y z: Q):
  x + z == y + z <-> x == y.
Proof.
 split; intro E.
  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y).
  rewrite <- (Qplus_opp_r z); auto.
  do 2 rewrite Qplus_assoc.
  rewrite E. reflexivity.
 rewrite E. reflexivity.
Qed.

Lemma Qplus_inj_l (x y z: Q):
  z + x == z + y <-> x == y.
Proof.
 rewrite (Qplus_comm z x), (Qplus_comm z y).
 apply Qplus_inj_r.
Qed.

(** * Properties of [Qmult] *)

(** Multiplication is associative: *)

Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p.
Proof.
  intros; red; simpl; rewrite Pmult_assoc; ring.
Qed.

(** multiplication and zero *)

Lemma Qmult_0_l : forall x , 0*x == 0.
Proof.
  intros; compute; reflexivity.
Qed.

Lemma Qmult_0_r : forall x , x*0 == 0.
Proof.
  intros; red; simpl; ring.
Qed.

(** [1] is a neutral element for multiplication: *)

Lemma Qmult_1_l : forall n, 1*n == n.
Proof.
  intro; red; simpl; destruct (Qnum n); auto.
Qed.

Theorem Qmult_1_r : forall n, n*1==n.
Proof.
  intro; red; simpl.
  rewrite Zmult_1_r with (n := Qnum n).
  rewrite Pmult_comm; simpl; trivial.
Qed.

(** Commutativity of multiplication *)

Theorem Qmult_comm : forall x y, x*y==y*x.
Proof.
  intros; red; simpl; rewrite Pmult_comm; ring.
Qed.

(** Distributivity over [Qadd] *)

Theorem Qmult_plus_distr_r : forall x y z, x*(y+z)==(x*y)+(x*z).
Proof.
  intros (x1, x2) (y1, y2) (z1, z2).
  unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
Qed.

Theorem Qmult_plus_distr_l : forall x y z, (x+y)*z==(x*z)+(y*z).
Proof.
  intros (x1, x2) (y1, y2) (z1, z2).
  unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
Qed.

(** Integrality *)

Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0.
Proof.
  intros (x1,x2) (y1,y2).
  unfold Qeq, Qmult; simpl; intros.
  destruct (Zmult_integral (x1*1)%Z (y1*1)%Z); auto.
  rewrite <- H; ring.
Qed.

Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0.
Proof.
  intros (x1, x2) (y1, y2).
  unfold Qeq, Qmult; simpl; intros.
  apply Zmult_integral_l with x1; auto with zarith.
  rewrite <- H0; ring.
Qed.

(** * inject_Z is a ring homomorphism: *)

Lemma inject_Z_plus (x y: Z): inject_Z (x + y) = inject_Z x + inject_Z y.
Proof.
 unfold Qplus, inject_Z. simpl. f_equal. ring.
Qed.

Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y.
Proof. reflexivity. Qed.

Lemma inject_Z_opp (x: Z): inject_Z (- x) = - inject_Z x.
Proof. reflexivity. Qed.

(** * Inverse and division. *)

Lemma Qinv_involutive : forall q, (/ / q) == q.
Proof.
intros [[|n|n] d]; red; simpl; reflexivity.
Qed.

Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1.
Proof.
  intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl;
    intros; simpl_mult; try ring.
  elim H; auto.
Qed.

Lemma Qinv_mult_distr : forall p q, / (p * q) == /p * /q.
Proof.
  intros (x1,x2) (y1,y2); unfold Qeq, Qinv, Qmult; simpl.
  destruct x1; simpl; auto;
    destruct y1; simpl; auto.
Qed.

Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x.
Proof.
  intros; unfold Qdiv.
  rewrite <- (Qmult_assoc x y (Qinv y)).
  rewrite (Qmult_inv_r y H).
  apply Qmult_1_r.
Qed.

Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x.
Proof.
  intros; unfold Qdiv.
  rewrite (Qmult_assoc y x (Qinv y)).
  rewrite (Qmult_comm y x).
  fold (Qdiv (Qmult x y) y).
  apply Qdiv_mult_l; auto.
Qed.

(** Injectivity of Qmult (requires theory about Qinv above): *)

Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y).
Proof.
 intro z_ne_0.
 split; intro E.
  rewrite <- (Qmult_1_r x), <- (Qmult_1_r y).
  rewrite <- (Qmult_inv_r z); auto.
  do 2 rewrite Qmult_assoc.
  rewrite E. reflexivity.
 rewrite E. reflexivity.
Qed.

Lemma Qmult_inj_l (x y z: Q): ~ z == 0 -> (z * x == z * y <-> x == y).
Proof.
 rewrite (Qmult_comm z x), (Qmult_comm z y).
 apply Qmult_inj_r.
Qed.

(** * Properties of order upon Q. *)

Lemma Qle_refl : forall x, x<=x.
Proof.
  unfold Qle; auto with zarith.
Qed.

Lemma Qle_antisym : forall x y, x<=y -> y<=x -> x==y.
Proof.
  unfold Qle, Qeq; auto with zarith.
Qed.

Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z.
Proof.
  unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
  Open Scope Z_scope.
  apply Zmult_le_reg_r with ('y2).
  red; trivial.
  apply Zle_trans with (y1 * 'x2 * 'z2).
  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
  apply Zmult_le_compat_r; auto with zarith.
  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
  apply Zmult_le_compat_r; auto with zarith.
  Close Scope Z_scope.
Qed.

Hint Resolve Qle_trans : qarith.

Lemma Qlt_irrefl : forall x, ~x<x.
Proof.
 unfold Qlt. auto with zarith.
Qed.

Lemma Qlt_not_eq : forall x y, x<y -> ~ x==y.
Proof.
  unfold Qlt, Qeq; auto with zarith.
Qed.

Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y).
Proof.
 unfold Qle. intros. simpl.
 do 2 rewrite Zmult_1_r. reflexivity.
Qed.

Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y).
Proof.
 unfold Qlt. intros. simpl.
 do 2 rewrite Zmult_1_r. reflexivity.
Qed.

(** Large = strict or equal *)

Lemma Qle_lteq : forall x y, x<=y <-> x<y \/ x==y.
Proof.
 intros.
 rewrite Qeq_alt, Qle_alt, Qlt_alt.
 destruct (x ?= y); intuition; discriminate.
Qed.

Lemma Qlt_le_weak : forall x y, x<y -> x<=y.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
Proof.
  unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
  Open Scope Z_scope.
  apply Zgt_lt.
  apply Zmult_gt_reg_r with ('y2).
  red; trivial.
  apply Zgt_le_trans with (y1 * 'x2 * 'z2).
  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
  apply Zmult_gt_compat_r; auto with zarith.
  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
  apply Zmult_le_compat_r; auto with zarith.
  Close Scope Z_scope.
Qed.

Lemma Qlt_le_trans : forall x y z, x<y -> y<=z -> x<z.
Proof.
  unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
  Open Scope Z_scope.
  apply Zgt_lt.
  apply Zmult_gt_reg_r with ('y2).
  red; trivial.
  apply Zle_gt_trans with (y1 * 'x2 * 'z2).
  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
  apply Zmult_le_compat_r; auto with zarith.
  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
  apply Zmult_gt_compat_r; auto with zarith.
  Close Scope Z_scope.
Qed.

Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z.
Proof.
  intros.
  apply Qle_lt_trans with y; auto.
  apply Qlt_le_weak; auto.
Qed.

(** [x<y] iff [~(y<=x)] *)

Lemma Qnot_lt_le : forall x y, ~ x<y -> y<=x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qnot_le_lt : forall x y, ~ x<=y -> y<x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qlt_not_le : forall x y, x<y -> ~ y<=x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_not_lt : forall x y, x<=y -> ~ y<x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
Proof.
  unfold Qle, Qlt, Qeq; intros; apply Zle_lt_or_eq; auto.
Qed.

Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le
 Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith.

(** Some decidability results about orders. *)

Lemma Q_dec : forall x y, {x<y} + {y<x} + {x==y}.
Proof.
  unfold Qlt, Qle, Qeq; intros.
  exact (Z_dec' (Qnum x * QDen y) (Qnum y * QDen x)).
Defined.

Lemma Qlt_le_dec : forall x y, {x<y} + {y<=x}.
Proof.
  unfold Qlt, Qle; intros.
  exact (Z_lt_le_dec (Qnum x * QDen y) (Qnum y * QDen x)).
Defined.

(** Compatibility of operations with respect to order. *)

Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p.
Proof.
  intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
  do 2 rewrite <- Zopp_mult_distr_l; omega.
Qed.

Hint Resolve Qopp_le_compat : qarith.

Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
Proof.
  intros (x1,x2) (y1,y2); unfold Qle; simpl.
  rewrite <- Zopp_mult_distr_l.
  split; omega.
Qed.

Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p.
Proof.
  intros (x1,x2) (y1,y2); unfold Qlt; simpl.
  rewrite <- Zopp_mult_distr_l.
  split; omega.
Qed.

Lemma Qplus_le_compat :
  forall x y z t, x<=y -> z<=t -> x+z <= y+t.
Proof.
  unfold Qplus, Qle; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
    simpl; simpl_mult.
  Open Scope Z_scope.
  intros.
  match goal with |- ?a <= ?b => ring_simplify a b end.
  rewrite Zplus_comm.
  apply Zplus_le_compat.
  match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
  auto with zarith.
  match goal with |- ?a <= ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
  auto with zarith.
  Close Scope Z_scope.
Qed.

Lemma Qplus_lt_le_compat :
  forall x y z t, x<y -> z<=t -> x+z < y+t.
Proof.
  unfold Qplus, Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
    simpl; simpl_mult.
  Open Scope Z_scope.
  intros.
  match goal with |- ?a < ?b => ring_simplify a b end.
  rewrite Zplus_comm.
  apply Zplus_le_lt_compat.
  match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
  auto with zarith.
  match goal with |- ?a < ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
  assert (forall p, 0 < ' p) by reflexivity.
  repeat (apply Zmult_lt_compat_r; auto).
  Close Scope Z_scope.
Qed.

Lemma Qplus_le_l (x y z: Q): x + z <= y + z <-> x <= y.
Proof.
 split; intros.
  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
  do 2 rewrite Qplus_assoc.
  apply Qplus_le_compat; auto with *.
 apply Qplus_le_compat; auto with *.
Qed.

Lemma Qplus_le_r (x y z: Q): z + x <= z + y <-> x <= y.
Proof.
 rewrite (Qplus_comm z x), (Qplus_comm z y).
 apply Qplus_le_l.
Qed.

Lemma Qplus_lt_l (x y z: Q): x + z < y + z <-> x < y.
Proof.
 split; intros.
  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
  do 2 rewrite Qplus_assoc.
  apply Qplus_lt_le_compat; auto with *.
 apply Qplus_lt_le_compat; auto with *.
Qed.

Lemma Qplus_lt_r (x y z: Q): z + x < z + y <-> x < y.
Proof.
 rewrite (Qplus_comm z x), (Qplus_comm z y).
 apply Qplus_lt_l.
Qed.

Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
Proof.
  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
  Open Scope Z_scope.
  intros; simpl_mult.
  replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
  replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
  apply Zmult_le_compat_r; auto with zarith.
  Close Scope Z_scope.
Qed.

Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 <  z  -> x*z <= y*z -> x <= y.
Proof.
  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
  Open Scope Z_scope.
  simpl_mult.
  replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
  replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
  intros; apply Zmult_le_reg_r with (c1*'c2); auto with zarith.
  Close Scope Z_scope.
Qed.

Lemma Qmult_le_r (x y z: Q): 0 < z -> (x*z <= y*z <-> x <= y).
Proof.
 split; intro.
  now apply Qmult_lt_0_le_reg_r with z.
 apply Qmult_le_compat_r; auto with qarith.
Qed.

Lemma Qmult_le_l (x y z: Q): 0 < z -> (z*x <= z*y <-> x <= y).
Proof.
 rewrite (Qmult_comm z x), (Qmult_comm z y).
 apply Qmult_le_r.
Qed.

Lemma Qmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
Proof.
  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
  Open Scope Z_scope.
  intros; simpl_mult.
  replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
  replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
  apply Zmult_lt_compat_r; auto with zarith.
  apply Zmult_lt_0_compat.
  omega.
  compute; auto.
  Close Scope Z_scope.
Qed.

Lemma Qmult_lt_r: forall x y z, 0 < z -> (x*z < y*z <-> x < y).
Proof.
 Open Scope Z_scope.
 intros (a1,a2) (b1,b2) (c1,c2).
 unfold Qle, Qlt; simpl.
 simpl_mult.
 replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
 replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
 assert (forall p, 0 < ' p) by reflexivity.
 split; intros.
  apply Zmult_lt_reg_r with (c1*'c2); auto with zarith.
  apply Zmult_lt_0_compat; auto with zarith.
 apply Zmult_lt_compat_r; auto with zarith.
 apply Zmult_lt_0_compat. omega.
 compute; auto.
 Close Scope Z_scope.
Qed.

Lemma Qmult_lt_l (x y z: Q): 0 < z -> (z*x < z*y <-> x < y).
Proof.
 rewrite (Qmult_comm z x), (Qmult_comm z y).
 apply Qmult_lt_r.
Qed.

Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b.
Proof.
intros a b Ha Hb.
unfold Qle in *.
simpl in *.
auto with *.
Qed.

Lemma Qinv_le_0_compat : forall a, 0 <= a -> 0 <= /a.
Proof.
intros [[|n|n] d] Ha; assumption.
Qed.

Lemma Qle_shift_div_l : forall a b c,
 0 < c -> a*c <= b -> a <= b/c.
Proof.
intros a b c Hc H.
apply Qmult_lt_0_le_reg_r with (c).
 assumption.
setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm.
rewrite Qmult_div_r; try assumption.
auto with *.
Qed.

Lemma Qle_shift_inv_l : forall a c,
 0 < c -> a*c <= 1 -> a <= /c.
Proof.
intros a c Hc H.
setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l).
change (a <= 1/c).
apply Qle_shift_div_l; assumption.
Qed.

Lemma Qle_shift_div_r : forall a b c,
 0 < b -> a <= c*b -> a/b <= c.
Proof.
intros a b c Hc H.
apply Qmult_lt_0_le_reg_r with b.
 assumption.
setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm.
rewrite Qmult_div_r; try assumption.
auto with *.
Qed.

Lemma Qle_shift_inv_r : forall b c,
 0 < b -> 1 <= c*b -> /b <= c.
Proof.
intros b c Hc H.
setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l).
change (1/b <= c).
apply Qle_shift_div_r; assumption.
Qed.

Lemma Qinv_lt_0_compat : forall a, 0 < a -> 0 < /a.
Proof.
intros [[|n|n] d] Ha; assumption.
Qed.

Lemma Qlt_shift_div_l : forall a b c,
 0 < c -> a*c < b -> a < b/c.
Proof.
intros a b c Hc H.
apply Qnot_le_lt.
intros H0.
apply (Qlt_not_le _ _ H).
apply Qmult_lt_0_le_reg_r with (/c).
 apply Qinv_lt_0_compat.
 assumption.
setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with *).
assumption.
Qed.

Lemma Qlt_shift_inv_l : forall a c,
 0 < c -> a*c < 1 -> a < /c.
Proof.
intros a c Hc H.
setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l).
change (a < 1/c).
apply Qlt_shift_div_l; assumption.
Qed.

Lemma Qlt_shift_div_r : forall a b c,
 0 < b -> a < c*b -> a/b < c.
Proof.
intros a b c Hc H.
apply Qnot_le_lt.
intros H0.
apply (Qlt_not_le _ _ H).
apply Qmult_lt_0_le_reg_r with (/b).
 apply Qinv_lt_0_compat.
 assumption.
setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with *).
assumption.
Qed.

Lemma Qlt_shift_inv_r : forall b c,
 0 < b -> 1 < c*b -> /b < c.
Proof.
intros b c Hc H.
setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l).
change (1/b < c).
apply Qlt_shift_div_r; assumption.
Qed.

(** * Rational to the n-th power *)

Definition Qpower_positive (q:Q)(p:positive) : Q :=
 pow_pos Qmult q p.

Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive.
Proof.
intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy.
unfold Qpower_positive.
induction y; simpl;
try rewrite IHy;
try rewrite Hx;
reflexivity.
Qed.

Definition Qpower (q:Q) (z:Z) :=
    match z with
      | Zpos p => Qpower_positive q p
      | Z0 => 1
      | Zneg p => /Qpower_positive q p
    end.

Notation " q ^ z " := (Qpower q z) : Q_scope.

Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower.
Proof.
intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy.
destruct y; simpl; rewrite ?Hx; auto with *.
Qed.


From Hammer Require Import Hammer.

Require Import Bool NSub NZParity.

Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N).

Include NZParityProp N N NP.

Lemma odd_pred : forall n, n~=0 -> odd (P n) = even n.
Proof. hammer_hook "NParity" "NParity.NParityProp.odd_pred".
intros. rewrite <- (succ_pred n) at 2 by trivial.
symmetry. apply even_succ.
Qed.

Lemma even_pred : forall n, n~=0 -> even (P n) = odd n.
Proof. hammer_hook "NParity" "NParity.NParityProp.even_pred".
intros. rewrite <- (succ_pred n) at 2 by trivial.
symmetry. apply odd_succ.
Qed.

Lemma even_sub : forall n m, m<=n -> even (n-m) = Bool.eqb (even n) (even m).
Proof. hammer_hook "NParity" "NParity.NParityProp.even_sub".
intros.
case_eq (even n); case_eq (even m);
rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec;
intros (m',Hm) (n',Hn).
exists (n'-m'). now rewrite mul_sub_distr_l, Hn, Hm.
exists (n'-m'-1).
rewrite !mul_sub_distr_l, Hn, Hm, sub_add_distr, mul_1_r.
rewrite two_succ at 5. rewrite <- (add_1_l 1). rewrite sub_add_distr.
symmetry. apply sub_add.
apply le_add_le_sub_l.
rewrite add_1_l, <- two_succ, <- (mul_1_r 2) at 1.
rewrite <- mul_sub_distr_l. rewrite <- mul_le_mono_pos_l by order'.
rewrite one_succ, le_succ_l. rewrite <- lt_add_lt_sub_l, add_0_r.
destruct (le_gt_cases n' m') as [LE|GT]; trivial.
generalize (double_below _ _ LE). order.
exists (n'-m'). rewrite mul_sub_distr_l, Hn, Hm.
apply add_sub_swap.
apply mul_le_mono_pos_l; try order'.
destruct (le_gt_cases m' n') as [LE|GT]; trivial.
generalize (double_above _ _ GT). order.
exists (n'-m'). rewrite Hm,Hn, mul_sub_distr_l.
rewrite sub_add_distr. rewrite add_sub_swap. apply add_sub.
apply succ_le_mono.
rewrite add_1_r in Hm,Hn. order.
Qed.

Lemma odd_sub : forall n m, m<=n -> odd (n-m) = xorb (odd n) (odd m).
Proof. hammer_hook "NParity" "NParity.NParityProp.odd_sub".
intros. rewrite <- !negb_even. rewrite even_sub by trivial.
now destruct (even n), (even m).
Qed.

End NParityProp.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import Bool Lists.List.
Import ListNotations.
Import BoolNotations.
Open Scope list.

From Utils Require Import Base Booleans Eqb Default.

Section __.
  Context (A : Type).

  (* nil_nil not necessary because of reflexivity
  Lemma invert_eq_nil_nil : @nil A = @nil A <-> True.
  Proof.
    solve_invert_constr_eq_lemma.
  Qed.
  Hint Rewrite invert_eq_nil_nil : utils. *)

  Lemma invert_eq_cons_nil (e:A) es : e::es = [] <-> False.
  Proof.
    solve_invert_constr_eq_lemma.
  Qed.
  Hint Rewrite invert_eq_cons_nil : utils.
  Lemma invert_eq_nil_cons (e:A) es : [] =e::es <-> False.
  Proof.
    solve_invert_constr_eq_lemma.
  Qed.
  Hint Rewrite invert_eq_nil_cons : utils.
  Lemma invert_eq_cons_cons (e e':A) es es' : e::es = e'::es' <-> e = e' /\ es = es'.
  Proof.
    solve_invert_constr_eq_lemma.
  Qed.
  Hint Rewrite invert_eq_cons_cons : utils.

  Fixpoint sublist (s l : list A) : Prop :=
    match s,l with
    | [],_ => True
    | sa::s', [] => False
    | sa::s', la::l' =>
        ((sa = la) /\ (sublist s' l')) \/ (sublist s l')
    end.

  Lemma sublist_cons_rest (a:A) l1 l2
    : sublist (a::l1) l2 -> sublist l1 l2.
  Proof using.
    induction l2; destruct l1; basic_goal_prep; basic_utils_crush.
  Qed.
  Hint Resolve sublist_cons_rest : utils.

  Lemma sublist_cons_first (a:A) l1 l2
    : sublist (a::l1) l2 -> In a l2.
  Proof using.
    induction l2; basic_goal_prep; basic_utils_crush.
  Qed.
  Hint Resolve sublist_cons_first : utils.

  Lemma rewrite_sublist_refl l : sublist l l <-> True.
  Proof.
    induction l; basic_goal_prep; basic_utils_crush.
  Qed.
  Hint Rewrite rewrite_sublist_refl : utils.

  Lemma sublist_refl l : sublist l l.
  Proof.
    basic_utils_crush.
  Qed.
  Hint Resolve sublist_refl : utils.

  Lemma sublist_l_cons_l (a:A) l
    : sublist l (a::l).
  Proof.
    simpl.
    destruct l;
      basic_utils_crush.
  Qed.
  Hint Resolve sublist_l_cons_l : utils.

  Lemma rewrite_sublist_nil (l : list A) : sublist [] l <-> True.
  Proof.
    destruct l; simpl; easy.
  Qed.
  Hint Rewrite rewrite_sublist_nil : utils.

  Lemma sublist_nil (l : list A) : sublist [] l.
  Proof.
    destruct l; simpl; easy.
  Qed.
  Hint Resolve sublist_nil : utils.

  (*TODO: check if still needed.
    Original note: redefined to use the right concatenation
  Definition flat_map {B} (f : A -> list B) :=
    fix flat_map l :=
      match l with
      | [] => []
      | x :: t => (f x ++ flat_map t)
      end.
   *)

  Section All.
    Context (P : A -> Prop).

    (* A Fixpoint version of List.Forall *)
    Fixpoint all l : Prop :=
      match l with
      | [] => True
      | e::l' => P e /\ all l'
      end.

    Lemma in_all l a
      : all l -> In a l -> P a.
    Proof.
      induction l; basic_goal_prep; basic_utils_crush.
    Qed.

  End All.

  Definition set_eq (l1 l2 : list A) :=
    incl l1 l2 /\ incl l2 l1.

  Lemma incl_nil (l : list A)
    : incl l [] <-> l = [].
  Proof.
    split; intros; subst;
      eauto using incl_l_nil,
      incl_nil_l.
  Qed.
  Hint Rewrite incl_nil : utils.

  Lemma incl_cons (a:A) l1 l2
    : incl (a::l1) l2 <-> In a l2 /\ incl l1 l2.
  Proof.
    split; intros; break; eauto using incl_cons, incl_cons_inv.
  Qed.
  Hint Rewrite incl_cons : utils.

  #[export] Instance list_default : WithDefault (list A) := [].

  Section Eqb.

    Context `{Eqb_ok A}.

    #[export] Instance list_eqb : Eqb (list A) := all2 (eqb (A:=A)).

    #[export] Instance list_eqb_ok : Eqb_ok (list_eqb).
    Proof.
      unfold Eqb_ok;
        unfold eqb.
      induction a;
        destruct b;
        basic_goal_prep;
        basic_utils_crush.
      my_case Ha (eqb a a1);
        basic_goal_prep;
        basic_utils_crush.
      specialize (IHa b).
      case_match;
        basic_goal_prep;
        basic_utils_crush.
    Qed.

    Definition inb (x : A) := existsb (eqb x).

    Lemma inb_is_In a l
      : Is_true (inb a l) <-> In a l.
    Proof.
      induction l;
        basic_goal_prep;
        basic_utils_crush.
    Qed.

    Fixpoint sublistb (s l : list A) : bool :=
      match s,l with
      | [],_ => true
      | sa::s', [] => false
      | sa::s', la::l' =>
          if eqb sa la then sublistb s' l' else sublistb s l'
      end.

    Lemma use_sublistb (s l : list A)
      : Is_true (sublistb s l) -> sublist s l.
    Proof.
      revert s; induction l; destruct s; basic_goal_prep; try easy.
      revert H1. case_match; basic_utils_crush.
    Qed.

    Fixpoint inclb (l1 l2 : list A) {struct l1} : bool :=
      match l1 with
      | [] => true
      | a::l1' =>
          (inb a l2) && (inclb l1' l2)
      end.

    #[local] Hint Resolve incl_nil_l : utils.
    #[local] Hint Rewrite incl_cons : utils.
    #[local] Hint Rewrite inb_is_In : utils.

    Lemma use_inclb (l1 l2 : list A)
      : Is_true (inclb l1 l2) -> incl l1 l2.
    Proof.
      induction l1;
        basic_goal_prep;
        basic_utils_crush.
    Qed.

  End Eqb.

  (*
  (*TODO: remove, replace with the Eqb version *)
  Fixpoint compute_sublist (dec : forall x y : A, {x = y} + {x <> y})
    (s l : list A) {struct l} :=
    match s,l with
    | [],_ => true
    | sa::s', [] => false
    | sa::s', la::l' => if dec sa la
                        then compute_sublist dec s' l'
                        else compute_sublist dec s l'
    end.

  Lemma use_compute_sublist
    (dec : forall x y : A, {x = y} + {x <> y})
    (s l : list A)
    : compute_sublist dec s l = true -> sublist s l.
  Proof.
    revert s; induction l; destruct s; basic_goal_prep; try easy.
    revert H. case_match; basic_utils_crush.
  Qed.
  *)

End __.

Arguments sublist {A}%type_scope (s l)%list_scope.
Arguments all {A}%type_scope P%function_scope l%list_scope.
Arguments set_eq {A}%type_scope (l1 l2)%list_scope.

Arguments sublistb {A}%type_scope {Eqb_A} (s l)%list_scope : rename.

Arguments use_sublistb {A}%type_scope {H H0} (s l)%list_scope _.
Ltac compute_sublist := apply use_sublistb; vm_compute; exact I.

Arguments use_inclb {A}%type_scope {H H0} (l1 l2)%list_scope _ a _.
Ltac compute_incl := apply use_inclb; vm_compute; exact I.

#[export] Hint Rewrite invert_eq_cons_nil : utils.
#[export] Hint Rewrite invert_eq_nil_cons : utils.
#[export] Hint Rewrite invert_eq_cons_cons : utils.

#[export] Hint Resolve in_nil : utils.
#[export] Hint Resolve in_eq : utils.
#[export] Hint Resolve in_cons : utils.

#[export] Hint Rewrite map_length : utils.
#[export] Hint Rewrite in_app_iff : utils.
#[export] Hint Rewrite app_nil_r : utils.

#[export] Hint Resolve sublist_cons_rest : utils.
#[export] Hint Resolve sublist_cons_first : utils.

#[export] Hint Rewrite rewrite_sublist_refl : utils.
#[export] Hint Resolve sublist_refl : utils.

#[export] Hint Resolve sublist_l_cons_l : utils.

#[export] Hint Rewrite rewrite_sublist_nil : utils.
#[export] Hint Resolve sublist_nil : utils.

#[export] Hint Rewrite incl_nil : utils.
#[export] Hint Rewrite incl_cons : utils.

#[export] Hint Resolve incl_appr : utils.
#[export] Hint Resolve incl_refl : utils.
#[export] Hint Resolve incl_app : utils.
#[export] Hint Resolve incl_appl : utils.
#[export] Hint Resolve incl_tl : utils.

#[export] Hint Rewrite inb_is_In using solve[typeclasses eauto] : utils.


Require Import List.
Import ListNotations.

Require Import IFOL.Util.Witness.
Require Import IFOL.Util.List_index.

(*
Inductive BList {X} (Y : list X -> Type) : list X -> Type :=
  | bnil : BList Y nil
  | bcons {xs} : Y xs -> BList Y xs -> BList Y xs
  | bump {xs} x : BList Y xs -> BList Y (cons x xs).

Arguments bnil {_} {_}.
Arguments bcons {_} {_} {_} _ _.
Arguments bump {_} {_} {_} _ _.

Inductive bindex {X} {Y : list X -> Type} :
  forall {xs}, BList Y xs -> Type :=
  | biz {xs} {y} {ys : BList Y xs} : bindex (bcons y ys)
  | bis {xs} {y} {ys : BList Y xs} :
      bindex ys -> bindex (bcons y ys)
  | bibump {xs} {ys : BList Y xs} {x} :
      bindex ys -> bindex (bump x ys).

Record bindex_result {X} {Y} {xs : list X} (ys : BList Y xs) : Type := {
  suff : list X;
  suff_wit : suffix_wit suff xs;
  data : Y suff
  }.

Fixpoint bl_proj {X} {Y : list X -> Type} {xs}
  (ys : BList Y xs) (i : bindex ys) : bindex_result ys.
Proof.
  destruct i eqn:?.
  - econstructor.
    2:{ exact y. }
    apply sw_refl.
  - epose (bl_proj X Y xs ys b).
    destruct b0.
    econstructor.
    2:{ exact data0. }
    exact suff_wit0.
  - epose (bl_proj X Y xs ys b).
    destruct b0.
    econstructor.
    apply sw_cons.
    exact suff_wit0.
    exact data0.
Defined.
 *)

Fixpoint BList {X} (Y : list X -> Type) (xs : list X) : Type :=
  match xs with
  | [] => list (Y [])
  | x :: xs' => list (Y xs) * (BList Y xs')
  end.

Definition bnil {X} {Y : list X -> Type} : BList Y nil :=
  nil.

Definition bcons {X} {Y : list X -> Type} {xs : list X}
  : Y xs -> BList Y xs -> BList Y xs :=
  match xs with
  | [] => cons
  | x :: xs' => fun y ys =>
    match ys with
    | (ys, ys') => (y :: ys, ys')
    end
  end.

Definition bump {X} {Y : list X -> Type} {xs : list X} (x : X) :
  BList Y xs -> BList Y (cons x xs) :=
  pair nil.

Fixpoint bindex {X} {Y : list X -> Type} {xs} : BList Y xs -> Type :=
  match xs with
  | [] => list_index
  | _ :: _ => fun '(l, b) => (list_index l + bindex b)%type
  end.

Record bindex_result {X} {Y} {xs : list X} (ys : BList Y xs) : Type := {
  suff : list X;
  suff_wit : suffix_wit suff xs;
  data : Y suff
  }.

Fixpoint bl_proj {X} {Y : list X -> Type} {xs} :
  forall ys : BList Y xs, bindex ys -> bindex_result ys.
Proof.
  destruct xs.
  - intros.
    simpl in *.
    econstructor.
    2:{ exact (list_proj ys X0). }
    constructor.
  - intros.
    simpl in *.
    destruct ys.
    destruct X0.
    + econstructor.
      2:{ exact (list_proj l l0). }
      apply sw_refl.
    + destruct (bl_proj X Y xs b b0).
      econstructor.
      2:{ exact data0. }
      apply sw_cons.
      exact suff_wit0.
Defined.


From Hammer Require Import Hammer.

Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Relations_2.
Require Export Relations_2_facts.
Require Export Relations_3.

Theorem Rstar_imp_coherent :
forall (U:Type) (R:Relation U) (x y:U), Rstar U R x y -> coherent U R x y.
Proof. hammer_hook "Relations_3_facts" "Relations_3_facts.Rstar_imp_coherent".
intros U R x y H'; red.
exists y; auto with sets.
Qed.
Hint Resolve Rstar_imp_coherent.

Theorem coherent_symmetric :
forall (U:Type) (R:Relation U), Symmetric U (coherent U R).
Proof. hammer_hook "Relations_3_facts" "Relations_3_facts.coherent_symmetric".
unfold coherent at 1.
intros U R; red.
intros x y H'; elim H'.
intros z H'0; exists z; tauto.
Qed.

Theorem Strong_confluence :
forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
Proof. hammer_hook "Relations_3_facts" "Relations_3_facts.Strong_confluence".
intros U R H'; red.
intro x; red; intros a b H'0.
unfold coherent at 1.
generalize b; clear b.
elim H'0; clear H'0.
intros x0 b H'1; exists b; auto with sets.
intros x0 y z H'1 H'2 H'3 b H'4.
generalize (Lemma1 U R); intro h; lapply h;
[ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0;
[ intro H'5; generalize (H'5 y); intro h1; lapply h1;
[ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7;
clear h h0 h1 h2 h3
| clear h h0 h1 ]
| clear h h0 ]
| clear h ]; auto with sets.
generalize (H'3 z0); intro h; lapply h;
[ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1
| clear h ]; auto with sets.
exists z1; split; auto with sets.
apply Rstar_n with z0; auto with sets.
Qed.

Theorem Strong_confluence_direct :
forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
Proof. hammer_hook "Relations_3_facts" "Relations_3_facts.Strong_confluence_direct".
intros U R H'; red.
intro x; red; intros a b H'0.
unfold coherent at 1.
generalize b; clear b.
elim H'0; clear H'0.
intros x0 b H'1; exists b; auto with sets.
intros x0 y z H'1 H'2 H'3 b H'4.
cut (ex (fun t:U => Rstar U R y t /\ R b t)).
intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0.
generalize (H'3 t); intro h; lapply h;
[ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1
| clear h ]; auto with sets.
exists z0; split; [ assumption | idtac ].
apply Rstar_n with t; auto with sets.
generalize H'1; generalize y; clear H'1.
elim H'4.
intros x1 y0 H'0; exists y0; auto with sets.
intros x1 y0 z0 H'0 H'1 H'5 y1 H'6.
red in H'.
generalize (H' x1 y0 y1); intro h; lapply h;
[ intro H'7; lapply H'7;
[ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9;
clear h H'7 h0 h1
| clear h ]
| clear h ]; auto with sets.
generalize (H'5 z1); intro h; lapply h;
[ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1
| clear h ]; auto with sets.
exists t; split; auto with sets.
apply Rstar_n with z1; auto with sets.
Qed.

Theorem Noetherian_contains_Noetherian :
forall (U:Type) (R R':Relation U),
Noetherian U R -> contains U R R' -> Noetherian U R'.
Proof. hammer_hook "Relations_3_facts" "Relations_3_facts.Noetherian_contains_Noetherian".
unfold Noetherian at 2.
intros U R R' H' H'0 x.
elim (H' x); auto with sets.
Qed.

Theorem Newman :
forall (U:Type) (R:Relation U),
Noetherian U R -> Locally_confluent U R -> Confluent U R.
Proof. hammer_hook "Relations_3_facts" "Relations_3_facts.Newman".
intros U R H' H'0; red; intro x.
elim (H' x); unfold confluent.
intros x0 H'1 H'2 y z H'3 H'4.
generalize (Rstar_cases U R x0 y); intro h; lapply h;
[ intro h0; elim h0;
[ clear h h0; intro h1
| intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6;
clear h h0 h1 h2 ]
| clear h ]; auto with sets.
elim h1; auto with sets.
generalize (Rstar_cases U R x0 z); intro h; lapply h;
[ intro h0; elim h0;
[ clear h h0; intro h1
| intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8;
clear h h0 h1 h2 ]
| clear h ]; auto with sets.
elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets.
unfold Locally_confluent, locally_confluent, coherent in H'0.
generalize (H'0 x0 u v); intro h; lapply h;
[ intro H'9; lapply H'9;
[ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11;
clear h H'9 h0 h1
| clear h ]
| clear h ]; auto with sets.
clear H'0.
unfold coherent at 1 in H'2.
generalize (H'2 u); intro h; lapply h;
[ intro H'0; generalize (H'0 y t); intro h0; lapply h0;
[ intro H'9; lapply H'9;
[ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13;
clear h h0 H'9 h1 h2
| clear h h0 ]
| clear h h0 ]
| clear h ]; auto with sets.
generalize Rstar_transitive; intro T; red in T.
generalize (H'2 v); intro h; lapply h;
[ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0;
[ intro H'14; lapply H'14;
[ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16;
clear h h0 H'14 h1 h2
| clear h h0 ]
| clear h h0 ]
| clear h ]; auto with sets.
red; (exists z1; split); auto with sets.
apply T with y1; auto with sets.
apply T with t; auto with sets.
Qed.


Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Bedrock.Decidables.

Set Implicit Arguments.
Set Strict Implicit.

(* Some tactics for automation of later proofs *)
Ltac caseDestruct t := destruct t; try solve [ simpl in *; discriminate ].

Ltac dintuition := repeat (intuition;
  match goal with
    | [ H : exists _, _ |- _ ] => destruct H
  end).

Ltac unlet := repeat match goal with
                       | [ x := ?y |- _ ] => subst x
                     end.

Ltac hypRewriter := repeat match goal with
                              | [ H : ?x = _ |- context [ ?x ] ] => rewrite H
                              | [ H1 : ?x = _, H2 : context [ ?x ] |- _ ] => rewrite H1 in H2
                            end.

Ltac loop := repeat (repeat (hypRewriter; autorewrite with provers in *); simpl in *; subst; dintuition).

Ltac provers := intuition; loop; unlet; loop; try congruence; firstorder.

(* null hint to initialize db *)
Hint Rewrite app_nil_l : provers.

Section UpdateAt.
  Variable A : Type.

  Variable new default : A.

  Fixpoint updateAt (ls : list A) (n : nat) : list A :=
    match n with
      | 0 => new :: tail ls
      | S n => match head ls with
                 | None => default
                 | Some v => v
               end :: updateAt (tail ls) n
    end.

  Definition defaulted (ls : list A) (n : nat) (n' : nat) : option A :=
    match Compare_dec.lt_eq_lt_dec n n' with
      | inleft (left _) => nth_error ls n'
      | inleft (right _) => Some new
      | inright _ => match nth_error ls n' with
                       | None => Some default
                       | Some v => Some v
                     end
    end.

  Require Import Coq.omega.Omega.
  Lemma nth_error_updateAt : forall n l,
    nth_error (updateAt l n) n = value new.
    induction n; destruct l; simpl; (reflexivity || apply IHn).
  Defined.

  Lemma nth_error_updateAt_not : forall old n' ls n,
    n <> n' ->
    nth_error ls n = Some old ->
    nth_error (updateAt ls n') n = Some old.
  Proof.
    induction n'; destruct ls; destruct n; simpl; intros; try solve [ discriminate | exfalso; auto | auto ].
  Qed.

  Lemma nth_error_updateAt_gt : forall n n' ls,
    n < n' ->
    nth_error (updateAt ls n) n' = nth_error ls n'.
  Proof.
    induction n; simpl; intros.
      destruct n'; destruct ls; simpl; intros; try solve [ auto | exfalso; omega | destruct n'; reflexivity ].

      destruct n'. exfalso; omega.
        destruct ls; simpl. rewrite IHn. destruct n'; auto. omega.
        apply IHn. omega.
  Defined.

  Lemma nth_error_updateAt_lt : forall n' n ls,
    n' < n ->
    nth_error (updateAt ls n) n' =
      match nth_error ls n' with
        | None => Some default
        | Some v => Some v
      end.
  Proof.
    induction n'; simpl; intros.
      destruct n; [ exfalso; omega | ]. destruct ls; auto.
      destruct n; [ exfalso; omega | ]. destruct ls; simpl; rewrite IHn' by omega. destruct n'; auto.
      auto.
  Defined.

  Theorem nth_error_updateAt_eq : forall n ls n',
    nth_error (updateAt ls n) n' = defaulted ls n n'.
  Proof.
    unfold defaulted; intros.
      destruct (lt_eq_lt_dec n n'). destruct s.
      eapply nth_error_updateAt_gt; auto.
      subst; eapply nth_error_updateAt; auto.
      eapply nth_error_updateAt_lt; auto.
  Defined.

  (** **)
  Fixpoint cast (P : option A -> Type) ls idx
    : P (nth_error (updateAt ls idx) idx) -> P (Some new) :=
    match idx with
      | O => match ls
             return P (nth_error (updateAt ls O) O) -> _ with
               | nil => fun x => x
               | _ => fun x => x
             end
      | S idx =>
        match ls return P (nth_error (updateAt ls (S idx)) (S idx)) -> _ with
          | nil => cast P nil idx
          | _ => cast P _ idx
        end
    end.

  Theorem cast_inj : forall P idx ls x y, cast P ls idx x = cast P ls idx y -> x = y.
  Proof.
    induction idx; destruct ls; simpl; intros; auto.
  Qed.

End UpdateAt.

Section UpdatePosition2.
  Variable A : Type.

  Hint Rewrite nth_error_updateAt : provers.
  Lemma nth_error_updateAt_2 : forall A (ls : list A) d d' a b m n,
    m <> n ->
    nth_error (updateAt a d (updateAt b d' ls n) m) n = value b.
    induction ls; induction m; induction n; provers.
  Qed.
End UpdatePosition2.

(*
Section MapRepr.
  Variable T : Type.
  Record Repr : Type :=
  { footprint : list (nat * T)
  ; default : T
  }.

  Definition nil_Repr (d : T) : Repr :=
  {| footprint := nil
   ; default := d
   |}.

  Definition listToRepr (ls : list T) (d : T) : Repr :=
    {| footprint :=
      ((fix listToRepr ls cur : list (nat * T) :=
        match ls with
          | nil => nil
          | l :: ls => (cur, l) :: listToRepr ls (S cur)
        end) ls 0)
     ; default := d
     |}.

  Definition listOptToRepr (ls : list (option T)) (d : T) : Repr :=
    {| footprint :=
      ((fix listToRepr ls cur : list (nat * T) :=
        match ls with
          | nil => nil
          | Some l :: ls => (cur, l) :: listToRepr ls (S cur)
          | None :: ls => listToRepr ls (S cur)
        end) ls 0)
     ; default := d
     |}.

  Fixpoint repr' (d : T) (ls : list (nat * T)) : list T -> list T :=
    match ls with
      | nil => fun x => x
      | (n, v) :: ls =>
        fun x => updateAt v d (repr' d ls x) n
    end.

  Section get.
    Variable n : nat.

    Fixpoint get (ls : list (nat * T)) : option T :=
      match ls with
        | nil => None
        | (n',v) :: ls =>
          if Peano_dec.eq_nat_dec n n' then Some v else get ls
      end.
  End get.

  Definition repr (l : Repr) : list T -> list T :=
    match l with
      | {| footprint := f ; default := d |} =>
        repr' d f
    end.

  Fixpoint nat_eq_bool (a b : nat) : bool :=
    match a , b with
      | 0 , 0 => true
      | S a , S b => nat_eq_bool a b
      | _ , _ => false
    end.

  Fixpoint nat_in (l : list nat) (n : nat) : bool :=
    match l with
      | nil => false
      | a :: b => if nat_eq_bool a n then true else nat_in b n
    end.

  Fixpoint repr_optimize (l : list (nat * T)) (ignore : list nat) : list (nat * T) :=
    match l with
      | nil => nil
      | (n,t) :: b =>
        if nat_in ignore n then
          repr_optimize b ignore
        else
          (n,t) :: repr_optimize b (n :: ignore)
    end.

  Definition repr_combine (l r : Repr) : Repr :=
    match l , r with
      | {| footprint := lf ; default := ld |} ,
        {| footprint := rf ; default := rd |} =>
        {| footprint := repr_optimize (lf ++ rf) nil ; default := ld |}
    end.
  (** NOTE: that we don't have any lemmas for combination because we are
   ** relying on Ltac's dynamic types to do combinations
   **)

  Definition repr_get (l : Repr) (n : nat) : option T :=
    get n (footprint l).

End MapRepr.
*)

(** This is an alternative representation
 ** 1) it avoids nats (including comparison)
 ** 2) it is canonical
 ** 3) it optimizes the common case of prefixes
 **)
Section Repr2.
  Section parametric.
    Variable T : Type.
    Record Repr : Type :=
    { footprint : list (option T)
    ; default : T
    }.

    Definition nil_Repr (d : T) : Repr :=
      {| footprint := nil
       ; default := d
      |}.

    Definition listToRepr (ls : list T) (d : T) : Repr :=
      {| footprint := map (@Some _) ls
       ; default := d
      |}.

    Definition listOptToRepr (ls : list (option T)) (d : T) : Repr :=
      {| footprint := ls
       ; default := d
      |}.

    Fixpoint repr' (d : T) (ls : list (option T)) : list T -> list T :=
      match ls with
        | nil => fun x => x
        | None :: ls => fun x =>
          match x with
            | nil => d
            | a :: _ => a
          end :: repr' d ls (tl x)
        | Some v :: ls => fun x =>
          v :: repr' d ls (tl x)
      end.

    Definition repr (l : Repr) : list T -> list T :=
      Eval cbv delta [ repr' ] in
        match l with
          | {| footprint := f ; default := d |} =>
            repr' d f
        end.

    Fixpoint join (ls rs : list (option T)) : list (option T) :=
      match ls , rs with
        | nil , rs => rs
        | ls , nil => ls
        | l :: ls , r :: rs =>
          match l with
            | Some _ => l
            | None => r
          end :: join ls rs
      end.

    Definition repr_combine (l r : Repr) : Repr :=
      Eval cbv delta [ join ] in
        match l , r with
          | {| footprint := lf ; default := ld |} ,
            {| footprint := rf ; default := rd |} =>
            {| footprint := join lf rf ; default := ld |}
        end.

    Lemma repr_idempotent : forall a b,
      repr a (repr a b) = repr a b.
    Proof.
      clear. destruct a.
      simpl. induction footprint0; simpl; intros; auto.
      destruct a; simpl; auto. f_equal. rewrite IHfootprint0. auto.
      destruct b; auto. rewrite IHfootprint0; auto. simpl.
      rewrite IHfootprint0. auto.
    Qed.

  End parametric.
End Repr2.

Ltac reduce_repr_list ls :=
  eval cbv beta zeta delta [
    repr_combine repr listOptToRepr listToRepr nil_Repr
    map
  ] in ls.


Require Import Utils.
From RelationAlgebra Require Export ordinal lattice level sups sums comparisons.

Open Scope ltb_scope.

Section index_of.
  Context {A : Type}.
  Context `{EqDec A eq}.
  Context (a : A).

  Fixpoint index_of (xs : list A) : option (ord (length xs)) :=
    match xs with
    | [] => None
    | x :: xs =>
      if a ==b x then Some ord0
      else option_map ordS (index_of xs)
    end.

  Lemma In_index_of xs (HIn : In a xs) :
    exists i, index_of xs = Some i.
  Proof using.
    induction xs as [| x xs IHxs ]. { inv HIn. }
    simpls. case equiv_decbP; ins; subst.
    { now eexists. }
    desf. destruct IHxs as [? IH]; auto.
    rewrite IH. now eexists.
  Qed.

  Lemma index_of_nth xs i
    (Hindex : index_of xs = Some i) :
      nth_error xs i = Some a.
  Proof using.
    gen_dep i.
    induction xs as [| x xs IHxs ]; ins.
    unfold option_map in *.
    destruct (equiv_decbP a x); desf.
    simpls. auto.
  Qed.

  Lemma index_of_In xs i
    (Hindex : index_of xs = Some i) :
      In a xs.
  Proof using.
    eapply nth_error_In, index_of_nth, Hindex.
  Qed.

  Lemma index_of_In_iff xs :
    In a xs <-> exists i, index_of xs = Some i.
  Proof using.
    split; ins.
    { now apply In_index_of. }
    { desf. eauto using index_of_In. }
  Qed.
End index_of.

(* TODO: prove that nat is a lattice *)

Canonical Structure nat_lattice_ops: lattice.ops := {|
  leq := fun i j => i <= j;
  weq := eq;
  cup := max;
  cap := min;
  bot := 0;
  neg := id; (* this is a stub *)
  top := 1; (* this is a stub *)
|}.

Theorem ltb_succ (x y : nat) : x <= y <-> x < S y.
Proof.
  split; ins; gen_dep y.
  all: induction x; ins; destruct y; simpls; auto.
  destruct x; auto.
Qed.

Theorem leb_refl (n : nat) : n <= n.
Proof. induction n; auto. Qed.

Theorem leb_trans (x y z : nat)
  (H1 : x <= y) (H2 : y <= z) : x <= z.
Proof.
  gen_dep y x.
  induction z; ins; destruct y, x; simpls.
  eauto.
Qed.

Theorem leb_antisym (x y : nat)
  (H1 : x <= y) (H2 : y <= x) : x = y.
Proof.
  gen_dep x.
  induction y; ins; destruct x; simpls.
  f_equal. eauto.
Qed.

Theorem max_leb (x y z : nat)
  (H1 : x <= z) (H2 : y <= z) : max x y <= z.
Proof.
  gen_dep x y.
  induction z; ins; destruct x, y; simpls.
  auto.
Qed.

Theorem max_leb_l (x y z : nat)
  (H : max x y <= z) : x <= z.
Proof.
  gen_dep x y.
  induction z; ins; destruct x, y; simpls.
  eauto.
Qed.

Theorem max_leb_r (x y z : nat)
  (H : max x y <= z) : y <= z.
Proof.
  gen_dep x y.
  induction z; ins; destruct x, y; simpls.
  eauto.
Qed.

Theorem max_leb_iff (x y z : nat) :
  max x y <= z <-> x <= z /\ y <= z.
Proof.
  split; ins.
  { split; eauto using max_leb_l, max_leb_r. }
  { desf. eauto using max_leb. }
Qed.

Theorem leb_min (x y z : nat)
  (H1 : z <= x) (H2 : z <= y) : z <= min x y.
Proof.
  gen_dep x y.
  induction z; ins; destruct x, y; simpls.
  auto.
Qed.

Theorem leb_min_l (x y z : nat)
  (H : z <= min x y) : z <= x.
Proof.
  gen_dep x y.
  induction z; ins; destruct x, y; simpls.
  eauto.
Qed.

Theorem leb_min_r (x y z : nat)
  (H : z <= min x y) : z <= y.
Proof.
  gen_dep x y.
  induction z; ins; destruct x, y; simpls.
  eauto.
Qed.

Theorem leb_min_iff (x y z : nat) :
  z <= min x y <-> z <= x /\ z <= y.
Proof.
  split; ins.
  { split; eauto using leb_min_l, leb_min_r. }
  { desf. eauto using leb_min. }
Qed.

Theorem min_leb_l (x y : nat) : min x y <= x.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
Qed.

Theorem min_leb_r (x y : nat) : min x y <= y.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
Qed.

Theorem leb_max_l (x y : nat) : x <= max x y.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
  apply leb_refl.
Qed.

Theorem leb_max_r (x y : nat) : y <= max x y.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
  apply leb_refl.
Qed.

Theorem zro_leb (x : nat) : 0 <= x.
Proof. induction x; auto. Qed.

Theorem min_leb_max (x y : nat) : min x y <= max x y.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
Qed.

Theorem max_comm (x y : nat) : max x y = max y x.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
  f_equal. eauto.
Qed.

Theorem max_assoc (x y z : nat) : max x (max y z) = max (max x y) z.
Proof.
  gen_dep y z; induction x; ins; destruct y, z; simpls.
  f_equal. eauto.
Qed.

Theorem max_idemp (x : nat) : max x x = x.
Proof.
  induction x; ins; simpls.
  f_equal. eauto.
Qed.

Theorem min_comm (x y : nat) : min x y = min y x.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
  f_equal. eauto.
Qed.

Theorem min_assoc (x y z : nat) : min x (min y z) = min (min x y) z.
Proof.
  gen_dep y z; induction x; ins; destruct y, z; simpls.
  f_equal. eauto.
Qed.

Theorem min_idemp (x : nat) : min x x = x.
Proof.
  induction x; ins; simpls.
  f_equal. eauto.
Qed.

Theorem max_min_distr (x y z : nat) : max (min x y) (min x z) = min x (max y z).
Proof.
  gen_dep y z; induction x; ins; destruct y, z; simpls.
  f_equal. eauto.
Qed.

Theorem min_max_cancel (x y : nat) : min x (max x y) = x.
Proof.
  gen_dep y; induction x; ins; destruct y; simpls.
  all: f_equal; eauto.
  { apply min_idemp. }
Qed.

Theorem min_max_distr (x y z : nat) : min (max x y) (max x z) = max x (min y z).
Proof.
  gen_dep y z; induction x; ins; destruct y, z; simpls.
  all: f_equal.
  { apply min_idemp. }
  { apply min_max_cancel. }
  { rewrite min_comm. apply min_max_cancel. }
  eauto.
Qed.

Theorem leb_max_eq_l_iff (x y : nat) :
  max x y = x <-> y <= x.
Proof.
  split; ins.
  { gen_dep y. induction x; intros [|y]; ins.
    desf; auto. }
  apply leb_antisym.
  { eapply max_leb; auto using leb_refl. }
  { eapply leb_max_l. }
Qed.

Theorem leb_max_eq_r_iff (x y : nat) :
  max x y = y <-> x <= y.
Proof.
  rewrite max_comm. apply leb_max_eq_l_iff.
Qed.

Theorem leb_min_eq_l_iff (x y : nat) :
  min x y = x <-> x <= y.
Proof.
  split; ins.
  { gen_dep y. induction x; intros [|y]; ins.
    desf; auto. }
  apply leb_antisym.
  { eapply min_leb_l. }
  { eapply leb_min; auto using leb_refl. }
Qed.

Theorem leb_min_eq_r_iff (x y : nat) :
  min x y = y <-> y <= x.
Proof.
  rewrite min_comm. apply leb_min_eq_l_iff.
Qed.

#[global]
Instance nat_lattice_laws: lattice.laws (CUP + CAP + BOT) nat_lattice_ops.
Proof.
  constructor; ins.
  { constructor.
    { unfold Reflexive. apply leb_refl. }
    { unfold Transitive. apply leb_trans. } }
  { simpls. intros.
    split.
    { ins; subst. split; apply leb_refl. }
    { intros []. now apply leb_antisym. } }
  { apply max_leb_iff. }
  { apply leb_min_iff. }
  { right. apply zro_leb. }
  { rewrite min_max_distr. apply leb_refl. }
Qed.

Theorem eqb_eq_iff (A: cmpType) (x y : A) : eqb x y <-> x = y.
Proof.
  split; ins.
  { apply eqb_eq. auto. }
  { subst. apply eqb_refl. }
Qed.

From RelationAlgebra Require Import bmx matrix monoid boolean.
Local Open Scope ra_terms.

Lemma andb_is_true_iff a b :
  a && b <-> a /\ b.
Proof.
  unfold is_true.
  now rewrite Bool.andb_true_iff.
Qed.

Lemma bmx_one_spec n i j :
  (mx_one bool_ops bool_tt n) i j <-> i = j.
Proof.
  simpl. unfold mx_one.
  unfold eqb_ord, ofbool, is_true. simpl.
  split; ins; desf; desf.
  now apply eq_ord.
Qed.

Lemma bmx_dot_spec n m q i j (a : bmx n m) (b : bmx m q) :
  ((mx_dot _ _ _ _ _) a b) i j <-> exists k, a i k /\ b k j.
Proof.
  unfold mx_dot.
  rewrite is_true_sup. simpl.
  setoid_rewrite andb_is_true_iff.
  split; ins; desf.
  all: eauto using in_seq.
Qed.