Require Import Ensembles.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Program.Program.
Require Import Order.
Require Import Fix.

Class Meet A := meet : A -> A -> A.
Class Join A := join : A -> A -> A.
Class Top A := top: A.
Class Bottom A := bottom: A.

Infix "⊓" := meet (at level 49, no associativity).
Infix "⊔" := join (at level 49, no associativity).

Notation "(⊓)" := meet (only parsing).
Notation "(⊔)" := join (only parsing).

Typeclasses Transparent Meet Join Top Bottom.

Class MeetSemiLatticeOrder {A:Type} `{Ae : Equiv A} (Ale: Le A) `{Meet A} : Prop :=
  { meet_lattice_ord :> PartialOrder (≤)
  ; meet_lb_l : forall x y, x ⊓ y ≤ x
  ; meet_lbl_r: forall x y, x ⊓ y ≤ y
  ; meet_glb  : forall x y z, z ≤ x -> z ≤ y -> z ≤ x ⊓ y }.

Class JoinSemiLatticeOrder {A:Type} `{Ae : Equiv A} (Ale: Le A) `{Join A} : Prop :=
  { join_lattice_ord :> PartialOrder (≤)
  ; join_lb_l : forall x y, x ≤ x ⊔ y
  ; join_lbl_r: forall x y, y ≤ x ⊔ y
  ; join_lub  : forall x y z, x ≤ z -> y ≤ z -> x ⊔ y ≤ z }.

Class LatticeOrder {A:Type} `{Ae : Equiv A} (Ale : Le A) `{Meet A} `{Join A} : Prop :=
  { lattice_order_meet :> MeetSemiLatticeOrder (≤)
  ; lattice_order_join :> JoinSemiLatticeOrder (≤) }.

Definition contains {U:Type} (S : Ensemble U) (x : U) : Prop := S x.

Infix "∈" := (flip contains) (at level 55, no associativity).

Definition subset {U:Type} (A B : Ensemble U) := forall x, x ∈ A -> x ∈ B.

Section Bounds.

Context {A : Type} `{Le A}.

Definition Upper_Bound (S: Ensemble A) (d:A) : Prop :=
 forall s, s ∈ S -> s ≤ d.

Definition Lower_Bound (S: Ensemble A) (d:A) : Prop :=
 forall s, s ∈ S -> d ≤ s.

Definition Upper_Set (S :  Ensemble A) : Ensemble A :=
  fun d => Upper_Bound S d.

Definition Lower_Set (S :  Ensemble A) : Ensemble A :=
  fun d => Lower_Bound S d.

End Bounds.

Section CLattice.

Class CompleteLattice {A: Type} `{Ae: Equiv A} (Ale: Le A) :=
  { ltord :> PartialOrder (≤)
  ; inf   : forall S : A -> Prop, A
  ; Pinf  : forall P : Ensemble A, Lower_Bound P (inf P)
  ; PinfL : forall P : Ensemble A, forall t, Lower_Bound P t -> t ≤ inf P }.

Context {A} `{CompleteLattice A}.

Definition sup (S :  A -> Prop) : A := inf (Upper_Set S).

Lemma Psup : forall (S: A -> Prop), Upper_Bound S (sup S).
Proof.
intros Sl t C.
apply PinfL.
intros x Usl.
apply Usl.
apply C.
Qed.

Lemma PsupL : forall (S: A->Prop) t, Upper_Bound S t -> sup S ≤ t.
Proof.
intros S t Sl.
apply Pinf. red.
apply Sl.
Qed.

Lemma inf_rewrite : forall (S : A->Prop), inf S = sup (Lower_Set S).
Proof.
  intros.
  unfold sup.
  apply po_antisym.
  apply PinfL.
  reduce.
  reduce in H0.
  apply H0.
  apply Pinf.
  apply PinfL.
  reduce.
  apply Pinf.
  reduce.
  apply H1.
  apply H0.
Qed.

Global Instance dual_is_clattice  : CompleteLattice (≥) := {
  inf := sup }.
apply dual_is_partialorder.
apply Psup.
apply PsupL.
Defined.

End CLattice.

Definition bot {A} `{CompleteLattice A} := inf (fun _ => True).

Notation "⊥" := bot.

Section SubLattices.

Context {A} {P : A->Prop} `{Equiv A} (leq : Le A)  `{!CompleteLattice leq}.

Variable PSinf: forall (S : Ensemble A), (forall t, S t -> P t) -> P (inf S).

Definition Embed (t : A) (p : P t) : { x : A | P x }.
exists t . apply p.
Defined.

Definition Extend (S : { x : A | P x } -> Prop) : A -> Prop.
intro l. apply (exists p:P l, S (Embed l p)).
Defined.

Lemma ExtendP : forall (S : {x : A | P x} -> Prop) t, Extend S t -> P t.
intros S t Ex. unfold Extend in Ex. unfold Embed in Ex. destruct Ex as [E _]. apply E.
Defined.

Global Instance subord_is_clattice : CompleteLattice (sub_leq (P:=P) leq).
  exists (fun (S : Ensemble { x : A | P x }) => Embed (inf (Extend S)) (PSinf (Extend S) (ExtendP S))).
  destruct CompleteLattice0. apply subord_is_partialorder. apply ltord0.
- intros P0 t C. unfold le. unfold sub_leq. unfold inf. refine (Pinf _ _ _).
  unfold contains. unfold Extend. unfold Embed. red. exists (proj2_sig t). destruct t. apply C.
- intros P0 t C. unfold le. unfold sub_leq. destruct CompleteLattice0. apply PinfL0. unfold le in C. unfold sub_leq in C. intros x Ex.
  unfold Extend in Ex. unfold Embed in Ex. destruct Ex as [Pt St]. specialize (C _ St). apply C.
Qed.

End SubLattices.

Section ArrowLattice.

Context {A B: Type} (leb: Le B) `{Equiv B} `{!CompleteLattice leb}.

Global Instance arrow_is_clattice : CompleteLattice (arrow_leq (A:=A)).
  exists (fun S => fun d :A => inf (fun x => exists f, f ∈ S /\ f d = x)).
  apply arrow_is_partialorder. apply ltord.
- destruct CompleteLattice0. unfold Lower_Bound in *. intros. unfold le in *. unfold arrow_leq in *. intros t.
  apply Pinf0. unfold contains. unfold flip. exists s. split.
  + assumption.
  + destruct ltord0. reflexivity.
- unfold le in *. unfold arrow_leq in *. destruct CompleteLattice0.
  intros. apply PinfL0. intro. unfold contains. unfold flip. intro.
  case H1. intro. intro. destruct H2. destruct ltord0. rewrite <- H3.
  apply H0. apply H2.
Defined.

End ArrowLattice.

Section ProdLattice.

Context {A} {B} {lea : Le A} {leb : Le B} `{Equiv A} `{!CompleteLattice lea} `{Equiv B}  `{!CompleteLattice leb}.

Instance : CompleteLattice (@prod_leq A B lea leb).
  exists (fun (S : Ensemble (A*B)) => (inf (fun (l1:A) => exists l2, S(l1,l2)), inf (fun (l2:B) => exists l1, S(l1,l2)))).
  apply prod_is_partialorder; apply ltord.
unfold Lower_Bound. unfold le. unfold prod_leq. simpl. intros P s Ps.
  split. apply Pinf. reduce. exists (snd s).
  assert (ss:= surjective_pairing). rewrite <- ss. apply Ps.
  apply Pinf. reduce. exists (fst s).
  assert (ss:= surjective_pairing). rewrite <- ss. apply Ps.
unfold Lower_Bound. unfold le. unfold prod_leq. simpl. intros P s Ps.
split. apply PinfL. unfold Lower_Bound. intros. reduce in H1. case H1. intros.
specialize Ps with (s0:=(pair s0 x)). apply Ps in H2. destruct H2. apply H2.
apply PinfL. unfold Lower_Bound. intros. reduce in H1. case H1. intros.
specialize Ps with (s0:=(pair x s0)). apply Ps in H2. destruct H2. apply H3.
Qed.

End ProdLattice.

Section KnapsterTarski.

Context {A} `{eq : Equiv A}  (leq : Le A) `{!CompleteLattice leq} (f: A->A) `{!OrderPreserving f}.

Lemma PreFixedInfs: forall S : Ensemble A,
        (forall t : A, S t -> PreFixedPoint f t) -> PreFixedPoint f (inf S).
Proof.
intros S C.
unfold PreFixedPoint in *.
destruct CompleteLattice0.
apply (PinfL0 S).
intros l Sl.
transitivity (f l).
destruct  OrderPreserving0.
apply order_preserving. apply Pinf. apply Sl.
apply (C _ Sl).
Qed.

Lemma PostFixedSups : forall S : Ensemble A,
        (forall t : A, S t -> PostFixedPoint f t) -> PostFixedPoint f (@inf A equiv (flip leq) dual_is_clattice S).
Proof.
unfold PostFixedPoint.
intros S C.
apply PsupL.
intros l Sl.
transitivity (f l).
apply (C _ Sl).
destruct  OrderPreserving0.
apply order_preserving. apply Psup. apply Sl.
Qed.

Instance PreFixedLattice : CompleteLattice (sub_leq (P:=PreFixedPoint f) leq).
apply (subord_is_clattice leq PreFixedInfs).
Defined.

Instance PostFixedLattice : CompleteLattice (sub_leq (P:=PostFixedPoint f) (flip leq)).
apply (subord_is_clattice (flip leq) PostFixedSups).
Defined.

Definition lfp := proj1_sig (@inf {x : A | PreFixedPoint f x} (sub_equiv) (sub_leq leq) PreFixedLattice (fun _ => True)).
Definition gfp := proj1_sig (@inf {x : A | PostFixedPoint f x} (sub_equiv) (sub_leq (flip leq)) PostFixedLattice (fun _  => True)).

Lemma lfp_is_PreFixedPoint : PreFixedPoint f lfp.
Proof.
unfold PreFixedPoint. unfold lfp.
assert (yy:=@Pinf {x : A | PreFixedPoint f x} (sub_equiv) (sub_leq leq) PreFixedLattice).
generalize yy;  clear yy.
case (@inf {x : A | PreFixedPoint f x} (sub_equiv) (sub_leq leq) PreFixedLattice (fun _ => True)).
intros x Px yy.
apply Px.
Qed.

Lemma gfp_is_PostFixedPoint : PostFixedPoint f gfp.
Proof.
unfold PostFixedPoint. unfold gfp.
assert (yy:=@Pinf {x : A | PostFixedPoint f x} (sub_equiv) (sub_leq (flip leq)) PostFixedLattice).
generalize yy;  clear yy.
case (@inf {x : A | PostFixedPoint f x} (sub_equiv) (sub_leq (flip leq)) PostFixedLattice (fun _ => True)).
intros x Px yy.
apply Px.
Qed.

(* least fixed point is the least of all pre-fixed points. *)
Lemma lfp_least : forall fp, PreFixedPoint f fp -> lfp ≤ fp.
Proof.
unfold PreFixedPoint. unfold lfp.
assert (yy:=@Pinf {x : A | PreFixedPoint f x} (sub_equiv) (sub_leq leq) PreFixedLattice (fun _ => True)).
generalize yy; clear yy.
case (@inf {x : A | PreFixedPoint f x} (sub_equiv) (sub_leq leq) PreFixedLattice (fun _ => True)).
unfold proj1_sig.
intros x Px yy.
assert (zz:=fun X PX => (yy (exist (fun t => PreFixedPoint f t) X PX))). clear yy.
case (@inf {x : A | PreFixedPoint f x} (sub_equiv) (sub_leq leq) PreFixedLattice (fun _ => True)).
intros.
refine (zz _ H _).
reduce.
trivial.
Qed.

(* greatest fixed point is the greatest among all post-fixed points *)
Lemma gfp_greatest : forall fp, PostFixedPoint f fp -> fp ≤ gfp.
Proof.
unfold PostFixedPoint. unfold gfp.
assert (yy:=@Pinf {x : A | PostFixedPoint f x} (sub_equiv) (sub_leq (flip leq)) PostFixedLattice (fun _ => True)).
generalize yy; clear yy.
case (@inf {x : A | PostFixedPoint f x} (sub_equiv) (sub_leq (flip leq)) PostFixedLattice (fun _ => True)).
unfold proj1_sig.
intros x Px yy.
assert (zz:=fun X PX => (yy (exist (fun t => PostFixedPoint f t) X PX))). clear yy.
case (@inf {x : A | PostFixedPoint f x} (sub_equiv) (sub_leq (flip leq)) PostFixedLattice (fun _ => True)).
intros.
refine (zz _ H _).
reduce.
trivial.
Qed.

Lemma lfp_fixedpoint : FixedPoint f lfp.
Proof.
unfold FixedPoint.
apply po_antisym.
- apply lfp_is_PreFixedPoint.
- assert (Hfx: PreFixedPoint f (f lfp)). {
    unfold PreFixedPoint. apply OrderPreserving0. apply lfp_is_PreFixedPoint. }
  apply lfp_least. apply Hfx.
Qed.

Lemma gfp_fixedpoint : FixedPoint f gfp.
Proof.
unfold FixedPoint.
apply po_antisym.
- assert (Hfx: PostFixedPoint f (f gfp)). {
    unfold PostFixedPoint. apply OrderPreserving0. apply gfp_is_PostFixedPoint. }
  apply gfp_greatest. apply Hfx.
- apply gfp_is_PostFixedPoint.
Qed.

End KnapsterTarski.

Section OrderPreservingLattice.

