(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    EGroup.v

    Given an element a, create the group {e, a, a^2, ..., a^n}
 **********************************************************************)
Require Import ZArith.
Require Import Tactic.
Require Import List.
Require Import ZAux.
Require Import Wf_nat.
Require Import UList.
Require Import FGroup.
Require Import Lagrange.

Open Scope Z_scope.

Section EGroup.

Variable A: Type.

Variable A_dec: forall a b: A, {a = b} + {~ a = b}.

Variable op: A -> A -> A.

Variable a: A.

Variable G: FGroup op.

Hypothesis a_in_G: In a G.(s).

(**************************************
  The power function for the group
 **************************************)

Set Implicit Arguments.
Definition gpow n :=
  match n with
  | Z0 => G.(e)
  | Zpos p => iter_pos p _ (op a) G.(e)
  | Zneg p  => G.(i) (iter_pos p _ (op a) G.(e))
  end.
Unset Implicit Arguments.

Theorem gpow_0: gpow 0 = G.(e).
Proof.
 simpl; sauto.
Qed.

Theorem gpow_1 : gpow 1 = a.
Proof.
 simpl; sauto.
Qed.

(**************************************
  Some properties of the power function
 **************************************)

Theorem gpow_in: forall n, In (gpow n) G.(s).
Proof.
 intros n; case n; simpl; auto.
 intros p; apply iter_pos_invariant with (Inv := fun x => In x G.(s)); auto.
 intro p; apply i_internal.
 apply iter_pos_invariant with (Inv := fun x => In x G.(s)); auto.
Qed.

Theorem gpow_op: forall b p, In b G.(s) -> iter_pos p _ (op a) b = op (iter_pos p _ (op a) G.(e)) b.
Proof.
 intros b p; generalize b; elim p; simpl; auto; clear  b p.
 intros p Rec b Hb.
 assert (H: In (gpow (Zpos p)) G.(s)).
 apply gpow_in.
 rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos p A x y)); auto.
 repeat rewrite G.(assoc); auto.
 intros p Rec b Hb.
 assert (H: In (gpow (Zpos p)) G.(s)).
 apply gpow_in.
 rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos p A x y)); auto.
 repeat rewrite G.(assoc); auto.
 intros b H; rewrite e_is_zero_r; auto.
Qed.

Theorem gpow_add: forall n m, 0 <= n -> 0 <= m -> gpow (n + m) = op (gpow n) (gpow m).
Proof.
 intros n; case n.
 intros m _ _; simpl; apply sym_equal; apply e_is_zero_l; apply gpow_in.
 2: intros p m H; contradict H; auto with zarith.
 intros p1 m; case m.
 intros _ _; simpl; apply sym_equal; apply e_is_zero_r.
 exact (gpow_in (Zpos p1)).
 2: intros p2 _ H; contradict H; auto with zarith.
 intros p2 _ _; simpl.
 rewrite iter_pos_plus; rewrite (fun x y => gpow_op (iter_pos p2 A x y)); auto.
 exact (gpow_in (Zpos p2)).
Qed.

Lemma gpow_neg : forall p, gpow (Zneg p) = i G (gpow (Zpos p)).
Proof.
 intros p;simpl; trivial.
Qed.

Lemma gpow_add_pos_neg :forall p1 p2 : positive,
   gpow (Zpos p1 + Zneg p2) = op (gpow (Zpos p1)) (gpow (Zneg p2)).
Proof.
 intros p1 p2; case_eq (Zpos p1 + Zneg p2); intros.

 assert (- Zpos p1 = Zneg p2) by omega.
 rewrite <- H0.
 cutrewrite (- Zpos p1 = Zneg p1); simpl; trivial.
 rewrite i_is_inverse_r; trivial.
 exact (gpow_in (Zpos p1)).

 assert (Zpos p1 = Zpos p + Zpos p2).
 rewrite <- H, <- (Zopp_neg p2).
 cutrewrite (Zpos p1 + Zneg p2 + - Zneg p2 = Zpos p1);[ trivial | ring ].
 rewrite H0, gpow_add; simpl.
 rewrite <- (assoc G), i_is_inverse_r.
 apply gpow_op.
 apply e_in_s.
 exact (gpow_in (Zpos p2)).
 exact (gpow_in (Zpos p)).
 exact (gpow_in (Zpos p2)).
 apply i_internal.
 exact (gpow_in (Zpos p2)).
 apply Zle_0_pos.
 apply Zle_0_pos.

 assert (Zpos p2 = Zpos p + Zpos p1).
 cutrewrite (Zpos p = Zpos p2 + Zneg p1).
 rewrite <- (Zopp_neg p1); ring.
 rewrite <- (Zopp_neg p2), <- (Zopp_neg p).
 cutrewrite (Zneg p1 = - Zpos p1); [omega | ].
 rewrite <- (Zopp_neg p1); ring.
 repeat rewrite gpow_neg.
 rewrite H0, gpow_add, inv_op, (assoc G), i_is_inverse_r, e_is_zero_l; trivial.
 apply i_internal; exact (gpow_in (Zpos p)).
 exact (gpow_in (Zpos p1)).
 exact (gpow_in (Zpos p1)).
 apply i_internal; exact (gpow_in (Zpos p1)).
 apply i_internal; exact (gpow_in (Zpos p)).
 exact (gpow_in (Zpos p)).
 exact (gpow_in (Zpos p1)).
 apply Zle_0_pos.
 apply Zle_0_pos.
Qed.

Lemma gpow_add_neg_pos :forall p1 p2 : positive,
   gpow (Zneg p1 + Zpos p2) = op (gpow (Zneg p1)) (gpow (Zpos p2)).
Proof.
 intros p1 p2; case_eq (Zneg p1 + Zpos p2); intros.

 assert (- Zneg p1 = Zpos p2) by omega.
 rewrite <- H0.
 cutrewrite (- Zneg p1 = Zpos p1); simpl; trivial.
 rewrite i_is_inverse_l; trivial.
 exact (gpow_in (Zpos p1)).

 assert (Zpos p2 = Zpos p + Zpos p1).
 rewrite <- H.
 rewrite <- (Zopp_neg p1); ring.
 repeat rewrite gpow_neg.
 rewrite H0, Zplus_comm, gpow_add, (assoc G), i_is_inverse_l, e_is_zero_l; trivial.
 exact (gpow_in (Zpos p)).
 exact (gpow_in (Zpos p1)).
 apply i_internal; exact (gpow_in (Zpos p1)).
 exact (gpow_in (Zpos p1)).
 exact (gpow_in (Zpos p)).
 apply Zle_0_pos.
 apply Zle_0_pos.

 assert (Zpos p1 = Zpos p + Zpos p2).
 cutrewrite (Zpos p = Zpos p1 + Zneg p2).
 rewrite <- (Zopp_neg p2); ring.
 rewrite <- (Zopp_neg p1), <- (Zopp_neg p).
 cutrewrite (Zneg p2 = - Zpos p2); [omega | ].
 rewrite <- (Zopp_neg p2); ring.
 repeat rewrite gpow_neg.
 rewrite H0, Zplus_comm, gpow_add, inv_op, <- (assoc G), i_is_inverse_l, e_is_zero_r; trivial.
 apply i_internal; exact (gpow_in (Zpos p)).
 exact (gpow_in (Zpos p2)).
 apply i_internal; exact (gpow_in (Zpos p)).
 apply i_internal; exact (gpow_in (Zpos p2)).
 exact (gpow_in (Zpos p2)).
 exact (gpow_in (Zpos p2)).
 exact (gpow_in (Zpos p)).
 apply Zle_0_pos.
 apply Zle_0_pos.
Qed.

Theorem gpow_add_full: forall n m, gpow (n + m) = op (gpow n) (gpow m).
Proof.
 intros n; case n.

 intros m; simpl; apply sym_equal; apply e_is_zero_l; apply gpow_in.

 intros p1 m; case m; intros.
 simpl; apply sym_equal; apply e_is_zero_r.
 exact (gpow_in (Zpos p1)).
 apply gpow_add; apply Zle_0_pos.
 apply gpow_add_pos_neg.

 intros p1 m; case m; intros.
 simpl; apply sym_equal; apply e_is_zero_r.
 apply i_internal.
 exact (gpow_in (Zpos p1)).
 apply gpow_add_neg_pos.

 rewrite <- Zneg_plus_distr.
 simpl.

 rewrite <- inv_op.
 apply f_equal.
 rewrite <- gpow_op, Pplus_comm, iter_pos_plus; trivial.
 exact (gpow_in (Zpos p1)).
 exact (gpow_in (Zpos p)).
 exact (gpow_in (Zpos p1)).
Qed.

Theorem gpow_1_more:
  forall n, 0 < n -> gpow n = G.(e) -> forall m, 0 <= m -> exists p, 0 <= p < n /\ gpow m = gpow p.
Proof.
 intros n H1 H2 m Hm;  generalize Hm; pattern m; apply Z_lt_induction; auto with zarith; clear m Hm.
 intros m Rec Hm.
 case (Zle_or_lt n m); intros H3.
 case (Rec (m - n)); auto with zarith.
 intros p (H4,H5); exists p; split; auto.
 replace m with (n + (m - n)); auto with zarith.
 rewrite gpow_add; try rewrite H2; try rewrite H5; sauto; auto with zarith.
 generalize gpow_in; sauto.
 exists m; auto.
Qed.

