Require Import A1_Plan A2_Orientation A4_Droite A7_Tactics .
Require Import B7_Tactics .
Require Import G1_Angles G3_ParticularAngle .
Require Import H1_Triangles .
Require Import I1_SupplementaryAngle I2_Supplement I4_Tactics .
Require Import J1_MidLine J2_MidPoint J3_MidProp J4_Tactics .
Require Import K1_RightAngle.

Section MIDLINEandRIGHTANGLE.

Lemma RightAngleNotCollinear : forall A B C : Point,
	RightAngle A B C ->
	~Collinear A B C.
Proof.
	intros; intro.
	by3SegmentCases1 H0.
	 elim (RightAngleNotNullAngle A B C H).
	   apply OpenRayNullAngle.
	  apply (RightAngleDistinctBA A B C H).
	  step9 H1.
	    apply (RightAngleDistinctBC A B C H).
	 elim (RightAngleNotNullAngle A B C H).
	   apply OpenRayNullAngle.
	  apply (RightAngleDistinctBA A B C H).
	  immediate9.
	 elim (RightAngleNotElongatedAngle A B C H).
	   apply BetweenElongatedAngle.
	   step9 H2.
	  apply sym_not_eq; apply (RightAngleDistinctBC A B C H).
	  apply (RightAngleDistinctBA A B C H).
Qed.

Lemma SupplementaryRightAngle : Supplementary Vv IsAngleVv = Vv.
Proof.
	unfold Supplementary in |- *.
	assert (H := IsAngleVv); eqToCongruent8.
	exact RightVvOouU.
Qed.

Lemma EqSupplementaryEqRightAngle : forall alpha : Point, forall (H : IsAngle alpha),
	Supplementary alpha H = alpha ->
	alpha = Vv.
Proof.
	unfold Supplementary, RightAngle in |- *; intros.
	from9 3 (TCongruent (Tr alpha Oo uU) (Tr alpha Oo Uu)).
	   eqToCongruent8; immediate9.
	 apply EqVv.
	  immediate9.
	  elim H; intros.
	    contrapose0 H3.
	    step9 BetweenUuOouU.
	  step9 H1.
Qed.

Lemma EqSupplementEqRightAngle : forall A B C : Point,
	Supplement A B C A B C ->
	RightAngle A B C.
Proof.
	intros.
	inversion H.
	since9 (Angle A B C Hed Hef = Vv).
	 apply  (EqSupplementaryEqRightAngle (Angle A B C Hed Hef) (IsAngleAngle A B C Hed Hef)).
	  step9 H0.
	 unfold RightAngle in |- *.
	   congruentToEq8.
	  exact DistinctOoVv.
	  rewrite H1.
	    assert (H4 := IsAngleVv).
	    step9 H4.
Qed.

Lemma SupplementCongruentRightAngle : forall A B C D E F : Point,
	CongruentAngle A B C D E F ->
	Supplement A B C D E F ->
	RightAngle A B C.
Proof.
	intros.
	apply EqSupplementEqRightAngle.
	step9 H0.
Qed.

Lemma RightAngleAIA' : forall A B : Point, forall H : A <> B,
	RightAngle A (MidPoint A B H) (LineA (MidLine A B H)).
Proof.
	intros.
	apply EqSupplementEqRightAngle.
	since9  (CongruentAngle A (MidPoint A B H) (LineA (MidLine A B H)) B (MidPoint A B H) (LineA (MidLine A B H))).
	 assert (H1 := TCongruentAIA'BIA' A B H).
	   step9 H1;  immediate9.
	 step9 H0.
	   since9 (Between A (MidPoint A B H) B).
Qed.

Lemma RightAngleAIB' : forall A B : Point, forall H : A <> B,
	RightAngle A (MidPoint A B H) (LineB (MidLine A B H)).
Proof.
	intros.
	apply (CongruentRightAngle A (MidPoint A B H) (LineA (MidLine A B H))).
	 apply RightAngleAIA'.
	 step9 (TCongruentAIA'AIB' A B H);  immediate9.
Qed.

Lemma RightAngleBIA' : forall A B : Point, forall H : A <> B,
	RightAngle B (MidPoint A B H) (LineA (MidLine A B H)).
Proof.
	intros.
	apply (CongruentRightAngle A (MidPoint A B H) (LineA (MidLine A B H))).
	 apply RightAngleAIA'.
	 step9 (TCongruentAIA'BIA' A B H);  immediate9.
Qed.

Lemma RightAngleBIB' : forall A B : Point, forall H : A <> B,
	RightAngle B (MidPoint A B H) (LineB (MidLine A B H)).
Proof.
	intros.
	apply (CongruentRightAngle A (MidPoint A B H) (LineB (MidLine A B H))).
	 apply RightAngleAIB'.
	 step9 (TCongruentAIB'BIB' A B H);  immediate9.
Qed.

Lemma OnMidLineRightAngle : forall A B C : Point, forall H : A <> B,
	MidPoint A B H <> C ->
	OnLine (MidLine A B H) C ->
	RightAngle A (MidPoint A B H) C.
Proof.
	intros.
	from9 1 (TCongruent (Tr A (MidPoint A B H) C) (Tr B (MidPoint A B H) C)).
	  step9 H1.
	 from9 H2 (CongruentAngle A (MidPoint A B H) C B (MidPoint A B H) C).
	  apply EqSupplementEqRightAngle.
	    step9 H3.
	    since9 (Between A (MidPoint A B H) B).
Qed.

Lemma OnMidLineEqMidPointRightAngleA : forall A B C D : Point, forall H : A <> B,
	C <> D ->
	C = MidPoint A B H ->
	OnLine (MidLine A B H) D ->
	RightAngle A  C D.
Proof.
	intros.
	subst.
	apply OnMidLineRightAngle; immediate9.
Qed.

Lemma OnMidLineEqMidPointRightAngleB : forall A B C D : Point, forall H : A <> B,
	C <> D ->
	C = MidPoint A B H ->
	OnLine (MidLine A B H) D ->
	RightAngle B  C D.
Proof.
	intros; subst.
	apply (CongruentRightAngle A (MidPoint A B H) D).
	 apply (OnMidLineEqMidPointRightAngleA A B (MidPoint A B H) D H); immediate9.
	 from9 1 (TCongruent (Tr A (MidPoint A B H) D) (Tr B (MidPoint A B H) D)).
	   step9 H2.
	  step9 H1.
	   immediate9.
	   immediate9.
Qed.

Lemma RightSupplementUuOoVv :
	Supplement Uu Oo Vv Uu Oo Vv.
Proof.
	assert (H := IsAngleVv).
	congruentToEq8.
	 immediate9.
	 since9  (Supplementary (Angle Uu Oo Vv H0 H1) (IsAngleAngle Uu Oo Vv H0 H1) = Supplementary Vv IsAngleVv).
	  rewrite H2; rewrite SupplementaryRightAngle.
	    immediate9.
Qed.

Lemma RightRightSupplement : forall A B C D E F : Point,
	RightAngle A B C ->
	RightAngle D E F ->
	Supplement A B C D E F.
Proof.
	unfold RightAngle in |- *; intros.
	step9 H.
	apply SupplementSym; step9 H0.
	exact RightSupplementUuOoVv.
Qed.

Lemma RightSupplement : forall A B C : Point,
	RightAngle A B C ->
	Supplement A B C A B C.
Proof.
	intros; apply RightRightSupplement; immediate9.
Qed.

Lemma RightSupplementRight : forall A B C D E F : Point,
	RightAngle A B C ->
	Supplement A B C D E F ->
	RightAngle D E F.
Proof.
	intros; apply (CongruentRightAngle A B C D E F H).
	apply CongruentAngleSym; step9 H0.
	apply RightSupplement; immediate9.
Qed.

Lemma OrSupplementRight : forall A B C D E F : Point,
	RightAngle A B C \/ CongruentAngle A B C D E F ->
	Supplement A B C D E F ->
	RightAngle D E F.
Proof.
	intros; destruct H.
	 apply (RightSupplementRight A B C D E F H H0).
	 apply (SupplementCongruentRightAngle D E F A B C).
	  immediate9.
	  apply SupplementSym; immediate9.
Qed.

Lemma RightOrRight : forall A B C D E F : Point,
	RightAngle A B C ->
	Supplement A B C D E F \/ CongruentAngle A B C D E F ->
	RightAngle D E F.
Proof.
	intros.
	destruct H0.
	 apply (RightSupplementRight A B C D E F H H0).
	 apply (CongruentRightAngle A B C D E F H H0).
Qed.

End MIDLINEandRIGHTANGLE.


Require Import Ring_theory.
Print ring_theory.

Inductive V0 (A : Type) : Type := V0Make.
Inductive V1 (A : Type) : Type := V1Make : A -> V1 A.
Inductive V2 (A : Type) : Type := V2Make : A -> A -> V2 A.
Inductive Kron (f : Type -> Type) (g : Type -> Type) (a : Type) := MkKron : (f (g a)) -> Kron f g a.
Inductive DSum (f : Type -> Type) (g : Type -> Type) (a : Type) := MkDSum : f a -> g a -> DSum f g a.
(* We need to get the ring theory in there. *)
Class Linear (f : Type -> Type) (A : Type) := {
                                   vsum : f A -> f A -> f A ;
                                   smul : A -> f A -> f A;
                                   vzero : f A
                                            }.

Notation "s *^ v" := (smul s v) (at level 75, right associativity).
Notation "v ^+^ w" := (vsum v w) (at level 70, right associativity).

Instance linearV1 : Linear V1 nat := {
                         vsum := fun v w => match v,w with
                                         | (V1Make _ x), (V1Make _ y) => V1Make _ (x + y)
                                         end;
                         smul s v := match v with
                                     | (V1Make _ x) => V1Make _ (s * x)
                                     end;
                         vzero := V1Make _ 0
                                  }.
Instance linearDSum (f : Type -> Type) (g : Type -> Type) `{Linear f nat} `{Linear g nat}  : Linear (DSum f g) nat := {
                         vsum := fun v w => match v,w with
                                         | (MkDSum _ _ _ f g), (MkDSum _ _ _ f' g') => MkDSum _ _ _ (f ^+^ f') (g ^+^ g')
                                         end;
                         smul s v := match v with
                                     | (MkDSum _ _ _ f g) => MkDSum _ _ _ (s *^ f) (s *^ g)
                                     end;
                         vzero := MkDSum _ _ _ vzero vzero
                                  }.

Definition v1one := V1Make _ 1.
Compute v1one ^+^ v1one.
Definition v2one := MkDSum _ _ _ v1one v1one.
Compute v2one ^+^ v2one.

(*
Class Ring (A : Type) := {
           eq :
           plus
           theory : ring_theory eq

}

Record LinOp (f : v A -> w A) {
       is_linear : f (v ^+^ w) = (f v) ^+^ (f w)

}

*)
(*
                                   dist_smul : smul s (vsum x y) = vsum (smul s x) (smul s y);
                                   assoc_vsum : (vsum (vsum x y) z) = vsum (vsum x y) z;
                                   assoc_smul : smul s (smul s' v) = smul (s * s') v;
                                   dist_smul : smul (s + s') v = vsum (smul s v) (smul s' v);
                                   vsum_comm : vsum x y = vsum y x;
                                   smul_id : smul 1 v = v;
                                   vzero_id : vsum v vzero = v

                                 *)


Require Import Arith.

CoInductive stream :=
| SCons : nat -> stream -> stream.

CoFixpoint gen m n :=
  SCons m (if m <? n then gen (S m) n else gen 0 (S n)).

Fixpoint Snth n s :=
  match n with
  | 0 => match s with SCons h _ => h end
  | S n' => match s with SCons _ s' => Snth n' s' end
  end.

(* Show that each natural number occurs infinitely often in [gen 0 0]. *)
Definition task :=
  forall x, forall y, exists z, y <= z /\ Snth z (gen 0 0) = x.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

