Require Import vcfloat.VCFloat.
Require Import List.
Import ListNotations.
Require Import common op_defs dotprod_model sum_model.
Require Import float_acc_lems list_lemmas.
Require Import fma_dot_acc sum_acc.

Require Import Reals.
Open Scope R.

Section NAN.
Variable NAN: Nans.

Definition fmax (t: type) := bpow Zaux.radix2 (femax t).

Lemma is_finite_fma_no_overflow' (t : type) :
  forall x y z
  (Hfinx: Binary.is_finite (fprec t) (femax t) x = true)
  (Hfiny: Binary.is_finite (fprec t) (femax t) y = true)
  (Hfinz: Binary.is_finite (fprec t) (femax t) z = true)
  (Hov : @fma_no_overflow t (FT2R x) (FT2R y) (FT2R z)),
 Binary.is_finite (fprec t) (femax t) (BFMA x y z) = true.
Proof.
intros.
pose proof (Binary.Bfma_correct  (fprec t) (femax t)  (fprec_gt_0 t) (fprec_lt_femax t) (fma_nan t)
                      BinarySingleNaN.mode_NE x y z Hfinx Hfiny Hfinz).
unfold fma_no_overflow, FT2R, rounded in Hov;
apply Rlt_bool_true in Hov.
cbv zeta in H.
rewrite Hov in H; simpl in H; destruct H as (_ & B & _); simpl; auto.
Qed.

Definition fun_bnd (t : type) (n : nat) :=
let x := (fmax t - @default_abs t) / (1 + @default_rel t) - @g1 t n (n-1) in
let y := 1 / (1 + INR n * (@g t (n - 1) + 1)) in x * y.

Lemma rdiv_lt (a b: R) :
  0 < b -> 0 < a -> b < a -> / a < / b.
Proof.
intros.
replace (/b) with (1/b) by nra.
apply Rdiv_lt_right; auto.
rewrite Rmult_comm.
apply Rdiv_lt_left; auto.
nra.
Qed.

Lemma rdiv_le (a b: R) :
  0 < b -> 0 < a -> b <= a -> / a <= / b.
Proof.
intros.
replace (/b) with (1/b) by nra.
apply Rcomplements.Rle_div_r; auto.
rewrite Rmult_comm.
apply Rdiv_le_left; auto.
nra.
Qed.

Lemma rdiv_mult_eq :
forall a b, b <> 0 -> a/b = a * (1/b) .
Proof.
(intros; field_simplify; nra).
Qed.

Lemma Rminus_le_minus a b c :
 b <= c -> a - c <= a - b.
Proof.  nra. Qed.

Lemma Rminus_lt_minus a b c :
 b < c -> a - c < a - b.
Proof.  nra. Qed.

Lemma defualt_abs_le_fmax t :
@default_abs t <= fmax t.
Proof.
replace (fmax t) with (1 * fmax t) by nra.
unfold default_abs, fmax; apply Rmult_le_compat; try nra.
apply bpow_ge_0.
apply bpow_le.
apply Z.le_sub_le_add_r.
apply Z.le_sub_le_add_r.
Search fprec femax.
eapply Z.le_trans with (fprec t + fprec t + femax t)%Z;
  [ | repeat apply Zplus_le_compat_r; apply Z.lt_le_incl; apply fprec_lt_femax].
eapply Z.le_trans with (fprec t + fprec t + fprec t)%Z;
[ |  repeat apply Zplus_le_compat_l;apply Z.lt_le_incl; apply fprec_lt_femax ].
eapply Z.le_trans with (1 + fprec t + fprec t)%Z;
[ |  repeat apply Zplus_le_compat_r;apply Z.lt_le_incl;apply fprec_gt_one].
eapply Z.le_trans with (1 + 1 + fprec t)%Z;
[ |  repeat apply Zplus_le_compat_r; repeat apply Zplus_le_compat_l; apply Z.lt_le_incl;
apply fprec_gt_one].
eapply Z.le_trans with (1 + 1 + 1)%Z;
[ lia |  repeat apply Zplus_le_compat_r; repeat apply Zplus_le_compat_l; apply Z.lt_le_incl;
apply fprec_gt_one].
Qed.

Lemma bpow_femax_lb t :
4 <= bpow Zaux.radix2 (femax t).
Proof.
pose proof fprec_gt_one t.
pose proof fprec_lt_femax t.
assert (1 < femax t)%Z.
eapply Z.lt_trans with (fprec t); auto.
eapply Rle_trans with (bpow Zaux.radix2 2).
unfold bpow; simpl; nra.
apply bpow_le; lia.
Qed.

Lemma bpow_fprec_lb t :
2 <= bpow Zaux.radix2 (fprec t).
Proof.
pose proof fprec_gt_one t.
eapply Rle_trans with (bpow Zaux.radix2 1).
unfold bpow; simpl; nra.
apply bpow_le; lia.
Qed.

Lemma default_abs_ub t :
@default_abs t <= 1.
Proof.
unfold default_abs.
pose proof bpow_gt_0 Zaux.radix2 (femax t).
pose proof bpow_gt_0 Zaux.radix2 (fprec t).
replace (3 - femax t - fprec t)%Z with (3 +- femax t +- fprec t)%Z by lia.
rewrite !bpow_plus.
rewrite <- !Rmult_assoc.
replace (/ 2 * bpow Zaux.radix2 3) with 4; [|simpl;nra].
rewrite !bpow_opp, !Rcomplements.Rle_div_r.
field_simplify; try nra.
eapply Rle_trans; [| apply Rmult_le_compat ;[ | | apply bpow_fprec_lb | apply bpow_femax_lb  ]]; try nra.
apply Rlt_gt.
replace (/ bpow Zaux.radix2 (femax t)) with (1 / bpow Zaux.radix2 (femax t)) by nra.
apply Rdiv_lt_0_compat; try nra.
apply Rlt_gt;
replace (/ bpow Zaux.radix2 (fprec t)) with (1 / bpow Zaux.radix2 (fprec t)) by nra;
apply Rdiv_lt_0_compat; try nra.
Qed.

Lemma default_rel_ub t :
@default_rel t <= 1.
Proof.
unfold default_rel.
pose proof bpow_gt_0 Zaux.radix2 (fprec t).
rewrite !bpow_plus.
rewrite <- !Rmult_assoc.
rewrite Rmult_comm.
rewrite <- !Rmult_assoc.
replace (bpow Zaux.radix2 1 * / 2) with 1; [|simpl;nra].
rewrite !bpow_opp, !Rcomplements.Rle_div_r.
field_simplify; try nra.
replace 1 with  (bpow Zaux.radix2 0).
apply bpow_le.
pose proof fprec_gt_one t; lia.
simpl; auto.
apply Rlt_gt;
replace (/ bpow Zaux.radix2 (fprec t)) with (1 / bpow Zaux.radix2 (fprec t)) by nra;
apply Rdiv_lt_0_compat; try nra.
Qed.