Theorem gpow_i: forall n m, 0 <= n -> 0 <= m -> gpow n = gpow (n + m) -> gpow m = G.(e).
intros n m H1 H2 H3; generalize gpow_in; intro PI.
apply g_cancel_l with (g:= G) (a := gpow n); sauto.
rewrite <- gpow_add; try rewrite <- H3; sauto.
Qed.

(**************************************
  We build the support by iterating the power function
 **************************************)

Set Implicit Arguments.

Fixpoint support_aux (b: A) (n: nat) {struct n}: list A :=
b::let c := op a b in
    match n with
       O => nil |
      (S n1) =>if A_dec c G.(e) then nil else  support_aux c n1
    end.

Definition support := support_aux G.(e) (Zabs_nat (g_order G)).

Unset Implicit Arguments.

(**************************************
  Some properties of the support that helps to prove that we have a group
 **************************************)

Theorem support_aux_gpow:
  forall n m b, 0 <=  m -> In b (support_aux (gpow m) n) ->
        exists p, (0 <= p < length (support_aux (gpow m) n))%nat  /\ b = gpow (m + Z_of_nat p).
intros n; elim n; simpl.
intros n1 b Hm [H1 | H1]; exists 0%nat; simpl; rewrite Zplus_0_r; auto; case H1.
intros n1 Rec m b Hm [H1 | H1].
exists 0%nat; simpl; rewrite Zplus_0_r; auto; auto with arith.
generalize H1; case (A_dec (op a (gpow m)) G.(e)); clear H1; simpl; intros H1 H2.
case H2.
case (Rec (1 + m) b); auto with zarith.
rewrite gpow_add; auto with zarith.
rewrite gpow_1; auto.
intros p (Hp1, Hp2); exists (S p); split; auto with zarith.
rewrite <- gpow_1.
rewrite <- gpow_add; auto with zarith.
rewrite inj_S; rewrite Hp2; eq_tac; auto with zarith.
Qed.

Theorem gpow_support_aux_not_e:
  forall n m p, 0 <= m -> m < p < m + Z_of_nat (length (support_aux (gpow m) n)) -> gpow p <> G.(e).
intros n; elim n; simpl.
intros m p Hm (H1, H2); contradict H2; auto with zarith.
intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl.
intros _ (H1, H2); contradict H2; auto with zarith.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp.
intros H1 (H2, H3); case (Zle_lt_or_eq (1 + m) p); auto with zarith; intros H4; subst.
apply (Rec (1 + m)); try split; auto with zarith.
rewrite gpow_add; auto with zarith.
rewrite gpow_1; auto with zarith.
rewrite gpow_add; try rewrite gpow_1; auto with zarith.
Qed.

Theorem support_aux_not_e: forall n m b, 0 <= m -> In b (tail (support_aux (gpow m) n)) -> ~ b = G.(e).
intros n; elim n; simpl.
intros m b Hm H; case H.
intros n1 Rec m b Hm; case (A_dec (op a (gpow m)) G.(e)); intros H1 H2; simpl; auto.
assert (Hm1: 0 <= 1 + m); auto with zarith.
generalize( Rec (1 + m) b Hm1) H2; case n1; auto; clear Hm1.
intros _ [H3 | H3]; auto.
contradict H1; subst; auto.
rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith.
intros n2; case (A_dec (op a (op a (gpow m))) G.(e)); intros H3.
intros _ [H4 | H4].
contradict H1; subst; auto.
case H4.
intros H4 [H5 | H5]; subst; auto.
Qed.

Theorem support_aux_length_le: forall n a, (length (support_aux a n) <= n + 1)%nat.
intros n; elim n; simpl; auto.
intros n1 Rec a1; case (A_dec (op a a1) G.(e)); simpl; auto with arith.
Qed.

Theorem support_aux_length_le_is_e:
   forall n m, 0 <= m ->  (length (support_aux (gpow m) n) <= n)%nat ->
      gpow (m + Z_of_nat (length (support_aux (gpow m) n))) = G.(e) .
intros n; elim n; simpl; auto.
intros m _ H1; contradict H1; auto with arith.
intros n1 Rec m Hm; case (A_dec (op a (gpow m)) G.(e)); simpl;  intros H1.
intros H2; rewrite Zplus_comm; rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp.
rewrite <- gpow_1.
rewrite <- gpow_add; auto with zarith.
rewrite  Zplus_assoc; rewrite (Zplus_comm 1); intros H2; apply Rec; auto with zarith.
Qed.

Theorem support_aux_in:
  forall n m p, 0 <= m ->  (p < length (support_aux (gpow m) n))% nat ->
            (In (gpow (m + Z_of_nat p)) (support_aux (gpow m) n)).
intros n; elim n; simpl; auto; clear n.
intros m p Hm H1; replace p with 0%nat.
left; eq_tac; auto with zarith.
generalize H1; case p; simpl; auto with arith.
intros n H2; contradict H2; apply le_not_lt; auto with arith.
intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl; intros H1 H2; auto.
replace p with 0%nat.
left; eq_tac; auto with zarith.
generalize H2; case p; simpl; auto with arith.
intros n H3; contradict H3; apply le_not_lt; auto with arith.
generalize H2; case p; simpl; clear H2.
rewrite Zplus_0_r; auto.
intros n.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp.
rewrite <- gpow_1; rewrite <- gpow_add; auto with zarith.
rewrite  Zplus_assoc; rewrite (Zplus_comm 1); intros H2; right; apply Rec; auto with zarith.
Qed.

Theorem support_aux_ulist:
  forall n m, 0 <= m -> (forall p, 0 <= p < m -> gpow (1 + p) <> G.(e)) -> ulist (support_aux (gpow m) n).
intros n; elim n; auto; clear n.
intros m _ _; auto.
simpl; apply ulist_cons; auto.
intros n1 Rec m Hm H.
simpl; case (A_dec (op a (gpow m)) G.(e)); auto.
intros He; apply ulist_cons; auto.
intros H1; case  (support_aux_gpow n1 (1 + m) (gpow m)); auto with zarith.
rewrite gpow_add; try rewrite gpow_1; auto with zarith.
intros p (Hp1, Hp2).
assert (H2: gpow (1 + Z_of_nat p) = G.(e)).
apply gpow_i with m; auto with zarith.
rewrite Hp2; eq_tac; auto with zarith.
case (Zle_or_lt m  (Z_of_nat p)); intros H3; auto.
2: case (H (Z_of_nat p)); auto with zarith.
case (support_aux_not_e (S n1) m (gpow (1 + Z_of_nat p))); auto.
rewrite gpow_add; auto with zarith; simpl; rewrite e_is_zero_r; auto.
case (A_dec (op a (gpow m)) G.(e)); auto.
intros _; rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith.
replace (1 + Z_of_nat p) with ((1 + m) + (Z_of_nat (p - Zabs_nat m))); auto with zarith.
apply support_aux_in; auto with zarith.
rewrite inj_minus1; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
apply inj_le_inv.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith.
apply (Rec (1 + m)); auto with zarith.
intros p H1; case (Zle_lt_or_eq p m); intros; subst; auto with zarith.
rewrite  gpow_add; auto with zarith.
rewrite gpow_1; auto.
Qed.

Theorem support_gpow: forall b, (In b support) -> exists p, 0 <= p < Z_of_nat (length support) /\ b = gpow p.
intros b H; case (support_aux_gpow  (Zabs_nat (g_order G)) 0 b); auto with zarith.
intros p ((H1, H2), H3); exists (Z_of_nat p); repeat split; auto with zarith.
apply inj_lt; auto.
Qed.

Theorem support_incl_G: incl support G.(s).
intros a1 H; case (support_gpow a1); auto; intros p (H1, H2); subst; apply gpow_in.
Qed.

Theorem gpow_support_not_e: forall p, 0 < p < Z_of_nat (length support) -> gpow p <> G.(e).
intros p (H1, H2); apply gpow_support_aux_not_e with (m := 0) (n := length G.(s)); simpl;
  try split; auto with zarith.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
Qed.

Theorem support_not_e: forall b, In b (tail support) -> ~ b = G.(e).
intros b H; apply (support_aux_not_e (Zabs_nat (g_order G)) 0); auto with zarith.
Qed.

Theorem support_ulist:  ulist support.
apply (support_aux_ulist (Zabs_nat (g_order G)) 0); auto with zarith.
Qed.

Theorem support_in_e:  In G.(e) support.
unfold support; case (Zabs_nat (g_order G)); simpl; auto with zarith.
Qed.

Theorem gpow_length_support_is_e: gpow (Z_of_nat (length support)) = G.(e).
apply (support_aux_length_le_is_e (Zabs_nat (g_order G)) 0); simpl; auto with zarith.
unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_ulist.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_incl_G.
Qed.

Theorem support_in:  forall p, 0 <= p < Z_of_nat (length support) ->  In (gpow p) support.
intros p (H, H1); unfold support.
rewrite <-  (Z_of_nat_Zabs_nat p); auto.
generalize (support_aux_in (Zabs_nat (g_order G)) 0); simpl; intros H2; apply H2; auto with zarith.
rewrite <-  (fun x => Zabs_nat_Z_of_nat (@length A x)); auto.
apply Zabs_nat_lt; split; auto.
Qed.

Theorem support_internal: forall a b, In a support -> In b support -> In (op a b) support.
intros a1 b1 H1 H2.
case support_gpow with (1 := H1); auto; intros p1 ((H3, H4), H5); subst.
case support_gpow with (1 := H2); auto; intros p2 ((H5, H6), H7); subst.
rewrite <- gpow_add; auto with zarith.
case gpow_1_more with (m:= p1 + p2)   (2 := gpow_length_support_is_e); auto with zarith.
intros p3 ((H8, H9), H10); rewrite H10; apply support_in; auto with zarith.
Qed.