(* No helper lemma needed. *)
Theorem theorem0 : forall (x : lst) (y : natural), eq (len (append x (Cons y Nil))) (Succ (len x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.


Require Import List Lia.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

(* Generic facts *)

(* duplicates argument *)
Fact copy {A : Type} : A -> A * A.
Proof. done. Qed.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

Lemma iter_plus {X: Type} {f: X -> X} {x: X} {n m: nat} : Nat.iter n f (Nat.iter m f x) = Nat.iter (n + m) f x.
Proof. elim: n; [done | by move=> n /= ->]. Qed.

Fact iter_last {X: Type} {f: X -> X} {n x} : Nat.iter n f (f x) = Nat.iter (1+n) f x.
Proof. elim: n x; [done | by move=> n /= + x => ->]. Qed.

(* induction/recursion principle wrt. a decreasing measure f *)
(* example: elim /(measure_rect length) : l. *)
Lemma measure_rect {X : Type} (f : X -> nat) (P : X -> Type) :
  (forall x, (forall y, f y < f x -> P y) -> P x) -> forall (x : X), P x.
Proof.
  exact: (well_founded_induction_type (Wf_nat.well_founded_lt_compat X f _ (fun _ _ => id)) P).
Qed.

(* List facts *)
Lemma Forall_appI {X: Type} {P : X -> Prop} {A B}: Forall P A -> Forall P B -> Forall P (A ++ B).
Proof. move=> ? ?. apply /Forall_app. by constructor. Qed.

Lemma incl_nth_error {X: Type} {Gamma Gamma': list X} :
  incl Gamma Gamma' -> exists ξ, forall x, nth_error Gamma x = nth_error Gamma' (ξ x).
Proof.
  elim: Gamma Gamma'.
  - move=> Gamma' _. exists (fun x => length Gamma').
    move=> [|x] /=; apply /esym; by apply /nth_error_None.
  - move=> x Gamma IH Gamma'. move=> /Forall_forall /Forall_cons_iff.
    move=> [/(@In_nth_error _ _ _) [nx] Hnx /Forall_forall /IH] [ξ Hξ].
    exists (fun y => if y is S y then ξ y else nx). by case.
Qed.

Lemma Forall_seqP {P : nat -> Prop} {m n: nat} :
  Forall P (seq m n) <-> (forall i, m <= i < m + n -> P i).
Proof. rewrite Forall_forall. constructor; move=> H ? ?; apply H; by apply /in_seq. Qed.

Lemma Forall2_consE {X Y: Type} {R: X -> Y -> Prop} {x y l1 l2} :
  Forall2 R (x :: l1) (y :: l2) -> R x y /\ Forall2 R l1 l2.
Proof. move=> H. by inversion H. Qed.

Lemma Forall2_length_eq {X Y: Type} {R: X -> Y -> Prop} {l1 l2} :
  Forall2 R l1 l2 -> length l1 = length l2.
Proof.
  elim: l1 l2.
  - move=> [| ? ?] H; first done. by inversion H.
  - move=> ? ? IH [| ? ?] /= H; inversion H. congr S. by apply: IH.
Qed.

Lemma in_app_l {X: Type} {x: X} {l1 l2: list X} : In x l1 -> In x (l1 ++ l2).
Proof. move=> ?. apply /in_app_iff. by left. Qed.

Lemma in_app_r {X: Type} {x: X} {l1 l2: list X} : In x l2 -> In x (l1 ++ l2).
Proof. move=> ?. apply /in_app_iff. by right. Qed.

(* construct choice function for a list over nat *)
Lemma list_choice {P : nat -> nat -> Prop} {l: list nat} : Forall (fun i : nat => exists n : nat, P i n) l ->
  exists φ, Forall (fun i : nat => P i (φ i)) l.
Proof.
  elim: l; first by exists id.
  move=> k l IH /Forall_cons_iff [[n Hkn]] /IH [φ Hφ].
  exists (fun i => if PeanoNat.Nat.eq_dec i k then n else φ i).
  constructor; first by case: (PeanoNat.Nat.eq_dec k k).
  apply: Forall_impl Hφ => i Hi.
  case: (PeanoNat.Nat.eq_dec i k); [by move=> /= ->|done].
Qed.

Lemma map_id' {X: Type} {f: X -> X} {l: list X} : (forall x, f x = x) -> map f l = l.
Proof. move=> ?. rewrite -[RHS]map_id. by apply: map_ext => ?. Qed.

Lemma is_trueP {b1 b2: bool} : (is_true b1 <-> is_true b2) <-> b1 = b2.
Proof.
  case: b1; case: b2; rewrite /is_true; firstorder done.
Qed.


  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*							         *)
  (*   File : nat_bounded_list.v			         *)
  (*   Authors : S. Coupet-Grimal, W. Delobel		         *)
  (*   Content : instanciation of pred_list to list of natural   *)
  (*             numbers less than a certain bound               *)
  (***************************************************************)

Section nat_bounded_list.

  Require Export pred_list.
  (* bound : *)
  Variable n : nat.

  Definition P := fun (e:nat)=>lt e n.
  Definition nb_list := pred_list nat P.
  Definition nb_nil := pred_nil P.
  Definition nb_cons := pred_cons P.

  Definition nb_list_add_element := pred_list_add_element eq_nat_dec (P:=P).
  Definition nb_list_belong := pred_list_belong (P:=P).
  Definition nb_list_belong_dec := pred_list_belong_dec eq_nat_dec (P:=P).
  Definition nb_list_get_witness := pred_list_get_witness (P:=P).
  Definition nb_list_belong_add := pred_list_belong_add eq_nat_dec (P:=P).
  Definition nb_list_belong_rem := pred_list_belong_rem eq_nat_dec (P:=P).
  Definition nb_list_add_already_there := pred_list_add_already_there
    eq_nat_dec (P:=P).
  Definition nb_list_add_already_there_added := pred_list_add_already_there_added
    eq_nat_dec (P:=P).
  Definition nb_list_belong_added := pred_list_belong_added eq_nat_dec (P:=P).
  Definition nb_list_remove := pred_list_remove eq_nat_dec (P:=P).
  Definition nb_length := pred_length (P:=P).
  Definition nb_list_equiv := pred_list_equiv (P:=P) (Q:=P).
  Definition lt_nb_length := lt_pred_length (P:=P).

  Definition nb_list_convert (m:nat) := pred_list_convert (P:=P) (Q := fun p:nat => p<m).
  Definition nb_list_convert_equiv (m:nat) := pred_list_convert_equiv (P:=P)
    (Q := fun p:nat => p<m).
  Definition nb_list_convert_length (m:nat) := pred_list_convert_length (P:=P)
    (Q := fun p:nat => p<m).

  Definition nb_list_belong_convert (m:nat) := pred_list_belong_convert (P:=P)
    (Q:=fun p:nat => p<m).
  Definition nb_list_convert_belong (m:nat) := pred_list_convert_belong (P:=P)
    (Q:=fun p:nat => p<m).

End nat_bounded_list.

Implicit Arguments nb_nil [n].
Implicit Arguments nb_cons [n].
Implicit Arguments nb_list_add_element [n].
Implicit Arguments nb_list_belong [n].
Implicit Arguments nb_list_belong_dec [n].
Implicit Arguments nb_list_get_witness [n].
Implicit Arguments nb_list_belong_add [n].
Implicit Arguments nb_list_belong_rem [n].
Implicit Arguments nb_list_remove [n].
Implicit Arguments nb_length [n].
Implicit Arguments lt_nb_length [n].
Implicit Arguments nb_list_equiv [n].
Implicit Arguments nb_list_belong_convert [n].
Implicit Arguments nb_list_convert_belong [n].

Notation "a 'INnb' l" := (nb_list_belong l a) (at level 50).
Notation "l =nb= m" := (nb_list_equiv l m) (at level 50).


From Coq Require Import Arith OrderedType BinNat.
From mathcomp Require Import ssreflect ssrbool ssrnat div eqtype.
From ssrlib Require Import Types SsrOrder.

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

Section NatLemmas.

  Theorem nat_strong_ind (P : nat -> Prop) :
    (forall n : nat, (forall k : nat, k < n -> P k) -> P n) ->
    forall n : nat, P n.
  Proof.
    move=> IH. have H0: P 0.
    { apply: IH. move=> k H; by inversion H. }
    have H: forall n m, m <= n -> P m.
    { move=> n; elim: n.
      - move=> m Hm. rewrite leqn0 in Hm. rewrite (eqP Hm); exact: H0.
      - move=> n H m Hmn. apply: IH. move=> k Hkm.
        apply: H. exact: (leq_trans Hkm Hmn). }
    move=> n. apply: IH. move=> k Hkn. exact: (H _ _ (ltnW Hkn)).
  Qed.

  Lemma addn_add n m :
    n + m = (n + m)%coq_nat.
  Proof.
    reflexivity.
  Qed.

  Lemma subn_sub n m :
    n - m = (n - m)%coq_nat.
  Proof.
    reflexivity.
  Qed.

  Lemma muln_mul n m :
    n * m = (n * m)%coq_nat.
  Proof.
    reflexivity.
  Qed.

  Lemma leq_le_iff n m : n <= m <-> (n <= m)%coq_nat.
  Proof.
    elim: m n => /=.
    - move=> n; split => H.
      + rewrite /leq subn0 in H. rewrite (eqP H). done.
      + inversion_clear H. done.
    - move=> m IH n; split => H.
      + apply: (proj1 (Nat.le_pred_le_succ n m)). apply: (proj1 (IH (n.-1))).
        rewrite -subn1 leq_subLR addnC addn1. exact: H.
      + rewrite -addn1 addnC -leq_subLR subn1. apply: (proj2 (IH (n.-1))).
        apply: (proj2 (Nat.le_pred_le_succ n m)). exact: H.
  Qed.

  Lemma leq_le n m : n <= m -> (n <= m)%coq_nat.
  Proof.
    exact: (proj1 (leq_le_iff n m)).
  Qed.

  Lemma le_leq n m : (n <= m)%coq_nat -> n <= m.
  Proof.
    exact: (proj2 (leq_le_iff n m)).
  Qed.

  Lemma ltn_lt_iff n m : n < m <-> (n < m)%coq_nat.
  Proof.
    split => H.
    - apply: (proj1 (Nat.le_succ_l n m)). apply: leq_le. exact: H.
    - apply: le_leq. apply: (proj2 (Nat.le_succ_l n m)). exact: H.
  Qed.

  Lemma ltn_lt n m : n < m -> (n < m)%coq_nat.
  Proof.
    exact: (proj1 (ltn_lt_iff n m)).
  Qed.

  Lemma lt_ltn n m : (n < m)%coq_nat -> n < m.
  Proof.
    exact: (proj2 (ltn_lt_iff n m)).
  Qed.

  Lemma geq_ge_iff n m : n >= m <-> (n >= m)%coq_nat.
  Proof.
    split => H.
    - exact: (leq_le H).
    - exact: (le_leq H).
  Qed.

  Lemma geq_ge n m : n >= m -> (n >= m)%coq_nat.
  Proof.
    exact: (proj1 (geq_ge_iff n m)).
  Qed.

  Lemma ge_geq n m : (n >= m)%coq_nat -> n >= m.
  Proof.
    exact: (proj2 (geq_ge_iff n m)).
  Qed.

  Lemma gtn_gt_iff n m : n > m <-> (n > m)%coq_nat.
  Proof.
    split => H.
    - exact: (ltn_lt H).
    - exact: (lt_ltn H).
  Qed.

  Lemma gtn_gt n m : n > m -> (n > m)%coq_nat.
  Proof.
    exact: (proj1 (gtn_gt_iff n m)).
  Qed.

  Lemma gt_gtn n m : (n > m)%coq_nat -> n > m.
  Proof.
    exact: (proj2 (gtn_gt_iff n m)).
  Qed.

  Lemma ltn_leq_sub n m :
    n < m -> n <= m - 1.
  Proof.
    rewrite leq_eqVlt. move=> /orP. case => H.
    - rewrite -(eqP H). rewrite subn1 Nat.pred_succ. exact: leqnn.
    - move: (leq_sub2r 1 H). rewrite subn1 Nat.pred_succ. exact: ltnW.
  Qed.

  Lemma subn_gtn : forall n m r, n < m - r -> r < m.
  Proof.
    move=> n m r H.
    have: r < m.
    - rewrite -(subn_gt0 r m).
      induction n.
      + assumption.
      + by auto.
    - exact.
  Qed.

  Lemma lt_subr_addl : forall n m r : nat, (n < m - r) == (n + r < m).
  Proof.
    move=> n m r.
    case Hrm: (r < m).
    - rewrite -(ltn_add2r r n (m - r)).
      rewrite (subnK (ltnW Hrm)).
      exact: eqxx.
    - (* left is false *)
      move/negP/negP: (Hrm) => Hle.
      rewrite -leqNgt in Hle.
      move: (subn_eq0 m r) => Hsub.
      rewrite Hle in Hsub.
      move/idP/eqP: Hsub => Hsub.
      rewrite Hsub => {Hsub}.
      rewrite ltn0.
      (* right is false *)
      rewrite -(leq_add2l n m r) in Hle.
      move: (leq_trans (leq_addl n m) Hle) => {Hle} Hle.
      rewrite (leqNgt m (n + r)) in Hle.
      move/negPf: Hle => Hle.
      rewrite Hle.
      exact: eqxx.
  Qed.

  Lemma lt_sub1r_add1l : forall n m : nat, (n < m.-1) == (n.+1 < m).
  Proof.
    move=> n m.
    rewrite -{2}addn1 -subn1.
    exact: (lt_subr_addl n m 1).
  Qed.

  Lemma lt_sub1l_le (n m : nat) : (n.-1 < m) -> (n <= m).
  Proof.
    move=> H. move: (ltn_lt H) => {H} H.
    move: (Nat.lt_pred_le _ _ H) => {H} /le_leq H. exact: H.
  Qed.

  Lemma gt0_sub1F :
    forall n : nat, n > 0 -> n = n - 1 -> False.
  Proof.
    move=> n; elim: n.
    - done.
    - move=> n IH Hgt Heq.
      rewrite -add1n addKn add1n in Heq.
      apply: IH.
      + rewrite -Heq.
        assumption.
      + rewrite -{2}Heq -add1n addKn.
        reflexivity.
  Qed.

  Lemma ltn_leq_trans n m p :
    m < n -> n <= p -> m < p.
  Proof.
    move=> Hmn Hnp.
    move/ltP: Hmn => Hmn.
    move/leP: Hnp => Hnp.
    apply/ltP.
    exact: (Lt.lt_le_trans _ _ _ Hmn Hnp).
  Qed.

  Lemma ltn_addn m1 m2 n1 n2 : m1 < n1 -> m2 < n2 -> m1 + m2 < n1 + n2.
  Proof.
    move=> /ltP H1 /ltP H2. apply/ltP. exact: (Nat.add_lt_mono _ _ _ _ H1 H2).
  Qed.

  Lemma ltn_leq_addn x y a b : x < a -> y <= b -> x + y < a + b.
  Proof.
    move => /ltP H1 /leP H2. apply/ltP. exact: (Nat.add_lt_le_mono _ _ _ _ H1 H2).
  Qed.

  Lemma leq_ltn_addn x y a b : x <= a -> y < b -> x + y < a + b.
  Proof.
    move=> H1 H2. rewrite (addnC x) (addnC a). exact: ltn_leq_addn.
  Qed.

  Lemma ltb_leq n m : (n <? m) = true -> n <= m.
  Proof.
    move=> H. apply/leP. move: (Nat.ltb_lt n m) => [H1 _]. move: (H1 H) => {H1 H} H.
    auto with arith.
  Qed.

  Lemma eqn_ltn_gtn_cases :
    forall (m n : nat), (m == n) || (m < n) || (n < m).
  Proof.
    move=> m n. case Heq: (m == n) => /=; first done.
    move/idP/negP: Heq. rewrite neq_ltn. by apply.
  Qed.

  Lemma ltn_leq_mul_ltn m1 m2 n1 n2 :
    0 < m2 ->
    m1 < n1 -> m2 <= n2 -> m1 * m2 < n1 * n2.
  Proof.
    move=> H H1 H2. rewrite leq_eqVlt in H2. move/orP: H2; case => H2.
    - rewrite -(eqP H2) => {H2}.
      + rewrite ltn_mul2r H H1. done.
      + exact: ltn_mul.
  Qed.

  Lemma ltn_leq_mul_leq m1 m2 n1 n2 :
    m1 < n1 -> m2 <= n2 -> m1 * m2 <= n1 * n2.
  Proof.
    move=> H1 H2. move: (ltnW H1) => {H1} H1. exact: leq_mul.
  Qed.

  Lemma leq_ltn_mul_ltn m1 m2 n1 n2 :
    0 < m1 ->
    m1 <= n1 -> m2 < n2 -> m1 * m2 < n1 * n2.
  Proof.
    move=> H H1 H2. rewrite (mulnC m1 m2) (mulnC n1 n2). exact: ltn_leq_mul_ltn.
  Qed.

  Lemma leq_ltn_mul_leq m1 m2 n1 n2 :
    m1 <= n1 -> m2 < n2 -> m1 * m2 <= n1 * n2.
  Proof.
    move=> H1 H2. move: (ltnW H2) => {H2} H2. exact: leq_mul.
  Qed.

  Lemma addr_ltn n m : 0 < m -> n < n + m.
  Proof.
    move=> Hm. rewrite -{1}(addn0 n) ltn_add2l. assumption.
  Qed.

  Lemma addl_ltn n m : 0 < m -> n < m + n.
  Proof.
    rewrite addnC. exact: addr_ltn.
  Qed.

  Lemma div2_succ n :
    Nat.div2 (S n) = Nat.odd n + Nat.div2 n.
  Proof.
    case H: (Nat.odd n).
    - move: (proj1 (Nat.odd_spec n) H) => {H} [m H].
      rewrite {n}H.
      have: (((2 * m) + 1).+1 = 2 * (1 + m)) by ring.
      move=> ->. rewrite Nat.div2_double (plus_comm (2 * m) 1)
                         Nat.div2_succ_double.
      reflexivity.
    - move/negPn: H => H. move: (proj1 (Nat.even_spec n) H) => {H} [m H].
      rewrite {n}H Nat.div2_double Nat.div2_succ_double.
      reflexivity.
  Qed.

  Lemma expn_pow n m : n ^ m = Nat.pow n m.
  Proof.
    elim: m.
    - reflexivity.
    - move=> m IH. rewrite expnS (Nat.pow_succ_r _ _ (Nat.le_0_l m)) IH.
      reflexivity.
  Qed.

  Lemma ssrodd_odd n :
    odd n = Nat.odd n.
  Proof.
    elim: n => /=.
    - reflexivity.
    - move=> n IH. rewrite {}IH Nat.odd_succ Nat.negb_odd. reflexivity.
  Qed.

  Lemma addn_subn a b c :
    b <= c ->
    (a + b == c) = (a == c - b).
  Proof.
    move=> Hbc. case H: (a == c - b).
    - move: H. rewrite -(eqn_add2r b) (subnK Hbc). by apply.
    - move/negP: H => Hne. apply/negP => H. apply: Hne.
      rewrite -(eqn_add2r b) (subnK Hbc). exact: H.
  Qed.

  Lemma sub_diff_add_rdiff m n : n - (n - m) + (m - n) = m.
  Proof.
    case/orP: (leq_total n m) => H.
    - rewrite -subn_eq0 in H. rewrite (eqP H) subn0. rewrite subn_eq0 in H.
      exact: (subnKC H).
    - rewrite -subn_eq0 in H. rewrite (eqP H) addn0. rewrite subn_eq0 in H.
      exact: (subKn H).
  Qed.

  Lemma ssrdiv2_succ n :
    (n.+1)./2 = odd n + n./2.
  Proof.
    rewrite /half -/uphalf -/half uphalf_half.
    reflexivity.
  Qed.

  Lemma ssrdiv2_div2 n :
    n./2 = Nat.div2 n.
  Proof.
    elim: n.
    - reflexivity.
    - move=> n IH.
      rewrite div2_succ ssrdiv2_succ ssrodd_odd IH.
      reflexivity.
  Qed.

  Lemma modn_muln2_subn1 n : 0 < n -> (n.*2 - 1) %% n = n - 1.
  Proof.
    move=> Hn. rewrite -addnn -(addnBA _ Hn) modnDl.
    apply: modn_small. rewrite subn1 (prednK Hn).
    exact: leqnn.
  Qed.

  Lemma divn_muln2_subn1 n : 0 < n -> (n.*2 - 1) %/ n = 1.
  Proof.
    move=> Hn. move: (divn_eq (n.*2-1) n).
    rewrite (modn_muln2_subn1 Hn) -addnn -{1}(addnBA _ Hn).
    move/eqP => H. rewrite eqn_add2r -{1}(mul1n n) (eqn_pmul2r Hn) in H.
    apply/eqP. rewrite eq_sym. assumption.
  Qed.

  Lemma divn01 x n :
    x < n.*2 -> x %/ n = 0 \/ x %/ n = 1.
  Proof.
    move=> Hx.
    have Hn: n > 0.
    { case: n Hx; first by move=> H; inversion H. move=> n _.
      exact: ltn0Sn. }
    case Hxn: (x < n).
    - rewrite (divn_small Hxn). left; reflexivity.
    - rewrite ltnNge in Hxn. move/negPn: Hxn => Hxn. right.
      rewrite -add1n in Hx. move: (leq_sub2r 1 Hx).
      rewrite addKn => {Hx} Hx.
      move: (leq_div2r n Hx) (leq_div2r n Hxn).
      rewrite divnn Hn /= (divn_muln2_subn1 Hn) => {Hx Hxn} Hx Hxn.
      apply/eqP; rewrite eqn_leq. by rewrite Hx Hxn.
  Qed.

  Lemma odd_divn x n :
    x < n.*2 -> nat_of_bool (odd (x %/ n)) = x %/ n.
  Proof.
    move=> Hx. by case: (divn01 Hx) => ->.
  Qed.

  Lemma odd_divn_eucl x n :
    x < n.*2 ->
    x = odd (x %/ n) * n + x %% n.
  Proof.
    move=> H. rewrite (odd_divn H) -(divn_eq x n). reflexivity.
  Qed.

  Lemma ltn_ltn_addn_divn x y n :
    x < n -> y < n -> (x + y) %/ n = 0 \/ (x + y) %/ n = 1.
  Proof.
    move=> Hx Hy. apply: divn01. rewrite -addnn. exact: (ltn_addn Hx Hy).
  Qed.

  Lemma divn_eq0 n m :
    n %/ m = 0 -> m = 0 \/ n < m.
  Proof.
    move=> Hdivn. move: (divn_eq n m).
    rewrite Hdivn mul0n add0n. move=> Hmodn. case Hm0: (m == 0).
    - left; by rewrite (eqP Hm0).
    - right; rewrite ltnNge. apply/negP => Hmn. rewrite -divn_gt0 in Hmn.
      + rewrite Hdivn in Hmn; by inversion Hmn.
      + rewrite ltn_neqAle eq_sym. move/idP/negP: Hm0.
        move=> H; rewrite H /=. done.
  Qed.

  Lemma divn_gt0_eq0 n m :
    n %/ m = 0 -> m > 0 -> n < m.
  Proof.
    move=> Hdivn Hm.
    case: (divn_eq0 Hdivn).
    - move=> H; rewrite {}H in Hm *. by inversion Hm.
    - by apply.
  Qed.

  Lemma ltn_1_2expnS n :
    1 < 2 ^ n.+1.
  Proof.
    rewrite expnS. apply: leq_pmulr. rewrite expn_gt0. done.
  Qed.

  Lemma modn_muln_modn_l n x y :
    (n %% (x * y)) %% x = n %% x.
  Proof.
    have: (n %% x) = (n %/ (x * y) * (x * y) + n %% (x * y)) %% x.
    { rewrite -(divn_eq n (x * y)). reflexivity. }
    rewrite -modnDm.
    have: (n %/ (x * y) * (x * y)) %% x = 0.
    { rewrite (mulnC x y) mulnA modnMl. reflexivity. }
    move=> ->. rewrite add0n. rewrite modn_mod. move=> <-. reflexivity.
  Qed.

  Lemma modn_muln_modn_r n x y :
    (n %% (x * y)) %% y = n %% y.
  Proof.
    rewrite (mulnC x y). exact: modn_muln_modn_l.
  Qed.

  Lemma expn2_gt0 n : 0 < 2^n.
  Proof.
    by rewrite expn_gt0.
  Qed.

  Lemma expn2_gt1 n : 1 < 2^n.+1.
  Proof.
    rewrite expnS. apply: leq_pmulr. by rewrite expn_gt0.
  Qed.

  Lemma modn_subn n m : m <= n -> n %% m = (n - m) %% m.
  Proof.
    move=> H. apply/eqP. rewrite -(eqn_modDl m).
    rewrite addnC modnDr. rewrite addnC (subnK H). exact: eqxx.
  Qed.

  Lemma mod_sub n m :
    (m <> 0)%coq_nat ->
    (m <= n)%coq_nat -> ((n mod m) = (n - m) mod m)%coq_nat.
  Proof.
    move=> Hm Hmn. rewrite -(Nat.mod_add (n - m) 1 _ Hm).
    rewrite Nat.mul_1_l (Nat.sub_add _ _ Hmn).
    reflexivity.
  Qed.

  Lemma modn_modulo (n m : nat) : m != 0 -> n %% m = Nat.modulo n m.
  Proof.
    move=> Hm0. case H: (n < m)%N.
    - rewrite (modn_small H) Nat.mod_small; first reflexivity.
      exact: (ltn_lt H).
    - move/negP/idP: H; rewrite -leqNgt => H.
      move: m H Hm0. induction n using nat_strong_ind.
      move=> m Hmn Hm0. have Hne: m <> 0 by move/eqP: Hm0; apply.
      rewrite (modn_subn Hmn) (mod_sub Hne (leq_le Hmn)).
      case Hsub: ((n - m) < m)%N.
      + rewrite (modn_small Hsub) (Nat.mod_small _ _ (ltn_lt Hsub)).
        reflexivity.
      + move/negP/idP: Hsub; rewrite -leqNgt => Hsub.
        apply: H.
        * rewrite -lt0n in Hm0. rewrite -{2}(subn0 n). apply: ltn_sub2l.
          -- exact: (ltn_leq_trans Hm0 Hmn).
          -- exact: Hm0.
        * exact: Hsub.
        * exact: Hm0.
  Qed.

  Lemma divn_div (n m : nat) : n %/ m = Nat.div n m.
  Proof.
    case Hm: (m == 0).
    - rewrite (eqP Hm) divn0 /=. reflexivity.
    - move/negP/idP: Hm => Hm. have Hne: (m <> 0) by move/eqP: Hm; apply.
      move: (eq_refl n). rewrite {1}(divn_eq n m).
      rewrite {3}(Nat.div_mod n m Hne).
      rewrite -(modn_modulo _ Hm) -addn_add. rewrite eqn_add2r.
      rewrite -muln_mul mulnC. rewrite -lt0n in Hm. rewrite (eqn_pmul2l Hm).
      move/eqP=> H. exact: H.
  Qed.

End NatLemmas.

(** EQTYPE modules. *)

Module NatEqtype <: EQTYPE.
  Definition t := nat_eqType.
End NatEqtype.

Module OptionNatEqtype <: EQTYPE.
  Module OptionNat := MakeOptionReflectable(NatEqtype).
  Definition t := OptionNat.option_eqType.
End OptionNatEqtype.

(** An ordered type for nat with a Boolean equality in mathcomp. *)

Module NatOrderMinimal <: SsrOrderMinimal.

  Definition t : eqType := nat_eqType.

  Definition eqn : t -> t -> bool := fun x y : t => x == y.

  Definition ltn : t -> t -> bool := fun x y => x < y.

  Global Hint Unfold eqn ltn : core.

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof. exact: ltn_trans. Qed.

  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof. move=> H. by rewrite (ltn_eqF H). Qed.

  Lemma compare (x y : t) : Compare ltn eqn x y.
  Proof.
    case H: (Nat.compare x y).
    - apply: EQ. move: (PeanoNat.Nat.compare_eq_iff x y) => [Hc _].
      apply/eqP. exact: (Hc H).
    - apply: LT. move: (PeanoNat.Nat.compare_lt_iff x y) => [Hc _].
      apply/ltP. exact: (Hc H).
    - apply: GT. move: (PeanoNat.Nat.compare_gt_iff x y) => [Hc _].
      apply/ltP. exact: (Hc H).
  Defined.

End NatOrderMinimal.

Module NatOrder <: SsrOrder := MakeSsrOrder NatOrderMinimal.

Ltac deduce_compare_cases H :=
  match type of H with
  | is_true (_ < _)%N =>
    let H1 := fresh in
    let H2 := fresh in
    let H3 := fresh in
    let H4 := fresh in
    let H5 := fresh in
    (move: (H) => H1; rewrite ltnNge in H1);
    (move: (H1) => H2; rewrite leq_eqVlt negb_or in H2; case/andP: H2=> H2 H3);
    (move/negPf: H3; move/negPf: H2; move/negPf: H1; move=> H1 H2 H3);
    (move: (ltnW H) => H4);
    (move: (ltnW H) => /eqP H5)
  | is_true (_ <= _)%N =>
    let H1 := fresh in
    let H2 := fresh in
    let H3 := fresh in
    (move: (H) => H1; rewrite leqNgt in H1; move/negPf: H1 => H1);
    (move: (H); move/eqP=> H2);
    (move: (H) => H3; rewrite leq_eqVlt in H3)
  | (?n = ?m)%N =>
    let H1 := fresh in
    let H2 := fresh in
    let H3 := fresh in
    let H4 := fresh in
    (move: (ltnn n) => H1; rewrite {2}H in H1);
    (move: (ltnn m) => H2; rewrite -{2}H in H2);
    (move: (leqnn n) => H3; rewrite {2}H in H3);
    (move: (leqnn m) => H4; rewrite -{2}H in H4)
  end.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 comment *)
