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

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

Print Assumptions add.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* Definitions for public key encryption. *)

Set Implicit Arguments.
Require Import fcf.FCF.

Local Open Scope rat_scope.

Section IND_CPA.

  Variable Plaintext : Set.
  Variable Ciphertext : Set.
  Variable PrivateKey : Set.
  Variable PublicKey : Set.

  Variable KeyGen : Comp (PrivateKey * PublicKey).
  Variable Encrypt : Plaintext -> PublicKey -> Comp Ciphertext.

  Variable A_state : Set.
  Variable A1 : PublicKey -> Comp (Plaintext * Plaintext * A_state).
  Variable A2 : (Ciphertext * A_state) -> Comp bool.

  Definition IND_CPA_G :=
    [prikey, pubkey] <-$2 KeyGen;
    [p0, p1, a_state] <-$3 (A1 pubkey);
    b <-$ {0, 1};
    pb <- if b then p0 else p1;
                         c <-$ (Encrypt pb pubkey);
                         b' <-$ (A2 (c, a_state));
                         ret (eqb b b').

  Definition IND_CPA_Advantage := | Pr[IND_CPA_G] - 1 / 2 |.

  Definition IND_CPA (epsilon : Rat) :=
    | Pr[IND_CPA_G] - 1 / 2 | <= epsilon.

End IND_CPA.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult (Succ lv0) lv1) (plus (mult lv0 lv1) lv1)).
Admitted.
QuickChick conj14synthconj5.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *)

From Coq Require Import Lia.
Require Import Raux Defs Generic_fmt Float_prop Digits Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_div.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real quotient of the
    input floating-point numbers.

The algorithm performs the following steps:
- Shift dividend mantissa so that it has at least p2 + p digits.
- Perform the Euclidean division.
- Compute the position according to the division remainder.

Complexity is fine as long as p1 <= 2p and p2 <= p.
*)

Lemma mag_div_F2R :
  forall m1 e1 m2 e2,
  (0 < m1)%Z -> (0 < m2)%Z ->
  let e := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
  (e <= mag beta (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) <= e + 1)%Z.
Proof.
intros m1 e1 m2 e2 Hm1 Hm2.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
rewrite <- (mag_F2R_Zdigits beta m2 e2) by now apply Zgt_not_eq.
apply mag_div.
now apply F2R_neq_0, Zgt_not_eq.
now apply F2R_neq_0, Zgt_not_eq.
Qed.

Definition Fdiv_core m1 e1 m2 e2 e :=
  let (m1', m2') :=
    if Zle_bool e (e1 - e2)%Z
    then (m1 * Zpower beta (e1 - e2 - e), m2)%Z
    else (m1, m2 * Zpower beta (e - (e1 - e2)))%Z in
  let '(q, r) :=  Z.div_eucl m1' m2' in
  (q, new_location m2' r loc_Exact).

Theorem Fdiv_core_correct :
  forall m1 e1 m2 e2 e,
  (0 < m1)%Z -> (0 < m2)%Z ->
  let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
  inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l.
Proof.
intros m1 e1 m2 e2 e Hm1 Hm2.
unfold Fdiv_core.
match goal with |- context [if ?b then ?b1 else ?b2] => set (m12 := if b then b1 else b2) end.
case_eq m12 ; intros m1' m2' Hm.
assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * bpow e)%R /\ (0 < m2')%Z) as [Hf Hm2'].
{ unfold F2R, Zminus ; simpl.
  destruct (Zle_bool e (e1 - e2)) eqn:He' ; injection Hm ; intros ; subst.
  - split ; try easy.
    apply Zle_bool_imp_le in He'.
    rewrite mult_IZR, IZR_Zpower by lia.
    unfold Zminus ; rewrite 2!bpow_plus, 2!bpow_opp.
    field.
    repeat split ; try apply Rgt_not_eq, bpow_gt_0.
    now apply IZR_neq, Zgt_not_eq.
  - apply Z.leb_gt in He'.
    split ; cycle 1.
    { apply Z.mul_pos_pos with (1 := Hm2).
      apply Zpower_gt_0 ; lia. }
    rewrite mult_IZR, IZR_Zpower by lia.
    unfold Zminus ; rewrite bpow_plus, bpow_opp, bpow_plus, bpow_opp.
    field.
    repeat split ; try apply Rgt_not_eq, bpow_gt_0.
    now apply IZR_neq, Zgt_not_eq. }
clearbody m12 ; clear Hm Hm1 Hm2.
generalize (Z_div_mod m1' m2' (Z.lt_gt _ _ Hm2')).
destruct (Z.div_eucl m1' m2') as (q, r).
intros (Hq, Hr).
rewrite Hf.
unfold inbetween_float, F2R. simpl.
rewrite Hq, 2!plus_IZR, mult_IZR.
apply inbetween_mult_compat.
  apply bpow_gt_0.
destruct (Z_lt_le_dec 1 m2') as [Hm2''|Hm2''].
- replace 1%R with (IZR m2' * /IZR m2')%R.
  apply new_location_correct ; try easy.
  apply Rinv_0_lt_compat.
  now apply IZR_lt.
  constructor.
  field.
  now apply IZR_neq, Zgt_not_eq.
  field.
  now apply IZR_neq, Zgt_not_eq.
- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; lia).
  unfold Rdiv.
  rewrite Rmult_1_l, Rplus_0_r, Rinv_1, Rmult_1_r.
  now constructor.
Qed.

Definition Fdiv (x y : float beta) :=
  let (m1, e1) := x in
  let (m2, e2) := y in
  let e' := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
  let e := Z.min (Z.min (fexp e') (fexp (e' + 1))) (e1 - e2) in
  let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
  (m, e, l).

Theorem Fdiv_correct :
  forall x y,
  (0 < F2R x)%R -> (0 < F2R y)%R ->
  let '(m, e, l) := Fdiv x y in
  (e <= cexp beta fexp (F2R x / F2R y))%Z /\
  inbetween_float beta m e (F2R x / F2R y) l.
Proof.
intros [m1 e1] [m2 e2] Hm1 Hm2.
apply gt_0_F2R in Hm1.
apply gt_0_F2R in Hm2.
unfold Fdiv.
generalize (mag_div_F2R m1 e1 m2 e2 Hm1 Hm2).
set (e := Zminus _ _).
set (e' := Z.min (Z.min (fexp e) (fexp (e + 1))) (e1 - e2)).
intros [H1 H2].
generalize (Fdiv_core_correct m1 e1 m2 e2 e' Hm1 Hm2).
destruct Fdiv_core as [m' l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
destruct (Zle_lt_or_eq _ _ H1) as [H|H].
- replace (fexp (mag _ _)) with (fexp (e + 1)).
  apply Z.le_min_r.
  clear -H1 H2 H ; apply f_equal ; lia.
- replace (fexp (mag _ _)) with (fexp e).
  apply Z.le_min_l.
  clear -H1 H2 H ; apply f_equal ; lia.
Qed.

End Fcalc_div.


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(** This library reexports portions of the Coq standard libraries used
    throughtout the proof.  It also defines some convenience tactics.
 *)
Require Export VST.msl.Extensionality.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Relations.Relations.
Require Export Lia.

Definition compose (A B C:Type) (g:B -> C) (f:A -> B) := fun x => g (f x).
Arguments compose [A B C] _ _ _.
Infix "oo" := compose (at level 54, right associativity).

Lemma compose_assoc (A B C D:Type) (h:C->D) (g:B->C) (f:A->B) :
  (h oo g) oo f = h oo g oo f.
Proof.
  intros; apply extensionality; intro x; unfold compose; auto.
Qed.

Lemma compose_rewr {A B C} (f : B -> C) (g : A -> B) x : f (g x) = (f oo g) x.
Proof.
  reflexivity.
Qed.

Definition id (A:Type) := fun x:A => x.

Lemma id_unit1 : forall A B (f:A->B), f oo id A = f.
Proof.
  intros; apply extensionality; intro x; auto.
Qed.

Lemma id_unit2 : forall A B (f:A->B), id B oo f = f.
Proof.
  intros; apply extensionality; intro x; auto.
Qed.

Record bijection (A B:Type) : Type := Bijection {
  bij_f: A -> B;
  bij_g: B -> A;
  bij_fg: forall x, bij_f (bij_g x) = x;
  bij_gf: forall x, bij_g (bij_f x) = x
}.

Lemma bij_f_inj {A} {B} (bij: bijection A B):
     forall x y, bij_f _ _ bij x = bij_f _ _ bij y -> x=y.
Proof.
intros. rewrite <- (bij_gf _ _ bij x). rewrite <- (bij_gf _ _ bij y).
 rewrite H; auto.
Qed.

Lemma bij_g_inj {A} {B} (bij: bijection A B):
     forall x y, bij_g _ _ bij x = bij_g _ _ bij y -> x=y.
Proof.
intros. rewrite <- (bij_fg _ _ bij x). rewrite <- (bij_fg _ _ bij y).
 rewrite H; auto.
Qed.

Lemma bij_fg_id: forall {A B} (f: bijection A B),
  (bij_f _ _ f) oo (bij_g _ _ f) = id _.
Proof.
  intros.
  extensionality.
  unfold compose, id.
  apply bij_fg.
Qed.

Lemma bij_gf_id: forall {A B} (f: bijection A B),
  (bij_g _ _ f) oo (bij_f _ _ f) = id _.
Proof.
  intros.
  extensionality.
  unfold compose, id.
  apply bij_gf.
Qed.

Definition bij_compose {A B C:Type} (g: bijection B C) (f: bijection A B):
  bijection A C.
  refine (Bijection _ _
           ((bij_f _ _ g) oo (bij_f _ _ f))
           ((bij_g _ _ f) oo (bij_g _ _ g)) _ _).
  + intros.
    unfold compose.
    rewrite !bij_fg.
    auto.
  + intros.
    unfold compose.
    rewrite !bij_gf.
    auto.
Defined.

Infix "ooo" := bij_compose (at level 54, right associativity).

Definition bij_refl (A: Type): bijection A A.
  refine (Bijection _ _ (id _) (id _) _ _).
  + reflexivity.
  + reflexivity.
Defined.

Definition bij_sym {A B} (f: bijection A B): bijection B A.
  refine (Bijection _ _ (bij_g _ _ f) (bij_f _ _ f) _ _).
  + apply bij_gf.
  + apply bij_fg.
Defined.

Definition func_bij {A1 A2 B1 B2} (f: bijection A1 A2) (g: bijection B1 B2):
  bijection (A1 -> B1) (A2 -> B2).
  refine (Bijection _ _
            (fun F => (bij_f _ _ g) oo F oo (bij_g _ _ f))
            (fun F => (bij_g _ _ g) oo F oo (bij_f _ _ f)) _ _).
  + intros F; extensionality x.
    unfold compose; rewrite !bij_fg; auto.
  + intros F; extensionality x.
    unfold compose; rewrite !bij_gf; auto.
Defined.

Definition unit_unit1 (A: Type): bijection A (A * unit).
  refine (Bijection _ _ (fun a => (a, tt)) fst _ _).
  + intros; destruct x as [? []]; auto.
  + intros; auto.
Defined.

Definition unit_unit2 (A: Type): bijection A (unit * A).
  refine (Bijection _ _ (pair tt) snd _ _).
  + intros; destruct x as [[] ?]; auto.
  + intros; auto.
Defined.

Definition prod_bij_comm (A B: Type): bijection (A * B) (B * A).
  refine (Bijection _ _
           (fun p => (snd p, fst p))
           (fun p => (snd p, fst p)) _ _).
  + intros; destruct x; auto.
  + intros; destruct x; auto.
Defined.

(** Perform inversion on a hypothesis, removing it from the context, and
    perform substitutions
  *)
Tactic Notation "inv" hyp(H) := inversion H; clear H; subst.

Ltac detach H :=
  match goal with [ H : (?X -> ?Y) |- _ ] =>
    cut Y; [ clear H; intro H | apply H; clear H ]
  end.

Ltac spec H :=
  match type of H with ?a -> _ =>
    let H1 := fresh in (assert (H1: a); [|generalize (H H1); clear H H1; intro H]) end.

(* THIS IS OBSOLETE because of Coq's "specialize" tactic
(** Specialize a hypothesis with respect to specific terms or proofs. *)
Tactic Notation "spec" hyp(H) :=
  match type of H with ?a -> _ =>
    let H1 := fresh in (assert (H1: a); [|generalize (H H1); clear H H1; intro H]) end.

Tactic Notation "spec" hyp(H) constr(a) :=
  (generalize (H a); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) :=
  (generalize (H a b); clear H; intro H).

 Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) :=
  (generalize (H a b c); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
  (generalize (H a b c d); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) :=
  (generalize (H a b c d e); clear H; intro H).

(* Some further tactics, from Barrier Project *)

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) :=
  (generalize (H a b c d e f); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) :=
  (generalize (H a b c d e f g); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) :=
  (generalize (H a b c d e f g h); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) :=
  (generalize (H a b c d e f g h i); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) constr(n) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) constr(n) constr(o) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) constr(n) constr(o) constr(p) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).
*)