Context {A B : Type} `{PartialOrder A} `{Equiv B} (leq : Le B) `{!CompleteLattice leq}.

Lemma inf_is_order_preserving : forall (S : Ensemble (A->B)), (forall t : A->B, S t -> OrderPreserving t) -> OrderPreserving (inf (Ale:=arrow_leq) S).
intros S l.
assert (Hhh : forall (x:A) (f : A->B), S f -> (f x) ∈ (fun x0 : B => exists g : A->B, S g /\ g x = x0)). {
    intros. exists f. split. assumption. destruct CompleteLattice0. destruct ltord0. reflexivity. }
split.
- split.
 + assumption.
 + destruct CompleteLattice0. assumption.
 +
  split.
    * destruct H0. apply po_setoid.
    * destruct CompleteLattice0. destruct ltord0. apply po_setoid.
    * reduce.
      assert (forall f : A -> B, S f -> f x = f y). {
        intro. intro.  apply l in H3. destruct CompleteLattice0. destruct ltord0. rewrite H2. reflexivity. }
      assert (forall x y, x ≤ y /\ y ≤ x <-> x = y). {
        intros. split. intro. destruct H4. destruct CompleteLattice0. destruct ltord0.
        apply po_antisym. assumption. assumption.
        intro.  destruct CompleteLattice0. destruct ltord0. split. rewrite H4.  reflexivity. rewrite H4. reflexivity. }
      apply H4. split.
      destruct CompleteLattice0. unfold inf. unfold arrow_is_clattice. reduce.
      { apply PinfL0. intro. intro. reduce in H5. case H5. intros. destruct H6. apply Pinf0. reduce. exists x0. destruct ltord0. rewrite <- H7. split.
        assumption. apply H3. apply H6. }
            destruct CompleteLattice0.
      { apply PinfL0. intro. intro. reduce in H5. case H5. intros. destruct H6. apply Pinf0. reduce. exists x0. destruct ltord0. rewrite <- H7. split.
        assumption. symmetry. apply H3. apply H6. }
- intros. unfold inf. unfold arrow_is_clattice. unfold contains. unfold flip. reduce.
  destruct CompleteLattice0.
  assert (mon: forall f : A->B, S f -> f x ≤ f y). { intros. apply l. assumption. assumption. }

  apply PinfL0. unfold Lower_Bound. intros.  reduce in H3. case H3. intro. intro. destruct H4. assert (Hc : S x0). { assumption. }
  apply mon in H4. destruct ltord0. rewrite <- H5.
  simple apply Hhh with (f:=x0) (x:=x) in Hc.
  apply Pinf0 in Hc.
  transitivity (x0 x). assumption. assumption.
Qed.

Global Instance orderpreserving_is_complete_lattice : CompleteLattice (sub_leq (P:=OrderPreserving) (@arrow_leq A B leq)).
apply (subord_is_clattice (@arrow_leq A B leq) inf_is_order_preserving).
Qed.

End OrderPreservingLattice.


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

- Frederic Blanqui & Wang Qian & Zhang Lianyi, 2009-05-06

positions in a term and related functions and relations:
subterm at some position, replacement of a subterm at some position,
context corresponding to a position, position of the Hole of a context,
definition of rewriting based on positions
*)

Set Implicit Arguments.

From CoLoR Require Import ATrs ListUtil NatUtil VecUtil LogicUtil OptUtil.

(***********************************************************************)
(** positions are lists of natural numbers *)

Notation position := (list nat).

Section S.

Variable Sig : Signature.

Notation term := (term Sig). Notation context := (context Sig).
Notation terms := (vector term).

(***********************************************************************)
(** context corresponding to a position *)

Fixpoint context_pos (t : term) (ps : position) : option context :=
  match t, ps with
    | _, nil => Some Hole
    | Var x, _ :: _ => None
    | Fun f ts, p :: ps =>
      match lt_ge_dec p (arity f) with
        | left h =>
          match context_pos (Vnth ts h) ps with
            | None => None
            | Some x =>
              Some (Cont f (Veq_app_cons_aux3 h)
                (Vsub ts (Veq_app_cons_aux1 h))
                x (Vsub ts (Veq_app_cons_aux2 h)))
          end
        | right _ => None
      end
  end.

(***********************************************************************)
(** subterm at some position *)

Fixpoint subterm_pos (t : term) (ps : position) {struct ps} : option term :=
  match t, ps with
    | _ , nil => Some t
    | Var x , _ :: _ => None
    | Fun f ts, p :: ps' =>
      match lt_ge_dec p (arity f) with
        | left h => subterm_pos (Vnth ts h) ps'
        | right _ => None
      end
  end.

Lemma subterm_pos_elim : forall p t u, subterm_pos t p = Some u ->
  {C | context_pos t p = Some C /\  t = fill C u}.

Proof.
induction p; simpl; intros.
(* nil *)
exists Hole. simpl. destruct t; inversion H; auto.
(* cons *)
destruct t. discr. revert H. simpl.
destruct (lt_ge_dec a (arity f)); intros. 2: discr.
destruct (IHp _ _ H). destruct a0. rewrite H0.
exists (Cont f (Veq_app_cons_aux3 l)
  (Vsub t (Veq_app_cons_aux1 l)) x (Vsub t (Veq_app_cons_aux2 l))).
intuition. simpl. apply args_eq. rewrite <- H1. apply Veq_app_cons_aux.
Defined.

Lemma subterm_pos_sub : forall s u p t,
  subterm_pos t p = Some u -> subterm_pos (sub s t) p = Some (sub s u).

Proof.
induction p; destruct t; simpl; intros.
inversion H. simpl. destruct (s n); refl.
inversion H. rewrite sub_fun. refl.
discr. revert H. destruct (lt_ge_dec a (arity f)); intro.
rewrite Vnth_map. apply IHp. hyp. discr.
Qed.

(***********************************************************************)
(** replace subterm at some position *)

Fixpoint replace_pos (t : term) (ps : position) (u : term)
  : option term :=
  match t, ps with
    | _, nil => Some u
    | Var x, _ :: _ => None
    | Fun f ts, p :: ps' =>
      match lt_ge_dec p (arity f) with
        | left h =>
          match replace_pos (Vnth ts h) ps' u with
            | None => None
            | Some v => Some (Fun f (Vreplace ts h v))
          end
        | right _ => None
      end
  end.

Lemma subterm_pos_replace_eq_Some : forall p u v t,
  subterm_pos t p = Some u -> {w | replace_pos t p v = Some w}.

Proof.
induction p; simpl; intros.
(* nil *)
destruct t; exists v; simpl; refl.
(* cons *)
destruct t. discr. simpl.
case_eq (lt_ge_dec a (arity f)); intros l H0; rewrite H0 in H; clear H0.
destruct (IHp _ v _ H). rewrite e. exists (Fun f (Vreplace t l x)). refl.
discr.
Defined.

Lemma subterm_pos_replace_neq_None : forall p u v t,
  subterm_pos t p = Some u -> replace_pos t p v <> None.

Proof.
intros. destruct (subterm_pos_replace_eq_Some p v t H). rewrite e. discr.
Qed.

Lemma replace_pos_elim : forall p t u t', replace_pos t p u = Some t' ->
  {C | context_pos t p = Some C /\ t' = fill C u}.

Proof.
induction p; intros.
(* nil *)
exists Hole. simpl. destruct t; inversion H; auto.
(* cons *)
destruct t; destruct t'.
(* Var, Var *)
discr.
(* Var, Fun *)
discr.
(* Fun, Var *)
revert H. simpl. destruct (lt_ge_dec a (arity f)); intro.
destruct (replace_pos (Vnth t l) p u); inversion H. discr.
(* Fun, Fun *)
gen H. simpl. destruct (lt_ge_dec a (arity f)); intro. 2: discr.
destruct (replace_pos (Vnth t l) p u). 2: discr.
apply Some_eq in H0. Funeqtac. subst t0.
destruct (IHp (Vnth t l) u t1). revert H. simpl.
destruct (lt_ge_dec a (arity f)); intro. 2: discr.
assert (l0 = l). apply lt_unique. subst l0.
destruct (replace_pos (Vnth t l) p u). 2: discr.
f_equal. apply Some_eq in H. Funeqtac.
apply Vreplace_eq_elim in H0. hyp. destruct a0. rewrite H0.
exists (Cont f (Veq_app_cons_aux3 l) (Vsub t (Veq_app_cons_aux1 l)) x
  (Vsub t (Veq_app_cons_aux2 l))). intuition. simpl. apply args_eq.
assert (fill x u = Vnth (Vreplace t l t1) l). rewrite <- H1.
rewrite Vnth_replace. refl. rewrite H2.
rewrite (Veq_app_cons_aux (Vreplace t l t1) (Veq_app_cons_aux1 l)
  l (Veq_app_cons_aux2 l) (Veq_app_cons_aux3 l)).
apply Vcast_eq_intro. apply Vapp_eq_intro. rewrite Vsub_replace_l. refl. lia.
apply Vcons_eq_intro. rewrite Vnth_cast. rewrite Vnth_app_cons. refl.
rewrite Vsub_replace_r. refl. lia.
Defined.

Arguments replace_pos_elim [p t u t'] _.

(***********************************************************************)
(** position of the Hole in a context *)

Fixpoint pos_context (C : context) : position :=
  match C with
    | Hole => nil
    | @Cont _ _ i _ _ _ C _ => i :: pos_context C
  end.

Lemma subterm_fill_pos_context : forall c u,
  subterm_pos (fill c u) (pos_context c) = Some u.

Proof.
induction c; intros; simpl.
destruct u; auto.
case (lt_ge_dec i (arity f)); intro. 2: lia.
rewrite Vnth_cast. rewrite Vnth_app_cons. apply IHc.
Qed.

Lemma replace_fill_pos_context : forall c u v,
  replace_pos (fill c u) (pos_context c) v = Some (fill c v).

Proof.
induction c; intros; simpl.
(* nil *)
destruct u; auto.
(* cons *)
case (lt_ge_dec i (arity f)); intro. rewrite Vnth_cast. rewrite Vnth_app_cons.
2: lia. rewrite (IHc u v). f_equal. apply args_eq.
apply Veq_nth; intros. rewrite Vnth_cast.
destruct (eq_nat_dec i i0).
subst i0. rewrite Vnth_replace. rewrite Vnth_app_cons. refl.
rewrite Vnth_replace_neq. 2: hyp. rewrite Vnth_cast.
apply Vnth_app_cons_neq. auto.
Qed.

(***********************************************************************)
(** definition of rewriting based on positions *)

Definition red_pos R u v := exists p, exists l, exists r, exists s,
  In (mkRule l r) R
  /\ subterm_pos u p = Some (sub s l)
  /\ replace_pos u p (sub s r) = Some v.

Lemma red_pos_ok : forall R t u, red R t u <-> red_pos R t u.

Proof.
split; intro.
(* red << red_pos *)
redtac. unfold red_pos. exists (pos_context c). exists l. exists r. exists s.
intuition; rewrite xl. apply subterm_fill_pos_context.
rewrite yr. apply replace_fill_pos_context.
(* red_pos << red *)
unfold red. unfold red_pos in H. decomp H.
exists x0. exists x1. apply subterm_pos_elim in H1. destruct H1. destruct a.
exists x3. exists x2. intuition. ded (replace_pos_elim H3). destruct X.
destruct a. rewrite H in H2. inversion H2. subst x4. hyp.
Qed.

(***********************************************************************)
(** position of a variables *)

Lemma in_vars_subterm : forall x t, In x (vars t) ->
  exists ps, subterm_pos t ps = Some (Var x).

Proof.
intros x t; pattern t; apply term_ind with (Q := fun n (ts : terms n) =>
  In x (vars_vec ts) -> exists i, exists h:i<n, exists ps,
    subterm_pos (Vnth ts h) ps = Some (Var x)); clear t.
intro y. simpl. intuition. subst. exists nil. refl.
intros f ts IH h. rewrite vars_fun in h. destruct (IH h). do 2 destruct H.
exists (x0::x2). simpl. case (lt_ge_dec x0 (arity f)); intro.
rewrite (lt_unique l x1). hyp. lia.
simpl. tauto.
intros t n ts ht hts. simpl vars_vec. rewrite in_app. intros [h|h].
destruct (ht h). exists 0. exists (lt_O_Sn n). exists x0. simpl. hyp.
destruct (hts h). do 2 destruct H. exists (S x0). exists (lt_n_S x1).
exists x2. simpl. rewrite (lt_unique (lt_S_n (lt_n_S x1)) x1). hyp.
Qed.

End S.

Arguments subterm_pos_elim [Sig p t u] _.
Arguments in_vars_subterm [Sig x t] _.
Arguments subterm_pos_sub [Sig] _ [u p t] _.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import finfun path matrix.
Require Import bigop ssralg poly polydiv ssrnum zmodp div ssrint.
Require Import polyorder polyrcf interval polyXY.
Require Import qe_rcf_th ordered_qelim mxtens.

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

Import GRing.Theory Num.Theory.

Local Open Scope nat_scope.
Local Open Scope ring_scope.

Import ord.

Section QF.

Variable R : Type.

Inductive term : Type :=
| Var of nat
| Const of R
| NatConst of nat
| Add of term & term
| Opp of term
| NatMul of term & nat
| Mul of term & term
| Exp of term & nat.

Inductive formula : Type :=
| Bool of bool
| Equal of term & term
| Lt of term & term
| Le of term & term
| And of formula & formula
| Or of formula & formula
| Implies of formula & formula
| Not of formula.

Coercion rterm_to_term := fix loop (t : term) : GRing.term R :=
  match t with
    | Var x => GRing.Var _ x
    | Const x => GRing.Const x
    | NatConst n => GRing.NatConst _ n
    | Add u v => GRing.Add (loop u) (loop v)
    | Opp u => GRing.Opp (loop u)
    | NatMul u n  => GRing.NatMul (loop u) n
    | Mul u v => GRing.Mul (loop u) (loop v)
    | Exp u n => GRing.Exp (loop u) n
  end.

Coercion qfr_to_formula := fix loop (f : formula) : ord.formula R :=
  match f with
    | Bool b => ord.Bool b
    | Equal x y => ord.Equal x y
    | Lt x y => ord.Lt x y
    | Le x y => ord.Le x y
    | And f g => ord.And (loop f) (loop g)
    | Or f g => ord.Or (loop f) (loop g)
    | Implies f g => ord.Implies (loop f) (loop g)
    | Not f => ord.Not (loop f)
  end.

Definition to_rterm := fix loop (t : GRing.term R) : term :=
  match t with
    | GRing.Var x => Var x
    | GRing.Const x => Const x
    | GRing.NatConst n => NatConst n
    | GRing.Add u v => Add (loop u) (loop v)
    | GRing.Opp u => Opp (loop u)
    | GRing.NatMul u n  => NatMul (loop u) n
    | GRing.Mul u v => Mul (loop u) (loop v)
    | GRing.Exp u n => Exp (loop u) n
    | _ => NatConst 0
  end.

End QF.

Bind Scope qf_scope with term.
Bind Scope qf_scope with formula.
Arguments Scope Add [_ qf_scope qf_scope].
Arguments Scope Opp [_ qf_scope].
Arguments Scope NatMul [_ qf_scope nat_scope].
Arguments Scope Mul [_ qf_scope qf_scope].
Arguments Scope Mul [_ qf_scope qf_scope].
Arguments Scope Exp [_ qf_scope nat_scope].
Arguments Scope Equal [_ qf_scope qf_scope].
Arguments Scope And [_ qf_scope qf_scope].
Arguments Scope Or [_ qf_scope qf_scope].
Arguments Scope Implies [_ qf_scope qf_scope].
Arguments Scope Not [_ qf_scope].

Implicit Arguments Bool [R].
Prenex Implicits Const Add Opp NatMul Mul Exp Bool Unit And Or Implies Not Lt.
Prenex Implicits to_rterm.

Notation True := (Bool true).
Notation False := (Bool false).

Delimit Scope qf_scope with qfT.
Notation "''X_' i" := (Var _ i) : qf_scope.
Notation "n %:R" := (NatConst _ n) : qf_scope.
Notation "x %:T" := (Const x) : qf_scope.
Notation "0" := 0%:R%qfT : qf_scope.
Notation "1" := 1%:R%qfT : qf_scope.
Infix "+" := Add : qf_scope.
Notation "- t" := (Opp t) : qf_scope.
Notation "t - u" := (Add t (- u)) : qf_scope.
Infix "*" := Mul : qf_scope.
Infix "*+" := NatMul : qf_scope.
Infix "^+" := Exp : qf_scope.
Notation "t ^- n" := (t^-1 ^+ n)%qfT : qf_scope.
Infix "==" := Equal : qf_scope.
Infix "<%" := Lt : qf_scope.
Infix "<=%" := Le : qf_scope.
Infix "/\" := And : qf_scope.
Infix "\/" := Or : qf_scope.
Infix "==>" := Implies : qf_scope.
Notation "~ f" := (Not f) : qf_scope.
Notation "x != y" := (Not (x == y)) : qf_scope.

Section evaluation.

Variable R : realDomainType.

Fixpoint eval (e : seq R) (t : term R) {struct t} : R :=
  match t with
  | ('X_i)%qfT => e`_i
  | (x%:T)%qfT => x
  | (n%:R)%qfT => n%:R
  | (t1 + t2)%qfT => eval e t1 + eval e t2
  | (- t1)%qfT => - eval e t1
  | (t1 *+ n)%qfT => eval e t1 *+ n
  | (t1 * t2)%qfT => eval e t1 * eval e t2
  | (t1 ^+ n)%qfT => eval e t1 ^+ n
  end.

Lemma evalE (e : seq R) (t : term R) : eval e t = GRing.eval e t.
Proof. by elim: t=> /=; do ?[move->|move=>?]. Qed.

