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 A B T : Universe, ((wd_ A B /\ (wd_ T A /\ (wd_ T B /\ (wd_ O A /\ (wd_ O B /\ (col_ O B T /\ col_ A T B)))))) -> col_ O A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Definition and classification of the [Σ] Type, with primitive projections *)
(** In this file, we classify the basic structure of Σ types ([sigT]
    in Coq).  In particular, we classify equalities of dependent pairs
    (inhabitants of Σ types), so that when we have an equality between
    two such pairs, or when we want such an equality, we have a
    systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Coq.Classes.Morphisms.
Require Import Rewriter.Util.IffT.
Require Import Rewriter.Util.Equality.
Require Import Rewriter.Util.GlobalSettings.
Require Import Rewriter.Util.Notations.

Local Set Primitive Projections.

Delimit Scope primproj_type_scope with primproj_type.
Delimit Scope primproj_scope with primproj.

Import EqNotations.
Module Import Primitive.
  Record sigT {A} P := existT { projT1 : A ; projT2 : P projT1 }.
  Global Arguments existT {_} _ _ _.
  Global Arguments projT1 {_ _} _.
  Global Arguments projT2 {_ _} _.

  Module Export Notations.
    Notation "{ x  &  P }" := (sigT (fun x => P)) : type_scope.
    Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
    Add Printing Let sigT.
  End Notations.

  Add Printing Let sigT.

  Local Set Implicit Arguments.

  Definition sigT_beq A P (eq_A : A -> A -> bool) (eq_P : forall a a', P a -> P a' -> bool) (X Y : @sigT A P) : bool
    := let (a, b) := X in let (a', b') := Y in (eq_A a a' && eq_P _ _ b b')%bool.
  Global Arguments sigT_beq / .
  Lemma sigT_dec_bl A P eq_A eq_P
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (P_bl : forall a a' x y (pf : eq_A a a' = true), eq_P a a' x y = true -> rew [P] (A_bl _ _ pf) in x = y)
        (x y : @sigT A P)
    : sigT_beq eq_A eq_P x y = true -> x = y.
  Proof.
    destruct x as [a b], y as [a' b'].
    specialize (P_bl a a' b b'); cbn.
    generalize dependent (A_bl a a'); clear A_bl; intros A_bl P_bl H.
    edestruct eq_A; cbn in *;
      destruct (eq_A a a');
      first [ specialize (P_bl eq_refl); generalize dependent (A_bl eq_refl)
            | specialize (P_bl H); generalize dependent (A_bl H) ];
      clear A_bl; intros A_bl P_bl; try specialize (P_bl H); subst;
        cbn [eq_rect] in *;
        try reflexivity.
    all: edestruct eq_P; first [ specialize (P_bl eq_refl) | specialize (P_bl H) ]; subst;
      reflexivity.
  Defined.
  Lemma sigT_dec_bl_nd A P eq_A eq_P
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (P_bl : forall a a' x y (pf : a = a'), rew [P] pf in x = y)
        (x y : @sigT A P)
    : sigT_beq eq_A eq_P x y = true -> x = y.
  Proof.
    apply (@sigT_dec_bl A P eq_A eq_P A_bl); intros; apply P_bl.
  Defined.

  Lemma sigT_dec_lb A P eq_A (eq_P : forall a a', P a -> P a' -> bool)
        (A_lb : forall x y : A, x = y -> eq_A x y = true)
        (P_lb : forall a (x y : P a), x = y -> eq_P a a x y = true)
        (x y : @sigT A P)
    : x = y -> sigT_beq eq_A eq_P x y = true.
  Proof.
    intro; subst y; specialize (A_lb _ _ (eq_refl (projT1 x))); specialize (P_lb _ _ _ (eq_refl (projT2 x))); cbn in *.
    edestruct eq_A, eq_P; (reflexivity + assumption).
  Defined.
  Definition sigT_eq_dec A P eq_A eq_P
             (A_bl : forall x y : A, eq_A x y = true -> x = y)
             (P_bl : forall a a' x y (pf : eq_A a a' = true), eq_P a a' x y = true -> rew [P] (A_bl _ _ pf) in x = y)
             (A_lb : forall x y : A, x = y -> eq_A x y = true)
             (P_lb : forall a (x y : P a), x = y -> eq_P a a x y = true)
             (x y : @sigT A P)
    : {x = y} + {x <> y}.
  Proof.
    refine (let H := let b := @sigT_beq A P eq_A eq_P x y in if b as b0 return ({b0 = true} + {b0 = false}) then left eq_refl else right eq_refl in
            match H with
            | left e => left (@sigT_dec_bl A P eq_A eq_P A_bl P_bl x y e)
            | right H' => right (fun e => _ (@sigT_dec_lb A P eq_A eq_P A_lb P_lb x y e))
            end).
    congruence.
  Defined.
End Primitive.
Notation "{ x  &  P }" := (sigT (fun x => P%primproj_type)) : primproj_type_scope.
Notation "{ x : A  & P }" := (sigT (A:=A%primproj_type) (fun x => P%primproj_type)) : primproj_type_scope.
Add Printing Let sigT.

Local Arguments f_equal {_ _} _ {_ _} _.

Definition projT1_existT {A B} (a:A) (b:B a) : projT1 (existT B a b) = a := eq_refl.
Definition projT2_existT {A B} (a:A) (b:B a) : projT2 (existT B a b) = b := eq_refl.
Create HintDb cancel_primsig discriminated. #[global] Hint Rewrite @projT1_existT @projT2_existT : cancel_primsig.

(** ** Equality for [sigT] *)
Section sigT.

  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition pr1_path {A} {P : A -> Type} {u v : sigT P} (p : u = v)
  : projT1 u = projT1 v
    := f_equal (@projT1 _ _) p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition pr2_path {A} {P : A -> Type} {u v : sigT P} (p : u = v)
    : eq_rect _ _ (projT2 u) _ (pr1_path p) = projT2 v.
  Proof.
    destruct p; reflexivity.
  Defined.

  (** *** Equality of [sigT] is itself a [sigT] *)
  Definition path_sigT_uncurried {A : Type} {P : A -> Type} (u v : sigT P)
             (pq : sigT (fun p : projT1 u = projT1 v => eq_rect _ _ (projT2 u) _ p = projT2 v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct q; simpl in *.
    destruct p; reflexivity.
  Defined.

  (** *** Curried version of proving equality of sigma types *)
  Definition path_sigT {A : Type} {P : A -> Type} (u v : sigT P)
             (p : projT1 u = projT1 v) (q : eq_rect _ _ (projT2 u) _ p = projT2 v)
  : u = v
    := path_sigT_uncurried u v (existT _ p q).

  (** *** Equality of [sigT] when the property is an hProp *)
  Definition path_sigT_hprop {A P} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u v : @sigT A P)
             (p : projT1 u = projT1 v)
    : u = v
    := path_sigT u v p (P_hprop _ _ _).

  (** *** Equivalence of equality of [sigT] with a [sigT] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of Σ types
      in dependent positions, we'd need it. *)
  Definition path_sigT_uncurried_iff {A P}
             (u v : @sigT A P)
    : u = v <-> (sigT (fun p : projT1 u = projT1 v => eq_rect _ _ (projT2 u) _ p = projT2 v)).
  Proof.
    split; [ intro; subst; exists eq_refl; reflexivity | apply path_sigT_uncurried ].
  Defined.

  (** *** Induction principle for [@eq (sigT _)] *)
  Definition path_sigT_rect {A P} {u v : @sigT A P} (Q : u = v -> Type)
             (f : forall p q, Q (path_sigT u v p q))
    : forall p, Q p.
  Proof. intro p; specialize (f (pr1_path p) (pr2_path p)); destruct p; exact f. Defined.
  Definition path_sigT_rec {A P u v} (Q : u = v :> @sigT A P -> Set) := path_sigT_rect Q.
  Definition path_sigT_ind {A P u v} (Q : u = v :> @sigT A P -> Prop) := path_sigT_rec Q.

  (** *** Equivalence of equality of [sigT] involving hProps with equality of the first components *)
  Definition path_sigT_hprop_iff {A P} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u v : @sigT A P)
    : u = v <-> (projT1 u = projT1 v)
    := conj (f_equal projT1) (path_sigT_hprop P_hprop u v).

  (** *** Non-dependent classification of equality of [sigT] *)
  Definition path_sigT_nondep {A B : Type} (u v : @sigT A (fun _ => B))
             (p : projT1 u = projT1 v) (q : projT2 u = projT2 v)
  : u = v
    := @path_sigT _ _ u v p (eq_trans (transport_const _ _) q).

  (** *** Classification of transporting across an equality of [sigT]s *)
  Lemma eq_rect_sigT {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : sigT (Q x)) {y} (H : x = y)
  : eq_rect x (fun a => sigT (Q a)) u y H
    = existT
        (Q y)
        (eq_rect x P (projT1 u) y H)
        match H in (_ = y) return Q y (eq_rect x P (projT1 u) y H) with
          | eq_refl => projT2 u
        end.
  Proof.
    destruct H; reflexivity.
  Defined.

  (** *** η Principle for [sigT] *)
  Definition sigT_eta {A P} (p : { a : A & P a })
    : p = existT _ (projT1 p) (projT2 p)
    := eq_refl.
End sigT.

(** ** Useful Tactics *)
(** *** [inversion_sigma] *)
(** The built-in [inversion] will frequently leave equalities of
    dependent pairs.  When the first type in the pair is an hProp or
    otherwise simplifies, [inversion_sigma] is useful; it will replace
    the equality of pairs with a pair of equalities, one involving a
    term casted along the other.  This might also prove useful for
    writing a version of [inversion] / [dependent destruction] which
    does not lose information, i.e., does not turn a goal which is
    provable into one which requires axiom K / UIP.  *)
Ltac simpl_proj_exist_in H :=
  repeat match type of H with
         | context G[projT1 (existT _ ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[projT2 (existT _ ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_sigma_in_as_using H H0 H1 rect :=
  induction H as [H0 H1] using (rect _ _ _ _);
  simpl_proj_exist_in H0;
  simpl_proj_exist_in H1.
Ltac induction_sigma_in_using H rect :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction_sigma_in_as_using H H0 H1 rect.
Ltac inversion_sigma_step :=
  match goal with
  | [ H : _ = existT _ _ _ |- _ ]
    => induction_sigma_in_using H @path_sigT_rect
  | [ H : existT _ _ _ = _ |- _ ]
    => induction_sigma_in_using H @path_sigT_rect
  end.
Ltac inversion_sigma := repeat inversion_sigma_step.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier Psatz Omega.

Definition output {A} (p: ldist A) := [seq i.2 | i <- outcomes p].

Definition mspec {A: eqType} (m: ldist A) (P: A → Prop) :=
  ∀ y, y \in output m → P y.

Lemma mspec_mret {A: eqType} (x: A) (P: A → Prop):
  P x → mspec (mret x) P.
Proof.
  intros HP y. rewrite /mret/dist_ret/output//= mem_seq1.
  move /eqP => -> //.
Qed.

Lemma mspec_conseq {A: eqType} (m: ldist A) (P Q: A → Prop):
  mspec m P → (∀ a, P a → Q a) → mspec m Q.
Proof.
  intros HP HPQ a Hin. apply HPQ; eauto.
Qed.

Lemma output_mbind_in {A B: eqType} b (m: ldist A) (f: A → ldist B):
  (b \in output (x ← m; f x)) →
  ∃ r a, ((r, a)) \in outcomes m ∧ (b \in output (f a)).
Proof.
  rewrite /mbind/output.
  move /mapP => [[r b' Hin]] => //= ->.
  eapply (in_ldist_bind _ r b' m) in Hin as (r'&r''&c'&Hin1&Hin2&Heq).
  exists r'', c'; split; auto. apply /mapP; eauto.
Qed.

Lemma mspec_mbind {A B: eqType} (f: A → ldist B) m (P: A → Prop) (Q: B → Prop):
  mspec m P →
  (∀ a, P a → mspec (f a) Q) →
  mspec (mbind f m) Q.
Proof.
  intros Hinput Hbody b Hin.
  edestruct (output_mbind_in b m f) as (r&?&Hin'&Hout); eauto.
  eapply Hbody; eauto. apply Hinput; eauto.
  apply /mapP; eauto.
Qed.

Tactic Notation "tbind" open_constr(P) :=
  match goal with
  | [ |- mspec (mbind ?f ?m) ?Q ] =>
    intros; eapply (@mspec_mbind _ _ f m P); auto
  end.

Lemma fun_to_mspec {A: eqType} (m: ldist A) (P: A → Prop):
  mspec m P → (∀ x, P ((rvar_of_ldist m) x)).
Proof.
  rewrite /mspec/output => Hspec /= x.
  apply /Hspec/mem_nth. rewrite size_map. inversion x. done.
Qed.

Lemma mspec_range_eq_dist {A: eqType} (m1 m2: ldist A) (P: pred A):
  mspec m1 P →
  mspec m2 P →
  (∀ a, P a → pr_eq (rvar_of_ldist m1) a = pr_eq (rvar_of_ldist m2) a) →
  eq_dist (rvar_of_ldist m1) (rvar_of_ldist m2).
Proof.
  intros Hm1 Hm2 Hin_eq a.
  specialize (Hm1 a). rewrite //= in Hm1.
  specialize (Hm2 a). rewrite //= in Hm2.
  specialize (Hin_eq a).
  case_eq (P a).
  - intros HP. apply Hin_eq. auto.
  - intros HnP. transitivity 0; last symmetry.
    * apply pr_img_nin. intros Hin. move /negP in HnP. apply HnP.
      apply Hm1. by rewrite /output -mem_undup -img_rvar_of_ldist'.
    * apply pr_img_nin. intros Hin. move /negP in HnP. apply HnP.
      apply Hm2. by rewrite /output -mem_undup -img_rvar_of_ldist'.
Qed.

Lemma mspec_eq_dist_ldist_bind_ext {A B: eqType} m P (f g: A → ldist B):
  mspec m P →
  (∀ a, P a → eq_dist (rvar_of_ldist (f a)) (rvar_of_ldist (g a))) →
  eq_dist (rvar_of_ldist (mbind f m)) (rvar_of_ldist (mbind g m)).
Proof.
  intros Hspec.
  rewrite /eq_dist => Heq b. rewrite ?pr_mbind_ldist1.
  eapply eq_bigr => a _. rewrite Heq; first done.
  apply Hspec. rewrite /output.
  rewrite -mem_undup -img_rvar_of_ldist'.
  destruct a as (x&Hin) => //=.
Qed.

Lemma Ex_bound {A : eqType} (X: ldist A) f r:
  mspec X (λ x, f x <= r) →
  Ex (rvar_comp (rvar_of_ldist X) f) <= r.
Proof.
  intros Hmspec. rewrite Ex_fin_comp.
  eapply Rle_trans.
  {
    eapply Rle_bigr => i _.
    apply Rmult_le_compat_l; last apply Hmspec.
    - apply Rge_le, ge_pr_0.
    - destruct i as (?&?) => //=. rewrite /output -mem_undup -img_rvar_of_ldist' //.
  }
  rewrite -big_distrl //= (pr_sum_all (rvar_of_ldist X)) Rmult_1_l. fourier.
Qed.


(***************************************************************************
* Safety for STLC with Exceptions - Infrastructure                         *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN
  STLC_Exn_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

(** Computing free variables of a term. *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs t1    => (fv t1)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_raise t1  => (fv t1)
  | trm_catch t1 t2 => (fv t1) \u (fv t2)
  end.

(** Substitution for names *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (subst z u t1)
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_raise t1  => trm_raise (subst z u t1)
  | trm_catch t1 t2 => trm_catch (subst z u t1) (subst z u t2)
  end.

Notation "[ z ~> u ] t" := (subst z u t) (at level 68).

(** Definition of the body of an abstraction *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

(** Tactic [pick_fresh] is used to pick fresh names *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C \u D).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto*.

Hint Constructors term value fails red.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*. unfolds open.
  pick_fresh x. apply* (@open_rec_term_core t1 0 (trm_fvar x)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*. case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2).
Proof.
  intros. unfold open. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_var : forall x y u t, y <> x -> term u ->
  ([x ~> u]t) ^ y = [x ~> u] (t ^ y).
Proof.
  introv Neq Wu. rewrite* subst_open.
  simpl. case_var*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* subst_open.
  rewrite* subst_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs as y. rewrite* subst_open_var.
Qed.

Hint Resolve subst_term.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> body t1.
Proof.
  intros. unfold body. inversion* H.
Qed.

Lemma body_to_term_abs : forall t1,
  body t1 -> term (trm_abs t1).
Proof.
  intros. inversion* H.
Qed.

Hint Resolve term_abs_to_body body_to_term_abs.

(** ** Opening a body with a term gives a term *)

Lemma open_term : forall t u,
  body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro y).
Qed.

Hint Resolve open_term.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma typing_regular : forall E t T,
  typing E t T -> ok E /\ term t.
Proof.
  split; induction H; auto*.
  pick_fresh y. forwards~ K: (H0 y).
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall t,
  value t -> term t.
Proof.
  induction 1; auto*.
Qed.

(** A fails relation only holds on pairs of locally-closed terms. *)

Lemma fails_regular : forall t e,
  fails t e -> term t /\ term e.
Proof.
  lets: value_regular. induction 1;  jauto.
Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Lemma red_regular : forall t t',
  red t t' -> term t /\ term t'.
Proof.
  lets: value_regular. induction 1; jauto.
  lets: (fails_regular H1). jauto.
Qed.

(** Automation for reasoning on well-formedness. *)

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

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: fails t _ |- _ => apply (proj1 (fails_regular H))
  | H: fails _ t |- _ => apply (proj2 (fails_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import bigops ssralg poly.

Import GRing.

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

Open Scope ring_scope.

Section ExtraArith.

Lemma leqn1 : (forall n, n <= 1 = ((n==0) || (n==1)))%N.
Proof. by elim; first done; elim. Qed.

Lemma leqn2 : (forall n, n <= 2 = [|| n == 0,  n == 1 | n == 2])%N.
Proof. by elim; first done; elim; first done; elim. Qed.

Lemma addn_pred1 : (forall n m, n != 0 -> (n == (m + n).-1) = (m == 1))%N.
Proof.
case; first by elim.
move=> n m _; by rewrite addnS /= -add1n eqn_addr eq_sym.
Qed.
End ExtraArith.

Section ExtraPolynomialIdomain.

Variable R : idomainType.
Implicit Types x y c : R.
Implicit Types p q r d : {poly R}.

Lemma size1_is_polyC : forall p,
  reflect (exists c, c != 0 /\ p = c%:P) (size p == 1%N).
Proof.
move=> p; apply: (iffP eqP) => [s1 | [c [nc0 ep]]].
  exists p`_0; move: (leqnn (size p)); rewrite {2}s1; move/size1_polyC=> e.
  by split=> //; rewrite -polyC_eq0 -e -size_poly_eq0 s1.
by rewrite ep size_polyC nc0.
Qed.

Lemma size1_dvdp1 : forall p, (size p == 1%N) = (p %= 1).
Proof.
move=> p; apply/size1_is_polyC/idP=> [[c [cn0 ep]] |].
  by apply/eqpP; exists 1; exists c; rewrite oner_eq0 mulr1 polyC1 mul1r.
by move/size_eqp; rewrite size_poly1; move/eqP; move/size1_is_polyC.
Qed.

Lemma neqp01 : 0 %= (1 : {poly R}) = false.
Proof.
case abs : (0 %= 1) => //; case/eqpP: abs=> c1 [c2 [c1n0 c2n0]].
by rewrite mulr0 mulr1; move/eqP; rewrite eq_sym polyC_eq0 (negbTE c2n0).
Qed.

Lemma dvd0p : forall p, 0 %| p = (p == 0).
Proof. by move=> p; rewrite /dvdp modp0. Qed.

Lemma dvdp_eqp1 : forall p q, p %| q -> q %= 1 -> p %= 1.
Proof.
move=> p q dpq hq.
have sizeq : size q == 1%N by rewrite size1_dvdp1.
have n0q : q != 0.
  by case abs: (q == 0) => //; move: hq; rewrite (eqP abs) neqp01.
rewrite -size1_dvdp1 eqn_leq -{1}(eqP sizeq) size_dvdp //=.
case p0 : (size p == 0%N); last by rewrite neq0_lt0n.
move: dpq;  rewrite size_poly_eq0 in p0.
by rewrite (eqP p0) dvd0p (negbTE n0q).
Qed.

Lemma dvdpn0 : forall p q, p %| q -> q != 0 -> p != 0.
Proof.
move=> p q pq; apply: contra=> p0.
by move:pq; rewrite (eqP p0) dvd0p.
Qed.

Lemma dvdp_mulIl : forall p q, p %| p * q.
Proof. by move=> p q; apply: dvdp_mulr; exact: dvdpp. Qed.

Lemma dvdp_mulIr : forall p q, q %| p * q.
Proof. by move=> p q; apply: dvdp_mull; exact: dvdpp. Qed.

Lemma eqp_polyC: forall c, (c != 0) = (c%:P %= 1).
Proof.
move=> c; apply/idP/eqpP=> [nc0 | [x] [y]].
  by exists 1; exists c; rewrite nc0 /= nonzero1r mulrC.
case c0 : (c == 0); rewrite // mulr1 (eqP c0) mulr0; case=> _ /=; move/negbTE<-.
by move/eqP; rewrite eq_sym polyC_eq0.
Qed.

Lemma gcd1p : forall p, gcdp 1 p %= 1.
Proof.
move=> p; rewrite -size1_dvdp1 gcdpE size_poly1; case: ltnP.
  by rewrite modp1 gcd0p size_poly1 eqxx.
move/size1_polyC=> e; rewrite e.
case p00: (p`_0 == 0); first by rewrite (eqP p00) modp0 gcdp0 size_poly1.
by rewrite modpC ?p00 // gcd0p size_polyC p00.
Qed.

Lemma modp_dvd : forall p q, (q %| p) -> p %% q = 0.
Proof. by move=> p q; rewrite /dvdp; move/eqP. Qed.

Lemma modp_dvd_eq0 : forall p q, (q %| p) = (p %% q == 0).
Proof. by move=> p q; rewrite /dvdp. Qed.

Lemma eqp_dvdr : forall q p d, p %= q -> d %| p = (d %| q).
Proof.
move=> q p d epq; move: q p epq.
suff: forall q p, p %= q -> (d %| p) -> (d %| q)=> [Hpq|] q p.
  by move=> pq; apply/idP/idP; apply: Hpq; rewrite // eqp_sym.
by rewrite /eqp; case/andP=> pq qp dp; apply: (dvdp_trans dp).
Qed.

Lemma eqp_dvdl : forall d' d p, d %= d' -> d %| p = (d' %| p).
move=> d' d p edd'; move: d' d edd'.
suff: forall d' d, d %= d' -> (d %| p) -> (d' %| p)=> [Hdd'|] d' d.
  by move=> dd'; apply/idP/idP; apply: Hdd'; rewrite // eqp_sym.
by rewrite /eqp; case/andP=> dd' d'd dp; apply: (dvdp_trans d'd).
Qed.

Lemma eqp1_dvd : forall d p, d %= 1 -> d %| p.
Proof. by move=> d p d1; rewrite (@eqp_dvdl 1)// dvd1p. Qed.

Lemma eqp1_dvd1 : forall d, (d %= 1) = (d %| 1).
Proof.
move=> d; apply/idP/idP; first exact: eqp1_dvd.
move=> d1; move/size_dvdp:(d1); rewrite GRing.nonzero1r size_poly1.
rewrite leqn1 size_poly_eq0; case d0 : (_ == _)=> /=.
  by move: d1; rewrite (eqP d0) dvd0p oner_eq0.
by rewrite size1_dvdp1=> d'1; apply: d'1.
Qed.

Lemma eqp_mulC : forall p q c, c != 0 -> c%:P * p %= p.
Proof.
move=> p q c c0; apply/eqpP; exists 1; exists c; rewrite c0 oner_eq0.
by split=> //; rewrite polyC1 mul1r.
Qed.

Lemma dvdp_size_eqp : forall p q, p %| q -> size p == size q = (p %= q).
Proof.
move=> p q pq; apply/idP/idP; last by move/size_eqp->.
case q0: (q == 0).
  by rewrite (eqP q0) size_poly0 size_poly_eq0; move/eqP->; rewrite eqpxx.
case p0: (p == 0).
  by rewrite (eqP p0) size_poly0 eq_sym size_poly_eq0; move/eqP->; rewrite eqpxx.
case/dvdpPc:pq=> x [qq [x0]]=> eqpq.
move:(eqpq); move/(congr1 (size \o (@polyseq R)))=> /=.
rewrite (@size_eqp _ _ q); last exact: eqp_mulC.
rewrite size_mul_id ?p0 //.
  move ->; rewrite addn_pred1 ?size_poly_eq0 ?p0 // => sqq.
  apply/eqpP; exists qq`_0; exists x.
  split; rewrite // -1?polyC_eq0 -?size1_polyC ?(eqP sqq) //.
  by rewrite -size_poly_eq0 (eqP sqq).
move/eqP:eqpq; apply: contraL; move/eqP->; rewrite mul0r.
by rewrite mulf_neq0 ?q0 ?polyC_eq0.
Qed.

Lemma size_divp : forall p q, q != 0 -> size q <= size p
  -> size (p %/ q) = ((size p) - (size q).-1)%N.
Proof.
move=> p q nq0 sqp.
move: (nq0); rewrite -size_poly_eq0 -lt0n=> lt0sq.
move: (sqp); move/(leq_trans lt0sq) => lt0sp.
move: (lt0sp); rewrite lt0n size_poly_eq0=> p0.
case:(divp_spec p q).
move/(congr1 (size \o (@polyseq R)))=> /=.
rewrite (@size_eqp _ _ p) ?eqp_mulC ?scalp_id //.
case qq0: (p %/ q == 0).
  rewrite (eqP qq0) mul0r add0r=> es.
  by have:= modp_spec p nq0; rewrite -es ltnNge sqp.
move/negP:(qq0); move/negP; rewrite -size_poly_eq0 -lt0n=> lt0qq.
rewrite size_addl.
  rewrite size_mul_id ?qq0 // => ->.
  apply/eqP; rewrite -(eqn_addr ((size q).-1)).
  rewrite subnK; first by rewrite -subn1 addn_subA // subn1.
  rewrite /leq -(subn_add2l 1%N) !add1n prednK // (@ltn_predK (size q)) //.
    by rewrite addnC -subn_sub subnn sub0n.
  by rewrite -[size q]add0n ltn_add2r.
rewrite size_mul_id ?qq0 // (leq_trans (modp_spec _ nq0)) //.
rewrite /leq -(subn_add2l 1%N) !add1n (@ltn_predK (size q)).
  by rewrite addnC -subn_sub subSnn subn_eq0.
by rewrite -[size q]add0n ltn_add2r.
Qed.

Lemma eqp_transl : left_transitive (@eqp R).
Proof.
move=> p q r pq.
by apply/idP/idP=> e; apply: eqp_trans e; rewrite // eqp_sym.
Qed.

Lemma eqp_transr : right_transitive (@eqp R).
Proof. by move=> x y xy z; rewrite eqp_sym (eqp_transl xy) eqp_sym. Qed.

Lemma gcdp_eq0 : forall p q, gcdp p q == 0 = (p == 0) && (q == 0).
Proof.
move=> p q; apply/idP/idP; last first.
  by case/andP; move/eqP->; move/eqP->; rewrite gcdp0.
move: p q; suff: forall p q,  gcdp p q == 0 -> (p == 0)=> [Hpq|] p q.
  move=> gpq0; apply/andP; split; [apply: (Hpq p q) | apply: (Hpq q p)]=> //.
  by rewrite -eqp0E (eqp_transl (gcdpC _ _)) eqp0E.
move=> gpq0; rewrite -dvd0p.
apply: dvdp_trans (dvdp_gcdl p q).
by rewrite dvd0p.
Qed.

Definition coprimep p q := size (gcdp p q) == 1%N.

Lemma size_gcdp1 : forall p q, size (gcdp p q) == 1%N = (coprimep p q).
Proof. done. Qed.

Lemma gcdp_eqp1 : forall p q, gcdp p q %= 1 = (coprimep p q).
Proof. by move=> p q; rewrite -size1_dvdp1 size_gcdp1. Qed.

Lemma coprimep_sym : forall p q, coprimep p q = coprimep q p.
Proof.
by move=> p q; rewrite -!gcdp_eqp1; apply: eqp_transl; rewrite gcdpC.
Qed.

Lemma coprime1p: forall p, coprimep 1 p.
Proof.
move=> p; rewrite /coprimep -[1%N](size_poly1 R); apply/eqP; apply: size_eqp.
exact: gcd1p.
Qed.

Lemma coprimep1 : forall p, coprimep p 1.
Proof. by move=> p; rewrite coprimep_sym; apply: coprime1p. Qed.

Lemma coprimep0 : forall p, coprimep p 0 = (p %= 1).
Proof. by move=> p; rewrite /coprimep gcdp0 size1_dvdp1. Qed.

Lemma coprime0p : forall p, coprimep 0 p = (p %= 1).
Proof. by move=> p; rewrite coprimep_sym coprimep0. Qed.

Lemma coprimepP : forall p q,
  reflect (forall d, d %| p -> d %| q -> d %= 1) (coprimep p q).
Proof.
move=> p q; apply: (iffP idP)=> [|h].
  rewrite /coprimep; move/eqP=> hs d dvddp dvddq.
  have dvddg: d %| gcdp p q by rewrite dvdp_gcd dvddp dvddq.
  by apply: (dvdp_eqp1 dvddg); rewrite -size1_dvdp1; apply/eqP.
by case/andP: (dvdp_gcd2 p q)=> h1 h2; rewrite /coprimep size1_dvdp1; apply: h.
Qed.

Lemma coprimepPn : forall p q, p != 0 ->
  reflect (exists d, (d %| gcdp p q) && ~~(d %= 1))  (~~ coprimep p q).
Proof.
move=> p q p0; apply: (iffP idP).
  by rewrite -gcdp_eqp1=> ng1; exists (gcdp p q); rewrite dvdpp /=.
case=> d; case/andP=> dg; apply: contra; rewrite -gcdp_eqp1=> g1.
by move: dg; rewrite (eqp_dvdr _ g1) eqp1_dvd1.
Qed.

Lemma coprimep_dvdl : forall p q r,
  r %| q -> coprimep p q -> coprimep p r.
Proof.
move=> p q r rq cpq.
apply/coprimepP=> d dp dr; move/coprimepP:cpq=> cpq'.
by apply: cpq'; rewrite // (dvdp_trans dr).
Qed.

Lemma modp_mod : forall p q, (p %% q) %% q = p %% q.
Proof.
move=> p q; case q0: (q == 0); first by rewrite (eqP q0) modp0.
by rewrite modp_size // modp_spec // q0.
Qed.

Fixpoint egcdp_rec p q n {struct n} :=
  if n is n'.+1 then
    if q == 0 then (1, 0) else
    let: (u, v) := egcdp_rec q (p%%q) n' in
      ((v * (scalp p q)%:P), (u - v * (p %/ q)))
  else (1, 0).
Definition egcdp p q := egcdp_rec p q (size q).

Lemma egcdp_recP : forall n p q, size q <= n -> size q <= size p
  -> let e := (egcdp_rec p q n) in gcdp p q %= e.1*p + e.2*q.
Proof.
elim=> [|n ihn] p q /=.
  rewrite leqn0 size_poly_eq0; move/eqP=> -> _.
  by rewrite gcdp0 mul1r mulr0 addr0 eqpxx.
move=> sqSn qsp.
case q0: (q == 0)=> /=.
  by rewrite (eqP q0) gcdp0 mul1r mulr0 addr0 eqpxx.
have := (ihn q (p %% q)_ _).
case: (egcdp_rec _ _)=> u v=> ihn'.
rewrite gcdpE ltnNge qsp //= (eqp_transl (gcdpC _ _)).
apply: (eqp_trans (ihn' _ _)).
- by rewrite -(leq_add2l 1) !add1n (leq_trans (modp_spec _ _)) ?q0.
- by rewrite -(leq_add2l 1) !add1n (leq_trans (modp_spec _ _)) ?q0 ?leqnSn.
case: (divp_spec p q). rewrite -mulrA=> ->.
rewrite eqp_sym mulr_addr mulr_subl mulrA /=.
by rewrite addrC addrA -[_-_+_]addrA addNr addr0 eqpxx.
Qed.

Lemma egcdpPS : forall p q, size q <= size p
  -> let e := egcdp p q in gcdp p q %= e.1*p + e.2*q.
Proof.
move=> p q sqp; rewrite /egcdp //=.
apply: egcdp_recP; rewrite ?leqnn // sqp.
Qed.

Lemma egcdpPW : forall p q, exists u, exists v, (u*p + v*q) %= (gcdp p q).
Proof.
move=> p q; case: (leqP (size p) (size q))=> sqp /=.
  - exists (egcdp q p).2; exists (egcdp q p).1.
    rewrite (eqp_transr (gcdpC _ _)).
    by rewrite addrC eqp_sym; apply: egcdpPS.
  - exists (egcdp p q).1; exists (egcdp p q).2.
    by rewrite eqp_sym; apply: egcdpPS (ltnW _).
Qed.

Lemma coprimepPW : forall p q,
  reflect (exists u, exists v, (u*p + v*q) %= 1) (coprimep p q).
Proof.
move=> p q; rewrite -gcdp_eqp1; apply:(iffP idP)=> [g1|].
  case: (egcdpPW p q) => [u [v Puv]]; exists u; exists v.
  exact: eqp_trans g1.
move=>[u [v]]; rewrite eqp_sym=> Puv.
rewrite eqp1_dvd1; rewrite (eqp_dvdr _ Puv).
by rewrite dvdp_addr dvdp_mull ?dvdp_gcdl ?dvdp_gcdr.
Qed.

Lemma eqp_mull : forall p q r, (q %= r) -> (p * q %= p * r).
Proof.
move=> p q r.
  case/eqpP=>[c[d [c0 d0 e]]].
  apply/eqpP; exists c; exists d.
  by split=> //; rewrite !mulrA mulrAC e mulrAC.
Qed.

Lemma gauss : forall p q d, coprimep d q -> d %| p = (d %| p * q).
Proof.
move=> p q d.
move/coprimepPW=>[u [v Puv]].
apply/idP/idP; first exact: dvdp_mulr.
move:Puv; move/(eqp_mull p).
rewrite mulr1 mulr_addr eqp_sym=> peq dpq.
rewrite (eqp_dvdr _  peq) dvdp_addr.
  by rewrite mulrA mulrAC dvdp_mulr.
by rewrite mulrA dvdp_mull ?dvdpp.
Qed.

(* "gdcop Q P" is the Greatest Divisor of P which is coprime to Q *)
(* if P null, we pose that gdcop returns 1 if Q null, 0 otherwise*)
Fixpoint gdcop_rec q p n :=
  if n is m.+1 then
      if coprimep p q then p
        else gdcop_rec q (p %/ (gcdp p q)) m
    else (q == 0)%:R.
Definition gdcop q p := gdcop_rec q p (size p).

CoInductive gdcop_spec q p : {poly R} -> Type :=
  GdcopSpec r of (r %| p) & ((coprimep r q) || (p == 0))
  & (forall d,  d %| p -> coprimep d q -> d %| r)
  : gdcop_spec q p r.

Lemma gdcop0 : forall q, gdcop q 0 = (q == 0)%:R.
Proof. by move=> q; rewrite /gdcop size_poly0. Qed.

Lemma eqPn0 : (forall n, (n.-1 == 0) = ((n==0) || (n==1)))%N.
Proof. by elim. Qed.

Lemma divpp : forall p, p != 0 -> p %/ p = (scalp p p)%:P.
Proof.
move=> p np0; case: (divp_spec p p).
rewrite modpp addr0. move/eqP.
by rewrite (inj_eq (mulIf np0)); move/eqP.
Qed.

Lemma gdcop_recP : forall q p n,
  size p <= n -> gdcop_spec q p (gdcop_rec q p n).
Proof.
move=> q p n; elim: n p => [p | n ihn p] /=.
  rewrite leqn0 size_poly_eq0; move/eqP->.
  case q0: (_ == _); split; rewrite ?coprime1p ?dvdp0 ?eqxx ?orbT //.
  by move=> d _; rewrite (eqP q0) coprimep0 -eqp1_dvd1.
move=> hs; case cop : (coprimep _ _); first by split; rewrite ?dvdpp ?cop.
case p0 : (p == 0).
  by rewrite (eqP p0) div0p; apply: ihn; rewrite size_poly0 leq0n.
case q0: (q == 0).
  rewrite (eqP q0) gcdp0 divpp ?p0 //= => {hs ihn}; case: n=> /=.
    rewrite eqxx; split; rewrite ?dvd1p ?coprimep0 ?eqpxx //=.
    by move=> d _; rewrite coprimep0 eqp1_dvd1.
  move=> n; rewrite coprimep0 -eqp_polyC scalp_id.
  split; first by rewrite (@eqp_dvdl 1) ?dvd1p -?eqp_polyC ?scalp_id //.
    by rewrite coprimep0 -eqp_polyC scalp_id.
  by move=> d _; rewrite coprimep0; move/eqp_dvdl->; rewrite dvd1p.
(* should we have a spec for dvdn ? => I also wondered *)
case: (divp_spec p (gcdp p q)); rewrite modp_dvd ?dvdp_gcdl // addr0 => e.
have sgp : size (gcdp p q) <= size p.
  by apply: size_dvdp; rewrite ?gcdp_eq0 ?p0 ?q0 // dvdp_gcdl.
have : p %/ gcdp p q != 0; last move/negPf=>p'n0.
  move: (dvdp_mulIl (p %/ gcdp p q) (gcdp p q)); move/dvdpn0; apply; rewrite -e.
  by rewrite -size_poly_eq0 size_polyC_mul ?scalp_id //size_poly_eq0 p0.
have gn0 : gcdp p q != 0.
  move: (dvdp_mulIr (p %/ gcdp p q) (gcdp p q)); move/dvdpn0; apply; rewrite -e.
  by rewrite -size_poly_eq0 size_polyC_mul ?scalp_id //size_poly_eq0 p0.
have sp' : size (p %/ (gcdp p q)) <= n.
  rewrite size_divp ?sgp // leq_sub_add (leq_trans hs)//.
  rewrite -add1n leq_add2r lt0n eqPn0 negb_orb size_poly_eq0 gn0 /=.
  by rewrite size_gcdp1 cop.
case (ihn _ sp')=> r' dr'p'; first rewrite p'n0 orbF=> cr'q maxr'.
constructor=> //=; rewrite ?p0 ?orbF //.
  apply: (dvdp_trans dr'p').
  apply/dvdpPc; exists (scalp p (gcdp p q)); exists (gcdp p q).
  by rewrite e mulrC scalp_id.
move=> d dp cdq.
apply: maxr'; last by rewrite cdq.
case dpq: (d %| gcdp p q).
  move: (dpq); rewrite dvdp_gcd dp /= => dq.
  apply: eqp1_dvd; move: cdq; apply: contraLR=> nd1.
  apply/coprimepPn.
    move/negP: p0; move/negP; apply: contra=> d0.
    by move:dp; rewrite (eqP d0) dvd0p.
  by exists d; rewrite dvdp_gcd dvdpp dq nd1.
move: (dp); apply: contraLR=> ndp'.
rewrite (@eqp_dvdr ((scalp p (gcdp p q))%:P*p)).
  by rewrite e; rewrite -gauss //; apply: (coprimep_dvdl (dvdp_gcdr _ _)).
by rewrite eqp_sym eqp_mulC // scalp_id.
Qed.

Lemma gdcopP : forall q p, gdcop_spec q p (gdcop q p).
Proof. by move=> q p; rewrite /gdcop; apply: gdcop_recP. Qed.

Lemma dvdp_gdco : forall p q d,
  p != 0 -> size d == 2%N ->
  (d %| p) && ~~(d %| q) = (d %| (gdcop q p)).
Proof.
move=> p q d p0 sd.
apply/idP/idP.
  case/andP=> dp dq.
  case: gdcopP=> r rp crq maxr.
  apply: maxr=> //.
  apply/negPn; apply/negP; case/coprimepPn.
    by move:p0; apply:contra=> d0; move: dp; rewrite (eqP d0) dvd0p.
  move=> x; case/andP.
  rewrite dvdp_gcd; case/andP=> xd xq nx1.
  case nd0: (d == 0).
    by move: dp p0; rewrite (eqP nd0) dvd0p=> ->.
  move:(xd); move/negP: nd0; move/negPn=> nd0; move/(size_dvdp nd0).
  rewrite (eqP sd) leqn2; case/or3P.
  * rewrite size_poly_eq0=> x0; rewrite (eqP x0) dvd0p in xd.
    by rewrite (eqP xd) size_poly0 in sd.
  * by rewrite size1_dvdp1=> x1; rewrite x1 in nx1.
  * rewrite -(eqP sd) dvdp_size_eqp // => exd.
    by rewrite (eqp_dvdl _ exd) in xq; rewrite xq in dq.
case: gdcopP=> r rp crq maxr dr.
move/negPf: (p0)=> p0f.
rewrite (dvdp_trans dr) //=.
move: crq; apply: contraL=> dq; rewrite p0f orbF; apply/coprimepPn.
  by move:p0; apply: contra=> r0; move: rp; rewrite (eqP r0) dvd0p.
by exists d; rewrite dvdp_gcd dr dq -size1_dvdp1 (eqP sd).
Qed.

Lemma root_gdco : forall p q, p != 0 ->
  forall x, root p x && ~~(root q x) = root (gdcop q p) x.
Proof.
move=> p q p0 x.
rewrite !root_factor_theorem.
apply: dvdp_gdco; rewrite ?p0 //.
rewrite size_addl size_polyX // size_opp size_polyC.
by case: (x != 0).
Qed.

Lemma root_mul : forall p q x, root (p * q) x = root p x || root q x.
Proof. by move=> p q x; rewrite /root horner_mul mulf_eq0. Qed.

Lemma eqp_root : forall p q, p %= q -> forall x, root p x = root q x.
Proof.
move=> p q; move/eqpP=> [c [d [c0 d0 e]]] x.
rewrite /root; move/negPf:c0=>c0; move/negPf:d0=>d0.
rewrite -[_==_]orFb -c0 -mulf_eq0 -horner_Cmul e.
by rewrite horner_Cmul mulf_eq0 d0.
Qed.

Lemma root_gcd : forall p q x, root (gcdp p q) x = root p x && root q x.
Proof.
move=> p q x; rewrite !root_factor_theorem.
apply/idP/andP=> [dg| [dp dq]].
  by split; apply: (dvdp_trans dg); rewrite ?(dvdp_gcdl, dvdp_gcdr).
have:= (egcdpPW p q)=> [[u [v]]]; rewrite eqp_sym=> e.
by rewrite (eqp_dvdr _ e) dvdp_addl dvdp_mull.
Qed.

Lemma root0 : forall x, root 0 x.
Proof. by move=> x; rewrite /root ?hornerC. Qed.

Lemma root1n : forall x, ~~root 1 x.
Proof. by move=> x; rewrite /root ?hornerC oner_eq0. Qed.

Lemma root_biggcd : forall x (ps : seq {poly R}),
  root (\big[@gcdp _/0]_(p<-ps)p) x = all (fun p => root p x) ps.
Proof.
move=> x; elim; first by rewrite big_nil root0.
by move=> p ps ihp; rewrite big_cons /= root_gcd ihp.
Qed.

Lemma root_bigmul : forall x (ps : seq {poly R}),
  ~~root (\big[@mul _/1]_(p<-ps)p) x = all (fun p => ~~ root p x) ps.
Proof.
move=> x; elim; first by rewrite big_nil root1n.
by move=> p ps ihp; rewrite big_cons /= root_mul negb_or ihp.
Qed.

Lemma size_XMa : forall a : R, size ('X - a%:P) = 2%N.
Proof.
move=> a; rewrite size_addl size_polyX//.
by rewrite size_opp size_polyC; case: (_ != _).
Qed.

End ExtraPolynomialIdomain.

Section ExtraPolynomialFields.

Variable F : Field.type.

Variable axiom : ClosedField.axiom F.

Lemma root_size_neq1 : forall p : {poly F},
  reflect (exists x, root p x) (size p != 1%N).
Proof.
move=> p; case p0: (p == 0).
  rewrite (eqP p0) /= /root size_poly0 /=.
  by constructor; exists 0; rewrite horner0.
apply: (iffP idP); last first.
  case=> x; rewrite root_factor_theorem.
  apply: contraL; rewrite size1_dvdp1; move/eqp_dvdr->.
  rewrite -eqp1_dvd1 -size1_dvdp1 size_addl size_polyX //.
  by rewrite size_opp size_polyC; case: (x != 0).
move/negPf => sp.
case: (ltnP (size p).-1 1)=> [|s2].
  by rewrite prednK ?lt0n ?leqn1 ?size_poly_eq0 p0 // sp.
have := axiom (fun n => -p`_n*(lead_coef p)^-1) s2.
case=> x; exists x.
have : 0 < size p by apply: leq_trans s2 _; apply: leq_pred.
rewrite /root horner_coef; move/prednK<-; rewrite big_ord_recr /= H.
apply/eqP; rewrite big_distrr -big_split big1 //= => i _.
rewrite mulrA [ _ * (_ / _)]mulrCA mulfV; last by rewrite lead_coef_eq0 p0.
by rewrite mulr1 mulNr addrN.
Qed.

Lemma ex_px_neq0 : forall p : {poly F}, p != 0 -> exists x, p.[x] != 0.
Proof.
move=> p p0.
case sp1: (size p == 1%N).
  by move/size1_is_polyC: sp1=> [x [x0 ->]]; exists x; rewrite hornerC.
have: (size (1 + p) != 1%N).
  rewrite addrC size_addl ?sp1 //.
  move/negPf: p0 => p0f.
  by rewrite size_poly1 ltnNge leqn1 size_poly_eq0 p0f sp1.
move/root_size_neq1 => [x rx]; exists x.
move: rx; rewrite /root horner_add hornerC.
rewrite addrC -(inj_eq (@addIr _ (-1))) addrK sub0r.
move/eqP->; rewrite eq_sym -(inj_eq (@addrI _ 1)).
by rewrite addr0 subrr oner_eq0.
Qed.

End ExtraPolynomialFields.


(** * Basic First-Order Logic *)
(** ** Syntax *)
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation.
From Undecidability Require Import Shared.Libs.PSL.Vectors.Vectors.
Import ListAutomationNotations.

Import Coq.Vectors.Vector.
Local Notation vec := t.

Inductive peirce := class | intu.
Existing Class peirce.

(* Some preliminary definitions for substitions  *)
Definition scons {X: Type} (x : X) (xi : nat -> X) :=
  fun n => match n with
        | 0 => x
        | S n => xi n
        end.

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

Fixpoint iter {X: Type} f n (x : X) :=
  match n with
    0 => x
  | S m => f (iter f m x)
  end.

Fact iter_switch {X} f n x :
  f (@iter X f n x) = iter f n (f x).
Proof.
  induction n; cbn; now try rewrite IHn.
Qed.

(* Signatures are a record to allow for easier definitions of general transformations on signatures *)

Class funcs_signature :=
  { syms : Type; ar_syms : syms -> nat }.

Coercion syms : funcs_signature >-> Sortclass.

Class preds_signature :=
  { preds : Type; ar_preds : preds -> nat }.

Coercion preds : preds_signature >-> Sortclass.

Section fix_signature.

  Context {Σ_funcs : funcs_signature}.

  (* We use the stdlib definition of vectors to be maximally compatible  *)

  Unset Elimination Schemes.

  Inductive term  : Type :=
  | var : nat -> term
  | func : forall (f : syms), vec term (ar_syms f) -> term.
  Arguments func _ _ : clear implicits. (* Temporarily make it fully explicit *)

  Definition ForallT {X} (p : X -> Type) := fix ForallT {n} (v : t X n) :=
    match v with
    | nil _ => (unit : Type)
    | cons _ x _ v => (p x * ForallT v)%type
    end.

  Definition InT {X} (x:X) := fix InT {n} (v : t X n) :=
    match v with
    | nil _ => (False : Type)
    | cons _ y _ v => ((x=y) + InT v)%type
    end.

  Lemma term_rect' (p : term -> Type) :
    (forall x, p (var x)) -> (forall F v, (ForallT p v) -> p (@func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. fix strong_term_ind' 1. destruct t as [n|F v].
    - apply f1.
    - apply f2. induction v.
      + econstructor.
      + econstructor. now eapply strong_term_ind'. eauto.
  Qed.

  Lemma term_rect (p : term -> Type) :
    (forall x, p (var x)) -> (forall F v, (forall t, InT t v -> p t) -> p (@func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. eapply term_rect'.
    - apply f1.
    - intros. apply f2. induction v.
      + intros t H; exfalso; apply H.
      + intros t [->|H]; cbn in *; destruct X; eauto.
  Qed.

  Lemma term_ind (p : term -> Prop) :
    (forall x, p (var x)) -> (forall F v (IH : forall t, In t v -> p t), p (func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. eapply term_rect'.
    - apply f1.
    - intros. apply f2. intros t. induction 1; inversion X; subst; eauto.
  Qed.

  Set Elimination Schemes.

  Fixpoint subst_term (σ : nat -> term) (t : term) : term :=
    match t with
    | var t => σ t
    | func f v => func f (map (subst_term σ) v)
    end.

  Context {Σ_preds : preds_signature}.

  (* We use a flag to switch on and off a constant for falisity *)

  Inductive falsity_flag := falsity_off | falsity_on.
  Existing Class falsity_flag.
  Existing Instance falsity_on | 1.
  Existing Instance falsity_off | 0.

  (* Syntax is parametrised in binary operators and quantifiers.
      Most developments will fix these types in the beginning and never change them.
   *)
  Class operators := {binop : Type ; quantop : Type}.
  Context {ops : operators}.

  Inductive form : falsity_flag -> Type :=
  | falsity : form falsity_on
  | atom {b} : forall (P : preds), vec term (ar_preds P) -> form b
  | bin {b} : binop -> form b -> form b -> form b
  | quant {b} : quantop -> form b -> form b.
  Arguments form {_}.
  Arguments atom {_} _ _, _ _ _.
  Arguments bin {_} _ _ _, _ _ _ _.
  Arguments quant {_} _ _, _ _ _.

  Definition up (σ : nat -> term) := scons (var 0) (funcomp (subst_term (funcomp var S)) σ).

  Fixpoint subst_form `{falsity_flag} (σ : nat -> term) (phi : form) : form :=
    match phi with
    | falsity => falsity
    | atom P v => atom P (map (subst_term σ) v)
    | bin op phi1 phi2 => bin op (subst_form σ phi1) (subst_form σ phi2)
    | quant op phi => quant op (subst_form (up σ) phi)
    end.

End fix_signature.

(* Setting implicit arguments is crucial  *)
(* We can write term both with and without arguments, but printing is without. *)
Arguments term _, {_}.
Arguments var _ _, {_} _.
Arguments func _ _ _, {_} _ _.
Arguments subst_term {_} _ _.

(* Formulas can be written with the signatures explicit or not.
    If the operations are explicit, the signatures are too.
 *)
Arguments form  _ _ _ _, _ _ {_ _}, {_ _ _ _}, {_ _ _} _.
Arguments atom  _ _ _ _, _ _ {_ _}, {_ _ _ _}.
Arguments bin   _ _ _ _, _ _ {_ _}, {_ _ _ _}.
Arguments quant _ _ _ _, _ _ {_ _}, {_ _ _ _}.

Arguments up         _, {_}.
Arguments subst_form _ _ _ _, _ _ {_ _}, {_ _ _ _}.

(* Substitution Notation *)

Declare Scope subst_scope.
Open Scope subst_scope.

Notation "$ x" := (var x) (at level 3, format "$ '/' x") : subst_scope.
Notation "t `[ sigma ]" := (subst_term sigma t) (at level 7, left associativity, format "t '/' `[ sigma ]") : subst_scope.
Notation "phi [ sigma ]" := (subst_form sigma phi) (at level 7, left associativity, format "phi '/' [ sigma ]") : subst_scope.
Notation "s .: sigma" := (scons s sigma) (at level 70, right associativity) : subst_scope.
Notation "f >> g" := (funcomp g f) (at level 50) : subst_scope.
Notation "s '..'" := (scons s var) (at level 4, format "s ..") : subst_scope.
Notation "↑" := (S >> var) : subst_scope.

(* Full syntax *)

Module FullSyntax.

  Inductive full_logic_sym : Type :=
  | Conj : full_logic_sym
  | Disj : full_logic_sym
  | Impl : full_logic_sym.

  Inductive full_logic_quant : Type :=
  | All : full_logic_quant
  | Ex : full_logic_quant.

  Definition full_operators : operators :=
    {| binop := full_logic_sym ; quantop := full_logic_quant |}.

  #[export] Hint Immediate full_operators : typeclass_instances.

  Declare Scope full_syntax.
  Delimit Scope full_syntax with Ffull.

  #[global] Open Scope full_syntax.
  Notation "∀ Phi" := (@quant _ _ full_operators _ All Phi) (at level 50) : full_syntax.
  Notation "∃ Phi" := (@quant _ _ full_operators _ Ex Phi) (at level 50) : full_syntax.
  Notation "A ∧ B" := (@bin _ _ full_operators _ Conj A B) (at level 41) : full_syntax.
  Notation "A ∨ B" := (@bin _ _ full_operators _ Disj A B) (at level 42) : full_syntax.
  Notation "A → B" := (@bin _ _ full_operators _ Impl A B) (at level 43, right associativity) : full_syntax.
  Notation "⊥" := (falsity) : full_syntax.
  Notation "¬ A" := (A → ⊥) (at level 42) : full_syntax.
  Notation "A ↔ B" := ((A → B) ∧ (B → A)) (at level 43) : full_syntax.

  Fixpoint impl {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} {ff : falsity_flag} (A : list form) phi :=
    match A with
    | [] => phi
    | psi :: A => bin _ _ full_operators _ Impl psi (impl A phi)
    end.

  Notation "A ==> phi" := (impl A phi) (right associativity, at level 55).

  Definition exist_times {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} {ff : falsity_flag} n (phi : form) := iter (fun psi => ∃ psi) n phi.
  Definition forall_times {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} {ff : falsity_flag} n (phi : form) := iter (fun psi => ∀ psi) n phi.

End FullSyntax.

(* Fragment syntax *)

Module FragmentSyntax.

  Inductive frag_logic_binop : Type :=
  | Impl : frag_logic_binop.

  Inductive frag_logic_quant : Type :=
  | All : frag_logic_quant.

  Definition frag_operators : operators :=
    {| binop := frag_logic_binop ; quantop := frag_logic_quant |}.

  #[export] Hint Immediate frag_operators : typeclass_instances.

  Declare Scope fragment_syntax.
  Delimit Scope fragment_syntax with Ffrag.

  #[global] Open Scope fragment_syntax.
  Notation "∀ Phi" := (@quant _ _ frag_operators _ All Phi) (at level 50) : fragment_syntax.
  Notation "phi → psi" := (@bin _ _ frag_operators _ Impl phi psi) (at level 43, right associativity) : fragment_syntax.
  Notation "¬ phi" := (phi → falsity) (at level 42) : fragment_syntax.
  Notation "⊥" := (falsity) : fragment_syntax.

  Fixpoint impl {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} {ff : falsity_flag} (A : list form) phi :=
    match A with
    | [] => phi
    | psi :: A => bin _ _ frag_operators _ Impl psi (impl A phi)
    end.

  Notation "A ==> phi" := (impl A phi) (right associativity, at level 55).

  Definition forall_times {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} {ff : falsity_flag} n (phi : form) := iter (fun psi => ∀ psi) n phi.

End FragmentSyntax.


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*               Intensional Lambda Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation               *)
(* of Lambda Calculus from Project Coq                                *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                   LamSF_Closed.v                                   *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import Max.
Require Import LamSF_Terms.
Require Import LamSF_Tactics.
Require Import LamSF_Substitution_term.
Require Import SF_reduction.
Require Import LamSF_reduction.
Require Import LamSF_Normal.
Require Import Omega.

(* closed terms *)

Fixpoint maxvar (M: lamSF) :=
match M with
| Ref i => S i
| Op o  => 0
| App M1 M2 => max (maxvar M1) (maxvar M2)
| Abs N => pred (maxvar N)
end.

Definition closed M := maxvar M = 0.

Lemma maxvar_lift_rec : forall M n k, maxvar M + k >= maxvar (lift_rec M n k) .
Proof.
induction M; split_all.
unfold relocate. elim(test n0 n); split_all; omega.
omega.
assert(pred (maxvar M) + k >= pred (maxvar M + k)) by omega.
assert(maxvar M + k >= maxvar (lift_rec M (S n) k)) by eapply2 IHM.
omega.
rewrite max_plus.
eapply2 max_monotonic.
Qed.

Lemma subst_decreases_maxvar :
forall M N k,  max (pred (maxvar M)) (maxvar N + k) >= maxvar(subst_rec M N k).
Proof.
induction M; split_all.
unfold insert_Ref.
elim(compare k n); split_all.
elim a; split_all.
assert(max n (maxvar N + k) >= n) by eapply2 max_is_max.
omega.
unfold lift.
elim(maxvar_lift_rec N 0 k); split_all.
eapply2 max_is_max.
assert(max n (S m) >= max n m) by (eapply2 max_monotonic; omega).
omega.
assert(max n (maxvar N + k) >= maxvar N + k) by eapply2 max_is_max.
omega.
omega.

(* 2 subgoals *)
assert(max (pred (pred (maxvar M))) (maxvar N + k) >= pred(max (pred (maxvar M)) (maxvar N + (S k)))).
rewrite max_pred.
eapply2 max_monotonic.
omega.
assert(max (pred (maxvar M)) (maxvar N + S k) >= maxvar (subst_rec M N (S k)))
by eapply2 IHM.
assert(pred (max (pred (maxvar M)) (maxvar N + S k)) >= pred (maxvar (subst_rec M N (S k)))) by omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k)) >= max (maxvar (subst_rec M1 N k)) (maxvar (subst_rec M2 N k))).
eapply2 max_monotonic.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N + k)  >=
max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k))).
2: omega.
eapply2 max_max2; eapply2 max_monotonic; eapply2 max_is_max.
Qed.

Definition decreases  (rank: lamSF -> nat) (red:termred):=
forall M N, red M N -> rank M >= rank N.

Lemma decreases_multi_step:
forall rank red, decreases rank red -> decreases rank (multi_step red).
Proof.
red. intros rank red D M N R;  induction R; split_all.
assert(rank M >= rank N) by eapply2 D.
assert(rank N >= rank P) by eapply2 IHR.
omega.
Qed.

Lemma lift_rec_closed: forall M n, n>= maxvar M  -> forall k, lift_rec M n k = M.
Proof. induction M; split_all; subst; unfold lift; unfold lift_rec; fold lift_rec.
unfold relocate. elim(test n0 n); split_all; try noway.
rewrite IHM.  auto. omega.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; congruence.
Qed.

Lemma lift_closed: forall M, maxvar M =0 -> forall k, lift k M = M.
Proof.  split_all; eapply2 lift_rec_closed. omega. Qed.

Lemma subst_rec_closed : forall M n, n>= maxvar M -> forall N, subst_rec M N n = M.
Proof.
induction M; split_all; subst.
unfold insert_Ref.
elim(compare n0 n); split_all; try noway.  elim a; split_all; try noway.
rewrite IHM; try omega; split_all.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Lemma maxvar_subst_rec: forall M k, maxvar M <= k -> forall N, subst_rec M N k = M.
Proof.
induction M; unfold subst_rec; fold subst_rec; split_all; subst.
unfold insert_Ref. elim(compare k n); split_all; try noway.
elim a; split_all; try noway.
rewrite IHM; split_all; omega.

assert(k>= maxvar M1 /\ k>= maxvar M2) by eapply2 max_max; split_all.
rewrite IHM1; split_all.
rewrite IHM2; split_all.
Qed.

Lemma maxvar_star: forall M, maxvar (star M) = pred (maxvar M).
Proof.
induction M; split_all.
case n; split_all.
rewrite max_pred. auto.
Qed.

Lemma left_component_preserves_maxvar : forall M, compound M ->
maxvar(left_component M) <= maxvar M.
Proof.
split_all.
inversion H; split_all; try omega.
eapply2 max_is_max.
Qed.

Lemma right_component_preserves_maxvar : forall M, compound M ->
maxvar(right_component M) <= maxvar M.
Proof.
split_all.
inversion H; split_all; try omega.
eapply2 max_is_max.
rewrite maxvar_star.
auto.
rewrite maxvar_star.
auto.
Qed.

Ltac max_l :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= m) by eapply2 max_is_max;
cut(m >= p); split_all; try omega
end.
Ltac max_r :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= n) by eapply2 max_is_max;
cut(n >= p); split_all; try omega
end.

Lemma decreases_maxvar_lamF_red1: decreases maxvar lamSF_red1.
(*
forall M N, lamF_red1 M N -> maxvar N <= maxvar M.
*)
Proof.
cut(forall M N, lamSF_red1 M N -> maxvar N <= maxvar M).
split_all; red.

intros M N R; induction R; split_all; eauto; try (repeat (eapply2 max_monotonic); fail); try omega; repeat (eapply2 max_max2); try (max_r; fail); try (repeat max_l; fail).
(* 5 *)
unfold subst.
assert(max (pred (maxvar M)) (maxvar N + 0) >= maxvar(subst_rec M N 0)).
eapply2 subst_decreases_maxvar.
replace (maxvar N + 0) with (maxvar N) in H by omega.
omega.
(* 4 *)
max_l. max_r.
(* 3 *)
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l. omega.
(* 2 *)
max_l. max_l. eapply2 left_component_preserves_maxvar.
max_l. max_l. eapply2 right_component_preserves_maxvar.
Qed.

Lemma decreases_maxvar_lamF_red : decreases maxvar lamSF_red.
Proof. eapply2 decreases_multi_step. eapply2 decreases_maxvar_lamF_red1. Qed.

Lemma status_lt_maxvar: forall M, status M <= maxvar M.
Proof.
cut(forall p M, p>= rank M -> status M <= maxvar M).
split_all; eapply2 H.
induction p; intros.
assert(rank M >0) by eapply2 rank_positive. noway.
induction M; intros; try max_out; try (eapply2 IHM1); try (split_all; omega).
simpl in *; split_all.
assert(status M <= maxvar M). eapply2 IHp.
omega. omega.
(* 1 *)
generalize IHM1 H; clear IHM1 H; case M1; intros; try (split_all; omega).
split_all.
case (maxvar M2); split_all.
assert(max n n0 >= n) by max_l. omega.
(* 1 *)
generalize IHM1 H; clear IHM1 H; case l; intros; try (split_all; omega).
split_all.
case (maxvar l0); split_all.
case (maxvar M2); split_all.
assert(max n n0 >= n) by max_l. omega.
case (maxvar M2); split_all.
assert(max n n0 >= n) by max_l. omega.
assert(max n n0 >= n) by max_l.
assert(max n n1 >= n) by max_l.
assert(max (max n n0) n1 >= max n n1) by eapply2 max_monotonic. omega.
(* 1 *)
generalize IHM1 H; clear IHM1 H; case l1; intros; try (split_all; omega).
split_all.
case (maxvar l2); split_all.
case (maxvar l0); split_all.
case (maxvar M2); split_all.
assert(max n n0 >= n) by max_l. omega.
case (maxvar M2); split_all.
assert(max n n0 >= n) by max_l. omega.
assert(max n n0 >= n) by max_l.
assert(max n n1 >= n) by max_l.
assert(max (max n n0) n1 >= max n n1) by eapply2 max_monotonic. omega.
case (maxvar l0); split_all.
case (maxvar M2); split_all.
assert(max n n0 >= n) by max_l. omega.
assert(max n n0 >= n) by max_l.
assert(max n n1 >= n) by max_l.
assert(max (max n n0) n1 >= max n n1) by eapply2 max_monotonic. omega.
case (maxvar M2); split_all.
assert(max n n0 >= n) by max_l.
assert(max n n1 >= n) by max_l.
assert(max (max n n0) n1 >= max n n1) by eapply2 max_monotonic. omega.
assert(max n n0 >= n) by max_l.
assert(max n n1 >= n) by max_l.
assert(max n n2 >= n) by max_l.
assert(max (max n n0) n1 >= max n n1) by eapply2 max_monotonic.
assert(max (max n n0) n1 >= n) by omega.
assert(max (max (max n n0) n1) n2 >= max n n2) by eapply2 max_monotonic.
assert(max (max (max n n0) n1) n2 >= n) by omega.
omega.
gen2_case IHM1 H o.
omega.
assert(status l2 <= maxvar l2). eapply2 IHp. simpl in *; omega.
assert(maxvar l2 <= max (max (maxvar l2) (maxvar l0)) (maxvar M2)).
assert(max (maxvar l2) (maxvar l0) >= maxvar l2) by max_l.
assert(max (max (maxvar l2) (maxvar l0)) (maxvar M2) >= max (maxvar l2) (maxvar l0)) by max_l.
omega.
omega.
(* 1 *)
assert(status(App (App (App (App l3 l4) l2) l0) M2) = status  (App (App (App l3 l4) l2) l0)). split_all.
rewrite H0.
assert(status (App (App (App l3 l4) l2) l0) <=
         maxvar (App (App (App l3 l4) l2) l0)). eapply2 IHM1.
simpl in *; omega.
assert(maxvar  (App (App (App l3 l4) l2) l0) <= maxvar (App (App (App (App l3 l4) l2) l0) M2)). split_all.  eapply2 max_is_max. omega.
Qed.

Definition program M := normal M /\ maxvar M = 0.

Lemma components_monotonic:
forall M N, program M -> program N ->
left_component M = left_component N ->
right_component M = right_component N -> M = N.
Proof.
induction M; unfold program; split_all.
(* 3 *)
gen4_case H1 H2 H3 H4 N; try discriminate.
subst. gen_case H2 l. gen_case H2 n. discriminate.
subst. inversion H3. inversion H7. inversion H7.
(* 2 *)
gen4_case H1 H2 H3 H4 N; try discriminate.
(* 4 *)
gen_case H2 M.
gen_case H2 n. discriminate.
assert(M=l). eapply2 star_monotonic. congruence.
(* 2 *)
subst.
inversion H3. simpl in *. noway.
inv1 compound.
(* 1 *)
inversion H0. simpl in *.
assert(status (App M1 M2) <= maxvar (App M1 M2)) by eapply2 status_lt_maxvar.
simpl in *. noway.
subst.
gen_case H9 N; inversion H9.
Qed.

Definition factorable M := (exists o, M = Op o) \/ compound M.

Theorem programs_are_factorable : forall M, program M  -> factorable M.
Proof.
unfold program, factorable; split_all. eapply2 not_active_factorable.
assert(status M <= maxvar M) by eapply2 status_lt_maxvar.
omega.
Qed.


(** * Tutorial for QuickChick *)

(** QuickChick is a clone of Haskell's QuickCheck, slightly on
    steroids.  This tutorial explores basic aspects of random
    property-based testing and details the majority of features of
    QuickChick. *)

(* begin hide *)
From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import List ZArith.
Import ListNotations.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

(* end hide *)

(** ** Introduction *)

(** It is not uncommon during a verification effort to spend many
    hours attempting to prove a slightly false theorem, only to result
    in frustration when the mistake is realized and one needs to start
    over. Other theorem provers have testing tools to quickly raise
    one's confidence before embarking on the body of the proof;
    Isabelle has its own QuickCheck clone, as well as Nitpick,
    Sledgehammer and a variety of other tools; ACL2 has gone a step
    further using random testing to facilitate its
    automation. QuickChick is meant to fill this void for Coq.

    Consider the following short function [remove] that takes a
    natural number [x] and a list of nats [l] and proceeds to remove
    [x] from the list. While one might be tempted to pose the question
    "Is there a bug in this definition?", such a question has little
    meaning without an explicit specification. Here, [removeP]
    requires that after removing [x] from [l], the resulting list does
    not contain any occurences of [x]. *)

Fixpoint remove (x : nat) (l : list nat) : list nat :=
  match l with
    | []   => []
    | h::t => if beq_nat h x then t else h :: remove x t
  end.

Definition removeP (x : nat) (l : list nat) :=
  (~~ (existsb (fun y => beq_nat y x) (remove x l))).

(** For this simple example, it is not hard to "spot" the bug by
    inspection. We will use QuickChick to find out what is wrong.

    QuickChick provides a toplevel command [QuickChick] that receives
    as input an executable property and attempts to falsify it. *)

QuickChick removeP.

(** Internally, the code is extracted to OCaml, compiled and ran to
obtain the output:
<<
    0

    [ 0, 0 ]

    Failed! After 17 tests and 12 shrinks
>>
    The output signifies that if we use an input where [x] is [0] and
    [l] is the two element list containing two zeros, then our
    property fails. Indeed, we can now identify that the [then] branch
    of [remove] fails to make a recursive call, which means that only
    one occurence of each element will be deleted. The last line of
    the output states that it took 17 tests to identify some fault
    inducing input and 12 shrinks to reduce it to a minimal
    counterexample.

    Before we begin to explain exactly how QuickChick magically comes
    up with this result, it is important to point out the first (and
    arguably most important) limitation of this tool: it requires an
    *executable* specification. QuickChick needs to be able to "run" a
    property and decide whether it is true or not; a definition like
    [remove_spec] can't be QuickChecked! *)

Definition remove_spec :=
  forall x l, ~ In x (remove x l).

(** QuickChick requires either a functional spec (like [removeP]) or a
    decidability procedure for an inductive spec. *)

(** ** Property Based Random Testing Ingredients

    There are four basic ingredients in property based random testing:

    - An executable property, as discussed above
    - A printer, to report counterexamples found
    - A generator, to produce random inputs
    - A shrinker, to reduce counterexamples.

    We will now review the latter three in order. *)

(** *** Printing

    For printing, QuickChick uses a [Show] typeclass, like Haskell. *)

Print Show.
(**  ==> Record Show (A : Type) : Type
            := Build_Show { show : A -> String.string }   *)

(** The [Show] typeclass contains a single function [show] from some
    type [A] to Coq's [string]. QuickChick provides default instances
    for [string]s (the identity function), [nat], [bool], [Z],
    etc. (via extraction to appropriate OCaml functions for
    efficiency), as well as some common compound datatypes: lists,
    pairs and options.

    Writing your own show instance is easy! Let's define a simple
    [Color] datatype. *)

Inductive Color := Red | Green | Blue | Yellow.

(** After ensuring we have opened the [string] scope, we can declare
    an instance of [Show Color] by encoding [show] as a simple pattern
    matching on colors. *)

Require Import String. Open Scope string.
Instance show_color : Show Color :=
  {| show c :=
       match c with
         | Red    => "Red"
         | Green  => "Green"
         | Blue   => "Blue"
         | Yellow => "Yellow"
       end
  |}.

Eval compute in (show Green).
(** ==> "Green" : string *)

(** While writing show instances is relatively straightforward, it can
    get tedious.  The QuickChick provides a lot of automation, which
    will be discussed at the end of this Tutorial. *)

(** *** Generators *)

(** **** The [G] Monad *)

(** The heart of property based random testing is the random
    generation of inputs.  In QuickChick, a generator for elements of
    some type [A] is a monadic object with type [G A]. The monad [G]
    serves as an abstraction over random seed plumbing. Consider
    writing a program that given a random seed generates many
    integers: one needs to use the given seed to produce an integer
    while at the same time obtain a new, altered seed to use for
    future draws. This [State]-monad like behavior is hidden behind
    [G].

    Standard monadic functions have the [Gen] suffix. *)

Check bindGen.
(** ==> bindGen : G ?A -> (?A -> G ?B) -> G ?B *)

Check returnGen.
(** ==> returnGen : ?A -> G ?A *)

(** For those familiar with Haskell's monadic interface, QuickChick
    also provides variants of [liftM] (as [liftGen]) with arities 1 to
    5, [sequence] (as [sequenceGen]) and [foldM] (as [foldGen]). *)

(** **** Primitive generators *)

(** Primitive generators for booleans, natural numbers and integers
    are provided via extraction to OCaml. They can be accessed via the
    [choose] combinator.
 *)

Check choose.
(** ==> choose : Z * Z -> G Z *)

(** While here [choose] is monomorphised to [Z], it actually takes an
    interval of any type [A] that satisfies a [ChoosableFromInterval]
    typeclass (with default standard numeric instances) and produces
    an object of type [A] within that interval.

    We can see that in action using [Sample]. This is another toplevel
    command by QuickChick that runs a generator a number of times and
    prints whatever was generated in the form of a list. *)

Sample (choose(0, 10)).
(** ==> [ 1, 2, 1, 9, 8, 1, 3, 6, 2, 1, 8, 0, 1, 1, 3, 5, 4, 10, 4, 6 ] *)

(** **** Lists *)

(** Due to being the most commonly used compound datatype, lists have
    special combinators in Haskell's QuickCheck. The same is true in
    QuickChick; there are two combinators, [listOf] and [vectorOf]. *)

Check listOf.
(** ==> listOf : G ?A -> G (list ?A) *)

(** [listOf] takes as input a generator for elements of type [A] and returns a
    generator for lists of the same type. *)

Sample (listOf (choose (0,4))).
(** ==> [ [ 0, 3, 2, 0 ],
         [ 1, 3, 4, 1, 0, 3, 0, 2, 2, 3, 2, 2, 2, 0, 4, 2, 3, 0, 1 ],
         [ 3, 4, 3, 1, 2, 4, 4, 1, 0, 3, 4, 3, 2, 2, 4, 4, 1 ],
         [ 0 ],
         [ 4, 2, 3 ],
         [ 3, 3, 4, 0, 1, 4, 3, 2, 4, 1 ],
         [ 0, 4 ],
         [  ],
         [ 1, 0, 1, 3, 1 ],
         [ 0, 0 ],
         [ 1, 4 ],
         [ 4, 3, 2, 0, 2, 2, 4, 0 ],
         [ 1, 1, 0, 0, 1, 4 ],
         [ 2, 0, 2, 1, 3, 3 ],
         [ 4, 3, 3, 0, 1 ],
         [ 3, 3, 3 ],
         [ 3, 2, 4 ],
         [ 1, 2 ],
         [  ],
         [  ]
       ]
*)

(** The second combinator, [vectorOf], receives an additional numeric
    argument [n], the length of the list to be generated. *)

Check vectorOf.
(** ==> vectorOf : nat -> G ?A -> G (list ?A) *)

(** This raises a question: how does [listOf] decide how big of a list
    to generate? The answer is hidden inside the [G] monad.

    In addition to handling random seed plumbing, the [G] monad also
    provides a [Reader]-like environment with size information: a
    natural number [n] that nominally serves as the upper bound on the
    depth of the generated objects.  QuickChick progressively tries
    larger and larger values for [n], in order to explore larger and
    deeper part of the search space. Note that each generator can
    choose to interpret this input size however it wants and there is
    no guarantee that all generators comply to this standard - it is
    more of a "good practice" when writing one to respect this
    bound. *)

(** **** Custom Datatypes *)

(** Naturally, a lot of the time one needs to write generators involving
    user-defined datatypes. Let's revisit our color datatype; to generate a
    color, we only need to pick one of its four constructors, [Red], [Green],
    [Blue] and [Yellow]. This is done using [elements]. *)

Check elements.
(** ==> elements : ?A -> list ?A -> G ?A *)

(** This is the first place where the totality checker of Coq raises a
    design question. While Haskell's QuickCheck can simply fail
    raising an [error] whenever the input list is empty, Coq does not
    allow that behavior. Instead of increasing the burden to the user
    by requiring a proof that the list is not empty or by making the
    return type an option, QuickChick requires an additional element
    of type [A] as input to serve as a "default" object.  If the list
    is not empty, [elements] returns a generator that picks an element
    of that list; otherwise the generator always returns the default
    object.

    Moreover, QuickChick provides convenient notation to hide this
    default if it is apparent from the structure. *)

(*
Notation            Scope
" 'elems' [ x ] " := elements x (cons x nil)
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ] " := elements x (cons x (cons y nil))
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ; .. ; z ] " := elements x
                                    (cons x (cons y .. (cons z nil) ..))
                      : qc_scope
                      (default interpretation)
" 'elems' ( x ;; l ) " := elements x (cons x l)
                      : qc_scope
                      (default interpretation)
*)

(** Armed with [elems], we can write the following simple [Color]
    generator. *)

Definition genColor : G Color :=
  elems [ Red ; Green ; Blue ; Yellow ].

Sample genColor.
(** ==> [ Blue, Red, Yellow, Red, Blue, Yellow, Yellow, Blue, Green, Red, Green,
         Blue, Blue, Red, Yellow, Blue, Red, Blue, Blue, Red ] *)

(** For more complicated ADTs, QuickChick provides more
    combinators. We will showcase them using everyone's favorite
    datatype: Trees!

    Our trees are standard binary trees; either [Leaf]s or [Node]s
    containing some payload of type [A] and two subtrees. *)

Inductive Tree A :=
| Leaf : Tree A
| Node : A -> Tree A -> Tree A -> Tree A.

Arguments Leaf {A}.
Arguments Node {A} _ _ _.

(** Before getting to generators for trees, we give a simple [Show]
    instance.  The rather inconvenient need for a local [let fix]
    declaration stems from the fact that Coq's typeclasses (unlike
    Haskell's) are not automatically recursive. *)

Instance showTree {A} `{_ : Show A} : Show (Tree A) :=
  {| show :=
       let fix aux t :=
         match t with
           | Leaf => "Leaf"
           | Node x l r => "Node (" ++ show x ++ ") (" ++ aux l ++ ") (" ++ aux r ++ ")"
         end
       in aux
  |}.

(** The first combinator that actually combines different generators
    is [oneof]. *)

Check oneof.
(** ==> oneof : G ?A -> list (G ?A) -> G ?A *)

(** [oneof] takes a default generator and a list of generators, and
    picks one of the generators from the list uniformly at random, as
    long as the list is not empty.  Just like before, QuickChick
    introduces the notation [oneOf] to hide this default element.

    At this point, Coq's termination checker saves us from shooting
    ourselves in the foot. The "obvious" first generator that one
    might write is the following [genTree]: either generate a [Leaf]
    or a [Node] whose subtrees are generated recursively and whose
    payload is produced by a generator for elements of type [A].*)

(*
Fixpoint genTree {A} (g : G A) : G (Tree A) :=
  oneOf [ returnGen Leaf ;
          liftGen3 Node  g (genTree g) (genTree g) ].*)

(** Of course, this fixpoint will not pass Coq's termination
    check. Attempting to justify this fixpoint to oneself, one might
    say that at some point the random generation will pick a [Leaf] so
    it will eventually terminate. Sadly, in this case the expected
    size of the generated Tree is infinite...

    The solution is the standard "fuel" solution Coq users are so
    familiar with: we add an additional natural number [sz] as a
    parameter; when that parameter is [O] we only generate
    non-recursive branches, while we decrease this size in each
    recursive call. Thus, [sz] serves as a bound on the depth of the
    tree.

 *)

Fixpoint genTreeSized {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => oneOf [ returnGen Leaf ;
                       liftGen3  Node g (genTreeSized sz' g) (genTreeSized sz' g)
                     ]
  end.

Sample (genTreeSized 3 (choose(0,3))).
(** ==> [ Leaf,
         Leaf,
         Node (3) (Node (0) (Leaf) (Leaf)) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Leaf,
         Leaf,
         Node (1) (Leaf) (Node (1) (Leaf) (Node (0) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Leaf) (Leaf),
         Node (1) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Node (0) (Leaf) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (2) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Node (0) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Leaf,
         Leaf,
         Leaf ]
*)

(** While this generator succesfully generated trees, just by
    observing [Sample] above there is a problem: [genTreeSized]
    produces way too many [Leaf]s! That is to be expected, 50% of the
    time we generate a [Leaf]. The solution is to skew the
    distribution towards [Node]s, using the most expressive QuickChick
    combinator, [frequency] and its associated default-lifting
    notation [freq].
 *)
Check frequency.
(** ==> frequency : G ?A -> seq (nat * G ?A) -> G ?A *)

(** [freq] takes a list of generators, each one tagged with a natural
    number that serves as the weight of that generator. In the
    following example, a [Leaf] will be generated 1 / (sz + 1) of the
    time, while a [Node] the remaining sz / (sz + 1) of the time.*)

Fixpoint genTreeSized' {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => freq [ (1,  returnGen Leaf) ;
                      (sz, liftGen3  Node g (genTreeSized' sz' g) (genTreeSized' sz' g))
                    ]
  end.

Sample (genTreeSized' 3 (choose(0,3))).
(** ==> [ Node (3) (Node (1) (Node (3) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Node (2) (Node (1) (Leaf) (Leaf)) (Leaf),
         Node (0) (Leaf) (Node (0) (Node (2) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (1) (Node (2) (Leaf) (Node (0) (Leaf) (Leaf))) (Leaf),
         Node (0) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (2) (Leaf) (Leaf)),
         Node (1) (Node (3) (Node (2) (Leaf) (Leaf)) (Node (3) (Leaf) (Leaf))) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (0) (Node (0) (Leaf) (Leaf)) (Node (1) (Leaf) (Leaf))) (Node (2) (Node (3) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (2) (Node (2) (Leaf) (Leaf)) (Node (1) (Node (2) (Leaf) (Leaf)) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf)) (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)),
         Leaf,
         Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Leaf,
         Node (1) (Leaf) (Leaf),
         Leaf,
         Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Leaf ]
 *)

(** To showcase this generator, we will use the notion of mirroring a
    tree: swapping its left and right subtrees recursively. *)

Fixpoint mirror {A : Type} (t : Tree A) : Tree A :=
  match t with
    | Leaf => Leaf
    | Node x l r => Node x (mirror r) (mirror l)
  end.

(** We also need a simple structural equality on trees *)
Fixpoint eq_tree (t1 t2 : Tree nat) : bool :=
  match t1, t2 with
    | Leaf, Leaf => true
    | Node x1 l1 r1, Node x2 l2 r2 =>
      beq_nat x1 x2 && eq_tree l1 l2 && eq_tree r1 r2
    | _, _ => false
  end.

(** One expects that [mirror] should be unipotent; mirroring a tree
    twice yields the original tree.  *)

Definition mirrorP (t : Tree nat) := eq_tree (mirror (mirror t)) t.

(** To test this assumption, we can use the [forAll] property
    combinator that receives a generator [g] for elements of type [A]
    and an executable property with argument [A] and tests the
    property on random inputs of [g]. *)

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) mirrorP).

(** QuickChick quickly responds that this property passed 10000 tests,
    so we gain some confidence in its truth. But what would happend if
    we had the *wrong* property? *)

Definition faultyMirrorP (t : Tree nat) := eq_tree (mirror t) t.

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) faultyMirrorP).
(** ==> Node (3) (Node (0) (Leaf) (Node (0) (Node (1) (Leaf) (Leaf)) (Leaf)))
(Node (5) (Node (0) (Node (1) (Leaf) (Node (4) (Leaf) (Leaf))) (Node (4) (Leaf)
(Node (0) (Leaf) (Leaf)))) (Node (5) (Node (4) (Node (0) (Leaf) (Leaf)) (Leaf))
(Node (3) (Leaf) (Leaf))))

*** Failed! After 1 tests and 0 shrinks
*)

(** The bug is found immediately and reported. However, is this counterexample
    really helpful? What is the important part of it? The reported bug is too
    big and noisy to identify the root cause of the problem. That is where
    shrinking comes in. *)

(** **** Shrinking *)

(** Shrinking, also known as delta debugging, is a greedy process by
    which we can find a smaller counterexample given a relatively
    large one. Given a shrinking function [s] of type [A -> list A]
    and a counterexample [x] of type [A] that is known to falsify some
    property [p], QuickChick (lazily) tries [p] on all members of [s
    x] until it finds another counterexample; then it repeats this
    process.

    This greedy algorithm can only work if all elements of [s x] are
    strictly "smaller" that [x] for all [x]. Most of the time, a
    shrinking function for some type only returns elements that are
    "one step" smaller. For example, consider the default shrinking
    function for lists provided by QuickChick. *)

Print shrinkList.
(** ==> shrinkList =
     fix shrinkList (A : Type) (shr : A -> seq A) (l : seq A) {struct l} :
       seq (seq A) :=
       match l with
       | [::] => [::]
       | x :: xs =>
           ((xs :: List.map (fun xs' : seq A => x :: xs') (shrinkList A shr xs))%SEQ ++
            List.map (fun x' : A => (x' :: xs)%SEQ) (shr x))%list
       end
          : forall A : Type, (A -> seq A) -> seq A -> seq (seq A)
*)

(** An empty list can not be shrunk - there is no smaller list.  A
    cons cell can be shrunk in three ways: by returning the tail of
    the list, by shrinking the tail of the list and consing the head,
    or by shrinking the head and consing its tail. By induction, this
    process can generate all smaller lists.

    Writing a shrinking instance for trees is equally straightforward:
    we don't shrink [Leaf]s while for [Node]s we can return the left
    or right subtrees, shrink the payload or one of the subtrees.*)

Open Scope list.
Fixpoint shrinkTree {A} (s : A -> list A) (t : Tree A) : seq (Tree A) :=
  match t with
    | Leaf => []
    | Node x l r => [l] ++ [r] ++
                    map (fun x' => Node x' l r) (s x) ++
                    map (fun l' => Node x l' r) (shrinkTree s l) ++
                    map (fun r' => Node x l r') (shrinkTree s r)
  end.

(** Armed with [shrinkTree], we use the [forAllShrink] property
    combinator that takes an additional argument, a shrinker *)

QuickChick (forAllShrink (genTreeSized' 5 (choose (0,5))) (shrinkTree shrink) faultyMirrorP).

(** ==> Node (0) (Leaf) (Node (0) (Leaf) (Leaf))

*** Failed! After 1 tests and 8 shrinks *)

(** We now got a much simpler counterexample (in fact, this is one of
    the two minimal ones) and can tell that the real problem occurs
    when the subtrees of a [Node] are different. *)

(** **** Putting it all Together *)

(** QuickChick, just like QuickCheck, provides an [Arbitrary]
    typeclass parameterized over some type [A] with two objects:
    [arbitrary] and [shrink].

    The [arbitrary] object is a generator for elements of type [A]. If
    we were to encode an [Arbitrary] instance for trees we would like
    to use [genTreeSized']; however that generator takes an additional
    size argument.  The [G] monad will provide that argument through
    the combinator [sized].*)

Check sized.
(** ==> sized : (nat -> G ?A) -> G ?A *)

(** [sized] receives a function that given a number produces a
    generator, just like [genTreeSized'], and returns a generator that
    uses the size information inside the [G] monad.

    The [shrink] function is simply a shrinker like [shrinkTree]. *)

Instance genTree {A} `{Gen A} : GenSized (Tree A) :=
  {| arbitrarySized n := genTreeSized n arbitrary |}.

Instance shrTree {A} `{Shrink A} : Shrink (Tree A) :=
  {| shrink x := shrinkTree shrink x |}.

(** With this [Arbitrary] instance we can once again use the toplevel
    [QuickChick] command with just the property.  *)

QuickChick faultyMirrorP.

(** [QuickChick] internally calls the function [quickCheck] with type
    [forall prop. Checkable prop => prop -> Result]. But what _is_
    [Checkable]? It is easy to see how a boolean is [Checkable]; we
    can always tell if it is true or not and then return a [Result],
    [Success]/[Failure] as appropriate.

    To see how executable properties are [Checkable], consider a
    single argument function [p : A -> Bool] that returns a
    boolean. If we know that [A] has [Show] and [Arbitrary] instances,
    we can just call [forAllShrink] with [arbitrary] and
    [shrink]. Going a step further, the result type doesn't really
    need to be [Bool], it can be a [Checkable]! Thus, we can provide a
    [Checkable] instance for arbitrary functions.*)

Print testFun.

(** **** Collecting Statistics *)

(** Earlier in this tutorial we claimed that [genTreeSized] produced
    "too many" [Leaf]s. But how can we justify that? Just looking at
    the result of [Sample] gives us an idea that something is going
    wrong but just observing a handful of samples cannot realistically
    provide statistical guarantees. That is where [collect], another
    property combinator, comes in. In Haskell notation, [collect]
    would have the type [collect : Show A, Checkable prop => A -> prop
    -> prop]; it takes some value of type [A] that can be shown and a
    property, and returns the property itself. Whenever the resulting
    property is exercised, the [A] object is captured and statistics
    are collected.

    For example, consider a [size] function on [Tree]s.
 *)

Fixpoint size {A} (t : Tree A) : nat :=
  match t with
    | Leaf => O
    | Node _ l r => 1 + size l + size r
  end.

(** If we were to write a dummy property to check our generators and
    measure the size of generated trees, we could use [treeProp]
    below. *)

Definition treeProp (g : nat -> G nat -> G (Tree nat)) n :=
  forAll (g n (choose (0,n))) (fun t =>
  collect (size t) true).

QuickChick (treeProp genTreeSized  5).

(** ==>
4947 : 0
1258 : 1
673 : 2
464 : 6
427 : 5
393 : 3
361 : 7
302 : 4
296 : 8
220 : 9
181 : 10
127 : 11
104 : 12
83 : 13
64 : 14
32 : 15
25 : 16
16 : 17
13 : 18
6 : 19
5 : 20
2 : 21
1 : 23
+++ OK, passed 10000 tests

We see that 62.5% of the tests are either [Leaf]s or empty [Nodes], while too
few tests have larger sizes. Compare that with [genTreeSized'] below.  *)

QuickChick (treeProp genTreeSized' 5).
(** ==>
1624 : 0
571 : 10
564 : 12
562 : 11
559 : 9
545 : 8
539 : 14
534 : 13
487 : 7
487 : 15
437 : 16
413 : 6
390 : 17
337 : 5
334 : 1
332 : 18
286 : 19
185 : 4
179 : 20
179 : 2
138 : 21
132 : 3
87 : 22
62 : 23
19 : 24
10 : 25
6 : 26
2 : 27
+++ OK, passed 10000 tests

A lot fewer terms have small sizes, allowing us to explore larger terms*)

(** ** Avoiding Work  :) *)

(** While a lot of time putting a bit of time and effort in a
    generator and a shrinker, the examples shown here are fairly
    straightforward. After writing a couple of [Show] and [Arbitrary]
    instances, it can get tedious and boring. That is precisely why
    [QuickChick] provides some automation in deriving such instances
    for _plain_ datatypes automatically. *)

Derive Arbitrary for Tree.
(* GenSizedTree is defined *)
(* ShrinkTree is defined *)
Print GenSizedTree.
Print ShrinkTree.

Derive Show for Tree.
(* ShowTree is defined *)
Print ShowTree.


(*
Storage module provides the means to model a Solidity storage using the functional mapping.
SolifityFun module is implemneted the same way as a storage however it operates with
lambda functions that officiate the role of a solidity function's command.
*)

Module Storage.

Definition storage := string * string -> SolidityVar.var.
Definition empty (def : SolidityVar.var) : storage := (fun _ => def).
Definition update (s : storage) (a : string * string) (v : SolidityVar.var) :=
  (fun a' : string * string => if a =? a' then v else s a').

Definition Vdefault := SolidityVar.build_var SolidityVar.VTint 0.

Lemma apply_empty : forall (x : string * string) (v : SolidityVar.var),
  (empty v) x = v.
Proof.
  intros.
  trivial.
Qed.

End Storage.

Module SolidityFun.

Definition command := Storage.storage -> Storage.storage.

Definition functions := string -> list command.
Definition empty : functions := (fun _ => nil).
Definition new (fs : functions) (n : string) (cmds : list command) :=
  fun n' => if eqb n n' then cmds else fs n'.

End SolidityFun.


Require Import VST.floyd.proofauto.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.MathUAdjMatGraph.
Require Export CertiGraph.graph.SpaceAdjMatGraph3.
Require Import CertiGraph.lib.List_ext.

Local Open Scope logic.

Section Spatial_UAdjMat_Model_3.
  (* Model 3 is for a stack-allocated graph,
     where the graph is declared on the stack
     as a two-dimension array: graph[size][size].
   *)

Context {size : Z}.
Context {inf : Z}.

Definition graph_to_symm_mat g :=
  @graph_to_mat size g eformat.

Lemma graph_to_mat_eq:
  forall (g: AdjMatLG) i j, 0 <= i < size -> 0 <= j < size ->
    (Znth i (Znth j (graph_to_symm_mat g))) = elabel g (eformat (i,j)).
Proof.
  intros.
  symmetry. rewrite eformat_symm.
  apply elabel_Znth_graph_to_mat; lia.
Qed.

Lemma graph_to_mat_symmetric:
  forall (g: AdjMatLG) i j,
    0 <= i < size -> 0 <= j < size ->
    (Znth i (Znth j (graph_to_symm_mat g))) =
    (Znth j (Znth i (graph_to_symm_mat g))).
Proof.
  intros. repeat rewrite graph_to_mat_eq; trivial.
  f_equal. apply eformat_symm.
Qed.

Lemma graph_to_mat_inf:
  forall (g: @AdjMatGG size inf) u v,
    0 <= u < v ->
    v < size ->
    ~ evalid g (u,v) ->
    Znth v (Znth u (graph_to_symm_mat g)) =
    inf.
Proof.
  intros. unfold graph_to_symm_mat.
  rewrite <- elabel_Znth_graph_to_mat; try lia.
  rewrite eformat1.
  apply (MathAdjMatGraph.invalid_edge_weight); auto.
  simpl; lia.
Qed.

Context {size_rep': 0 < size <= Int.max_signed}.
Context {inf_rep: 0 < inf < Int.max_signed}.

Definition edgeless_graph' := @edgeless_graph size inf inf_rep size_rep'.
Definition adde := @UAdjMatGG_adde size inf.
Definition eremove := @UAdjMatGG_eremove size inf.

Lemma edgeless_vert_rep:
  forall v,
    0 <= v < size ->
    (@vert_to_list size edgeless_graph' eformat v) =
    list_repeat (Z.to_nat size) inf.
Proof.
  unfold vert_to_list; intros. rewrite map_map. apply list_eq_Znth.
+rewrite Zlength_map, nat_inc_list_Zlength, Zlength_list_repeat'; auto.
+intros. rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id in H0. 2: lia.
rewrite Znth_list_repeat_inrange by auto.
rewrite Znth_map, nat_inc_list_i. simpl; auto.
rewrite Z2Nat.id; lia.
rewrite nat_inc_list_Zlength.
rewrite Z2Nat.id; lia.
Qed.

Lemma edgeless_to_symm_mat:
  graph_to_symm_mat edgeless_graph' =
  list_repeat (Z.to_nat size) (list_repeat (Z.to_nat size) inf).
Proof.
  unfold graph_to_symm_mat, graph_to_mat. apply list_eq_Znth.
+rewrite Zlength_map, nat_inc_list_Zlength, Zlength_list_repeat'; auto.
+intros. rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id in H by lia.
rewrite Znth_list_repeat_inrange by lia.
rewrite Znth_map. rewrite nat_inc_list_i. apply edgeless_vert_rep; lia.
rewrite Z2Nat.id by lia; lia.
rewrite nat_inc_list_Zlength, Z2Nat.id; lia.
Qed.

End Spatial_UAdjMat_Model_3.