Tactic Notation "disc" := (try discriminate).

Tactic Notation "contr" := (try contradiction).

Tactic Notation "congr" := (try congruence).

Tactic Notation  "icase" constr(v) := (destruct v; disc; contr; auto).

Tactic Notation "copy" hyp(H) := (generalize H; intro).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Environments for metatheory                                             *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibOption LibList LibProd LibLogic LibReflect.
Require Export LibVar.
Generalizable Variable A.

(* ********************************************************************** *)
(** * Definition of environments and their basic operations *)

(** To avoid definitions being unfolded by [simpl] in an uncontrollable
    manner, we use a module signature to enforce abstraction *)

(* ---------------------------------------------------------------------- *)
(** ** Abstract definitions *)

Definition env (A:Type) := list (var * A).

Module Type EnvOpsSig.

Section Definitions.
Variable A B : Type.

Parameter empty : env A.
Parameter empty_def : empty = nil.

Parameter single : var -> A -> env A.
Parameter single_def :
  single = fun x v => (x,v)::nil.

Parameter concat : env A -> env A -> env A.
Parameter concat_def :
  concat = fun E F => F ++ E.

Parameter singles : list var -> list A -> env A.
Parameter singles_def :
  singles = fun xs vs =>
    fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).

Parameter keys : env A -> list var.
Parameter keys_def :
  keys = map fst.

Parameter values : env A -> list A.
Parameter values_def :
  values = map snd.

Parameter fold_vars : (A -> vars) -> env A -> vars.
Parameter fold_vars_defs :
  fold_vars = fun fv E =>
    fold_right (fun v acc => fv v \u acc) \{} (values E).

Parameter dom : env A -> vars.
Parameter dom_def :
  dom = fold_right (fun p E => \{fst p} \u E) \{}.

Parameter map : (A -> B) -> env A -> env B.
Parameter map_def :
  map = fun f E =>
    LibList.map (fun p => (fst p, f (snd p))) E.

Parameter map_keys : (var -> var) -> env A -> env A.
Parameter map_keys_def :
  map_keys = fun f E =>
    LibList.map (fun p => (f (fst p), snd p)) E.

Parameter get : var -> env A -> option A.
Fixpoint get_impl (k : var) (E : env A) {struct E} : option A :=
  match E with
  | nil => None
  | (x,v) :: E' => If k = x then Some v else get_impl k E'
  end.
Parameter get_def :
  get = get_impl.

End Definitions.

Implicit Arguments empty [A].

End EnvOpsSig.

(* ---------------------------------------------------------------------- *)
(** ** Concrete definitions *)

Module Export EnvOps : EnvOpsSig.

Section Concrete.
Variable A B : Type.

Definition empty : env A := nil.
Lemma empty_def : empty = nil.
Proof using. reflexivity. Qed.

Definition single x v : env A := (x,v)::nil.
Lemma single_def :
  single = fun x v => (x,v)::nil.
Proof using. reflexivity. Qed.

Definition concat (E F : env A) := F ++ E.
Lemma concat_def :
  concat = fun E F => F ++ E.
Proof using. reflexivity. Qed.

Definition singles (xs : list var) (vs : list A) : env A :=
  fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).
Lemma singles_def :
  singles = fun xs vs =>
   fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).
Proof using. reflexivity. Qed.

Definition keys : env A -> list var :=
  map fst.
Lemma keys_def :
  keys = map fst.
Proof using. reflexivity. Qed.

Definition values : env A -> list A :=
  map snd.
Lemma values_def :
  values = map snd.
Proof using. reflexivity. Qed.

Definition fold_vars (fv : A -> vars) (E : env A) :=
  fold_right (fun v acc => fv v \u acc) \{} (values E).
Lemma fold_vars_defs :
  fold_vars = fun fv E => fold_right (fun v acc => fv v \u acc) \{} (values E).
Proof using. reflexivity. Qed.

Definition map (f:A->B) (E:env A) :=
  LibList.map (fun p => (fst p, f (snd p))) E.
Lemma map_def :
  map = fun f E => LibList.map (fun p => (fst p, f (snd p))) E.
Proof using. reflexivity. Qed.

Definition map_keys (f:var->var) (E:env A) :=
  LibList.map (fun p => (f (fst p), snd p)) E.
Lemma map_keys_def :
  map_keys = fun f E => LibList.map (fun p => (f (fst p), snd p)) E.
Proof using. reflexivity. Qed.

Definition dom : env A -> vars :=
  fold_right (fun p E => \{fst p} \u E) \{}.
Lemma dom_def :
  dom = fold_right (fun p E => \{fst p} \u E) \{}.
Proof using. reflexivity. Qed.

Fixpoint get_impl (k : var) (E : env A) {struct E} : option A :=
  match E with
  | nil => None
  | (x,v) :: E' => If k = x then Some v else get_impl k E'
  end.
Definition get := get_impl.
Lemma get_def :
  get = get_impl.
Proof using. reflexivity. Qed.

End Concrete.

Implicit Arguments empty [A].

End EnvOps.

(* ---------------------------------------------------------------------- *)
(** ** Notations *)

Module LibEnvNotations.
(** [x ~ a] is the notation for a singleton environment mapping x to a. *)

Notation "x ~ a" := (single x a)
  (at level 7, left associativity) : env_scope.

(** [xs ~* vs] is the notation for [single_iter xs vs]. *)

Notation "xs ~* vs" := (singles xs vs)
  (at level 7, left associativity) : env_scope.

(** [E & F] is the notation for concatenation of E and F. *)

Notation "E & F" := (concat E F)
  (at level 28, left associativity) : env_scope.

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.
End LibEnvNotations.
Import LibEnvNotations.

Bind Scope env_scope with env.
Delimit Scope env_scope with env.
Open Scope env_scope.

(* ---------------------------------------------------------------------- *)
(** ** Additional definitions *)

Section MoreDefinitions.
Variable A : Type.
Implicit Types E F : env A.

(** Well-formed environments contains no duplicate bindings. *)

Inductive ok : env A -> Prop :=
  | ok_empty :
      ok empty
  | ok_push : forall E x v,
      ok E -> x # E -> ok (E & x ~ v).

(** An environment contains a binding from x to a iff the most recent
  binding on x is mapped to a *)

Definition binds x v E :=
  get x E = Some v.

(** Read the value associated to a bound variable *)