Definition qf_eval e := fix loop (f : formula R) : bool :=
  match f with
  | Bool b => b
  | t1 == t2 => (eval e t1 == eval e t2)%bool
  | t1 <% t2 => (eval e t1 < eval e t2)%bool
  | t1 <=% t2 => (eval e t1 <= eval e t2)%bool
  | f1 /\ f2 => loop f1 && loop f2
  | f1 \/ f2 => loop f1 || loop f2
  | f1 ==> f2 => (loop f1 ==> loop f2)%bool
  | ~ f1 => ~~ loop f1
  end%qfT.

Lemma qf_evalE (e : seq R) (f : formula R) : qf_eval e f = ord.qf_eval e f.
Proof. by elim: f=> /=; do ?[rewrite evalE|move->|move=>?]. Qed.

Lemma to_rtermE (t : GRing.term R) :
  GRing.rterm t -> to_rterm t = t :> GRing.term _.
Proof.
elim: t=> //=; do ?
  [ by move=> u hu v hv /andP[ru rv]; rewrite hu ?hv
  | by move=> u hu *; rewrite hu].
Qed.

End evaluation.

Import Pdiv.Ring.

Definition bind_def T1 T2 T3 (f : (T1 -> T2) -> T3) (k : T1 -> T2)  := f k.
Notation "'bind' x <- y ; z" :=
  (bind_def y (fun x => z)) (at level 99, x at level 0, y at level 0,
    format "'[hv' 'bind'  x  <-  y ;  '/' z ']'").

Section ProjDef.

Variable F : realFieldType.

Notation fF := (formula  F).
Notation tF := (term  F).
Definition polyF := seq tF.

Lemma qf_formF (f : fF) : qf_form f.
Proof. by elim: f=> // *; apply/andP; split. Qed.

Lemma rtermF (t : tF) : GRing.rterm t.
Proof. by elim: t=> //=; do ?[move->|move=>?]. Qed.

Lemma rformulaF (f : fF) : rformula f.
Proof. by elim: f=> /=; do ?[rewrite rtermF|move->|move=>?]. Qed.

Section If.

Implicit Types (pf tf ef : formula F).

Definition If pf tf ef := (pf /\ tf \/ ~ pf /\ ef)%qfT.

End If.

Notation "'If' c1 'Then' c2 'Else' c3" := (If c1 c2 c3)
  (at level 200, right associativity, format
"'[hv   ' 'If'  c1  '/' '[' 'Then'  c2  ']' '/' '[' 'Else'  c3 ']' ']'").

Notation cps T := ((T -> fF) -> fF).

Section Pick.

Variables (I : finType) (pred_f then_f : I -> fF) (else_f : fF).

Definition Pick :=
  \big[Or/False]_(p : {ffun pred I})
    ((\big[And/True]_i (if p i then pred_f i else ~ pred_f i))
    /\ (if pick p is Some i then then_f i else else_f))%qfT.

Lemma eval_Pick e (qev := qf_eval e) :
  let P i := qev (pred_f i) in
  qev Pick = (if pick P is Some i then qev (then_f i) else qev else_f).
Proof.
move=> P; rewrite ((big_morph qev) false orb) //= big_orE /=.
apply/existsP/idP=> [[p] | true_at_P].
  rewrite ((big_morph qev) true andb) //= big_andE /=.
  case/andP=> /forallP eq_p_P.
  rewrite (@eq_pick _ _ P) => [|i]; first by case: pick.
  by move/(_ i): eq_p_P => /=; case: (p i) => //=; move/negbTE.
exists [ffun i => P i] => /=; apply/andP; split.
  rewrite ((big_morph qev) true andb) //= big_andE /=.
  by apply/forallP=> i; rewrite /= ffunE; case Pi: (P i) => //=; apply: negbT.
rewrite (@eq_pick _ _ P) => [|i]; first by case: pick true_at_P.
by rewrite ffunE.
Qed.

End Pick.

Fixpoint eval_poly (e : seq F) pf :=
  if pf is c :: qf then (eval_poly e qf) * 'X + (eval e c)%:P else 0.

Lemma eval_polyP e p : eval_poly e p = Poly (map (eval e) p).
Proof. by elim: p=> // a p /= ->; rewrite cons_poly_def. Qed.

Fixpoint Size (p : polyF) : cps nat := fun k =>
  if p is c :: q then
    bind n <- Size q;
    if n is m.+1 then k m.+2
      else If c == 0 Then k 0%N Else k 1%N
    else k 0%N.

Definition Isnull (p : polyF) : cps bool := fun k =>
  bind n <- Size p; k (n == 0%N).

Definition LtSize (p q : polyF) : cps bool := fun k =>
  bind n <- Size p; bind m <- Size q; k (n < m)%N.

Fixpoint LeadCoef p : cps tF := fun k =>
  if p is c :: q then
    bind l <- LeadCoef q; If l == 0 Then k c Else k l
    else k (Const 0).

Fixpoint AmulXn (a : tF) (n : nat) : polyF:=
  if n is n'.+1 then (Const 0) :: (AmulXn a n') else [::a].

Fixpoint AddPoly (p q : polyF) :=
  if p is a::p' then
    if q is b::q' then (a + b)%qfT :: (AddPoly p' q')
      else p
    else q.
Local Infix "++" := AddPoly : qf_scope.

Definition ScalPoly (c : tF) (p : polyF) : polyF := map (Mul c) p.
Local Infix "*:" := ScalPoly : qf_scope.