Lemma fun_bnd_pos_1 :
forall t n
(Hn : @g1 t (n + 1) n <= fmax t),
0 <= (fmax t - @default_abs t) / (1 + @default_rel t) - @g1 t n (n-1).
Proof.
intros;
apply Rle_0_minus. apply Generic_proof.Rdiv_le_mult_pos;
[apply default_rel_plus_1_gt_0 | apply Rminus_plus_le_minus].
assert (Hn': (n=0)%nat \/ (1<=n)%nat) by lia; destruct Hn'; subst.
{ simpl. unfold g1, g. simpl; field_simplify. apply defualt_abs_le_fmax. }
assert (Hn': (n=1)%nat \/ (1 < n)%nat) by lia; destruct Hn'; subst.
{ simpl. unfold g1, g. simpl; field_simplify.
eapply Rle_trans.
apply Rplus_le_compat.
apply Rmult_le_compat.
apply default_abs_ge_0.
apply default_rel_ge_0.
apply default_abs_ub.
apply default_rel_ub.
apply Rmult_le_compat_l; try nra.
apply default_abs_ub.
eapply Rle_trans; [| apply bpow_femax_lb]; nra. }
eapply Rle_trans. apply mult_d_e_g1_le'; try lia.
replace (S n) with (n + 1)%nat by lia.
replace (S (n - 1)) with n by lia; auto.
Qed.

Lemma fun_bnd_le (t : type) (n : nat) :
forall (Hn : @g1 t (S n + 1) (S n) <= fmax t),
fun_bnd t (S n) <= fun_bnd t n.
Proof.
assert (Hn': (n=0)%nat \/ (1<=n)%nat) by lia; destruct Hn'; subst.
{ intros; simpl. unfold fun_bnd. apply Rmult_le_compat; try apply Rabs_pos.
apply fun_bnd_pos_1; auto. simpl. unfold g. simpl; field_simplify; nra.
apply Rminus_le_minus. simpl. unfold g1, g; field_simplify; simpl.
field_simplify. apply default_abs_ge_0.
simpl; unfold g; field_simplify; simpl; try nra. }
intros; unfold fun_bnd.
assert (0 < 1 + INR (S n) * (@g t (S n - 1) + 1)).
{
apply Rplus_lt_le_0_compat; try nra.
apply Rmult_le_pos; try apply pos_INR.
apply Rplus_le_le_0_compat; try nra; apply g_pos. }
assert (
INR n * @g t (n - 1) + INR n + 1 > 0).
{
apply Rplus_lt_le_0_compat; try nra.
apply Rplus_le_lt_0_compat; [| apply lt_0_INR; lia].
apply Rmult_le_pos; try apply pos_INR.
apply g_pos. }
apply Rmult_le_compat; try apply Rabs_pos.
apply fun_bnd_pos_1; auto.
apply Rdiv_le_0_compat_Raux; try nra.
apply Rminus_le_minus.
replace (S n -1)%nat with (S (n-1))%nat by lia.
apply g1n_le_g1Sn; auto.
apply Rcomplements.Rle_div_r.
apply Rlt_gt.
replace (/ (1 + INR (S n) * (@g t (S n - 1) + 1))) with
  (1/(1 + INR (S n) * (@g t (S n - 1) + 1))) by nra.
apply Rdiv_lt_0_compat; try nra.
field_simplify; try nra.
apply Rcomplements.Rle_div_r; try nra.
rewrite Rmult_1_l.
apply Rplus_le_compat; try nra.
apply Rplus_le_compat.
apply Rmult_le_compat; [ apply pos_INR | apply g_pos | | ].
apply le_INR; lia.
replace (S n - 1)%nat with (S (n-1))%nat by lia.
apply le_g_Sn.
apply le_INR; lia.
Qed.

Lemma length_split {A : Type} (l : list (A * A)) :
length (fst (List.split l)) = length (snd (List.split l)).
Proof.
induction l; [simpl; auto | ].
destruct a; simpl; destruct (List.split l); simpl.
simpl in IHl; lia.
Qed.

Lemma fun_bound_pos t n :
forall (Hn : @g1 t (n + 1) n <= fmax t),
0 <= fun_bnd t n.
Proof.
intros;
unfold fun_bnd; apply Rmult_le_pos.
apply fun_bnd_pos_1; auto.
apply Rdiv_le_0_compat_Raux; try nra.
apply Rplus_lt_le_0_compat; try nra.
apply Rmult_le_pos; try apply pos_INR.
apply Rplus_le_le_0_compat; try nra; apply g_pos.
Qed.

Lemma combine_split {A : Type} (l : list (A * A)) :
combine (fst (List.split l)) (snd (List.split l)) = l.
Proof.
induction l; [simpl; auto | ].
destruct a; simpl; destruct (List.split l); simpl.
simpl in IHl; rewrite IHl; auto.
Qed.

Lemma finite_sum_from_bounded :
  forall (t: type) (v1 v2: list (ftype t))
  (fp : ftype t)
  (Hfp: fma_dot_prod_rel (List.combine v1 v2) fp)
  (Hn : @g1 t (S  (length (List.combine v1 v2)) + 1) (S (length (List.combine v1 v2))) <= fmax t),
  (forall x, In x (List.combine v1 v2) ->
    Binary.is_finite _ _ (fst x) = true /\
    Binary.is_finite _ _ (snd x) = true /\
    Rabs (FT2R (fst x)) < sqrt  (fun_bnd t (length (List.combine v1 v2))) /\
    Rabs (FT2R (snd x)) < sqrt  (fun_bnd t (length (List.combine v1 v2))))->
  Binary.is_finite _ _ fp = true.
Proof.
intros ? ? ? .
induction (List.combine v1 v2).
{ intros; inversion Hfp; subst; simpl; auto. }
{ intros. inversion Hfp; subst.
assert (Hn' : @g1 t (S (length l) + 1) (S (length l)) <= fmax t).
{ eapply Rle_trans; [ | apply Hn]; simpl. set (n:= (length l + 1)%nat).
  replace (length l) with (n-1)%nat by lia.
  replace (S(n-1))%nat with (S n - 1)%nat by lia; apply g1n_le_g1Sn; lia. }
assert (Hin: forall x : (ftype t * ftype t),
       In x l -> Binary.is_finite _ _ (fst x) = true /\
       Binary.is_finite _ _ (snd x) = true /\
       Rabs (FT2R (fst x)) < sqrt (fun_bnd t (length l)) /\
       Rabs (FT2R (snd x)) < sqrt (fun_bnd t (length l))).
  { intros. repeat split; [apply H; simpl; auto | apply H; simpl; auto  | | ].
    eapply Rlt_le_trans; [apply H; simpl; auto | apply sqrt_le_1_alt; apply fun_bnd_le; auto  ].
    eapply Rlt_le_trans; [apply H; simpl; auto | apply sqrt_le_1_alt; apply fun_bnd_le; auto ]. }
assert (Hfina : Binary.is_finite (fprec t) (femax t) (fst a) = true /\
        Binary.is_finite (fprec t) (femax t) (snd a) = true) by
  (split; apply H; simpl; auto); destruct Hfina as (Hfina1 & Hfina2).
specialize (IHl s H3 Hn' Hin).
apply is_finite_fma_no_overflow'; auto.
unfold fma_no_overflow, rounded.
destruct (@generic_round_property t (FT2R (fst a) * FT2R (snd a) + FT2R s)) as
  (del & eps & Hed & Hd & He & Hrn );
rewrite Hrn; clear Hrn.
destruct (dotprod_rel_R_exists_fma t l s H3) as (rs & Hrs).
destruct (sum_rel_R_abs_exists_fma t l s H3) as (rs_abs & Habs).
pose proof fma_dotprod_forward_error l
   s H3 IHl rs rs_abs Hrs Habs as Hacc.
apply Rabs_le_minus in Hacc.
set (n:=(length l)) in *.
assert (Hacc' : Rabs (FT2R s) <= (@g t n + 1) * rs_abs + @g1 t n (n - 1)).
{ eapply Rle_trans.
apply Hacc. replace (g n * rs_abs + g1 n (n - 1) + Rabs rs)
with ((@g t n * rs_abs + Rabs rs) + @g1 t n (n - 1)) by nra.
apply Rplus_le_compat_r.
field_simplify.
apply Rplus_le_compat_l.
rewrite <- (@R_dot_prod_rel_Rabs_eq (map FR2 l)); try nra; auto.
apply (@dot_prod_sum_rel_R_Rabs (map FR2 l)); auto. } clear Hacc.
pose proof dotprodR_rel_bound' as C.
pose proof dotprodR_rel_bound'' as D.
eapply Rle_lt_trans; [apply Rabs_triang |].
rewrite Rabs_mult.
eapply Rle_lt_trans; [apply Rplus_le_compat |].
apply Rmult_le_compat; try apply Rabs_pos.
eapply Rle_trans; [apply Rabs_triang |].
apply Rplus_le_compat.
rewrite Rabs_mult.
apply Rmult_le_compat; try apply Rabs_pos.
apply Rlt_le; apply H; simpl; auto.
apply Rlt_le; apply H; simpl; auto.
eapply Rle_trans.
apply Hacc'.
apply Rplus_le_compat_r.
apply Rmult_le_compat_l.
apply Rplus_le_le_0_compat; try nra. apply g_pos.
apply D.
apply fun_bound_pos.
apply Hn'.
apply Habs.
intros; split; apply Rlt_le; apply H; simpl; auto.
assert (HD: Rabs (1 + del) <= (1 + @default_rel t )).
{ eapply Rle_trans; [apply Rabs_triang| rewrite Rabs_R1; apply Rplus_le_compat_l].
eapply Rle_trans; [apply Hd |];  nra. }
apply HD.
apply He.
rewrite sqrt_def.
{
(*algebra*)
unfold fun_bnd.
replace (length (a :: l)) with (S n) by (simpl; lia).
set (x:= (@g t ((S n) - 1) + 1)).
set (y:= (1 + INR (S n) * x)).
set (z:= @g1 t (S n) ((S n) - 1)).
set (u := ((fmax t - @default_abs t) / (1 + @default_rel t) - z) * (1 / y)).
rewrite <- !Rplus_assoc.
replace (( u + (@g t n + 1) * (INR (length l) *  u)))
  with ( u * (1 + (@g t n + 1) * (INR (length l))))
  by nra.
apply Rcomplements.Rlt_minus_r.
apply Rcomplements.Rlt_div_r.
apply Rlt_gt; apply default_rel_plus_1_gt_0.
apply Rcomplements.Rlt_minus_r.
assert (0 < 1 + (@g t n + 1) * INR (length l)).
{ apply Rplus_lt_le_0_compat; try nra.
apply Rmult_le_pos; try apply pos_INR.
apply Rplus_le_le_0_compat; try nra; apply g_pos. }
apply Rcomplements.Rlt_div_r; auto.
assert (0 < 1 / (1 + INR (S (length l)) * (@g t (S (length l) - 1) + 1))).
{ apply Rcomplements.Rdiv_lt_0_compat; try nra.
apply Rplus_lt_le_0_compat; try nra.
apply Rmult_le_pos; try apply pos_INR.
apply Rplus_le_le_0_compat; try nra; apply g_pos. }
assert (0 < 1 + INR (S n) * (@g t (S n - 1) + 1)).
{
apply Rplus_lt_le_0_compat; try nra.
apply Rmult_le_pos; try apply pos_INR.
apply Rplus_le_le_0_compat; try nra; apply g_pos. }
rewrite rdiv_mult_eq; try nra.
unfold u, z, y, x.
apply Rmult_lt_compat.
apply fun_bnd_pos_1; auto.
apply Rlt_le; auto.
unfold fmax.
apply Rminus_lt_minus.
replace n with (length l).
assert (Hl: l = [] \/ l <> []).
destruct l; auto.
right.
eapply hd_error_some_nil; simpl; auto.
destruct Hl. subst.
simpl. unfold g1, g; field_simplify; simpl. field_simplify; apply default_abs_gt_0.
apply length_not_empty_nat in H4.
replace (S (length l) - 1)%nat with (S (length l - 1))%nat by lia.
apply g1n_lt_g1Sn; auto.
subst n; auto.
apply Rcomplements.Rlt_div_r.
apply Rlt_gt.
replace (/ (1 + INR (S n) * (@g t (S n - 1) + 1))) with
  (1/(1 + INR (S n) * (@g t (S n - 1) + 1))) by nra.
apply Rdiv_lt_0_compat; try nra.
field_simplify; try nra.
apply Rcomplements.Rlt_div_r; try nra.
rewrite Rmult_1_l.
apply Rplus_lt_le_compat; try nra.
apply Rplus_le_lt_compat.
rewrite Rmult_comm.
apply Rmult_le_compat; [ apply pos_INR | apply g_pos | | ].
apply le_INR; lia.
replace (S n - 1)%nat with (n)%nat by lia; try nra.
unfold n.
apply lt_INR; lia.
}
apply fun_bound_pos; auto.
}
Qed.

End NAN.


(*From LEM1 section*)

Definition myap {A B}{a0 a1:A} (f:A->B) (h:myeq _ a0 a1):(myeq _ (f a0) (f a1)).
Proof.
destruct h.
constructor.
Show Proof.
Defined.

Lemma equal_a : forall (A B : Type) (f : A -> B) (a0 a1:A),
  (a0 = a1) -> f a0 = f a1.
Proof.
intros A B f a0 a1 r.
destruct r.
reflexivity.
Defined.

(* Measure for terms: the sum of all functional symbols and variables. *)
Definition meas:=
(fix meas (u : Terms) : nat :=
   match u with
   | FVC _ => 1
   | FSC f t0 =>
       @Vector.fold_left nat nat Nat.add 1 (fsv f)
         (@Vector.map Terms nat meas (fsv f) t0) + (fsv f)
   end).
Check Build_FSV 0 1.
Compute (meas (FSC (Build_FSV 0 1) (Vector.cons _ (FVC 0) 0 (Vector.nil _)))).

(*Program *)
Fixpoint qlem1 (t : Terms) (xi : SetVars) (pi : SetVars->X) (u :Terms)
:= match u with
   | FVC v => FVC (v+1)
   | FSC f H => FSC f (Vector.map (qlem1 t xi pi) H)
   end.

(*(v:SetVars)(f:FSV)(H:t Terms (fsv f))*)
(* lem1  (is not proven yet) *)
(*
Fixpoint lem1 (t : Terms) (xi : SetVars) (pi : SetVars->X) (u :Terms)
{struct u}
:
(teI pi (substT t xi u))=(teI (cng pi xi (teI pi t)) u).
Proof.
apply Terms_ind.
Check Terms_ind. *)
Check True.

Theorem myfe :forall (A B : Type) (f g : A -> B),
(forall x : A, myeq _ (f x) (g x)) -> myeq _ f g.
Proof.
intros.
assert( KK : (forall x : A, f x = g x)).
intro x.
destruct (H x).
reflexivity.

pose(v:=(@functional_extensionality _ _ f g KK)).
destruct (@functional_extensionality _ _ f g KK).
reflexivity.
Defined.

Definition P(xi : SetVars) (pi : SetVars->X) (u :Terms)
:=(teI pi (substT t xi u))=(teI (cng pi xi (teI pi t)) u).

(**
Local Open Scope vector.**)
Inductive InV {A} (a:A): forall {n}, Vector.t A n -> Type :=
 |In_cons_hd {m} (v: Vector.t A m): InV a (@Vector.cons A a m v)
 |In_cons_tl {m} x (v: Vector.t A m): InV a v -> InV a (@Vector.cons A x m v).

Definition foma := @Vector.fold_left.
(* \u0418\u0437\u043c\u0435\u0440\u0435\u043d\u0438\u0435 - \u043a\u043e\u0434\u0438\u0440\u043e\u0432\u0430\u043d\u0438\u0435 \u0442\u0435\u0440\u043c\u043e\u0432 \u0430\u0440\u0438\u0444\u043c\u0435\u0442\u0438\u0447\u0435\u0441\u043a\u043e\u0435 x,y,z |-> c(x,y,z)*)
(* \u041d\u0430\u0434\u043e \u043f\u0440\u0438\u0434\u0443\u043c\u0430\u0442\u044c wf-\u043e\u0442\u043d\u043e\u0448\u0435\u043d\u0438\u0435 \u043d\u0430 \u0442\u0435\u0440\u043c\u0430\u0445 *)
(* x is less than y if ... *)
Definition rela : forall (x y:Terms), Prop.
Proof.
fix rela 2.
intros x y.
destruct y.
+ exact False.
+ refine (or _ _).
  exact (Vector.In x t0).
  simple refine (@Vector.fold_left Terms Prop _ False (fsv f) t0).
  intros Q e.
  exact (or Q (rela x e)).
Defined.

Definition snglV {A} (a:A) := Vector.cons A a 0 (Vector.nil A).


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__inequalitysymmetric.
Require Export lemma__localextension.
Require Export lemma__partnotequalwhole.
Require Export logic.
Definition proposition__01 : forall A B, (euclidean__axioms.neq A B) -> (exists X, (euclidean__defs.equilateral A B X) /\ (euclidean__axioms.Triangle A B X)).
Proof.
intro A.
intro B.
intro H.
assert (* Cut *) (exists J, euclidean__axioms.CI J A A B) as H0.
- apply (@euclidean__axioms.postulate__Euclid3 A B H).
- destruct H0 as [J H1].
assert (* Cut *) (euclidean__axioms.neq B A) as H2.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H).
-- assert (* Cut *) (exists K, euclidean__axioms.CI K B B A) as H3.
--- apply (@euclidean__axioms.postulate__Euclid3 B A H2).
--- destruct H3 as [K H4].
assert (* Cut *) (exists D, (euclidean__axioms.BetS B A D) /\ (euclidean__axioms.Cong A D A B)) as H5.
---- apply (@lemma__localextension.lemma__localextension B A B H2 H).
---- destruct H5 as [D H6].
destruct H6 as [H7 H8].
assert (* Cut *) (euclidean__axioms.Cong B A B A) as H9.
----- apply (@euclidean__axioms.cn__congruencereflexive B A).
----- assert (* Cut *) (euclidean__axioms.OutCirc D K) as H10.
------ exists A.
exists B.
exists B.
exists A.
split.
------- exact H4.
------- split.
-------- exact H7.
-------- exact H9.
------ assert (* Cut *) (B = B) as H11.
------- apply (@logic.eq__refl Point B).
------- assert (* Cut *) (euclidean__axioms.InCirc B K) as H12.
-------- exists A.
exists A.
exists B.
exists B.
exists A.
split.
--------- exact H4.
--------- left.
exact H11.
-------- assert (* Cut *) (euclidean__axioms.Cong A B A B) as H13.
--------- apply (@euclidean__axioms.cn__congruencereflexive A B).
--------- assert (* Cut *) (euclidean__axioms.OnCirc B J) as H14.
---------- exists A.
exists B.
exists A.
split.
----------- exact H1.
----------- exact H13.
---------- assert (* Cut *) (euclidean__axioms.OnCirc D J) as H15.
----------- exists A.
exists B.
exists A.
split.
------------ exact H1.
------------ exact H8.
----------- assert (* Cut *) (A = A) as H16.
------------ apply (@logic.eq__refl Point A).
------------ assert (* Cut *) (euclidean__axioms.InCirc A J) as H17.
------------- exists A.
exists A.
exists A.
exists A.
exists B.
split.
-------------- exact H1.
-------------- left.
exact H16.
------------- assert (* Cut *) (exists C, (euclidean__axioms.OnCirc C K) /\ (euclidean__axioms.OnCirc C J)) as H18.
-------------- apply (@euclidean__axioms.postulate__circle__circle B A A B K J B D B A H4 H12 H10 H1 H14 H15).
-------------- destruct H18 as [C H19].
destruct H19 as [H20 H21].
assert (* Cut *) (euclidean__axioms.Cong A C A B) as H22.
--------------- apply (@euclidean__axioms.axiom__circle__center__radius A A B J C H1 H21).
--------------- assert (* Cut *) (euclidean__axioms.Cong A B A C) as H23.
---------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A C B H22).
---------------- assert (* Cut *) (euclidean__axioms.Cong B C B A) as H24.
----------------- apply (@euclidean__axioms.axiom__circle__center__radius B B A K C H4 H20).
----------------- assert (* Cut *) (euclidean__axioms.Cong B C A B) as H25.
------------------ assert (* Cut *) ((euclidean__axioms.Cong C B A B) /\ ((euclidean__axioms.Cong C B B A) /\ (euclidean__axioms.Cong B C A B))) as H25.
------------------- apply (@lemma__congruenceflip.lemma__congruenceflip B C B A H24).
------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H29.
------------------ assert (* Cut *) (euclidean__axioms.Cong B C A C) as H26.
------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B C A B A C H25 H23).
------------------- assert (* Cut *) (euclidean__axioms.Cong A B B C) as H27.
-------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A B C B H25).
-------------------- assert (* Cut *) (euclidean__axioms.Cong A C C A) as H28.
--------------------- apply (@euclidean__axioms.cn__equalityreverse A C).
--------------------- assert (* Cut *) (euclidean__axioms.Cong B C C A) as H29.
---------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B C A C C A H26 H28).
---------------------- assert (* Cut *) (euclidean__defs.equilateral A B C) as H30.
----------------------- split.
------------------------ exact H27.
------------------------ exact H29.
----------------------- assert (* Cut *) (euclidean__axioms.neq B C) as H31.
------------------------ apply (@euclidean__axioms.axiom__nocollapse A B B C H H27).
------------------------ assert (* Cut *) (euclidean__axioms.neq C A) as H32.
------------------------- apply (@euclidean__axioms.axiom__nocollapse B C C A H31 H29).
------------------------- assert (* Cut *) (~(euclidean__axioms.BetS A C B)) as H33.
-------------------------- intro H33.
assert (* Cut *) (~(euclidean__axioms.Cong A C A B)) as H34.
--------------------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A C B H33).
--------------------------- assert (* Cut *) (euclidean__axioms.Cong C A A C) as H35.
---------------------------- apply (@euclidean__axioms.cn__equalityreverse C A).
---------------------------- assert (* Cut *) (euclidean__axioms.Cong C A A B) as H36.
----------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive C A A C A B H35 H22).
----------------------------- assert (euclidean__axioms.Cong A C C A) as H37 by exact H28.
assert (euclidean__axioms.Cong A C A B) as H38 by exact H22.
apply (@H34 H38).
-------------------------- assert (* Cut *) (~(euclidean__axioms.BetS A B C)) as H34.
--------------------------- intro H34.
assert (* Cut *) (~(euclidean__axioms.Cong A B A C)) as H35.
---------------------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A B C H34).
---------------------------- assert (* Cut *) (euclidean__axioms.Cong A B C A) as H36.
----------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive A B B C C A H27 H29).
----------------------------- assert (* Cut *) (euclidean__axioms.Cong C A A C) as H37.
------------------------------ apply (@euclidean__axioms.cn__equalityreverse C A).
------------------------------ assert (euclidean__axioms.Cong A B A C) as H38 by exact H23.
apply (@H35 H38).
--------------------------- assert (* Cut *) (~(euclidean__axioms.BetS B A C)) as H35.
---------------------------- intro H35.
assert (* Cut *) (~(euclidean__axioms.Cong B A B C)) as H36.
----------------------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole B A C H35).
----------------------------- assert (* Cut *) (euclidean__axioms.Cong B A A B) as H37.
------------------------------ apply (@euclidean__axioms.cn__equalityreverse B A).
------------------------------ assert (* Cut *) (euclidean__axioms.Cong B A B C) as H38.
------------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B A A B B C H37 H27).
------------------------------- apply (@H36 H38).
---------------------------- assert (* Cut *) (~(euclidean__axioms.Col A B C)) as H36.
----------------------------- intro H36.
assert (* Cut *) (euclidean__axioms.neq A C) as H37.
------------------------------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C A H32).
------------------------------ assert ((A = B) \/ ((A = C) \/ ((B = C) \/ ((euclidean__axioms.BetS B A C) \/ ((euclidean__axioms.BetS A B C) \/ (euclidean__axioms.BetS A C B)))))) as H38 by exact H36.
destruct H38 as [H39|H39].
------------------------------- apply (@H H39).
------------------------------- destruct H39 as [H40|H40].
-------------------------------- apply (@H37 H40).
-------------------------------- destruct H40 as [H41|H41].
--------------------------------- apply (@H31 H41).
--------------------------------- destruct H41 as [H42|H42].
---------------------------------- assert (* Cut *) (False) as H43.
----------------------------------- apply (@H35 H42).
----------------------------------- contradiction H43.
---------------------------------- destruct H42 as [H43|H43].
----------------------------------- assert (* Cut *) (False) as H44.
------------------------------------ apply (@H34 H43).
------------------------------------ contradiction H44.
----------------------------------- assert (* Cut *) (False) as H44.
------------------------------------ apply (@H33 H43).
------------------------------------ contradiction H44.
----------------------------- assert (* Cut *) (euclidean__axioms.Triangle A B C) as H37.
------------------------------ apply (@euclidean__tactics.nCol__notCol A B C H36).
------------------------------ exists C.
split.
------------------------------- exact H30.
------------------------------- exact H37.
Qed.