Definition get_or_arbitrary `{Inhab A} x (E:env A) :=
  unsome (get x E).

(** Inclusion of an environment in another one. *)

Definition extends E F :=
  forall x v, binds x v E -> binds x v F.

(** Gathering free variables contained in the values of an environment *)

Definition fv_in_values (fv:A->vars) (E:env A) :=
  fold_right (fun v L => (fv v) \u L) \{} (values E).

End MoreDefinitions.

(* ---------------------------------------------------------------------- *)
(** ** Basic Properties *)

Hint Rewrite empty_def single_def concat_def singles_def keys_def values_def
  dom_def map_def map_keys_def get_def : env_defs.

Ltac rew_env_defs := autorewrite with env_defs in *.

Section Properties.

Variable A B : Type.
Implicit Types k x : var.
Implicit Types v : A.
Implicit Types E F G : env A.
Implicit Types f : A -> B.
Implicit Types r : var -> var.

Lemma cons_to_push : forall x v E,
  (x, v) :: E = E & x ~ v.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma env_ind : forall (P : env A -> Prop),
  (P empty) ->
  (forall E x v, P E -> P (E & x ~ v)) ->
  (forall E, P E).
Proof using.
  rew_env_defs. induction E as [|(x,v)].
  auto. forwards*: H0 IHE.
Qed.

Lemma map_empty : forall f,
  map f empty = empty.
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_single : forall f x v,
  map f (x ~ v) = (x ~ (f v)).
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_concat : forall f E F,
  map f (E & F) = map f E & map f F.
Proof using.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list~.
  rew_list. fequals.
Qed.
Lemma map_push : forall f x v E,
  map f (E & x ~ v) = map f E & x ~ (f v).
Proof using. intros. rewrite map_concat, map_single. auto. Qed.

Lemma map_keys_empty : forall r,
  map_keys r (@empty A) = empty.
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_keys_single : forall r x v,
  map_keys r (x ~ v) = ((r x) ~ v).
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_keys_concat : forall r E F,
  map_keys r (E & F) = map_keys r E & map_keys r F.
Proof using.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list~.
  rew_list. fequals.
Qed.
Lemma map_keys_push : forall r x v E,
  map_keys r (E & x ~ v) = map_keys r E & (r x) ~ v.
Proof using. intros. rewrite map_keys_concat, map_keys_single. auto. Qed.

Lemma get_empty : forall k,
  get k (@empty A) = None.
Proof using. intros. rew_env_defs. auto. Qed.
Lemma get_single : forall k x v,
  get k (x ~ v) = If k = x
                    then Some v
                    else None.
Proof using. intros. rew_env_defs. unfold get_impl. auto. Qed.
Lemma get_concat : forall k E F,
  get k (E & F) = match get k F with
                  | None => get k E
                  | Some v => Some v
                  end.
Proof using.
  intros. rew_env_defs. induction F as [|(x,v)].
  auto.
  simpl. case_if~.
Qed.

Lemma dom_empty :
  dom (@empty A) = \{}.
Proof using. rew_env_defs. auto. Qed.
Lemma dom_single : forall x v,
  dom (x ~ v) = \{x}.
Proof using.
  intros. rew_env_defs.
  rew_list. rewrite~ union_empty_r.
Qed.
Lemma dom_concat : forall E F,
  dom (E & F) = dom E \u dom F.
Proof using.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list. rewrite~ union_empty_r.
  rew_app. rewrite fold_right_cons. rewrite IHF.
   rewrite~ union_comm_assoc.
Qed.
Lemma dom_push : forall x v E,
  dom (E & x ~ v) = \{x} \u dom E.
Proof using.
  intros. rewrite dom_concat. rewrite dom_single.
  rewrite~ union_comm.
Qed.

End Properties.

Section SinglesProperties.
Variable A B : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types xs : list var.
Implicit Types vs : list A.
Implicit Types E F : env A.

Lemma singles_nil :
  nil ~* nil = (@empty A).
Proof using. intros. rew_env_defs. auto. Qed.

Lemma singles_cons : forall x v xs vs,
  (x::xs) ~* (v::vs) = (xs ~* vs) & (x ~ v).
Proof using. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma singles_one : forall x v,
  (x::nil) ~* (v::nil) = (x ~ v).
Proof using. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma singles_two : forall x1 x2 v1 v2,
  (x1::x2::nil) ~* (v1::v2::nil) = (x2 ~ v2 & x1 ~ v1).
Proof using. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma keys_singles : forall xs vs,
  length xs = length vs ->
  keys (xs ~* vs) = xs.
Proof using.
  intros. rew_env_defs. gen vs. induction xs; introv E.
  rew_list~.
  destruct vs. false. simpl. rew_env_defs. rew_list. fequals.
   rew_list in E. applys IHxs. inverts E. auto.
Qed.

Lemma values_singles : forall xs vs,
  length xs = length vs ->
  values (xs ~* vs) = vs.
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  auto.
  rew_list in E. simpl. rew_env_defs. rew_list. fequals.
   applys IHxs. inverts E. auto.
Qed.

Lemma dom_singles : forall xs vs,
  length xs = length vs ->
  dom (xs ~* vs) = from_list xs.
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  simpl. rewrite~ from_list_nil.
  simpl. rew_env_defs. rew_list. rewrite from_list_cons. fequals.
   applys IHxs. inverts~ E.
Qed.

Lemma map_singles : forall (f : A -> B) xs vs,
  length xs = length vs ->
  map f (xs ~* vs) = xs ~* (LibList.map f vs).
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma map_keys_singles : forall f xs vs,
  length xs = length vs ->
  map_keys f (xs ~* vs) = (LibList.map f xs) ~* vs.
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma concat_singles : forall xs1 xs2 vs1 vs2,
  length xs1 = length vs1 ->
  length xs2 = length vs2 ->
  (xs2 ~* vs2) & (xs1 ~* vs1) = (xs1 ++ xs2) ~* (vs1 ++ vs2).
Proof using.
  introv E1 E2. rew_env_defs. gen vs1.
  induction xs1; destruct vs1; intros; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma singles_keys_values : forall E,
  E = (keys E) ~* (values E).
Proof using.
  intros. rew_env_defs. induction E as [|[x v] E'].
  auto.
  rew_list. simpl. rew_env_defs. rew_list. fequals.
Qed.

End SinglesProperties.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

Section StructProperties.

Variable A : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma env_case : forall E,
  E = empty \/ exists x v E', E = E' & x ~ v.
Proof using. intros. induction E using env_ind; autos*. Qed.

Lemma concat_empty_r : forall E,
  E & empty = E.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma concat_empty_l : forall E,
  empty & E = E.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma concat_assoc : forall E F G,
  E & (F & G) = (E & F) & G.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma empty_single_inv : forall x v,
  empty = x ~ v -> False.
Proof using. introv H. rew_env_defs. inverts H. Qed.

Lemma empty_concat_inv : forall E F,
  empty = E & F -> empty = E /\ empty = F.
Proof using. introv H. rew_env_defs. forwards*: nil_eq_app_inv H. Qed.

Lemma empty_push_inv : forall E x v,
  empty = E & x ~ v -> False.
Proof using. introv H. rew_env_defs. inverts H. Qed.

Lemma empty_middle_inv : forall E F x v,
  empty = E & x ~ v & F -> False.
Proof using. introv H. rew_env_defs. forwards* [_ ?]: nil_eq_app_inv H. false. Qed.

Lemma eq_single_inv : forall x1 x2 v1 v2,
  x1 ~ v1 = x2 ~ v2 ->
  x1 = x2 /\ v1 = v2.
Proof using. introv H. rew_env_defs. inverts~ H. Qed.

Lemma eq_push_inv : forall x1 x2 v1 v2 E1 E2,
  E1 & x1 ~ v1 = E2 & x2 ~ v2 ->
  x1 = x2 /\ v1 = v2 /\ E1 = E2.
Proof using. introv H. rew_env_defs. inverts~ H. Qed.

End StructProperties.

(* ---------------------------------------------------------------------- *)
(** ** More properties *)

Section MoreProperties.

Variable A : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma dom_map : forall (B:Type) (f:A->B) E,
  dom (map f E) = dom E.
Proof using.
  induction E using env_ind.
  rewrite map_empty. do 2 rewrite dom_empty. auto.
  rewrite map_concat. rewrite map_single.
  rewrite_all dom_concat. rewrite_all dom_single. congruence.
Qed.

Lemma concat_assoc_map_push : forall f E F x v,
  E & (map f (F & x ~ v)) = (E & map f F) & x ~ (f v).
Proof using.
  intros. rewrite map_concat. rewrite map_single.
  rewrite~ concat_assoc.
Qed.

Lemma get_push : forall k x v E,
  get k (E & x ~ v) =
    If k = x
      then Some v
      else get k E.
Proof using.
  intros. rewrite get_concat. rewrite get_single. case_if~.
Qed.

Ltac simpl_dom :=
  rewrite_all dom_push in *;
  rewrite_all dom_empty in *.

Lemma get_some : forall x E,
  x \in dom E -> exists v, get x E = Some v.
(* i.e.  [x \in dom E -> exists v, binds x v E] *)
Proof using. (* beautify *)
  unfold binds.
  introv H. rew_env_defs. induction E as [|[y v] E'].
  rew_list in H. rewrite* in_empty in H.
  unfold get_impl. case_if.
    eauto.
    rew_list in H. rewrite in_union in H. destruct H as [H|H].
     rewrite in_singleton in H. simpls. false.
     forwards* [v' ?]: IHE'.
Qed.

Lemma get_some_inv : forall x v E,
  get x E = Some v -> x \in dom E.
(* i.e.  [binds x v E -> x \in dom E] *)
Proof using. (* beautify *)
  unfold binds.
  introv H. rew_env_defs. unfolds get_impl. induction E as [|[y v'] E'].
  false.
  rew_list. rewrite in_union. simpl. case_if.
    inverts H. subst. left. rewrite~ in_singleton.
    forwards*: IHE'.
Qed.

Lemma get_none : forall x E,
  x # E -> get x E = None.
Proof using.
  induction E using env_ind; introv In.
  rewrite~ get_empty.
  rewrite~ get_push. case_if.
    simpl_dom. subst.
    notin_false.
    simpl_dom. auto.
Qed.

Lemma get_none_inv : forall x E,
  get x E = None -> x # E.
Proof using.
  induction E using env_ind; introv Eq.
  simpl_dom. auto.
  rewrite get_push in Eq. case_if~.
   simpl_dom. auto.
Qed.

End MoreProperties.

Lemma binds_get_or_arbitrary : forall `{Inhab A} x v (E:env A),
  binds x v E -> get_or_arbitrary x E = v.
Proof using. introv M. unfold get_or_arbitrary. rewrite~ M. Qed.

Definition indom_dec A (E:env A) x :=
  match get x E with None => false | Some _ => true end.

Global Instance indom_decidable : forall A (E:env A) x,
  Decidable (x \in dom E).
Proof using.
  intros. applys decidable_make (indom_dec E x).
  unfold indom_dec. cases (get x E) as C.
    lets: (get_some_inv C). rewrite~ isTrue_true.
    lets: (get_none_inv C). rewrite~ isTrue_false.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Hints and rewriting tactics *)

Hint Constructors ok.

Hint Rewrite dom_empty dom_single dom_concat : rew_env_dom.
Hint Rewrite map_empty map_single map_concat : rew_env_map.
Hint Rewrite map_keys_empty map_keys_single
 map_keys_concat : rew_env_map_keys.
Hint Rewrite get_empty get_single get_concat : rew_evn_get.

Hint Rewrite concat_empty_r concat_empty_l concat_assoc : rew_env_concat.

Tactic Notation "rew_env_concat" :=
  autorewrite with rew_env_concat.
Tactic Notation "rew_env_concat" "in" hyp(H) :=
  autorewrite with rew_env_concat in H.
Tactic Notation "rew_env_concat" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_env_concat).
  (* autorewrite with rew_env_concat in *. *)

Ltac simpl_dom :=
  rewrite_all dom_map in *;
  rewrite_all dom_push in *;
  rewrite_all dom_concat in *;
  rewrite_all dom_single in *;
  rewrite_all dom_empty in *.