Fixpoint MulPoly (p q : polyF) := if p is a :: p'
    then (a *: q ++ (0 :: (MulPoly p' q)))%qfT else [::].
Local Infix "**" := MulPoly (at level 40) : qf_scope.

Lemma map_poly0 (R R' : ringType) (f : R -> R') : map_poly f 0 = 0.
Proof. by rewrite map_polyE polyseq0. Qed.

Definition ExpPoly p n := iterop n MulPoly p [::1%qfT].
Local Infix "^^+" := ExpPoly (at level 29) : qf_scope.

Definition OppPoly := ScalPoly (@Const F (-1)).
Local Notation "-- p" := (OppPoly p) (at level 35) : qf_scope.
Local Notation "p -- q" := (p ++ (-- q))%qfT (at level 50) : qf_scope.

Definition NatMulPoly n := ScalPoly (NatConst F n).
Local Infix "+**" := NatMulPoly (at level 40) : qf_scope.

Fixpoint Horner (p : polyF) (x : tF) : tF :=
  if p is a :: p then (Horner p x * x + a)%qfT else 0%qfT.

Fixpoint Deriv (p : polyF) : polyF :=
  if p is a :: q then (q ++ (0 :: Deriv q))%qfT else [::].

Fixpoint Rediv_rec_loop (q : polyF) sq cq
  (c : nat) (qq r : polyF) (n : nat) {struct n} :
  cps (nat * polyF * polyF) := fun k =>
  bind sr <- Size r;
  if (sr < sq)%N then k (c, qq, r) else
    bind lr <- LeadCoef r;
    let m := AmulXn lr (sr - sq) in
    let qq1 := (qq ** [::cq] ++ m)%qfT in
    let r1 := (r ** [::cq] -- m ** q)%qfT in
    if n is n1.+1 then Rediv_rec_loop q sq cq c.+1 qq1 r1 n1 k
    else k (c.+1, qq1, r1).

 Definition Rediv (p : polyF) (q : polyF) : cps (nat * polyF * polyF) :=
  fun k =>
  bind b <- Isnull q;
  if b then k (0%N, [::Const 0], p)
    else bind sq <- Size q;
      bind sp <- Size p;
      bind lq <- LeadCoef q;
      Rediv_rec_loop q sq lq 0 [::Const 0] p sp k.

Definition Rmod (p : polyF) (q : polyF) (k : polyF -> fF) : fF :=
  Rediv p q (fun d => k d.2)%PAIR.
Definition Rdiv (p : polyF) (q : polyF) (k : polyF -> fF) : fF :=
  Rediv p q (fun d => k d.1.2)%PAIR.
Definition Rscal (p : polyF) (q : polyF) (k : nat -> fF) : fF :=
  Rediv p q (fun d => k d.1.1)%PAIR.
Definition Rdvd (p : polyF) (q : polyF) (k : bool -> fF) : fF :=
  bind r <- Rmod p q; bind r_null <- Isnull r; k r_null.

Fixpoint rgcdp_loop n (pp qq : {poly F}) {struct n} :=
  if rmodp pp qq == 0 then qq
    else if n is n1.+1 then rgcdp_loop n1 qq (rmodp pp qq)
        else rmodp pp qq.

Fixpoint Rgcd_loop n pp qq k {struct n} :=
  bind r <- Rmod pp qq; bind b <- Isnull r;
  if b then (k qq)
    else if n is n1.+1 then Rgcd_loop n1 qq r k else k r.

Definition Rgcd (p : polyF) (q : polyF) : cps polyF := fun k =>
  let aux p1 q1 k := (bind b <- Isnull p1;
    if b then k q1 else bind n <- Size p1; Rgcd_loop n p1 q1 k) in
  bind b <- LtSize p q;
  if b then aux q p k else aux p q k.

Fixpoint BigRgcd (ps : seq polyF) : cps (seq tF) := fun k =>
  if ps is p :: pr then bind r <- BigRgcd pr; Rgcd p r k else k [::Const 0].

Fixpoint Changes (s : seq tF) : cps nat := fun k =>
  if s is a :: q then
    bind v <- Changes q;
    If (Lt (a * head 0 q) 0)%qfT Then k (1 + v)%N Else k v
    else k 0%N.

Fixpoint SeqPInfty (ps : seq polyF) : cps (seq tF) := fun k =>
  if ps is p :: ps then
    bind lp <- LeadCoef p;
    bind lps <- SeqPInfty ps;
    k (lp :: lps)
  else k [::].

Fixpoint SeqMInfty (ps : seq polyF) : cps (seq tF) := fun k =>
  if ps is p :: ps then
    bind lp <- LeadCoef p;
    bind sp <- Size p;
    bind lps <- SeqMInfty ps;
    k ((-1)%:T ^+ (~~ odd sp) * lp :: lps)%qfT
  else k [::].

Definition ChangesPoly ps : cps int := fun k =>
  bind mps <- SeqMInfty ps;
  bind pps <- SeqPInfty ps;
  bind vm <- Changes mps; bind vp <- Changes pps; k (vm%:Z - vp%:Z).

Definition NextMod (p q : polyF) : cps polyF := fun k =>
  bind lq <- LeadCoef q;
  bind spq <- Rscal p q;
  bind rpq <- Rmod p q; k (- lq ^+ spq *: rpq)%qfT.

Fixpoint ModsAux (p q : polyF) n : cps (seq polyF) := fun k =>
    if n is m.+1
      then
        bind p_eq0 <- Isnull p;
        if p_eq0 then k [::]
        else
          bind npq <- NextMod p q;
          bind ps <- ModsAux q npq m;
          k (p :: ps)
      else k [::].

Definition Mods (p q : polyF) : cps (seq polyF) := fun k =>
  bind sp <- Size p; bind sq <- Size q;
  ModsAux p q (maxn sp sq.+1) k.

Definition PolyComb (sq : seq polyF) (sc : seq int) :=
  reducebig [::1%qfT] (iota 0 (size sq))
  (fun i => BigBody i MulPoly true (nth [::] sq i ^^+ comb_exp sc`_i)%qfT).

Definition Pcq sq i := (nth [::] (map (PolyComb sq) (sg_tab (size sq))) i).

Definition TaqR (p : polyF) (q : polyF) : cps int := fun k =>
  bind r <- Mods p (Deriv p ** q)%qfT; ChangesPoly r k.

Definition TaqsR (p : polyF) (sq : seq polyF) (i : nat) : cps tF :=
  fun k => bind n <- TaqR p (Pcq sq i); k ((n%:~R) %:T)%qfT.

Fixpoint ProdPoly T (s : seq T) (f : T -> cps polyF) : cps polyF := fun k =>
  if s is a :: s then
    bind fa <- f a;
    bind fs <- ProdPoly s f;
    k (fa ** fs)%qfT
  else k [::1%qfT].

Definition BoundingPoly (sq : seq polyF) : polyF :=
  Deriv (reducebig [::1%qfT] sq (fun i => BigBody i MulPoly true i)).

Definition Coefs (n i : nat) : tF :=
  Const (match n with
    | 0 => (i == 0%N)%:R
    | 1 => [:: 2%:R^-1; 2%:R^-1; 0]`_i
    | n => coefs _ n i
  end).

Definition CcountWeak (p : polyF) (sq : seq polyF) : cps tF := fun k =>
  let fix aux s (i : nat) k := if i is i'.+1
    then bind x <- TaqsR p sq i';
      aux (x * (Coefs (size sq) i') + s)%qfT i' k
    else k s in
   aux 0%qfT (3 ^ size sq)%N k.

Definition CcountGt0 (sp sq : seq polyF) : fF :=
  bind p <- BigRgcd sp; bind p0 <- Isnull p;
  if ~~ p0 then
    bind c <- CcountWeak p sq;
    Lt 0%qfT c
  else
    let bq := BoundingPoly sq in
      bind cw <- CcountWeak bq sq;
      ((reducebig True sq (fun q =>
          BigBody q And true (LeadCoef q (fun lq => Lt 0 lq))))
        \/ ((reducebig True sq (fun q =>
         BigBody q And true
          (bind sq <- Size q;
          bind lq <- LeadCoef q;
          Lt 0 ((Opp 1) ^+ (sq).-1 * lq)
        ))) \/ Lt 0 cw))%qfT.

Fixpoint abstrX (i : nat) (t : tF) : polyF :=
  (match t with
    | 'X_n => if n == i then [::0; 1] else [::t]
    | - x => -- abstrX i x
    | x + y => abstrX i x ++ abstrX i y
    | x * y => abstrX i x ** abstrX i y
    | x *+ n => n +** abstrX i x
    | x ^+ n => abstrX i x ^^+ n
    | _ => [::t]
  end)%qfT.

Definition wproj (n : nat) (s : seq (GRing.term F) * seq (GRing.term F)) :
  formula F :=
  let sp := map (abstrX n \o to_rterm) s.1%PAIR in
  let sq := map (abstrX n \o to_rterm) s.2%PAIR in
    CcountGt0 sp sq.

Definition rcf_sat := proj_sat wproj.

End ProjDef.

Section ProjCorrect.

Variable F : rcfType.
Implicit Types (e : seq F).

Notation fF := (formula  F).
Notation tF := (term  F).
Notation polyF := (polyF F).

Notation "'If' c1 'Then' c2 'Else' c3" := (If c1 c2 c3)
  (at level 200, right associativity, format
"'[hv   ' 'If'  c1  '/' '[' 'Then'  c2  ']' '/' '[' 'Else'  c3 ']' ']'").

Notation cps T := ((T -> fF) -> fF).

Local Infix "**" := MulPoly (at level 40) : qf_scope.
Local Infix "+**" := NatMulPoly (at level 40) : qf_scope.
Local Notation "-- p" := (OppPoly p) (at level 35) : qf_scope.
Local Notation "p -- q" := (p ++ (-- q))%qfT (at level 50) : qf_scope.
Local Infix "^^+" := ExpPoly (at level 29) : qf_scope.
Local Infix "**" := MulPoly (at level 40) : qf_scope.
Local Infix "*:" := ScalPoly : qf_scope.
Local Infix "++" := AddPoly : qf_scope.

Lemma eval_If e pf tf ef (ev := qf_eval e) :
  ev (If pf Then tf Else ef) = (if ev pf then ev tf else ev ef).
Proof. by unlock (If _ Then _ Else _)=> /=; case: ifP => _; rewrite ?orbF. Qed.

Lemma eval_Size k p e :
  qf_eval e (Size p k) = qf_eval e (k (size (eval_poly e p))).
Proof.
elim: p e k=> [|c p ihp] e k; first by rewrite size_poly0.
rewrite ihp /= size_MXaddC -size_poly_eq0; case: size=> //.
by rewrite eval_If /=; case: (_ == _).
Qed.

Lemma eval_Isnull k p e : qf_eval e (Isnull p k)
  = qf_eval e (k (eval_poly e p == 0)).
Proof. by rewrite eval_Size size_poly_eq0. Qed.

Lemma eval_LeadCoef e p k k' :
  (forall x, qf_eval e (k x) = (k' (eval e x))) ->
  qf_eval e (LeadCoef p k) = k' (lead_coef (eval_poly e p)).
Proof.
move=> Pk; elim: p k k' Pk=> [|a p ihp] k k' Pk //=.
  by rewrite lead_coef0 Pk.
rewrite (ihp _ (fun l => if l == 0 then qf_eval e (k a) else (k' l))); last first.
  by move=> x; rewrite eval_If /= !Pk.
rewrite lead_coef_eq0; have [->|p_neq0] := altP (_ =P 0).
  by rewrite mul0r add0r lead_coefC.
rewrite lead_coefDl ?lead_coefMX ?size_mulX // ltnS size_polyC.
by rewrite (leq_trans (leq_b1 _)) // size_poly_gt0.
Qed.

Implicit Arguments eval_LeadCoef [e p k].
Prenex Implicits eval_LeadCoef.

Lemma eval_AmulXn a n e : eval_poly e (AmulXn a n) = (eval e a)%:P * 'X^n.
Proof.
elim: n=> [|n] /=; first by rewrite expr0 mulr1 mul0r add0r.
by move->; rewrite addr0 -mulrA -exprSr.
Qed.

Lemma eval_AddPoly p q e :
  eval_poly e (p ++ q)%qfT = (eval_poly e p) + (eval_poly e q).
Proof.
elim: p q => [|a p Hp] q /=; first by rewrite add0r.
case: q => [|b q] /=; first by rewrite addr0.
by rewrite Hp mulrDl rmorphD /= !addrA [X in _ = X + _]addrAC.
Qed.

Lemma eval_ScalPoly e t p :
  eval_poly e (ScalPoly t p) = (eval e t) *: (eval_poly e p).
Proof.
elim: p=> [|a p ihp] /=; first by rewrite scaler0.
by rewrite ihp scalerDr scalerAl -!mul_polyC rmorphM.
Qed.

Lemma eval_MulPoly e p q :
  eval_poly e (p ** q)%qfT = (eval_poly e p) * (eval_poly e q).
Proof.
elim: p q=> [|a p Hp] q /=; first by rewrite mul0r.
rewrite eval_AddPoly /= eval_ScalPoly Hp.
by rewrite addr0 mulrDl addrC mulrAC mul_polyC.
Qed.

Lemma eval_ExpPoly e p n : eval_poly e (p ^^+ n)%qfT = (eval_poly e p) ^+ n.
Proof.
case: n=> [|n]; first by rewrite /= expr0 mul0r add0r.
rewrite /ExpPoly iteropS exprSr; elim: n=> [|n ihn] //=.
  by rewrite expr0 mul1r.
by rewrite eval_MulPoly ihn exprS mulrA.
Qed.

Lemma eval_NatMulPoly p n e :
  eval_poly e (n +** p)%qfT = (eval_poly e p) *+ n.
Proof.
elim: p; rewrite //= ?mul0rn // => c p ->.
rewrite mulrnDl mulr_natl polyC_muln; congr (_+_).
by rewrite -mulr_natl mulrAC -mulrA mulr_natl mulrC.
Qed.

Lemma eval_OppPoly p e : eval_poly e (-- p)%qfT = - eval_poly e p.
Proof.
elim: p; rewrite //= ?oppr0 // => t ts ->.
by rewrite !mulNr !opprD polyC_opp mul1r.
Qed.

Lemma eval_Horner e p x : eval e (Horner p x) = (eval_poly e p).[eval e x].
Proof. by elim: p => /= [|a p ihp]; rewrite !(horner0, hornerE) // ihp. Qed.

Lemma eval_ConstPoly e c : eval_poly e [::c] = (eval e c)%:P.
Proof. by rewrite /= mul0r add0r. Qed.

Lemma eval_Deriv e p : eval_poly e (Deriv p) = (eval_poly e p)^`().
Proof.
elim: p=> [|a p ihp] /=; first by rewrite deriv0.
by rewrite eval_AddPoly /= addr0 ihp !derivE.
Qed.

Definition eval_OpPoly :=
  (eval_MulPoly, eval_AmulXn, eval_AddPoly, eval_OppPoly, eval_NatMulPoly,
  eval_ConstPoly, eval_Horner, eval_ExpPoly, eval_Deriv, eval_ScalPoly).

Lemma eval_Changes e s k : qf_eval e (Changes s k)
  = qf_eval e (k (changes (map (eval e) s))).
Proof.
elim: s k=> //= a q ihq k; rewrite ihq eval_If /= -nth0.
by case: q {ihq}=> /= [|b q]; [rewrite /= mulr0 ltrr add0n | case: ltrP].
Qed.

Lemma eval_SeqPInfty e ps k k' :
  (forall xs, qf_eval e (k xs) = k' (map (eval e) xs)) ->
 qf_eval e (SeqPInfty ps k)
  = k' (map lead_coef (map (eval_poly e) ps)).
Proof.
elim: ps k k' => [|p ps ihps] k k' Pk /=; first by rewrite Pk.
rewrite (eval_LeadCoef (fun lp =>
  k' (lp :: [seq lead_coef i |i  <- [seq eval_poly e i | i <- ps]]))) => // lp.
rewrite (ihps _ (fun ps => k' (eval e lp :: ps))) => //= lps.
by rewrite Pk.
Qed.

Implicit Arguments eval_SeqPInfty [e ps k].
Prenex Implicits eval_SeqPInfty.

Lemma eval_SeqMInfty e ps k k' :
  (forall xs, qf_eval e (k xs) = k' (map (eval e) xs)) ->
 qf_eval e (SeqMInfty ps k)
  = k' (map (fun p : {poly F} => (-1) ^+ (~~ odd (size p)) * lead_coef p)
            (map (eval_poly e) ps)).
Proof.
elim: ps k k' => [|p ps ihps] k k' Pk /=; first by rewrite Pk.
rewrite (eval_LeadCoef (fun lp =>
  k' ((-1) ^+ (~~ odd (size (eval_poly e p))) * lp
       ::  [seq (-1) ^+ (~~ odd (size p)) * lead_coef p
            | p : {poly _} <- [seq eval_poly e i | i <- ps]]))) => // lp.
rewrite eval_Size /= (ihps _ (fun ps =>
 k' (((-1) ^+ (~~ odd (size (eval_poly e p))) * eval e lp) :: ps))) => //= lps.
by rewrite Pk.
Qed.

Implicit Arguments eval_SeqMInfty [e ps k].
Prenex Implicits eval_SeqMInfty.

Lemma eval_ChangesPoly e ps k : qf_eval e (ChangesPoly ps k) =
  qf_eval e (k (changes_poly (map (eval_poly e) ps))).
Proof.
rewrite (eval_SeqMInfty (fun mps =>
  qf_eval e (k ((changes mps)%:Z -
     (changes_pinfty  [seq eval_poly e i | i <- ps])%:Z)))) => // mps.
rewrite (eval_SeqPInfty (fun pps =>
  qf_eval e (k ((changes (map (eval e) mps))%:Z - (changes pps)%:Z)))) => // pps.
by rewrite !eval_Changes.
Qed.

Fixpoint redivp_rec_loop (q : {poly F}) sq cq
   (k : nat) (qq r : {poly F})(n : nat) {struct n} :=
    if (size r < sq)%N then (k, qq, r) else
    let m := (lead_coef r) *: 'X^(size r - sq) in
    let qq1 := qq * cq%:P + m in
    let r1 := r * cq%:P - m * q in
    if n is n1.+1 then redivp_rec_loop q sq cq k.+1 qq1 r1 n1 else (k.+1, qq1, r1).

Lemma redivp_rec_loopP q c qq r n : redivp_rec q c qq r n
    = redivp_rec_loop q (size q) (lead_coef q) c qq r n.
Proof. by elim: n c qq r => [| n Pn] c qq r //=; rewrite Pn. Qed.

Lemma eval_Rediv_rec_loop e q sq cq c qq r n k k'
  (d := redivp_rec_loop (eval_poly e q) sq (eval e cq)
    c (eval_poly e qq) (eval_poly e r) n) :
  (forall c qq r, qf_eval e (k (c, qq, r))
    = k' (c, eval_poly e qq, eval_poly e r)) ->
  qf_eval e (Rediv_rec_loop q sq cq c qq r n k) = k' d.
Proof.
move=> Pk; elim: n c qq r k Pk @d=> [|n ihn] c qq r k Pk /=.
  rewrite eval_Size /=; have [//=|gtq] := ltnP.
  rewrite (eval_LeadCoef (fun lr =>
    let m := lr *: 'X^(size (eval_poly e r) - sq) in
    let qq1 := (eval_poly e qq) * (eval e cq)%:P + m in
    let r1 := (eval_poly e r) * (eval e cq)%:P - m * (eval_poly e q) in
      k' (c.+1, qq1, r1))) //.
   by move=> x /=; rewrite Pk /= !eval_OpPoly /= !mul_polyC.
rewrite eval_Size /=; have [//=|gtq] := ltnP.
rewrite (eval_LeadCoef (fun lr =>
  let m := lr *: 'X^(size (eval_poly e r) - sq) in
  let qq1 := (eval_poly e qq) * (eval e cq)%:P + m in
  let r1 := (eval_poly e r) * (eval e cq)%:P - m * (eval_poly e q) in
    k' (redivp_rec_loop (eval_poly e q) sq (eval e cq) c.+1 qq1 r1 n))) //=.
by move=> x; rewrite ihn // !eval_OpPoly /= !mul_polyC.
Qed.

Implicit Arguments eval_Rediv_rec_loop [e q sq cq c qq r n k].
Prenex Implicits eval_Rediv_rec_loop.

Lemma eval_Rediv e p q k k' (d := (redivp (eval_poly e p) (eval_poly e q))) :
  (forall c qq r,  qf_eval e (k (c, qq, r)) = k' (c, eval_poly e qq, eval_poly e r)) ->
  qf_eval e (Rediv p q k) = k' d.
Proof.
move=> Pk; rewrite eval_Isnull /d unlock.
have [_|p_neq0] /= := boolP (_ == _); first by rewrite Pk /= mul0r add0r.
rewrite !eval_Size; set p' := eval_poly e p; set q' := eval_poly e q.
rewrite (eval_LeadCoef (fun lq =>
  k' (redivp_rec_loop q' (size q') lq 0 0 p' (size p')))) /=; last first.
  by move=> x; rewrite (eval_Rediv_rec_loop k') //= mul0r add0r.
by rewrite redivp_rec_loopP.
Qed.

Implicit Arguments eval_Rediv [e p q k].
Prenex Implicits eval_Rediv.

Lemma eval_NextMod e p q k k' :
  (forall p, qf_eval e (k p) = k' (eval_poly e p)) ->
  qf_eval e (NextMod p q k) =
  k' (next_mod (eval_poly e p) (eval_poly e q)).
Proof.
move=> Pk; set p' := eval_poly e p; set q' := eval_poly e q.
rewrite (eval_LeadCoef (fun lq =>
  k' (- lq ^+ rscalp p' q' *: rmodp p' q'))) => // lq.
rewrite (eval_Rediv (fun spq =>
  k' (- eval e lq ^+ spq.1.1%PAIR *: rmodp p' q'))) => //= spq _ _.
rewrite (eval_Rediv (fun mpq =>
  k' (- eval e lq ^+ spq *:  mpq.2%PAIR))) => //= _ _ mpq.
by rewrite Pk !eval_OpPoly.
Qed.

Implicit Arguments eval_NextMod [e p q k].
Prenex Implicits eval_NextMod.

Lemma eval_Rgcd_loop e n p q k k' :
  (forall p, qf_eval e (k p) = k' (eval_poly e p))
  -> qf_eval e (Rgcd_loop n p q k) =
    k' (rgcdp_loop n (eval_poly e p) (eval_poly e q)).
Proof.
elim: n p q k k'=> [|n ihn] p q k k' Pk /=.
  rewrite (eval_Rediv (fun r =>
    if r.2%PAIR == 0 then k' (eval_poly e q) else k' r.2%PAIR)) /=.
    by case: eqP.
  by move=> _ _ r; rewrite eval_Isnull; case: eqP.
pose q' := eval_poly e q.
rewrite (eval_Rediv (fun r =>
  if r.2%PAIR == 0 then k' q' else k' (rgcdp_loop n q' r.2%PAIR))) /=.
  by case: eqP.
move=> _ _ r; rewrite eval_Isnull; case: eqP; first by rewrite Pk.
by rewrite (ihn _ _ _ k').
Qed.

Lemma eval_Rgcd e p q k k' :
  (forall p, qf_eval e (k p) = k' (eval_poly e p)) ->
  qf_eval e (Rgcd p q k) =
  k' (rgcdp (eval_poly e p) (eval_poly e q)).
Proof.
move=> Pk; rewrite /Rgcd /LtSize !eval_Size /rgcdp.
case: ltnP=> _; rewrite !eval_Isnull; case: eqP=> // _;
by rewrite eval_Size; apply: eval_Rgcd_loop.
Qed.

Lemma eval_BigRgcd e ps k k' :
  (forall p, qf_eval e (k p) = k' (eval_poly e p)) ->
  qf_eval e (BigRgcd ps k) =
  k' (\big[@rgcdp _/0%:P]_(i <- ps) (eval_poly e i)).
Proof.
elim: ps k k'=> [|p sp ihsp] k k' Pk /=.
  by rewrite big_nil Pk /= mul0r add0r.
rewrite big_cons (ihsp _ (fun r => k' (rgcdp (eval_poly e p) r))) //.
by move=> r; apply: eval_Rgcd.
Qed.

Implicit Arguments eval_Rgcd [e p q k].
Prenex Implicits eval_Rgcd.

Fixpoint mods_aux (p q : {poly F}) (n : nat) : seq {poly F} :=
    if n is m.+1
      then if p == 0 then [::]
           else p :: (mods_aux q (next_mod p q) m)
      else [::].

Lemma eval_ModsAux e p q n k k' :
  (forall sp, qf_eval e (k sp) = k' (map (eval_poly e) sp)) ->
  qf_eval e (ModsAux p q n k) =
  k' (mods_aux (eval_poly e p) (eval_poly e q) n).
Proof.
elim: n p q k k'=> [|n ihn] p q k k' Pk; first by rewrite /= Pk.
rewrite /= eval_Isnull; have [|ep_neq0] := altP (_ =P _); first by rewrite Pk.
set q' := eval_poly e q; set p' := eval_poly e p.
rewrite (eval_NextMod (fun npq => k' (p' :: mods_aux q' npq n))) => // npq.
by rewrite (ihn _ _ _ (fun ps => k' (p' :: ps))) => // ps; rewrite Pk.
Qed.

Implicit Arguments eval_ModsAux [e p q n k].
Prenex Implicits eval_ModsAux.

Lemma eval_Mods e p q k k' :
  (forall sp, qf_eval e (k sp) = k' (map (eval_poly e) sp)) ->
  qf_eval e (Mods p q k) = k' (mods (eval_poly e p) (eval_poly e q)).
Proof. by move=> Pk; rewrite !eval_Size; apply: eval_ModsAux. Qed.

Implicit Arguments eval_Mods [e p q k].
Prenex Implicits eval_Mods.

Lemma eval_TaqR e p q k :
  qf_eval e (TaqR p q k) =
  qf_eval e (k (taqR (eval_poly e p) (eval_poly e q))).
Proof.
rewrite (eval_Mods (fun r => qf_eval e (k (changes_poly r)))).
  by rewrite !eval_OpPoly.
by move=> sp; rewrite !eval_ChangesPoly.
Qed.

Lemma eval_PolyComb e sq sc :
  eval_poly e (PolyComb sq sc) = poly_comb (map (eval_poly e) sq) sc.
Proof.
rewrite /PolyComb /poly_comb size_map.
rewrite -BigOp.bigopE -val_enum_ord -filter_index_enum !big_map.
apply: (big_ind2 (fun u v => eval_poly e u = v)).
+ by rewrite /= mul0r add0r.
+ by move=> x x' y y'; rewrite eval_MulPoly=> -> ->.
by move=> i _; rewrite eval_ExpPoly /= (nth_map [::]).
Qed.

Definition pcq (sq : seq {poly F}) i :=
  (map (poly_comb sq) (sg_tab (size sq)))`_i.

Lemma eval_Pcq e sq i :
  eval_poly e (Pcq sq i) = pcq (map (eval_poly e) sq) i.
Proof.
rewrite /Pcq /pcq size_map; move: (sg_tab _)=> s.
have [ge_is|lt_is] := leqP (size s) i.
  by rewrite !nth_default ?size_map // /=.
rewrite -(nth_map _ 0) ?size_map //; congr _`_i; rewrite -map_comp.
by apply: eq_map=> x /=; rewrite eval_PolyComb.
Qed.

Lemma eval_TaqsR e p sq i k k' :
  (forall x, qf_eval e (k x) = k' (eval e x)) ->
  qf_eval e (TaqsR p sq i k) =
  k' (taqsR (eval_poly e p) (map (eval_poly e) sq) i).
Proof. by move=> Pk; rewrite /TaqsR /taqsR eval_TaqR Pk /= eval_Pcq. Qed.

Implicit Arguments eval_TaqsR [e p sq i k].
Prenex Implicits eval_TaqsR.

Fact invmx_ctmat1 : invmx (map_mx (intr : int -> F) ctmat1) =
  \matrix_(i, j)
  (nth [::] [:: [::  2%:R^-1; - 2%:R^-1;  0];
                [::  2%:R^-1;   2%:R^-1; -1];
                [::        0;         0;  1]] i)`_j :> 'M[F]_3.
Proof.
rewrite -[lhs in lhs = _]mul1r; apply: (canLR (mulrK _)).
  exact: ctmat1_unit.
symmetry; rewrite /ctmat1.
apply/matrixP => i j; rewrite !(big_ord_recl, big_ord0, mxE) /=.
have halfP (K : numFieldType) : 2%:R^-1 + 2%:R^-1 = 1 :> K.
  by rewrite -mulr2n -[_ *+ 2]mulr_natl mulfV // pnatr_eq0.
move: i; do ?[case => //=]; move: j; do ?[case => //=] => _ _;
rewrite !(mulr1, mul1r, mulrN1, mulN1r, mulr0, mul0r, opprK);
by rewrite !(addr0, add0r, oppr0, subrr, addrA, halfP).
Qed.

Lemma eval_Coefs e n i : eval e (Coefs F n i) = coefs F n i.
Proof.
case: n => [|[|n]] //=; rewrite /coefs /=.
  case: i => [|i]; last first.
    by rewrite nth_default // size_map size_enum_ord expn0.
  rewrite (nth_map 0) ?size_enum_ord //.
  set O := _`_0; rewrite (_ : O = ord0).
    by rewrite ?castmxE ?cast_ord_id map_mx1 invmx1 mxE.
  by apply: val_inj => /=; rewrite nth_enum_ord.
have [lt_i3|le_3i] := ltnP i 3; last first.
  by rewrite !nth_default // size_map size_enum_ord.
rewrite /ctmat /= ?ntensmx1 invmx_ctmat1 /=.
rewrite (nth_map 0) ?size_enum_ord // castmxE /=.
rewrite !mxE !cast_ord_id //= nth_enum_ord //=.
by move: i lt_i3; do 3?case.
Qed.

Lemma eval_CcountWeak e p sq k k' :
  (forall x, qf_eval e (k x) = k' (eval e x)) ->
  qf_eval e (CcountWeak p sq k) =
  k' (ccount_weak (eval_poly e p) (map (eval_poly e) sq)).
Proof.
move=> Pk; rewrite /CcountWeak /ccount_weak.
set Aux := (fix Aux s i k := match i with 0 => _ | _ => _ end).
set aux := (fix aux s i := match i with 0 => _ | _ => _ end).
rewrite size_map -[0]/(eval e 0%qfT); move: 0%qfT=> x.
elim: (_ ^ _)%N k k' Pk x=> /= [|n ihn] k k' Pk x.
  by rewrite Pk.
rewrite (eval_TaqsR
  (fun y => k' (aux (y * (coefs F (size sq) n) + eval e x) n))).
  by rewrite size_map.
by move=> y; rewrite (ihn _ k') // -(eval_Coefs e).
Qed.

Implicit Arguments eval_CcountWeak [e p sq k].
Prenex Implicits eval_CcountWeak.

Lemma eval_ProdPoly e T s f k f' k' :
  (forall x k k', (forall p, (qf_eval e (k p) = k' (eval_poly e p))) ->
  qf_eval e (f x k) = k' (f' x)) ->
  (forall p, qf_eval e (k p) = k' (eval_poly e p)) ->
  qf_eval e (@ProdPoly _ T s f k) = k' (\prod_(x <- s) f' x).
Proof.
move=> Pf; elim: s k k'=> [|a s ihs] k k' Pk /=.
  by rewrite big_nil Pk /= !(mul0r, add0r).
rewrite (Pf _ _ (fun fa => k' (fa * \prod_(x <- s) f' x))).
  by rewrite big_cons.
move=> fa; rewrite (ihs _ (fun fs => k' (eval_poly e fa * fs))) //.
by move=> fs; rewrite Pk eval_OpPoly.
Qed.

Implicit Arguments eval_ProdPoly [e T s f k].
Prenex Implicits eval_ProdPoly.

Lemma eval_BoundingPoly e sq :
  eval_poly e (BoundingPoly sq) = bounding_poly (map (eval_poly e) sq).
Proof.
rewrite eval_Deriv -BigOp.bigopE; congr _^`(); rewrite big_map.
by apply: big_morph => [p q | ]/=; rewrite ?eval_MulPoly // mul0r add0r.
Qed.

Lemma eval_CcountGt0 e sp sq : qf_eval e (CcountGt0 sp sq) =
  ccount_gt0 (map (eval_poly e) sp) (map (eval_poly e) sq).
Proof.
pose sq' := map (eval_poly e) sq; rewrite /ccount_gt0.
rewrite (@eval_BigRgcd _ _ _ (fun p => if p != 0
  then 0 < ccount_weak p sq'
  else let bq := bounding_poly sq' in
    [|| \big[andb/true]_(q <- sq') (0 < lead_coef q),
     \big[andb/true]_(q <- sq') (0 < (-1) ^+ (size q).-1 * lead_coef q)
    | 0 < ccount_weak bq sq'])).
  by rewrite !big_map.
move=> p; rewrite eval_Isnull; case: eqP=> _ /=; last first.
  by rewrite (eval_CcountWeak (> 0)).
rewrite (eval_CcountWeak (fun n =>
   [|| \big[andb/true]_(q <- sq') (0 < lead_coef q),
    \big[andb/true]_(q <- sq') (0 < (-1) ^+ (size q).-1 * lead_coef q)
   | 0 < n ])).
  by rewrite eval_BoundingPoly.
move=> n /=; rewrite -!BigOp.bigopE !big_map; congr [|| _, _| _].
  apply: (big_ind2 (fun u v => qf_eval e u = v))=> //=.
    by move=> u v u' v' -> ->.
  by move=> i _; rewrite (eval_LeadCoef (> 0)).
apply: (big_ind2 (fun u v => qf_eval e u = v))=> //=.
  by move=> u v u' v' -> ->.
by move=> i _; rewrite eval_Size (eval_LeadCoef (fun lq =>
  (0 < (-1) ^+ (size (eval_poly e i)).-1 * lq))).
Qed.

Lemma abstrXP e i t x :
  (eval_poly e (abstrX i t)).[x] = eval (set_nth 0 e i x) t.
Proof.
elim: t.
- move=> n /=; case ni: (_ == _);
    rewrite //= ?(mul0r,add0r,addr0,polyC1,mul1r,hornerX,hornerC);
    by rewrite // nth_set_nth /= ni.
- by move=> r; rewrite /= mul0r add0r hornerC.
- by move=> r; rewrite /= mul0r add0r hornerC.
- by move=> t tP s sP; rewrite /= eval_AddPoly hornerD tP ?sP.
- by move=> t tP; rewrite /= eval_OppPoly hornerN tP.
- by move=> t tP n; rewrite /= eval_NatMulPoly hornerMn tP.
- by move=> t tP s sP; rewrite /= eval_MulPoly hornerM tP ?sP.
- by move=> t tP n; rewrite /= eval_ExpPoly horner_exp tP.
Qed.

Lemma wf_QE_wproj i bc (bc_i := @wproj F i bc) :
  dnf_rterm (w_to_oclause bc) -> qf_form bc_i && rformula bc_i.
Proof.
case: bc @bc_i=> sp sq /=; rewrite /dnf_rterm /= /wproj andbT=> /andP[rsp rsq].
by rewrite qf_formF rformulaF.
Qed.

Lemma valid_QE_wproj i bc (bc' := w_to_oclause bc)
    (ex_i_bc := ('exists 'X_i, odnf_to_oform [:: bc'])%oT) e :
  dnf_rterm bc' -> reflect (holds e ex_i_bc) (ord.qf_eval e (wproj i bc)).
Proof.
case: bc @bc' @ex_i_bc=> sp sq /=; rewrite /dnf_rterm /wproj /= andbT.
move=> /andP[rsp rsq]; rewrite -qf_evalE.
rewrite eval_CcountGt0 /=; apply: (equivP (ccount_gt0P _ _)).
set P1 := (fun x => _); set P2 := (fun x => _).
suff: forall x, P1 x <-> P2 x.
  by move=> hP; split=> [] [x Px]; exists x; rewrite (hP, =^~ hP).
move=> x; rewrite /P1 /P2 {P1 P2} !big_map !(big_seq_cond xpredT) /=.
rewrite (eq_bigr (fun t => GRing.eval (set_nth 0 e i x) t == 0)); last first.
  by move=> t /andP[t_in_sp _]; rewrite abstrXP evalE to_rtermE ?(allP rsp).
rewrite [X in _ && X](eq_bigr (fun t => 0 < GRing.eval (set_nth 0 e i x) t));
  last by move=> t /andP[tsq _]; rewrite abstrXP evalE to_rtermE ?(allP rsq).
rewrite -!big_seq_cond !(rwP (qf_evalP _ _)); first last.
+ elim: sp rsp => //= p sp ihsp /andP[rp rsp]; first by rewrite ihsp.
+ elim: sq rsq => //= q sq ihsq /andP[rq rsq]; first by rewrite ihsq.
rewrite !(rwP andP) (rwP orP) orbF !andbT /=.
have unfoldr P s : foldr (fun t => ord.And (P t)) ord.True s =
  \big[ord.And/ord.True]_(t <- s) P t by rewrite unlock /reducebig.
rewrite !unfoldr; set e' := set_nth _ _ _ _.
by rewrite !(@big_morph _ _ (ord.qf_eval _) true andb).
Qed.

Lemma rcf_satP e f : reflect (holds e f) (rcf_sat e f).
Proof. exact: (proj_satP wf_QE_wproj valid_QE_wproj). Qed.

End ProjCorrect.

(* Section Example. *)
(* no chances it computes *)

(* Require Import rat. *)

(* Eval vm_compute in (54%:R / 289%:R + 2%:R^-1 :rat). *)

(* Local Open Scope qf_scope. *)

(* Notation polyF := (polyF [realFieldType of rat]). *)
(* Definition p : polyF := [::'X_2; 'X_1; 'X_0]. *)
(* Definition q : polyF := [:: 0; 1]. *)
(* Definition sq := [::q]. *)

(* Eval vm_compute in MulPoly p q. *)

(* Eval vm_compute in Rediv ([:: 1] : polyF) [::1]. *)

(* Definition fpq := Eval vm_compute in (CcountWeak p [::q]). *)

(* End Example. *)


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq bigop fingroup ssralg
               ssrnum ssrint.
Import GRing.Theory Num.Theory.

Definition bval (b : bool) : int := (if b then 2 else - 1)%R.
Definition height (s : seq bool) : int := (\sum_(b <- s) bval b)%R.
Definition Lb (x : int) (s : seq bool) : bool := (x + height s == 0)%R.

Inductive Lp : seq bool -> Prop :=
  | Lp_empty : Lp [::]
  | Lp_app : forall s1 s2, Lp s1 -> Lp s2 -> Lp (s1 ++ s2)
  | Lp_rule1 : forall s, Lp s -> Lp (true :: s ++ [:: false; false])
  | Lp_rule2 : forall s, Lp s -> Lp (false :: false :: s ++ [:: true])
  | Lp_rule3 : forall s1 s2, Lp s1 -> Lp s2 ->
               Lp (false :: s1 ++ true :: s2 ++ [:: false]).

Lemma take_minn A n m (xs : seq A) : take n (take m xs) = take (minn n m) xs.
Proof. by elim: n m xs => [| n IH] [| m] [] // x xs; rewrite minnSS /= IH. Qed.

Theorem well_founded_lt : well_founded (fun n m => n < m).
Proof.
  move => x.
  move: {2}x (leqnn x) => n.
  elim: n x => [| n IHn] x H; constructor => y H0.
  - apply False_ind, notF; rewrite -(ltn0 y); apply (leq_trans H0 H).
  - apply IHn; rewrite -ltnS; apply (leq_trans H0 H).
Defined.

Fixpoint splitL (x : int) (s : seq bool) : seq bool * seq bool :=
  match s with
    | [::] => ([::], [::])
    | b :: s' =>
      let x' := (x + bval b)%R in
      if x' == 0%R
        then ([:: b], s')
        else let s'' := splitL x' s' in (b :: s''.1, s''.2)
  end.

Definition splitted (x : int) (s : seq bool) :=
  forall n, n < size s -> ~~ Lb x (take n s).

Lemma height0 : height [::] = 0%R.
Proof. by rewrite /height big_nil. Qed.

Lemma heightc b s : height (b :: s) = (bval b + height s)%R.
Proof. by rewrite /height big_cons. Qed.

Lemma heightcat s1 s2 : height (s1 ++ s2) = (height s1 + height s2)%R.
Proof. by rewrite /height big_cat. Qed.

Lemma Lb0 x : Lb x [::] = (0%R == x).
Proof. by rewrite /Lb height0 addr0. Qed.

Lemma Lbc x b s : Lb x (b :: s) = Lb (x + bval b) s.
Proof. by rewrite /Lb heightc addrA. Qed.

Lemma LbcatC x s1 s2 : Lb x (s1 ++ s2) = Lb x (s2 ++ s1).
Proof.  by rewrite /Lb !heightcat /= (addrC (height _)). Qed.

Lemma splitL_cat x s : s = (let s' := splitL x s in s'.1 ++ s'.2).
Proof. by elim: s x => //= b s H x; case: ifP => //= _; rewrite -H. Qed.

Lemma splitL_split x s : Lb x s ->
  let s' := splitL x s in Lb x s'.1 && Lb 0%R s'.2.
Proof.
  elim: s x => //=.
  - by move => x -> /=; rewrite Lb0.
  - move => b s IH x; case: ifP => /=.
    + by move/eqP => H; rewrite !Lbc Lb0 H => ->.
    + by rewrite !Lbc => _ H; apply IH.
Qed.

Lemma splitL_splitted (x : int) s : x != 0%R -> splitted x (splitL x s).1.
Proof.
  elim: s x => //= b s IH x H; case: ifP => /= H0.
  - by case => //; rewrite take0 Lb0 eq_sym.
  - case => /=.
    + by rewrite Lb0 eq_sym.
    + move => n; rewrite ltnS Lbc => H1.
      by apply (IH (x + bval b)%R) => //; rewrite H0.
Qed.

Lemma splitted_pn (x : int) s b :
  (0 < x)%R -> splitted x (rcons s b) ->
  forall n, n <= size s -> (0 < x + height (take n s))%R.
Proof.
  elim: s x => /=; first by move => x; rewrite height0 addr0.
  move => b' s IH x H H0 [_ | n] /=.
  - by rewrite height0 addr0.
  - rewrite ltnS heightc addrA; apply IH.
    + case: b' H0 => /=.
      * move => _; apply ltr_le_trans with x => //; apply ler_addl.
      * by move/(_ 1); rewrite /= size_rcons take0 Lbc Lb0 /=;
          move/(_ erefl) => H0; rewrite ltr_def eq_sym H0 /= subr_ge0 -gtz0_ge1.
    + by move => {n} n; move: (H0 n.+1) => /=; rewrite ltnS Lbc.
Qed.

Lemma splitted_last (x : int) s b :
  (0 < x)%R -> splitted x (rcons s b) -> (x + height (rcons s b) <= 2)%R ->
  b = false.
Proof.
  move => H H0 H1; move: {H H0} H1 (splitted_pn x s b H H0 (size s) (leqnn _)).
  rewrite take_size -cats1 heightcat heightc height0 addr0 addrA.
  case: b => //=; rewrite -{2}(add0r (2 : int)) ler_add2r => H H0.
  by move: (ltr_le_trans H0 H).
Qed.

Lemma splitted_catl x s1 s2 : splitted x (s1 ++ s2) -> splitted x s1.
Proof.
  by move => H n H0; move: (H n); rewrite size_cat;
    move/(_ (ltn_addr _ H0)); rewrite take_cat H0.
Qed.

Theorem LpLbP s : reflect (Lp s) (Lb 0%R s).
Proof.
  apply: (iffP idP).
  - move: {1}(size _) (erefl (size s)) => n; move: n s.
    refine (well_founded_ind well_founded_lt _ _);
      case => [| n] IH [] //; first constructor; move => b s H.
    move/splitL_split; move: H.
    rewrite {1 3}(splitL_cat 0 (b :: s)) /= size_cat;
      case: ifP => /=; first by case b.
    rewrite add0r addSn => _ [] H /andP [H0 H1]; apply (Lp_app (_ :: _));
      last by apply (IH (size (splitL (bval b) s).2)) => //;
              rewrite H ltnS leq_addl.
    have {n IH H H1} IH s' :
      size s' <= size (splitL (bval b) s).1 -> Lb 0 s' -> Lp s'
      by move => H2; apply (IH (size s')) => //;
        rewrite H -addSn; apply ltn_addr; rewrite ltnS.
    have/(splitL_splitted (bval b) s) : (bval b != 0) by case b.
    move: IH H0; rewrite Lbc add0r; case/lastP: {s} (fst _);
      first by rewrite Lb0; case: b.
    move: b => b' s b; (case: b'; last case: b) => /=.
    + rewrite size_rcons => IH H H0.
      move: (splitted_last 2 s b erefl H0); move: (H);
        rewrite /Lb => /eqP -> /(_ erefl) H1; subst b.
      move: H H0; rewrite -cats1 LbcatC Lbc /= => H /splitted_catl.
      case/lastP: s IH H; first by move => _; rewrite Lb0 //.
      move => s b; rewrite size_rcons => IH H H0.
      move: (splitted_last 2 s b erefl H0); move: (H);
        rewrite /Lb eq_sym addrC -subr_eq eq_sym =>
        /eqP -> /(_ erefl) H1; subst b;
      move: H H0; rewrite -cats1 LbcatC Lbc -catA /= => H H0.
      constructor; apply IH => //; apply (leq_addl 2).
    + case: s => /=; first by rewrite Lbc Lb0.
      case; last by move => l IH; rewrite Lbc -cats1 LbcatC Lbc /= => H _;
        constructor; apply IH => //; rewrite size_rcons; apply (leq_addl 2).
      move => s _;
        rewrite Lbc /Lb /= eq_sym addrC -subr_eq eq_sym sub0r => /eqP H H0.
      have {H0} H0: splitted 1 (rcons s true)
        by move => n H1; move: (H0 n.+1) => /=; rewrite ltnS Lbc /=; move/(_ H1).
      by move: (splitted_last 1 s true erefl H0); rewrite H; move/(_ erefl).
    + rewrite -cats1 LbcatC Lbc /= => H H0 /splitted_catl.
      case/(splitL_split (- (2 : int)))/andP: H0 => /=; move: H.
      rewrite {1 4 5}(splitL_cat (- (2 : int)) s) !size_cat /= addn1.
      move: (splitL_splitted (- (2 : int))%R s erefl).
      case/lastP: {s} (fst _) (snd _) => /=; first by rewrite Lb0.
      move => s1 [] s2.
      * rewrite -cats1 LbcatC Lbc /= -!catA => _ IH H H0 _; constructor;
          apply IH => //; rewrite size_cat /= addn1.
        - rewrite addSnnS -addnS; apply leq_addr.
        - rewrite -addSn; apply leq_addl.
      * rewrite -cats1 -catA; move => /splitted_catl H _ H0 _ /splitted_catl H1;
          apply False_ind; move: {s2} H0 H H1; rewrite LbcatC Lbc /=.
        have: (- (2 : int) - 1 < - (2 : int))%R by [].
        elim/last_ind: s1 (- _ - _)%R;
          first by move => x H; rewrite Lb0 => /eqP H1; rewrite -H1 in H.
        move => /= s b IH x H; rewrite -cats1 LbcatC Lbc /= => H0 H1 H2.
        move: (splitted_catl _ _ _ H1) (splitted_catl _ _ _ H2);
          apply (IH (x + bval b)%R) => //.
        move: {H1 H2} (H1 (size s)) (H2 (size s));
          rewrite size_cat /= addn1 leqnn take_cat ltnn subnn take0 cats0 =>
          /(_ erefl) H1 /(_ erefl) H2.
        case: b H0 => //=;
          last by move => _; apply ler_lt_trans with x => //;
                  rewrite -{2}(subr0 x); apply ler_add.
        move => H3; move: H3 H1 H2; rewrite /Lb !addr_eq0 => /eqP <-.
        by rewrite ltr_def => -> /=; rewrite -ltz_add1r ltr_def => -> /=;
          rewrite -ler_subr_addr -ltz_add1r.
  - rewrite /Lb add0r; move: s.
    refine (Lp_ind _ _ _ _ _ _) => //= [| s1 s2 | s | s | s1 s2];
      rewrite !(height0, heightc, heightcat); do 3 move => // _ /eqP ->.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import Cat.Cat.
Require Import NatTrans.NatTrans.

Local Open Scope nattrans_scope.

(** The opposite of a natural transformation N : F -> F' is a nattrans
    N^op : F'^op -> F^op. It has the same arrow family as the original
    natural transformation. *)
Section Opposite_NatTrans.
  Context {C D : Category} {F F' : (C –≻ D)%functor} (N : (F –≻ F')%nattrans).

  Program Definition Opposite_NatTrans : F'^op –≻ F^op :=
    {|
      Trans := Trans N;
      Trans_com := fun c c' h => (Trans_com_sym N h);
      Trans_com_sym := fun c c' h => (Trans_com N h)
    |}.

End Opposite_NatTrans.

Notation "N '^op'" := (Opposite_NatTrans N) : nattrans_scope.

(** Composition of opposite natural transformations is just the same as the
    opposite natural transformation of the composition. *)
Section Compose_NOP.
  Context {C D : Category} {F F' F'' : (C –≻ D)%functor}
          (N : F –≻ F') (N' : F' –≻ F'').

  Theorem NatTrans_compose_Op : ((N' ∘ N)^op = N^op ∘ (N'^op))%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    trivial.
  Qed.

End Compose_NOP.

(** Opposite of NatTrans_id is just NatTrans_id of the opposite functor *)
Section NatTrans_id_Op.
  Context {C D : Category} (F : (C –≻ D)%functor).

  Theorem NatTrans_id_Op
    : ((NatTrans_id F)^op)%nattrans = NatTrans_id (F^op)%functor.
  Proof.
    apply NatTrans_eq_simplify.
    trivial.
  Qed.

End NatTrans_id_Op.

(** Horizontal composition of natural transformations:

Let C, D and E be categories, F: C -> D G : C -> D, F' : D -> E and
G' : D -> E be functors and N : F -> G and N' : F' -> G' be natural
transformations. Then, the horizontal composition of N and N',
denoted by N ∘_h N' : F' ∘ F -> G' ∘ G is defined as follows:
 *)
Program Definition NatTrans_hor_comp {C D E : Category} {F G : (C –≻ D)%functor}
        {F' G' : (D –≻ E)%functor} (tr : F –≻ G) (tr' : F' –≻ G')
  : (F' ∘ F) –≻ (G' ∘ G) :=
{|
  Trans := fun c : Obj => ((G' _a (Trans tr c)) ∘ (Trans tr' (F _o c)))%morphism
|}.

Next Obligation. (* Trans_com*)
Proof.
  rewrite assoc.
  rewrite Trans_com.
  rewrite assoc_sym.
  rewrite <- F_compose.
  rewrite Trans_com.
  rewrite F_compose.
  auto.
Qed.

Next Obligation. (* Trans_com*)
Proof.
  symmetry.
  apply NatTrans_hor_comp_obligation_1.
Qed.

(**
Graphically:
#

    C      C             C              C
    |  N   |             |              |
  F | ===> | G           |              |
    |      |             |              |
    ∨      ∨             |   N' ∘_h N   |
    D      D        F'∘F | ===========> |G'∘G
    |  N'  |             |              |
 F' | ===> | G'          |              |
    |      |             |              |
    ∨      ∨             ∨              ∨
    E      E             E              E

#
*)

Notation "N ∘_h N'" := (NatTrans_hor_comp N' N) : nattrans_scope.

(** Horizontal composition of NatTrans_ids is just the NatTrans_id of
    the composition of underlying functors. *)
Section Hor_Compose_ids.
  Context {C D E : Category} (F : (C –≻ D)%functor) (G : (D –≻ E)%functor).

  Theorem NatTrans_hor_comp_ids
    : ((NatTrans_id G) ∘_h (NatTrans_id F))%nattrans = NatTrans_id  (G ∘ F).
  Proof.
    apply NatTrans_eq_simplify.
    cbn.
    extensionality c.
    rewrite F_id; simpl_ids; trivial.
  Qed.

End Hor_Compose_ids.

(** Horizontal composition of opposite of two natural transformations is just
    the opposite of the horizontal composition of those two natural
    transformations. *)
Section Hor_Compose_NOP.
  Context {C D E : Category} {F G : (C –≻ D)%functor} {F' G' : (D –≻ E)%functor}
          (N : F –≻ G) (N' : F' –≻ G').

  Theorem NatTrans_hor_comp_Op : ((N' ∘_h N)^op = N'^op ∘_h N^op)%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    cbn.
    extensionality c.
    rewrite Trans_com.
    trivial.
  Qed.

End Hor_Compose_NOP.

Section NatTransCompID.
  Context {C D : Category} (F : (C –≻ D)%functor).

  (** Natural transformation from a functor to itself composed with id on
      the right. *)
  Program Definition NatTrans_to_compose_id : F –≻ ((Functor_id D) ∘ F) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation to a functor from itself composed with id on
      the right. *)
  Program Definition NatTrans_from_compose_id : ((Functor_id _) ∘ F) –≻ F :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation from a functor to itself composed with id on
      the left. *)
  Program Definition NatTrans_to_id_compose : F –≻ (F ∘ (Functor_id _)) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation to a functor from itself composed with id on
      the left. *)
  Program Definition NatTrans_from_id_compose : (F ∘ (Functor_id _)) –≻ F :=
    {|
      Trans := fun c => id
    |}.

End NatTransCompID.

Section NatTransAssoc.
  Context {C1 C2 C3 C4 : Category}
          (F : (C1 –≻ C2)%functor)
          (G : (C2 –≻ C3)%functor)
          (H : (C3 –≻ C4)%functor)
  .

  (** Natural transformation corresponding to associativity of
      functor composition *)
  Program Definition NatTrans_Functor_assoc
    : ((H ∘ G) ∘ F) –≻ (H ∘ (G ∘ F)) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation corresponding to the symmetric form of
      associativity of functor composition *)
  Program Definition NatTrans_Functor_assoc_sym
    : (H ∘ (G ∘ F)) –≻ ((H ∘ G) ∘ F) :=
    {|
      Trans := fun c => id
    |}.

End NatTransAssoc.

(**
The following theorem states that the two natural transformations of
the diagram in the middle are equal.
#

    F                       G ∘ F                      G
 C —————––>D   D —————————–—————————————————–—–—–> E   D —–————–> E
     ||           ||                           ||          ||
     ||N1         ||                           ||          ||N2
     ||           ||                           ||          ||
     \/           ||                           ||          \/
     F'           ||                           ||          G'
 C ————–—–>D      ||(N4 ∘ N2) ∘_h (N3 ∘ N1)    ||      D ———–——–> E
     ||           ||                           ||          ||
     || N3        ||                           ||          ||N4
     ||           ||  (N4 ∘_h N3) ∘ (N2 ∘_h N1)||          ||
     \/           ||                           ||          \/
     F''          \/                           \/          G''
 C ————–—–> D  D ——–—————————————————————————–——–> E   D————–——–> E
                            G'' ∘ F''

#
*)
Section NatTrans_comp_hor_comp.
  Context {C D E  : Category}
          {F F' F'' : (C –≻ D)%functor}
          {G G' G'' : (D –≻ E)%functor}
          (N1 : F –≻ F')
          (N2 : G –≻ G')
          (N3 : F' –≻ F'')
          (N4 : G' –≻ G'')
  .

  Theorem NatTrans_comp_hor_comp
    : ((N4 ∘_h N3) ∘ (N2 ∘_h N1) = (N4 ∘ N2) ∘_h (N3 ∘ N1))%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality c.
    cbn.
    rewrite F_compose.
    repeat rewrite assoc.
    match goal with
      [|- (?A ∘ ?B = ?A ∘ ?C)%morphism] =>
      let H := fresh in
      cut (B = C); [intros H; rewrite H; trivial|]
    end.
    repeat rewrite assoc_sym.
    match goal with
      [|- (?A ∘ ?B = ?C ∘ ?B)%morphism] =>
      let H := fresh in
      cut (A = C); [intros H; rewrite H; trivial|]
    end.
    apply Trans_com.
  Qed.

End NatTrans_comp_hor_comp.

(**
Given I : C ≃ D for categories C and D and F : D -> E, there is a natural
transformation from F ∘ (I ∘ I⁻¹) to F and back.
*)
Section IsoCat_NatTrans.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%isomorphism)
          {E : Category} (F : (D –≻ E)%functor).

  Local Obligation Tactic := idtac.

  Program Definition IsoCat_NatTrans :
    (F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism)) –≻ F
    :=
      {|
        Trans :=
          fun c =>
            match eq_sym (f_equal (fun x => (x _o)%object c) (right_inverse I))
                  in _ = y return ((F _o y) –≻ (F _o c))%object%morphism
            with
              eq_refl => id
            end
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    match goal with
      [|- (match ?e with _ => _ end ∘ ?A)%morphism
         = (?B ∘ match ?e' with _ => _ end)%morphism] =>
      generalize e; generalize e';
      set (U := A); set (V := B)
    end.
    intros H H'.
    cut (JMeq U V); [intros HUV|].
    {
      apply JMeq_eq.
      destruct H.
      set (z' := ((iso_morphism I)
                    _o ((inverse_morphism I) _o c'))%object) in *.
      clearbody U.
      clearbody z'.
      destruct H'.
      auto.
    }
    {
      unfold U, V; clear.
      match goal with
        [|- JMeq (F @_a ?A ?B ?C)%morphism (F _a ?D)%morphism] =>
        set (V := C);
        set (M := A) in *;
        set (N := B) in *;
        set (U := D)
      end.
      cut (M = c); [intros Hc|].
      {
        cut (N = c'); [intros Hc'|].
        {
          cut (JMeq V U); [intros HVU|].
          {
            clearbody U V M N.
            destruct Hc.
            destruct Hc'.
            apply JMeq_eq in HVU.
            destruct HVU.
            trivial.
          }
          {
            unfold U, V, M, N; clear.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
            change ((iso_morphism I) _a (I⁻¹ _a h))%morphism
            with (((iso_morphism I) ∘ I⁻¹) _a h)%morphism.
            cbn_rewrite (right_inverse I).
            trivial.
          }
        }
        {
          unfold N; clear.
          change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
          with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
          cbn_rewrite (right_inverse I); trivial.
        }
      }
      {
        unfold M; clear.
        change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
        with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
        cbn_rewrite (right_inverse I); trivial.
      }
    }
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply IsoCat_NatTrans_obligation_1.
  Qed.

  Program Definition IsoCat_NatTrans_back :
    F –≻ (F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism))
    :=
      {|
        Trans :=
          fun c =>
            match eq_sym (f_equal (fun x => (x _o)%object c) (right_inverse I))
                  in _ = y return ((F _o c) –≻ (F _o y))%object%morphism
            with
              eq_refl => id
            end
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    match goal with
      [|- (match ?e with _ => _ end ∘ ?A)%morphism
         = (?B ∘ match ?e' with _ => _ end)%morphism] =>
      generalize e; generalize e';
      set (U := A); set (V := B)
    end.
    intros H H'.
    cut (JMeq U V); [intros HUV|].
    {
      apply JMeq_eq.
      destruct H'.
      set (z := ((iso_morphism I) _o ((inverse_morphism I) _o c))%object) in *.
      clearbody V.
      clearbody z.
      destruct H.
      auto.
    }
    {
      unfold U, V; clear.
      match goal with
        [|- JMeq (F _a ?D)%morphism (F @_a ?A ?B ?C)%morphism] =>
        set (V := C);
        set (M := A) in *;
        set (N := B) in *;
        set (U := D)
      end.
      cut (M = c); [intros Hc|].
      {
        cut (N = c'); [intros Hc'|].
        {
          cut (JMeq U V); [intros HUV|].
          {
            clearbody U V M N.
            destruct Hc.
            destruct Hc'.
            apply JMeq_eq in HUV.
            destruct HUV.
            trivial.
          }
          {
            unfold U, V, M, N; clear.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
            change ((iso_morphism I) _a (I⁻¹ _a h))%morphism
            with (((iso_morphism I) ∘ I⁻¹) _a h)%morphism.
            cbn_rewrite (right_inverse I).
            trivial.
          }
        }
        {
          unfold N; clear.
          change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
          with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
          cbn_rewrite (right_inverse I); trivial.
        }
      }
      {
        unfold M; clear.
        change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
        with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
        cbn_rewrite (right_inverse I); trivial.
      }
    }
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply IsoCat_NatTrans_back_obligation_1.
  Qed.

End IsoCat_NatTrans.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Category.Composable_Chain.
From Categories Require Import Functor.Functor.

(** The image of a functor is not simply the image of its object and arrow maps as
those may not form a category. Consider the following example.

  category C:
#

             f
       x1 ——————–> y1

       x2 ——————–> y2
             g

#
   category D:
#

             h1        h2
       x ——————–> y ————————> z

       u ——————–> v
            m

#
    functor F where:
#

       F _o x1 = x
       F _o y1 = y
       F _o x2 = y
       F _o y2 = z

       F _a f = h1
       F _a g = h2

#

Here we have not drawn identity arrows and compositions of arrows in categories and
their mappings by the functor as these are trivial details.

In this case, the simple image of arrow map of F has only h1 and h2 but not their
composition and is hence not a category.

We define the image of a functor to be a sum category of the codomain category with
objects the image of object map of the functor and as morphisms image of the arrow
map of the functor closed under composition. That is, each morphism in the image
category is a morphism that corresponds to a composable chain of morohisms in the
image of the arrow map of the functor.

*)
Section Functor_Image.
  Context {C D : Category}
          (F : (C –≻ D)%functor).

  Local Open Scope morphism_scope.

  Program Definition Functor_Image :=
    SubCategory D
                (fun a => ∃ x, (F _o x)%object = a)
                (
                  fun a b f =>
                    ∃ (ch : Composable_Chain D a b),
                      (Compose_of ch) = f
                      ∧
                      Forall_Links ch (
                                     fun x y g =>
                                     ∃ (c d : Obj) (h : c –≻ d)
                                       (Fca : (F _o c)%object = x)
                                       (Fdb : (F _o d)%object = y),
                                       match Fca in (_ = Z) return Z –≻ _ with
                                         eq_refl =>
                                         match Fdb in (_ = Y) return _ –≻ Y with
                                           eq_refl => (F _a h)%morphism
                                         end
                                       end = g)
                )
                _ _.

  Ltac destr_exists :=
    progress
    (repeat
       match goal with
         [H : ∃ x, _ |- _] =>
         let x := fresh "x" in
         let Hx := fresh "H" x in
         destruct H as [x Hx]
       end).

  Next Obligation. (* Hom_Cri_id *)
  Proof.
    destr_exists.
    ElimEq.
    exists (Single (F _a id)); simpl; split; auto.
    do 3 eexists; do 2 exists eq_refl; reflexivity.
  Qed.

  Next Obligation. (* Hom_Cri_compose *)
  Proof.
    destr_exists.
    intuition.
    ElimEq.
    match goal with
        [ch1 : Composable_Chain _ ?a ?b, ch2 : Composable_Chain _ ?b ?c|- _] =>
        exists (Chain_Compose ch1 ch2); split
    end.
    rewrite <- Compose_of_Chain_Compose; trivial.
    apply Forall_Links_Chain_Compose; auto.
  Qed.

End Functor_Image.


Require Export GeoCoq.Elements.OriginalProofs.lemma_inequalitysymmetric.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

Lemma lemma_NCdistinct :
   forall A B C,
   nCol A B C ->
   neq A B /\ neq B C /\ neq A C /\ neq B A /\ neq C B /\ neq C A.
Proof.
intros.
assert (~ eq A B).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (~ eq A C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq C A) by (conclude lemma_inequalitysymmetric).
assert (~ eq B C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq C B) by (conclude lemma_inequalitysymmetric).
close.
Qed.

End Euclid.


(** * Probas.v: The monad for distributions *)

Require Export Uprop.
Require Export Monads.
Require Arith.
Set Implicit Arguments.
Module Proba (Univ:Universe).
Module MP := (Monad Univ).
(* begin hide *)
Import Univ.
Import MP.
Import MP.UP.
(* end hide *)
(** ** Definition of distribution
Distributions are measure functions such that
    - $\mu (1-f) \leq 1-\mu(f)$
    - $f \leq 1 -g \Ra \mu(f+g)=\mu(f)+\mu(g)$
    - $\mu(k\times f) = k \times \mu(f)$
    - $f\leq g \Ra \mu(f)\leq\mu(g)$
*)
Record distr (A:Type) : Type :=
  {mu : M A;
   mu_stable_inv : stable_inv mu;
   mu_stable_plus : stable_plus mu;
   mu_stable_mult : stable_mult mu;
   mu_monotonic : monotonic mu}.

Hint Resolve mu_stable_plus mu_stable_inv mu_stable_mult mu_monotonic.

(** ** Properties of measures *)
Lemma mu_stable_eq : forall (A : Type)(m: distr A), stable_eq (mu m).
intros; apply monotonic_stable_eq; auto.
Qed.
Hint Resolve mu_stable_eq.
Implicit Arguments mu_stable_eq [A].

Lemma mu_zero : forall (A : Type)(m: distr A), mu m (f_zero A) == 0.
intros.
apply Ueq_trans with (mu m (fmult 0 (f_zero A))); auto.
apply mu_stable_eq; unfold fmult; auto.
apply Ueq_trans with (0 * (mu m (f_zero A))); auto.
apply mu_stable_mult; auto.
Qed.
Hint Resolve mu_zero.

Lemma mu_one_inv : forall (A : Type)(m:distr A),
   mu m (f_one A) == 1 -> forall f, mu m (finv f) == [1-] (mu m f).
intros; apply Ule_antisym.
apply (mu_stable_inv m f).
apply Uplus_le_simpl_left with (mu m f); auto.
setoid_rewrite (Uinv_opp_right (mu m f)).
apply Ule_trans with (mu m (fun x => (f x) + [1-] (f x))).
setoid_rewrite <- H; apply (mu_monotonic m); auto.
assert (H1 : fplusok f (finv f)).
repeat red; unfold finv; auto.
setoid_rewrite <- (mu_stable_plus m H1); auto.
Qed.
Hint Resolve mu_one_inv.

Lemma mu_le_minus : forall (A : Type)(m:distr A) (f g:A -> U),
     mu m (fminus f g) <= mu m f.
intros; apply mu_monotonic; repeat red; unfold fminus; auto.
Qed.
Hint Resolve mu_le_minus.

Lemma mu_le_plus : forall (A : Type)(m:distr A) (f g:A -> U),
     mu m (fplus f g) <= mu m f + mu m g.
intros; apply Ule_trans with (mu m (fplus (fminus f (fesp f g)) g)).
apply mu_monotonic.
unfold fle,fplus,fminus,fesp; intros; auto.
rewrite (mu_stable_plus m (f:=fminus f (fesp f g)) (g:=g)).
Usimpl; auto.
repeat red; unfold fminus,fesp,finv; auto.
Qed.
Hint Resolve mu_le_plus.

Lemma mu_cte : forall (A : Type)(m:(distr A)) (c:U),
   mu m (f_cte A c) == c * mu m (f_one A).
intros.
apply Ueq_trans with (mu m (fun x => c * 1)).
apply (mu_stable_eq m); auto.
unfold f_one; setoid_rewrite <- (mu_stable_mult m c (fun x => 1)); auto.
Qed.
Hint Resolve mu_cte.

Lemma mu_cte_le :   forall (A : Type)(m:(distr A)) (c:U),
   mu m (f_cte A c) <= c.
intros; apply Ule_trans with (c * mu m (f_one A)); auto.
Qed.

Lemma mu_cte_eq : forall (A : Type)(m:(distr A)) (c:U),
   mu m (f_one A) == 1 -> mu m (f_cte A c) == c.
intros; apply Ueq_trans with (c * mu m (f_one A)); auto.
setoid_rewrite H; auto.
Qed.

Hint Resolve mu_cte_le mu_cte_eq.

Lemma mu_stable_mult_right : forall (A : Type)(m:(distr A)) (c:U) (f : A -> U),
   mu m (fun x => (f x) * c) == (mu m f) * c.
intros; apply Ueq_trans with
   (mu m (fun x => c * (f x))).
apply mu_stable_eq; auto.
apply Ueq_trans with (c * mu m f); auto.
exact (mu_stable_mult m c f).
Qed.

Lemma mu_stable_minus : forall (A:Type) (m:distr A)(f g : A -> U),
 fle g f -> mu m (fun x => f x - g x) == mu m f - mu m g.
intros.
assert (mu m g <= mu m f).
apply (mu_monotonic m); auto.
assert (forall x, f x - g x <= [1-](g x)).
intros; unfold Uminus; auto.
setoid_replace (mu m f) with (mu m (fun x : A => f x - g x) + mu m g); auto.
apply Ueq_sym; apply Uplus_minus_simpl_right.
apply Ule_trans with ([1-](mu m (fun x => [1-] g x))); auto.
apply Uinv_le_perm_right.
apply (mu_stable_inv m g); auto.
apply Uinv_le_compat.
apply (mu_monotonic m); red; intros; auto.
rewrite <- (mu_stable_plus m (f:=fun x : A => f x - g x)  (g:=g)).
apply (mu_stable_eq m); repeat red; unfold fplus; intros; auto.
repeat red; intros; unfold finv; auto.
Qed.

Lemma mu_inv_minus :
forall (A:Type) (m:distr A)(f: A -> U), mu m (finv f) == mu m (f_one A) - mu m f.
intros; apply Ueq_trans with (mu m (fun x => f_one A x - f x)).
apply (mu_stable_eq m); repeat red; unfold finv,f_one; intros; auto.
apply mu_stable_minus; auto.
Qed.

Lemma mu_inv_minus_inv : forall (A:Type) (m:distr A)(f: A -> U),
     mu m (finv f) + [1-](mu m (f_one A)) == [1-](mu m f).
intros; apply Uminus_eq_perm_right.
apply Uinv_le_compat.
apply (mu_monotonic m); unfold f_one; auto.
unfold Uminus; Usimpl.
rewrite mu_inv_minus; repeat Usimpl.
unfold Uminus.
apply Uinv_eq_compat; auto.
Qed.

Lemma mu_le_esp_inv : forall (A:Type) (m:distr A)(f g : A -> U),
 ([1-]mu m (finv f)) & mu m g <= mu m (fesp f g).
intros; rewrite Uesp_sym.
apply Uplus_inv_le_esp; Usimpl.
apply Ule_trans with (mu m (fplus (fesp f g) (finv f))); auto.
apply (mu_monotonic m); unfold fplus, fle, fesp,finv; intros; auto.
rewrite Uesp_sym; auto.
Qed.
Hint Resolve mu_le_esp_inv.

Lemma mu_stable_inv_inv : forall (A:Type) (m:distr A)(f : A -> U),
             mu m f <= [1-] mu m (finv f).
intros; apply Ule_trans with (mu m (finv (finv f))).
apply (mu_monotonic m); auto.
apply (mu_stable_inv m); auto.
Qed.
Hint Resolve  mu_stable_inv_inv.

Lemma mu_le_esp : forall (A:Type) (m:distr A)(f g : A -> U),
 mu m f & mu m g <= mu m (fesp f g).
intros; apply Ule_trans with (([1-]mu m (finv f)) & mu m g); auto.
Qed.
Hint Resolve mu_le_esp.

(** ** Monadic operators for distributions *)
Definition Munit : forall A:Type, A -> distr A.
intros A x.
exists (unit x).
apply unit_stable_inv.
apply unit_stable_plus.
apply unit_stable_mult.
apply unit_monotonic.
Defined.

Definition Mlet : forall A B:Type, (distr A) -> (A -> distr B) -> distr B.
intros A B mA mB.
exists (star (mu mA) (fun x => (mu (mB x)))).
apply star_stable_inv; auto.
apply star_stable_plus; auto.
intros;apply Ule_trans with ([1-] (mu (mB a) g)); auto.
apply Ule_trans with (mu (mB a) (fun a => ([1-] (g a)))); auto.
apply (mu_monotonic (mB a)); auto.
apply (mu_stable_inv (mB a)) with (f:=g).
apply star_stable_mult; auto.
apply star_monotonic; auto.
Defined.

(** ** Operations on distributions *)

Definition le_distr (A:Type) (m1 m2:distr A) := forall f, mu m1 f <= mu m2 f.

Definition eq_distr (A:Type) (m1 m2:distr A) := forall f, mu m1 f == mu m2 f.

Lemma le_distr_antisym : forall (A:Type) (m1 m2:distr A),
  le_distr m1 m2 -> le_distr m2 m1 -> eq_distr m1 m2.
red; intros; apply Ule_antisym; auto.
Qed.

Lemma le_distr_refl : forall (A:Type) (m :distr A), le_distr m m.
unfold le_distr; auto.
Qed.

Lemma eq_distr_sym : forall A (m1 m2:distr A), eq_distr m1 m2 -> eq_distr m2 m1.
unfold eq_distr; auto.
Qed.

Lemma eq_distr_refl : forall A (m:distr A), eq_distr m m.
unfold eq_distr; auto.
Qed.

Lemma eq_distr_trans : forall A (m1 m2 m3:distr A),
      eq_distr m1 m2 -> eq_distr m2 m3->eq_distr m1 m3.
unfold eq_distr; intros.
apply Ueq_trans with (mu m2 f); auto.
Qed.

Hint Resolve eq_distr_refl.
Hint Immediate eq_distr_sym.

Lemma distr_setoid : forall (A:Type), Setoid_Theory  (distr A) (eq_distr (A:=A)).
intros; constructor; red ; auto.
exact (eq_distr_trans (A:=A)).
Qed.

Lemma le_distr_trans : forall (A:Type) (m1 m2 m3:distr A),
  le_distr m1 m2 -> le_distr m2 m3 -> le_distr m1 m3.
unfold le_distr; intros.
apply Ule_trans with (mu m2 f); auto.
Qed.

Hint Resolve le_distr_refl.
Hint Unfold le_distr.

Add Parametric Setoid A : (@distr A) (@eq_distr A) (@distr_setoid A) as Distr_Setoid.

Lemma Munit_compat : forall A (x y : A), x=y -> eq_distr (Munit x) (Munit y).
intros; subst; auto.
Qed.

Lemma Mlet_compat : forall (A B : Type) (m1 m2:distr A) (M1 M2 : A-> distr B),
  eq_distr m1 m2 -> (forall x, eq_distr (M1 x) (M2 x)) ->
  eq_distr (Mlet m1 M1) (Mlet m2 M2).
unfold eq_distr,Mlet,star; simpl; intros.
apply Ueq_trans with (mu m2 (fun x : A => mu (M1 x) f)); auto.
apply mu_stable_eq; red; auto.
Qed.

Lemma Munit_eq : forall (A:Type) (q:A->U) x, mu (Munit x) q == q x.
trivial.
Qed.

Lemma le_distr_gen : forall (A:Type) (m1 m2:distr A),
  le_distr m1 m2 -> forall f g,  fle f g -> mu m1 f <= mu m2 g.
intros; apply Ule_trans with (mu m2 f); auto.
apply (mu_monotonic m2); auto.
Qed.

(** ** Properties of monadic operators *)
Lemma Mlet_unit : forall (A B:Type) (x:A) (m:A -> distr B), eq_distr (Mlet (Munit x) m) (m x).
red; intros; simpl; rewrite law1; trivial.
Qed.

Lemma M_ext : forall (A:Type) (m:distr A), eq_distr (Mlet m (fun x => (Munit x))) m.
red; intros; simpl;rewrite law2; trivial.
Qed.

Lemma Mcomp : forall (A B C:Type) (m1:(distr A)) (m2:A -> distr B) (m3:B -> distr C),
     eq_distr (Mlet (Mlet m1 m2) m3) (Mlet m1 (fun x:A => (Mlet (m2 x) m3))).
red; intros; simpl.
rewrite law3; trivial.
Qed.

Lemma Mlet_mon : forall (A B:Type) (m1 m2: distr A) (f1 f2 : A -> distr B),
  le_distr m1 m2 -> (forall x, le_distr (f1 x) (f2 x)) -> le_distr (Mlet m1 f1) (Mlet m2 f2).
red; intros; simpl.
unfold star; auto.
apply (le_distr_gen H).
red; red in H0; auto.
Qed.

(** ** A specific distribution *)
Definition distr_null : forall A : Type, distr A.
intro A; exists (fun (f : A -> U) => 0); try red; auto.
Defined.

Lemma le_distr_null : forall (A:Type) (m : distr A), le_distr (distr_null A) m.
red; intros.
unfold distr_null; simpl; auto.
Qed.
Hint Resolve le_distr_null.

(** ** Least upper bound of increasing sequences of distributions *)
Section Lubs.
Variable A : Type.
Variable muf : nat -> (distr A).
Hypothesis muf_mon : forall n m:nat, (n <= m)%nat -> le_distr (muf n) (muf m).

Definition mu_lub_ : M A := fun f => lub (fun n => mu (muf n) f).

Definition mu_lub: distr A.
exists mu_lub_; try red; unfold mu_lub_; intros.

red in muf_mon; apply lub_inv; repeat red; intros; auto.

unfold fplus;apply Ueq_trans with
(lub (fun n:nat => (mu (muf n) f) + (mu (muf n) g))); auto.
apply lub_eq_stable; auto.
intro; exact (mu_stable_plus (muf n) H); auto.
apply (@lub_eq_plus (fun n:nat => mu (muf n) f)
                   (fun n:nat => mu (muf n) g));
intros; apply muf_mon; auto.
unfold fmult;
apply Ueq_trans with
(lub (fun n:nat => k * (mu (muf n) f))).
apply lub_eq_stable; auto.
intro; exact (mu_stable_mult (muf n) k f); auto.
exact (lub_eq_mult k (fun n:nat => mu (muf n) f)).
apply lub_le_stable; auto.
intros; apply (mu_monotonic (muf n)); auto.
Defined.

Lemma mu_lub_le : forall n:nat, le_distr (muf n) mu_lub.
red; intros; simpl; unfold mu_lub_; auto.
change (((fun n0:nat => mu (muf n0) f) n)
       <= lub (fun n0:nat => mu (muf n0) f)).
apply le_lub.
Qed.

Lemma mu_lub_sup : forall m:(distr A), (forall n:nat, le_distr (muf n) m) -> le_distr mu_lub m.
red; intros; simpl; unfold mu_lub_; auto.
apply lub_le.
red in H; auto.
Qed.

End Lubs.

(** ** Distribution for [flip]
The distribution associated to [flip ()] is
       $f \mapsto \frac{1}{2}f(true)+\frac{1}{2}f(false)$ *)
Definition flip : (M bool) := fun (f : bool -> U) => [1/2] * (f true) + [1/2] * (f false).

Lemma flip_stable_inv : stable_inv flip.
unfold flip, stable_inv, finv; intros; auto.
Qed.

Lemma flip_stable_plus : stable_plus flip.
unfold flip, stable_plus, fplus; intros; auto.
setoid_rewrite (Udistr_plus_left [1/2] (H true)).
setoid_rewrite (Udistr_plus_left [1/2] (H false)).
repeat norm_assoc_right.
apply Uplus_eq_compat_right.
repeat norm_assoc_left; apply Uplus_eq_compat_left; auto.
Qed.

Lemma flip_stable_mult : stable_mult flip.
unfold flip, stable_mult, fmult; intros; auto.
setoid_replace ([1/2]* (k * f true)) with (k * ([1/2]* f true)); auto.
setoid_replace ([1/2]* (k * f false))   with (k * ([1/2]* f false)); auto.
assert (([1/2]* f true) <= ([1-] ([1/2]* f false))); auto.
setoid_rewrite (Udistr_plus_left k H); auto.
Qed.

Lemma flip_monotonic : monotonic flip.
unfold monotonic, flip; intros.
red in H.
apply Ule_trans with ([1/2]* g true +[1/2]* f false ); auto.
Qed.

Definition ctrue (b:bool) := if b then 1 else 0.
Definition cfalse (b:bool) := if b then 0 else 1.

Lemma flip_ctrue : flip ctrue == [1/2].
unfold flip, ctrue; simpl; auto.
setoid_rewrite (Umult_one_right [1/2]).
setoid_rewrite (Umult_zero_right [1/2]); auto.
Qed.

Lemma flip_cfalse : flip cfalse == [1/2].
unfold flip, cfalse; simpl; auto.
setoid_rewrite (Umult_one_right [1/2]).
setoid_rewrite (Umult_zero_right [1/2]); auto.
Qed.

Hint Resolve flip_ctrue flip_cfalse.

Definition Flip  : distr bool.
exists flip.
apply flip_stable_inv.
apply flip_stable_plus.
apply flip_stable_mult.
apply flip_monotonic.
Defined.

(** ** Uniform distribution beween 0 and n *)

(** *** Definition of [fnth]
        [fnth n k] is defined as $\frac{1}{n+1}$ *)

Definition fnth (n:nat) : nat -> U := fun k => ([1/]1+n).

(** *** Basic properties of [fnth] *)

Lemma Unth_eq : forall n, Unth n == [1-] (sigma (fnth n) n).
intro; exact (Unth_prop n).
Qed.
Hint Resolve Unth_eq.

Lemma sigma_fnth_one : forall n, sigma (fnth n) (S n) == 1.
intros; rewrite sigma_S.
unfold fnth at 1.
rewrite (Unth_eq n); auto.
Qed.
Hint Resolve sigma_fnth_one.

Lemma Unth_inv_eq : forall n, [1-] ([1/]1+n) == sigma (fnth n) n.
intro; setoid_rewrite (Unth_eq n); auto.
Qed.

Lemma sigma_fnth_sup : forall n m, (m > n) -> sigma (fnth n) m == sigma (fnth n) (S n).
intros.
assert ((S n) <= m)%nat; auto with arith.
elim H0; intros; auto.
rewrite sigma_S; auto.
setoid_rewrite H2.
assert (m0 > n); auto with arith.
setoid_rewrite (sigma_fnth_one n); auto.
Qed.

Lemma sigma_fnth_le : forall n m, (sigma (fnth n) m) <= (sigma (fnth n) (S n)).
intros; setoid_rewrite (sigma_fnth_one n); auto.
Qed.

Hint Resolve sigma_fnth_le.

(** [fnth] is a retract *)
Lemma fnth_retract : forall n:nat,(retract (fnth n) (S n)).
red; intros.
unfold fnth at 1.
apply Ule_trans with ([1-] (sigma (fnth n) n)); auto with arith.
Qed.

Implicit Arguments fnth_retract [].

(** *** Distribution for [random n]
The distribution associated to [random n] is
       $f \mapsto \Sigma_{i=0}^n \frac{f(i)}{n+1}$
       we cannot factorize $\frac{1}{n+1}$ because of possible overflow *)

Definition random (n:nat):M nat:= fun (f:nat->U) => sigma (fun k => Unth n *  f k) (S n).

(** *** Properties of [random] *)

Lemma random_stable_inv : forall n, stable_inv (random n).
unfold random, stable_inv, finv; intros; auto.
setoid_rewrite (sigma_inv f (fnth_retract n)); auto.
Qed.

Lemma random_stable_plus : forall n, stable_plus (random n).
unfold random, stable_plus, fplus; intros; auto.
unfold fplusok, fle, finv in H.
apply Ueq_trans with
 (sigma (fun k : nat => ([1/]1+n * f k) + ([1/]1+n  * g k)) (S n)).
apply sigma_eq_compat; intros.
assert (f k <= [1-] (g k)); auto.
apply sigma_plus with (f:=fun k : nat => Unth n * f k)
                      (g:=fun k : nat => Unth n * g k); auto.
Qed.

Lemma random_stable_mult : forall n, stable_mult (random n).
unfold random, stable_mult, fmult; intros; auto.
apply Ueq_trans with
 (sigma (fun l : nat => k * ([1/]1+n * f l)) (S n)).
apply sigma_eq_compat; intros; auto.
apply sigma_mult with (f:=fun k : nat => Unth n * f k).
red; intros.
apply Ule_trans with ([1/]1+n); auto.
apply Ule_trans with ([1-] (sigma (fun k1 => Unth n) k0)); auto.
apply (fnth_retract n k0); auto.
Qed.

Lemma random_monotonic : forall n, monotonic (random n).
unfold monotonic, random; intros.
red in H.
apply sigma_le_compat; auto.
Qed.

Definition Random (n:nat) : (distr nat).
exists (random n).
apply random_stable_inv.
apply random_stable_plus.
apply random_stable_mult.
apply random_monotonic.
Defined.

Lemma random_total : forall n : nat,  mu (Random n) (f_one nat) == 1.
intros; simpl; unfold random.
unfold f_one.
apply Ueq_trans with  (sigma (fnth n) (S n)).
apply sigma_eq_compat.
intros; repeat Usimpl; auto.
auto.
Qed.

(** * Nondeterministic choice *)

Record Ndistr (A:Type): Type :=
   {nu : M A; nu_monotonic : monotonic nu; nu_continuous : continuous nu; nu_le_esp: le_esp nu}.

Hint Resolve nu_monotonic nu_continuous nu_le_esp.

Definition Nunit (A:Type) (x:A) : Ndistr A.
exists (unit x).
apply unit_monotonic.
apply unit_continuous.
red; auto.
Defined.

Definition Nlet (A B:Type)(n:Ndistr A) (N:A->Ndistr B): Ndistr B.
exists (star (nu n) (fun x => nu (N x))); auto.
apply star_monotonic; auto.
apply star_continuous; auto.
red; unfold star; intros.
apply Ule_trans with (nu n (fun x : A => nu (N x) f & nu (N x) g)).
apply (nu_le_esp n) with (f:=fun x : A => nu (N x) f) (g:=fun x : A => nu (N x) g).
apply (nu_monotonic n); red; intros.
apply (nu_le_esp (N x) f g).
Defined.

Definition Nif (A:Type) (nb: Ndistr bool) (n1 n2 :Ndistr A): Ndistr A :=
     Nlet nb (fun b => if b then n1 else n2).

Definition Ndistr_cte : forall A, forall x:U, Ndistr A.
intros;  exists (fun (f:A->U) => x).
red; auto.
red; simpl; intros.
apply le_lub with (f:= fun (n:nat) => x) (n:=O); auto.
red; auto.
Defined.

Definition Nmin : forall A, Ndistr A -> Ndistr A -> Ndistr A.
intros A n1 n2; exists (fun f => min (nu n1 f) (nu n2 f)).
red; destruct n1; destruct n2; simpl; intros.
apply min_le_compat; auto.
red; intros.
apply Ule_trans with
  (min (lub (fun n => nu n1 (fn n))) (lub (fun n => nu n2 (fn n)))); auto.
apply min_le_compat; auto.
apply (nu_continuous n1); auto.
apply (nu_continuous n2); auto.
apply min_lub_le_incr with (f:=fun n => nu n1 (fn n))
           (g:=fun n => nu n2 (fn n)).
red; intros; apply (nu_monotonic n1); auto.
red; intros; apply (nu_monotonic n2); auto.
red; intros.
apply Ule_trans with (min (nu n1 f & nu n1 g) (nu n2 f & nu n2 g)).
apply Uesp_min.
apply min_le_compat.
apply (nu_le_esp n1).
apply (nu_le_esp n2).
Defined.

Lemma Ndistr_eq_esp : forall (A:Type) (n:Ndistr A) f g, 1 <= nu n f -> nu n g == nu n (fesp f g).
intros; apply Ule_antisym.
apply Ule_trans with (nu n f & nu n g).
apply Ule_trans with (1 & nu n g); auto.
apply (nu_le_esp n); auto.
apply (nu_monotonic n); unfold fesp; red; auto.
Qed.
Hint Resolve Ndistr_eq_esp.

Definition le_ndistr (A:Type)(m1 m2 : Ndistr A) := forall f,  nu m1 f <= nu m2 f.

End Proba.