(*
 * Vericert: Verified high-level synthesis.
 * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
 *               2020 James Pollard <j@mes.dev>
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <https://www.gnu.org/licenses/>.
 *)

Require Import Coq.ZArith.BinInt.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.

Local Open Scope Z_scope.

Module ZLib.

Lemma mod2_cases: forall (n: Z), n mod 2 = 0 \/ n mod 2 = 1.
Proof.
  intros. pose proof (Z.mod_pos_bound n 2). lia.
Qed.

Lemma div_mul_undo: forall a b,
    b <> 0 ->
    a mod b = 0 ->
    a / b * b = a.
Proof.
  intros.
  pose proof Z.div_mul_cancel_l as A. specialize (A a 1 b).
  replace (b * 1) with b in A by lia.
  rewrite Z.div_1_r in A.
  rewrite Z.mul_comm.
  rewrite <- Z.divide_div_mul_exact; try assumption.
  - apply A; congruence.
  - apply Z.mod_divide; assumption.
Qed.

Lemma sub_mod_0: forall (a b m: Z),
    a mod m = 0 ->
    b mod m = 0 ->
    (a - b) mod m = 0.
Proof.
  intros *. intros E1 E2.
  rewrite Zminus_mod.
  rewrite E1. rewrite E2.
  reflexivity.