(* infix_ls is replaced with (x < x1)%R by the coq driver *)

(* Why3 goal *)
Lemma infix_lseq_def : forall (x:R) (y:R), (x <= y)%R <-> ((x < y)%R \/
  (x = y)).
reflexivity.
Qed.

(* Why3 comment *)
(* infix_pl is replaced with (x + x1)%R by the coq driver *)

(* Why3 comment *)
(* prefix_mn is replaced with (-x)%R by the coq driver *)

(* Why3 comment *)
(* infix_as is replaced with (x * x1)%R by the coq driver *)

(* Why3 goal *)
Lemma Assoc : forall (x:R) (y:R) (z:R),
  (((x + y)%R + z)%R = (x + (y + z)%R)%R).
Proof.
exact Rplus_assoc.
Qed.

(* Why3 goal *)
Lemma Unit_def_l : forall (x:R), ((0%R + x)%R = x).
Proof.
exact Rplus_0_l.
Qed.

(* Why3 goal *)
Lemma Unit_def_r : forall (x:R), ((x + 0%R)%R = x).
Proof.
exact Rplus_0_r.
Qed.

(* Why3 goal *)
Lemma Inv_def_l : forall (x:R), (((-x)%R + x)%R = 0%R).
Proof.
exact Rplus_opp_l.
Qed.

