Require Export XR_R.
Require Export XR_Rle.
Require Export XR_is_upper_bound.

Local Open Scope R_scope.

Definition is_lub (E:R -> Prop) (m:R) :=
  is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b).


Require Export RelationClasses.
Require Import Permutation.

Instance eq_Equivalence A : Equivalence (eq (A:=A)).
Proof.
  constructor; hnf; intros; congruence.
Qed.

Instance Permutation_Equivalence A : Equivalence (Permutation (A:=A)).
Proof.
  constructor; hnf; intros.
  apply Permutation_refl.
  apply Permutation_sym; auto.
  eapply Permutation_trans; eauto.
Qed.

Instance iff_Equivalence : Equivalence iff.
Proof.
  constructor; hnf; intuition auto.
Qed.


Require Import Arith.
Import Nat.

Definition pred (n: nat) :=
  match n with
  | O => O
  | S n => n
  end.

Definition CNat := forall A, (A -> A) -> A -> A.
Definition c0 : CNat := fun _ s z => z.
Definition c1 : CNat := fun _ s z => s z.
Definition c2 : CNat := fun _ s z => s (s z).

Fixpoint nat_to_cnat (n: nat) : CNat :=
  fun _ s z =>
    match n with
    | O => z
    | S n => s (nat_to_cnat n _ s z)
    end.

Goal c1 = nat_to_cnat 1.
Proof.
  unfold nat_to_cnat, c1. reflexivity.
Qed.

Definition k {A B:Type} (x: A) (y: B) := x.
Definition i {A: Type} (x: A) := x.
Definition cpred : CNat -> CNat :=
  fun (cn: CNat) (A:Type) (s: A -> A) (z: A) => cn ((A -> A) -> A) (fun p q => q (p s)) (k z) i.

Definition cnat_to_nat (cn: CNat) : nat := cn _ S O.

Goal 1 = cnat_to_nat c1.
Proof.
  reflexivity.
Qed.