Qed.

Lemma add_mod_0: forall a b m : Z,
    a mod m = 0 ->
    b mod m = 0 ->
    (a + b) mod m = 0.
Proof.
  intros *. intros E1 E2.
  rewrite Zplus_mod.
  rewrite E1. rewrite E2.
  reflexivity.
Qed.

Lemma Z_mod_mult': forall a b : Z,
    (a * b) mod a = 0.
Proof.
  intros. rewrite Z.mul_comm. apply Z_mod_mult.
Qed.

Lemma mod_add_r: forall a b,
    b <> 0 ->
    (a + b) mod b = a mod b.
Proof.
  intros. rewrite <- Z.add_mod_idemp_r by lia.
  rewrite Z.mod_same by lia.
  rewrite Z.add_0_r.
  reflexivity.
Qed.

Lemma mod_pow2_same_bounds: forall a n,
    a mod 2 ^ n = a ->
    0 <= n ->
    0 <= a < 2 ^ n.
Proof.
  intros. rewrite <- H. apply Z.mod_pos_bound.
  apply Z.pow_pos_nonneg; lia.
Qed.

Lemma pow2_nonneg: forall n,
    0 <= 2 ^ n.
Proof.
  intros. apply Z.pow_nonneg. lia.
Qed.

Lemma pow2_pos: forall n,
    0 <= n ->
    0 < 2 ^ n.