(* Why3 goal *)
Lemma Inv_def_r : forall (x:R), ((x + (-x)%R)%R = 0%R).
Proof.
exact Rplus_opp_r.
Qed.

(* Why3 goal *)
Lemma Comm : forall (x:R) (y:R), ((x + y)%R = (y + x)%R).
Proof.
exact Rplus_comm.
Qed.

(* Why3 goal *)
Lemma Assoc1 : forall (x:R) (y:R) (z:R),
  (((x * y)%R * z)%R = (x * (y * z)%R)%R).
Proof.
exact Rmult_assoc.
Qed.

(* Why3 goal *)
Lemma Mul_distr_l : forall (x:R) (y:R) (z:R),
  ((x * (y + z)%R)%R = ((x * y)%R + (x * z)%R)%R).
Proof.
intros x y z.
apply Rmult_plus_distr_l.
Qed.

(* Why3 goal *)
Lemma Mul_distr_r : forall (x:R) (y:R) (z:R),
  (((y + z)%R * x)%R = ((y * x)%R + (z * x)%R)%R).
Proof.
intros x y z.
apply Rmult_plus_distr_r.
Qed.

(* Why3 goal *)
Lemma infix_mn_def : forall (x:R) (y:R), ((x - y)%R = (x + (-y)%R)%R).
reflexivity.
Qed.

(* Why3 goal *)
Lemma Comm1 : forall (x:R) (y:R), ((x * y)%R = (y * x)%R).
Proof.
exact Rmult_comm.
Qed.

(* Why3 goal *)
Lemma Unitary : forall (x:R), ((1%R * x)%R = x).
Proof.
exact Rmult_1_l.
Qed.

(* Why3 goal *)
Lemma NonTrivialRing : ~ (0%R = 1%R).
Proof.
apply not_eq_sym.
exact R1_neq_R0.
Qed.

(* Why3 comment *)
(* inv is replaced with (Reals.Rdefinitions.Rinv x) by the coq driver *)

(* Why3 goal *)
Lemma Inverse : forall (x:R), (~ (x = 0%R)) ->
  ((x * (Reals.Rdefinitions.Rinv x))%R = 1%R).
exact Rinv_r.
Qed.

(* Why3 goal *)
Lemma infix_sl_def : forall (x:R) (y:R),
  ((x / y)%R = (x * (Reals.Rdefinitions.Rinv y))%R).
reflexivity.
Qed.

(* Why3 goal *)
Lemma add_div : forall (x:R) (y:R) (z:R), (~ (z = 0%R)) ->
  (((x + y)%R / z)%R = ((x / z)%R + (y / z)%R)%R).
Proof.
intros.
field.
assumption.
Qed.

(* Why3 goal *)
Lemma sub_div : forall (x:R) (y:R) (z:R), (~ (z = 0%R)) ->
  (((x - y)%R / z)%R = ((x / z)%R - (y / z)%R)%R).
Proof.
intros.
field.
assumption.
Qed.

(* Why3 goal *)
Lemma neg_div : forall (x:R) (y:R), (~ (y = 0%R)) ->
  (((-x)%R / y)%R = (-(x / y)%R)%R).
Proof.
intros.
field.
assumption.
Qed.

(* Why3 goal *)
Lemma assoc_mul_div : forall (x:R) (y:R) (z:R), (~ (z = 0%R)) ->
  (((x * y)%R / z)%R = (x * (y / z)%R)%R).
Proof.
intros x y z _.
apply Rmult_assoc.
Qed.

(* Why3 goal *)
Lemma assoc_div_mul : forall (x:R) (y:R) (z:R), ((~ (y = 0%R)) /\
  ~ (z = 0%R)) -> (((x / y)%R / z)%R = (x / (y * z)%R)%R).
Proof.
intros x y z (Zy, Zz).
unfold Rdiv.
rewrite Rmult_assoc.
now rewrite Rinv_mult_distr.
Qed.

(* Why3 goal *)
Lemma assoc_div_div : forall (x:R) (y:R) (z:R), ((~ (y = 0%R)) /\
  ~ (z = 0%R)) -> ((x / (y / z)%R)%R = ((x * z)%R / y)%R).
Proof.
intros x y z (Zy, Zz).
field.
now split.
Qed.

(* Why3 goal *)
Lemma Refl : forall (x:R), (x <= x)%R.
Proof.
exact Rle_refl.
Qed.

(* Why3 goal *)
Lemma Trans : forall (x:R) (y:R) (z:R), (x <= y)%R -> ((y <= z)%R ->
  (x <= z)%R).
Proof.
exact Rle_trans.
Qed.