Hint Extern 1 (_ # _) => simpl_dom; notin_solve.

(* ---------------------------------------------------------------------- *)
(** ** Properties of well-formedness and freshness *)

Section OkProperties.

Variable A B : Type.
Implicit Types k x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma ok_push_inv : forall E x v,
  ok (E & x ~ v) -> ok E /\ x # E.
Proof using.
  intros. inverts H as H1 H2.
  false (empty_push_inv H1).
  destructs 3 (eq_push_inv H). subst~.
Qed.

Lemma ok_push_inv_ok : forall E x v,
  ok (E & x ~ v) -> ok E.
Proof using. introv H. destruct* (ok_push_inv H). Qed.

Lemma ok_concat_inv : forall E F,
  ok (E & F) -> ok E /\ ok F.
Proof using.
  induction F using env_ind; rew_env_concat; introv Ok. auto.
  destruct (ok_push_inv Ok). destruct~ IHF.
Qed.

Lemma ok_concat_inv_l : forall E F,
  ok (E & F) -> ok E.
Proof using. introv H. lets*: ok_concat_inv H. Qed.

Lemma ok_concat_inv_r : forall E F,
  ok (E & F) -> ok F.
Proof using. introv H. lets*: ok_concat_inv H. Qed.

Lemma ok_middle_change : forall E F x v1 v2,
  ok (E & x ~ v1 & F) -> ok (E & x ~ v2 & F).
Proof using.
  induction F using env_ind; introv; rew_env_concat; introv Ok.
  destruct* (ok_push_inv Ok).
  destruct* (ok_push_inv Ok).
Qed.

Lemma ok_middle_inv : forall E F x v,
  ok (E & x ~ v & F) -> x # E /\ x # F.
Proof using.
  induction F using env_ind; introv; rew_env_concat; intros Ok;
   destruct (ok_push_inv Ok).
  split~.
  forwards~ [? ?]: IHF H.
Qed.

Lemma ok_middle_inv_l : forall E F x v,
  ok (E & x ~ v & F) -> x # E.
Proof using. introv H. forwards~ [? _]: ok_middle_inv H. Qed.

Lemma ok_middle_inv_r : forall E F x v,
  ok (E & x ~ v & F) -> x # F.
Proof using. introv H. forwards~ [_ ?]: ok_middle_inv H. Qed.

Lemma ok_remove : forall F E G,
  ok (E & F & G) -> ok (E & G).
Proof using.
  induction G using env_ind; rew_env_concat; introv Ok.
  lets*: ok_concat_inv Ok.
  lets*: ok_push_inv Ok.
Qed.

Lemma ok_map : forall E (f : A -> B),
  ok E -> ok (map f E).
Proof using.
  induction E using env_ind; introv;
   autorewrite with rew_env_map; rew_env_concat; intros Ok.
  auto. destruct* (ok_push_inv Ok).
Qed.

Lemma ok_concat_map: forall E F (f : A -> A),
  ok (E & F) -> ok (E & map f F).
Proof using.
  induction F using env_ind; introv;
   autorewrite with rew_env_map; rew_env_concat; intros Ok.
  auto. destruct* (ok_push_inv Ok).
Qed.

Lemma ok_singles : forall n E xs (vs:list A),
  fresh (dom E) n xs ->
  length xs = length vs ->
  ok E ->
  ok (E & xs ~* vs).
Proof using.
  introv F EQ O. gen E n vs.
  induction xs; destruct vs; destruct n; intros; tryfalse.
  rewrite singles_nil. rewrite~ concat_empty_r.
  rew_length in EQ. inverts EQ.
   simpl in F. destruct F as [Fr F']. lets [? M]: (fresh_union_r F').
   rewrite singles_cons. rewrite concat_assoc. applys ok_push.
     applys~ IHxs n.
     simpl_dom. rewrite~ dom_singles. lets~: fresh_single_notin M.
Qed.

(* LATER: not used
Lemma singles_ok : forall xs vs E,
  ok E ->
  fresh (dom E) (length xs) xs ->
  ok (E & xs ~* vs).
Proof using. ...
  induction xs; simpl; intros. auto.
  destruct H0. destruct Us; simpls. auto.
  rewrite iter_push_cons. rewrite* <- concat_assoc.
*)

(* LATER: not used;
   missing a precondition unless nil~*vs returns nil
Lemma ok_concat_singles : forall n xs vs E,
  ok E ->
  fresh (dom E) n xs ->
  ok (E & xs ~* vs).
Proof using.
  intros. rew_env_defs. gen vs n E.
  induction xs; introv Ok Fr; destruct n; tryfalse.
  auto.
  destruct vs. simpl.
  rew_list in Fr. destruct Fr as [F Fr'].
  applys_to Fr notin_union_r...
Qed.
*)

(* LATER: not used
  Lemma ok_concat : forall E F,
    ok E -> ok F -> disjoint (dom E) (dom F) ->
    ok (E & F).
*)

End OkProperties.

Implicit Arguments ok_push_inv [A E x v].
Implicit Arguments ok_concat_inv [A E F].
Implicit Arguments ok_remove [A F E G].
Implicit Arguments ok_map [A E f].
Implicit Arguments ok_middle_inv_l [A E F x v].
Implicit Arguments ok_middle_inv_r [A E F x v].
Implicit Arguments ok_middle_inv [A E F x v].

(** Automation *)

Hint Resolve ok_middle_inv_l ok_map ok_concat_map ok_singles.

Hint Extern 1 (ok (?E & ?G)) =>
  match goal with H: ok (E & ?F & G) |- _ =>
    apply (ok_remove H) end.

Hint Extern 1 (ok (?E)) =>
  match goal with H: ok (E & _ ~ _) |- _ =>
    apply (ok_push_inv_ok H) end.

Hint Extern 1 (ok (?E)) =>
  match goal with H: ok (E & _) |- _ =>
    apply (ok_concat_inv_l H) end.

Hint Extern 1 (ok (?E)) =>
  match goal with H: ok (_ & E) |- _ =>
    apply (ok_concat_inv_r H) end.

(* not used
Hint Extern 1 (ok (_ & ?xs ~* ?vs)) =>
  match goal with H: fresh _ ?n xs |- _ =>
  match type of vs with list ?A =>
    apply (@ok_concat_singles A n)
  end end.
*)

(* ---------------------------------------------------------------------- *)
(** ** Properties of the binds relation *)

Section BindsProperties.
Variable A B : Type.
Implicit Types E F : env A.
Implicit Types x : var.
Implicit Types v : A.

Lemma binds_get : forall x v E,
  binds x v E -> get x E = Some v.
Proof using. auto. Qed.

(** Constructor forms *)

Lemma binds_empty_inv : forall x v,
  binds x v empty -> False.
Proof using.
  unfold binds. introv H. rewrite get_empty in H. false.
Qed.

Lemma binds_single_eq : forall x v,
  binds x v (x ~ v).
Proof using.
  intros. unfold binds. rewrite get_single. case_if~.
Qed.

Lemma binds_single_inv : forall x1 x2 v1 v2,
  binds x1 v1 (x2 ~ v2) ->
  x1 = x2 /\ v1 = v2.
Proof using.
  unfold binds. introv H. rewrite get_single in H.
  case_if; inversions~ H.
Qed.

Lemma binds_push_inv : forall x1 v1 x2 v2 E,
  binds x1 v1 (E & x2 ~ v2) ->
     (x1 = x2 /\ v1 = v2)
  \/ (x1 <> x2 /\ binds x1 v1 E).
Proof using.
  introv H. unfolds binds. rewrite get_push in H. case_if.
  inverts~ H. auto.
Qed.

Lemma binds_push_eq : forall x v E,
  binds x v (E & x ~ v).
Proof using. intros. unfolds binds. rewrite get_push. case_if~. Qed.

Lemma binds_push_eq_inv : forall x v1 v2 E,
  binds x v1 (E & x ~ v2) -> v1 = v2.
Proof using.
  introv H. forwards [|]: binds_push_inv H. autos*. intros [? _]. false.
Qed.

Lemma binds_push_neq_inv : forall x1 x2 v1 v2 E,
  binds x1 v1 (E & x2 ~ v2) -> x1 <> x2 -> binds x1 v1 E.
Proof using.
  introv H. forwards [|]: binds_push_inv H.
  intros [? ?] ?. false. autos*.
Qed.

Lemma binds_tail : forall x v E,
  binds x v (E & x ~ v).
Proof using. intros. unfold binds. rewrite get_push. cases_if~. Qed.

Lemma binds_push_neq : forall x1 x2 v1 v2 E,
  binds x1 v1 E -> x1 <> x2 -> binds x1 v1 (E & x2 ~ v2).
Proof using.
  introv H N. unfolds binds. rewrite get_push. case_if~.
Qed.

Lemma binds_concat_inv : forall x v E1 E2,
  binds x v (E1 & E2) ->
     (binds x v E2)
  \/ (x # E2 /\ binds x v E1).
Proof using.
  introv H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   forwards [[? ?]|[? M]]: binds_push_inv H.
     subst. left. apply binds_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ binds_push_neq.
       right~.
Qed.

Lemma binds_map : forall x v (f : A -> B) E,
  binds x v E -> binds x (f v) (map f E).
Proof using.
  introv H. unfolds binds. rew_env_defs.
  induction E as [|[x' v'] E']; simpls.
  false.
  cases_if~. inverts~ H.
Qed.

(** Basic forms *)

Lemma binds_func : forall x v1 v2 E,
  binds x v1 E -> binds x v2 E -> v1 = v2.
Proof using.
  introv H1 H2. unfolds binds.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H1. false.
  rewrite get_push in H1,H2. case_if~.
   inverts H1. inverts~ H2.
Qed.

Lemma binds_fresh_inv : forall x v E,
  binds x v E -> x # E -> False.
Proof using.
  introv H F. unfolds binds.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H. false.
  rewrite get_push in H. case_if~. subst.
   simpl_dom; notin_false.
Qed.

(** Derived forms *)

Lemma binds_single_eq_inv : forall x v1 v2,
  binds x v1 (x ~ v2) ->
  v1 = v2.
Proof using.
  introv H. unfolds binds. rewrite get_single in H.
  case_if. inverts~ H.
Qed.

Lemma binds_concat_left : forall x v E1 E2,
  binds x v E1 ->
  x # E2 ->
  binds x v (E1 & E2).
Proof using.
  introv H F. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc. applys~ binds_push_neq.
   simpl_dom. auto.
Qed.

Lemma binds_concat_left_ok : forall x v E1 E2,
  ok (E1 & E2) ->
  binds x v E1 ->
  binds x v (E1 & E2).
Proof using.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc in O|-*. lets [_ ?]: ok_push_inv O.
  applys~ binds_push_neq. intro_subst. applys~ binds_fresh_inv H.
Qed.

Lemma binds_concat_left_inv : forall x v E1 E2,
  binds x v (E1 & E2) ->
  x # E2 ->
  binds x v E1.
Proof using.
  introv H F. lets~ [M|[? ?]]: binds_concat_inv H.
    false. applys~ binds_fresh_inv M.
Qed.

Lemma binds_concat_right : forall x v E1 E2,
  binds x v E2 ->
  binds x v (E1 & E2).
Proof using.
  introv H. induction E2 using env_ind.
  false. applys* binds_empty_inv.
  rewrite concat_assoc. lets [[? ?]|[? ?]]: binds_push_inv H.
    subst. applys binds_tail.
    applys~ binds_push_neq.
Qed.

Lemma binds_concat_right_inv : forall x v E1 E2,
  binds x v (E1 & E2) ->
  x # E1 ->
  binds x v E2.
Proof using.
  introv H F. lets~ [?|[? M]]: binds_concat_inv H.
    false. applys~ binds_fresh_inv M.
Qed.

Lemma binds_middle_eq : forall x E1 E2 v,
  x # E2 ->
  binds x v (E1 & x ~ v & E2).
Proof using.
  introv F. applys~ binds_concat_left. applys binds_tail.
Qed.

(** Metatheory proof forms *)

(** Interaction between binds and the insertion of bindings.
  In theory we don't need this lemma since it would suffice
  to use the binds_cases tactics, but since weakening is a
  very common operation we provide a lemma for it. *)

Lemma binds_weaken : forall x a E F G,
  binds x a (E & G) -> ok (E & F & G) ->
  binds x a (E & F & G).
Proof using.
  introv H O. lets [?|[? ?]]: binds_concat_inv H.
    applys~ binds_concat_right.
    applys~ binds_concat_left. applys~ binds_concat_left_ok.
Qed.

Lemma binds_remove : forall E2 E1 E3 x v,
  binds x v (E1 & E2 & E3) ->
  x # E2 ->
  binds x v (E1 & E3).
Proof using.
  introv H F. lets [?|[? M]]: binds_concat_inv H.
    applys~ binds_concat_right.
    forwards~: binds_concat_left_inv M. applys~ binds_concat_left.
Qed.

Lemma binds_subst : forall x2 v2 x1 v1 E1 E2,
  binds x1 v1 (E1 & x2 ~ v2 & E2) ->
  x1 <> x2 ->
  binds x1 v1 (E1 & E2).
Proof using. introv H N. applys~ binds_remove H. Qed.

Lemma binds_middle_eq_inv : forall x E1 E2 v1 v2,
  binds x v1 (E1 & x ~ v2 & E2) ->
  ok (E1 & x ~ v2 & E2) ->
  v1 = v2.
Proof using.
  introv H O. lets [? ?]: ok_middle_inv O.
  forwards~ M: binds_concat_left_inv H.
  applys~ binds_push_eq_inv M.
Qed.

Lemma binds_middle_inv : forall x1 v1 x2 v2 E1 E2,
  binds x1 v1 (E1 & x2 ~ v2 & E2) ->
     (binds x1 v1 E2)
  \/ (x1 # E2 /\ x1 = x2 /\ v1 = v2)
  \/ (x1 # E2 /\ x1 <> x2 /\ binds x1 v1 E1).
Proof using.
  introv H. lets [?|[? M]]: (binds_concat_inv H).
    left~.
    right. lets [N|[? N]]: (binds_concat_inv M).
      lets [? ?]: (binds_single_inv N). subst~.
      right. simpl_dom. split~.
Qed.

Lemma binds_not_middle_inv : forall x v E1 E2 E3,
  binds x v (E1 & E2 & E3) ->
  x # E2 ->
     (binds x v E3)
  \/ (x # E3 /\ binds x v E1).
Proof using.
  introv H F. lets [?|[? M]]: (binds_concat_inv H).
    left~.
    right. forwards~ N: (binds_concat_left_inv M).
Qed.

Lemma fv_in_values_binds : forall y fv x v E,
  binds x v E -> y \notin fv_in_values fv E -> y \notin fv v.
Proof using.
  unfold fv_in_values. introv H.
  induction E using env_ind; introv M.
  false. applys* binds_empty_inv.
  rewrite values_def in M,IHE.
  rewrite concat_def, single_def in M. rew_list in M. simpl in M.
  lets [[? ?]|[? ?]]: (binds_push_inv H); subst~.
Qed.

(* unused -- requires a precondition on f
Lemma binds_keys : forall x v f E,
  binds x v E -> binds (f x) v (map_keys f E).
Proof using.
Qed.
*)

(* unused
Lemma binds_concat_inv_ok : forall x v E1 E2,
  ok (E1 & E2) ->
  binds x v (E1 & E2) ->
     (x # E2 /\ binds x v E1)
  \/ (x # E1 /\ binds x v E2).
Proof using.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in O,H.
   forwards [[? ?]|[? M]]: binds_push_inv H.
     subst. left. apply conj_dup_r.
     split.
       apply binds_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ binds_push_neq.
       right~....
Qed.
*)

End BindsProperties.

(* ---------------------------------------------------------------------- *)
(** ** Tactics *)

Hint Resolve binds_push_eq binds_push_neq
  binds_map binds_concat_left binds_concat_right.

Tactic Notation "binds_mid" :=
  match goal with H: binds ?x ?v1 (_ & ?x ~ ?v2 & _) |- _ =>
    asserts: (v1 = v2); [ apply (binds_middle_eq_inv H) | subst; clear H ]
  end.
Tactic Notation "binds_mid" "~" :=
  binds_mid; auto_tilde.
Tactic Notation "binds_mid" "*" :=
  binds_mid; auto_star.

Tactic Notation "binds_push" constr(H) :=
  match type of H with binds ?x1 ?v1 (_ & ?x2 ~ ?v2) =>
    destruct (binds_push_inv H) as [[? ?]|[? ?]]; [ subst x2 v2 | ]
  end.
Tactic Notation "binds_push" "~" constr(H) :=
  binds_push H; auto_tilde.
Tactic Notation "binds_push" "*" constr(H) :=
  binds_push H; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Properties of environment inclusion *)

Section ExtendsProperties.
Variable A : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma extends_refl : forall E,
  extends E E.
Proof using. intros_all~. Qed.

Lemma extends_push : forall E x v,
  x # E -> extends E (E & x ~ v).
Proof using.
  introv Fr. intros x' v' B. unfolds binds.
  rewrite get_push. case_if~.
  lets: get_none Fr. false.
Qed.

Lemma extends_concat_l : forall E F,
  extends F (E & F).
Proof using.
  introv B. unfolds binds.
  rewrite get_concat. rewrite~ B.
Qed.

Lemma extends_concat_r : forall E F,
  disjoint (dom E) (dom F) ->
  extends E (E & F).
Proof using.
  introv D B. unfolds binds.
  lets: get_some_inv A B.
  forwards M: get_none A x F.
    applys~ disjoint_in_notin D.
  rewrite get_concat. rewrite~ M.
Qed.

(* not used
Lemma extends_push_reoccur : forall E x v,
  binds x v E -> extends E (E & x ~ v).
*)

End ExtendsProperties.

Hint Resolve extends_refl extends_push.

(* ********************************************************************** *)
(** ** Tactics for case analysis on binding relations *)

(** [binds_get H as EQ] produces from an hypothesis [H] of
  the form [binds x a (E & x ~ b & F)] the equality [EQ: a = b]. *)

Ltac binds_get_nosubst_base H EQ :=
  match type of H with
  | binds ?x ?v1 (?E1 & ?x ~ ?v2 & ?E2) =>
    forwards EQ: (@binds_middle_eq_inv _ x E1 E2 v1 v2 H); [ auto | ]
  (* | binds ?x1 ?v1 (?E1 & ?x2 ~ ?v2 & ?E2) =>
     forwards EQ: (@binds_middle_inv _ x1 v1 x2 v2 E1 E2); [ | auto ] *)
  end.

Tactic Notation "binds_get_nosubst" constr(H) "as" ident(EQ) :=
  binds_get_nosubst_base H EQ.
Tactic Notation "binds_get_nosubst" constr(H) :=
  let EQ := fresh "EQ" in binds_get_nosubst H as EQ.

(** [binds_get H] expects an hypothesis [H] of the form
  [binds x a (E & x ~ b & F)] and substitute [a] for [b] in the goal. *)

Ltac binds_get H :=
  let EQ := fresh in binds_get_nosubst H as EQ;
  try match type of EQ with
  | ?f _ = ?f _ => inversions EQ
  | ?x = ?y => subst x end.

(** [binds_single H] derives from an hypothesis [H] of the form
  [binds x a (y ~ b)] the equalities [x = y] and [a = b], then
  it substitutes [x] for [y] in the goal or deduce a contradiction
  if [x <> y] can be found in the context. *)

Ltac binds_single H :=
  match type of H with binds ?x ?a (?y ~ ?b) =>
    let EQ := fresh "EQ" in
    destruct (binds_single_inv H) as [? EQ];
    try discriminate; try subst y;
    try match goal with N: ?x <> ?x |- _ =>
      false; apply N; reflexivity end end.

(** [binds_case H as B1 B2] derives from an hypothesis [H] of the form
  [binds x a (E & F)] two subcases: [B1: binds x a E] (with a freshness
  condition [x # F]) and [B2: binds x a F]. *)

Lemma binds_concat_inv' : forall A, forall x (v:A) E1 E2,
  binds x v (E1 & E2) ->
     (x # E2 /\ binds x v E1)
  \/ (binds x v E2).
Proof using. intros. forwards K: binds_concat_inv A H. destruct* K. Qed.

Tactic Notation "binds_case" constr(H) "as" ident(B1) ident(B2) :=
   let Fr := fresh "Fr" in
   destruct (binds_concat_inv' H) as [[Fr B1] | B2].

(** [binds_case H] makes a case analysis on an hypothesis [H] of the form
  [binds x a E] where E can be constructed using concatenation and
  singletons. It calls [binds_single] when reaching a singleton. *)

Ltac binds_cases H :=
  let go B := clear H;
    first [ binds_single B | binds_cases B | idtac ] in
  let B1 := fresh "B" in let B2 := fresh "B" in
  binds_case H as B1 B2; (*fix_env;*) [ go B1 | go B2 ].
  (* TODO: add support for binds_empty_inv *)

(* LATER: improve the above tactic using pattern matching
Ltac binds_cases_base H :=
  match H with
  | binds _ _ empty => false (binds_empty_inv H)
  | binds _ _ (_ & _) =>
     let H1 := fresh "B" in
     destruct (binds_concat_inv H) as [H1|H1];
     clear H; binds_cases_base H1
  | binds _ _ (_ ~ _) =>
  | _ => idtac
  end.
*)


(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype fintype finfun ssrnat seq.
From mathcomp Require Import choice ssralg poly polydiv mxpoly matrix bigop.
From mathcomp Require Import mxalgebra perm fingroup tuple.
Require Import mxstructure dvdring.

(**   This file contains the definitions of similarity and equivalence
      between two matrices, and the proofs of some properties about
      these notions.

            similar M N == The matrices M and N are similar.
         equivalent M N == The matrices M and N are equivalent.

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

Section complements.

Lemma seq2_ind (T1 T2 : Type) (P : seq T1 -> seq T2 -> Prop) : P [::] [::] ->
 (forall x1 x2 s1 s2, P s1 s2 -> P (x1 :: s1) (x2 :: s2)) ->
  forall s1 s2, size s1 = size s2 -> P s1 s2.
Proof.
move=> HP IHP.
elim=> [|x1 l1 IH1]; case=> // x2 l2 /= Hs.
apply: IHP; apply: IH1.
by move/eqnP: Hs=> /= /eqnP.
Qed.
End complements.

(****************************************************************************)
(****************************************************************************)
(************ left pseudo division, it is complement of polydiv. ************)
(****************************************************************************)
(****************************************************************************)
Import GRing.Theory.
Import Pdiv.Ring.
Import Pdiv.RingMonic.

Local Open Scope ring_scope.

Module RPdiv.

Section RingPseudoDivision.

Variable R : ringType.
Implicit Types d p q r : {poly R}.

Definition id_converse_def := (fun x : R => x : R^c).
Lemma add_id : additive id_converse_def.
Proof. by []. Qed.

Definition id_converse := Additive add_id.

Lemma expr_rev (x : R) k : (x : R^c) ^+ k = x ^+ k.
Proof. by elim:k=> // k IHk; rewrite exprS exprSr IHk. Qed.

Definition phi (p : {poly R}^c) := map_poly id_converse p.

Fact phi_is_rmorphism : rmorphism phi.
Proof.
split=> //; first exact: raddfB.
split=> [p q|]; apply/polyP=> i; last by rewrite coef_map !coef1.
by rewrite coefMr coef_map coefM; apply: eq_bigr => j _; rewrite !coef_map.
Qed.

Canonical phi_rmorphism := RMorphism phi_is_rmorphism.

Definition phi_inv (p : {poly R^c}) :=
  map_poly (fun x : R^c => x : R) p : {poly R}^c.

Lemma phiK : cancel phi phi_inv.
Proof. by move=> p; rewrite /phi_inv -map_poly_comp_id0 // map_poly_id. Qed.

Lemma phi_invK : cancel phi_inv phi.
Proof. by move=> p; rewrite /phi -map_poly_comp_id0 // map_poly_id. Qed.

Lemma phi_bij : bijective phi.
Proof. by exists phi_inv; first exact: phiK; exact: phi_invK. Qed.

Lemma monic_map_inj (aR rR : ringType) (f : aR -> rR) (p : {poly aR}) :
  injective f -> f 0 = 0 -> f 1 = 1 -> map_poly f p \is monic = (p \is monic).
Proof.
move=> inj_f eq_f00 eq_f11; rewrite !monicE lead_coef_map_inj ?rmorph0 //.
by rewrite -eq_f11 inj_eq.
Qed.

Definition redivp_l (p q : {poly R}) : nat * {poly R} * {poly R} :=
  let:(d,q,p) := (redivp (phi p) (phi q)) in
  (d, phi_inv q, phi_inv p).

Definition rdivp_l p q := ((redivp_l p q).1).2.
Definition rmodp_l p q := (redivp_l p q).2.
Definition rscalp_l p q := ((redivp_l p q).1).1.
Definition rdvdp_l p q := rmodp_l q p == 0.
Definition rmultp_l := [rel m d | rdvdp_l d m].

Lemma ltn_rmodp_l p q : (size (rmodp_l p q) < size q) = (q != 0).
Proof.
have := ltn_rmodp (phi p) (phi q).
rewrite -(rmorph0 phi_rmorphism) (inj_eq (can_inj phiK)) => <-.
rewrite /rmodp_l /redivp_l /rmodp; case: (redivp _ _)=> [[k q'] r'] /=.
by rewrite !size_map_inj_poly.
Qed.

End RingPseudoDivision.

Module mon.

Section MonicDivisor.

Variable R : ringType.
Implicit Types p q r : {poly R}.

Variable d : {poly R}.
Hypothesis mond : d \is monic.

Lemma rdivp_l_eq p :
  p = d * (rdivp_l p d) + (rmodp_l p d).
Proof.
have mon_phi_d: phi d \is monic by rewrite monic_map_inj.
apply: (can_inj (@phiK R)); rewrite {1}[phi p](rdivp_eq mon_phi_d) rmorphD.
rewrite rmorphM /rdivp_l /rmodp_l /redivp_l /rdivp /rmodp.
by case: (redivp _ _)=> [[k q'] r'] /=; rewrite !phi_invK.
Qed.

End MonicDivisor.

End mon.

End RPdiv.

(****************************************************************************)
(****************************************************************************)
(****************************************************************************)
(****************************************************************************)

Section SimilarDef.

Local Open Scope ring_scope.
Import GRing.Theory.
Variable R : comUnitRingType.

Definition similar m n (A : 'M[R]_m) (B : 'M[R]_n) :=
   m = n /\ exists2 P, P \in unitmx & P *m A = (conform_mx P B) *m P.

Lemma similar0 m (A : 'M[R]_0) (B : 'M[R]_m) : (0 = m)%N -> similar A B.
Proof.
move=> H; split=> //.
exists 1%:M; first exact: unitmx1.
by apply/matrixP; case.
Qed.

Lemma similar_sym m : forall n (A : 'M[R]_m) (B : 'M[R]_n),
  similar A B -> similar B A.
Proof.
case=> [A B [H1 H2]|n A B [Hmn]].
  by apply: similar0; rewrite H1.
move: A; rewrite Hmn => A [P HP HPA].
split=> //; exists P^-1; first by rewrite unitmx_inv.
rewrite !conform_mx_id -1?[A *m _]mul1mx -?(mulVmx HP) in HPA *.
by rewrite mulmxA -(mulmxA P^-1) HPA -!mulmxA mulmxV // mulmx1.
Qed.

Lemma similar_trans m n p (B : 'M[R]_n) (A : 'M[R]_m) (C : 'M[R]_p) :
  similar A B -> similar B C -> similar A C.
Proof.
case=> [Hmn HAB] [Hnp].
move: Hmn Hnp A B C HAB=> -> -> A B C [P HP HAB] [Q HQ HBC].
split=> //; exists (Q *m P); first by rewrite unitmx_mul HP HQ.
by rewrite -mulmxA HAB !conform_mx_id !mulmxA HBC conform_mx_id.
Qed.

Lemma similar_refl n (A : 'M[R]_n) : similar A A.
Proof.
split=> //; exists 1%:M; first by rewrite unitmx1.
by rewrite conform_mx_id mulmx1 mul1mx.
Qed.

Lemma similar_det m n (A : 'M[R]_m) (B : 'M[R]_n) :
  similar A B -> \det A = \det B.
Proof.
case=> [Hmn]; move: Hmn A B=> -> A B [P HP HAB].
apply: (@mulrI _ (\det P)); first by rewrite -unitmxE.
by rewrite -det_mulmx mulrC -det_mulmx HAB conform_mx_id.
Qed.

Lemma similar_cast n m p (eq1 : m = p) (eq2 : m = p)
  (A : 'M[R]_n) (B : 'M[R]_m) :
  similar A (castmx (eq1,eq2) B) <-> similar A B.
Proof. by case: _ /eq1 eq2=> eq2; rewrite castmx_id. Qed.

Lemma similar_diag_mx_seq m n s1 s2 :
  m = n -> size s1 = m -> perm_eq s1 s2 ->
similar (diag_mx_seq m m s1) (diag_mx_seq n n s2).
Proof.
move=> eq Hms Hp.
have Hs12:= perm_size Hp.
have Hs2: size s2 == n by rewrite -Hs12 Hms eq.
pose t:= Tuple Hs2.
have HE: s2 = t by [].
move: Hp; rewrite HE.
case/tuple_permP=> p Hp.
split=> //; rewrite eq.
exists (perm_mx p)^T; first by rewrite unitmx_tr unitmx_perm.
apply/matrixP=> i j; rewrite conform_mx_id !mxE (bigD1 j) //= big1 ?addr0.
  rewrite (bigD1 i) //= big1 ?addr0.
    rewrite !mxE Hp -tnth_nth tnth_mktuple (tnth_nth 0) HE !eqxx.
    case: (p j == i) /eqP => Hij; first by rewrite Hij mulr1 mul1r.
    by rewrite mulr0 mul0r.
  by move=> k /negbTE Hk; rewrite !mxE eq_sym (inj_eq (@ord_inj _)) Hk mul0r.
by move=> k /negbTE Hk; rewrite !mxE (inj_eq (@ord_inj _)) Hk mulr0.
Qed.

Lemma similar_ulblockmx n1 n2 n3 (Aul : 'M[R]_n1) (Adr : 'M[R]_n3)
  (Bul : 'M[R]_n2) :
  similar Aul Bul ->
  similar (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Adr).
Proof.
case=> Hn1 [P HP HAB].
have Hu : (block_mx P 0 0 1%:M) \in unitmx.
  by move=> n; rewrite unitmxE det_ublock det1 mulr1 -unitmxE.
split; first by rewrite Hn1.
move: Aul P HP HAB Hu; rewrite Hn1=> Aul P HP; rewrite conform_mx_id=> HAB Hu.
exists (block_mx P 0 0 1%:M); first exact: Hu.
rewrite conform_mx_id !mulmx_block !mul0mx !mulmx0.
by rewrite !add0r !addr0 mulmx1 mul1mx HAB.
Qed.

Lemma similar_drblockmx n1 n2 n3(Aul : 'M[R]_n1) (Adr : 'M[R]_n2)
  (Bdr : 'M[R]_n3) :
  similar Adr Bdr ->
  similar (block_mx Aul 0 0 Adr) (block_mx Aul 0 0 Bdr).
Proof.
case=> Hn2 [P HP HAB].
have Hu : (block_mx 1%:M 0 0 P) \in unitmx.
  by move=> n; rewrite unitmxE det_ublock det1 mul1r -unitmxE.
split; first by rewrite Hn2.
move: Adr P HP HAB Hu; rewrite Hn2=> Adr P HP; rewrite conform_mx_id=> HAB Hu.
exists (block_mx 1%:M 0 0 P); first exact: Hu.
rewrite conform_mx_id !mulmx_block !mul0mx !mulmx0.
by rewrite !add0r !addr0 mulmx1 mul1mx HAB.
Qed.

Lemma similar_dgblockmx n1 n2 n3 n4 (Aul : 'M[R]_n1) (Adr : 'M[R]_n2)
  (Bul : 'M[R]_n3) (Bdr : 'M[R]_n4) :
  similar Aul Bul -> similar Adr Bdr ->
  similar (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Bdr).
Proof.
move=> HABu HABd; apply: (similar_trans (B:= (block_mx Bul 0 0 Adr))).
  exact: similar_ulblockmx.
exact: similar_drblockmx.
Qed.

Lemma similar_exp m n (A : 'M[R]_m.+1) (B : 'M_n.+1) k:
  similar A B -> similar (A ^+ k) (B ^+ k).
Proof.
case=> /eqP; rewrite eqSS=> /eqP eq [P HP]; move: B.
rewrite /similar -eq=> B; rewrite conform_mx_id=> HAB.
split=> //; exists P => //; rewrite conform_mx_id.
elim: k=> [|k IHk].
  by rewrite !expr0 mulmx1 mul1mx.
by rewrite exprSr mulmxA IHk -mulmxA HAB exprSr mulmxA.
Qed.

Lemma similar_poly  m n (A : 'M[R]_m.+1) (B : 'M_n.+1) p:
  similar A B -> similar (horner_mx A p) (horner_mx B p).
Proof.
case=> /eqP; rewrite eqSS=> /eqP eq [P HP]; move: B.
rewrite /similar -eq=> B; rewrite conform_mx_id=> HAB.
split=> //; exists P => //; rewrite conform_mx_id.
elim/poly_ind: p=>[|p c IHp].
  by rewrite !rmorph0 mulmx0 mul0mx.
rewrite !rmorphD !rmorphM /= !horner_mx_X !horner_mx_C.
by rewrite mulmxDr mulmxDl mulmxA IHp -mulmxA HAB mulmxA scalar_mxC.
Qed.

Lemma similar_horner n m (A : 'M[R]_n.+1) (B : 'M_m.+1) p :
  similar A B -> horner_mx A p = 0 -> horner_mx B p = 0.
Proof.
move/(similar_poly p)=> HAB HhA; move: HAB; rewrite HhA.
case=> /eqP; rewrite eqSS=> /eqP eq [P HP].
rewrite -eq in B *; rewrite conform_mx_id mulmx0=> H.
by apply: (mulIr HP); rewrite mul0r.
Qed.

Lemma similar_diag_block : forall l1 l2, size l1 = size l2 ->
   forall (F1 F2 : forall n : nat, nat -> 'M[R]_n.+1),
   (forall i, i < size l1 ->
    similar (F1 (nth 0%N l1 i) i) (F2 (nth 0%N l2 i) i)) ->
   similar (diag_block_mx l1 F1) (diag_block_mx l2 F2).
Proof.
case=>[|a l1]; case=> //=.
  by move=> *; apply: similar_refl.
move=> b l2 /eqP; rewrite eqSS=> /eqP Hsl F1 F2 Hl.
have Hab: similar (F1 a 0%N) (F2 b 0%N) by exact: (Hl 0%N).
move: l1 l2 Hsl a b F1 F2 Hab Hl.
apply: seq2_ind=> //= x1 x2 l1 l2 IH a b F1 F2 Hab H.
apply: (similar_dgblockmx Hab).
apply: IH=>[|i]; first exact: (H 1%N).
exact: (H i.+1).
Qed.

End SimilarDef.

Section EquivalentDef.

Variable R : comUnitRingType.
Local Open Scope ring_scope.
Import GRing.Theory.

Definition equivalent m1 n1 m2 n2 (A : 'M[R]_(m1,n1)) (B : 'M[R]_(m2,n2)) :=
  [/\ m1 = m2, n1 = n2 & exists M N,
  [/\ M \in unitmx, N \in unitmx & M *m A *m N = conform_mx A B]].

Lemma equiv0l n m p (A : 'M[R]_(0,n)) (B : 'M[R]_(m,p)) :
 (0 = m)%N -> (n = p)%N ->  equivalent A B.
Proof.
move=> eq1 eq2; split=> //.
exists 1%:M, 1%:M; split; try exact: unitmx1.
by apply/matrixP; case.
Qed.

Lemma equiv0r n m p (A : 'M[R]_(n,0)) (B : 'M[R]_(m,p)) :
 (n = m)%N -> (0 = p)%N ->  equivalent A B.
Proof.
move=> eq1 eq2; split=> //.
exists 1%:M, 1%:M; split; try exact: unitmx1.
by apply/matrixP=> i; case.
Qed.

Lemma similar_equiv m n (A : 'M_m) (B : 'M_n) : similar A B -> equivalent A B.
Proof.
case; case: m A B; case: n => //; first by move=> A B _ _; apply: equiv0r.
move=> m n A B eq [P HP HAB].
split=> //; exists P, P^-1; split=> //; first by rewrite unitmx_inv.
rewrite {}HAB -mulmxA mulmxV //; move: B.
by rewrite -eq=> B; rewrite !conform_mx_id mulmx1.
Qed.

Lemma equiv_refl m n (A : 'M[R]_(m,n)) : equivalent A A.
Proof.
split=> //; exists 1%:M, 1%:M.
by split; rewrite ?unitmx1 // conform_mx_id mulmx1 mul1mx.
Qed.

Lemma equiv_sym m1 n1 m2 n2 (A : 'M[R]_(m1,n1)) (B : 'M[R]_(m2,n2)) :
  equivalent A B -> equivalent B A.
Proof.
case: m2 A B=> [A B [eq1 eq2 _]|]; first by apply/equiv0l/esym.
case: n2=> [m2 A B [eq1 eq2 _]|]; first by apply/equiv0r/esym.
case: m1=> [m2 n2 A B []|] //.
case: n1=> [m1 m2 n2 A B []|n1 m1 n2 m2 A B [eq1 eq2 [M [N [HM HN HAB]]]]] //.
split; try exact: esym.
move: B HAB; rewrite -eq1 -eq2=> B; rewrite !conform_mx_id=> HAB.
exists M^-1, N^-1; split; rewrite ?unitmx_inv //.
by rewrite -HAB !mulmxA mulVmx // mul1mx -mulmxA mulmxV // mulmx1.
Qed.

Lemma equiv_trans  m1 n1 m2 n2 m3 n3 (B : 'M[R]_(m2,n2))
  (A : 'M[R]_(m1,n1)) (C : 'M[R]_(m3,n3)) :
  equivalent A B -> equivalent B C -> equivalent A C.
Proof.
case=> eqm12 eqn12 [M1 [N1 [HM1 HN1 HAB]]].
case=> eqm23 eqn23 [M2 [N2 [HM2 HN2 HBC]]].
split; [exact: (etrans eqm12) | exact: (etrans eqn12)|].
move: A B M1 N1 M2 N2 HM1 HN1 HM2 HN2 HAB HBC.
rewrite eqm12 eqn12 eqm23 eqn23=> A B M1 N1 M2 N2 HM1 HN1 HM2 HN2.
rewrite !conform_mx_id=> HAB HBC.
exists (M2 *m M1), (N1 *m N2); split; try by rewrite unitmx_mul; apply/andP.
by rewrite -!(mulmxA M2) (mulmxA (_ *m A)) HAB mulmxA.
Qed.

Lemma equiv_ulblockmx m1 n1 m2 n2 m3 n3 (Aul : 'M[R]_(m1,n1))
 (Adr : 'M[R]_(m2,n2)) (Bul : 'M[R]_(m3,n3)) :
  equivalent Aul Bul ->
  equivalent (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Adr).
Proof.
case=> eqm eqn [M [N [HM HN HAB]]].
split; rewrite ?eqm ?eqn //.
move: Aul M N HM HN HAB; rewrite eqm eqn => Aul M N HM HN.
rewrite !conform_mx_id=> HAB.
exists (block_mx M 0 0 1%:M), (block_mx N 0 0 1%:M).
split; try by rewrite unitmxE det_ublock det1 mulr1 -unitmxE.
by rewrite !mulmx_block !mulmx0 !mul0mx !addr0 !mul0mx !add0r mulmx1 mul1mx HAB.
Qed.

Lemma equiv_drblockmx m1 n1 m2 n2 m3 n3 (Aul : 'M[R]_(m1,n1))
  (Adr : 'M[R]_(m2,n2))   (Bdr : 'M[R]_(m3,n3)) :
   equivalent Adr Bdr ->
   equivalent (block_mx Aul 0 0 Adr) (block_mx Aul 0 0 Bdr).
Proof.
case=> eqm eqn [M [N [HM HN HAB]]].
split; rewrite ?eqm ?eqn //.
move: Adr M N HM HN HAB; rewrite eqm eqn=> Adr M N HM HN.
rewrite !conform_mx_id=> HAB.
exists (block_mx 1%:M 0 0 M), (block_mx 1%:M 0 0 N).
split; try by rewrite unitmxE det_ublock det1 mul1r -unitmxE.
by rewrite !mulmx_block !mulmx0 !mul0mx !addr0 !mul0mx !add0r mulmx1 mul1mx HAB.
Qed.

Lemma equiv_dgblockmx m1 n1 m2 n2 m3 n3 m4 n4
  (Aul : 'M[R]_(m1,n1)) (Adr : 'M[R]_(m2,n2))
  (Bul : 'M[R]_(m3,n3)) (Bdr : 'M[R]_(m4,n4)) :
  equivalent Aul Bul -> equivalent Adr Bdr ->
  equivalent (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Bdr).
Proof.
move=> HABu HABd; apply: (equiv_trans (B:=(block_mx Bul 0 0 Adr))).
  exact: equiv_ulblockmx.
exact: equiv_drblockmx.
Qed.

Lemma equiv_cast m1 n1 m2 n2 m3 n3 (eqm : m2 = m3) (eqn : n2 = n3)
 (A : 'M[R]_(m1,n1)) (B : 'M[R]_(m2,n2)) :
  equivalent A (castmx (eqm,eqn) B) <-> equivalent A B.
Proof. by split; case: m3 / eqm A; case: n3 / eqn B. Qed.

Lemma equiv_diag_block : forall l1 l2, size l1 = size l2 ->
   forall (F1 F2 : forall n : nat, nat -> 'M_n.+1),
   (forall i, i < size l1->
    equivalent (F1 (nth 0%N l1 i) i) (F2 (nth 0%N l2 i) i)) ->
   equivalent (diag_block_mx l1 F1) (diag_block_mx l2 F2).
Proof.
case=>[|a l1]; case=> //=.
  by move=> *; exact: equiv_refl.
move=> b l2 /eqP; rewrite eqSS=> /eqP Hsl F1 F2 Hl.
have Hab: equivalent (F1 a 0%N) (F2 b 0%N) by exact: (Hl 0%N).
move: l1 l2 Hsl a b F1 F2 Hab Hl.
apply: seq2_ind=> //= x1 x2 l1 l2 IH a b F1 F2 Hab H.
apply: (equiv_dgblockmx Hab).
apply: IH=>[|i]; first exact: (H 1%N).
exact: (H i.+1).
Qed.

End EquivalentDef.

Section Field.

Import GRing.Theory.
Import polydiv.Pdiv.Ring.
Import RPdiv.
Import polydiv.Pdiv.RingMonic.
Import RPdiv.mon.

Variables R : fieldType.
Variable m n : nat.
Local Open Scope ring_scope.

Theorem similar_fundamental (A: 'M[R]_m) (B : 'M[R]_n) :
  similar A B <-> equivalent (char_poly_mx A) (char_poly_mx B).
Proof.
constructor.
  case: n B=> [B [eq _]|n' B]; first by apply/equiv_sym/equiv0l/esym.
  case: m A=> [A [eq _]|m' A]; first exact: equiv0l.
  case=> eq [P HP HPA]; split=> //.
  move: A P HP HPA; rewrite eq=> A P HP; rewrite !conform_mx_id=> HPA.
  pose M := (map_mx (polyC_rmorphism _) P).
  pose N := (map_mx (polyC_rmorphism _) P^-1).
  have HM: M \in unitmx by rewrite map_unitmx.
  exists M, N; split=> //; first by rewrite map_unitmx unitmx_inv.
  rewrite mulmxBr mulmxBl mul_mx_scalar -scalemxAl /M /N map_mx_inv.
  rewrite (mulmxV HM) scalemx1 -map_mxM HPA -map_mx_inv -map_mxM.
  by rewrite -mulmxA (mulmxV HP) mulmx1.
case:n B=> [B [eq _ _]|n' B]; first by apply/similar_sym/similar0/esym.
case: m A=> [A [eq _ _]|m' A]; first exact: similar0.
case=> eq _ [M [N [HM HN HA]]]; split=> //.
move: A M N HM HN HA; rewrite eq=> A M N HM HN; rewrite conform_mx_id=> HA.
have [phi [phi_bij phiZ phiC phiG]] := mx_poly_ring_isom R n'.
have: phi M * phi (char_poly_mx A) * phi N = phi (char_poly_mx B).
  by rewrite -!rmorphM -mulmxE HA.
rewrite !{1}rmorphB phiZ !phiC map_polyX=> H.
have HphiM: phi M * ('X - A%:P) = ('X - B%:P) * phi N^-1.
  by rewrite -H -!mulrA -rmorphM mulrV // rmorph1 mulr1.
have HphiN: ('X - A%:P) * phi N = phi M^-1 * ('X - B%:P).
  by rewrite -H !mulrA -rmorphM -mulmxE (mulVmx HM) rmorph1 mul1r.
pose M0 := rmodp_l (phi M) ('X - B%:P).
pose N0 := rmodp (phi N) ('X - B%:P).
pose M1 := rdivp_l (phi M) ('X - B%:P).
pose N1 := rdivp (phi N) ('X - B%:P).
pose R1 := M1 * phi M^-1 + phi N^-1 * N1 - M1 * ('X - A%:P) * N1.
have {}H: M0 * ('X - A%:P) * N0 = (1 - ('X - B%:P) * R1) * ('X - B%:P).
  have HM1: ('X - B%:P) * M1 = phi M - M0.
    by rewrite [phi M](rdivp_l_eq (monicXsubC B)) addrK.
  have HN1: N1 * ('X - B%:P) = phi N - N0.
    by rewrite [phi N](rdivp_eq (monicXsubC B)) addrK.
  rewrite /R1 mulrBr mulrDr !mulrA HM1 mulrBl mulrDl mulrDl.
  rewrite mulNr -![_ * N1 * _]mulrA HN1 2!mulrBl.
  rewrite ![_ * (phi N - N0)]mulrBr ![(phi M - M0) * _]mulrBl.
  rewrite -[_ * _ * phi N]mulrA -!rmorphM divrr // mulVr // !rmorph1 !mulr1.
  rewrite mul1r 2!mulrBl H 3!opprD !opprK !addrA addrN add0r -{1 3}H.
  rewrite !mulrA -[_ * _ * phi M]mulrA -[_ * _ * phi N^-1]mulrA -!rmorphM.
  rewrite divrr // mulVr // !rmorph1 !mulr1 opprB addrA.
  rewrite -{1}[_ + _ - B%:P]addrA subrK (addrC (M0 * _ * _)) addrK.
  by rewrite opprD opprK addrA addrN add0r.
have HM0: size M0 <= 1.
  by rewrite -ltnS -(size_XsubC B) ltn_rmodp_l polyXsubC_eq0.
have HN0: size N0 <= 1.
  by rewrite -ltnS -(size_XsubC B) ltn_rmodp polyXsubC_eq0.
case: (eqVneq R1 0) => HR1; last first.
  have: size ((1 - ('X - B%:P) * R1) * ('X - B%:P)) <= 2.
    rewrite -H; apply:(leq_trans (size_mul_leq _ _)).
    rewrite (size1_polyC HN0) size_polyC -subn1 leq_subLR addnC.
    apply/(leq_add (leq_b1 _))/(leq_trans (size_mul_leq _ _)).
    by rewrite (size1_polyC HM0) size_polyC size_XsubC addnC; exact:leq_b1.
  have Hsize: size (1 - ('X - B%:P) * R1) = (size R1).+1.
    rewrite addrC size_addl size_opp (size_monicM (monicXsubC B) HR1).
      by rewrite {1}size_XsubC.
    rewrite size_polyC oner_neq0 size_XsubC.
    by move:(size_poly_eq0 R1); case:(size R1)=> //; rewrite (negbTE HR1).
  rewrite size_Mmonic.
  + by rewrite Hsize size_XsubC addnC !ltnS leqn0 size_poly_eq0 (negbTE HR1).
  + by rewrite -size_poly_eq0 Hsize.
  exact: monicXsubC.
move:H; rewrite HR1 mulr0 subr0 mul1r (size1_polyC HM0).
rewrite (size1_polyC HN0)=> /polyP H; move:(H 1%N); move:(H 0%N).
rewrite !coefMC !coefCM !coefD !coefN !coefC !coefX !eqxx !sub0r subr0 mulr1.
rewrite mulrN mulNr; move/eqP; rewrite eqr_opp=> /eqP HM0N0 HM0N0I.
case:(mulmx1_unit HM0N0I)=> HM00 HN00.
exists (M0`_0) => //; rewrite conform_mx_id -HM0N0 mulmxE -(divr1 N0`_0).
by rewrite -[1]HM0N0I invrM // mulrA divrr // mul1r -!mulrA mulVr // mulr1.
Qed.

Lemma similar_mxminpoly m' n' (A : 'M[R]_m'.+1) (B : 'M[R]_n'.+1) :
   similar A B -> mxminpoly A = mxminpoly B.
Proof.
move=> HAB; apply/eqP; rewrite -eqp_monic //; try exact: mxminpoly_monic.
apply/andP; split; apply: mxminpoly_min.
  by apply/(similar_horner (similar_sym HAB))/mx_root_minpoly.
by apply/(similar_horner HAB)/mx_root_minpoly.
Qed.

Lemma similar_char_poly m' n' (A : 'M[R]_m') (B : 'M[R]_n') :
    similar A B -> char_poly A = char_poly B.
Proof.
case=> eq [P HP HAB]; rewrite /char_poly /char_poly_mx.
have H: map_mx polyC P \in unitmx by rewrite map_unitmx.
apply: similar_det; split=> //.
rewrite -eq in B HAB *; rewrite conform_mx_id in HAB.
exists (map_mx polyC P) => //; rewrite conform_mx_id.
by rewrite mulmxDr mulmxDl scalar_mxC mulmxN mulNmx -!map_mxM HAB.
Qed.

End Field.

Section DvdRing.

Local Open Scope ring_scope.
Import GRing.Theory.
Variable R : dvdRingType.

Lemma eqd_equiv n m n' m' (s1 s2 : seq R) : n = n' -> m = m' ->
   size s1 = size s2 -> (forall i, nth 0 s1 i %= nth 0 s2 i) ->
   equivalent (diag_mx_seq n m s1) (diag_mx_seq n' m' s2).
Proof.
move=> <- <-.
case: n=> [_ _|n]; first exact: equiv0l.
case: m=> [_ _|m Hs]; first exact: equiv0r.
move: Hs n m.
pose P := (fun (s1 s2 : seq R) => forall n m,
  (forall i, nth 0 s1 i %= nth 0 s2 i) ->
  equivalent (diag_mx_seq n.+1 m.+1 s1) (diag_mx_seq n.+1 m.+1 s2)).
apply: (seq2_ind (P:=P))=> /= [n m _ | x1 x2 s0 s3 IH n m Hi].
  by rewrite !diag_mx_seq_nil; apply: equiv_refl.
rewrite /P !diag_mx_seq_cons.
have IHi: (forall i : nat, s0`_i %= s3`_i).
  by move=> i; move: (Hi i.+1); rewrite -nth_behead.
have Hxp : x1 %= x2 by move: (Hi 0%N); rewrite nth0.
have Hx12: (@equivalent _ 1 1 1 1 x1%:M x2%:M).
  split=> //; case/eqdP: Hxp=> c Hc Hcx.
  rewrite conform_mx_id.
  exists c%:M, 1%:M; split.
  + by rewrite -scalemx1 unitmxZ // unitmx1.
  + by rewrite unitmx1.
  by rewrite mul_scalar_mx scale_scalar_mx mulmx1 Hcx.
apply: (equiv_dgblockmx Hx12).
case: n=> [|n]; first exact: equiv0l.
case: m=> [|m]; first exact: equiv0r.
exact: (IH n m IHi).
Qed.

End DvdRing.


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

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

Print Assumptions sub.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski and Hans Zantema, 2007-04-25

* Polynomial interpretations in the setting of monotone algebras.

- Kim Quyen Ly, 2013-08-29

* Polynomial interpretations in the setting of monotone algebras on
  domain rational numbers.

*)

Require Import NewAPolyInt2 AMonAlg2 ZUtil RelUtil NewPositivePolynom2
  ATrs ListForall NewMonotonePolynom2 LogicUtil BoolUtil NewPolynom2
  OrdRingType2.

Section S.

  Variable Sig : Signature.

  Section TPolyIntQ.

    Record TPolyIntQ : Type := mkbTPolyInt {
      trsIntQ : forall f: Sig, Qpoly (arity f);
      trsIntQ_wm : PolyWeakMonotone trsIntQ
    }.

  End TPolyIntQ.

  Section PolyIntQ.

    Variable pi : TPolyIntQ.

    Definition I := Int_of_PI (trsIntQ_wm pi).

    Definition succQ := QDgt.

    Definition succeqQ := QDge.

    Lemma refl_Dge : reflexive QDge.
    Proof.
      intros [x hs]. unfold QDge. simpl. unfold QgeA. intuition.
    Qed.

    Lemma trans_Dgt : transitive QDgt.
    Proof.
      intros [x hx] [y hy] [z hz].
      unfold QDgt. simpl. apply QgtA_trans.
    Qed.

    Lemma trans_Dge : transitive QDge.
    Proof.
      intros [x hx] [y hy] [z hz].
      unfold QDge. simpl. apply QgeA_trans.
    Qed.

    Definition refl_succeqQ := refl_Dge.

    Definition trans_succQ := trans_Dgt.

    Definition trans_succeqQ := trans_Dge.

    Lemma monotone_succeq : AWFMInterpretation.monotone I succeqQ.

    Proof.
      unfold I. apply pi_monotone_eq.
    Qed.

    Definition succ_wfQ := WF_DgtQ.

    Lemma succ_succeq_compat : absorbs_left succQ succeqQ.

    Proof.
      unfold succQ, succeqQ. intros p q pq. destruct pq as [r [pr rq]].
      unfold QDgt. unfold QDge in pr. unfold QDgt in rq.
      apply QgeA_gtA_trans with (proj1_sig r); auto.
    Qed.

    Definition rulePoly_gtQ del l r := rulePoly_gtQ (trsIntQ pi) del (@mkRule Sig l r).

    Definition succ' del l r := coef_not_neg (rulePoly_gtQ del l r).

    Definition bsucc' del l r := bcoef_not_neg (rulePoly_gtQ del l r).

    Lemma bsucc'_ok : forall del l r, bsucc' del l r = true <-> succ' del l r.

    Proof.
      intros del l r. unfold bsucc', succ'. apply bcoef_not_neg_ok.
    Qed.

    Lemma succ'_dec: forall del, rel_dec (succ' del).

    Proof.
      intros del l r. unfold succ'. eapply dec. apply bcoef_not_neg_ok.
    Defined.

    Definition rulePoly_geQ l r := rulePoly_geQ (trsIntQ pi) (@mkRule Sig l r).

    Definition succeq' l r := coef_not_neg (rulePoly_geQ l r).

    Definition bsucceq' l r := bcoef_not_neg (rulePoly_geQ l r).

    Lemma bsucceq'_ok : forall l r, bsucceq' l r = true <-> succeq' l r.

    Proof.
      intros l r. unfold bsucceq', succeq'. apply bcoef_not_neg_ok.
    Qed.

    Lemma succeq'_dec : rel_dec succeq'.

    Proof.
      intros l r. unfold succeq'. eapply dec. apply bcoef_not_neg_ok.
    Defined.

    Lemma succ'_sub : forall del, (succ' del) << IR I succQ.

    Proof.
      intros del t u tu. unfold I, succQ. set (r := mkRule t u).
      change t with (lhs r). change u with (rhs r).
      apply pi_compat_rule with (del:=del). hyp.
    Qed.

    Lemma succeq'_sub : succeq' << IR I succeqQ.

    Proof.
      intros t u tu. unfold I, succQ. set (r := mkRule t u).
      change t with (lhs r). change u with (rhs r).
      apply pi_compat_rule_weak. hyp.
    Qed.

    (** Record type of MonotoneAlgType. *)

    Variable del: QArith_base.Q.

    Definition matQ := mkbMonoAlgType Sig I QDgt QDge refl_succeqQ
      trans_Dgt trans_Dge monotone_succeq succ_wfQ succ_succeq_compat
      (succ' del) succeq' (succ'_sub del) succeq'_sub (succ'_dec del) succeq'_dec.

    Section ExtendedMonotoneAlgebra.

      Lemma monotone_succ : PolyStrongMonotone (trsIntQ pi)->
        AWFMInterpretation.monotone I succQ.

      Proof.
        unfold I. apply pi_monotone.
      Qed.

    End ExtendedMonotoneAlgebra.

    Require Import List.

    Section fin_Sig.

      Variable Fs : list Sig.
      Variable Fs_ok : forall f : Sig, In f Fs.

      Lemma fin_monotone_succ :
        forallb (fun f => bQpstrong_monotone (trsIntQ pi f)) Fs = true ->
        AWFMInterpretation.monotone I succQ.

      Proof.
        intro H. apply monotone_succ. intro f. rewrite <- bpstrong_monotone_ok.
        rewrite forallb_forall in H. apply H. apply Fs_ok.
      Qed.

    End fin_Sig.

  End PolyIntQ.

End S.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O P A B X : Universe, ((wd_ O P /\ (wd_ X B /\ (wd_ O X /\ (wd_ O B /\ (wd_ A B /\ (wd_ O A /\ (col_ A B X /\ col_ A O B))))))) -> col_ A O X)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Pprime X Y : Universe, ((wd_ A C /\ (wd_ A B /\ (wd_ X Y /\ (col_ A B C /\ col_ A B Pprime)))) -> col_ A C Pprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C IB XB IA XA : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ IB B /\ (wd_ IA A /\ (wd_ XA B /\ (wd_ XB A /\ (wd_ XB B /\ (wd_ XA A /\ (col_ A B IB /\ (col_ IB B C /\ (col_ XB A B /\ (col_ XA A A /\ (col_ B XA C /\ (col_ A XB C /\ (col_ A XA IA /\ col_ B XB IB)))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) (Succ (plus Zero lv2))) (plus (mult lv2 (Succ lv1)) (Succ lv1))).
Admitted.
QuickChick conj25synthconj1.