Proof.
  intros. apply Z.pow_pos_nonneg; lia.
Qed.

Lemma pow2_times2: forall i,
    0 < i ->
    2 ^ i = 2 * 2 ^ (i - 1).
Proof.
  intros.
  rewrite <- Z.pow_succ_r by lia.
  f_equal.
  lia.
Qed.

Lemma pow2_div2: forall i,
    0 <= i ->
    2 ^ (i - 1) = 2 ^ i / 2.
Proof.
  intros.
  assert (i = 0 \/ 0 < i) as C by lia. destruct C as [C | C].
  - subst. reflexivity.
  - rewrite Z.pow_sub_r by lia.
    reflexivity.
Qed.

Lemma div_mul_undo_le: forall a b,
    0 <= a ->
    0 < b ->
    a / b * b <= a.
Proof.
  intros.
  pose proof (Zmod_eq_full a b) as P.
  pose proof (Z.mod_bound_pos a b) as Q.
  lia.
Qed.

Lemma testbit_true_nonneg: forall a i,
    0 <= a ->
    0 <= i ->
    Z.testbit a i = true ->
    2 ^ i <= a.
Proof.
  intros.
  apply Z.testbit_true in H1; [|assumption].
  pose proof (pow2_pos i H0).
  eapply Z.le_trans; [| apply (div_mul_undo_le a (2 ^ i)); lia].
  replace (2 ^ i) with (1 * 2 ^ i) at 1 by lia.
  apply Z.mul_le_mono_nonneg_r; [lia|].
  pose proof (Z.div_pos a (2 ^ i)).
  assert (a / 2 ^ i <> 0); [|lia].
  intro E. rewrite E in H1. cbv in H1. discriminate H1.