(* Why3 goal *)
Lemma Antisymm : forall (x:R) (y:R), (x <= y)%R -> ((y <= x)%R -> (x = y)).
Proof.
exact Rle_antisym.
Qed.

(* Why3 goal *)
Lemma Total : forall (x:R) (y:R), (x <= y)%R \/ (y <= x)%R.
Proof.
intros x y.
destruct (Rle_or_lt x y) as [H|H].
now left.
right.
now apply Rlt_le.
Qed.

(* Why3 goal *)
Lemma ZeroLessOne : (0%R <= 1%R)%R.
Proof.
exact Rle_0_1.
Qed.

(* Why3 goal *)
Lemma CompatOrderAdd : forall (x:R) (y:R) (z:R), (x <= y)%R ->
  ((x + z)%R <= (y + z)%R)%R.
Proof.
intros x y z.
exact (Rplus_le_compat_r z x y).
Qed.

(* Why3 goal *)
Lemma CompatOrderMult : forall (x:R) (y:R) (z:R), (x <= y)%R ->
  ((0%R <= z)%R -> ((x * z)%R <= (y * z)%R)%R).
Proof.
intros x y z H Zz.
now apply Rmult_le_compat_r.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
lfind.  rewrite <- IHx1.
Admitted.

Theorem drop_assoc : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  + rewrite 2 drop_Cons_assoc. reflexivity.
  + rewrite 3 drop_Nil. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (w : natural) (z : lst), eq (drop w (drop x (drop y z))) (drop y (drop x (drop w z))).
Proof.
  intros.
  rewrite (drop_assoc w x).
  rewrite (drop_assoc w y).
  rewrite (drop_assoc x y).
  reflexivity.
Qed.


Record Cat := mkCat
  { Obj  : Type
  ; Hom  : Obj -> Obj -> Type
  ; id   : forall(x : Obj), Hom x x
  ; comp : forall{x y z : Obj}, forall(f : Hom y z), forall(g : Hom x y), Hom x z
  ; assoc_l : forall{w x y z : Obj}, forall(f : Hom y z), forall(g : Hom x y), forall(h : Hom w x), comp (comp f g) h = comp f (comp g h)
  ; assoc_r : forall{w x y z : Obj}, forall(f : Hom y z), forall(g : Hom x y), forall(h : Hom w x), comp f (comp g h) = comp (comp f g) h
  ; id_l : forall{x y : Obj}, forall(f : Hom x y), comp (id y) f = f
  ; id_r : forall{x y : Obj}, forall(f : Hom x y), comp f (id x) = f
  ; id_id : forall(x : Obj), comp (id x) (id x) = id x
  ; homK : forall{x y : Obj}, forall{f : Hom x y}, forall(p : f = f), p = eq_refl f
  }.

Arguments Hom {c} x y.
Arguments id {c} x.
Arguments comp {c x y z} f g.
Arguments assoc_l {c w x y z} f g h.
Arguments assoc_r {c w x y z} f g h.
Arguments id_l {c x y} f.
Arguments id_r {c x y} f.
Arguments id_id {c} x.
Arguments homK {c x y f} p.

Definition Iso {C : Cat} (x y : Obj C) : Prop :=
  exists(f : Hom x y), exists(g : Hom y x), comp f g = id y /\ comp g f = id x.

Lemma equal_implies_iso {C : Cat} {x y : Obj C} :
  x = y -> Iso x y.
Proof.
  intro Heq. unfold Iso. destruct Heq.
  exists (id x). exists (id x). split; exact (id_id x).
Qed.

Record Functor (A B : Cat) := mkFun
  { Fobj  : Obj A -> Obj B
  ; Fmph  : forall{x y : Obj A}, Hom x y -> Hom (Fobj x) (Fobj y)
  ; Fid   : forall(x : Obj A), Fmph (id x) = id (Fobj x)
  ; Fcomp : forall{x y z : Obj A}, forall(f : Hom y z), forall(g : Hom x y), Fmph (comp f g) = comp (Fmph f) (Fmph g)
  }.

Record PreCategory := mkPCat
  { pObj  : Type
  ; pHom  : pObj -> pObj -> Type
  ; pid   : forall(x : pObj), pHom x x
  ; pcomp : forall{x y z : pObj}, forall(f : pHom y z), forall(g : pHom x y), pHom x z
  ; passoc_l : forall{w x y z : pObj}, forall(f : pHom y z), forall(g : pHom x y), forall(h : pHom w x), pcomp (pcomp f g) h = pcomp f (pcomp g h)
  ; pid_l : forall{x y : pObj}, forall(f : pHom x y), pcomp (pid y) f = f
  ; pid_r : forall{x y : pObj}, forall(f : pHom x y), pcomp f (pid x) = f
  ; phomK : forall{x y : pObj}, forall{f : pHom x y}, forall(p : f = f), p = eq_refl f
  }.
Definition fromPreCat (C : PreCategory) : Cat :=
  mkCat
    (pObj C)
    (pHom C)
    (pid C)
    (fun x y z => @pcomp C x y z)
    (fun w x y z => @passoc_l C w x y z)
    (fun w x y z f g h => eq_sym (@passoc_l C w x y z f g h))
    (fun x y => @pid_l C x y)
    (fun x y => @pid_r C x y)
    (fun x => @pid_l C x x (pid C x))
    (fun x y f => @phomK C x y f).

Axiom funext : forall{A B : Type}, forall(f g : A -> B), (forall x, f x = g x) -> f = g.
Record S := mkS
  { Stype : Type
  ; Sk    : forall{x : Stype}, forall(p : x = x), p = eq_refl x
  }.
Lemma Sfun (A B : S) : S.
Proof.
  apply (mkS (Stype A -> Stype B)). intros f p.


Require Import FunctionalExtensionality.