Theorem support_i_internal: forall a, In a support -> In (G.(i) a) support.
generalize gpow_in; intros Hp.
intros a1 H1.
case support_gpow with (1 := H1); auto.
intros p1 ((H2, H3), H4); case Zle_lt_or_eq with (1 := H2); clear H2; intros H2; subst.
2: rewrite gpow_0; rewrite i_e; apply support_in_e.
replace (G.(i) (gpow p1)) with (gpow (Z_of_nat (length support - Zabs_nat p1))).
apply support_in; auto with zarith.
rewrite inj_minus1.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
apply inj_le_inv; rewrite Z_of_nat_Zabs_nat; auto with zarith.
apply g_cancel_l with (g:= G) (a := gpow p1); sauto.
rewrite <- gpow_add; auto with zarith.
replace (p1 + Z_of_nat (length support - Zabs_nat p1)) with (Z_of_nat (length support)).
rewrite gpow_length_support_is_e; sauto.
rewrite inj_minus1; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
apply inj_le_inv; rewrite Z_of_nat_Zabs_nat; auto with zarith.
Qed.

(**************************************
  We are now ready to build the group
 **************************************)

Definition Gsupport: (FGroup op).
generalize support_incl_G; unfold incl; intros Ho.
apply mkGroup with support G.(e) G.(i); sauto.
apply support_ulist.
apply support_internal.
intros a1 b1 c1 H1 H2 H3; apply G.(assoc); sauto.
apply support_in_e.
apply support_i_internal.
Defined.

(**************************************
  Definition of the order of an element
 **************************************)
Set Implicit Arguments.

Definition e_order := Z_of_nat (length support).

Unset Implicit Arguments.

(**************************************
 Some properties of the order of an element
 **************************************)

Theorem gpow_e_order_is_e: gpow e_order = G.(e).
apply (support_aux_length_le_is_e (Zabs_nat (g_order G)) 0); simpl; auto with zarith.
unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_ulist.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_incl_G.
Qed.

Theorem gpow_e_order_lt_is_not_e: forall n, 1 <= n < e_order -> gpow n <> G.(e).
intros n (H1, H2); apply gpow_support_not_e; auto with zarith.
Qed.

Theorem e_order_divide_g_order:  (e_order | g_order G).
change ((g_order Gsupport) | g_order G).
apply lagrange; auto.
exact support_incl_G.
Qed.

Theorem e_order_pos: 0 < e_order.
unfold e_order, support; case (Zabs_nat (g_order G)); simpl; auto with zarith.
intros n; red; auto.
Qed.

Theorem e_order_divide_gpow: forall n, 0 <= n -> gpow n = G.(e) -> (e_order | n).
generalize gpow_in; intros Hp.
generalize e_order_pos; intros Hp1.
intros n Hn; generalize Hn; pattern n; apply Z_lt_induction; auto; clear n Hn.
intros n Rec Hn H.
case (Zle_or_lt  e_order n); intros H1.
case (Rec (n - e_order)); auto with zarith.
apply g_cancel_l with (g:= G) (a := gpow e_order); sauto.
rewrite G.(e_is_zero_r); auto with zarith.
rewrite <- gpow_add; try (rewrite gpow_e_order_is_e; rewrite <- H; eq_tac); auto with zarith.
intros k Hk; exists (1 + k).
rewrite Zmult_plus_distr_l; rewrite <- Hk; auto with zarith.
case (Zle_lt_or_eq 0 n); auto with arith; intros H2; subst.
contradict H; apply support_not_e.
generalize H1; unfold e_order, support.
case (Zabs_nat (g_order G)); simpl; auto.
intros H3; contradict H3; auto with zarith.
intros n1; case (A_dec (op a G.(e)) G.(e)); simpl; intros _ H3.
contradict H3; auto with zarith.
generalize H3; clear H3.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp; intros H3.
change (In (gpow n) (support_aux (gpow 1) n1)).
replace n with (1 + Z_of_nat (Zabs_nat n - 1)).
apply support_aux_in; auto with zarith.
rewrite <- (fun x => Zabs_nat_Z_of_nat (@length A x)).
replace (Zabs_nat n - 1)%nat  with (Zabs_nat (n - 1)).
apply Zabs_nat_lt; split; auto with zarith.
rewrite G.(e_is_zero_r) in H3; try rewrite gpow_1; auto with zarith.
apply inj_eq_inv; rewrite Z_of_nat_Zabs_nat; auto with zarith.
rewrite inj_minus1; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
apply inj_le_inv; rewrite Z_of_nat_Zabs_nat; simpl; auto with zarith.
rewrite inj_minus1; auto with zarith.
rewrite Z_of_nat_Zabs_nat; auto with zarith.
rewrite Zplus_comm; simpl; auto with zarith.
apply inj_le_inv; rewrite Z_of_nat_Zabs_nat; simpl; auto with zarith.
exists 0; auto with arith.
Qed.

End EGroup.

Theorem gpow_gpow: forall (A : Type) (op : A -> A -> A) (a : A) (G : FGroup op),
       In a (s G) -> forall n m, 0 <= n -> 0 <= m -> gpow a G (n * m ) = gpow (gpow a G n) G m.
Proof.
 intros A op a G H n m; case n.
 simpl; intros _ H1; generalize H1.
 pattern m; apply natlike_ind; simpl; auto.
 intros x H2 Rec _; unfold Zsucc; rewrite gpow_add; simpl; auto with zarith.
 repeat rewrite G.(e_is_zero_r); auto with zarith.
 apply gpow_in; sauto.
 intros p1 _; case m; simpl; auto.
 assert(H1: In (iter_pos p1 A (op a) (e G)) (s G)).
 refine (gpow_in _ _ _ _ _ (Zpos p1)); auto.
 intros p2 _;  pattern p2; apply Pind; simpl; auto.
 rewrite Pmult_1_r; rewrite G.(e_is_zero_r); try rewrite G.(e_is_zero_r); auto.
 intros p3 Rec; rewrite Pplus_one_succ_r; rewrite Pmult_plus_distr_l.
 rewrite Pmult_1_r.
 simpl; repeat rewrite iter_pos_plus; simpl.
 rewrite G.(e_is_zero_r); auto.
 rewrite gpow_op with (G:= G); try rewrite Rec; auto.
 apply sym_equal; apply gpow_op; auto.
 intros p Hp; contradict Hp; auto with zarith.
 intros.
 assert (H2 := Zlt_neg_0 p).
 elimtype False; omega.
Qed.

Theorem gpow_e: forall (A : Type) (op : A -> A -> A) (G : FGroup op) n, 0 <= n -> gpow G.(e) G n = G.(e).
 intros A op G n; case n; simpl; auto with zarith.
 intros p _; elim p; simpl; auto; intros p1 Rec; repeat rewrite Rec; auto.
 intros; assert (H2 := Zlt_neg_0 p).
 elimtype False; omega.
Qed.

Theorem gpow_pow: forall (A : Type) (op : A -> A -> A) (a : A) (G : FGroup op),
       In a (s G) -> forall n, 0 <= n -> gpow a G (2 ^ n) = G.(e) -> forall m, n <= m -> gpow a G (2 ^ m) = G.(e).
intros A op a G H n H1 H2 m Hm.
replace m with (n + (m - n)); auto with zarith.
rewrite Zpower_exp; auto with zarith.
rewrite gpow_gpow; auto with zarith.
rewrite H2; apply gpow_e.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
Qed.

Theorem gpow_mult: forall (A : Type) (op : A -> A -> A) (a b: A) (G : FGroup op)
       (comm: forall a b,  In a (s G) -> In b (s G) -> op a b = op b a),
       In a (s G) -> In b (s G) -> forall n, 0 <= n -> gpow (op a b) G n = op (gpow a G n) (gpow b G n).
intros A op a  b G comm Ha Hb n; case n; simpl; auto.
intros _; rewrite G.(e_is_zero_r); auto.
2: intros p Hp; contradict Hp; auto with zarith.
intros p _; pattern p; apply Pind; simpl; auto.
repeat rewrite G.(e_is_zero_r); auto.
intros p3 Rec; rewrite Pplus_one_succ_r.
repeat rewrite iter_pos_plus; simpl.
repeat rewrite (fun x y H z => gpow_op A  op x G H (op y z)) ; auto.
rewrite Rec.
repeat rewrite G.(e_is_zero_r); auto.
assert(H1: In (iter_pos p3 A (op a) (e G)) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p3)); auto.
assert(H2: In (iter_pos p3 A (op b) (e G)) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p3)); auto.
repeat rewrite <- G.(assoc); try eq_tac; auto.
rewrite (fun x y => comm (iter_pos p3 A x y) b); auto.
rewrite (G.(assoc) a); try apply comm; auto.
Qed.

Theorem Zdivide_mult_rel_prime:  forall a b c : Z, (a | c) -> (b | c) -> rel_prime a b -> (a * b | c).
intros a b c (q1, H1) (q2, H2) H3.
assert (H4: (a | q2)).
apply Gauss with (2 := H3).
exists q1; rewrite <- H1; rewrite H2; auto with zarith.
case H4; intros q3 H5; exists q3; rewrite H2; rewrite H5; auto with zarith.
Qed.