Qed.

Lemma range_div_pos: forall a b c d,
    0 < d ->
    a <= b <= c ->
    a / d <= b / d <= c / d.
Proof.
  intuition idtac.
  - apply (Z.div_le_mono _ _ _ H H1).
  - apply (Z.div_le_mono _ _ _ H H2).
Qed.

Lemma testbit_true_nonneg': forall a i,
    0 <= i ->
    2 ^ i <= a < 2 ^ (i + 1) ->
    Z.testbit a i = true.
Proof.
  intros.
  apply Z.testbit_true; [assumption|].
  destruct H0 as [A B].
  pose proof (pow2_pos i H) as Q.
  apply (Z.div_le_mono _ _ _ Q) in A.
  rewrite Z_div_same in A by lia.
  pose proof (Z.div_lt_upper_bound a (2 ^ i) 2 Q) as P.
  rewrite Z.mul_comm in P.
  replace i with (i + 1 - 1) in P by lia.
  rewrite <- pow2_times2 in P by lia.
  specialize (P B).
  replace (i + 1 - 1) with i in P by lia.
  replace (a / 2 ^ i) with 1 by lia.
  reflexivity.
Qed.

Lemma testbit_false_nonneg: forall a i,
    0 <= a < 2 ^ i ->
    0 < i ->
    Z.testbit a (i - 1) = false ->
    a < 2 ^ (i - 1).
Proof.
  intros.
  assert (2 ^ (i - 1) <= a < 2 ^ i \/ a < 2 ^ (i - 1)) as C by lia.
  destruct C as [C | C]; [exfalso|assumption].
  assert (Z.testbit a (i - 1) = true); [|congruence].
  replace i with (i - 1 + 1) in C at 2 by lia.
  apply testbit_true_nonneg'; lia.
Qed.

Lemma signed_bounds_to_sz_pos: forall sz n,
    - 2 ^ (sz - 1) <= n < 2 ^ (sz - 1) ->
    0 < sz.
Proof.
  intros.
  assert (0 < sz \/ sz - 1 < 0) as C by lia.
  destruct C as [C | C]; [assumption|exfalso].
  rewrite Z.pow_neg_r in H by assumption.
  lia.
Qed.

Lemma two_digits_encoding_inj_lo: forall base a b c d: Z,
  0 <= b < base ->
  0 <= d < base ->
  base * a + b = base * c + d ->
  b = d.
Proof.
  intros.
  pose proof Z.mod_unique as P.
  specialize P with (b := base) (q := c) (r := d).
  specialize P with (2 := H1).
  rewrite P by lia.
  rewrite <- Z.add_mod_idemp_l by lia.
  rewrite Z.mul_comm.
  rewrite Z.mod_mul by lia.
  rewrite Z.add_0_l.
  rewrite Z.mod_small by lia.
  reflexivity.
Qed.

Lemma two_digits_encoding_inj_hi: forall base a b c d: Z,
  0 <= b < base ->
  0 <= d < base ->
  base * a + b = base * c + d ->
  a = c.
Proof.
  intros. nia.
Qed.

Lemma Z_to_nat_neg: forall (n: Z),
    n < 0 ->
    Z.to_nat n = 0%nat.