Section RealLine.

    Variable R : Set.

    Variable add : R -> R -> R.
    Variable zero : R.
    Hypothesis add_zero_l : forall x, add zero x = x.
    Hypothesis add_comm   : forall x y, add x y = add y x.

    Lemma add_zero_r : forall x, add x zero = x.
      intro x.
      transitivity (add zero x).
      apply add_comm.
      apply add_zero_l.
    Qed.

    Hypothesis add_assoc  : forall x y z, add x (add y z) = add (add x y) z.
    Variable opp : R -> R.
    Hypothesis add_opp_eq_zero : forall x, add x (opp x) = zero.

    Variable mul : R -> R -> R.
    Variable one : R.
    Hypothesis mul_one_l  : forall x, mul one x = x.
    Hypothesis mul_comm   : forall x y, mul x y = mul y x.
    Hypothesis mul_assoc  : forall x y z, mul x (mul y z) = mul (mul x y) z.
    Variable inv : R -> R.
    Hypothesis mul_inv_eq_one : forall x, x = zero \/ mul x (inv x) = one.

    Hypothesis zero_neq_one : ~ (zero = one).

    Hypothesis distr : forall x y z, mul x (add y z) = add (mul x y) (mul x z).

    Variable rlt : R -> R -> Prop.

    Hypothesis ord_trich : forall x y, rlt x y \/ x = y \/ rlt y x.
    Hypothesis ord_trich_lt_not_eq : forall x y, rlt x y -> ~(x = y).
    Hypothesis ord_trich_lt_not_gt : forall x y, rlt x y -> ~(rlt y x).
    Hypothesis ord_trich_eq_not_lt : forall x y, x = y -> ~(rlt x y).
    Hypothesis ord_trans : forall x y z, rlt x y -> rlt y z -> rlt x z.
    Hypothesis ord_add : forall x y z, rlt x y -> rlt (add x z) (add y z).
    Hypothesis ord_mul : forall x y z, rlt x y -> rlt z zero -> rlt (mul x z) (mul y z).

    (* Slopes at 0 -- axioms *)

    Variable slope0 : (R -> R) -> R.

    Let is_slope0 (f : R -> R) (sl : R) : Prop :=
        forall eps, mul eps eps = zero ->
          f eps = add (f zero) (mul sl eps).

    Hypothesis koch_lauvere0 : forall f : R -> R, is_slope0 f (slope0 f).

    Hypothesis slope0_unique :
      forall f : R -> R,
        forall sl, is_slope0 f sl -> sl = slope0 f.

    (* Slopes at X0 -- lemmas *)

    Let slide (f : R -> R) (x0 : R) : R -> R := fun x => f (add x x0).

    Let is_slopeX0 (f : R -> R) (sl : R) (x0 : R) : Prop :=
        forall eps, mul eps eps = zero ->
          f (add x0 eps) = add (f x0) (mul sl eps).

    Let slopeX0 (f : R -> R) (x0 : R) := slope0 (slide f x0).

    Lemma koch_lauvereX0 : forall f : R -> R, forall x0 : R,
      is_slopeX0 f (slopeX0 f x0) x0.
    Proof.
      intros f x0.
      intros eps eps_nil.
      replace (f (add x0 eps)) with (slide f x0 eps).
        unfold slopeX0.
        replace (f x0) with (slide f x0 zero).
        apply koch_lauvere0. assumption.
        unfold slide. apply f_equal. apply add_zero_l.
        compute. apply f_equal. apply add_comm.
    Qed.

    Lemma slopeX0_unique : forall f : R -> R, forall sl: R, forall x0 : R,
      is_slopeX0 f sl x0 -> sl = slopeX0 f x0.
    Proof.
      intros f sl x0 is_sl.
      unfold is_slopeX0 in is_sl.
      unfold slopeX0.
      assert (is_slope0 (slide f x0) sl).
      intro eps.
      specialize is_sl with eps.
      intro eps_nil.
      replace (slide f x0 zero) with (f x0).
        unfold slide. rewrite add_comm. apply is_sl. assumption.
        compute; apply f_equal; symmetry; apply add_zero_l.
      apply slope0_unique. assumption.
    Qed.

    (* Areas *)

    Let two := add one one.
    Let half := inv two.
    Let halve x := mul x half.
    Let is_area (area : (R -> R) -> R -> R) : Prop :=
      forall f x eps, mul eps eps = zero ->
        area f (add x eps) =
        add (area f x) (halve
                          (mul eps
                               (add (f x) (f (add x eps))))).

    Lemma two_not_zero : not (add one one = zero).
      intro H.
      symmetry in H.
      apply ord_trich_eq_not_lt in H.
      assert (rlt zero one).
      replace one (

    Lemma halve_x_plus_x :
      forall x, halve (add x x) = x.
      intros.
      unfold halve, half, two.
      replace (add x x) with (mul x (add one one)).
      rewrite <- mul_assoc.
      assert (mul (add one one) (inv (add one one)) = one).
      destruct (mul_inv_eq_one (add one one)).

      rewrite <- mul_inv_eq_one.

    Lemma fund_thm_calc1 :
      forall a f, is_area a -> slopeX0 (a f) = f.
    Proof.
      intros a f is_a.
      apply functional_extensionality.
      intro x0.
      symmetry. apply slopeX0_unique.
      unfold is_slopeX0.
      intros eps eps_nil.

      replace (add (a f x0) (mul (f x0) eps)) with
              (add (a f x0)
                (halve
                  (mul eps
                    (add (f x0) (f (add x0 eps)))))).
      apply is_a.
      apply eps_nil.

      assert (
        (halve (mul eps (add (f x0) (f (add x0 eps)))))
        =
        (mul (f x0) eps)
      ).
      assert (
        (mul eps (add (f x0)
                      (f (add x0 eps))))
        =
        (add (mul (f x0) eps)
             (mul (f x0) eps))
      ).
      admit.
      rewrite H.

      apply f_equal. assumption.

End RealLine.


(** * Unitality *)

From DEZ Require Export
  Init.

(** ** Left-Unital Element of a Binary Function *)

Fail Fail Class IsUnlElemBinFnL (A B C : Type) (X : C -> C -> Prop)
  (x : B) (y : C) (k : B -> A -> C) : Prop :=
  unl_elem_bin_fn_l (z : A) : X (k x z) y.

(** ** Right-Unital Element of a Binary Function *)

Fail Fail Class IsUnlElemBinFnR (A B C : Type) (X : C -> C -> Prop)
  (x : B) (y : C) (k : A -> B -> C) : Prop :=
  unl_elem_bin_fn_r (z : A) : X (k z x) y.

(** ** Left-Unital Element of a Left Action *)
(** ** Left-Unital Element of an Action *)

Class IsUnlElemActL (A B : Type) (X : B -> B -> Prop)
  (x : A) (al : A -> B -> B) : Prop :=
  unl_elem_act_l (a : B) : X (al x a) a.

(** ** Right-Unital Element of a Right Action *)
(** ** Right-Unital Element of an Action *)

Class IsUnlElemActR (A B : Type) (X : B -> B -> Prop)
  (x : A) (ar : B -> A -> B) : Prop :=
  unl_elem_act_r (a : B) : X (ar a x) a.

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (x : A) (al : A -> B -> B).

(** A left-unital element of an action is a special case
    of a right-unital element of its flipped version. *)

#[local] Instance unl_elem_act_l_is_unl_elem_act_r_flip
  `{!IsUnlElemActL X x al} : IsUnlElemActR X x (flip al).
Proof. intros a. unfold flip in *. eauto. Qed.

#[local] Instance unl_elem_act_r_flip_is_unl_elem_act_l
  `{!IsUnlElemActR X x (flip al)} : IsUnlElemActL X x al.
Proof. intros a. unfold flip in *. eauto. Qed.

End Context.

(** ** Left-Unital Element of a Binary Operation *)

(** This has the same shape as [Z.add_0_l]. *)

Class IsUnlElemL (A : Type) (X : A -> A -> Prop)
  (x : A) (k : A -> A -> A) : Prop :=
  unl_elem_l (y : A) : X (k x y) y.

(** ** Right-Unital Element of a Binary Operation *)

(** This has the same shape as [Z.add_0_r]. *)

Class IsUnlElemR (A : Type) (X : A -> A -> Prop)
  (x : A) (k : A -> A -> A) : Prop :=
  unl_elem_r (y : A) : X (k y x) y.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (x : A) (k : A -> A -> A).

(** A left-unital element of a binary operation is a special case
    of a right-unital element of its flipped version. *)

#[local] Instance unl_elem_l_is_unl_elem_r_flip
  `{!IsUnlElemL X x k} : IsUnlElemR X x (flip k).
Proof. intros y. unfold flip in *. eauto. Qed.

#[local] Instance unl_elem_r_flip_is_unl_elem_l
  `{!IsUnlElemR X x (flip k)} : IsUnlElemL X x k.
Proof. intros y. unfold flip in *. eauto. Qed.

End Context.

(** ** Unital Element of a Binary Operation *)

Class IsUnlElem (A : Type) (X : A -> A -> Prop)
  (x : A) (k : A -> A -> A) : Prop := {
  unl_elem_is_unl_elem_l :> IsUnlElemL X x k;
  unl_elem_is_unl_elem_r :> IsUnlElemR X x k;
}.


Require Export A009prop.

Inductive ex (X:Type) (P : X->Prop) : Prop :=
  ex_intro : forall (witness:X), P witness -> ex X P.

Notation "'exists' x , p" := (ex _ (fun x => p))
  (at level 200, x ident, right associativity) : type_scope.
Notation "'exists' x : X , p" := (ex _ (fun x:X => p))
  (at level 200, x ident, right associativity) : type_scope.

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intros.
  inversion H as [m].
  exists (2 + m).
  apply H0.
Qed.

Lemma exists_example_3 :
  exists (n:nat), even n /\ beautiful n.
Proof.
  exists 8. split. constructor. apply b_sum with (n:=3)(m:=5); constructor.
Qed.

(* ex nat (fun n => beautiful (S n)). *)
(* Means that exists a n:nat, beautiful S n.
*)

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros. intro.
  inversion H0. apply H1. apply H.
Qed.

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  unfold excluded_middle.
  intros.
  assert (P x \/ ~P x). apply H.
  inversion H1. assumption.
  elimtype False. (* Ex falso quodlibet *)

  apply H0.
  exists (x). assumption.
Qed.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros.
  split; intro.
  inversion H. inversion H0.
    left. exists witness. assumption.
    right. exists witness. assumption.

  inversion H; inversion H0.
    exists witness. left. assumption.
    exists witness. right. assumption.
Qed.

Inductive sumbool (A B : Prop) : Set :=
 | left : A -> sumbool A B
 | right : B -> sumbool A B.

Notation "{ A } + { B }" := (sumbool A B) : type_scope.

Theorem eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  induction n.
  destruct m. left. reflexivity.
              right. intro. inversion H.
  destruct m. right. intro. inversion H.
              destruct IHn with m.
                left. apply f_equal. assumption.
                right. intro. inversion H. intuition.
Qed.

Definition override' {X: Type} (f: nat->X) (k:nat) (x:X) : nat->X:=
  fun (k':nat) => if eq_nat_dec k k' then x else f k'.

Theorem override_same' : forall (X:Type) x1 k1 k2 (f : nat->X),
  f k1 = x1 ->
  (override' f k1 x1) k2 = f k2.
Proof.
  unfold override'. intros.
  destruct (eq_nat_dec k1 k2).
    rewrite <- H. apply f_equal. assumption.
    reflexivity.
Qed.

Theorem override_shadow' : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  (override' (override' f k1 x2) k1 x1) k2 = (override' f k1 x1) k2.
Proof.
  unfold override'. intros.
  destruct (eq_nat_dec k1 k2).
    reflexivity.
    reflexivity.
Qed.

Inductive all {X : Type} (P : X -> Prop) : list X -> Prop :=
  | all0 : all P []
  | allI : forall x xs, P x -> all P xs -> all P (x :: xs).

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
    | [] => true
    | x :: l' => andb (test x) (forallb test l')
  end.

Theorem forallb_true_imp_all :
  forall {X} (p : X -> bool) l, forallb p l = true ->
                                all (fun x => p x = true) l.
Proof.
  intros.
  induction l.
    apply all0.
    simpl in H.
      destruct (p x) eqn:px.
      assert (forallb p l = true).
      destruct (forallb p l). reflexivity. inversion H.
      apply IHl in H0. apply allI. assumption. assumption.

      inversion H.
Qed.

Inductive appears_in {X:Type} (a:X) : list X -> Prop :=
  | ai_here : forall l, appears_in a (a::l)
  | ai_later : forall b l, appears_in a l -> appears_in a (b::l).

Lemma appears_in_app : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x (xs ++ ys) -> appears_in x xs \/ appears_in x ys.
Proof.
  intros.
  induction xs. simpl in H. right. assumption.
  inversion H. left. constructor.
  apply IHxs in H1. inversion H1. subst.
    left. constructor. assumption.
    right. assumption.
Qed.

Lemma app_appears_in : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x xs \/ appears_in x ys -> appears_in x (xs ++ ys).
Proof.
  intros.
  inversion H.
  induction H0.
  apply ai_here.
  simpl. apply ai_later.
  apply IHappears_in. left. assumption.

  induction xs. simpl. assumption.
  simpl. apply ai_later. apply IHxs. right. assumption.
Qed.

Definition disjoint {X} (xs ys : list X) : Prop :=
  forall a, appears_in a xs -> ~appears_in a ys.

Inductive no_repeats {X} : list X -> Prop :=
  | nr_null : no_repeats []
  | nr_cons : forall x xs, no_repeats xs -> ~(appears_in x xs) -> no_repeats (x::xs).

Goal forall {X} (xs ys : list X),
       no_repeats xs ->
       no_repeats ys ->
       disjoint xs ys ->
       no_repeats (xs ++ ys).
Proof.
  intros X xs ys Hxs Hys Hdisj.
  generalize dependent ys.
  induction Hxs.

  Case "nr_null []". intros.
  assumption.

  Case "nr_cons, xs = x::xs".
  intros ys Hys Hdisj.
  unfold disjoint in Hdisj.
  simpl.
  apply nr_cons.
  apply IHHxs. assumption.
  unfold disjoint. intros. apply Hdisj. apply ai_later. assumption.

  intro. apply appears_in_app in H0. inversion H0.

  apply H in H1. inversion H1. inversion H1. subst.
  unfold not in Hdisj. apply Hdisj with x. apply ai_here.
  assumption.

  subst.
  unfold not in Hdisj. apply Hdisj with x. apply ai_here. assumption.
Qed.

Inductive nostutter: list nat -> Prop :=
  | ns0 : nostutter []
  | ns1 : forall x, nostutter [x]
  | nsc : forall x x' xs, nostutter (x'::xs) -> x' <> x -> nostutter (x::x'::xs).

Example test_nostutter_1: nostutter [3;1;4;1;5;6].
Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_2: nostutter [].
Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_3: nostutter [5].
Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_4: not (nostutter [3;1;1;4]).
Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction H5; auto.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros.
  induction l1. reflexivity.
  simpl. rewrite IHl1. reflexivity.
Qed.

Lemma appears_in_app_split : forall (X:Type) (x:X) (l:list X),
  appears_in x l ->
  exists l1, exists l2, l = l1 ++ (x::l2).
Proof.
  intros.
  induction H.

  exists []. simpl. exists l. reflexivity.
  inversion IHappears_in as [xs0]. inversion H0 as [xs1].
  rewrite H1. exists (b :: xs0). simpl. exists xs1. reflexivity.
Qed.

(* Inductive no_repeats {X} : list X -> Prop := *)
(*   | nr_null : no_repeats [] *)
(*   | nr_cons : forall x xs, no_repeats xs -> ~(appears_in x xs) -> no_repeats (x::xs). *)

Inductive repeats {X:Type} : list X -> Prop :=
  | rp_here  : forall x xs, appears_in x xs -> repeats (x :: xs)
  | rp_later : forall x xs, repeats xs -> repeats (x :: xs).

Theorem pigeonhole_principle: forall (X:Type) (l1 l2:list X),
   excluded_middle ->
   (forall x, appears_in x l1 -> appears_in x l2) ->
   lt (length l2) (length l1) ->
   repeats l1.
Proof.
  unfold lt.
  induction l1 as [|x xs]. intros. inversion H1.
  intros l2 Hem Happ Hlen.
  destruct Hem with (appears_in x xs).
  apply rp_here. assumption.
  (*  so tough... i wanna give it up... 好難QAQ... *)
Admitted.

(*
Lemma appears_in_app_split : forall (X:Type) (x:X) (l:list X),
  appears_in x l ->
  exists l1, exists l2, l = l1 ++ (x::l2).
*)


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : common mathematical hierarchy structure by Module Type
  author    : ZhengPu Shi
  date      : 2021.05

  refrence  :
  1. https://en.wikipedia.org/wiki/Ring_(mathematics)

  remark    :
  1. The operations or properties below are not needed by ring structure,
     just for convenient.

        Aeqb, Aeqdec, Aeqb_true_iff, Aeqb_false_iff

     We may construct more elegent algebra structre use Typeclasses.

*)

From Coq Require Export Ring Field.
From FCS Require Export BasicConfig.
From FCS Require ZExt QcExt RExt RAST.