Lemma nat_cnat : forall n, cnat_to_nat (nat_to_cnat n) = n.
Proof.
  induction n as [|n'].
  - reflexivity.
  - unfold nat_to_cnat. fold nat_to_cnat.
    unfold cnat_to_nat. unfold cnat_to_nat in IHn'. rewrite IHn'.
    reflexivity.
Qed.

Require Import FunctionalExtensionality.

Lemma cnat_nat : forall cn A s z, nat_to_cnat (cnat_to_nat cn) A s z = cn A s z.
Proof.
  enough (forall cn n A s z, n = cnat_to_nat cn -> nat_to_cnat n A s z = cn A s z).
  - intros cn A s z. apply H. reflexivity.
  - intros cn n. induction n as [|n']; unfold cnat_to_nat; intros A s z H.
    + unfold nat_to_cnat.
Admitted.

Definition csucc : CNat -> CNat :=
  fun cn A s z => s (cn A s z).

(* Lemma cpred_csucc : forall cn A s z, cpred (csucc cn) A s z = cn A s z. *)
(* Proof. *)
(*   intros *. unfold csucc, cpred. unfold i. *)

Lemma cpred_pred : forall n, cnat_to_nat (cpred (nat_to_cnat n)) = pred n.
Proof.
  induction n as [|n'].
  - reflexivity.
  -
Abort.


Require Import Coq.Arith.Le Coq.Arith.Lt
               Coq.Arith.Compare_dec.
Require Import Coq.Logic.ProofIrrelevance.

Require Export CatSem.CAT.functor.

Definition PI := proof_irrelevance.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section N_set.
Variable n:nat.

Definition N_set:= {m | m < n}.

Definition projTT : N_set -> nat :=
     fun x => proj1_sig x.

Coercion projTT : N_set >-> nat.
(*
Definition injTT (k: nat) (H: k <= n): {m | m < n}.
intros k H. exists k. apply H. Defined.

Definition inj : {m | m < n} := injTT (le_n n).
*)
End N_set.
(*
Coercion injTT : nat >-> Funclass.
*)
Notation "[[ n ]]" := (N_set n).

Section monotone_maps.

Inductive N_hom: nat -> nat -> Type :=
| empty: forall n, N_hom 0 n
| shift: forall n m, N_hom n (S m) -> N_hom (S n) (S m)
| lift: forall n m, N_hom (S n) m -> N_hom (S n) (S m).

Definition HomDelta (n m: nat) := N_hom n m.
(*
Definition bla: False -> nat.
intro f. elim f.
*)

Require Import Arith.

Definition monotone (m n: nat) (f: [[m]] -> [[n]]) :=
          forall x y: [[m]], x <= y -> f x <= f y.
(*
Program Fixpoint interp (n m:nat)(f:HomDelta n m) {struct f} :
          { f: [[n]] -> [[m]] | monotone f } :=

      match f with
      | empty _ => _
      | shift p q f' => fun n => match n with
                             | O => O
                             | S n' => (interp f') (exist _ n' _ )
                             end
      | lift p q f' => fun n => S (interp f' n)
      end.

Next Obligation. unfold N_set. unfold HomDelta in f.
   elim f.
*)
Definition interp: forall n m (f:HomDelta n m), [[n]] -> [[m]].
intros n m f x.
induction f.
unfold N_set in x.
elim x.
intros b c.
assert False.
apply (lt_n_O _ c).
elim H.

destruct x as [x p].
destruct x.
exists 0. auto with arith.
assert (H0: x < n).
apply lt_S_n.
assumption.
apply (IHf (exist (fun x => x < n) x H0)).

set (y := IHf x).
destruct y.
assert (H0: S x0 < S m).
apply lt_n_S.
assumption.
apply (exist (fun x => x < S m) (S x0) H0).
Defined.

Definition interp2: forall n m (f: HomDelta n m), [[n]] -> nat.
intros n m f x.
induction f.
elim x. intros x0 H.
assert False. apply (lt_n_O _ H). elim H0.

destruct x as [x p].
destruct x.

exact 0.

assert (H0: x < n).
apply lt_S_n. assumption.
apply (IHf (exist (fun x => x < n) x H0)).

exact  (S (IHf x)).
Defined.

Section test.
Hypothesis H: 0 < S (S 0).

Definition test :=  shift (shift (empty 1)).

(*
Eval compute in ((interp2 test) (exist (fun x => x < 2) O H)).
Eval compute in (interp test) (exist (fun x => x < 2) O H).
*)
End test.

Lemma f_PI : forall m n (f: [[m]] -> [[n]]),
             forall k l (H: k = l) pk pl,
             f (exist _ k pk) = f (exist _ l pl).
Proof. intros m n f k l H.
        rewrite H. intros pk pl. rewrite (PI _ pk pl).
        auto.
Qed.

Lemma f_PI2 : forall m n (f: [[m]] -> [[n]]),
             forall k pk pl r,
          r = proj1_sig (f (existT _ k pk)) ->
          r = proj1_sig (f (existT _ k pl)).
Proof. intros. simpl.  rewrite <- (PI _ pk pl). auto.
Qed.

Lemma f_PI3 : forall m n (f: [[m]] -> [[n]]),
              forall k pk pl,
            f (exist _ k pk) = f (exist _ k pl).
Proof. intros m n f k pk pl.
       rewrite <- (PI _ pk pl). auto.
Qed.

Lemma f_PI4: forall m n (f: [[m]] -> [[n]]),
                forall k pk pl,
          proj1_sig (f (exist _ k pk)) =
          proj1_sig (f (exist _ k pl)).
Proof. intros. rewrite (f_PI3 f pk pl).
          auto.
Qed.

Require Import Omega.

Lemma interp_monotone: forall m n (f: N_hom m n), monotone (interp f).
Proof. induction f.
    unfold monotone. intro x. elim x.
    intros x0 p.
    assert (H': False).  apply (lt_n_O x0 p).
    elim H'.

    unfold monotone. intros x y H.
    destruct x as [x px].
    destruct y as [y py]. simpl in *|-*.
    destruct x. destruct y. simpl. auto.
        simpl. omega.
      destruct y. simpl. omega.
        unfold monotone in IHf.
        apply IHf. auto with arith.

    unfold monotone. intros x y H. simpl.
    assert (H': interp f x <= interp f y).
    apply IHf. auto.
    destruct (interp f x).
    destruct (interp f y). simpl in *|-*.
    auto with arith.
Qed.

Section translating_back.
(*
Hypothesis H: forall m n (f: [[m]] -> [[n]]), monotone f.

*)
Definition ins_0 (m:nat) : [[S m]] := exist (fun x => x < S m) 0
                              (lt_O_Sn m).
(*
Definition shift_down (m n:nat) (f: [[S m]] -> [[S n]])
           (H: monotone f)
           (H': f (ins_0 m) > 0): [[S m]] -> [[n]].
intros m n f H H' x.
exists (pred (f x)).
assert (Hx : 1 <= f x).
apply le_trans with (f (ins_0 m)).
assumption.
apply H. auto with arith.
assert (Hxx: f x < (S n)).
elim f.
intros. simpl. assumption.
assert (pred (f x) < f x).
apply lt_pred_n_n. apply Hx.
apply le_trans with (f x).
rewrite <- (@S_pred (f x) 0). auto with arith.
apply Hx. auto with arith.
Defined.

Lemma shift_down_monotone (m n:nat)(f: [[S m]] -> [[S n]])
           (H: monotone f)
           (H': f (ins_0 m) > 0):
         monotone (shift_down H H').
Proof. unfold monotone. intros m n f H H' x y Hxy.
       simpl.
       apply le_pred. apply H. auto.
Defined.
*)

Program Definition unlift (m n: nat) (f: [[S m]] -> [[S n]])
             (H: monotone f)
            (H': f (ins_0 m) > 0) (x:[[S m]]) : [[n]] :=
      pred (f x).
Next Obligation.
Proof.
  simpl;
  intros m n f H H0 x.
  assert (Hx : 1 <= f x).
  apply le_trans with (f (ins_0 m)).
  assumption.
  apply H. auto with arith.
  assert (Hxx: f x < (S n)).
  elim f.
  intros. simpl. assumption.
  assert (pred (f x) < f x).
  apply lt_pred_n_n. apply Hx.
  apply le_trans with (f x).
  rewrite <- (@S_pred (f x) 0). auto with arith.
  apply Hx. auto with arith.
Qed.

Lemma unlift_monotone (m n:nat)(f: [[S m]] -> [[S n]])
           (H: monotone f)
           (H': f (ins_0 m) > 0):
         monotone (unlift H H').
Proof. unfold monotone. intros m n f H H' x y Hxy.
       simpl.
       apply le_pred. apply H. auto.
Qed.

Require Import Omega.

Program Definition unshift (m n: nat) (f: [[S m]] -> [[n]])
                 : [[m]] -> [[n]] :=
      fun x => f (S x).
Next Obligation.
Proof.
  intros m n f x.
  elim x. intros.
  simpl.
  apply lt_n_S.
  auto.
Qed.

Lemma unshift_monotone (m n: nat) (f: [[S m]] -> [[n]]) :
          monotone f -> monotone (unshift f).
Proof. unfold monotone. intros m n f H x y Hxy.
       unfold unshift. apply H. simpl. auto with arith.
Qed.

End translating_back.
End monotone_maps.
(*
Obligation Tactic := idtac.
*)
(*
Program Fixpoint abstr (m n:nat) (f: [[m]] -> [[n]]) (H: monotone f)
               {measure (plus n m)} : N_hom m n :=
     match m with
     | 0 => empty n
     | (S m') => match n with
                | 0 => _
                | S n' =>
                    match (f (ins_0 (m'))) with
                   | 0 => shift (abstr (f:=(unshift f)) (unshift_monotone H))
                   | S p' => lift (abstr (f:=(@unlift _ _ f H (lt_O_Sn p')))
                                      (unlift_monotone H (lt_O_Sn p')))
                   end
                end
     end.

Next Obligation.
  intros. subst.
  unfold N_set in *|-*.
  elim f.
  intros x H'.
  assert (H0:False).
  apply (lt_n_O x). assumption.
  elim H0.
  exists m'. apply lt_n_Sn.
Defined.
Next Obligation.
Proof.
  intros.
  simpl.
  subst.
  apply lt_O_Sn.
Qed.
Next Obligation.
Proof.
  simpl; intros.
  subst.
  destruct x0; auto.
Qed.
Next Obligation.
Proof.
  simpl; intros.
  omega.
Qed.
Next Obligation.
Proof.
  simpl; intros.
  subst.
  destruct x0;
  auto.
Qed.
Next Obligation.
Proof.
  simpl; intros;
  subst.
  destruct x.
  auto.
Qed.
Next Obligation.
Proof.
  simpl; intros;
  subst.
  destruct x0.
  auto.
Qed.
Next Obligation.
Proof.
  simpl in *.
  intros;
  subst.
  elim f.
  simpl.
  intros.
  omega.
  exists m'.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros.
  elim f.
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  apply f_PI2 with (abstr_func_obligation_2 (f:=f) H abstr eq_refl
                          eq_refl).
  auto.
Qed.
Next Obligation.
Proof.
  apply f_PI4.
Qed.
Next Obligation.
Proof.
  apply f_PI4.
Qed.
Next Obligation.
Proof.
  apply f_PI2 with (abstr_func_obligation_2 (f:=f) H abstr eq_refl
                          eq_refl).
  auto.
Qed.

Definition abstract (m n:nat) (f:{f:[[m]] -> [[n]] | monotone f}) :=
             abstr (proj2_sig f).

(* maybe some of these should end with Defined rather than Qed *)

Section waterloo.

Definition N_idf (n:nat): [[n]] -> [[n]] := fun x => x.

Lemma N_id_monotone (n:nat) : monotone (@N_idf n).
Proof. intro n. unfold monotone. auto. Qed.

Definition N_id (n:nat) : { f: [[n]] -> [[n]] | monotone f } :=
            exist _ (@N_idf n) (@N_id_monotone n).

Definition N_id3 := @N_id 3.
(*
Eval compute in (abstract N_id3).
*)
Lemma comp_monotone: forall k m n (f: [[k]] -> [[m]])
                                  (g: [[m]] -> [[n]]),
    monotone f -> monotone g ->
              monotone (fun x => g (f x)).
Proof. unfold monotone. intros k m n f g Hf Hg x y Hxy.
       apply Hg. apply Hf. auto. Qed.

Definition N_comp (k m n: nat) (f: N_hom k m) (g: N_hom m n) :=
        abstr (comp_monotone (interp_monotone f)
                             (interp_monotone g))
           (*(fun x => (interp g) (interp f x))*).

Program Definition id3min1: { f: [[3]] -> [[2]] | monotone f} :=
       fun x => pred x.

Next Obligation.
Proof. destruct x. simpl. omega. Qed.

Next Obligation.
Proof. unfold monotone. intros x y H. simpl.
       omega. Qed.
(*
Eval compute in (N_comp (abstract N_id3)
                 (abstract id3min1)).
*)
End waterloo.

End translating_back.

Definition eq_H_hom1 (m n: nat) : relation (N_hom m n) :=
          fun f g => forall x, proj1_sig (interp f x) =
                               proj1_sig (interp g x).

Lemma eq_H_hom_equiv (m n: nat) : Equivalence (@eq_H_hom1 m n).
Proof.
  intros m n.
  unfold eq_H_hom1. split.
    unfold Reflexive. auto.
    unfold Symmetric. auto.
    unfold Transitive.
    intros x y z H H0 x0.
      transitivity (interp (n:=m) (m:=n) y x0).
      apply (H x0).
      apply (H0 x0).
Qed.

Definition eq_H_hom (m n: nat) := Build_Setoid (eq_H_hom_equiv m n).

Definition id_H_hom (n:nat) : N_hom n n :=
           abstract (@N_id n).

Program Definition interpret (m n: nat) (f: N_hom m n) :
                  { f: [[m]] -> [[n]] | monotone f } :=
 interp f.

Next Obligation. apply interp_monotone. Qed.
*)

(*
Lemma abstract_inj : forall m n (f g: { r: [[m]] -> [[n]] | monotone r }),
              abstract f = abstract g -> f = g.
Proof. intros m n f g H.
*)

(*
Lemma interp_inj: forall m n (f g: N_hom m n),
       interp f = interp g -> f = g.
Proof. induction f. intros. simpl.
       destruct g. inversion g. simpl.
*)
(*
Lemma interp_after_abstract: forall m n
        (f: { f: [[m]] -> [[n]] | monotone f }),
     interpret (abstract f) = f.
Proof. intros m n f.
unfold interpret, abstract. simpl.
destruct f as [f p].
apply break_Sig_Prop. extensionality x.
destruct x as [x px].
simpl. unfold interp. simpl.
destruct x. simpl.
*)

(*
Lemma bla2: forall m n (f: { r: [[S m]] -> [[S n]] | monotone r }),
             (proj1_sig f) (ins_0 m) > 0 ->
             exists t, abstract f = lift t.
Proof. intros. unfold abstract. unfold abstr.
        eauto. simpl. Admitted.

Lemma abstract_after_interp: forall m n (f:N_hom m n),
          abstract (interpret f) = f.
Proof. induction f. auto.

      Focus 2.
      assert (H: proj1_sig (interpret (lift f)) (ins_0 n) > 0).
      apply bla. generalize H. simpl.
      unfold interpret. unfold interp.
      simpl. auto with arith. auto.
      assert (H': exists t, abstract (interpret (lift f)) = lift t).
      apply bla2. auto.
      elim H'. intros.
      unfold interpret. unfold abstract. simpl.
      unfold interp. simpl. unfold abstr. simpl.
      auto.

       unfold abstract, interpret in *|-*. simpl in *|-*.
       unfold interp. simpl.
       unfold abstr. simpl.  red.
       rewrite IHf. simpl.  auto. simpl.

      unfold interpret. unfold abstract.
        simpl. auto. unfold abstr. unfold interp.
        simpl. unfold abstr_func. simpl.
          auto.

Definition monotone (m n: nat) (f: [[m]] -> [[n]]) :=
          forall i j: [[m]], i <= j -> f i <= f j.

Definition N_hom (m n:nat) := {f: [[m]] -> [[n]] | monotone f}.

Definition N_comp_h (k m n:nat) (f: [[k]] -> [[m]]) (g: [[m]] -> [[n]]):
                                    [[k]] -> [[n]] :=
       fun x => g (f x).

Lemma comp_monotone : forall k m n (f:[[k]] -> [[m]])
            (g:[[m]] -> [[n]]), monotone f -> monotone g ->
                monotone (N_comp_h f g).
Proof. intros k m n f g H H'.
 unfold N_comp_h. unfold monotone. intros i j H0.
 apply H'. apply H. apply H0.
Qed.

Definition N_comp (k m n: nat)
        (f:N_hom k [[m]]) (g:N_hom [[m]] [[n]]):
                  N_hom [[k]] [[n]] :=
    exist (N_comp_h f g) (comp_monotone f g).

*)

(*
Definition partial_comp (k:nat) (f: nat -> nat) (g:nat -> nat) :=
       fun x => match le_lt_dec x k with
                | left _ => f x
                | right _ => g (f x)
                end.

Definition up_one_k (m n: nat) (k:nat) (f:[[m]] -> [[n]])
            (H': monotone f)
            (H: f (inj m) < n ) : [[m]] -> [[n]].
intros m n k f H' H.
intro x.
case (le_lt_dec x k).
intro Hx. apply (f x).

intro Hx. exists (S (f x)).
apply le_trans with (S (f (inj m))).
apply le_n_S.
apply H'.
apply x.
auto with arith.
Defined.

(*
Definition const (m n: nat) (k : {x | x <= m}) :
                    {x | x <= m} -> {x | x <=
*)
Definition const (m n:nat) (k: [[ n ]]) : [[ m ]] -> [[ n ]].
intros m n k.
apply (fun x => k).
Defined.

Inductive monotone (m n: nat): [[ m ]] -> [[ n ]] -> Prop :=
| mon_const: forall k: [[ n ]], monotone (const k)
| mon_up_one: forall f, monotone f -> monotone (up_one_k

Variables m n: nat.

Definition hom: ob -> ob -> Prop :=
           fun k l =>  k <= l.

Definition hom_oid (a b:ob): relation (hom a b) :=
        fun p q => p = q.

Lemma all_related: forall a b: ob, forall p q: hom a b,
             hom_oid p q.
Proof.  intros a b p q.
    unfold hom_oid.
    apply PI.
Qed.

Lemma hom_setoid (a b: ob): Equivalence (@hom_oid a b).
Proof. intros a b. unfold hom_oid.
 split. unfold Reflexive.
        auto.
        unfold Symmetric. auto.
        unfold Transitive. intros x y z.
        transitivity y; auto.
Qed.

Definition category_n_oid (a b: ob) :=
        Build_Setoid (hom_setoid a b).
*)


Require Import ACTL.

Set Implicit Arguments.

Require Import Coq.Setoids.Setoid.

Inductive state := State : bool -> bool -> bool  -> state.

Inductive action := switch | brake | park | tau | isOn | isBraked | isParked.

Inductive trans : state -> action -> state -> Prop :=
    | Tr_SwitchOk e : trans (State e true true) switch (State (negb e) true true)
    | Tr_SwitchNG e b p : andb b p = false -> trans (State e b p) switch (State e b p)
    | Tr_Brake e b p : trans (State e b p) brake (State e (negb b) p)
    | Tr_Park e b p : trans (State e b p) park (State e b (negb p))
    | Tr_IsOn b p : trans (State true b p) isOn (State true b p)
    | Tr_IsBraked e p : trans (State e true p) isBraked (State e true p)
    | Tr_IsParked e b : trans (State e b true) isParked (State e b true)
    | Tr_tau s: trans s tau s.

Theorem tau_eq s s' : trans s tau s' <->  s = s'.
Proof.
    split; intro H.
    +   inversion H; subst; auto.
    +   subst; constructor.
Qed.

Notation "s |= f" := (@sat state action trans f s)(at level 80).
Notation "|= f" := (forall s, s |= f)(at level 80).
Notation τ := (action_ tau).
Notation "< chi > f" := (E (⊤ [τ] U [chi] f))(at level 50, chi at level 5).
Notation "[ chi ] f" := (¬ <chi> ¬ f)(at level 50, chi at level 5).
Notation "'EX' f" := (<any> f)(at level 50).
Notation "'AX' f" := ([any] f)(at level 50).
Notation "'EF' f" := (f ∨ EF [any] f)(at level 50).
Notation "'AF' f" := (f ∨ AF [any] f)(at level 50).
Notation "'EG' f" := (¬ AF ¬ f)(at level 50).
Notation "'AG' f" := (¬ EF ¬ f)(at level 50).

Notation "f 'EU' f'" := (E (f U f'))(at level 50).

Notation Path := (@path state action trans).
Notation Form := (@form action).
Notation Formr := (@formr action).

Notation IsOn := (< (action_ isOn) > ⊤).
Notation IsBraked := (<(action_ isBraked)> ⊤).
Notation IsParked := (<(action_ isParked)> ⊤).

Notation Switch := (action_ switch).
Notation Brake := (action_ brake).
Notation Park := (action_ park).

Ltac  satisfy := unfold sat; fold (sat (trans := trans)).

Definition engineState s :=
    match s with
    | State b _ _ => b
    end.

Definition brakeState s :=
    match s with
    | State _ b _ => b
    end.

Definition parkState s :=
    match s with
    | State _ _ b => b
    end.

Theorem IsOn_spec s :
    s |= IsOn <-> engineState s = true.
Proof.
    destruct s; simpl; split; satisfy; intro H.
    +   induction H as [r [Hr [_ HU]]].
        induction HU; simpl in *; auto; subst.
        -   destruct r,p; simpl in *; subst; inversion t; auto.
        -   apply IHHU; symmetry; apply tau_eq; auto.
    +   subst.
        remember (State true b0 b1).
        assert (trans s isOn s) by (subst; constructor).
        exists (Run s (nilp s isOn s H)); repeat split.
        constructor; unfold sata; auto.
Qed.

Theorem IsBraked_spec s :
    s |= IsBraked <-> brakeState s = true.
Proof.
    destruct s; simpl; split; satisfy; intro H.
    +   induction H as [r [Hr [_ HU]]].
        induction HU; simpl in *; auto; subst.
        -   destruct r,p; simpl in *; subst; inversion t; auto.
        -   apply IHHU; symmetry; apply tau_eq; auto.
    +   subst.
        remember (State b true b1).
        assert (trans s isBraked s) by (subst; constructor).
        exists (Run s (nilp s isBraked s H)); repeat split.
        constructor; unfold sata; auto.
Qed.

Theorem IsParked_spec s :
    s |= IsParked <-> parkState s = true.
Proof.
    destruct s; simpl; split; satisfy; intro H.
    +   induction H as [r [Hr [_ HU]]].
        induction HU; simpl in *; auto; subst.
        -   destruct r,p; simpl in *; subst; inversion t; auto.
        -   apply IHHU; symmetry; apply tau_eq; auto.
    +   subst.
        remember (State b b0 true).
        assert (trans s isParked s) by (subst; constructor).
        exists (Run s (nilp s isParked s H)); repeat split.
        constructor; unfold sata; auto.
Qed.

Theorem switch_safe :
    |= AG ((IsOn ∧ ¬ IsParked) → [Switch] IsOn).
Proof.
    satisfy; intros s F.
    induction F.
    +   apply imply_to_and in H.
        induction H as [[H H0] H1].
        apply IsOn_spec in H.
        rewrite (IsParked_spec s) in H0.
        assert (parkState s = false).
            { destruct (parkState s); auto. contradiction H0; auto. }
        clear H0.
        apply NNPP in H1.
        induction H1 as [r [Hr [_ HU]]].
        induction HU.
        -   apply H1; clear H1.
            destruct s; simpl in *; subst.
            destruct r, p; simpl in *; subst a s;
                inversion t; subst;
                remember (State true b0 false) as s;
                assert (trans s isOn s); try( subst; constructor );
                exists (Run s (nilp s isOn s H)); repeat split;
                constructor; unfold sata; auto.
        -   simpl in *; subst.
            apply IHHU. symmetry. apply tau_eq; auto.
    +   induction H as [r [Hr [_ HU]]]; subst.
        induction HU; auto.
        apply imply_to_and in H0.
        induction H0 as [[H0 H1] H2].
        apply IsOn_spec in H0.
        rewrite (IsParked_spec (nextState r)) in H1.
        assert (parkState (nextState r) = false).
            { destruct r, p, s', b1; auto; contradiction H1; auto. }
        clear H1.
        apply NNPP in H2.
        induction H2 as [r' [Hr' [_ HU']]].
        induction HU'.
        *   apply H2; clear H2.
            destruct r,p; simpl in *; subst;
            destruct r0; [destruct p| destruct p0]; simpl in *; subst;
            destruct s0; simpl in *; subst; inversion t0; subst;
                remember (State true b0 false) as s';
                assert (trans s' isOn s') as H0; try (subst; constructor);
                exists (Run s' (nilp s' isOn s' H0));
                repeat split; constructor; unfold sata; auto.
        *   apply IHHU'; simpl in *; subst.
            symmetry; apply tau_eq; auto.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.

Require Import Byte.
Require Import ByteData.
Require Import Util.

Local Open Scope bool.
Local Open Scope N.

Inductive FileId: Type :=
  | Ext2Id: N -> FileId
  | MockId: list (N*Byte) -> FileId
.

Fixpoint eqb (lhs rhs: FileId) :=
  match (lhs, rhs) with
  | ((Ext2Id l), (Ext2Id r)) => N.eqb l r
  | ((MockId l), (MockId r)) => listN_Byte_eqb l r
  | _ => false
  end.

Lemma eqb_reflection (lhs rhs: FileId) :
  eqb lhs rhs = true -> lhs = rhs.
Proof.
  generalize rhs.
  induction lhs.
    (* Ext2Id *)
    destruct rhs0; [| simpl; intros; inversion H].
    unfold eqb. intros. apply N.eqb_eq in H. rewrite H. reflexivity.
    (* MockId *)
    destruct rhs0; [simpl; intros; inversion H | ].
    intros. unfold eqb in H.
    apply listN_Byte_eqb_reflection in H.
    rewrite H. reflexivity.
Qed.


(* * Tactics for [Fin.t] *)

(* Author: Maximilian Wuttke and Fabian Kunze *)

From Undecidability.Shared.Libs.PSL Require Import Base.
Require Import Coq.Vectors.Fin.

Lemma fin_destruct_S (n : nat) (i : Fin.t (S n)) :
  { i' | i = Fin.FS i' } + { i = Fin.F1 }.
Proof.
  refine (match i in (Fin.t n')
          with
          | Fin.F1 => _
          | Fin.FS i' => _
          end); eauto.
  (*
  refine (match i as i0 in (Fin.t n') return
                match n' with
                | O => fun _ : Fin.t 0 => unit
                | S n'' => fun i0 : Fin.t (S n'') => { i' | i0 = Fin.FS i' } + { i0 = Fin0}
                end i0
          with
          | Fin.F1 => _
          | Fin.FS i' => _
          end); eauto.
   *)
Defined.

Lemma fin_destruct_O (i : Fin.t 0) : Empty_set.
Proof. refine (match i with end). Defined.

Lemma fin_destruct_add
: forall (n m : nat) (i : Fin.t (n+m)),
    {i' : Fin.t n | i = Fin.L _ i'} + {i' : Fin.t m | i = Fin.R _ i'}.
Proof.
  induction n;cbn. right. now eauto.
  intros ? i. destruct (fin_destruct_S i) as [[i' ->]| ->].
  -destruct (IHn _ i') as [ [? ->] | [? ->]].
    --left. now eexists (Fin.FS _).
    --right. eauto.
  -left. now exists Fin.F1.
Qed.

Ltac destruct_fin i :=
  lazymatch type of i with
  | Fin.t (S ?n) =>
    let i' := fresh i in
    pose proof fin_destruct_S i as [ (i'&->) | -> ];
    [ destruct_fin i'
    | idtac]
  | Fin.t O =>
    pose proof fin_destruct_O i as []
  | Fin.t (_ + _) =>
    let i' := fresh i in
    pose proof fin_destruct_add i as [ (i'&->) | (i'&->)];destruct_fin i'
  | Fin.t _ => idtac
  end.

Goal True.
Proof.
  assert (i : Fin.t 4) by repeat constructor.
  enough (i = i) by tauto.
  destruct_fin i.
  all: reflexivity.
Qed.

Lemma Fin_L_fillive (n m : nat) (i1 i2 : Fin.t n) :
  Fin.L m i1 = Fin.L m i2 -> i1 = i2.
Proof.
  induction n as [ | n' IH].
  - destruct_fin i1.
  - destruct_fin i1; destruct_fin i2; cbn in *; auto; try congruence.
    intros H%Fin.FS_inj. now apply IH in H as ->.
Qed.

Lemma Fin_R_fillive (n m : nat) (i1 i2 : Fin.t n) :
  Fin.R m i1 = Fin.R m i2 -> i1 = i2.
Proof.
  induction m as [ | n' IH]; cbn.
  - auto.
  - intros H % Fin.FS_inj. auto.
Qed.

Lemma Fin_eqb_R_R  m n (i i' : Fin.t n):
  Fin.eqb (Fin.R m i) (Fin.R m i') = Fin.eqb i i'.
Proof. induction m;cbn. all:congruence. Qed.

Lemma Fin_eqb_L_L m n (i i' : Fin.t n):
  Fin.eqb (Fin.L m i) (Fin.L m i') = Fin.eqb i i'.
Proof.
  revert i i'. induction n;intros i i'; destruct_fin i;destruct_fin i';cbn.
  4:rewrite !Nat.eqb_refl. all:congruence.
Qed.

Lemma Fin_eqb_R_L m n (i : Fin.t n) (i' : Fin.t m):
  Fin.eqb(Fin.R n i')  (Fin.L m i)  = false.
Proof.
  revert m i i'. induction n;intros m i i'; destruct_fin i;destruct_fin i';cbn. all:easy.
Qed.

Lemma Fin_eqb_L_R m n (i : Fin.t n) (i' : Fin.t m):
  Fin.eqb (Fin.L m i) (Fin.R n i') = false.
Proof.
  revert m i i'. induction n;intros m i i'; destruct_fin i;destruct_fin i';cbn. all:easy.
Qed.


Require Export SpecSyntax.
Set Implicit Arguments.

(******************************************************************************)
(* Shifting                                                                   *)
(******************************************************************************)

Fixpoint shiftIndex (c : nat) (i : nat) : nat :=
  match c with
    | O   => S i
    | S c =>
      match i with
        | O   => O
        | S i => S (shiftIndex c i)
      end
  end.

Fixpoint tshiftTy (c : nat) (T : Ty) : Ty :=
  match T with
    | tvar X     => tvar (shiftIndex c X)
    | tarr T1 T2 => tarr (tshiftTy c T1) (tshiftTy c T2)
    | tall T     => tall (tshiftTy (S c) T)
    | texist T   => texist (tshiftTy (S c) T)
  end.

Fixpoint tshiftTm (c : nat) (t : Tm) : Tm :=
  match t with
  | var x         => var x
  | abs T1 t2     => abs (tshiftTy c T1) (tshiftTm c t2)
  | app t1 t2     => app (tshiftTm c t1) (tshiftTm c t2)
  | tabs t2       => tabs (tshiftTm (S c) t2)
  | tapp t1 T2    => tapp (tshiftTm c t1) (tshiftTy c T2)
  | pack T1 t T2  => pack (tshiftTy c T1) (tshiftTm c t) (tshiftTy c T2)
  | unpack t1 t2  => unpack (tshiftTm c t1) (tshiftTm (S c) t2)
  end.

Fixpoint shiftTm (c : nat) (t : Tm) : Tm :=
  match t with
  | var x        => var (shiftIndex c x)
  | abs T1 t2    => abs T1 (shiftTm (S c) t2)
  | app t1 t2    => app (shiftTm c t1) (shiftTm c t2)
  | tabs t2      => tabs (shiftTm c t2)
  | tapp t1 T2   => tapp (shiftTm c t1) T2
  | pack T1 t T2  => pack T1 (shiftTm c t) T2
  | unpack t1 t2  => unpack (shiftTm c t1) (shiftTm (S c) t2)
  end.

(******************************************************************************)
(* Type substitution.                                                         *)
(******************************************************************************)

Fixpoint tsubstIndex (X : nat) (T' : Ty) (Y : nat) : Ty :=
  match X , Y with
    | O   , O   => T'
    | O   , S Y => tvar Y
    | S X , O   => tvar O
    | S X , S Y => tshiftTy 0 (tsubstIndex X T' Y)
  end.

Fixpoint tsubstTy (X : nat) (T' : Ty) (T : Ty) : Ty :=
  match T with
    | tvar Y     => tsubstIndex X T' Y
    | tarr T1 T2 => tarr (tsubstTy X T' T1) (tsubstTy X T' T2)
    | tall T     => tall (tsubstTy (S X) T' T)
    | texist T   => texist (tsubstTy (S X) T' T)
  end.

Fixpoint tsubstTm (X : nat) (T' : Ty) (t : Tm) : Tm :=
  match t with
  | var x         => var x
  | abs T1 t2     => abs  (tsubstTy X T' T1) (tsubstTm X T' t2)
  | app t1 t2     => app  (tsubstTm X T' t1) (tsubstTm X T' t2)
  | tabs t2       => tabs (tsubstTm (S X) T' t2)
  | tapp t1 T2    => tapp (tsubstTm X T' t1) (tsubstTy X T' T2)
  | pack T1 t T2  => pack (tsubstTy X T' T1) (tsubstTm X T' t) (tsubstTy X T' T2)
  | unpack t1 t2  => unpack (tsubstTm X T' t1) (tsubstTm (S X) T' t2)
  end.

(******************************************************************************)
(* Term substitutions.                                                        *)
(******************************************************************************)

Inductive hnat : Set :=
  | hn0 : hnat
  | hsm : hnat → hnat
  | hsy : hnat → hnat.

Fixpoint substIndex (x : hnat) (t : Tm) (y : nat) : Tm :=
  match x , y with
    | hn0   , O   => t
    | hn0   , S y => var y
    | hsm x , O   => var O
    | hsm x , S y => shiftTm O (substIndex x t y)
    | hsy x , y   => tshiftTm O (substIndex x t y)
  end.

Fixpoint substTm (x : hnat) (t' : Tm) (t : Tm) : Tm :=
  match t with
    | var y        => substIndex x t' y
    | abs T1 t2    => abs T1 (substTm (hsm x) t' t2)
    | app t1 t2    => app (substTm x t' t1) (substTm x t' t2)
    | tabs t2      => tabs (substTm (hsy x) t' t2)
    | tapp t1 T2   => tapp (substTm x t' t1) T2
    | pack T1 t T2 => pack T1 (substTm x t' t) T2
    | unpack t1 t2 => unpack (substTm x t' t1) (substTm (hsm (hsy x)) t' t2)
  end.

(******************************************************************************)
(* Context lookups.                                                           *)
(******************************************************************************)

Inductive lookup_etvar : Env → nat → Prop :=
  | lookup_etvar_here {Γ} :
      lookup_etvar (etvar Γ) O
  | lookup_etvar_there_evar {Γ T X} :
      lookup_etvar Γ X →
      lookup_etvar (evar Γ T) X
  | lookup_etvar_there_etvar {Γ X} :
      lookup_etvar Γ X →
      lookup_etvar (etvar Γ) (S X).
Hint Constructors lookup_etvar.

Inductive lookup_evar : Env → nat → Ty → Prop :=
  | lookup_evar_here {Γ T} :
      lookup_evar (evar Γ T) O T
  | lookup_evar_there_evar {Γ T T' X} :
      lookup_evar Γ X T →
      lookup_evar (evar Γ T') (S X) T
  | lookup_evar_there_etvar {Γ T X} :
      lookup_evar Γ X T →
      lookup_evar (etvar Γ) X (tshiftTy 0 T).
Hint Constructors lookup_evar.

(******************************************************************************)
(* Well-formed types.                                                         *)
(******************************************************************************)

Inductive wfTy : Env → Ty → Prop :=
  | wf_tvar {Γ X} :
      lookup_etvar Γ X → wfTy Γ (tvar X)
  | wf_tarr {Γ T1 T2} :
      wfTy Γ T1 → wfTy Γ T2 → wfTy Γ (tarr T1 T2)
  | wf_tall {Γ T} :
      wfTy (etvar Γ) T → wfTy Γ (tall T)
  | wf_texist {Γ T} :
      wfTy (etvar Γ) T → wfTy Γ (texist T).
Hint Constructors wfTy.


(** * Example of manipulation of inductive definitions *)

(** Needham-Schroeder protocol *)
(** simplified version without a server for distributing public keys *)
(** version without flaw *)

(** ** Basic data types *)
(** - Users;
    - Agents : A is Alice, B is Bob, I is the intruder
    - Keys and data: keys will be asymmetric and public;
    - Messages: the keys, or names of agents,
      or nonces generated by one agent for another;
      messages can be encoded with the public key of an agent and paired.
*)

Inductive agent : Set := A | B | I .

Inductive message : Set :=
	Name  : agent -> message
      | Nonce : agent * agent -> message
      | SK    : agent -> message
      | Enc   : message -> agent -> message
      | P     : message -> message -> message.

(** ** Description of the protocol *)

(**
Three mutually inductively defined relations:
 - [send Y m] when [Y] send a message [m] encodes the protocol
    -- A --> B : {NA,A} pk(B)
    -- B --> A : {NA,NB,B} pk(A)
    -- A --> B : {NB} pk(B)
The intruder [I] can send any message that (s)he knows;
 - [receive Z m] when [Z] receive the message m
   (ie, the message was sent by someone);
 - [known m] when the message [m] is known from [I], ie
   it was intercepted by [I] or deducible from informations received by [I].
*)

Section Protocol_without_flaw.

(** A global parameter [X] represents the agent with which [A] initiates the protocol *)

Variable X:agent.

(** [A] and [B] follow the protocol *)

Inductive send : agent -> message -> Prop :=
     init   : send A (Enc (P (Nonce (A,X)) (Name A)) X)
   | trans1 : forall Y d,
              receive B (Enc (P (Nonce d) (Name Y)) B)
              -> send B (Enc (P (Nonce d) (P (Nonce (B,Y)) (Name B))) Y)
   | trans2 : forall d, receive A (Enc (P (Nonce (A,X)) (P (Nonce d) (Name X))) A)
              -> send A (Enc (Nonce d) X)
   | cheat : forall m, known m -> send I m

with receive : agent -> message -> Prop :=
     link : forall m Y Z, send Y m -> receive Z m

with known : message -> Prop :=
     spy : forall m, receive I m -> known m
   | name : forall a, known (Name a)
   | nonce : forall Y, known (Nonce (I,Y))
   | secret_KI : known (SK I)
   | decomp_l : forall m m', known (P m m') -> known m
   | decomp_r : forall m m', known (P m m') -> known m'
   | compose  : forall m m', known m -> known m' -> known (P m m')
   | crypt  : forall m a, known m -> known (Enc m a)
   | decrypt : forall m a, known (Enc m a) -> known (SK a) -> known m.

(** ** Properties of the protocol *)
(**  Invariant : approximates what is known from the intruder. *)

Inductive invknown :  message -> Prop :=
     base : forall a, invknown (Name a)
   | nonce_to_I : forall a, invknown (Nonce (a,I))
   | nonce_from_I : forall a, invknown (Nonce (I,a))
   | mes  : invknown (SK I)
   | enc : forall m a, invknown m -> invknown (Enc m a)
   | exchinit : X<>I -> invknown (Enc (P (Nonce (A,X)) (Name A)) X)
   | exch1 : forall Y, Y<>I -> X=B ->
             invknown (Enc (P (Nonce (A,B)) (P (Nonce (B,Y)) (Name B))) Y)
   | exch1cheat : forall Y d, Y<>I ->  invknown (Nonce d) ->
             invknown (Enc (P (Nonce d) (P (Nonce (B,Y)) (Name B))) Y)
   | exch2 : X=B -> invknown (Enc (Nonce (B,A)) B)
   | invcompose  : forall m m', invknown m -> invknown m' -> invknown (P m m').
Hint Constructors invknown.

(** Mutually recursive induction principle *)

Scheme receive_mut_ind := Minimality for receive Sort Prop
with known_mut_ind := Minimality for known Sort Prop
with send_mut_ind := Minimality for send Sort Prop.

Print receive_mut_ind.

(** Technical lemma for case analysis *)
Lemma I_eq_dec : forall a, a = I \/ a <> I.
destruct a; ((left; congruence) || (right; congruence)).
Qed.

(** Preservation of the invariant *)
Lemma receive_invknown : forall Y m, receive Y m -> invknown m.
intros Y m H; elim H using receive_mut_ind
       with (P1 := invknown)
              (P2 := fun (a:agent) => invknown);
         intros; auto.

inversion H1; trivial.
inversion H1; trivial.
inversion H3.
inversion H1; auto; try congruence.
destruct (I_eq_dec X) as [H1|H1]; auto.
subst X; auto.
destruct (I_eq_dec Y0) as [He|He]; auto.
subst Y0; inversion H1; auto.
inversion H3; auto.
inversion H1.
inversion H3; auto.
apply exch1; congruence.
inversion H1; auto.
inversion H3; auto.
inversion H8; auto.
Qed.

(** Everything known can be sent and received and satisfies the invariant *)
Lemma known_invknown : forall m, known m -> invknown m.
intros; apply receive_invknown with I.
apply link with I.
apply cheat; auto.
Qed.
Hint Immediate known_invknown.

(** Everything not in the invariant is not known *)
Lemma not_known : forall m, ~ invknown m -> ~ known m.
  intros. intro. auto.
Qed.

(** Whatever [X] is the nonces generated by [A] for [B] and [B] for [A] stay private *)
Lemma NonceAB_unknown : ~ known (Nonce (A,B)).
 intros.
 apply not_known.
 intro.
 inversion H.
Qed.

Print NonceAB_unknown.

Lemma NonceBA_unknown : ~ known (Nonce (B,A)).
intros; apply not_known; intro.
inversion H.
Qed.

(** Authentication : if [B] received the nonce generated by [A] then the protocol was initiated by [A] with [B] *)

Lemma protocol_ok : receive B (Enc (Nonce (B,A)) B) -> X = B.
intros H.
 inversion_clear H.
inversion_clear H0; trivial.
assert (invknown (Enc (Nonce (B, A)) B)); auto.
inversion H0; auto.
inversion H2.
Qed.

End Protocol_without_flaw.


Require Coq.setoid_ring.Ncring.
Require Coq.setoid_ring.Cring.
Require Import Coq.Classes.Morphisms.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.OnSubterms.
Require Import Crypto.Util.Tactics.Revert.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Group Crypto.Algebra.Monoid.
Require Coq.ZArith.ZArith Coq.PArith.PArith.

Section Ring.
  Context {T eq zero one opp add sub mul} `{@ring T eq zero one opp add sub mul}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Notation "0" := zero. Local Notation "1" := one.
  Local Infix "+" := add. Local Infix "-" := sub. Local Infix "*" := mul.

  Global Instance Ncring_Ring_ops : @Ncring.Ring_ops T zero one add mul sub opp eq := {}.
  Global Instance Ncring_Ring : @Ncring.Ring T zero one add mul sub opp eq Ncring_Ring_ops.
  Proof using Type*.
    split; exact _ || cbv; intros; eauto using left_identity, right_identity, commutative, associative, right_inverse, left_distributive, right_distributive, ring_sub_definition with core typeclass_instances.
    - (* TODO: why does [eauto using @left_identity with typeclass_instances] not work? *)
      eapply @left_identity; eauto with typeclass_instances.
    - eapply @right_identity; eauto with typeclass_instances.
    - eapply associative.
  Qed.

  Lemma mul_0_l : forall x, 0 * x = 0.
  Proof using Type*. apply Ncring.ring_mul_0_l. Qed.

  Lemma mul_0_r : forall x, x * 0 = 0.
  Proof using Type*. apply Ncring.ring_mul_0_r. Qed.

  Lemma sub_0_l x : 0 - x = opp x.
  Proof using Type*. rewrite ring_sub_definition. rewrite left_identity. reflexivity. Qed.

  Lemma mul_opp_r x y : x * opp y = opp (x * y).
  Proof using Type*. symmetry. apply Ncring.ring_opp_mul_r. Qed.

  Lemma mul_opp_l x y : opp x * y = opp (x * y).
  Proof using Type*. symmetry. apply Ncring.ring_opp_mul_l. Qed.

  Definition opp_zero_iff : forall x, opp x = 0 <-> x = 0 := Group.inv_id_iff.

  Global Instance is_left_distributive_sub : is_left_distributive (eq:=eq)(add:=sub)(mul:=mul).
  Proof using Type*.
    split; intros. rewrite !ring_sub_definition, left_distributive.
    eapply Group.cancel_left, mul_opp_r.
  Qed.

  Global Instance is_right_distributive_sub : is_right_distributive (eq:=eq)(add:=sub)(mul:=mul).
  Proof using Type*.
    split; intros. rewrite !ring_sub_definition, right_distributive.
    eapply Group.cancel_left, mul_opp_l.
  Qed.

  Lemma sub_zero_iff x y : x - y = 0 <-> x = y.
  Proof using Type*.
    split; intro E.
    { rewrite <-(right_identity y), <- E, ring_sub_definition.
      rewrite commutative, <-associative, commutative.
      rewrite left_inverse, left_identity. reflexivity. }
    { rewrite E, ring_sub_definition, right_inverse; reflexivity. }
  Qed.

  Lemma neq_sub_neq_zero x y (Hxy:x<>y) : x-y <> 0.
  Proof using Type*.
    intro Hsub. apply Hxy. rewrite <-(left_identity y), <-Hsub, ring_sub_definition.
    rewrite <-associative, left_inverse, right_identity. reflexivity.
  Qed.

  Lemma zero_product_iff_zero_factor {Hzpzf:@is_zero_product_zero_factor T eq zero mul} :
    forall x y : T, eq (mul x y) zero <-> eq x zero \/ eq y zero.
  Proof using Type*.
    split; eauto using zero_product_zero_factor; [].
    intros [Hz|Hz]; rewrite Hz; eauto using mul_0_l, mul_0_r.
  Qed.

  Lemma nonzero_product_iff_nonzero_factor {Hzpzf:@is_zero_product_zero_factor T eq zero mul} :
    forall x y : T, not (eq (mul x y) zero) <-> (not (eq x zero) /\ not (eq y zero)).
  Proof using Type*. intros; rewrite zero_product_iff_zero_factor; tauto. Qed.

End Ring.

Section Homomorphism.
  Context {R EQ ZERO ONE OPP ADD SUB MUL} `{@ring R EQ ZERO ONE OPP ADD SUB MUL}.
  Context {S eq zero one opp add sub mul} `{@ring S eq zero one opp add sub mul}.
  Context {phi:R->S}.
  Local Infix "=" := eq. Local Infix "=" := eq : type_scope.

  Class is_homomorphism :=
    {
      homomorphism_is_homomorphism : Monoid.is_homomorphism (phi:=phi) (OP:=ADD) (op:=add) (EQ:=EQ) (eq:=eq);
      homomorphism_mul : forall x y, phi (MUL x y) = mul (phi x) (phi y);
      homomorphism_one : phi ONE = one
    }.
  Global Existing Instance homomorphism_is_homomorphism.

  Context `{phi_homom:is_homomorphism}.

  Lemma homomorphism_zero : phi ZERO = zero.
  Proof using Type*. apply Group.homomorphism_id. Qed.

  Lemma homomorphism_add : forall x y,  phi (ADD x y) = add (phi x) (phi y).
  Proof using phi_homom. apply Monoid.homomorphism. Qed.

  Definition homomorphism_opp : forall x,  phi (OPP x) = opp (phi x) :=
    (Group.homomorphism_inv (INV:=OPP) (inv:=opp)).

  Lemma homomorphism_sub : forall x y, phi (SUB x y) = sub (phi x) (phi y).
  Proof using Type*.
    intros.
    rewrite !ring_sub_definition, Monoid.homomorphism, homomorphism_opp. reflexivity.
  Qed.

  Global Instance monoid_homomorphism_mul :
    Monoid.is_homomorphism (phi:=phi) (OP:=MUL) (op:=mul) (EQ:=EQ) (eq:=eq).
  Proof using phi_homom. split; destruct phi_homom; assumption || exact _. Qed.
End Homomorphism.

(* TODO: file a Coq bug for rewrite_strat -- it should accept ltac variables *)
Ltac push_homomorphism phi :=
  let H := constr:(_ : @is_homomorphism _ _ _ _ _ _ _ _ _ _ phi) in
  pose proof (@homomorphism_zero _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_0;
  pose proof (@homomorphism_one _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_1;
  pose proof (@homomorphism_add _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_p;
  pose proof (@homomorphism_opp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_o;
  pose proof (@homomorphism_sub _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_s;
  pose proof (@homomorphism_mul _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_m;
  (rewrite_strat bottomup (terms _push_homomrphism_0 _push_homomrphism_1 _push_homomrphism_p _push_homomrphism_o _push_homomrphism_s _push_homomrphism_m));
  clear _push_homomrphism_0 _push_homomrphism_1 _push_homomrphism_p _push_homomrphism_o _push_homomrphism_s _push_homomrphism_m.

Ltac pull_homomorphism phi :=
  let H := constr:(_ : @is_homomorphism _ _ _ _ _ _ _ _ _ _ phi) in
  pose proof (@homomorphism_zero _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_0;
  pose proof (@homomorphism_one _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_1;
  pose proof (@homomorphism_add _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_p;
  pose proof (@homomorphism_opp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_o;
  pose proof (@homomorphism_sub _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_s;
  pose proof (@homomorphism_mul _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_m;
  symmetry in _pull_homomrphism_0;
  symmetry in _pull_homomrphism_1;
  symmetry in _pull_homomrphism_p;
  symmetry in _pull_homomrphism_o;
  symmetry in _pull_homomrphism_s;
  symmetry in _pull_homomrphism_m;
  (rewrite_strat bottomup (terms _pull_homomrphism_0 _pull_homomrphism_1 _pull_homomrphism_p _pull_homomrphism_o _pull_homomrphism_s _pull_homomrphism_m));
  clear _pull_homomrphism_0 _pull_homomrphism_1 _pull_homomrphism_p _pull_homomrphism_o _pull_homomrphism_s _pull_homomrphism_m.

Section Isomorphism.
  Context {F EQ ZERO ONE OPP ADD SUB MUL} {ringF:@ring F EQ ZERO ONE OPP ADD SUB MUL}.
  Context {H} {eq : H -> H -> Prop} {zero one : H} {opp : H -> H} {add sub mul : H -> H -> H} {inv : H -> H} {div : H -> H -> H}.
  Context {phi:F->H} {phi':H->F}.
  Local Infix "=" := EQ. Local Infix "=" := EQ : type_scope.
  Context (phi'_phi_id : forall A, phi' (phi A) = A)
          (phi'_eq : forall a b, EQ (phi' a) (phi' b) <-> eq a b)
          {phi'_zero : phi' zero = ZERO}
          {phi'_one : phi' one = ONE}
          {phi'_opp : forall a, phi' (opp a) = OPP (phi' a)}
          (phi'_add : forall a b, phi' (add a b) = ADD (phi' a) (phi' b))
          (phi'_sub : forall a b, phi' (sub a b) = SUB (phi' a) (phi' b))
          (phi'_mul : forall a b, phi' (mul a b) = MUL (phi' a) (phi' b)).

  Lemma ring_by_isomorphism
    : @ring H eq zero one opp add sub mul
      /\ @is_homomorphism F EQ ONE ADD MUL H eq one add mul phi
      /\ @is_homomorphism H eq one add mul F EQ ONE ADD MUL phi'.
  Proof using phi'_add phi'_eq phi'_mul phi'_one phi'_opp phi'_phi_id phi'_sub phi'_zero ringF.
    repeat match goal with
           | [ H : field |- _ ] => destruct H; try clear H
           | [ H : commutative_ring |- _ ] => destruct H; try clear H
           | [ H : ring |- _ ] => destruct H; try clear H
           | [ H : commutative_group |- _ ] => destruct H; try clear H
           | [ H : group |- _ ] => destruct H; try clear H
           | [ H : monoid |- _ ] => destruct H; try clear H
           | [ H : is_commutative |- _ ] => destruct H; try clear H
           | [ H : is_left_distributive |- _ ] => destruct H; try clear H
           | [ H : is_right_distributive |- _ ] => destruct H; try clear H
           | [ H : is_zero_neq_one |- _ ] => destruct H; try clear H
           | [ H : is_associative |- _ ] => destruct H; try clear H
           | [ H : is_left_identity |- _ ] => destruct H; try clear H
           | [ H : is_right_identity |- _ ] => destruct H; try clear H
           | [ H : Equivalence _ |- _ ] => destruct H; try clear H
           | [ H : is_left_inverse |- _ ] => destruct H; try clear H
           | [ H : is_right_inverse |- _ ] => destruct H; try clear H
           | _ => intro
           | _ => split
           | [ H : eq _ _ |- _ ] => apply phi'_eq in H
           | [ |- eq _ _ ] => apply phi'_eq
           | [ H : (~eq _ _)%type |- _ ] => pose proof (fun pf => H (proj1 (@phi'_eq _ _) pf)); clear H
           | [ H : EQ _ _ |- _ ] => rewrite H
           | _ => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_phi_id by reflexivity
           | [ H : _ |- _ ] => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_phi_id in H by reflexivity
           | _ => solve [ eauto ]
           end.
  Qed.
End Isomorphism.

Section TacticSupportCommutative.
  Context {T eq zero one opp add sub mul} `{@commutative_ring T eq zero one opp add sub mul}.

  Global Instance Cring_Cring_commutative_ring :
    @Cring.Cring T zero one add mul sub opp eq Ncring_Ring_ops Ncring_Ring.
  Proof using Type. unfold Cring.Cring; intros; cbv. eapply commutative. Qed.

  Lemma ring_theory_for_stdlib_tactic : Ring_theory.ring_theory zero one add mul sub opp eq.
  Proof using Type*.
    constructor; intros. (* TODO(automation): make [auto] do this? *)
    - apply left_identity.
    - apply commutative.
    - apply associative.
    - apply left_identity.
    - apply commutative.
    - apply associative.
    - apply right_distributive.
    - apply ring_sub_definition.
    - apply right_inverse.
  Qed.
End TacticSupportCommutative.

Section Z.
  Import ZArith.
  Global Instance ring_Z : @ring Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul.
  Proof. repeat split; auto using Z.eq_dec with zarith typeclass_instances. Qed.

  Global Instance commutative_ring_Z : @commutative_ring Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul.
  Proof. eauto using @commutative_ring, @is_commutative, ring_Z with zarith. Qed.

  Global Instance integral_domain_Z : @integral_domain Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul.
  Proof.
    split.
    { apply commutative_ring_Z. }
    { split. intros. eapply Z.eq_mul_0; assumption. }
    { split. discriminate. }
  Qed.
End Z.

Section of_Z.
  Import ZArith PArith. Local Open Scope Z_scope.
  Context {R Req Rzero Rone Ropp Radd Rsub Rmul}
          {Rring : @ring R Req Rzero Rone Ropp Radd Rsub Rmul}.
  Local Infix "=" := Req. Local Infix "=" := Req : type_scope.

  Fixpoint of_nat (n:nat) : R :=
    match n with
    | O => Rzero
    | S n' => Radd (of_nat n') Rone
    end.
  Definition of_Z (x:Z) : R :=
    match x with
    | Z0 => Rzero
    | Zpos p => of_nat (Pos.to_nat p)
    | Zneg p => Ropp (of_nat (Pos.to_nat p))
    end.

  Lemma of_Z_0 : of_Z 0 = Rzero.
  Proof using Type*. reflexivity. Qed.

  Lemma of_nat_add x :
    of_nat (Nat.add x 1) = Radd (of_nat x) Rone.
  Proof using Type*. destruct x; rewrite ?Nat.add_1_r; reflexivity. Qed.

  Lemma of_nat_sub x (H: (0 < x)%nat):
    of_nat (Nat.sub x 1) = Rsub (of_nat x) Rone.
  Proof using Type*.
    induction x; [lia|simpl].
    rewrite <-of_nat_add.
    rewrite Nat.sub_0_r, Nat.add_1_r.
    simpl of_nat.
    rewrite ring_sub_definition, <-associative.
    rewrite right_inverse, right_identity.
    reflexivity.
  Qed.

  Lemma of_Z_add_1_r :
    forall x, of_Z (Z.add x 1) = Radd (of_Z x) Rone.
  Proof using Type*.
    destruct x; [reflexivity| | ]; simpl of_Z.
    { rewrite Pos2Nat.inj_add, of_nat_add.
      reflexivity. }
    { rewrite Z.pos_sub_spec; break_match;
        match goal with
        | H : _ |- _ => rewrite Pos.compare_eq_iff in H
        | H : _ |- _ => rewrite Pos.compare_lt_iff in H
        | H : _ |- _ => rewrite Pos.compare_gt_iff in H;
                          apply Pos.nlt_1_r in H; tauto
        end;
        subst; simpl of_Z; simpl of_nat.
      { rewrite left_identity, left_inverse; reflexivity. }
      { rewrite Pos2Nat.inj_sub by assumption.
        rewrite of_nat_sub by apply Pos2Nat.is_pos.
        rewrite ring_sub_definition, Group.inv_op, Group.inv_inv.
        rewrite commutative; reflexivity. } }
  Qed.

  Lemma of_Z_sub_1_r :
    forall x, of_Z (Z.sub x 1) = Rsub (of_Z x) Rone.
  Proof using Type*.
    induction x as [|p|].
    { simpl; rewrite ring_sub_definition, !left_identity;
        reflexivity. }
    { case_eq (1 ?= p)%positive; intros;
        match goal with
        | H : _ |- _ => rewrite Pos.compare_eq_iff in H
        | H : _ |- _ => rewrite Pos.compare_lt_iff in H
        | H : _ |- _ => rewrite Pos.compare_gt_iff in H;
                          apply Pos.nlt_1_r in H; tauto
        end.
      { subst. simpl; rewrite ring_sub_definition, !left_identity,
                      right_inverse; reflexivity. }
      { rewrite <-Pos2Z.inj_sub by assumption; simpl of_Z.
        rewrite Pos2Nat.inj_sub by assumption.
        rewrite of_nat_sub by apply Pos2Nat.is_pos.
        reflexivity. } }
    { simpl. rewrite Pos2Nat.inj_add, of_nat_add.
      rewrite ring_sub_definition, Group.inv_op, commutative.
      reflexivity. }
  Qed.

  Lemma of_Z_opp : forall a,
      of_Z (Z.opp a) = Ropp (of_Z a).
  Proof using Type*.
    destruct a; simpl; rewrite ?Group.inv_id, ?Group.inv_inv;
      reflexivity.
  Qed.

  Lemma of_Z_add : forall a b,
      of_Z (Z.add a b) = Radd (of_Z a) (of_Z b).
  Proof using Type*.
    intros a b.
    let x := match goal with |- ?x => x end in
    let f := match (eval pattern b in x) with ?f _ => f end in
    apply (Z.peano_ind f); intros.
    { rewrite !right_identity. reflexivity. }
    { match goal with
      | [ |- context[?a + Z.succ ?x'] ]
        => rename x' into x
      end.
      replace (a + Z.succ x) with ((a + x) + 1) by ring.
      replace (Z.succ x) with (x+1) by ring.
      rewrite !of_Z_add_1_r; rewrite_hyp *.
      rewrite associative; reflexivity. }
    { match goal with
      | [ |- context[?a + Z.pred ?x'] ]
        => rename x' into x
      end.
      replace (a + Z.pred x) with ((a+x)-1)
        by (rewrite <-Z.sub_1_r; ring).
      replace (Z.pred x) with (x-1) by apply Z.sub_1_r.
      rewrite !of_Z_sub_1_r; rewrite_hyp *.
      rewrite !ring_sub_definition.
      rewrite associative; reflexivity. }
  Qed.

  Lemma of_Z_mul : forall a b,
      of_Z (Z.mul a b) = Rmul (of_Z a) (of_Z b).
  Proof using Type*.
    intros a b.
    let x := match goal with |- ?x => x end in
    let f := match (eval pattern b in x) with ?f _ => f end in
    apply (Z.peano_ind f); intros *; try intro IHb.
    { rewrite !mul_0_r; reflexivity. }
    { rewrite Z.mul_succ_r, <-Z.add_1_r.
      rewrite of_Z_add, of_Z_add_1_r.
      rewrite IHb.
      rewrite left_distributive, right_identity.
      reflexivity. }
    { rewrite Z.mul_pred_r, <-Z.sub_1_r.
      rewrite of_Z_sub_1_r.
      rewrite <-Z.add_opp_r.
      rewrite of_Z_add, of_Z_opp.
      rewrite IHb.
      rewrite ring_sub_definition, left_distributive.
      rewrite mul_opp_r,right_identity.
      reflexivity. }
  Qed.

  Global Instance homomorphism_of_Z :
    @is_homomorphism
      Z Logic.eq Z.one Z.add Z.mul
      R Req  Rone  Radd  Rmul
      of_Z.
  Proof using Type*.
    repeat constructor; intros.
    { apply of_Z_add. }
    { repeat intro; subst; reflexivity. }
    { apply of_Z_mul. }
    { simpl. rewrite left_identity; reflexivity. }
  Qed.
End of_Z.

Section of_Z_absorbs_homomorphism.
  Context {R Req Rzero Rone Ropp Radd Rsub Rmul}
          {Rring : @ring R Req Rzero Rone Ropp Radd Rsub Rmul}.
  Context {R' R'eq R'zero R'one R'opp R'add R'sub R'mul}
          {R'ring : @ring R' R'eq R'zero R'one R'opp R'add R'sub R'mul}.
  Context {phi}
          {Hphi:@is_homomorphism R Req Rone Radd Rmul
                                     R' R'eq R'one R'add R'mul phi}.

  Local Notation R_of_nat := (@of_nat R Rzero Rone Radd) (only parsing).
  Local Notation R'_of_nat := (@of_nat R' R'zero R'one R'add) (only parsing).
  Local Notation R_of_Z := (@of_Z R Rzero Rone Ropp Radd) (only parsing).
  Local Notation R'_of_Z := (@of_Z R' R'zero R'one R'opp R'add) (only parsing).

  Lemma of_nat_absorbs_homomorphism x
    : R'eq (phi (R_of_nat x)) (R'_of_nat x).
  Proof.
    induction x as [|x IHx]; cbn [of_nat];
      repeat first [ rewrite homomorphism_zero
                   | rewrite homomorphism_add
                   | rewrite homomorphism_one
                   | rewrite IHx
                   | reflexivity ].
  Qed.

  Lemma of_Z_absorbs_homomorphism x
    : R'eq (phi (R_of_Z x)) (R'_of_Z x).
  Proof.
    cbv [of_Z]; break_innermost_match;
      repeat first [ rewrite homomorphism_zero
                   | rewrite homomorphism_opp
                   | rewrite of_nat_absorbs_homomorphism
                   | reflexivity ].
  Qed.
End of_Z_absorbs_homomorphism.

Definition char_ge
           {R eq zero one opp add} {sub:R->R->R} {mul:R->R->R}
           C :=
  @Hierarchy.char_ge R eq zero (fun p => (@of_Z R zero one opp add) (BinInt.Z.pos p)) C.
Existing Class char_ge.

(*** Tactics for ring equations *)
Require Export Coq.setoid_ring.Ring_tac.
Ltac ring_simplify_subterms := tac_on_subterms ltac:(fun t => ring_simplify t).

Ltac ring_simplify_subterms_in_all :=
  reverse_nondep; ring_simplify_subterms; intros.

Create HintDb ring_simplify discriminated.
Create HintDb ring_simplify_subterms discriminated.
Create HintDb ring_simplify_subterms_in_all discriminated.
Global Hint Extern 1 => progress ring_simplify : ring_simplify.
Global Hint Extern 1 => progress ring_simplify_subterms : ring_simplify_subterms.
Global Hint Extern 1 => progress ring_simplify_subterms_in_all : ring_simplify_subterms_in_all.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require BuiltIn.
Require real.Real.
Require real.Square.

(* Why3 assumption *)
Definition dot (x1:R) (x2:R) (y1:R) (y2:R): R :=
  ((x1 * y1)%R + (x2 * y2)%R)%R.

(* Why3 assumption *)
Definition norm2 (x1:R) (x2:R): R :=
  ((Reals.RIneq.Rsqr x1) + (Reals.RIneq.Rsqr x2))%R.

Axiom norm2_pos : forall (x1:R) (x2:R), (0%R <= (norm2 x1 x2))%R.

Axiom Lagrange : forall (a1:R) (a2:R) (b1:R) (b2:R), (((norm2 a1
  a2) * (norm2 b1 b2))%R = ((Reals.RIneq.Rsqr (dot a1 a2 b1
  b2)) + (Reals.RIneq.Rsqr ((a1 * b2)%R - (a2 * b1)%R)%R))%R).

Axiom CauchySchwarz_aux : forall (x1:R) (x2:R) (y1:R) (y2:R),
  ((Reals.RIneq.Rsqr (dot x1 x2 y1 y2)) <= ((norm2 x1 x2) * (norm2 y1
  y2))%R)%R.

(* Why3 assumption *)
Definition norm (x1:R) (x2:R): R := (Reals.R_sqrt.sqrt (norm2 x1 x2)).

Axiom norm_pos : forall (x1:R) (x2:R), (0%R <= (norm x1 x2))%R.

Axiom sqr_le_sqrt : forall (x:R) (y:R), ((Reals.RIneq.Rsqr x) <= y)%R ->
  (x <= (Reals.R_sqrt.sqrt y))%R.

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.95.1," timelimit 3.

(* Why3 goal *)
Theorem CauchySchwarz : forall (x1:R) (x2:R) (y1:R) (y2:R), ((dot x1 x2 y1
  y2) <= ((norm x1 x2) * (norm y1 y2))%R)%R.
(* Why3 intros x1 x2 y1 y2. *)
intros x1 x2 y1 y2.
unfold norm.
rewrite <- R_sqrt.sqrt_mult.
apply sqr_le_sqrt.
ae.
ae.
ae.
Qed.


Require Import XR_R.
Require Import XR_Rabs.
Require Import XR_Rabs_pos.
Require Import XR_Rabs_pos_eq.

Local Open Scope R_scope.

Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
Proof.
  intro x.
  apply Rabs_pos_eq.
  apply Rabs_pos.
Qed.


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

(*i $Id: Zpow_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import ZArith_base.
Require Import ZArithRing.
Require Import Zcomplements.
Require Export Zpower.
Require Import Zdiv.
Require Import Znumtheory.
Open Local Scope Z_scope.

Lemma Zpower_pos_1_r: forall x, Zpower_pos x 1 = x.
Proof.
  intros x; unfold Zpower_pos; simpl; auto with zarith.
Qed.

Lemma Zpower_pos_1_l: forall p, Zpower_pos 1 p = 1.
Proof.
  induction p.
  (* xI *)
  rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l.
  repeat rewrite Zpower_pos_is_exp.
  rewrite Zpower_pos_1_r, IHp; auto.
  (* xO *)
  rewrite <- Pplus_diag.
  repeat rewrite Zpower_pos_is_exp.
  rewrite IHp; auto.
  (* xH *)
  rewrite Zpower_pos_1_r; auto.
Qed.

Lemma Zpower_pos_0_l: forall p, Zpower_pos 0 p = 0.
Proof.
  induction p.
  change (xI p) with (1 + (xO p))%positive.
  rewrite Zpower_pos_is_exp, Zpower_pos_1_r; auto.
  rewrite <- Pplus_diag.
  rewrite Zpower_pos_is_exp, IHp; auto.
  rewrite Zpower_pos_1_r; auto.
Qed.

Lemma Zpower_pos_pos: forall x p,
  0 < x -> 0 < Zpower_pos x p.
Proof.
  induction p; intros.
  (* xI *)
  rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l.
  repeat rewrite Zpower_pos_is_exp.
  rewrite Zpower_pos_1_r.
  repeat apply Zmult_lt_0_compat; auto.
  (* xO *)
  rewrite <- Pplus_diag.
  repeat rewrite Zpower_pos_is_exp.
  repeat apply Zmult_lt_0_compat; auto.
  (* xH *)
  rewrite Zpower_pos_1_r; auto.
Qed.

Theorem Zpower_1_r: forall z, z^1 = z.
Proof.
  exact Zpower_pos_1_r.
Qed.

Theorem Zpower_1_l: forall z, 0 <= z -> 1^z = 1.
Proof.
  destruct z; simpl; auto.
  intros; apply Zpower_pos_1_l.
  intros; compute in H; elim H; auto.
Qed.

Theorem Zpower_0_l: forall z, z<>0 -> 0^z = 0.
Proof.
  destruct z; simpl; auto with zarith.
  intros; apply Zpower_pos_0_l.
Qed.

Theorem Zpower_0_r: forall z, z^0 = 1.
Proof.
  simpl; auto.
Qed.

Theorem Zpower_2: forall z, z^2 = z * z.
Proof.
  intros; ring.
Qed.

Theorem Zpower_gt_0: forall x y,
  0 < x -> 0 <= y -> 0 < x^y.
Proof.
  destruct y; simpl; auto with zarith.
  intros; apply Zpower_pos_pos; auto.
  intros; compute in H0; elim H0; auto.
Qed.

Theorem Zpower_Zabs: forall a b,  Zabs (a^b) = (Zabs a)^b.
Proof.
  intros a b; case (Zle_or_lt 0 b).
  intros Hb; pattern b; apply natlike_ind; auto with zarith.
  intros x Hx Hx1; unfold Zsucc.
  (repeat rewrite Zpower_exp); auto with zarith.
  rewrite Zabs_Zmult; rewrite Hx1.
  f_equal; auto.
  replace (a ^ 1) with a; auto.
  simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto.
  simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto.
  case b; simpl; auto with zarith.
  intros p Hp; discriminate.
Qed.

Theorem Zpower_Zsucc: forall p n, 0 <= n -> p^(Zsucc n) = p * p^n.
Proof.
  intros p n H.
  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
  rewrite Zpower_1_r; apply Zmult_comm.
Qed.

Theorem Zpower_mult: forall p q r, 0 <= q -> 0 <= r -> p^(q*r) = (p^q)^r.
Proof.
  intros p q r H1 H2; generalize H2; pattern r; apply natlike_ind; auto.
  intros H3; rewrite Zmult_0_r; repeat rewrite Zpower_exp_0; auto.
  intros r1 H3 H4 H5.
  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
  rewrite <- H4; try rewrite Zpower_1_r; try rewrite <- Zpower_exp; try f_equal; auto with zarith.
  ring.
  apply Zle_ge; replace 0 with (0 * r1); try apply Zmult_le_compat_r; auto.
Qed.

Theorem Zpower_le_monotone: forall a b c,
 0 < a -> 0 <= b <= c -> a^b <= a^c.
Proof.
  intros a b c H (H1, H2).
  rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith.
  rewrite Zpower_exp; auto with zarith.
  apply Zmult_le_compat_l; auto with zarith.
  assert (0 < a ^ (c - b)); auto with zarith.
  apply Zpower_gt_0; auto with zarith.
  apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
Qed.

Theorem Zpower_lt_monotone: forall a b c,
 1 < a -> 0 <= b < c -> a^b < a^c.
Proof.
  intros a b c H (H1, H2).
  rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith.
  rewrite Zpower_exp; auto with zarith.
  apply Zmult_lt_compat_l; auto with zarith.
  apply Zpower_gt_0; auto with zarith.
  assert (0 < a ^ (c - b)); auto with zarith.
  apply Zpower_gt_0; auto with zarith.
  apply Zlt_le_trans with (a ^1); auto with zarith.
  rewrite Zpower_1_r; auto with zarith.
  apply Zpower_le_monotone; auto with zarith.
Qed.

Theorem Zpower_gt_1 : forall x y,
  1 < x -> 0 < y -> 1 < x^y.
Proof.
  intros x y H1 H2.
  replace 1 with (x ^ 0) by apply Zpower_0_r.
  apply Zpower_lt_monotone; auto with zarith.
Qed.

Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y.
Proof.
  intros x y; case y; auto with zarith.
  simpl ; auto with zarith.
  intros p H1; assert (H: 0 <= Zpos p); auto with zarith.
  generalize H; pattern (Zpos p); apply natlike_ind; auto with zarith.
  intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith.
  apply Zmult_le_0_compat; auto with zarith.
  generalize H1; case x; compute; intros; auto; try discriminate.
Qed.

Theorem Zpower_le_monotone2:
   forall a b c, 0 < a -> b <= c -> a^b <= a^c.
Proof.
  intros a b c H H2.
  destruct (Z_le_gt_dec 0 b).
  apply Zpower_le_monotone; auto.
  replace (a^b) with 0.
  destruct (Z_le_gt_dec 0 c).
  destruct (Zle_lt_or_eq _ _ z0).
  apply Zlt_le_weak;apply Zpower_gt_0;trivial.
  rewrite <- H0;simpl;auto with zarith.
  replace (a^c) with 0. auto with zarith.
  destruct c;trivial;unfold Zgt in z0;discriminate z0.
  destruct b;trivial;unfold Zgt in z;discriminate z.
Qed.

Theorem Zmult_power: forall p q r, 0 <= r ->
  (p*q)^r = p^r * q^r.
Proof.
  intros p q r H1; generalize H1; pattern r; apply natlike_ind; auto.
  clear r H1; intros r H1 H2 H3.
  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
  rewrite H2; repeat rewrite Zpower_exp; auto with zarith; ring.
Qed.

Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith.

Theorem Zpower_le_monotone3: forall a b c,
 0 <= c -> 0 <= a <= b -> a^c <= b^c.
Proof.
  intros a b c H (H1, H2).
  generalize H; pattern c; apply natlike_ind; auto.
  intros x HH HH1 _; unfold Zsucc; repeat rewrite Zpower_exp; auto with zarith.
  repeat rewrite Zpower_1_r.
  apply Zle_trans with (a^x * b); auto with zarith.
Qed.

Lemma Zpower_le_monotone_inv: forall a b c,
  1 < a -> 0 < b -> a^b <= a^c -> b <= c.
Proof.
  intros a b c H H0 H1.
  destruct (Z_le_gt_dec b c);trivial.
  assert (2 <= a^b).
   apply Zle_trans with (2^b).
   pattern 2 at 1;replace 2 with (2^1);trivial.
   apply Zpower_le_monotone;auto with zarith.
   apply Zpower_le_monotone3;auto with zarith.
  assert (c > 0).
  destruct (Z_le_gt_dec 0 c);trivial.
  destruct (Zle_lt_or_eq _ _ z0);auto with zarith.
  rewrite <- H3 in H1;simpl in H1; exfalso;omega.
  destruct c;try discriminate z0. simpl in H1. exfalso;omega.
  assert (H4 := Zpower_lt_monotone a c b H). exfalso;omega.
Qed.

Theorem Zpower_nat_Zpower: forall p q, 0 <= q ->
 p^q = Zpower_nat p (Zabs_nat q).
Proof.
  intros p1 q1; case q1; simpl.
  intros _; exact (refl_equal _).
  intros p2 _; apply Zpower_pos_nat.
  intros p2 H1; case H1; auto.
Qed.

Theorem Zpower2_lt_lin: forall n, 0 <= n -> n < 2^n.
Proof.
  intros n; apply (natlike_ind (fun n => n < 2 ^n)); clear n.
  simpl; auto with zarith.
  intros n H1 H2; unfold Zsucc.
  case (Zle_lt_or_eq _ _ H1); clear H1; intros H1.
  apply Zle_lt_trans with (n + n); auto with zarith.
  rewrite Zpower_exp; auto with zarith.
  rewrite Zpower_1_r.
  assert (tmp: forall p, p * 2 = p + p); intros; try ring;
  rewrite tmp; auto with zarith.
  subst n; simpl; unfold Zpower_pos; simpl; auto with zarith.
Qed.

Theorem Zpower2_le_lin: forall n, 0 <= n -> n <= 2^n.
Proof.
  intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto.
Qed.

Lemma Zpower2_Psize :
  forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize p <= n)%nat.
Proof.
  induction n.
  destruct p; split; intros H; discriminate H || inversion H.
  destruct p; simpl Psize.
  rewrite inj_S, Zpower_Zsucc; auto with zarith.
  rewrite Zpos_xI; specialize IHn with p; omega.
  rewrite inj_S, Zpower_Zsucc; auto with zarith.
  rewrite Zpos_xO; specialize IHn with p; omega.
  split; auto with arith.
  intros _; apply Zpower_gt_1; auto with zarith.
  rewrite inj_S; generalize (Zle_0_nat n); omega.
Qed.

(** * Zpower and modulo *)

Theorem Zpower_mod: forall p q n, 0 < n ->
 (p^q) mod n = ((p mod n)^q) mod n.
Proof.
  intros p q n Hn; case (Zle_or_lt 0 q); intros H1.
  generalize H1; pattern q; apply natlike_ind; auto.
  intros q1 Hq1 Rec _; unfold Zsucc; repeat rewrite Zpower_exp; repeat rewrite Zpower_1_r; auto with zarith.
  rewrite (fun x => (Zmult_mod x p)); try rewrite Rec; auto with zarith.
  rewrite (fun x y => (Zmult_mod (x ^y))); try f_equal; auto with zarith.
  f_equal; auto; apply sym_equal; apply Zmod_mod; auto with zarith.
  generalize H1; case q; simpl; auto.
  intros; discriminate.
Qed.

(** A direct way to compute Zpower modulo **)

Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z :=
  match m with
   | xH => a mod n
   | xO m' =>
      let z := Zpow_mod_pos a m' n in
      match z with
       | 0 => 0
       | _ => (z * z) mod n
      end
   | xI m' =>
      let z := Zpow_mod_pos a m' n in
      match z with
       | 0 => 0
       | _ => (z * z * a) mod n
      end
  end.

Definition Zpow_mod a m n :=
  match m with
   | 0 => 1
   | Zpos p => Zpow_mod_pos a p n
   | Zneg p => 0
  end.

Theorem Zpow_mod_pos_correct: forall a m n, 0 < n ->
 Zpow_mod_pos a m n = (Zpower_pos a m) mod n.
Proof.
  intros a m; elim m; simpl; auto.
  intros p Rec n H1; rewrite xI_succ_xO, Pplus_one_succ_r, <-Pplus_diag; auto.
  repeat rewrite Zpower_pos_is_exp; auto.
  repeat rewrite Rec; auto.
  rewrite Zpower_pos_1_r.
  repeat rewrite (fun x => (Zmult_mod x a)); auto with zarith.
  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith.
  case (Zpower_pos a p mod n); auto.
  intros p Rec n H1; rewrite <- Pplus_diag; auto.
  repeat rewrite Zpower_pos_is_exp; auto.
  repeat rewrite Rec; auto.
  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith.
  case (Zpower_pos a p mod n); auto.
  unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith.
Qed.

Theorem Zpow_mod_correct: forall a m n, 1 < n -> 0 <= m ->
 Zpow_mod a m n = (a ^ m) mod n.
Proof.
  intros a m n; case m; simpl.
  intros; apply sym_equal; apply Zmod_small; auto with zarith.
  intros; apply Zpow_mod_pos_correct; auto with zarith.
  intros p H H1; case H1; auto.
Qed.

(* Complements about power and number theory. *)

Lemma Zpower_divide: forall p q, 0 < q -> (p | p ^ q).
Proof.
  intros p q H; exists (p ^(q - 1)).
  pattern p at 3; rewrite <- (Zpower_1_r p); rewrite <- Zpower_exp; try f_equal; auto with zarith.
Qed.

Theorem rel_prime_Zpower_r: forall i p q, 0 < i ->
 rel_prime p q -> rel_prime p (q^i).
Proof.
  intros i p q Hi Hpq; generalize Hi; pattern i; apply natlike_ind; auto with zarith; clear i Hi.
  intros H; contradict H; auto with zarith.
  intros i Hi Rec _; rewrite Zpower_Zsucc; auto.
  apply rel_prime_mult; auto.
  case Zle_lt_or_eq with (1 := Hi); intros Hi1; subst; auto.
  rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1.
Qed.

Theorem rel_prime_Zpower: forall i j p q, 0 <= i ->  0 <= j ->
 rel_prime p q -> rel_prime (p^i) (q^j).
Proof.
  intros i j p q Hi; generalize Hi j p q; pattern i; apply natlike_ind; auto with zarith; clear i Hi j p q.
  intros _ j p q H H1; rewrite Zpower_0_r; apply rel_prime_1.
  intros n Hn Rec _ j p q Hj Hpq.
  rewrite Zpower_Zsucc; auto.
  case Zle_lt_or_eq with (1 := Hj); intros Hj1; subst.
  apply rel_prime_sym; apply rel_prime_mult; auto.
  apply rel_prime_sym; apply rel_prime_Zpower_r; auto with arith.
  apply rel_prime_sym; apply Rec; auto.
  rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1.
Qed.

Theorem prime_power_prime: forall p q n, 0 <= n ->
 prime p -> prime q -> (p | q^n)  -> p = q.
Proof.
  intros p q n Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn.
  rewrite Zpower_0_r; intros.
  assert (2<=p) by (apply prime_ge_2; auto).
  assert (p<=1) by (apply Zdivide_le; auto with zarith).
  omega.
  intros n1 H H1.
  unfold Zsucc; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith.
  assert (2<=p) by (apply prime_ge_2; auto).
  assert (2<=q) by (apply prime_ge_2; auto).
  intros H3; case prime_mult with (2 := H3); auto.
  intros; apply prime_div_prime; auto.
Qed.

Theorem Zdivide_power_2: forall x p n, 0 <= n -> 0 <= x -> prime p ->
 (x | p^n) -> exists m, x = p^m.
Proof.
  intros x p n Hn Hx; revert p n Hn; generalize Hx.
  pattern x; apply Z_lt_induction; auto.
  clear x Hx; intros x IH Hx p n Hn Hp H.
  case Zle_lt_or_eq with (1 := Hx); auto; clear Hx; intros Hx; subst.
  case (Zle_lt_or_eq 1 x); auto with zarith; clear Hx; intros Hx; subst.
  (* x > 1 *)
  case (prime_dec x); intros H2.
  exists 1; rewrite Zpower_1_r; apply prime_power_prime with n; auto.
  case not_prime_divide with (2 := H2); auto.
  intros p1 ((H3, H4), (q1, Hq1)); subst.
  case (IH p1) with p n; auto with zarith.
  apply Zdivide_trans with (2 := H); exists q1; auto with zarith.
  intros r1 Hr1.
  case (IH q1) with p n; auto with zarith.
  case (Zle_lt_or_eq 0 q1).
  apply Zmult_le_0_reg_r with p1; auto with zarith.
  split; auto with zarith.
  pattern q1 at 1; replace q1 with (q1 * 1); auto with zarith.
  apply Zmult_lt_compat_l; auto with zarith.
  intros H5; subst; contradict Hx; auto with zarith.
  apply Zmult_le_0_reg_r with p1; auto with zarith.
  apply Zdivide_trans with (2 := H); exists p1; auto with zarith.
  intros r2 Hr2; exists (r2 + r1); subst.
  apply sym_equal; apply Zpower_exp.
  generalize Hx; case r2; simpl; auto with zarith.
  intros; red; simpl; intros; discriminate.
  generalize H3; case r1; simpl; auto with zarith.
  intros; red; simpl; intros; discriminate.
  (* x = 1 *)
  exists 0; rewrite Zpower_0_r; auto.
  (* x = 0 *)
  exists n; destruct H; rewrite Zmult_0_r in H; auto.
Qed.

(** * Zsquare: a direct definition of [z^2] *)

Fixpoint Psquare (p: positive): positive :=
  match p with
   | xH => xH
   | xO p => xO (xO (Psquare p))
   | xI p => xI (xO (Pplus (Psquare p) p))
  end.

Definition Zsquare p :=
  match p with
   | Z0 => Z0
   | Zpos p => Zpos (Psquare p)
   | Zneg p => Zpos (Psquare p)
  end.

Theorem Psquare_correct: forall p, Psquare p = (p * p)%positive.
Proof.
  induction p; simpl; auto; f_equal; rewrite IHp.
  apply trans_equal with (xO p + xO (p*p))%positive; auto.
  rewrite (Pplus_comm (xO p)); auto.
  rewrite Pmult_xI_permute_r; rewrite Pplus_assoc.
  f_equal; auto.
  symmetry; apply Pplus_diag.
  symmetry; apply Pmult_xO_permute_r.
Qed.

Theorem Zsquare_correct: forall p, Zsquare p = p * p.
Proof.
  intro p; case p; simpl; auto; intros p1; rewrite Psquare_correct; auto.
Qed.


(** Pierre Casteran, LaBRI, University of Bordeaux *)
(** Definition of termination variants *)

Set Implicit Arguments.

From Coq Require Import Relations Basics
     Wellfounded.Inverse_Image Wellfounded.Inclusion.

Section Variants.
 Variable E: Type.
 Variable tr : relation E. (* transition *)

 Definition terminates  :=  well_founded (flip tr).

 Variables (T: Type)
           (lt : relation T)
           (m : E -> T).

 Infix "<" := lt.

 Class WfVariant :=
   {
     wf : well_founded lt;
     decr : forall x y, tr x y -> m y < m x
   }.

Lemma Variant_termination (Var : WfVariant ) :  terminates .
Proof.
  intro x; apply Acc_incl with (fun  a b => m a < m b).
  - intros  a b H; now  apply decr.
  - apply Acc_inverse_image, wf.
Qed.

End Variants.

 Arguments decr {E tr T lt m} _ _ _ _.
 Arguments wf {E tr T lt m} _ _  .


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* *************************************************************************

          Buchberger : Terms

          Laurent Thery April 2001

  ************************************************************************** *)

From Coq Require Import Relation_Definitions.
From Buchberger Require Import CoefStructure moreCoefStructure.
From Buchberger Require Import OrderStructure Monomials.

Set Default Proof Using "Type".

Section Term.
Load hCoefStructure.
Load mCoefStructure.
Load hOrderStructure.
Load mOrderStructure.

Definition M1 := zero_mon n.

Definition Term := (A * mon n)%type.

Set Implicit Arguments.
Unset Strict Implicit.

Definition zeroP : Term -> Prop.
intros H'; case H'.
intros a H'1; exact (eqA a A0).
Defined.

Definition eqTerm : Term -> Term -> Prop.
intros H'; case H'.
intros a a' H'2; case H'2.
intros b b'; exact (eqA a b /\ a' = b').
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem eqTerm_refl : reflexive Term eqTerm.
Proof using plusA multA minusA invA divA cs A1 A0.
red in |- *.
intros x; case x; simpl in |- *; auto.
Qed.

Theorem eqTerm_sym : symmetric Term eqTerm.
Proof using plusA multA minusA invA divA cs A1 A0.
red in |- *.
intros x y; case x; case y; simpl in |- *; intuition.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
Qed.

Theorem eqTerm_trans : transitive Term eqTerm.
Proof using plusA multA minusA invA divA cs A1 A0.
red in |- *.
intros x y z; case x; case y; case z; simpl in |- *; intuition.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := a0); auto.
rewrite H2; auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition T2M : Term -> mon n.
intros t; case t; intros a m; exact m.
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Set Implicit Arguments.
Unset Strict Implicit.

Definition eqT (a b : Term) : Prop := T2M a = T2M b.

Local Hint Unfold eqT : core.

Set Strict Implicit.
Unset Implicit Arguments.

Lemma eqT_refl : reflexive _ eqT.
Proof.
red in |- *; auto.
Qed.

Lemma eqT_sym : symmetric _ eqT.
Proof.
red in |- *; auto.
Qed.

Lemma eqT_trans : transitive _ eqT.
Proof.
red in |- *; unfold eqT in |- *.
intros x y z H' H'0; rewrite H'; auto.
Qed.

Theorem eqTerm_imp_eqT : forall a b : Term, eqTerm a b -> eqT a b.
Proof.
intros a b; case a; case b; simpl in |- *; intuition.
Qed.

Definition eqTerm_dec : forall x y : Term, {eqTerm x y} + {~ eqTerm x y}.
intros x y; case x; case y; simpl in |- *.
intros b2 c2 b3 c3.
case (eqA_dec b3 b2); intros eqAZ; auto.
case (eqmon_dec n c3 c2); intros eqAZ1; auto.
right; red in |- *; intros H'; elim H'; intros H'0 H'1; clear H'; auto.
right; red in |- *; intros H'; elim H'; intros H'0 H'1; clear H'; auto.
Defined.

Theorem eqT_zerop_is_eqTerm :
 forall a b : Term, eqT a b -> zeroP a -> zeroP b -> eqTerm a b.
Proof using plusA multA minusA invA divA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intuition.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := A0); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
Qed.

Definition zeroP_dec : forall x : Term, {zeroP x} + {~ zeroP x}.
intros x; case x; simpl in |- *.
intros b H'.
apply eqA_dec; auto.
Defined.

Theorem zeroP_comp_eqTerm :
 forall a b : Term, zeroP a -> eqTerm a b -> zeroP b.
Proof using plusA multA minusA invA divA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intuition.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := a1); auto;
 apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
Qed.

Theorem nzeroP_comp_eqTerm :
 forall a b : Term, ~ zeroP a -> eqTerm a b -> ~ zeroP b.
Proof using plusA multA minusA invA divA cs A1.
intros a b H' H'0; red in |- *; intros H'1.
apply H'.
apply zeroP_comp_eqTerm with (a := b); auto.
apply eqTerm_sym; auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition plusTerm : Term -> Term -> Term.
intros x; case x; intros b2 c2; intros y; case y; intros b3 c3;
 exact (plusA b2 b3, c2).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem zeroP_plusTermr :
 forall a b : Term, eqT a b -> zeroP b -> eqTerm a (plusTerm a b).
Proof using multA minusA invA divA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros a1 m1 a2 m2 H1 H2; split; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := plusA a2 A0); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
Qed.

Theorem zeroP_plusTerml :
 forall a b : Term, eqT a b -> zeroP a -> eqTerm b (plusTerm a b).
Proof using multA minusA invA divA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros a1 m1 a2 m2 H1 H2; split; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := plusA A0 a1); auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := plusA a1 A0); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
Qed.

Theorem plusTerm_comp_l :
 forall a b c : Term,
 eqT a c -> eqT b c -> eqTerm a b -> eqTerm (plusTerm a c) (plusTerm b c).
Proof using multA minusA invA divA cs A1 A0.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intuition.
Qed.

Theorem plusTerm_comp_r :
 forall a b c : Term,
 eqT c a -> eqT c b -> eqTerm a b -> eqTerm (plusTerm c a) (plusTerm c b).
Proof using multA minusA invA divA cs A1 A0.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intuition.
Qed.

Theorem plusTerm_com :
 forall x y : Term, eqT x y -> eqTerm (plusTerm x y) (plusTerm y x).
Proof using multA minusA invA divA cs A1 A0.
intros a b; case a; case b; simpl in |- *; auto.
Qed.

Theorem plusTerm_eqT1 :
 forall m1 m2 : Term, eqT m1 m2 -> eqT (plusTerm m1 m2) m1.
Proof.
intros a b; case a; case b; simpl in |- *; auto.
Qed.

Theorem plusTerm_eqT2 :
 forall m1 m2 : Term, eqT m1 m2 -> eqT (plusTerm m1 m2) m2.
Proof.
intros a b; case a; case b; simpl in |- *; auto.
Qed.

Theorem plusTerm_assoc :
 forall a a0 A1 : Term,
 eqT A1 a0 ->
 eqT a a0 ->
 eqTerm (plusTerm (plusTerm A1 a0) a) (plusTerm A1 (plusTerm a0 a)).
Proof using multA minusA invA divA cs A1 A0.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intuition.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs).
apply plusA_assoc with (1 := cs).
Qed.

Theorem eqTerm_plusTerm_comp :
 forall a b c d : Term,
 eqT a c ->
 eqT b d -> eqTerm a b -> eqTerm c d -> eqTerm (plusTerm a c) (plusTerm b d).
Proof using multA minusA invA divA cs A1 A0.
intros a b c d; case a; case b; case c; case d; simpl in |- *; auto.
intuition.
Qed.

Local Hint Resolve eqTerm_plusTerm_comp : core.

Set Implicit Arguments.
Unset Strict Implicit.

Definition multTerm : Term -> Term -> Term.
intros H'; case H'; intros b2 c2 H1'; case H1'; intros b3 c3;
 exact (multA b2 b3, mult_mon n c2 c3).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem zeroP_multTerm_l : forall a b : Term, zeroP a -> zeroP (multTerm a b).
Proof using plusA minusA invA divA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros a1 H' b2 H'0 H'1;
 apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA A0 a1);
 auto.
Qed.

Theorem zeroP_multTerm_r : forall a b : Term, zeroP a -> zeroP (multTerm b a).
Proof using plusA minusA invA divA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros a1 H' b2 H'0 H'1;
 apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA a1 A0);
 auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA A0 a1); auto.
Qed.

Theorem multTerm_plusTerm_dist_l :
 forall a b c : Term,
 eqTerm (plusTerm (multTerm a c) (multTerm b c)) (multTerm (plusTerm a b) c).
Proof using minusA invA divA cs A1 A0.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a1 m1 a2 m2 a3 m3; split; auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA (multA a1 a3) (multA a1 a2));
 auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (multA a1 (plusA a3 a2)); auto.
Qed.

Theorem multTerm_plusTerm_dist_r :
 forall a b c : Term,
 eqTerm (plusTerm (multTerm c a) (multTerm c b)) (multTerm c (plusTerm a b)).
Proof using minusA invA divA cs A1 A0.
intros a b c; case a; case b; case c; simpl in |- *; auto.
Qed.

Theorem multTerm_eqT :
 forall a b c d : Term,
 eqT a b -> eqT c d -> eqT (multTerm a c) (multTerm b d).
Proof.
intros a b c d; case a; case b; case c; case d; unfold eqT in |- *;
 simpl in |- *; auto.
intros H' c0 H'0 c2 H'1 c3 H'2 c4 H'3 H'4; rewrite H'3; rewrite H'4; auto.
Qed.

Theorem multTerm_assoc :
 forall a b c : Term,
 eqTerm (multTerm a (multTerm b c)) (multTerm (multTerm a b) c).
Proof using plusA minusA invA divA cs A1 A0.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1; split; auto.
apply multA_assoc with (1 := cs); auto.
apply mult_mon_assoc.
Qed.

Theorem multTerm_com :
 forall a b : Term, eqTerm (multTerm a b) (multTerm b a).
Proof using plusA minusA invA divA cs A1 A0.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0; split; auto.
apply mult_mon_com.
Qed.

Theorem eqTerm_multTerm_comp :
 forall a b c d : Term,
 eqTerm a b -> eqTerm c d -> eqTerm (multTerm a c) (multTerm b d).
Proof using plusA minusA invA divA cs A1 A0.
intros a b c d; case a; case b; case c; case d; simpl in |- *; auto.
intros a1 m1 a2 m2 a3 m3 a4 m4; intros H1; case H1; intros H2 H3 H4; case H4;
 intros H5 H6; split; auto.
rewrite H3; rewrite H6; auto.
Qed.

Local Hint Resolve eqTerm_multTerm_comp : core.

Set Implicit Arguments.
Unset Strict Implicit.

Definition invTerm : Term -> Term.
intros H; case H; intros b2 c2; exact (invA b2, c2).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem plusTerm_invTerm_zeroP :
 forall a : Term, zeroP (plusTerm a (invTerm a)).
Proof using multA minusA divA cs A1.
intros a; case a; simpl in |- *; auto.
intros; apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); apply invA_plusA with (1 := cs);
 auto.
Qed.

Theorem zeroP_invTerm_zeroP : forall a : Term, zeroP a -> zeroP (invTerm a).
Proof using plusA multA minusA divA cs A1.
intros a; case a; simpl in |- *; auto.
intros b H' H'0;
 apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := plusA A0 (invA A0));
 auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := invA A0); auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := plusA (invA A0) A0); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
Qed.

Theorem invTerm_invol : forall a : Term, eqTerm a (invTerm (invTerm a)).
Proof using plusA multA minusA divA cs A1 A0.
intros a; case a; simpl in |- *; auto.
intros a0 m; split; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA a0 A0); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA a0 (plusA (invA a0) (invA (invA a0))));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (plusA a0 (invA a0)) (invA (invA a0)));
 auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA A0 (invA (invA a0))); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA (invA (invA a0)) A0); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
Qed.

Theorem nZero_invTerm_nZero :
 forall a : Term, ~ zeroP a -> ~ zeroP (invTerm a).
Proof using plusA multA minusA divA cs A1.
intros a H'; red in |- *; intros H'0; absurd (zeroP a); auto.
apply zeroP_comp_eqTerm with (a := invTerm (invTerm a)); auto.
apply zeroP_invTerm_zeroP; auto.
apply eqTerm_sym; apply invTerm_invol; auto.
Qed.

Local Hint Resolve nZero_invTerm_nZero : core.

Set Implicit Arguments.
Unset Strict Implicit.

Definition T1 : Term.
exact (A1, M1).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem T1_nz : ~ zeroP T1.
Proof using plusA multA minusA invA divA cs.
simpl in |- *; auto.
apply A1_diff_A0 with (1 := cs).
Qed.

Theorem T1_multTerm_l :
 forall a b : Term, eqTerm a T1 -> eqTerm b (multTerm a b).
Proof using plusA minusA invA divA cs A0.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 H'; elim H'; intros H'0 H'1; rewrite H'1; clear H'; auto.
split; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA A1 a0); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs).
apply multA_A1_l with (1 := cs); auto.
apply multA_eqA_comp with (1 := cs); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply sym_eq; unfold M1 in |- *; apply mult_mon_zero_l.
Qed.

Theorem T1_multTerm_r :
 forall a b : Term, eqTerm a T1 -> eqTerm b (multTerm b a).
Proof using plusA minusA invA divA cs A0.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 H'; elim H'; intros H'0 H'1; rewrite H'1; clear H'.
split; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA a0 A1); auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA A1 a0); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); apply multA_A1_l with (1 := cs); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply sym_eq; unfold M1 in |- *; apply mult_mon_zero_r.
Qed.

Theorem nZero_invTerm_T1 : ~ zeroP (invTerm T1).
Proof using plusA multA minusA divA cs.
apply nZero_invTerm_nZero; auto.
exact T1_nz.
Qed.

Local Hint Resolve nZero_invTerm_T1 : core.

Theorem mult_invTerm_com :
 forall a b : Term, eqTerm (multTerm (invTerm a) b) (invTerm (multTerm a b)).
Proof using plusA minusA divA cs A1 A0.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0; split; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA (multA (invA a1) a0) A0);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (plusA (multA (invA a1) a0) (plusA (multA a1 a0) (invA (multA a1 a0))));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (plusA (plusA (multA (invA a1) a0) (multA a1 a0)) (invA (multA a1 a0)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA (plusA (invA a1) a1) a0) (invA (multA a1 a0)));
 auto.
apply plusA_eqA_comp with (1 := cs); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA a0 (invA a1)) (multA a0 a1));
 auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (multA a0 (plusA (invA a1) a1));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA (plusA a1 (invA a1)) a0) (invA (multA a1 a0)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA A0 a0) (invA (multA a1 a0)));
 auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA A0 (invA (multA a1 a0)));
 auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs);
 apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA (invA (multA a1 a0)) A0);
 auto.
Qed.

Theorem mult_invTerm_com_r :
 forall a b : Term, eqTerm (multTerm a (invTerm b)) (invTerm (multTerm a b)).
Proof using plusA minusA divA cs A1 A0.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0; split; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA (multA a1 (invA a0)) A0);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (plusA (multA a1 (invA a0)) (plusA (multA a1 a0) (invA (multA a1 a0))));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (plusA (plusA (multA a1 (invA a0)) (multA a1 a0)) (invA (multA a1 a0)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA a1 (plusA (invA a0) a0)) (invA (multA a1 a0)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA a1 (plusA a0 (invA a0))) (invA (multA a1 a0)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA a1 A0) (invA (multA a1 a0)));
 auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (plusA (multA A0 a1) (invA (multA a1 a0)));
 auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA A0 (invA (multA a1 a0)));
 auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs);
 apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (plusA (invA (multA a1 a0)) A0);
 auto.
Qed.

Theorem eqTerm_invTerm_comp :
 forall a b : Term, eqTerm a b -> eqTerm (invTerm a) (invTerm b).
Proof using plusA multA minusA divA cs A1 A0.
intros a b; case a; case b; simpl in |- *; auto.
intuition.
Qed.

Theorem invTerm_eqT : forall a : Term, eqT a (invTerm a).
Proof.
intros a; case a; simpl in |- *; auto.
Qed.

Theorem T1_eqT : forall a b : Term, eqTerm a T1 -> eqT b (multTerm a b).
Proof.
intros a b; case a; case b; simpl in |- *; auto.
intros a1 m1 a2 m2 H1; case H1; intros H2 H3; auto.
rewrite H3; auto.
unfold eqT in |- *; simpl in |- *; apply sym_eq; unfold M1 in |- *;
 apply mult_mon_zero_l.
Qed.

Theorem eqTerm_T1_eqT : forall a : Term, eqTerm a T1 -> eqT a T1.
Proof.
intros a; case a; simpl in |- *; auto.
intuition.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition minusTerm : Term -> Term -> Term.
intros H; case H; intros b2 c2 H'; case H'; intros b3 c3;
 exact (minusA b2 b3, c2).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem eqTerm_minusTerm_plusTerm_invTerm :
 forall a b : Term, eqTerm (minusTerm a b) (plusTerm a (invTerm b)).
Proof using multA divA cs A1 A0.
intros a b; case a; case b; simpl in |- *; auto.
split; auto.
apply minusA_def with (1 := cs); auto.
Qed.

Theorem minusTerm_eqT :
 forall m1 m2 : Term, eqT m1 m2 -> eqT (minusTerm m1 m2) m1.
Proof.
intros a b; case a; case b; simpl in |- *; auto.
Qed.

Theorem zeroP_minusTerm : forall a : Term, zeroP (minusTerm a a).
Proof using plusA multA invA divA cs A1.
intros a; apply zeroP_comp_eqTerm with (a := plusTerm a (invTerm a)); auto.
apply plusTerm_invTerm_zeroP; auto.
apply eqTerm_sym; apply eqTerm_minusTerm_plusTerm_invTerm; auto.
Qed.

Theorem multTerm_zeroP_div :
 forall a b : Term, zeroP (multTerm a b) -> zeroP a \/ zeroP b.
Proof using plusA minusA invA eqA_dec divA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 H.
apply A_sep with (2 := eqA_dec) (1 := cs); auto.
Qed.

Theorem multTerm_minusTerm_dist_l :
 forall a b c : Term,
 eqT a b ->
 eqTerm (minusTerm (multTerm a c) (multTerm b c))
   (multTerm (minusTerm a b) c).
Proof using plusA invA divA cs A1 A0.
intros a b c eqT1.
apply eqTerm_trans with (y := multTerm (plusTerm a (invTerm b)) c); auto.
apply
 eqTerm_trans with (y := plusTerm (multTerm a c) (multTerm (invTerm b) c));
 auto.
apply
 eqTerm_trans with (y := plusTerm (multTerm a c) (invTerm (multTerm b c)));
 auto.
apply eqTerm_minusTerm_plusTerm_invTerm; auto.
apply eqTerm_plusTerm_comp; auto.
apply eqT_trans with (y := multTerm b c); auto.
apply multTerm_eqT; auto.
apply invTerm_eqT; auto.
apply multTerm_eqT; auto.
apply eqT_trans with (y := b); auto.
apply invTerm_eqT; auto.
apply eqTerm_refl; auto.
apply eqTerm_sym; apply mult_invTerm_com; auto.
apply multTerm_plusTerm_dist_l; auto.
apply eqTerm_multTerm_comp; auto.
apply eqTerm_sym; apply eqTerm_minusTerm_plusTerm_invTerm; auto.
apply eqTerm_refl; auto.
Qed.

Local Hint Resolve multTerm_minusTerm_dist_l : core.

Theorem nzeroP_multTerm :
 forall a b : Term, ~ zeroP a -> ~ zeroP b -> ~ zeroP (multTerm a b).
Proof using plusA minusA invA eqA_dec divA cs A1.
intros a b H' H'0; red in |- *; intros H'1;
 elim multTerm_zeroP_div with (a := a) (b := b); auto.
Qed.

End Term.


Require Import Arith.
Require Import List.
Import ListNotations.
Require Import Omega.

Require Import v1.Multi.
Require Import v1.NeutronTactics.

Require Import ProofIrrelevance.

Set Default Timeout 10.
Set Implicit Arguments.

Inductive no_dup_index n : list (index n) -> Prop :=
| NdiNil : no_dup_index []
| NdiCons : forall i l,
        Forall (fun i' => index_nat i <> index_nat i') l ->
        no_dup_index l ->
        no_dup_index (i::l).

Inductive sorted_index n : list (index n) -> Prop :=
| SiNil : sorted_index []
| SiCons : forall i l,
        Forall (fun i' => index_nat i < index_nat i') l ->
        sorted_index l ->
        sorted_index (i::l).

Lemma index_list'_sorted :
    forall n i acc Hlt,
    sorted_index acc ->
    Forall (fun i' => i < index_nat i') acc ->
    sorted_index (@index_list' n i acc Hlt).
first_induction i; unfold index_list'; fold index_list'; intros0 Hndi Hfa.
{ (* zero *) constructor; simpl; assumption. }

eapply IHi.
- constructor; simpl; eassumption.
- eapply Forall_cons; simpl.
  + omega.
  + eapply Forall_forall. intros i' Hi'.
    rewrite Forall_forall in Hfa.
    specialize (Hfa i' Hi').
    omega.
Qed.

Lemma sorted_index_no_dup :
    forall n (l : list (index n)),
    sorted_index l -> no_dup_index l.
first_induction l; intros.
{ constructor. }

inversion H; subst.
constructor.
- eapply Forall_impl; eauto.
  simpl. intros. omega.
- eauto.
Qed.

Lemma index_list_no_dup :
    forall n, no_dup_index (index_list n).
intros.
destruct n; unfold index_list.
{ unfold index_list. constructor. }
eapply sorted_index_no_dup.
eapply index_list'_sorted.
- constructor.
- eauto.
Qed.

Lemma no_dup_tail :
    forall n (x : index n) xs,
    no_dup_index (x :: xs) ->
    no_dup_index xs.
intros0 Hdiff. inversion Hdiff. eauto.
Qed.

Lemma no_dup_cons_nat :
    forall n (x x' : index n) xs,
    In x' xs ->
    no_dup_index (x :: xs) ->
    index_nat x <> index_nat x'.
intros0 Hin Hdiff.
inversion Hdiff; subst.
rewrite Forall_forall in *. eauto.
Qed.

Lemma index_list'_length : forall n i acc Hlt,
    length (@index_list' n i acc Hlt) = length acc + S i.
first_induction i; intros; simpl in *.
- omega.
- rewrite IHi. simpl. omega.
Qed.

Lemma index_list_length : forall n,
    length (index_list n) = n.
intros. destruct n.
unfold index_list.
- reflexivity.
- eapply index_list'_length.
Qed.

Lemma index_list'_nth_error_nat : forall n i acc Hlt,
    (forall j idx,
        nth_error acc j = Some idx ->
        index_nat idx = S i + j) ->
    (forall j idx,
        nth_error (@index_list' n i acc Hlt) j = Some idx ->
        index_nat idx = j).
first_induction i; intros0 Hacc; intros0 Hnth; simpl in *.
- destruct j; simpl in *.
  + inject_some. simpl. reflexivity.
  + eapply Hacc. auto.
- eapply IHi; eauto. intros.
  destruct j0; simpl in *.
  + inject_some. simpl. omega.
  + replace (i + S j0) with (S (i + j0)) by omega.
    eapply Hacc. auto.
Qed.

Lemma index_list_nth_error_nat : forall n i idx,
    nth_error (index_list n) i = Some idx ->
    index_nat idx = i.
destruct n; intros.
  { simpl in *. destruct i; discriminate. }
eapply index_list'_nth_error_nat; eauto.
intros. destruct j; discriminate.
Qed.

Lemma index_proof_irrel : forall n (i1 i2 : index n),
    index_nat i1 = index_nat i2 <-> i1 = i2.
intros. split; intro; destruct i1, i2; simpl in *.
- subst. f_equal. apply proof_irrelevance.
- invc H. reflexivity.
Qed.

Lemma index_list_in : forall n (i : index n),
    In i (index_list n).
intros.
destruct i as [i' Hlt].
eapply nth_error_In with (n := i').
destruct (nth_error _ _) eqn:?; cycle 1.
  { rewrite nth_error_None in *. rewrite index_list_length in *. omega. }
forward eapply index_list_nth_error_nat; eauto.
f_equal. eapply index_proof_irrel.
simpl. auto.
Qed.


Notation "[ a ] < [ b ]" := (forall (F : a -> b), exists (y : b), forall (x : a), F x <> y).
Notation "[ a ] > [ b ]" := ([b] < [a]).
Notation "[ a ] = [ b ]" := (~([a] < [b]) /\ ~([a] > [b])).

Proposition prop1 : forall (A : Type), [A] < [A -> bool].
Proof.
intros A F.
remember (fun n => negb (F n n)) as G.
exists G.
intros n H.
assert (F n n = G n).
replace (F n) with G.
reflexivity.
rewrite HeqG in H0.
destruct (F n n).
inversion H0.
inversion H0.
Qed.

Proposition prop2 : forall (A : Type), [A] = [A].
Proof.
intros A.
assert (~ [A]> [A]).
intro H.
assert (H0 := H (fun x => x)).
simpl in H0.
case H0.
intro x.
intro x0.
assert (H1 := x0 x).
congruence.
split.
apply H.
apply H.
Qed.

(*
Proposition prop3 : [nat * nat] = [nat].
Proof.
split.
intro H.
assert (H0 := H (fun t => fst t)).
case H0.
intros x H1.
simpl in H1.
assert (H2 := H1 (pair x x)).
simpl in H2.
congruence.
intro H.
assert (H0 := H (fun n => pair n n)).
case H0.
intros x H1.
assert (H2 := H1 (fst x)).
*)


Theorem Modus_ponens : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
  intros.
  apply H0.
  apply H.
Qed.