Proof.
  intros. destruct n; (lia||reflexivity).
Qed.

End ZLib.

Module ZExtra.

  Lemma mod_0_bounds :
    forall x y m,
      0 < m ->
      x mod m = 0 ->
      y mod m = 0 ->
      x <> y ->
      x + m > y ->
      y + m <= x.
  Proof.
    intros x y m.
    intros POS XMOD YMOD NEQ H.
    destruct (Z_le_gt_dec (y + m) x); eauto.

    apply Znumtheory.Zmod_divide in YMOD; try lia.
    apply Znumtheory.Zmod_divide in XMOD; try lia.
    inversion XMOD as [x']; subst; clear XMOD.
    inversion YMOD as [y']; subst; clear YMOD.

    assert (x' <> y') as NEQ' by lia; clear NEQ.

    rewrite <- Z.mul_succ_l in H.
    rewrite <- Z.mul_succ_l in g.
    apply Zmult_gt_reg_r in H;
      apply Zmult_gt_reg_r in g; lia.
  Qed.

  Lemma Ple_not_eq :
    forall x y,
    (x < y)%positive -> x <> y.
  Proof. lia. Qed.

  Lemma Pge_not_eq :
    forall x y,
    (y < x)%positive -> x <> y.
  Proof. lia. Qed.

  Lemma Ple_Plt_Succ :
    forall x y n,
    (x <= y)%positive -> (x < y + n)%positive.
  Proof. lia. Qed.

End ZExtra.


(************************************************************************)
(*  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: Lexicographic_Exponentiation.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Author: Cristina Cornes

    From : Constructing Recursion Operators in Type Theory
           L. Paulson  JSC (1986) 2, 325-355  *)

Require Import List.
Require Import Relation_Operators.
Require Import Transitive_Closure.

Section Wf_Lexicographic_Exponentiation.
  Variable A : Set.
  Variable leA : A -> A -> Prop.

  Notation Power := (Pow A leA).
  Notation Lex_Exp := (lex_exp A leA).
  Notation ltl := (Ltl A leA).
  Notation Descl := (Desc A leA).

  Notation List := (list A).
  Notation Nil := (nil (A:=A)).
  (* useless but symmetric *)
  Notation Cons := (cons (A:=A)).
  Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100).

  (* Hint Resolve d_one d_nil t_step. *)

  Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z.
  Proof.
    simple induction x.
    simple induction z.
    simpl in |- *; intros H.
    inversion_clear H.
    simpl in |- *; intros; apply (Lt_nil A leA).
    intros a l HInd.
    simpl in |- *.
    intros.
    inversion_clear H.
    apply (Lt_hd A leA); auto with sets.
    apply (Lt_tl A leA).
    apply (HInd y y0); auto with sets.
  Qed.

  Lemma right_prefix :
    forall x y z:List,
      ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
  Proof.
    intros x y; generalize x.
    elim y; simpl in |- *.
    right.
    exists x0; auto with sets.
    intros.
    inversion H0.
    left; apply (Lt_nil A leA).
    left; apply (Lt_hd A leA); auto with sets.
    generalize (H x1 z H3).
    simple induction 1.
    left; apply (Lt_tl A leA); auto with sets.
    simple induction 1.
    simple induction 1; intros.
    rewrite H8.
    right; exists x2; auto with sets.
  Qed.

  Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x.
  Proof.
    intros.
    inversion H.
    generalize (app_cons_not_nil _ _ _ H1); simple induction 1.
    cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets.
    intro.
    generalize (app_eq_unit _ _ H0).
    simple induction 1; simple induction 1; intros.
    rewrite H4; auto using d_nil with sets.
    discriminate H5.
    generalize (app_inj_tail _ _ _ _ H0).
    simple induction 1; intros.
    rewrite <- H4; auto with sets.
  Qed.

  Lemma desc_tail :
    forall (x:List) (a b:A),
      Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b.
  Proof.
    intro.
    apply rev_ind with
      (A := A)
      (P := fun x:List =>
        forall a b:A,
          Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b).
    intros.

    inversion H.
    cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil);
      auto with sets; intro.
    generalize H0.
    intro.
    generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4);
      simple induction 1.
    intros.

    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
    generalize H1.
    rewrite <- H10; rewrite <- H7; intro.
    apply (t_step A leA); auto with sets.

    intros.
    inversion H0.
    generalize (app_cons_not_nil _ _ _ H3); intro.
    elim H1.

    generalize H0.
    generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b);
      simple induction 1.
    intro.
    generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro.
    generalize (H x0 b H6).
    intro.
    apply t_trans with (A := A) (y := x0); auto with sets.

    apply t_step.
    generalize H1.
    rewrite H4; intro.

    generalize (app_inj_tail _ _ _ _ H8); simple induction 1.
    intros.
    generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b).
    intro.
    generalize H10.
    rewrite H12; intro.
    generalize (app_inj_tail _ _ _ _ H13); simple induction 1.
    intros.
    rewrite <- H11; rewrite <- H16; auto with sets.
  Qed.

  Lemma dist_aux :
    forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y.
  Proof.
    intros z D.
    elim D.
    intros.
    cut (x ++ y = Nil); auto with sets; intro.
    generalize (app_eq_nil _ _ H0); simple induction 1.
    intros.
    rewrite H2; rewrite H3; split; apply d_nil.

    intros.
    cut (x0 ++ y = Cons x Nil); auto with sets.
    intros E.
    generalize (app_eq_unit _ _ E); simple induction 1.
    simple induction 1; intros.
    rewrite H2; rewrite H3; split.
    apply d_nil.

    apply d_one.

    simple induction 1; intros.
    rewrite H2; rewrite H3; split.
    apply d_one.

    apply d_nil.

    do 5 intro.
    intros Hind.
    do 2 intro.
    generalize x0.
    apply rev_ind with
      (A := A)
      (P := fun y0:List =>
        forall x0:List,
          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 ->
          Descl x0 /\ Descl y0).

    intro.
    generalize (app_nil_end x1); simple induction 1; simple induction 1.
    split. apply d_conc; auto with sets.

    apply d_nil.

    do 3 intro.
    generalize x1.
    apply rev_ind with
      (A := A)
      (P := fun l0:List =>
        forall (x1:A) (x0:List),
          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil ->
          Descl x0 /\ Descl (l0 ++ Cons x1 Nil)).

    simpl in |- *.
    split.
    generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
    simple induction 1; auto with sets.

    apply d_one.
    do 5 intro.
    generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)).
    simple induction 1.
    generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1.
    intro E.
    generalize (app_inj_tail _ _ _ _ E).
    simple induction 1; intros.
    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
    rewrite <- H7; rewrite <- H10; generalize H6.
    generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1.
    rewrite E1.
    intro.
    generalize (Hind x4 (l1 ++ Cons x2 Nil) H11).
    simple induction 1; split.
    auto with sets.

    generalize H14.
    rewrite <- H10; intro.
    apply d_conc; auto with sets.
  Qed.

  Lemma dist_Desc_concat :
    forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y.
  Proof.
    intros.
    apply (dist_aux (x ++ y) H x y); auto with sets.
  Qed.

  Lemma desc_end :
    forall (a b:A) (x:List),
      Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) ->
      clos_trans A leA a b.
  Proof.
    intros a b x.
    case x.
    simpl in |- *.
    simple induction 1.
    intros.
    inversion H1; auto with sets.
    inversion H3.

    simple induction 1.
    generalize (app_comm_cons l (Cons a Nil) a0).
    intros E; rewrite <- E; intros.
    generalize (desc_tail l a a0 H0); intro.
    inversion H1.
    apply t_trans with (y := a0); auto with sets.

    inversion H4.
  Qed.

  Lemma ltl_unit :
    forall (x:List) (a b:A),
      Descl (x ++ Cons a Nil) ->
      ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil).
  Proof.
    intro.
    case x.
    intros; apply (Lt_nil A leA).

    simpl in |- *; intros.
    inversion_clear H0.
    apply (Lt_hd A leA a b); auto with sets.

    inversion_clear H1.
  Qed.

  Lemma acc_app :
    forall (x1 x2:List) (y1:Descl (x1 ++ x2)),
      Acc Lex_Exp << x1 ++ x2, y1 >> ->
      forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>.
  Proof.
    intros.
    apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
    auto with sets.

    unfold lex_exp in |- *; simpl in |- *; auto with sets.
  Qed.

  Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp.
  Proof.
    unfold well_founded at 2 in |- *.
    simple induction a; intros x y.
    apply Acc_intro.
    simple induction y0.
    unfold lex_exp at 1 in |- *; simpl in |- *.
    apply rev_ind with
      (A := A)
      (P := fun x:List =>
	forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>).
    intros.
    inversion_clear H0.

    intro.
    generalize (well_founded_ind (wf_clos_trans A leA H)).
    intros GR.
    apply GR with
      (P := fun x0:A =>
        forall l:List,
          (forall (x1:List) (y:Descl x1),
            ltl x1 l -> Acc Lex_Exp << x1, y >>) ->
          forall (x1:List) (y:Descl x1),
            ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>).
    intro; intros HInd; intros.
    generalize (right_prefix x2 l (Cons x1 Nil) H1).
    simple induction 1.
    intro; apply (H0 x2 y1 H3).

    simple induction 1.
    intro; simple induction 1.
    clear H4 H2.
    intro; generalize y1; clear y1.
    rewrite H2.
    apply rev_ind with
      (A := A)
      (P := fun x3:List =>
        forall y1:Descl (l ++ x3),
          ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>).
    intros.
    generalize (app_nil_end l); intros Heq.
    generalize y1.
    clear y1.
    rewrite <- Heq.
    intro.
    apply Acc_intro.
    simple induction y2.
    unfold lex_exp at 1 in |- *.
    simpl in |- *; intros x4 y3. intros.
    apply (H0 x4 y3); auto with sets.

    intros.
    generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1).
    simple induction 1.
    intros.
    generalize (desc_end x4 x1 l0 (conj H8 H5)); intros.
    generalize y1.
    rewrite <- (app_ass l l0 (Cons x4 Nil)); intro.
    generalize (HInd x4 H9 (l ++ l0)); intros HInd2.
    generalize (ltl_unit l0 x4 x1 H8 H5); intro.
    generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2).
    simple induction 1; intros.
    generalize (H4 H12 H10); intro.
    generalize (Acc_inv H14).
    generalize (acc_app l l0 H12 H14).
    intros f g.
    generalize (HInd2 f); intro.
    apply Acc_intro.
    simple induction y3.
    unfold lex_exp at 1 in |- *; simpl in |- *; intros.
    apply H15; auto with sets.
  Qed.