(* ######################################################################### *)
(** * Scope of element *)

(** New scope for field. *)
Declare Scope A_scope.
Delimit Scope A_scope with A.
Open Scope A_scope.

(* ######################################################################### *)
(** * Ring Structure *)

(** ** Ring Signature *)
Module Type RingSig.

  (** Carrier and operations *)
  Parameter A : Type.   (* Carrier Type *)
  Parameter A0 : A.     (* Additive unit element *)
  Parameter A1 : A.     (* Multiplicative unit element *)
  Parameter Aadd : A -> A -> A.    	(* Addition operation *)
  Parameter Amul : A -> A -> A.     (* Multiplication operation *)
  Parameter Aopp : A -> A.          (* Additive inverse *)
  Parameter Aeqb : A -> A -> bool.

  (** New scope, and notations *)
  Bind Scope A_scope with A A0 A1 Aadd Amul Aopp Aeqb.

  (** Notations for carrier operations *)
  Notation  "a =? b"    := (Aeqb a b)         : A_scope.
  Infix     "+"         := Aadd               : A_scope.
  Infix     "*"         := Amul               : A_scope.
  Notation  "- a"       := (Aopp a)           : A_scope.
  Notation  Asub        := (fun x y => x + -y).
  Infix     "-"         := Asub               : A_scope.

  (** Equality is decidable *)
  Parameter Aeqdec : forall (x y : A), {x = y} + {x <> y}.

  (** Reflection of Aeq and Aeqb *)
  Parameter Aeqb_true_iff : forall x y, (x =? y = true) <-> x = y.
  Parameter Aeqb_false_iff : forall x y, (x =? y = false) <-> (x <> y).

  (** Ring tactic requirement *)
  Parameter Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp eq.
  Add Ring Ring_thy_inst : Ring_thy.

End RingSig.

(** ** Ring theory *)

(** Although ring and field tactic is enough automatic, but some cases we also
  need to manually rewrite. So, we gather and added lots of properties for
  Ring structure. Thus, no matter what the carrier is, the unified name can be
  used always. *)
Module RingThy (E : RingSig).
  Export E.
  Notation "0" := A0.
  Notation "1" := A1.
  Infix "+" := Aadd.
  Notation "- x" := (Aopp x).
  Notation "a - b" := (a + (-b)).

  Lemma add_comm : forall a b : A, a + b = b + a.
  Proof. intros. ring. Qed.

  Lemma add_assoc : forall a b c : A, (a + b) + c = a + (b + c).
  Proof. intros. ring. Qed.

  Lemma add_0_l : forall a : A, 0 + a = a.
  Proof. intros. ring. Qed.

  Lemma add_0_r : forall a : A, a + 0 = a.
  Proof. intros. ring. Qed.

  Lemma add_opp_l : forall a : A, -a + a = 0.
  Proof. intros. ring. Qed.

  Lemma add_opp_r : forall a : A, a - a = 0.
  Proof. intros. ring. Qed.

  Lemma opp_opp : forall a : A, - - a = a.
  Proof. intros. ring. Qed.

  Lemma add_cancel_l : forall a b1 b2 : A, a + b1 = a + b2 -> b1 = b2.
  Proof.
    intros.
    rewrite <- (add_0_l b1).
    rewrite <- (add_0_l b2).   (* 0 + b1 = 0 + b2  *)
    rewrite <- (add_opp_l a).  (* -a + a + b1 = -a + a + b1 *)
    rewrite ?add_assoc.        (* -a + (a + b1) = -a + (a + b2) *)
    rewrite H. reflexivity.
  Qed.

  Lemma add_cancel_r : forall a1 a2 b : A, a1 + b = a2 + b -> a1 = a2.
  Proof.
    intros.
    rewrite <- (add_0_r a1).
    rewrite <- (add_0_r a2).
    rewrite <- (add_opp_r b).
    rewrite <- ?add_assoc.
    rewrite H. reflexivity.
  Qed.

End RingThy.

(** ** Ring on Z *)
Module RingZ.

  Export ZArith.
  (* Open Scope Z. *)

  Module Export RingDefZ : RingSig
    with Definition A := Z
    with Definition A0 := 0%Z
    with Definition A1 := 1%Z
    with Definition Aadd := Z.add
    with Definition Amul := Z.mul
    with Definition Aopp := Z.opp
    with Definition Aeqb := Z.eqb
    .

    Definition A := Z.
    Definition A0 := 0%Z.
    Definition A1 := 1%Z.
    Definition Aadd := Z.add.
    Definition Amul := Z.mul.
    Definition Aopp := Z.opp.
    Definition Aeqb := Z.eqb.

    Definition Aeqdec := Z.eq_dec.
    Definition Aeqb_true_iff := Z.eqb_eq.
    Definition Aeqb_false_iff := Z.eqb_neq.

    Definition Ring_thy : ring_theory A0 A1 Aadd Amul Z.sub Aopp eq.
      constructor; intros; try reflexivity.
      apply Zplus_comm.
      apply Zplus_assoc.
      apply Z.mul_1_l.
      apply Z.mul_comm.
      apply Z.mul_assoc.
      apply Z.mul_add_distr_r.
      apply Z.add_opp_diag_r.
    Defined.

    Add Ring Ring_thy_inst : Ring_thy.

  End RingDefZ.

  Module Export RingThyZ := RingThy RingDefZ.

End RingZ.

(** ** Test for Ring on Z *)

Module RingZ_test.

  Import RingZ.

  Example ex2 : forall a b c d : A,
    (a + b) * (c + d) = a * c + a * d + c * b + b * d.
  Proof.
    intros. ring. Qed.

End RingZ_test.

(** ** Ring on Q *)

Module RingQ.

  Export QExt.

  (* Open Scope Q_scope. *)
  Module Export RingDefQ : RingSig
    with Definition A := Q
    with Definition A0 := 0
    with Definition A1 := 1
    with Definition Aadd := Qplus
    with Definition Amul := Qmult
    with Definition Aopp := Qopp
    with Definition Aeqb := Qeqb
    .

    Definition A := Q.
    Definition A0 := 0.
    Definition A1 := 1.
    Definition Aadd := Qplus.
    Definition Amul := Qmult.
    Definition Aopp := Qopp.
    Definition Aeqb := Qeqb.
    Definition Aeqdec := Qeqdec.
    Definition Aeqb_true_iff := Qeqb_true_iff.
    Definition Aeqb_false_iff := Qeqb_false_iff.

    (** Ring Theory *)

    Definition Ring_thy : ring_theory A0 A1 Aadd Amul Qminus Aopp eq.
      constructor; intros; try reflexivity; try apply Qeq_iff_eq.
      apply Qplus_0_l.
      apply Qplus_comm.
      apply Qplus_assoc.
      apply Qmult_1_l.
      apply Qmult_comm.
      apply Qmult_assoc.
      apply Qmult_plus_distr_l.
      apply Qplus_opp_r.
    Defined.

    Add Ring Ring_thy_inst : Ring_thy.

  End RingDefQ.

End RingQ.

(** ** Test for Ring on Q *)

Module RingQ_test.

  Import RingQ.
  Open Scope A_scope.

  Example ex2 : forall a b c d : A,
    (a + b) * (c + d) = a * c + a * d + c * b + b * d.
  Proof.
    intros. ring. Qed.

End RingQ_test.

(** ** Ring on Qc *)

Module RingQc.

  Export QcExt.
  (* Open Scope Qc_scope. *)

  Module Export RingDefQc : RingSig
    with Definition A := Qc
    with Definition A0 := 0
    with Definition A1 := 1
    with Definition Aadd := Qcplus
    with Definition Amul := Qcmult
    with Definition Aopp := Qcopp
    with Definition Aeqb := Qceqb
    .

    Definition A := Qc.
    Definition A0 := 0.
    Definition A1 := 1.
    Definition Aadd := Qcplus.
    Definition Amul := Qcmult.
    Definition Aopp := Qcopp.
    Definition Aeqb := Qceqb.
    Definition Aeqdec := Qceqdec.
    Definition Aeqb_true_iff := Qceqb_true_iff.
    Definition Aeqb_false_iff := Qceqb_false_iff.

    (** Ring Theory *)

    Definition Ring_thy : ring_theory A0 A1 Aadd Amul Qcminus Aopp eq.
      constructor; intros; try reflexivity.
      apply Qcplus_0_l.
      apply Qcplus_comm.
      apply Qcplus_assoc.
      apply Qcmult_1_l.
      apply Qcmult_comm.
      apply Qcmult_assoc.
      apply Qcmult_plus_distr_l.
      apply Qcplus_opp_r.
    Defined.

    Add Ring Ring_thy_inst : Ring_thy.

  End RingDefQc.

End RingQc.

(** ** Test for Ring on Qc *)

Module RingQc_test.

  Import RingQc.
  Open Scope A_scope.

  Example ex2 : forall a b c d : A,
    (a + b) * (c + d) = a * c + a * d + c * b + b * d.
  Proof.
    intros. ring. Qed.

End RingQc_test.

(** ** Ring on R *)

Module RingR.

  Export Reals RExt.
  Open Scope R.

  Module Export RingDefR : RingSig
    with Definition A := R
    with Definition A0 := R0
    with Definition A1 := R1
    with Definition Aadd := Rplus
    with Definition Amul := Rmult
    with Definition Aopp := Ropp
    with Definition Aeqb := Reqb
    .

    Definition A := R.
    Definition A0 := R0.
    Definition A1 := R1.
    Definition Aadd := Rplus.
    Definition Amul := Rmult.
    Definition Aopp := Ropp.

    (** Ring Theory *)

    Definition Ring_thy : ring_theory A0 A1 Aadd Amul Rminus Aopp eq.
      constructor; intros; cbv; ring. Defined.

    Add Ring Ring_thy_inst : Ring_thy.

    Definition Aeqb r1 r2 := Reqb r1 r2.
    Definition Aeqdec := Req_EM_T.
    Definition Aeqb_true_iff := Reqb_true_iff.
    Definition Aeqb_false_iff := Reqb_false_iff.

  End RingDefR.

End RingR.

(** ** Test for Ring on R *)

Module RingR_test.

  Import RingR.
  Open Scope A_scope.

  Example ex2 : forall a b c d : A,
    (a + b) * (c + d) = (a * c + a * d + c * b + b * d).
  Proof.
    intros. ring. Qed.

End RingR_test.

(** ** Ring on T *)

Module RingT.

  Export RAST.
  Open Scope T.

  Module Export RingDefT : RingSig
    with Definition A := T
    with Definition A0 := T0
    with Definition A1 := T1
    with Definition Aadd := Tadd
    with Definition Amul := Tmul
    with Definition Aopp := Topp
    with Definition Aeqb := Teqb
    .

    Definition A := T.
    Definition A0 := T0.
    Definition A1 := T1.
    Definition Aadd := Tadd.
    Definition Amul := Tmul.
    Definition Aopp := Topp.

    (** Ring Theory *)

    Definition Ring_thy := T_ring.
    Add Ring Ring_thy_inst : Ring_thy.

    Definition Aeqb r1 r2 := Teqb r1 r2.
    Definition Aeqdec := Teqdec.
    Axiom Teqb_true_iff : forall x y : T, (x =? y)%T = true <-> x = y.
    Axiom Teqb_false_iff : forall x y : T, (x =? y)%T = false <-> x <> y.
    Definition Aeqb_true_iff := Teqb_true_iff.
    Definition Aeqb_false_iff := Teqb_false_iff.

  End RingDefT.

End RingT.

(** ** Test for Ring on T *)

Module RingT_test.

  Import RingT.

  Open Scope T.
  Example ex1 : forall a b c d : T,
    (a + b) * (c + d) = a * c + a * d + c * b + b * d.
  Proof. intros. ring. Qed.

  Open Scope A_scope.
  Example ex2 : forall a b c d : A,
    (a + b) * (c + d) = (a * c + a * d + c * b + b * d).
  Proof.
    intros. ring. Qed.

End RingT_test.

(* ######################################################################### *)
(** * Field Signature *)

(** ** Signature for field *)
Module Type FieldSig <: RingSig.

  (** Carrier *)
  Parameter A : Type.

  (** Operations *)
  Parameter A0 A1 : A.
  Parameter Aadd Amul : A -> A -> A.
  Parameter Aopp Ainv : A -> A.
  Parameter Aeqb : A -> A -> bool.

  (** Notations *)
  Notation "0" := A0 : A_scope.
  Notation "1" := A1 : A_scope.
  Infix "+" := Aadd : A_scope.
  Infix "*" := Amul : A_scope.
  Notation "- a" := (Aopp a) : A_scope.
  Notation "/ a" := (Ainv a) : A_scope.
  Notation Asub := (fun x y => x + -y).
  Notation Adiv := (fun x y => x * /y).
  Infix "-" := Asub : A_scope.
  Infix "/" := Adiv : A_scope.
  Notation "a =? b" := (Aeqb a b) (at level 70) : A_scope.

  (** Bind something to the scope *)
  Bind Scope A_scope with A A0 A1 Aadd Amul Aopp Ainv Aeqb.

  (** Properties *)

  (** Equality is decidable *)
  Parameter Aeqdec : forall (x y : A), {x = y} + {x <> y}.

  (** Reflection of Aeq and Aeqb *)
  Parameter Aeqb_true_iff : forall x y, (x =? y = true) <-> x = y.
  Parameter Aeqb_false_iff : forall x y, (x =? y = false) <-> (x <> y).

  (** 1 <> 0. *)
  Parameter A1_neq_A0 : A1 <> A0.

  (** Ring theory *)
  Parameter Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp eq.
  Add Ring Ring_thy_inst : Ring_thy.

  (** Field Theory *)
  Parameter Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv eq.
  Add Field Field_thy_inst : Field_thy.

End FieldSig.

(** ** Field theory *)

Module FieldThy (E : FieldSig).

  Export E.

  Open Scope A_scope.

  Lemma add_comm : forall a b, a + b = b + a.
  Proof. intros. ring. Qed.

  Lemma add_assoc : forall a b c, (a + b) + c = a + (b + c).
  Proof. intros. ring. Qed.

  Lemma add_0_l : forall a, 0 + a = a.
  Proof. intros. ring. Qed.

  Lemma add_0_r : forall a, a + 0 = a.
  Proof. intros. ring. Qed.

  Lemma add_opp_l : forall a, -a + a = 0.
  Proof. intros. ring. Qed.

  Lemma add_opp_r : forall a, a - a = 0.
  Proof. intros. ring. Qed.

  Lemma opp_opp : forall a, - - a = a.
  Proof. intros. ring. Qed.

  Lemma add_cancel_l : forall a b1 b2, a + b1 = a + b2 -> b1 = b2.
  Proof.
    intros.
    rewrite <- (add_0_l b1).
    rewrite <- (add_0_l b2).   (* 0 + b1 = 0 + b2  *)
    rewrite <- (add_opp_l a).  (* -a + a + b1 = -a + a + b1 *)
    rewrite ?add_assoc.        (* -a + (a + b1) = -a + (a + b2) *)
    rewrite H. reflexivity.
  Qed.

  Lemma add_cancel_r : forall a1 a2 b, a1 + b = a2 + b -> a1 = a2.
  Proof.
    intros. rewrite <- (add_0_r a1). rewrite <- (add_0_r a2).
    rewrite <- (add_opp_r b). rewrite <- ?add_assoc. rewrite H. auto.
  Qed.

  Lemma mul_comm : forall a b, a * b = b * a.
  Proof. intros. ring. Qed.

  Lemma mul_assoc : forall a b c, (a * b) * c = a * (b * c).
  Proof. intros. ring. Qed.

  Lemma mul_0_l : forall a, 0 * a = 0.
  Proof. intros. ring. Qed.

  Lemma mul_0_r : forall a, a * 0 = 0.
  Proof. intros. ring. Qed.

  Lemma mul_1_l : forall a, 1 * a = a.
  Proof. intros. ring. Qed.

  Lemma mul_1_r : forall a, a * 1 = a.
  Proof. intros. ring. Qed.

  Lemma mul_inv_l : forall a, a <> 0 -> /a * a = 1.
  Proof. intros. field. auto. Qed.

  Lemma mul_inv_r : forall a, a <> 0 -> a / a = 1.
  Proof. intros. field. auto. Qed.

  Lemma inv_inv : forall a, a <> 0 -> //a = a.
  Proof. intros. field. split; auto. apply A1_neq_A0. Qed.

  Lemma mul_cancel_l : forall a b1 b2, a <> 0 -> a * b1 = a * b2 -> b1 = b2.
  Proof.
    intros. rewrite <- (mul_1_l b1). rewrite <- (mul_1_l b2).
    rewrite <- (mul_inv_l a); auto. rewrite ?mul_assoc. f_equal. auto.
  Qed.

  Lemma mul_cancel_r : forall a1 a2 b, b <> 0 -> a1 * b = a2 * b -> a1 = a2.
  Proof.
    intros. rewrite <- (mul_1_r a1). rewrite <- (mul_1_r a2).
    rewrite <- (mul_inv_r b); auto. rewrite <- ?mul_assoc. f_equal. auto.
  Qed.

End FieldThy.

(** ** Field on Qc *)

Module FieldQc.

  Export QcExt.
  Open Scope Qc_scope.

  Module Export FieldDefQc : FieldSig
    with Definition A := Qc
    with Definition A0 := 0
    with Definition A1 := 1
    with Definition Aadd := Qcplus
    with Definition Aopp := Qcopp
    with Definition Amul := Qcmult
    with Definition Ainv := Qcinv
    with Definition Aeqb := Qceqb.

    Definition A := Qc.
    Definition A0 := 0.
    Definition A1 := 1.
    Definition Aadd := Qcplus.
    Definition Aopp := Qcopp.
    Definition Amul := Qcmult.
    Definition Ainv := Qcinv.
    Definition Aeqb := Qceqb.
    Definition Aeqdec := Qceqdec.
    Definition Aeqb_true_iff := Qceqb_true_iff.
    Definition Aeqb_false_iff := Qceqb_false_iff.

    Lemma A1_neq_A0 : A1 <> A0.
    Proof. intro. discriminate. Qed.

    Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Qcminus Aopp eq.
    Proof.
      constructor; intros; try auto.
      apply Qcplus_0_l. apply Qcplus_comm. apply Qcplus_assoc.
      apply Qcmult_1_l. apply Qcmult_comm. apply Qcmult_assoc.
      apply Qcmult_plus_distr_l. apply Qcplus_opp_r.
    Qed.
    Add Ring Ring_thy_inst : Ring_thy.

    Lemma Field_thy : field_theory A0 A1 Aadd Amul Qcminus Aopp Qcdiv
      Ainv eq.
    Proof.
      constructor; try easy. apply Ring_thy.
      intros. rewrite Qcmult_comm,Qcmult_inv_r; auto.
    Qed.
    Add Field Field_thy_inst : Field_thy.

  End FieldDefQc.

  Module Export FieldThyQc := FieldThy FieldDefQc.

End FieldQc.

(** ** Test for FieldQc *)
Module FieldQc_test.

  Import FieldQc.
  Open Scope A_scope.

  Goal forall a b c : A, (c<>0) -> (a + b) / c = a / c + b / c.
  Proof. intros. field. auto. Qed.

  Goal forall a b, a <> 0 -> /a * a * b = b.
  Proof. intros. rewrite mul_inv_l. field. auto. Qed.

End FieldQc_test.

(** ** Field on R *)

Module FieldR.

  Export RExt.
  Open Scope R_scope.

  Module Export FieldDefR : FieldSig
    with Definition A := R
    with Definition A0 := 0
    with Definition A1 := 1
    with Definition Aadd := Rplus
    with Definition Aopp := Ropp
    with Definition Amul := Rmult
    with Definition Ainv := Rinv
    with Definition Aeqb := Reqb.

    Definition A := R.
    Definition A0 := 0.
    Definition A1 := 1.
    Definition Aadd := Rplus.
    Definition Aopp := Ropp.
    Definition Amul := Rmult.
    Definition Ainv := Rinv.
    Definition Aeqb := Reqb.
    Definition Aeqdec := Req_EM_T.
    Definition Aeqb_true_iff := Reqb_true_iff.
    Definition Aeqb_false_iff := Reqb_false_iff.

    Lemma A1_neq_A0 : A1 <> A0.
    Proof. intro. auto with R. Qed.

    Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Rminus Aopp eq.
    Proof. constructor; intros; cbv; ring. Qed.
    Add Ring Ring_thy_inst : Ring_thy.

    Lemma Field_thy : field_theory A0 A1 Aadd Amul Rminus Aopp Rdiv Ainv eq.
    Proof.
      constructor; try easy. apply Ring_thy. apply A1_neq_A0.
      intros; cbv; field; auto.
    Qed.
    Add Field Field_thy_inst : Field_thy.

  End FieldDefR.

  Module Export FieldThyR := FieldThy FieldDefR.

End FieldR.

(** ** Test for FieldR *)
Module FieldR_test.

  Import FieldR.
  Open Scope A_scope.

  Goal forall a b c : A, (c<>0) -> (a + b) / c = a / c + b / c.
  Proof. intros. field. auto. Qed.

End FieldR_test.

(** ** Field on T *)

Module FieldT.

  Export RAST.
  Open Scope T_scope.

  Module Export FieldDefT : FieldSig
    with Definition A := T
    with Definition A0 := T0
    with Definition A1 := T1
    with Definition Aadd := Tadd
    with Definition Aopp := Topp
    with Definition Amul := Tmul
    with Definition Ainv := Tinv
    with Definition Aeqb := Teqb.

    Axiom Teqb_true_iff : forall x y : T, (x =? y)%T = true <-> x = y.
    Axiom Teqb_false_iff : forall x y : T, (x =? y)%T = false <-> x <> y.

    Definition A := T.
    Definition A0 := T0.
    Definition A1 := T1.
    Definition Aadd := Tadd.
    Definition Aopp := Topp.
    Definition Amul := Tmul.
    Definition Ainv := Tinv.
    Definition Aeqb := Teqb.
    Definition Aeqdec := Teqdec.
    Definition Aeqb_true_iff := Teqb_true_iff.
    Definition Aeqb_false_iff := Teqb_false_iff.

    Lemma A1_neq_A0 : A1 <> A0.
    Proof. intro. easy. Qed.

    Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Tsub Aopp eq.
    Proof. constructor; intros; cbv; ring. Qed.
    Add Ring Ring_thy_inst : Ring_thy.

    Lemma Field_thy : field_theory A0 A1 Aadd Amul Tsub Aopp Tdiv Ainv eq.
    Proof.
      constructor; try easy. apply Ring_thy.
      intros; cbv; field; auto.
    Qed.
    Add Field Field_thy_inst : Field_thy.

  End FieldDefT.

  Module Export FieldThyT := FieldThy FieldDefT.

End FieldT.

(** ** Test for FieldR *)
Module FieldT_test.

  Import FieldT.
  Open Scope A_scope.

  Goal forall a b c : A, (c<>0) -> (a + b) / c = a / c + b / c.
  Proof. intros. field. auto. Qed.

End FieldT_test.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Field_theory.

(** * Vector spaces *)

Section Vector_Spaces.
  Variable (R:Type)
    (rO:R) (rI:R)
    (radd rmul rsub : R -> R -> R)
    (ropp : R -> R)
    (rdiv : R -> R -> R)
    (rinv : R -> R)
    (req : R -> R -> Prop)
  .
  Variable Rfield : field_theory rO rI radd rmul rsub ropp rdiv rinv req.
  Variable (V:Type) (vO:V).
  Variable vadd : V->V->V.
  Variable smul : R->V->V.

  Record vector_space : Type := {
    vadd_comm := forall x y, vadd x y = vadd y x;
    vadd_assoc := forall x y z, vadd (vadd x y) z = vadd x (vadd y z);
    vadd_identity := forall x, vadd vO x = x;
    vadd_inverse := forall x, exists y, vadd x y = vO;

    smul_distr_vadd := forall a x y, smul a (vadd x y) = vadd (smul a x) (smul a y);
    smul_distr_radd := forall a b x, smul (radd a b) x = vadd (smul a x) (smul b x);
    smul_compat_rmul := forall a b x, smul a (smul b x) = smul (rmul a b) x;
    smul_identity := forall x, smul rI x = x
  }.

  Fixpoint finite_sum (n:nat) (v:nat->V) {struct n} := match n with
    | 0 => vO
    | S i => vadd (v n) (finite_sum i v)
  end.

  Record Basis (I:Type) (Xi:I->V) : Prop := {
    basis_spanning : forall x:V, exists n, exists vn : nat -> I,
      x = finite_sum n (fun n => Xi (vn n));
    basis_linear_independence : forall n (vn : nat->I) (an : nat->R),
      (forall i j , i<=n -> j<=n -> vn i = vn j -> i=j) ->
      finite_sum n (fun m => Xi (vn m)) = vO ->
      forall i, i<=n -> an i = rO
  }.

End Vector_Spaces.