Theorem order_mult: forall (A : Type) (op : A -> A -> A) (A_dec: forall a b: A, {a = b} + {~ a = b}) (G : FGroup op)
       (comm: forall a b,  In a (s G) -> In b (s G) -> op a b = op b a) (a b: A),
       In a (s G) -> In b (s G) -> rel_prime (e_order A_dec a G) (e_order A_dec b G) ->
        e_order A_dec (op a b) G = e_order A_dec a G * e_order A_dec b G.
intros A op A_dec G comm a b Ha Hb Hab.
assert (Hoat: 0 < e_order A_dec a G); try apply e_order_pos.
assert (Hobt: 0 < e_order A_dec b G); try apply e_order_pos.
assert (Hoabt: 0 < e_order A_dec (op a b) G); try apply e_order_pos.
assert (Hoa: 0 <= e_order A_dec a G); auto with zarith.
assert (Hob: 0 <= e_order A_dec b G); auto with zarith.
apply Zle_antisym; apply Zdivide_le; auto with zarith.
apply Zmult_lt_O_compat; auto.
apply e_order_divide_gpow; sauto; auto with zarith.
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto.
rewrite Zmult_comm.
rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto.
apply Zdivide_mult_rel_prime; auto.
apply Gauss with (2 := Hab).
apply e_order_divide_gpow; auto with zarith.
rewrite <- (gpow_e _ _ G (e_order A_dec b G)); auto.
rewrite <- (gpow_e_order_is_e _ A_dec  _ (op a b) G); auto with zarith.
rewrite <- gpow_gpow; auto with zarith.
rewrite (Zmult_comm (e_order A_dec (op a b) G)).
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow with (a := b); auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto with zarith.
rewrite G.(e_is_zero_r); auto with zarith.
apply gpow_in; auto.
apply Gauss with (2 := rel_prime_sym _ _ Hab).
apply e_order_divide_gpow; auto with zarith.
rewrite <- (gpow_e _ _ G (e_order A_dec a G)); auto.
rewrite <- (gpow_e_order_is_e _ A_dec  _ (op a b) G); auto with zarith.
rewrite <- gpow_gpow; auto with zarith.
rewrite (Zmult_comm (e_order A_dec (op a b) G)).
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow with (a := a); auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto with zarith.
rewrite G.(e_is_zero_l); auto with zarith.
apply gpow_in; auto.
Qed.

Theorem fermat_gen: forall (A : Type) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op),
       In a G.(s) ->  gpow a G (g_order G) = G.(e).
intros A A_dec op a G H.
assert (H1: (e_order A_dec a G | g_order G)).
apply e_order_divide_g_order; auto.
case H1; intros q; intros Hq; rewrite Hq.
assert (Hq1: 0 <= q).
apply Zmult_le_reg_r with (e_order A_dec a G); auto with zarith.
apply Zlt_gt; apply e_order_pos.
rewrite Zmult_0_l; rewrite <- Hq; apply Zlt_le_weak; apply g_order_pos.
rewrite Zmult_comm; rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
apply gpow_e; auto.
apply Zlt_le_weak; apply e_order_pos.
Qed.

Theorem order_div: forall (A : Type) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op) m,
 0 < m -> (forall p, prime p -> (p | m) -> gpow a G (m / p) <> G.(e)) ->
 In a G.(s) -> gpow a G m = G.(e) -> e_order A_dec a G = m.
intros A Adec op a G m Hm H H1 H2.
assert (F1: 0 <= m); auto with zarith.
case (e_order_divide_gpow A Adec op a G H1 m F1 H2); intros q Hq.
assert (F2: 1 <= q).
  case (Zle_or_lt 0 q); intros HH.
    case (Zle_lt_or_eq _ _ HH); auto with zarith.
    intros HH1; generalize Hm; rewrite Hq; rewrite <- HH1;
      auto with zarith.
  assert (F2: 0 <= (- q) * e_order Adec a G); auto with zarith.
    apply Zmult_le_0_compat; auto with zarith.
    apply Zlt_le_weak; apply e_order_pos.
  generalize F2; rewrite Zopp_mult_distr_l_reverse;
      rewrite <- Hq; auto with zarith.
case (Zle_lt_or_eq _ _ F2); intros H3; subst; auto with zarith.
case (prime_dec q); intros Hq.
  case (H q); auto with zarith.
    rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith.
  apply gpow_e_order_is_e; auto.
case (Zdivide_div_prime_le_square _ H3 Hq); intros r (Hr1, (Hr2, Hr3)).
case (H _ Hr1); auto.
  apply Zdivide_trans with (1 := Hr2).
  apply Zdivide_factor_r.
case Hr2; intros q1 Hq1; subst.
assert (F3: 0 < r).
  generalize (prime_le_2 _ Hr1); auto with zarith.
rewrite <- Zmult_assoc; rewrite Zmult_comm; rewrite <- Zmult_assoc;
  rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith.
rewrite gpow_gpow; auto with zarith.
  rewrite gpow_e_order_is_e; try rewrite gpow_e; auto.
  apply Zmult_le_reg_r with r; auto with zarith.
  apply Zlt_le_weak; apply e_order_pos.
apply Zmult_le_reg_r with r; auto with zarith.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_nat gcd crt sums.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.MuRec.Util
  Require Import recalg recomp beta ra_utils ra_recomp.

Set Implicit Arguments.

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

Opaque ra_cst_n ra_iter_n ra_iter ra_prim_min ra_prim_max.
Opaque ra_plus ra_pred ra_minus ra_mult ra_exp ra_div ra_rem.
Opaque ra_ite ra_eq.
Opaque ra_div2 ra_mod2 ra_pow2 ra_notdiv_pow2.
Opaque ra_decomp_l ra_decomp_r ra_recomp.