End Wf_Lexicographic_Exponentiation.


From iris.algebra Require Import cmra list.

Lemma replicate_op {A: ucmraT} (a b: A) n:
  replicate n (a ⋅ b) = replicate n a ⋅ replicate n b.
Proof. apply list_eq. induction n; simpl. done. case; done. Qed.

Lemma included_None {A: cmraT} (a : option A):
  (a ≼ None) -> a = None.
Proof.
  rewrite option_included. case; first done.
  intros (? & ? & _ & HContra & _). discriminate.
Qed.

Lemma None_least (A: cmraT) (a: option A): None ≼ a.
Proof. by apply option_included; left. Qed.

Theorem prod_included':
  forall (A B: cmraT) (x y: (A * B)), x.1 ≼ y.1 ∧ x.2 ≼ y.2 -> x ≼ y.
Proof.
    by intros; apply prod_included.
Qed.

Lemma None_op_left_id {A: cmraT} (a: option A): None ⋅ a = a.
Proof. rewrite /op /cmra_op /=. by destruct a. Qed.

Theorem prod_included'':
  forall (A B: cmraT) (x y: (A * B)), x ≼ y -> x.1 ≼ y.1 ∧ x.2 ≼ y.2.
Proof.
    by intros; apply prod_included.
Qed.

Theorem prod_included''':
  forall (A B: cmraT) (x x' : A) (y y': B), (x, y) ≼ (x', y') -> x ≼ x' ∧ y ≼ y'.
Proof.
  intros ? ? ? ? ? ? HEv.
  apply prod_included'' in HEv.
  by simpl in *.
Qed.

Lemma list_validN_app {A: ucmraT} (x y : list A) (n: nat):
  ✓{n} (x ++ y) <-> ✓{n} x ∧ ✓{n} y.
Proof. apply Forall_app. Qed.


Require Import prelude_import.

Theorem start (A: Prop) : (A->A).
  intros. apply H.
  Qed.
Theorem th0 (A0 A1 A2 A3 A4: Prop) : (A0->A1->A2->A3->A4->A3).
  intros.
  apply H2.
Qed.

Theorem th1 (A0 A1 A2 A3 A4: Prop) : (A0->A1->A2->A3->A4->A3).
  pose th0.
  apply p.
Qed.

Theorem th2_other (A0 A1 A2 A3 A4: Prop) : (A0->A1->A2->A3->A4->A2).
  pose th1.
  pose th0.
  intros.
  apply H1.
Qed.

Theorem th2 (A0 A1 A2 A3 A4: Prop) : (A0->A1->A2->A3->A4->A2).
  pose th0.
  pose th1.
  intros.
  apply H1.
Qed.