Section ra_godel_beta.

  (* Gödel Beta function *)

  Definition ra_godel_beta : recalg 3.
  Proof.
    ra root ra_rem.
    + ra arg pos0.
    + ra root ra_succ.
      ra root ra_mult.
      * ra root ra_succ.
        ra arg pos2.
      * ra arg pos1.
  Defined.

  Fact ra_godel_beta_prim_rec : prim_rec ra_godel_beta.
  Proof. ra prim rec. Qed.

  Fact ra_godel_beta_val a b n : ⟦ra_godel_beta⟧ (a##b##n##vec_nil) (godel_beta a b n).
  Proof.
    exists (a##S ((S n)*b)##vec_nil); split.
    + apply ra_rem_val; discriminate.
    + pos split; simpl; auto.
      exists (((S n)*b)##vec_nil); split; simpl; auto.
      pos split; simpl.
      exists (S n##b##vec_nil); split.
      * apply ra_mult_val.
      * pos split; simpl; auto.
        exists (n##vec_nil); split; simpl; auto.
        pos split; simpl; auto.
  Qed.

  Fact ra_godel_beta_rel v e : ⟦ra_godel_beta⟧ v e <-> e = godel_beta (vec_pos v pos0) (vec_pos v pos1) (vec_pos v pos2).
  Proof.
    vec split v with a; vec split v with b; vec split v with n; vec nil v.
    split.
    + intros H; apply ra_rel_fun with (1 := H), ra_godel_beta_val; auto.
    + intros; subst; apply ra_godel_beta_val; auto.
  Qed.

End ra_godel_beta.

#[export] Hint Resolve ra_godel_beta_prim_rec ra_godel_beta_val : core.
Opaque ra_godel_beta.

Section ra_beta.

  Definition ra_beta : recalg 2.
  Proof.
    ra root ra_godel_beta.
    + ra root ra_decomp_l.
      ra arg pos0.
    + ra root ra_decomp_r.
      ra arg pos0.
    + ra arg pos1.
  Defined.

  Fact ra_beta_prim_rec : prim_rec ra_beta.
  Proof. ra prim rec. Qed.

  Fact ra_beta_val a n : ⟦ra_beta⟧ (a##n##vec_nil) (beta a n).
  Proof.
    exists (decomp_l a##decomp_r a##n##vec_nil); split.
    { apply ra_godel_beta_val. }
    pos split; simpl; auto;
      exists (a##vec_nil); split; auto;
      pos split; simpl; auto.
  Qed.

  Fact ra_beta_rel v e : ⟦ra_beta⟧ v e <-> e = beta (vec_pos v pos0) (vec_pos v pos1).
  Proof.
    vec split v with a; vec split v with n; vec nil v.
    split.
    + intros H; apply ra_rel_fun with (1 := H), ra_beta_val; auto.
    + intros; subst; apply ra_beta_val; auto.
  Qed.

End ra_beta.

#[export] Hint Resolve ra_beta_prim_rec ra_beta_val : core.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Parameter set : forall (a:Type), Type.

Parameter mem: forall (a:Type), a -> (set a) -> Prop.

Implicit Arguments mem.

Definition infix_eqeq (a:Type)(s1:(set a)) (s2:(set a)): Prop :=
  forall (x:a), (mem x s1) <-> (mem x s2).
Implicit Arguments infix_eqeq.

Axiom extensionality : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (infix_eqeq s1 s2) -> (s1 = s2).

Definition subset (a:Type)(s1:(set a)) (s2:(set a)): Prop := forall (x:a),
  (mem x s1) -> (mem x s2).
Implicit Arguments subset.

Axiom subset_trans : forall (a:Type), forall (s1:(set a)) (s2:(set a))
  (s3:(set a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1 s3)).

Parameter empty: forall (a:Type), (set a).

Set Contextual Implicit.
Implicit Arguments empty.
Unset Contextual Implicit.

Definition is_empty (a:Type)(s:(set a)): Prop := forall (x:a), ~ (mem x s).
Implicit Arguments is_empty.

Axiom empty_def1 : forall (a:Type), (is_empty (empty:(set a))).

Parameter add: forall (a:Type), a -> (set a) -> (set a).

Implicit Arguments add.

Axiom add_def1 : forall (a:Type), forall (x:a) (y:a), forall (s:(set a)),
  (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall (a:Type), a -> (set a) -> (set a).

Implicit Arguments remove.

Axiom remove_def1 : forall (a:Type), forall (x:a) (y:a) (s:(set a)), (mem x
  (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom subset_remove : forall (a:Type), forall (x:a) (s:(set a)),
  (subset (remove x s) s).

Parameter union: forall (a:Type), (set a) -> (set a) -> (set a).

Implicit Arguments union.

Axiom union_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter: forall (a:Type), (set a) -> (set a) -> (set a).

Implicit Arguments inter.

Axiom inter_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff: forall (a:Type), (set a) -> (set a) -> (set a).

Implicit Arguments diff.

Axiom diff_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (subset (diff s1 s2) s1).

Parameter cardinal: forall (a:Type), (set a) -> Z.

Implicit Arguments cardinal.

Axiom cardinal_nonneg : forall (a:Type), forall (s:(set a)),
  (0%Z <= (cardinal s))%Z.

Axiom cardinal_empty : forall (a:Type), forall (s:(set a)),
  ((cardinal s) = 0%Z) <-> (is_empty s).

Axiom cardinal_add : forall (a:Type), forall (x:a), forall (s:(set a)),
  (~ (mem x s)) -> ((cardinal (add x s)) = (1%Z + (cardinal s))%Z).

Axiom cardinal_remove : forall (a:Type), forall (x:a), forall (s:(set a)),
  (mem x s) -> ((cardinal s) = (1%Z + (cardinal (remove x s)))%Z).

Axiom cardinal_subset : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (subset s1 s2) -> ((cardinal s1) <= (cardinal s2))%Z.

Parameter vertex : Type.

Parameter succ: vertex -> (set vertex).

Inductive path : vertex -> vertex -> Z -> Prop :=
  | path_empty : forall (v:vertex), (path v v 0%Z)
  | path_succ : forall (v1:vertex) (v2:vertex) (v3:vertex) (n:Z), (path v1 v2
      n) -> ((mem v3 (succ v2)) -> (path v1 v3 (n + 1%Z)%Z)).

Axiom path_nonneg : forall (v1:vertex) (v2:vertex) (n:Z), (path v1 v2 n) ->
  (0%Z <= n)%Z.

Axiom path_inversion : forall (v1:vertex) (v3:vertex) (n:Z), (0%Z <= n)%Z ->
  ((path v1 v3 (n + 1%Z)%Z) -> exists v2:vertex, (path v1 v2 n) /\ (mem v3
  (succ v2))).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem path_closure : forall (s:(set vertex)), (forall (x:vertex), (mem x
  s) -> forall (y:vertex), (mem y (succ x)) -> (mem y s)) ->
  forall (v1:vertex) (v2:vertex) (n:Z), (path v1 v2 n) -> ((mem v1 s) ->
  (mem v2 s)).
(* YOU MAY EDIT THE PROOF BELOW *)
induction 2; auto.
intuition.
eauto.
Qed.
(* DO NOT EDIT BELOW *)


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.

Inductive id : Type :=
| Id : string -> id.

Definition beq_id x y :=
  match x, y with
  | Id n1, Id n2 => if string_dec n1 n2 then true else false
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof. intros [n]. simpl. destruct (string_dec n n).
       -reflexivity.
       -destruct n0. reflexivity.
Qed.

Theorem beq_id_true_iff : forall x y : id,
    beq_id x y = true <-> x = y.
Proof. intros [x] [y]. unfold beq_id. destruct (string_dec x y).
       -subst. split. reflexivity. reflexivity.
       -split.
        + intros contra. inversion contra.
        + intros H. inversion H. subst. destruct n. reflexivity.
Qed.

Theorem beq_id_false_iff : forall x y : id,
    beq_id x y = false <-> x <> y.
Proof. intros x y. rewrite <- beq_id_true_iff. rewrite not_true_iff_false.
       reflexivity.
Qed.

Theorem false_beq_id : forall x y : id,
    x <> y -> beq_id x y = false.
Proof. intros x y. rewrite <- beq_id_false_iff. intros H. apply H.
Qed.

Definition total_map (A : Type) := id -> A.
Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).
Definition t_update {A : Type} (m : total_map A)
           (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

Lemma t_apply_empty : forall A x v, @t_empty A v x = v.
Proof. intros A x v. unfold t_empty. reflexivity.
Qed.

Lemma t_update_eq : forall A (m : total_map A) x v,
    (t_update m x v) x = v.
Proof. intros A m x v. unfold t_update. rewrite <- beq_id_refl. reflexivity.
Qed.

Lemma t_update_neq : forall (X : Type) v x1 x2 (m : total_map X),
    x1 <> x2 -> (t_update m x1 v) x2 = m x2.
Proof. intros X v x1 x2 m H. unfold t_update. apply beq_id_false_iff in H.
       rewrite H. reflexivity.
Qed.

Lemma t_update_shadow : forall A (m : total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2 = t_update m x v2.
Proof. intros A m v1 v2 x. apply functional_extensionality.
       intros. unfold t_update. destruct (beq_id x x0).
       reflexivity. reflexivity.
Qed.

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof. intros x y. apply iff_reflect. symmetry. apply beq_id_true_iff.
Qed.

Theorem t_update_same : forall X x (m : total_map X),
    t_update m x (m x) = m.
Proof. intros X x m. apply functional_extensionality. unfold t_update.
       intros x0. destruct (beq_idP x x0). rewrite e. reflexivity. reflexivity.
Qed.

Theorem t_update_permute : forall (X : Type) v1 v2 x1 x2
                                  (m : total_map X),
    x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
    = (t_update (t_update m x1 v1) x2 v2).
Proof. intros X v1 v2 x1 x2 m H. apply functional_extensionality. intros x.
       unfold t_update. destruct (beq_idP x1 x). rewrite <- e.
       apply beq_id_false_iff in H. rewrite H. reflexivity.
       reflexivity.
Qed.

Definition partial_map (A : Type) := total_map (option A).
Definition empty {A : Type } : partial_map A := t_empty None.
Definition update {A : Type} (m : partial_map A)
           (x : id) (v : A) :=
  t_update m x (Some v).

Lemma apply_empty : forall A x, @empty A x = None.
Proof. intros A id. apply t_apply_empty.
Qed.

Lemma update_eq : forall A (m : partial_map A) x v,
    (update m x v) x = Some v.
Proof. intros A m x v. apply t_update_eq.
Qed.

Theorem update_neq : forall (X : Type) v x1 x2
                            (m : partial_map X),
    x2 <> x1 -> (update m x2 v) x1 = m x1.
Proof. intros X v x1 x2 m. apply t_update_neq.
Qed.

Lemma update_shadow : forall A (m : partial_map A) v1 v2 x,
    update (update m x v1) x v2 = update m x v2.
Proof. intros A m v1 v2 x. apply t_update_shadow.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
    m x = Some v ->
    update m x v = m.
Proof. intros X v x m H. unfold update. rewrite <- H. apply t_update_same.
Qed.

Theorem update_permute : forall (X : Type) v1 v2 x1 x2
                                (m : partial_map X),
    x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
    = (update (update m x1 v1) x2 v2).
Proof. intros X v1 v2 x1 x2 m. apply t_update_permute.
Qed.


From Hammer Require Import Hammer.

Require Import Arith.
From Lambda Require Import Test.
From Lambda Require Import Terms.

Inductive red1 : lambda -> lambda -> Prop :=
| beta : forall M N : lambda, red1 (App (Abs M) N) (subst N M)
| abs_red : forall M N : lambda, red1 M N -> red1 (Abs M) (Abs N)
| app_red_l :
forall M1 N1 : lambda,
red1 M1 N1 -> forall M2 : lambda, red1 (App M1 M2) (App N1 M2)
| app_red_r :
forall M2 N2 : lambda,
red1 M2 N2 -> forall M1 : lambda, red1 (App M1 M2) (App M1 N2).

Inductive red : lambda -> lambda -> Prop :=
| one_step_red : forall M N : lambda, red1 M N -> red M N
| refl_red : forall M : lambda, red M M
| trans_red : forall M N P : lambda, red M N -> red N P -> red M P.

Lemma red_abs : forall M M' : lambda, red M M' -> red (Abs M) (Abs M').
Proof. hammer_hook "Reduction" "Reduction.red_abs".
simple induction 1; intros.
apply one_step_red; apply abs_red; trivial.
apply refl_red.
apply trans_red with (Abs N); trivial.
Qed.

Lemma red_appl :
forall M M' : lambda,
red M M' -> forall N : lambda, red (App M N) (App M' N).
Proof. hammer_hook "Reduction" "Reduction.red_appl".
simple induction 1; intros.
apply one_step_red; apply app_red_l; trivial.
apply refl_red.
apply trans_red with (App N N0); trivial.
Qed.

Lemma red_appr :
forall M M' : lambda,
red M M' -> forall N : lambda, red (App N M) (App N M').
Proof. hammer_hook "Reduction" "Reduction.red_appr".
simple induction 1; intros.
apply one_step_red; apply app_red_r; trivial.
apply refl_red.
apply trans_red with (App N0 N); trivial.
Qed.

Lemma red_app :
forall M M' N N' : lambda, red M M' -> red N N' -> red (App M N) (App M' N').
Proof. hammer_hook "Reduction" "Reduction.red_app".
intros; apply trans_red with (App M' N).
apply red_appl; trivial.
apply red_appr; trivial.
Qed.

Lemma red_beta :
forall M M' N N' : lambda,
red M M' -> red N N' -> red (App (Abs M) N) (subst N' M').
Proof. hammer_hook "Reduction" "Reduction.red_beta".
intros; apply trans_red with (App (Abs M') N').
apply red_app; trivial.
apply red_abs; trivial.
apply one_step_red; apply beta.
Qed.

Inductive par_red1 : lambda -> lambda -> Prop :=
| par_beta :
forall M M' : lambda,
par_red1 M M' ->
forall N N' : lambda,
par_red1 N N' -> par_red1 (App (Abs M) N) (subst N' M')
| ref_par_red : forall n : nat, par_red1 (Ref n) (Ref n)
| abs_par_red :
forall M M' : lambda, par_red1 M M' -> par_red1 (Abs M) (Abs M')
| app_par_red :
forall M M' : lambda,
par_red1 M M' ->
forall N N' : lambda, par_red1 N N' -> par_red1 (App M N) (App M' N').

Hint Resolve par_beta ref_par_red abs_par_red app_par_red.

Lemma refl_par_red1 : forall M : lambda, par_red1 M M.
Proof. hammer_hook "Reduction" "Reduction.refl_par_red1".
simple induction M; auto.
Qed.

Hint Resolve refl_par_red1.

Lemma red1_par_red1 : forall M N : lambda, red1 M N -> par_red1 M N.
Proof. hammer_hook "Reduction" "Reduction.red1_par_red1".
simple induction 1; auto.
Qed.

Inductive par_red : lambda -> lambda -> Prop :=
| one_step_par_red : forall M N : lambda, par_red1 M N -> par_red M N
| trans_par_red :
forall M N P : lambda, par_red M N -> par_red N P -> par_red M P.

Lemma red_par_red : forall M N : lambda, red M N -> par_red M N.
Proof. hammer_hook "Reduction" "Reduction.red_par_red".
simple induction 1; intros.
apply one_step_par_red; apply red1_par_red1; trivial.
apply one_step_par_red; auto.
apply trans_par_red with N0; trivial.
Qed.

Lemma par_red_red : forall M N : lambda, par_red M N -> red M N.
Proof. hammer_hook "Reduction" "Reduction.par_red_red".
simple induction 1.
2: intros; apply trans_red with N0; trivial.
simple induction 1.
intros; apply red_beta; trivial.
intros; apply refl_red.
intros; apply red_abs; trivial.
intros; apply red_app; trivial.
Qed.


(* Definitions and lemmas used in list solver *)
Require Import ZArith Znumtheory.
Require Import Coq.Lists.List.
Require Import Lia.
Import ListNotations.
Require Import VST.floyd.sublist.
Import SublistInternalLib.

(** This file provides a almost-complete solver for list with concatenation.
  Its core symbols include:
    Zlength
    Znth
    Zrepeat
    app
    sublist
    map.
  And it also interprets these symbols by convernting to core symbols:
    nil
    cons
    upd_Znth. *)

(** * Zlength_solve *)
(** Zlength_solve is a tactic that solves linear arithmetic about length of lists. *)

(* Auxilary lemmas for Zlength_solve. *)
(*
Lemma repeat_list_repeat : forall {A : Type} (n : nat) (x : A),
  repeat x n = list_repeat n x.
Proof. intros. induction n; simpl; try f_equal; auto. Qed.
*)

Definition Zrepeat {A : Type} (x : A) (n : Z) : list A :=
  repeat x (Z.to_nat n).

Lemma Zlength_Zrepeat : forall (A : Type) (x : A) (n : Z),
  0 <= n ->
  Zlength (Zrepeat x n) = n.
Proof. intros *. unfold Zrepeat. apply @Zlength_repeat. Qed.

Local Lemma Zlength_firstn : forall (A : Type) n (l : list A),
  Zlength (firstn n l) = Z.min (Z.max (Z.of_nat n) 0) (Zlength l).
Proof.
  induction n; intros.
  - simpl. rewrite Zlength_nil.
    pose proof (Zlength_nonneg l). lia.
  - destruct l; simpl.
    + rewrite Zlength_nil. lia.
    + rewrite !Zlength_cons.
      rewrite IHn.
      pose proof (Zlength_nonneg l). lia.
Qed.

Local Lemma Zlength_firstn_to_nat : forall (A : Type) n (l : list A),
  Zlength (firstn (Z.to_nat n) l) = Z.min (Z.max n 0) (Zlength l).
Proof.
  intros.
  rewrite Zlength_firstn.
  lia.
Qed.

Local Lemma Zlength_skipn : forall (A : Type) n (l : list A),
  Zlength (skipn n l) = Z.max (Zlength l - (Z.max (Z.of_nat n) 0)) 0.
Proof.
  induction n; intros.
  - simpl.
    pose proof (Zlength_nonneg l). lia.
  - destruct l; simpl.
    + rewrite Zlength_nil. lia.
    + rewrite !Zlength_cons.
      rewrite IHn.
      pose proof (Zlength_nonneg l). lia.
Qed.

Local Lemma Zlength_skipn_to_nat : forall (A : Type) n (l : list A),
  Zlength (skipn (Z.to_nat n) l) = Z.max (Zlength l - (Z.max n 0)) 0.
Proof.
  intros.
  rewrite Zlength_skipn.
  lia.
Qed.

Lemma Zlength_sublist2 : forall (A : Type) lo hi (l : list A),
  Zlength (sublist lo hi l) = Z.max (Z.min hi (Zlength l) - Z.max lo 0) 0.
Proof.
  intros.
  unfold sublist.
  rewrite Zlength_skipn_to_nat, Zlength_firstn_to_nat.
  lia.
Qed.

Lemma Zlength_upd_Znth : forall (A : Type) i l (x : A),
  Zlength (upd_Znth i l x) = Zlength l.
Proof.
  intros.
  unfold upd_Znth. if_tac; auto.
  rewrite Zlength_app, Zlength_cons.
  rewrite !Zlength_sublist2. lia.
Qed.

Definition Zlength_fact P : Prop := P.

Lemma Zlength_fact_intro : forall (P : Prop),
  P -> Zlength_fact P.
Proof.
  auto.
Qed.

Lemma Zlength_fact_elim : forall (P : Prop),
  Zlength_fact P -> P.
Proof.
  auto.
Qed.

(** create a new database, do nothing if database already exists. *)
Ltac init_Zlength_db :=
  idtac.

(** remove the database, do nothing if database doesn't exist. *)
Ltac clear_Zlength_db :=
  repeat lazymatch goal with
  | f : Zlength_fact _ |- _ =>
    clear f
  end.

(** Add a new result to the databasem without checking for duplication. *)
Ltac add_Zlength_res H :=
  pose proof (Zlength_fact_intro _ H).

(** Test whether l exists in the database.
 * Success without side effect if existing, fail otherwise. *)
Ltac search_Zlength l :=
  lazymatch goal with
  | f : Zlength_fact (Zlength l = _) |- _ =>
    idtac
  end.

(* Arguments:
  l - the list to calculate length
  H - the name for result
*)
Ltac pose_Zlength l H :=
  lazymatch goal with
  | f : Zlength_fact (Zlength l = _) |- _ =>
    pose proof (Zlength_fact_elim _ f) as H
  end.

Ltac get_Zlength l :=
  lazymatch goal with
  | f : Zlength_fact (Zlength l = _) |- _ =>
    constr:(Zlength_fact_elim _ f)
  end.

Goal forall A (al bl cl : list A) n m,
  Zlength al = n -> Zlength bl = n -> Zlength cl = n + m ->
  Zlength al = n /\ Zlength bl = n /\ Zlength cl = n + m.
Proof.
  intros.
  init_Zlength_db.
  add_Zlength_res H.
  search_Zlength al.
  Fail search_Zlength bl.
  add_Zlength_res H0.
  search_Zlength bl.
  Fail search_Zlength cl.
  add_Zlength_res H1.
  search_Zlength cl.
  search_Zlength bl.
  pose_Zlength al ltac:(fresh).
Abort.

Lemma calc_Zlength_var : forall A (l : list A),
  Zlength l = Zlength l.
Proof.
  auto.
Qed.

Lemma calc_Zlength_nil : forall A,
  Zlength (@nil A) = 0.
Proof.
  auto.
Qed.

Lemma calc_Zlength_cons : forall A (l : list A) len x,
  Zlength l = len ->
  Zlength (x :: l) = 1 + len.
Proof.
  intros.
  rewrite Zlength_cons.
  lia.
Qed.

Lemma calc_Zlength_app : forall A (al bl : list A) alen blen,
  Zlength al = alen ->
  Zlength bl = blen ->
  Zlength (al ++ bl) = alen + blen.
Proof.
  intros.
  rewrite Zlength_app.
  lia.
Qed.

Lemma calc_Zlength_sublist : forall A (l : list A) len lo hi,
  Zlength l = len ->
  0 <= lo <= hi ->
  hi <= len ->
  Zlength (sublist lo hi l) = hi - lo.
Proof.
  intros.
  rewrite Zlength_sublist;
  lia.
Qed.

Lemma calc_Zlength_upd_Znth : forall A (l : list A) len i x,
  Zlength l = len ->
  Zlength (upd_Znth i l x) = len.
Proof.
  intros; subst; apply Zlength_upd_Znth.
Qed.

Lemma calc_Zlength_map : forall A B (l : list A) len (f : A -> B),
  Zlength l = len ->
  Zlength (map f l) = len.
Proof.
  intros.
  rewrite Zlength_map.
  auto.
Qed.

Ltac calc_Zlength := fail "defined later".

Ltac Zlength_simplify :=
  init_Zlength_db;
  repeat match goal with
  | |- context [Zlength ?l] =>
    progress (
      calc_Zlength l;
      try progress (
        let H := get_Zlength l in
        rewrite !H
      )
    )
  end.

Ltac Zlength_simplify_in H :=
  init_Zlength_db;
  repeat match type of H with
  | context [Zlength ?l] =>
    progress (
      calc_Zlength l;
      try progress (
        let H1 := get_Zlength l in
        rewrite !H1 in H
      )
    )
  end.

Ltac Zlength_simplify_in_all :=
  init_Zlength_db;
  repeat match goal with
  | |- context [Zlength ?l] =>
    progress (
      calc_Zlength l;
      try progress (
        let H := get_Zlength l in
        rewrite !H
      )
    )
  | H : _ |- _ =>
    lazymatch type of H with
    | Zlength_fact _ => fail
    | _ =>
      match type of H with
      | context [Zlength ?l] =>
        progress (
          calc_Zlength l;
          try progress (
            let H1 := get_Zlength l in
            rewrite !H1 in H
          )
        )
      end
    end
  end.

Ltac calc_Zlength_by_autorewrite l :=
  let len_name := fresh "len" in
  pose (Zlength l) as len_name;
  let H := fresh in
  eassert (len_name = Zlength l) as H by reflexivity;
  progress autorewrite with Zlength in H;
  Zlength_simplify_in H;
  unfold len_name in H;
  clear len_name;
  add_Zlength_res H;
  clear H.

Ltac calc_Zlength_extra l := fail.

Ltac calc_Zlength l ::=
  first
  [ search_Zlength l
  | lazymatch l with
    | @nil ?A =>
      add_Zlength_res (calc_Zlength_nil A)
    | @cons ?A ?x ?l =>
      calc_Zlength l;
      let H := get_Zlength l in
      add_Zlength_res (calc_Zlength_cons A l _ x H)
    | @app ?A ?l1 ?l2 =>
      calc_Zlength l1; calc_Zlength l2;
      let H1 := get_Zlength l1 in
      let H2 := get_Zlength l2 in
      add_Zlength_res (calc_Zlength_app A l1 l2 _ _ H1 H2)
    | @Zrepeat ?A ?x ?n =>
      add_Zlength_res (Zlength_Zrepeat A x n ltac:(lia))
    | @sublist ?A ?lo ?hi ?l =>
      calc_Zlength l;
      let H := get_Zlength l in
      let Z_solve :=
        try lia;
        fail 0 "cannot prove" lo hi "are in range for" l
      in
      add_Zlength_res (calc_Zlength_sublist A l _ lo hi H ltac:(Z_solve) ltac:(Z_solve))
    | @upd_Znth ?A ?i ?l ?x =>
      calc_Zlength l;
      let H := get_Zlength l in
      add_Zlength_res (calc_Zlength_upd_Znth A l _ i x H)
    | @map ?A ?B ?f ?l =>
      calc_Zlength l;
      let H := get_Zlength l in
      add_Zlength_res (calc_Zlength_map A B l _ f H)
    | _ =>
      tryif first [
        calc_Zlength_extra l
      | calc_Zlength_by_autorewrite l
      | add_Zlength_res (calc_Zlength_var _ l);
        pose proof (Zlength_nonneg l)
      ] then idtac
      else
        fail "calc_Zlength does not support" l
    end
  ].

Ltac Zlength_solve :=
  Zlength_simplify;
  lia.


(***************************************************************************)
(*   This is part of FA_3rdCalculus, it is distributed under the terms     *)
(*         of the GNU Lesser General Public License version 3              *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*            Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.             *)
(***************************************************************************)

Require Import R_sup1.

Definition Fun := Real -> Real.

Definition Dot_con (f :Fun) x0 := ∀ ε, ε > O ->
  ∃ δ, δ > O /\  ∀ x, | x - x0 | < δ -> | f x - f x0 | < ε.

Definition DotR_con (f :Fun) x0 := ∀ ε, ε > O ->
  ∃ δ, δ > O /\  ∀ x, x-x0 < δ -> O ≦ x-x0 -> | f x - f x0 | < ε.

Definition DotL_con (f :Fun) x0 := ∀ ε, ε > O ->
  ∃ δ, δ > O /\  ∀ x, x0-x < δ -> O ≦ x0-x -> | f x - f x0 | < ε.

Fact Dc_DLc : ∀ {f c}, Dot_con f c -> DotL_con f c.
Proof.
  intros; red; intros. destruct (H _ H0), H1.
  exists x; split; auto. intros. destruct H4.
  - apply H2. apply -> Ab1; split.
    + apply Theorem183_1'. rewrite Theorem181. Simpl_R.
    + apply Theorem183_1 in H4. rewrite Theorem181 in H4.
      eapply Theorem171; eauto.
  - symmetry in H4. apply Theorem182_2 in H4. subst c. Simpl_R.
Qed.

Fact Dc_DRc : ∀ {f c}, Dot_con f c -> DotR_con f c.
Proof.
  intros; red; intros. destruct (H _ H0), H1.
  exists x; split; auto. intros. destruct H4.
  - apply H2. apply -> Ab1; split; auto.
    eapply Theorem171; eauto. apply Theorem176_1; auto.
  - symmetry in H4. apply Theorem182_2 in H4. subst c. Simpl_R.
Qed.

Fact DRc_ln : ∀ {f a}, DotR_con f a -> f a < O ->
  ∃ δ, δ > O /\ ∀ x, x - a < δ -> O ≦ x - a -> f x < O.
Proof.
  intros. apply Theorem182_1' in H0; apply H in H0.
  destruct H0 as [δ H0], H0. exists δ; split; intros; auto.
  apply H1 in H2; auto. apply Ab1'' in H2; destruct H2; Simpl_Rin H4.
Qed.

Fact DLc_lp : ∀ {f b}, DotL_con f b -> f b > O ->
  ∃ δ, δ > O /\ ∀ x, b - x < δ -> O ≦ b - x -> f x > O.
Proof.
  intros; apply Theorem182_1' in H0; apply H in H0.
  destruct H0 as [δ H0], H0. exists δ; split; intros; auto.
  apply H1 in H2; auto; apply Ab1'' in H2; destruct H2; Simpl_Rin H2.
Qed.

Definition FunClose_con f a b := a < b /\ DotR_con f a /\
  DotL_con f b /\ (∀ z, z ∈ (a|b) -> Dot_con f z).

Ltac temtac1 x :=
  exists x; split; intros; Simpl_R; rewrite <- Theorem178, Theorem180; Simpl_R.

Fact Fc_mFc : ∀ f a b, FunClose_con f a b ->
  FunClose_con (λ x, - f(x)) a b.
Proof.
  intros. destruct H, H0, H1. repeat split; auto; red; intros.
  - destruct (H0 _ H3), H4. temtac1 x.
  - destruct (H1 _ H3), H4. temtac1 x.
  - destruct (H2 _ H3 _ H4), H5. temtac1 x.
Qed.

Ltac temtac2 x := exists x; split; auto; intros; rewrite Mi_R'; Simpl_R.

Fact Fc_Fmc : ∀ {f a b} C, FunClose_con f a b ->
  FunClose_con (λ x, f(x) - C) a b.
Proof.
  intros. destruct H, H0, H1. repeat split; auto; red; intros.
  - destruct (H0 _ H3), H4. temtac2 x.
  - destruct (H1 _ H3), H4. temtac2 x.
  - destruct (H2 _ H3 _ H4), H5. temtac2 x.
Qed.

Definition Zero_point_theorem := ∀ f a b, FunClose_con f a b ->
  f(a)·f(b) < O -> ∃ ξ, ξ ∈ [a|b] /\ f ξ = O.

Definition supremum y A :=
  Boundup_Ens y A /\ ∀ z, Boundup_Ens z A -> y ≦ z.

Definition infimum y A :=
  Bounddown_Ens y A /\ ∀ z, Bounddown_Ens z A -> z ≦ y.

Corollary Cor_sup : ∀ s S, supremum s S ->
  ∀ ε, ε > O -> ∃ x, x ∈ S /\ (s - ε) < x.
Proof.
  intros; destruct H; Absurd.
  assert (Boundup_Ens (s - ε) S).
  { red; intros. destruct (Co_T167 x (s - ε)); auto. elim H2; eauto. }
  apply H1 in H3. apply LePl_R with (z:=ε) in H3; Simpl_Rin H3.
  destruct (@Pl_R s ε). LEGR H3 (H4 H0).
Qed.

Definition SupremumT := ∀ R, No_Empty R ->
  (∃ x, Boundup_Ens x R) -> ∃ y, supremum y R.

Definition InfimumT := ∀ R, No_Empty R ->
  (∃ x, Bounddown_Ens x R) -> ∃ y, infimum y R.

Section Sup_imply_Int.

Hypothesis SupT : SupremumT.

Theorem ZTcase1 : ∀ {f a b}, FunClose_con f a b ->
  f a < O -> f b > O -> ∃ ξ, ξ ∈ [a|b] /\ f ξ = O.
Proof.
  intros. destruct H as [H [H2 [H3]]].
  set (R:= /{ z | a ≦ z /\ z ≦ b /\ f z ≦ O /}).
  assert (a ∈ R). { constructor. repeat split; red; auto. }
  assert (Boundup_Ens b R). { red; intros. destruct H6; tauto. }
  assert (∃ ξ, supremum ξ R). { apply SupT; [red|]; eauto. }
  destruct H7 as [ξ]. inversion H7.
  assert (ξ ∈ [a|b]). { constructor; split; auto. }
  exists ξ; split; auto.
  destruct (Theorem167 (f ξ) O) as [H11|[H11|H11]]; auto.
  - inversion H10. destruct H12, H13.
    + assert (DotR_con f ξ).
      { destruct H12; subst; auto. apply Dc_DRc, H4. split; auto. }
      destruct (DRc_ln H14 H11) as [δ []].
      set (c:=R2min (ξ+((δ/2) NoO_N)) (mid ξ b)).
      assert (c ∈ R).
      { repeat split; left.
        - eapply Theorem172; left; split; eauto. apply R2mgt.
          + apply Pl_R, Pr_2a; auto.
          + apply Mid_P'; auto.
        - apply R2mlt. right. apply Mid_P; auto.
        - apply H16.
          + apply Theorem188_1 with (Θ:=ξ); Simpl_R. apply R2mlt. left.
            apply Theorem188_1 with (Θ:=-ξ); Simpl_R. apply Pr_2b; auto.
          + apply LePl_R with (z:=ξ); Simpl_R. left. apply R2mgt.
            * apply Pl_R, Pr_2a; auto.
            * apply Mid_P'; auto. } apply H8 in H17.
      assert (ξ < c).
      { apply R2mgt; [apply Pl_R, Pr_2a| apply Mid_P']; auto. } LEGR H17 H18.
    + subst b. LGR H11 H1.
  - inversion H10. destruct H12, H12.
    + assert (DotL_con f ξ).
      { destruct H13; subst; auto. apply Dc_DLc, H4. split; auto. }
      destruct (DLc_lp H14 H11) as [δ []].
      destruct (Cor_sup _ _ H7 _ H15), H17.
      inversion H17. destruct H19 as [_ [_ H19]]. apply H8 in H17.
      apply LePl_R with (z:=-x) in H17; Simpl_Rin H17.
      apply H16 in H17; [LEGR H19 H17|].
      apply Theorem188_1' with (Θ:=δ) in H18; Simpl_Rin H18.
      rewrite Theorem175 in H18.
      apply Theorem188_1 with (Θ:=x); Simpl_R.
    + subst a. LGR H11 H0.
Qed.

Theorem ZTcase2 : ∀ {f a b}, FunClose_con f a b ->
  f a > O -> f b < O -> ∃ ξ, ξ ∈ [a|b] /\ f ξ = O.
Proof.
  intros; apply Fc_mFc in H. apply Theorem183_1 in H0.
  apply Theorem183_1 in H1. eapply ZTcase1 in H; eauto.
  destruct H as [ξ [H]]. apply Theorem183_2 in H2; Simpl_Rin H2; eauto.
Qed.

Theorem ZPT : Zero_point_theorem.
Proof.
  red; intros. assert ((f a < O /\ f b > O) \/ (f a > O /\ f b < O)).
  { destruct (f a), (f b); simpl; inversion H0; auto. }
  destruct H1, H1; [apply ZTcase1| apply ZTcase2]; auto.
Qed.

Theorem IVTcase1 : ∀ f a b, FunClose_con f a b -> f a < f b ->
  ∀ C, f a < C -> C < f b -> ∃ ξ, ξ ∈ [a|b] /\ f ξ = C.
Proof.
  intros. apply Theorem182_3' in H1. apply Theorem182_1' in H2.
  destruct (ZTcase1 (Fc_Fmc C H) H1 H2), H3.
  apply Theorem182_2 in H4. eauto.
Qed.

Theorem IVTcase2 : ∀ f a b, FunClose_con f a b -> f a > f b ->
  ∀ C, f b < C -> C < f a -> ∃ ξ, ξ ∈ [a|b] /\ f ξ = C.
Proof.
  intros. apply Theorem182_3' in H1. apply Theorem182_1' in H2.
  destruct (ZTcase2 (Fc_Fmc C H) H2 H1), H3.
  apply Theorem182_2 in H4. eauto.
Qed.

End Sup_imply_Int.

Section Int_imply_Sup.

Hypothesis ZPT : Zero_point_theorem.

Theorem SupT : SupremumT.
Proof.
  red; intros. destruct (classic (∃ x, EnsMax x R)) as [H1 | H1].
  - destruct H1 as [Max [H1 H2]].
    exists Max; red; intros; split; auto.
  - set (S:= /{ z | Boundup_Ens z R /}); set (S':= /{ w | ~ w ∈ S /}).
    assert (∀ r, {r ∈ S'} + {r ∈ S}) as P.
    { intros. destruct (classicT (r ∈ S)); auto. left. constructor. auto. }
    assert (∀ r, ~ ((r ∈ S') /\ (r ∈ S))) as Q.
    { intros; intro. destruct H2, H2; auto. } Absurd.
    assert (∀ r, r ∈ S' -> ∃ r0, r0 > r /\ r0 ∈ S').
    { intros. destruct H3. Absurd. elim H3. constructor. red. intros.
      destruct (Co_T167 x r); auto. elim H4. exists x. split; auto.
      constructor. intro. destruct H7. elim H1. exists x; split; auto. }
    assert (∀ r, r ∈ S -> ∃ r0, r0 < r /\ r0 ∈ S).
    { intros. Absurd. elim H2. exists r; split; try red; intros.
      - destruct H4; auto.
      - destruct (Co_T167 r z); auto.
        elim H5. exists z; split; auto. constructor. auto. }
    assert (∀ x, x ∈ S' -> ∀ y, y ≦ x -> y ∈ S').
    { intros. constructor; intro. destruct H5, H7. elim H5. constructor.
      red; intros. apply H7 in H8. eapply Theorem173; eauto. }
    assert (∀ x, x ∈ S -> ∀ y, x ≦ y -> y ∈ S).
    { intros. constructor; red; intros. destruct H6.
      apply H6 in H8. eapply Theorem173; eauto. }
    destruct H as [a H], H0 as  [b H0].
    assert (a ∈ S').
    { constructor. intro. destruct H7. elim H1; exists a; red; auto. }
    assert (b ∈ S). { constructor; intros. auto. }
    assert (a < b).
    { destruct H7, (Co_T167 b a); auto. destruct (H7 (H6 _ H8 _ H9)). }
    set (f:= λ x, match P x with | left _ => -(1) | right _ => 1 end).
    assert (f a = -(1)).
    { unfold f. destruct P; auto. destruct (Q a); auto. }
    assert (f b = 1).
    { unfold f. destruct P; auto. destruct (Q b); auto. }
    assert (FunClose_con f a b).
    { repeat split; auto; red; intros.
      - destruct (H3 _ H7) as [r [H13]]. pose proof (Theorem182_1' _ _ H13).
        exists (r-a); split; auto; intros.
        apply Theorem188_1' with (Θ:=a) in H16; Simpl_Rin H16.
        assert (x ∈ S'). { eapply H5; red; eauto. }
        rewrite H10. unfold f. destruct P; Simpl_R. destruct (Q x); auto.
      - destruct (H4 _ H8) as [r [H13]]. pose proof (Theorem182_1' _ _ H13).
        exists (b-r); split; auto; intros.
        apply Theorem183_1 in H16. do 2 rewrite Theorem181 in H16.
        apply Theorem188_1' with (Θ:=b) in H16; Simpl_Rin H16.
        assert (x ∈ S). { eapply H6; red; eauto. }
        rewrite H11. unfold f. destruct P; Simpl_R. destruct (Q x); auto.
      - destruct (P z).
        + destruct (H3 _ i) as [z0 [H14]]. pose proof (Theorem182_1' _ _ H14).
          exists (z0-z); split; auto; intros. apply Ab1 in H17; destruct H17.
          apply Theorem188_1' with (Θ:=z) in H18; Simpl_Rin H18.
          assert (x ∈ S'). { eapply H5; red; eauto. }
          unfold f. destruct P, P; Simpl_R; edestruct Q; eauto.
        + destruct (H4 _ i) as [z0 [H14]]. pose proof (Theorem182_1' _ _ H14).
          exists (z-z0); split; auto; intros. apply Ab1 in H17; destruct H17.
          rewrite Theorem181 in H17.
          apply Theorem188_1' with (Θ:=z) in H17; Simpl_Rin H17.
          assert (x ∈ S). { eapply H6; red; eauto. }
          unfold f. destruct P, P; Simpl_R; edestruct Q; eauto. }
  assert (f a · f b < O). { rewrite H10, H11; reflexivity. }
  destruct (ZPT _ _ _ H12 H13), H14.
  unfold f in H15; destruct P; inversion H15.
Qed.

Theorem InfT : InfimumT.
Proof.
  red; intros; destruct H0 as [x H0]. set (R' := /{ r | (-r) ∈ R /}).
  assert (∃ y, supremum y R').
  { apply SupT.
    - destruct H; red. exists (-x0); constructor; Simpl_R.
    - exists (-x); red; intros; destruct H1. apply LEminus; Simpl_R. }
  destruct H1 as [y [H1]].
  exists (-y); split; try red; intros; apply LEminus; Simpl_R.
  - apply H1; constructor; Simpl_R.
  - apply H2; red; intros; destruct H4. apply LEminus; Simpl_R.
Qed.

End Int_imply_Sup.