(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

Require Import Reals.
Require Import Rsequence.
Require Import Rsequence_base_facts.
Require Import Rsequence_cv_facts.
Require Import Rsequence_rel_facts.
Require Import Fourier.
(** printing ~	~ *)
(** * Convergence of usual sequences. *)

(** Convergence of polynomials. *)

(**********)
Lemma Rseq_poly_cv : forall d, (d > 0)%nat -> Rseq_cv_pos_infty (Rseq_poly d).
Proof.
intros d H M.
assert (Hm : forall n, Rseq_poly d n >= INR n).
unfold Rseq_poly; induction H; intros n.
simpl; fourier.
eapply Rge_trans with (INR n * INR n)%R.
rewrite <- tech_pow_Rmult.
apply Rmult_ge_compat_l; [apply Rle_ge; apply pos_INR|apply IHle].
destruct n; auto with real.
destruct n; auto with real.
left; rewrite <- Rmult_1_r.
apply Rmult_gt_compat_l.
apply lt_0_INR; omega.
apply lt_1_INR; omega.
destruct (IZN (up (Rmax 0 (M + 1)))) as [N Hz].
apply le_0_IZR.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
left; eapply Rle_lt_trans; [apply RmaxLess1|eexact Hp].
exists N; intros n Hn.
eapply Rlt_le_trans with (INR n); [|apply Rge_le; apply Hm].
eapply Rlt_le_trans with (INR N); [|apply le_INR; assumption].
rewrite INR_IZR_INZ; rewrite <- Hz.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
eapply Rlt_trans; [|eexact Hp].
eapply Rlt_le_trans with (M + 1)%R; [fourier|apply RmaxLess2].
Qed.

(** Convergence of power sequences. *)

(**********)
Lemma Rseq_pow_eq_1_cv : Rseq_cv (Rseq_pow 1) 1.
Proof.
intros eps Heps.
exists 1%nat; intros n Hn.
assert (He : Rseq_pow 1 n = 1).
clear Hn; induction n; simpl; try rewrite IHn; field.
rewrite He; rewrite R_dist_eq; assumption.
Qed.

(**********)
Lemma Rseq_pow_lt_1_cv : forall r, 0 <= r < 1 -> Rseq_cv (Rseq_pow r) 0.
intros r [Hl Hr] eps Heps.
unfold R_dist; unfold Rseq_pow.
assert (exists N, forall n, (n >= N)%nat -> Rabs (r ^ n) < eps).
apply pow_lt_1_zero; [rewrite Rabs_right|]; try apply Rle_ge; assumption.
destruct H as [N H].
exists N; intros n Hn.
rewrite Rminus_0_r.
apply H; assumption.
Qed.

(**********)
Lemma Rseq_pow_gt_1_cv : forall r, r > 1 -> Rseq_cv_pos_infty (Rseq_pow r).
Proof.
intros r Hr M.
unfold Rseq_pow.
destruct (Pow_x_infinity r) with (b := (M + 1)%R) as [N HN].
rewrite Rabs_right; fourier.
exists N; intros n Hn.
rewrite <- Rabs_right.
eapply Rlt_le_trans with (M + 1)%R; [fourier|].
apply Rge_le; apply HN; assumption.
left; apply pow_lt; fourier.
Qed.

(** Convergence of factorial. *)

(**********)
Lemma Rseq_fact_cv : Rseq_cv_pos_infty Rseq_fact.
Proof.
intros M.
assert (forall n, (INR n) <= Rseq_fact n).
unfold Rseq_fact.
intros n; apply le_INR.
destruct n.
simpl; repeat constructor.
rewrite fact_simpl.
pattern (S n) at 1; rewrite <- mult_1_r.
apply mult_le_compat_l.
induction n.
simpl; constructor.
rewrite fact_simpl; pattern 1%nat; rewrite <- mult_1_r.
apply mult_le_compat; omega.
destruct (IZN (up (Rmax 0 (M + 1)))) as [N Hz].
apply le_0_IZR.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
left; eapply Rle_lt_trans; [apply RmaxLess1|eexact Hp].
exists N; intros n Hn.
eapply Rlt_le_trans with (INR n); [|apply H].
eapply Rlt_le_trans with (INR N); [|apply le_INR; assumption].
rewrite INR_IZR_INZ; rewrite <- Hz.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
eapply Rlt_trans; [|eexact Hp].
eapply Rlt_le_trans with (M + 1)%R; [fourier|apply RmaxLess2].
Qed.

(** * Growth comparison. *)

(**********)
Lemma Rseq_poly_little_O : forall d1 d2, (d1 < d2)%nat -> (Rseq_poly d1) = o(Rseq_poly d2).
Proof.
intros d1 d2 Hd.
intros eps Heps.
unfold Rseq_poly.
pose (k := (d2 - d1)%nat).
assert (Hk : (k > 0)%nat); [unfold k; omega|].
assert (HM : exists N, forall n, (n >= N)%nat -> /eps < Rseq_poly k n).
apply Rseq_poly_cv; assumption.
destruct HM as [N HN].
exists N; intros n Hn.
replace d2 with (d1 + k)%nat by (unfold k; omega).
rewrite pow_add; rewrite Rabs_mult.
rewrite Rmult_comm.
rewrite Rmult_assoc.
pattern (Rabs (INR n ^ d1)) at 1; rewrite <- Rmult_1_r.
apply Rmult_le_compat_l; [apply Rabs_pos|].
rewrite <- (Rinv_l eps); [|apply Rgt_not_eq; assumption].
apply Rmult_le_compat_r; [fourier|].
rewrite Rabs_right; [|apply Rle_ge; apply pow_le; apply pos_INR].
left; apply HN; assumption.
Qed.

(**********)
Lemma Rseq_inv_poly_little_O : forall d1 d2, (d1 < d2)%nat -> (Rseq_inv_poly d2) = o(Rseq_inv_poly d1).
Proof.
intros d1 d2 Hd.
eapply Rseq_little_O_asymptotic.
  intros Wn Xn H; eexact H.
exists 1%nat.
eapply Rseq_little_O_eq_compat
  with (Un := fun n => / (INR (S n) ^ d2)) (Vn := fun n => (/ INR (S n) ^ d1)).
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [reflexivity|auto with real].
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [reflexivity|auto with real].
apply Rseq_little_O_inv_contravar.
intros eps Heps.
destruct (Rseq_poly_little_O d1 d2 Hd eps Heps) as [N HN].
exists N; intros n Hn; apply HN; omega.
intros n; apply pow_nonzero; auto with real.
intros n; apply pow_nonzero; auto with real.
Qed.

(**********)
Lemma Rseq_pow_little_O : forall r1 r2, (0 <= r1 < r2) -> (Rseq_pow r1) = o(Rseq_pow r2).
Proof.
intros r1 r2 [Hp Hr] eps Heps.
pose (k := (r1 / r2)%R).
assert (Hkl : 0 <= k).
unfold k; unfold Rdiv; replace 0 with (0 * 0)%R by field.
apply Rmult_le_compat; try apply Rle_refl; try fourier.
left; apply Rinv_0_lt_compat; eapply Rle_lt_trans; eassumption.
assert (Hkr : k < 1).
unfold k; unfold Rdiv.
rewrite <- (Rinv_r r2).
apply Rmult_lt_compat_r; [|assumption].
apply Rinv_0_lt_compat; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
apply Rgt_not_eq; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
unfold Rseq_pow.
assert (Hk : exists N, forall n, (n >= N)%nat -> Rabs (k ^ n) < eps).
apply pow_lt_1_zero; [rewrite Rabs_right|]; try apply Rle_ge; assumption.
destruct Hk as [N HN].
exists N; intros n Hn.
replace r1 with (k * r2)%R.
cutrewrite ((k * r2) ^ n = k ^ n * r2 ^ n)%R.
rewrite Rabs_mult.
apply Rmult_le_compat_r; [apply Rabs_pos|].
left; apply HN; apply Hn.
clear Hn HN; induction n; simpl; try rewrite IHn; field.
unfold k; field; apply Rgt_not_eq; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
Qed.

(**********)
Lemma Rseq_poly_pow_gt_1_little_O : forall d r, r > 1 -> (Rseq_poly d) = o(Rseq_pow r).
Proof.
intros d r Hr.
pose (npow := (fix F m d := match d with O => 1 | S d => m * F m d end)%nat).
(* Lack of a lemma in stdlib *)
assert (Hpow : (forall x y n, pow (x * y) n = pow x n * pow y n)%R).
intros x y n; induction n.
simpl; rewrite Rmult_1_l; reflexivity.
repeat rewrite <- tech_pow_Rmult; rewrite IHn; field.
(* end of lemma *)
assert (Ho : forall k, Rseq_poly (npow 2%nat k) = o(Rseq_pow r)).
induction k; simpl.
(* Case k = 0 *)
set (x := (r - 1)%R).
assert (Hx : x > 0); [unfold x; fourier|].
assert (Hdev : forall n, (2 <= n)%nat -> (1 + x) ^ n >= 1 + INR n * x + (INR n * (INR n - 1)) * /2 * x * x).
intros n H; induction H.
simpl; right; field.
rewrite <- tech_pow_Rmult.
eapply Rge_trans.
apply Rmult_ge_compat_l; [fourier|apply IHle].
repeat rewrite S_INR.
field_simplify.
unfold Rdiv; apply Rmult_ge_compat_r; [fourier|].
assert (HINR : 1 < INR m); [apply lt_1_INR; omega|].
rewrite <- Rplus_0_l.
unfold Rminus; repeat rewrite Rplus_assoc.
rewrite <- Rplus_assoc.
apply Rplus_ge_compat_r.
rewrite <- Ropp_mult_distr_r_reverse.
rewrite <- Rmult_plus_distr_l.
rewrite <- (Rmult_0_l 0).
apply Rmult_ge_compat; try fourier.
apply Rle_ge; apply pow_le; fourier.
simpl.
pattern (INR m) at 3; rewrite <- Rmult_1_r.
rewrite <- Ropp_mult_distr_r_reverse.
rewrite <- Rmult_plus_distr_l.
rewrite <- (Rmult_0_l 0).
apply Rmult_ge_compat; try fourier.
assert (Hmin : forall n, (2 <= n)%nat -> r ^ n > (INR n * (INR n - 1) * / 2 * x * x)).
intros n Hd.
replace r with (1 + x)%R by (unfold x; field).
rewrite <- Rplus_0_l.
eapply Rlt_le_trans; [|apply Rge_le; apply Hdev; assumption].
apply Rplus_lt_compat_r.
assert (HINR: 0 <= INR n); [apply pos_INR; omega|].
pattern 0; rewrite <- Rplus_0_l.
apply Rplus_lt_le_compat; [fourier|].
apply Rmult_le_pos; fourier.
assert (HO : (Rseq_poly 2) = O(fun n => INR n * (INR n - 1) * / 2 * x * x)%R).
unfold Rseq_poly.
exists (INR 4 * / x * / x)%R; split.
  apply Rle_ge; rewrite <- (Rmult_0_r 0).
  rewrite Rmult_assoc.
  apply Rmult_le_compat; try apply Rle_refl.
  apply pos_INR.
  left; apply Rmult_lt_0_compat; apply Rinv_0_lt_compat; assumption.
  exists 2%nat; intros n Hn.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_right; try fourier.
  simpl; field_simplify; [|apply Rgt_not_eq; assumption].
  replace ((4 * INR n ^ 2 - 4 * INR n) / 2)%R
    with (INR n * (2 * (INR n - 1)))%R by field.
  replace (INR n ^ 2 / 1)%R with (INR n * INR n)%R by field.
  apply Rmult_le_compat_l; [apply pos_INR|].
  replace 1%R with (INR 1) by reflexivity.
  rewrite <- plus_INR.
  rewrite <- minus_INR; [|omega].
  rewrite <- mult_INR.
  apply le_INR; omega.
  replace 1%R with (INR 1) by reflexivity.
  rewrite <- minus_INR; [apply Rle_ge; apply pos_INR|omega].
  apply Rle_ge; apply pos_INR.
  apply Rle_ge; apply pow_le; apply pos_INR.
assert (HO2 : (fun n => INR n * (INR n - 1) * / 2 * x * x)%R = O(Rseq_pow r)).
  exists 1; split; [fourier|].
  exists 2%nat; intros n Hn.
  rewrite Rabs_right; [rewrite Rabs_right|].
  left; rewrite Rmult_1_l; apply Hmin; assumption.
  apply Rle_ge; apply pow_le; fourier.
  apply Rle_ge; left; repeat apply Rmult_lt_0_compat; try fourier.
  apply lt_0_INR; omega.
  replace 1 with (INR 1) by reflexivity; rewrite <- minus_INR; [|omega].
  apply lt_0_INR; omega.
eapply Rseq_little_O_big_O_trans.
  apply (Rseq_poly_little_O 1 2); omega.
  eapply Rseq_big_O_trans.
    apply HO.
    apply HO2.
(* Case k > 0 *)
set (kk := npow 2%nat k).
rewrite plus_0_r.
replace (kk + kk)%nat
  with (2 * kk)%nat by ring.
intros eps Heps.
destruct (IHk (/ Rabs (2 ^ kk) * sqrt eps * / sqrt r))%R as [N HN].
repeat apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat; apply Rabs_pos_lt;
apply pow_nonzero; apply Rgt_not_eq; fourier.
apply sqrt_lt_R0; fourier.
apply Rinv_0_lt_compat; apply sqrt_lt_R0; fourier.
exists (2 * N)%nat; intros n Hn.
unfold Rseq_poly; unfold Rseq_pow.
pose (m :=
  match Even.even_odd_dec n with
  | left evn => proj1_sig (Div2.even_2n n evn)
  | right odd => S (proj1_sig (Div2.odd_S2n n odd))
  end
).
assert (Hm : (n <= 2 * m /\ 2 * m <= S n)%nat).
destruct (Even.even_odd_dec n) as [Hm|Hm];
[destruct (Div2.even_2n n Hm) as [p Hp]|destruct (Div2.odd_S2n n Hm) as [p Hp]];
simpl in m; unfold Div2.double in Hp; unfold m; omega.
destruct Hm as [Hml Hmr].
apply Rle_trans with (Rabs (INR (2 * m) ^ (2 * kk))).
repeat rewrite Rabs_right.
apply pow_incr; split; [apply pos_INR|apply le_INR; assumption].
apply Rle_ge; apply pow_le; apply pos_INR.
apply Rle_ge; apply pow_le; apply pos_INR.
rewrite pow_Rsqr; rewrite mult_INR.
unfold Rsqr; repeat rewrite Hpow; repeat rewrite Rabs_mult; simpl.
eapply Rle_trans.
apply Rmult_le_compat.
replace 0 with (0 * 0)%R by field;
apply Rmult_le_compat; (apply Rle_refl || apply Rabs_pos).
replace 0 with (0 * 0)%R by field;
apply Rmult_le_compat; (apply Rle_refl || apply Rabs_pos).
apply Rmult_le_compat_l; [apply Rabs_pos|]; apply HN; omega.
apply Rmult_le_compat_l; [apply Rabs_pos|]; apply HN; omega.
unfold Rseq_pow.
field_simplify.
simpl; unfold Rdiv; repeat rewrite Rinv_1;
repeat rewrite Rmult_1_r.
rewrite sqrt_sqrt; [|fourier].
rewrite sqrt_sqrt; [|fourier].
rewrite Rmult_assoc.
apply Rmult_le_compat_l; [fourier|].
pattern (/ r)%R at 1; rewrite <- Rabs_right; [|left; apply Rinv_0_lt_compat; fourier].
repeat rewrite <- Rabs_mult.
rewrite <- pow_add.
repeat rewrite Rabs_right.
apply (Rmult_le_reg_l r); [fourier|].
field_simplify.
unfold Rdiv; repeat rewrite Rinv_1; repeat rewrite Rmult_1_r.
rewrite tech_pow_Rmult.
apply Rle_pow; [fourier|].
replace (m + m)%nat with (2 * m)%nat by ring; assumption.
apply Rgt_not_eq; fourier.
apply Rle_ge; apply pow_le; fourier.
replace 0 with (0 * 0)%R by field.
apply Rmult_ge_compat; try fourier.
left; apply pow_lt; fourier.
left; apply Rinv_0_lt_compat; fourier.
split; apply Rgt_not_eq.
apply sqrt_lt_R0; fourier.
apply Rabs_pos_lt; apply pow_nonzero; apply Rgt_not_eq; fourier.
assert (Hp : (forall n, exists p, n < npow 2 p)%nat).
intros n.
destruct (zerop n) as [H|H].
exists 0%nat; simpl; omega.
induction H.
exists 1%nat; simpl; omega.
destruct IHle as [p Hp].
exists (S p); simpl; omega.
destruct (Hp d) as [dm Hdm].
apply Rseq_little_O_trans with (Rseq_poly (npow 2 dm)%nat).
apply Rseq_poly_little_O; assumption.
apply Ho.
Qed.

(**********)
Lemma Rseq_inv_poly_pow_lt_1_little_O : forall d r, 0 < r < 1 -> (Rseq_pow r) = o(Rseq_inv_poly d).
Proof.
intros d r [Hr1 Hr2].
eapply Rseq_little_O_asymptotic.
  intros Wn Xn H; eexact H.
exists 1%nat.
apply Rseq_little_O_eq_compat
  with (Un := fun n => / ((/ r) ^ (S n))) (Vn := fun n => (/ INR (S n) ^ d)).
intros n; unfold Rseq_pow.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [|auto with real].
rewrite Rinv_involutive; [|auto with real].
reflexivity.
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [|auto with real].
reflexivity.
apply Rseq_little_O_inv_contravar.
intros eps Heps.
destruct (Rseq_poly_pow_gt_1_little_O d (/ r)) with (eps := eps) as [N HN].
  rewrite <- Rinv_1.
  apply Rinv_lt_contravar.
  rewrite Rmult_1_r; assumption.
  assumption.
  assumption.
exists N; intros n Hn.
apply HN; omega.
intros n; apply pow_nonzero; auto with real.
intros n; apply pow_nonzero; auto with real.
Qed.

(**********)
Lemma Rseq_pow_fact_little_O : forall r, 0 <= r -> (Rseq_pow r) = o(Rseq_fact).
Proof.
assert (HO : forall n, Rseq_pow (INR n) = O(Rseq_fact)).
  intros n.
  assert (Hp: 0 <= INR n ^ n).
    apply pow_le; apply pos_INR.
  assert (Hf: / INR (fact n) > 0).
    apply Rinv_0_lt_compat.
    replace 0 with (INR 0) by reflexivity.
    apply lt_INR; apply lt_O_fact.
  exists (INR n ^ n / INR (fact n)); split.
    replace 0 with (0 * 0)%R by field.
    apply Rmult_ge_compat; try fourier.
      left; apply Hf.
  exists n; intros m Hm.
  induction Hm.
    rewrite Rabs_right; [|apply Rle_ge; apply Hp].
    rewrite Rabs_right; [|apply Rle_ge; apply pos_INR].
    right.
      unfold Rseq_pow; unfold Rseq_fact; field.
      apply Rgt_not_eq.
      replace 0 with (INR 0) by reflexivity.
      apply lt_INR; apply lt_O_fact.
    simpl; unfold Rseq_fact; rewrite fact_simpl.
    rewrite mult_INR.
    repeat rewrite Rabs_mult.
    set (K := INR n ^ n / INR (fact n)).
    replace (K * (Rabs (INR (S m)) * Rabs (INR (fact m))))
      with (Rabs (INR (S m)) * (K * (Rabs (INR (fact m)))))
      by field.
    apply Rmult_le_compat; try apply Rabs_pos.
    repeat rewrite Rabs_right; try (apply Rle_ge; apply pos_INR).
    apply le_INR; omega.
    apply IHHm.
intros r Hr.
destruct (IZN (up r)) as [d Hd].
  destruct (archimed r) as [H _].
  apply le_IZR.
  eapply Rle_trans.
    simpl; eexact Hr.
    left; eexact H.
apply Rseq_little_O_big_O_trans with (Rseq_pow (INR d)).
apply Rseq_pow_little_O; split.
  assumption.
  destruct (archimed r) as [H _].
  rewrite Hd in H.
  rewrite <- INR_IZR_INZ in H.
  exact H.
apply HO.
Qed.

(**********)
Lemma Rseq_poly_fact_little_O : forall d, Rseq_poly d = o(Rseq_fact).
Proof.
intros d.
eapply Rseq_little_O_trans.
apply Rseq_poly_pow_gt_1_little_O.
instantiate (1 := 2); fourier.
apply Rseq_pow_fact_little_O; fourier.
Qed.

(** * Things that don't have anything to do there... *)

(**********)
Lemma Rseq_ln_cv : Rseq_cv_pos_infty (fun n => ln (INR n)).
Proof.
intro m.
destruct (Rseq_poly_cv 1) with (M := Rabs m) as [N HN]; [omega|].
destruct (IZN(up (exp (INR N)))) as [N1 HN1].
  apply le_IZR; simpl.
  apply Rle_trans with (exp (INR N)).
    left; apply exp_pos.
  left; eapply (proj1 (archimed _)).
exists N1.
intros n Hn.
apply Rle_lt_trans with (Rabs m).
  apply RRle_abs.
apply Rlt_le_trans with (INR N).
  replace (INR N) with (INR N ^ 1) by field.
  apply (HN _ (le_refl _)).
rewrite <- ln_exp with (INR N).
left; apply ln_increasing.
  apply exp_pos.
apply Rlt_le_trans with (IZR (Z_of_nat N1)).
  rewrite <- HN1.
  apply (proj1(archimed _)).
rewrite <- INR_IZR_INZ; apply le_INR; apply Hn.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Monoid_kernel.
Require Export Free_monoid.
Section Generated_monoid_def.
Variable M : MONOID.
Variable A : part_set M.

Definition generated_monoid : submonoid M :=
  image_monoid_hom (FM_lift (inj_part A)).
End Generated_monoid_def.

Lemma generated_monoid_minimal :
 forall (M : MONOID) (A : part_set M) (H : submonoid M),
 included A H -> included (generated_monoid A) H.
unfold included in |- *.
simpl in |- *.
intros M A H H' x H'0; try assumption.
elim H'0; intros x0; clear H'0.
generalize x; clear x.
elim x0.
intros c; try assumption.
elim c.
simpl in |- *.
intros y subtype_prf x H'0; elim H'0; intros H'1 H'2; try exact H'2;
 clear H'0.
apply in_part_comp_l with y; auto with algebra.
intros f H'0 f0 H'1 x H'2; elim H'2; intros H'3 H'4; try exact H'4; clear H'2.
simpl in H'4.
apply
 in_part_comp_l
  with
    (sgroup_law M (FM_lift_fun (inj_part A) f) (FM_lift_fun (inj_part A) f0));
 auto with algebra.
simpl in |- *.
intros x H'0; elim H'0; intros H'1 H'2; try exact H'2; clear H'0.
apply in_part_comp_l with (monoid_unit M); auto with algebra.
Qed.

Lemma generated_monoid_prop_included :
 forall (M : MONOID) (A : part_set M), included A (generated_monoid A).
unfold included in |- *.
simpl in |- *.
intros M A x H'; try assumption.
exists (Var (V:=A) (Build_subtype (E:=M) (P:=A) (subtype_elt:=x) H')); split;
 [ idtac | try assumption ].
auto with algebra.
simpl in |- *.
auto with algebra.
Qed.

Lemma generated_monoid_prop :
 forall (M : MONOID) (A : part_set M) (y : M),
 in_part y (generated_monoid A) ->
 exists x : FM A, Equal y (FM_lift (inj_part A) x).
simpl in |- *; auto with algebra.
intros M A y H'; try assumption.
elim H'; intros x E; elim E; intros H'0 H'1; try exact H'1; clear E H'.
exists x; try assumption.
Qed.

Lemma generated_monoid_prop_rev :
 forall (M : MONOID) (A : part_set M) (y : M),
 (exists x : FM A, Equal y (FM_lift (inj_part A) x)) ->
 in_part y (generated_monoid A).
intros M A y H'; try assumption.
elim H'; intros x E; try exact E; clear H'.
simpl in |- *; auto with algebra.
exists x; split; [ idtac | try assumption ].
auto with algebra.
Qed.
Hint Resolve generated_monoid_minimal generated_monoid_prop_included
  generated_monoid_prop_rev: algebra.


Module NatList.
Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Require Import FunInd FMapInterface.
From Coq Require Import Ascii.
Import ListNotations.
Require Import Le Gt Minus Min Bool.
Require Import Setoid.
Require Import String.
Open Scope string_scope.
Scheme Equality for string.

Set Implicit Arguments.

Definition Variabila := string -> nat. (* Pt expresii aritmetice*)
Definition Strings := string -> string. (* Pt strings *)
Inductive listNat : Type :=
| nil
| cons ( n : nat ) ( l : listNat) .

Definition Stiva := string -> listNat. (* Pt stive *)
Inductive Configuration :=
| conf: Variabila -> Strings -> Stiva -> Configuration.

Inductive aexp :=
| avar : string -> aexp
| anum : nat -> aexp
| aplus : aexp -> aexp -> aexp
| aminus : aexp -> aexp -> aexp
| adivision : aexp -> aexp -> aexp
| amodulo : aexp -> aexp -> aexp
| amul : aexp -> aexp -> aexp.

Coercion anum : nat >-> aexp.
Coercion avar : string >-> aexp.

Inductive bexp :=
| btrue : bexp
| bfalse : bexp
| blessthan : aexp -> aexp -> bexp
| bequal : aexp -> aexp -> bexp
| bnot : bexp -> bexp
| band : bexp -> bexp -> bexp.

Inductive strexp1 :=
| atoi : string -> strexp1.

Inductive strexp2 :=
| itoa : nat -> strexp2.

Inductive stexp :=
| sstack : listNat -> stexp
| stack : string -> stexp
| push : stexp -> nat -> stexp
| push_var : stexp -> string -> stexp
| pop : stexp -> stexp
| stempty : stexp -> stexp.
Inductive stexp2 :=
| top_string : string -> stexp2
| top_list : listNat -> stexp2.

Notation "A +' B" := (aplus A B) (at level 48).
Notation "A -' B" := (aminus A B) (at level 48).
Notation "A //' B" := (adivision A B) (at level 46).
Notation "A %' B" := (amodulo A B) (at level 46).
Notation "A *' B" := (amul A B) (at level 46).

Notation "'~' A" := (bnot A) (at level 75, right associativity).
Notation "A <=' B" := (blessthan A B) (at level 53).
Notation "A ==' B" := (bequal A B) (at level 70, no associativity).
Notation "A >=' B" := (blessthan B A) (at level 53).
Infix "and'" := band (at level 80).

Notation "[ ]" := nil (format "[ ]") : list_scope.
Notation "[ x ]" := (cons x nil) : list_scope.
Infix "::" := cons (at level 60, right associativity) : list_scope.
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope.

Notation "'push'( stack , x )" := ( push stack x ) (at level 60).
Notation "'top_var'( stack )" := ( top_string stack ) (at level 60).
Notation "'top_l'( stack )" := ( top_list stack ) (at level 60).
Notation "'pop'( stack )" := ( pop stack ) (at level 60).
Notation "'empty_stack'( stack )" := ( stempty stack ) (at level 60).

Compute 10 +' 11.
Compute 15 +' "a".
Compute "b" +' 3.
Compute "a" +' "b".

Compute 10 -' 11.
Compute 15 -' "a".
Compute "b" -' 3.
Compute ("a") -' ("b").

Compute 10 *' 11.
Compute 15 *' "a".
Compute "b" *' 3.
Compute ("a") *' ("b").

Compute 10 //' 11.
Compute 15 //' "a".
Compute "b" //' 3.
Compute ("a") //' ("b").

Compute 10 %' 11.
Compute 15 %' "a".
Compute "b" %' 3.
Compute ("a") %' ("b").

Compute (atoi "13").
Compute (itoa 12).

Compute [ 10 ; 15 ; 16 ; 5].
Compute push (sstack ([10 ; 15 ; 16 ; 5]))  (10).
Compute push_var (sstack ([10 ; 15 ; 16 ; 5]))  "x".
Compute top_list ([10 ; 15 ; 16 ; 5]).
Compute top_string ("a").
Compute pop (sstack ([10 ; 15 ; 16 ; 5])).
Compute stempty (sstack ([10 ; 15 ; 16 ; 5])).

(* stmt *)
Inductive Stmt :=
| assignment_string : string -> string -> Stmt
| assignment_stiva : string -> listNat -> Stmt
| assignment : string -> aexp -> Stmt
| string_atoi: string -> string -> Stmt
| string_itoa: string -> nat -> Stmt
| stack_top: string -> string -> Stmt
| stack_pop: string -> stexp -> Stmt
| stack_push: string -> stexp -> nat -> Stmt
| stack_push_var: string -> stexp -> string -> Stmt
| stack_sempty: string -> stexp -> Stmt
| sequence : Stmt -> Stmt -> Stmt
| while : bexp -> Stmt -> Stmt
| iff : bexp -> Stmt -> Stmt -> Stmt
| iffsimpl : bexp -> Stmt -> Stmt.

Notation "'stackk' var :=: variabile" :=(assignment_stiva var variabile) (at level 40).
Notation "'str' var <<->> ass" :=(assignment_string var ass) (at level 40).
Notation "X ::= A" := (assignment X A) (at level 50).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 90).
Notation "'ifs' cond 'den' { stmt }" := (iffsimpl cond stmt) (at level 93).
Notation "'ifd' cond 'denn' { stmt1 } 'els' { stmt2 }" := (iff cond stmt1 stmt2) (at level 93).
Notation "'While' ( B ) { S }" := (while B S) (at level 97).
Notation "'phor' ( s1 ~ cond ~ s2 ) { stmt }" := (s1 ;; While ( cond ) { stmt ;; s2 }  ) (at level 97).
Notation "'do' { stmt } 'whilee' ( cond )" := ( stmt ;; while ( cond ) ( stmt ) ) (at level 97).

Example ex1 :=
stackk "a" :=: [ 1 ; 2 ; 3] ;;
"c" ::= 10 ;;
str "b" <<->> "ana" ;;
string_atoi "c" "123" ;;
string_itoa "d" 123 ;;
stack_top "c" "a" ;;
stack_pop "a" (stack "a") ;;
stack_push "a" (stack "a") 12 ;;
stack_push_var "a" (stack "a") "c" ;;
stack_sempty "a" (stack "a") ;;
(ifs (2 <=' "c")
  den
    { "s" ::= 11 ;;
      "s" ::= "s" +' 1
    }) ;;
(ifd (2 <=' "c")
  denn
    { "s" ::= 11 ;;
      "s" ::= "s" +' 1
    } els
        { stack_pop "a" (stack "a") ;;
          "s" ::= 45
        }) ;;
(While ( "c" <=' 11 )
    { "c" ::= "c" +' 1 }) ;;
(phor ( ("i" ::= 1) ~ ("i" <=' 3) ~ ("i" ::= "i" +' 1) )
      { "c" ::= "c" *' 2 }) ;;
do {
     ("c" ::= "c" *' 2)
    } whilee ( "c" <=' 30 )
.

Example ex2 :=
stackk "s" :=: [ 1 ; 2 ; 3 ; 4 ; 5] ;;
"a" ::= 6 ;;
stack_top "c" "a" .
Compute ex1.
Compute ex2.

(* SEMANTICA *)

(* Variabile *)
Definition e_var : Variabila :=  (* Pt expresii aritmetice*)
  fun x =>
    if (string_eq_dec x "fix")
    then 10
    else 0.
Check e_var.

Definition update_var (c : Configuration) (x : string) (v : nat) : Variabila :=
match c with
| conf vvar vstring vstiva =>   fun y =>
                                    if (string_eq_dec y x)
                                    then v
                                    else (vvar y)
end.
Notation "S [ V /' X ]" := (update_var S X V) (at level 0).

(* Strings *)
Definition e_string : Strings :=  (* Pt strings *)
  fun x =>
    if (string_eq_dec x "fix3")
    then ""
    else "".
Check e_string.
Definition update_string (c : Configuration) (x : string) (v : string ) : Strings :=
match c with
| conf svar sstring sstiva =>   fun y =>
                                    if (string_eq_dec y x)
                                    then v
                                    else (sstring y)
end.

(* Stiva *)
Definition e_stiva : Stiva :=  (* Pt stive *)
  fun x =>
    if (string_eq_dec x "fix2")
    then [ ]
    else [ ].
Check e_stiva.
Notation "S [[[ V /' X ]]]" := (update_string S X V) (at level 0).

Definition update_stiva (c : Configuration) (x : string) (v : listNat ) : Stiva :=
match c with
| conf svar sstring sstiva =>   fun y =>
                                    if (string_eq_dec y x)
                                    then v
                                    else (sstiva y)
end.

Notation "S [[ V /' X ]]" := (update_stiva S X V) (at level 0).

Definition config1 : Configuration :=  conf e_var e_string e_stiva.

(* Variabile *)

Fixpoint divmod x y q u :=
  match x with
    | 0 => (q,u)
    | S x' => match u with
                | 0 => divmod x' y (S q) y
                | S u' => divmod x' y q u'
              end
  end.
Definition div x y :=
  match y with
    | 0 => y
    | S y' => fst (divmod x y' 0 y')
  end.

Definition nmodulo x y :=
  match y with
    | 0 => y
    | S y' => y' - snd (divmod x y' 0 y')
  end.

Infix "/" := div : nat_scope.
Infix "mod" := nmodulo (at level 40, no associativity) : nat_scope.

Fixpoint aeval_fun (a : aexp) (c :Configuration) : nat :=
match c with
| conf vvar vstring vstiva =>
                              match a with
                                | avar k => vvar k
                                | anum v => v
                                | aplus a1 a2 => (aeval_fun a1 c) + (aeval_fun a2 c)
                                | aminus a1 a2 => (aeval_fun a1 c) - (aeval_fun a2 c)
                                | adivision a1 a2 => (aeval_fun a1 c) / (aeval_fun a2 c)
                                | amodulo a1 a2 => (aeval_fun a1 c) mod (aeval_fun a2 c)
                                | amul a1 a2 => (aeval_fun a1 c) * (aeval_fun a2 c)
                                end
end.

Compute aeval_fun (10 +' 11) config1.
Compute aeval_fun (15 +' "a") config1.
Compute aeval_fun ("b" +' 3) config1.
Compute aeval_fun  ("a" +' "b") config1.

Compute aeval_fun (11 -' 10) config1.
Compute aeval_fun (15 -' "a") config1.
Compute aeval_fun ("b" -' 3) config1.
Compute aeval_fun (("a") -' ("b")) config1.

Compute aeval_fun (10 *' 11) config1.
Compute aeval_fun (15 *' "a") config1.
Compute aeval_fun ("b" *' 3) config1.
Compute aeval_fun (("a") *' ("b")) config1.

Compute aeval_fun (10 //' 3) config1.
Compute aeval_fun (15 //' "a") config1.
Compute aeval_fun ("b" //' 3) config1.
Compute aeval_fun (("a") //' ("b")) config1.

Compute aeval_fun (10 %' 4) config1.
Compute aeval_fun (15 %' "a") config1.
Compute aeval_fun ("b" %' 3) config1.
Compute aeval_fun (("a") %' ("b")) config1.

Compute aeval_fun ((((300 +' 23 -'76 +' (2 *' 10))) //' 2) %' 4) config1.

Fixpoint beval_fun (b : bexp) (c : Configuration) : bool :=
match c with
| conf bvar bstring bstiva =>
                            match b with
                            | btrue => true
                            | bfalse => false
                            | blessthan a1 a2 => Nat.leb (aeval_fun a1 c) (aeval_fun a2 c)
                            | bequal a1 a2 => Nat.eqb (aeval_fun a1 c) (aeval_fun a2 c)
                            | bnot b' => negb (beval_fun b' c)
                            | band b1 b2 => match (beval_fun b1 c), (beval_fun b2 c) with
                                            | true, true => false
                                            | true, false => true
                                            | false, true => true
                                            | false, false => false
                                            end
  end
end.

(* Strings *)
(*itoa*)
Fixpoint nat_to_string_aux (time n : nat) (acc : string) : string :=
  let d := match n mod 10 with
           | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4" | 5 => "5"
           | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9"
           end in
  let acc' := d ++ acc in (*append*)
  match time with
    | 0 => acc'
    | S time' =>
      match n / 10 with
        | 0 => acc'
        | n' => nat_to_string_aux time' n' acc'
      end
  end.

Definition nat_to_string (n : nat) : string :=
  nat_to_string_aux n n "".

Definition streval_fun2 ( s : strexp2 ) (c : Configuration) : string :=
match c with
| conf svar sstring sstiva =>
                              match s with
                              | itoa n => nat_to_string n
                              end
end.

(* atoi *)

Definition is_nat (x : ascii) : nat :=
  match x with
  | "0" => 0
  | "1" => 1
  | "2" => 2
  | "3" => 3
  | "4" => 4
  | "5" => 5
  | "6" => 6
  | "7" => 7
  | "8" => 8
  | "9" => 9
  | _ =>   0
  end%char.

Fixpoint reverse_string ( s: string ) : string :=
match s with
| EmptyString => EmptyString
| String ch rest => (reverse_string rest) ++ (String ch EmptyString)
end.

Fixpoint string_to_nat_aux ( s : string ) : nat :=
match s with
  | EmptyString => 0
  | String ch rest =>
    match ( is_nat ch ), (string_to_nat_aux rest) with
      | x, y => x +  y * 10
    end
end.

Definition string_to_nat ( s: string ) : nat :=
match string_to_nat_aux(reverse_string s) with
  | n => n
end.

Definition streval_fun1 ( s : strexp1 ) (c : Configuration) : nat :=
match c with
| conf svar sstring sstiva =>
                              match s with
                              | atoi n => string_to_nat n
                              end
end.

Compute streval_fun1 (atoi "12") config1.
Compute streval_fun2 (itoa 652) config1.

(* Stiva *)

Fixpoint pop_stack ( l: listNat) : listNat :=
match l with
| nil => nil
| [ a ] => []
| a :: l => a :: pop_stack l
end.

Fixpoint push_stack ( l: listNat) ( x : nat ) : listNat :=
match l with
| nil => [x]
| a :: l => a :: push_stack l x
end.

Fixpoint top_stack (l:listNat ) (d:nat) {struct l} : nat :=
match l with
| nil => d
| a :: nil => a
| a :: l => top_stack l d
end.

Definition sempty_stack ( l: listNat) : listNat :=
match l with
| [] => []
| a :: l => []
end.

Compute pop_stack ([10 ; 15 ; 16 ; 5]).
Compute push_stack ([10 ; 15 ; 16 ; 5]) (10).
Compute top_stack ([10 ; 15 ; 16 ; 5]).
Compute sempty_stack ([10 ; 15 ; 16 ; 5]).

Fixpoint seval_fun ( s : stexp ) (c : Configuration) : listNat :=
match c with
| conf svar sstring sstiva =>
                            match s with
                            | sstack x => x
                            | stack y => sstiva y
                            | push a b => push_stack (seval_fun a c) b
                            | push_var a b => push_stack (seval_fun a c) (svar b)
                            | pop a => pop_stack (seval_fun a c)
                            | stempty a => sempty_stack (seval_fun a c)
                            end
end.

Definition seval_fun2 ( s : stexp2 ) (c : Configuration) : nat :=
match c with
| conf svar sstring sstiva =>
                            match s with
                            | top_string x => top_stack (sstiva x) 1
                            | top_list x => top_stack x 1
                            end
end.
Check seval_fun2.

Compute seval_fun (push (sstack ([10 ; 15 ; 16 ; 5]))  (10)) config1.
Compute seval_fun2 (top_list ([10 ; 15 ; 16 ; 5])) config1.
Compute seval_fun2 (top_string ("a")) config1.
Compute seval_fun (pop (sstack ([10 ; 15 ; 16 ; 5]))) config1.
Compute seval_fun (stempty (sstack ([10 ; 15 ; 16 ; 5]))) config1.

(* Stmt *)

(*Reserved Notation "S -{ Sigma }-> Sigma'" (at level 60).*)

Fixpoint eval (s : Stmt) ( c : Configuration) (gas : nat) : Configuration :=
  match gas with
  | 0 => c
  | S gas' => match c with
              | conf env3 env2 env =>
                       match s with
                      | assignment_string s1 s2 => conf env3 (update_string c s1 s2) env
                      | assignment_stiva s1 s2 => conf env3 env2 (update_stiva c s1 s2)
                      | assignment s1 s2 => conf (update_var c s1 (aeval_fun s2 c)) env2 env
                      | string_atoi vari stri => conf (update_var c vari (streval_fun1 (atoi stri) c)) env2 env
                      | string_itoa stri vari => conf env3 (update_string c stri (streval_fun2 (itoa vari)c)) env
                      | stack_top slist stri => conf (update_var c stri (seval_fun2 (top_string slist)c)) env2 env
                      | stack_pop s1 s2 => conf env3 env2 (update_stiva c s1 (seval_fun (pop s2)c))
                      | stack_push s1 s2 nat => conf env3 env2 (update_stiva c s1 (seval_fun (push s2 nat)c))
                      | stack_push_var s1 s2 var => conf env3 env2 (update_stiva c s1 (seval_fun (push_var s2 var)c))
                      | stack_sempty s1 s2 => conf env3 env2 (update_stiva c s1 (seval_fun (stempty s2)c))
                      | sequence S1 S2 => eval S2 (eval S1 c gas') gas'
                      | while cond s' => if (beval_fun cond c)
                                         then eval (s' ;; (while cond s')) c gas'
                                         else c
                      | iff cond s1 s2 => if (beval_fun cond c)
                                          then eval s1 c gas'
                                          else eval s2 c gas'
                      | iffsimpl cond s1 => if (beval_fun cond c)
                                            then eval s1 c gas'
                                            else c
                      end
        end
end.
Definition get_nat (c : Configuration) ( s: string ) : nat :=
match c with
| conf env3 env2 env => (env3 s)
end.

Definition get_string (c : Configuration) ( s: string ) : string :=
match c with
| conf env3 env2 env => (env2 s)
end.

Definition get_stack (c : Configuration) ( s: string ) : listNat :=
match c with
| conf env3 env2 env => (env s)
end.

Definition config2 : Configuration := eval ("x" ::= 123 +' 34 //' 10 ;; str "b" <<->> "ana" ;; stackk "a" :=: [ 1 ; 2 ; 3] ) config1 300.

Compute get_string config2 "b".
Compute get_nat config2 "x".
Compute get_stack config2 "a".

Definition config3 : Configuration := eval ex1 config1 300.
Compute get_string config3 "b".
Compute get_nat config3 "c".
Compute get_nat config3 "s".
Compute get_nat config3 "i".
Compute get_stack config3 "a".

Example p_ex2 :=
stackk "s" :=: [ 1 ; 2 ; 3 ; 4 ; 5] ;;
"a" ::= 6 ;;
stack_top "s" "a" .

Definition config4 : Configuration := eval p_ex2 config1 300.
Compute get_nat config4 "a".
Compute get_stack config4 "s".

Example p_ex3 :=
stackk "s" :=: [ 1 ; 2 ; 3 ; 4 ; 5] ;;
"a" ::= 6 ;;
stack_top "s" "a" ;;
stack_pop "s" (stack "s") .

Definition config5 : Configuration := eval p_ex3 config1 300.
Compute get_stack config5 "s".

Example p_ex4 :=
stackk "s" :=: [ 1 ; 2 ; 3 ; 4 ; 5] ;;
"a" ::= 6 ;;
stack_top "s" "a" ;;
stack_pop "s" (stack "s") ;;
stack_push "s" (stack "s") 12 .

Definition config6 : Configuration := eval p_ex4 config1 300.
Compute get_stack config6 "s".

Example p_ex5 :=
string_atoi "c" "123" ;;
string_itoa "d" 35.

Definition config7 : Configuration := eval p_ex5 config1 300.
Compute get_nat config7 "c".
Compute get_string config7 "d".

Example p_ex6 :=
stackk "s" :=: [ 34 ; 2 ; 11 ; 23 ; 129] ;;
"i" ::= 10 ;;
While ( "i" <=' 12 )
    { stack_pop "s" (stack "s") ;;
     "i" ::= ("i" +' 1) }
.

Definition config8 : Configuration := eval p_ex6 config1 300.
Compute get_nat config8 "i".
Compute get_stack config8 "s".

Example p_ex7 :=
stackk "s" :=: [ 34 ; 2 ; 11 ; 23 ; 129] ;;
"i" ::= 10 ;;
do { stack_pop "s" (stack "s") ;;
     "i" ::= ("i" +' 1) }
whilee ( "i" <=' 11 )
.

Definition config9 : Configuration := eval p_ex7 config1 300.
Compute get_nat config9 "i".
Compute get_stack config9 "s".

Example p_ex8 :=
stackk "s" :=: [ 34 ; 2 ; 11 ; 23 ; 129] ;;
stackk "x" :=: [ ] ;;
"nr" ::= 111 ;;
phor ( ("i" ::= 1) ~ ("i" <=' 3) ~ ("i" ::= "i" +' 1) )
      { stack_pop "s" (stack "s") ;;
        stack_push_var "x" (stack "x") "nr" ;;
        "nr" ::= "nr" +' 20
       }
.

Definition config10 : Configuration := eval p_ex8 config1 300.
Compute get_nat config10 "i".
Compute get_stack config10 "s".
Compute get_stack config10 "x".


Require Export ZArith Int.
Open Scope Int_scope.

Definition int := Z.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import algebra.rat.
From mathcomp Require Import ssrint seq.

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

(* każdy skończony ciąg liczb wymiernych da się zakodować liczbą naturalną *)
Definition hipoteza :=
  exists f : nat -> seq rat, forall qs : seq rat, exists n, f n = qs.

(* Najpierw potrzeba funkcji parującej.
   Ta jest prosta, ale nie jest bijekcją.
   Za Stefan G. Simpson - "Subsystems of Second Order Arithmetic" (II.2)
 *)
Definition zgniec (para: nat*nat) : nat := let (i, j) := para in ((i+j)^2)+i.
Check Nat.sqrt.
Definition odgniec (k: nat): (nat*nat) :=
  let m := Nat.sqrt k in
  let i := k - (m^2) in
  (i,m-i).

(* Jeśli będę chciał potem poszpanować, to zmienię powyższą funkcję parującą na bijekcję *)
(*
0 1 3 6 A F
2 4 7 B 10
5 8 C 11
9 D 12
E

m-ty wiersz n-ta kolmna
 *)
Definition zgniec' (para: nat*nat) : nat :=
  let (m, n) := para in (((m+n)*(m+n+1)) %/ 2)+m.

Definition odgniec' (n : nat) : nat * nat :=
  let fix f (a nr_przek na_przek : nat) : nat * nat :=
    match a with
    | O => (nr_przek, na_przek)
    | n.+1 => if nr_przek == na_przek then f n nr_przek.+1 0 else f n nr_przek na_przek.+1
    end
  in let (nr_przek, na_przek) := f n 0 0
     in (na_przek, nr_przek - na_przek).
(* No ale podmiankę zachowam se na koniec *)

Lemma roznica_miedzy_kwadratami n : n.+1^2 = n^2 + 2*n +1.
Proof.
  rewrite -addn1 sqrnD -![n^2 + _ + _]addnA [1 ^2 + 2*_]addnC -[1^2]/1 muln1 //.
Qed.

(* Lemat pomocniczy do zgniec_odgniec;
 w pewnym sensie, to słabsza wersja różnicy między kwadratami *)
Lemma sqrt_ij i j : Nat.sqrt ((i + j) ^ 2 + i) = (i+j).
Proof.
  apply: PeanoNat.Nat.sqrt_unique.
  rewrite -[(_ * _)%coq_nat]/((i+j) * (i+j)) -[(_ * _)%coq_nat]/((i+j).+1 * (i+j).+1) !mulnn.
  split; [by apply /leP; apply: leq_addr| apply /ltP].
  rewrite roznica_miedzy_kwadratami  -(@addnA ((i+j)^2) (2*(i+j)) 1) ltn_add2l.
  rewrite mul2n -addnn -[i in X in X < _]addn0 -[_ + _ + 1 ]addnA -[i+  j + _ ]addnA.
  rewrite ltn_add2l addnA addn1.
  apply: ltn0Sn.
Qed.

Lemma a_plus_b_minus_a a b : a + b - a = b.
Proof.
  by rewrite -[a in X in _+_-X=_]addn0 subnDl subn0.
Qed.

(* Podstawowy lemat mówiący, że 2 liczby naturalne można zakodować za pomocą jednej
   cała reszta dowodu bazuje na zgniataniu i odgniataniu par liczb naturalnych *)
Lemma zgniec_odgniec k : odgniec (zgniec k) = k.
Proof.
  case: k => i j.
  by rewrite /zgniec /odgniec !sqrt_ij pair_equal_spec !a_plus_b_minus_a.
Qed.

(* Liczby całkowite można zakodować parą liczb natualnych
 możliwych kodowań jest dużo, to tutaj nie jest eleganckie,
 ale łatwo się dowodzi jego odwracalność*)
Definition int_do_nat(z : int) : nat :=
  match z with
  | ssrint.Posz n => zgniec (n, 0)
  | ssrint.Negz n => zgniec (n, 1)
  end.

Definition nat_do_int(n : nat) :=
  let (a, b) := odgniec n in
  if b == 0 then Posz a else Negz a.

Lemma zgniec_odgniec_int z : nat_do_int (int_do_nat z) = z.
Proof.
  by case : z => n; rewrite /nat_do_int /int_do_nat  zgniec_odgniec.
Qed.

(* Liczby wymierne można zakodować parą liczb całkowitych *)
Definition rat_do_nat (r : rat) : nat :=
  let (a, b) := rat.valq r in zgniec(int_do_nat a, int_do_nat b).

(* udziwnienia przy definicji a' i b' mają na celu
   ułatwienie spełnienia wymagań konstruktora Rat *)
Definition nat_do_rat (n : nat): rat .
  pose (ab := odgniec n).
  pose (a := nat_do_int ab.1).
  pose (b := nat_do_int ab.2).
  Open Scope order_scope.
  pose (b' := (if (Posz 0) < b then b else (Posz 1))).
  Close Scope order_scope.
  pose (a' := if (coprime `|a| `|b'|) then a else (Posz 1)).
  refine (@Rat (a', b') _ ).
  apply /andP; split;
    [by rewrite /b'; case: ifP | rewrite  /a'; case: ifP => //= _; apply: coprime1n].
Defined.

Lemma zgniec_odgniec_rat r : nat_do_rat (rat_do_nat r) = r.
Proof.
  apply /eqP; case : r => [[a b]] H.
  rewrite -[_ == _]/(valq _ == valq _) -[valq (Rat H)]/(a,b) /rat_do_nat -[valq (Rat H)]/(a,b).
  (* H nie znajduje się teraz w celu, będzie potrzebne dopiero na końcu  *)
  rewrite /nat_do_rat; apply /eqP.
  rewrite [(a,b) in RHS]surjective_pairing pair_equal_spec !zgniec_odgniec !zgniec_odgniec_int.
  move: H => /andP [zero_ltn_b wzgl_pierwsze]. (* teraz H jest potrzebne *)
  split; [by case: ifP => //; rewrite zero_ltn_b wzgl_pierwsze | by rewrite zero_ltn_b].
Qed.

(* Kodowanie ciągu liczb wymiernych o długości n:
 (n, (a1, a2, a3, a4, ..., a_n, 0),
 gdzie a_n to zakodowany n-ty wyrac ciągu.
 Liczba na końcu to wartownik, mogło by go nie być, ale tak było mi łatwiej *)
Definition seq_do_nat (sq : seq rat) : nat :=
  zgniec ((length sq), foldr (fun r z => zgniec ((rat_do_nat r), z)) 0 sq).

(* Funkcja pomocnicza do odkodowywania.
   Jeśli ciąg jest zakodowany jako (n, (a1, a2, a3,....)),
   to pierwszy argument funkcji to n, a drugi to (a1, a2 ...) *)
Fixpoint odgniec_seq' dlugosc wartosci :=
  match dlugosc with
  | 0 => [::]
  | n.+1 => let (a_i, reszta) := odgniec wartosci in (nat_do_rat a_i) :: (odgniec_seq' n reszta)
  end.

Definition nat_do_seq (n : nat): seq rat :=
  let (dlugosc, wartosci) := odgniec n in odgniec_seq' dlugosc wartosci.

(* pomocnicze lematy do wykonywania pojedyńczego kroku obliczeń *)
Lemma fold1krok {A B : Type} (f : A -> B -> B) z q qs : foldr f z (q::qs) = f q (foldr f z qs).
Proof. done. Qed.

Lemma fold0 {A B : Type} (f : A -> B -> B) z: foldr  f z  [::] = z.
Proof. done. Qed.

Lemma odgniec1krok dlugosc wartosci :
  odgniec_seq' dlugosc.+1 wartosci =
    let (a_i, reszta) := odgniec wartosci in (nat_do_rat a_i) :: (odgniec_seq' dlugosc reszta).
Proof. done. Qed.

(* Dodatkowo, przy poprawnym rozkodowywaniu wartosci=0, ale to nie istotne *)
Lemma odgniec0 wartosci : odgniec_seq' 0 wartosci = [::].
Proof. done. Qed.

Lemma seq_do_nat1krok q sq :
  seq_do_nat (q :: sq) =
    zgniec (length (q ::sq), zgniec (rat_do_nat q, foldr (fun r z => zgniec ((rat_do_nat r), z)) 0 sq)).
Proof. done. Qed.

(* Koniec nudnych lematów, teraz zasadnicze mięsko *)
Lemma nat_do_seq_glowa q qs :
  nat_do_seq (seq_do_nat (q :: qs)) = q :: (nat_do_seq (seq_do_nat qs)).
Proof.
  rewrite seq_do_nat1krok {1}/nat_do_seq zgniec_odgniec.
  rewrite odgniec1krok. (* czemu "length" się otwiera? nie powinno *)
  rewrite zgniec_odgniec zgniec_odgniec_rat.
  apply (f_equal (fun qs => q :: qs)).
  by rewrite /seq_do_nat /nat_do_seq zgniec_odgniec.
Qed.

Lemma zgniec_odgniec_seq qs : nat_do_seq (seq_do_nat qs) = qs.
Proof.
  elim : qs => // q qs H.
  rewrite -[in RHS]H.
  apply: nat_do_seq_glowa.
Qed.

Lemma twierdzenie: hipoteza.
Proof.
  exists nat_do_seq => qs.
  exists (seq_do_nat qs).
  apply: zgniec_odgniec_seq.
Qed.

(* Teraz udowodnić, że istnieje bijekcja N <-> [Q],
   taką bijekcją jest zgniec' i odgniec' *)


Require Import Coq.Strings.String.

Require Export SystemFR.AssocList.
Require Export SystemFR.Tactics.

Require Export SystemFR.Trees.
Require Export SystemFR.Syntax.
Require Export SystemFR.ListUtils.

Require Import PeanoNat.

Open Scope list_scope.

Fixpoint equivalent_pairs_with_relation { T } rel (l1 l2: map nat T) equiv :=
  match l1, l2 with
  | nil, nil => True
  | (x,a) :: l1', (y,b) :: l2' =>
    lookup PeanoNat.Nat.eq_dec rel x = Some y /\
    lookup PeanoNat.Nat.eq_dec (swap rel) y = Some x /\
    equiv a b /\
    equivalent_pairs_with_relation rel l1' l2' equiv
  | _, _ => False
  end.


(**
Here we define the signature for the coherent 2-groups.
A coherent 2-group has a unit, a multiplication, and an inverse operation.
The inverse laws are witnessed up to adjoint equivalence while associativity and unitality are witnessed as in a monoidal category.

For more details, see:
- https://ncatlab.org/nlab/show/2-group#definition
- Definition 7 in https://arxiv.org/pdf/math/0307200.pdf
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.displayed_algebra.

Local Open Scope cat.

(** The signature *)
Definition coh_2gr_point_constr
  : poly_code
  := C unit_one_type + I + I * I.

Inductive coh_2gr_paths : UU :=
| lunit : coh_2gr_paths
| runit : coh_2gr_paths
| linv : coh_2gr_paths
| rinv : coh_2gr_paths
| massoc : coh_2gr_paths.

Inductive coh_2gr_homots : UU :=
| inv_adj_triangle_l : coh_2gr_homots
| inv_adj_triangle_r : coh_2gr_homots
| triangle : coh_2gr_homots
| pentagon : coh_2gr_homots.

Definition coh_2gr_paths_args
  : coh_2gr_paths → poly_code.
Proof.
  intro i.
  induction i.
  - (* lunit *)
    exact I.
  - (* runit *)
    exact I.
  - (* linv *)
    exact I.
  - (* rinv *)
    exact I.
  - (* massoc *)
    exact (I * I * I).
Defined.

Definition unit_endpoint
           (P : poly_code)
  : endpoint coh_2gr_point_constr P I
  := comp
       (comp
          (comp
             (c P (tt : unit_one_type))
             (ι₁ _ _))
          (ι₁ _ _))
       constr.

Definition inv_endpoint
           {P : poly_code}
           (e : endpoint coh_2gr_point_constr P I)
  : endpoint coh_2gr_point_constr P I
  := comp
       (comp
          (comp
             e
             (ι₂ _ _))
          (ι₁ _ _))
       constr.

Definition mult_endpoint
           {P : poly_code}
           (e₁ e₂ : endpoint coh_2gr_point_constr P I)
  : endpoint coh_2gr_point_constr P I
  := comp
       (comp
          (pair e₁ e₂)
          (ι₂ _ _))
       constr.

Definition coh_2gr_paths_lhs
           (i : coh_2gr_paths)
  : endpoint coh_2gr_point_constr (coh_2gr_paths_args i) I.
Proof.
  induction i.
  - (* lunit *)
    exact (mult_endpoint
             (unit_endpoint _)
             (id_e _ _)).
  - (* runit *)
    exact (mult_endpoint
             (id_e _ _)
             (unit_endpoint _)).
  - (* linv *)
    exact (mult_endpoint
             (inv_endpoint (id_e _ _))
             (id_e _ _)).
  - (* rinv *)
    exact (unit_endpoint _).
  - (* massoc *)
    exact (mult_endpoint
             (comp (π₁ _ _) (π₁ _ _))
             (mult_endpoint
                (comp (π₁ _ _) (π₂ _ _))
                (π₂ _ _))).
Defined.

Definition coh_2gr_paths_rhs
           (i : coh_2gr_paths)
  : endpoint coh_2gr_point_constr (coh_2gr_paths_args i) I.
Proof.
  induction i.
  - (* lunit *)
    exact (id_e _ _).
  - (* runit *)
    exact (id_e _ _).
  - (* linv *)
    exact (unit_endpoint _).
  - (* rinv *)
    exact (mult_endpoint
             (id_e _ _)
             (inv_endpoint (id_e _ _))).
  - (* massoc *)
    exact (mult_endpoint
             (mult_endpoint
                (comp (π₁ _ _) (π₁ _ _))
                (comp (π₁ _ _) (π₂ _ _)))
             (π₂ _ _)).
Defined.

Definition coh_2gr_homots_point_arg
           (i : coh_2gr_homots)
  : poly_code.
Proof.
  induction i.
  - (* inv_adj_triangle_l *)
    exact I.
  - (* inv_adj_triangle_r *)
    exact I.
  - (* triangle *)
    exact (I * I).
  - (* pentagon *)
    exact (I * I * I * I).
Defined.

Definition coh_2gr_homots_point_left_endpoint
           (i : coh_2gr_homots)
  : endpoint coh_2gr_point_constr (coh_2gr_homots_point_arg i) I.
Proof.
  induction i.
  - (* inv_adj_triangle_l *)
    exact (mult_endpoint
             (unit_endpoint _)
             (id_e _ _)).
  - (* inv_adj_triangle_r *)
    exact(mult_endpoint
            (inv_endpoint (id_e _ _))
            (unit_endpoint _)).
  - (* triangle *)
    exact (mult_endpoint
             (π₁ _ _)
             (mult_endpoint
                (unit_endpoint _)
                (π₂ _ _))).
  - (* pentagon *)
    exact (mult_endpoint
             (comp (π₁ _ _) (comp (π₁ _ _) (π₁ _ _)))
             (mult_endpoint
                (comp (π₁ _ _) (comp (π₁ _ _) (π₂ _ _)))
                (mult_endpoint
                   (comp (π₁ _ _) (π₂ _ _))
                   (π₂ _ _)))).
Defined.

Definition coh_2gr_homots_point_right_endpoint
           (i : coh_2gr_homots)
  : endpoint coh_2gr_point_constr (coh_2gr_homots_point_arg i) I.
Proof.
  induction i.
  - (* inv_adj_triangle_l *)
    exact (mult_endpoint
             (id_e _ _)
             (unit_endpoint _)).
  - (* inv_adj_triangle_r *)
    exact(mult_endpoint
            (unit_endpoint _)
            (inv_endpoint (id_e _ _))).
  - (* triangle *)
    exact (mult_endpoint
             (π₁ _ _)
             (π₂ _ _)).
  - (* pentagon *)
    exact (mult_endpoint
             (mult_endpoint
                (mult_endpoint
                   (comp (π₁ _ _) (comp (π₁ _ _) (π₁ _ _)))
                   (comp (π₁ _ _) (comp (π₁ _ _) (π₂ _ _))))
                (comp (π₁ _ _) (π₂ _ _)))
             (π₂ _ _)).
Defined.

Definition lunit_homot_endpoint
           {P : poly_code}
           (e : endpoint coh_2gr_point_constr P I)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint (unit_endpoint P) e)
      e.
Proof.
  refine (trans_e
            _
            (comp_id_r _)).
  refine (trans_e
            _
            (path_constr
               lunit
               _)).
  simpl.
  unfold mult_endpoint.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  unfold unit_endpoint.
  refine (trans_e
            (path_pair _ _)
            (inv_e (comp_pair _ _ _))).
  - refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply path_inl.
    apply inv_e.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    apply comp_constant.
  - apply inv_e.
    apply comp_id_r.
Defined.

Definition runit_homot_endpoint
           {P : poly_code}
           (e : endpoint coh_2gr_point_constr P I)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint e (unit_endpoint _))
      e.
Proof.
  refine (trans_e
            _
            (comp_id_r _)).
  refine (trans_e
            _
            (path_constr
               runit
               _)).
  simpl.
  unfold mult_endpoint.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  unfold unit_endpoint.
  refine (trans_e
            (path_pair _ _)
            (inv_e (comp_pair _ _ _))).
  - apply inv_e.
    apply comp_id_r.
  - refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply path_inl.
    apply inv_e.
    refine (trans_e (comp_assoc _ _ _) _).
    apply ap_e.
    apply comp_constant.
Defined.

Definition linv_homot_endpoint
           {P : poly_code}
           (e : endpoint coh_2gr_point_constr P I)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint (inv_endpoint e) e)
      (unit_endpoint P).
Proof.
  refine (trans_e
            (trans_e
               _
               (path_constr linv e))
            _)
  ; cbn.
  - unfold mult_endpoint.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_pair _ _ _))).
    use path_pair.
    + unfold inv_endpoint.
      refine (trans_e
                _
                (inv_e (comp_assoc _ _ _))).
      apply ap_e.
      refine (trans_e
                _
                (inv_e (comp_assoc _ _ _))).
      apply ap_e.
      refine (trans_e
                _
                (inv_e (comp_assoc _ _ _))).
      apply ap_e.
      refine (inv_e _).
      apply comp_id_r.
    + refine (inv_e _).
      apply comp_id_r.
  - unfold unit_endpoint.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    apply comp_constant.
Defined.

Definition rinv_homot_endpoint
           {P : poly_code}
           (e : endpoint coh_2gr_point_constr P I)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (unit_endpoint P)
      (mult_endpoint e (inv_endpoint e)).
Proof.
  refine (trans_e
            (trans_e
               _
               (path_constr rinv e))
            _)
  ; cbn.
  - unfold unit_endpoint.
    cbn.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (inv_e _).
    apply comp_constant.
  - unfold mult_endpoint.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_pair _ _ _)
              _).
    use path_pair.
    + apply comp_id_r.
    + unfold inv_endpoint.
      refine (trans_e
                (comp_assoc _ _ _)
                _).
      apply ap_e.
      refine (trans_e
                (comp_assoc _ _ _)
                _).
      apply ap_e.
      refine (trans_e
                (comp_assoc _ _ _)
                _).
      apply ap_e.
      apply comp_id_r.
Defined.

Definition assoc_homot_endpoint
           {P : poly_code}
           (e₁ e₂ e₃ : endpoint coh_2gr_point_constr P I)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint
         e₁
         (mult_endpoint
            e₂
            e₃))
      (mult_endpoint
         (mult_endpoint
            e₁
            e₂)
         e₃).
Proof.
  unfold mult_endpoint.
  refine (trans_e
            _
            (trans_e
               (path_constr massoc (pair (pair e₁ e₂) e₃))
               _))
  ; simpl ; unfold mult_endpoint.
  - refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              (path_pair _ _)
              (inv_e (comp_pair _ _ _))).
    + apply inv_e.
      refine (trans_e
                (comp_assoc _ _ _)
                _).
      refine (trans_e
                (ap_e _ (pair_π₁ _ _))
                _).
      apply pair_π₁.
    + refine (trans_e
                _
                (inv_e (comp_assoc _ _ _))).
      apply ap_e.
      refine (trans_e
                _
                (inv_e (comp_assoc _ _ _))).
      apply ap_e.
      refine (trans_e
                (path_pair _ _)
                (inv_e (comp_pair _ _ _))).
      * apply inv_e.
        refine (trans_e
                  (comp_assoc _ _ _)
                  _).
        refine (trans_e
                  (ap_e _ (pair_π₁ _ _))
                  _).
        apply pair_π₂.
      * apply inv_e.
        apply pair_π₂.
  - refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_pair _ _ _)
              (path_pair _ _)).
    + refine (trans_e
                (comp_assoc _ _ _)
                _).
      apply ap_e.
      refine (trans_e
                (comp_assoc _ _ _)
                _).
      apply ap_e.
      refine (trans_e
                (comp_pair _ _ _)
                (path_pair _ _)).
      * refine (trans_e
                  (comp_assoc _ _ _)
                  _).
        refine (trans_e
                  (ap_e _ (pair_π₁ _ _))
                  _).
        apply pair_π₁.
      * refine (trans_e
                  (comp_assoc _ _ _)
                  _).
        refine (trans_e
                  (ap_e _ (pair_π₁ _ _))
                  _).
        apply pair_π₂.
    + apply pair_π₂.
Defined.

Definition lwhisker_endpoint
           {P : poly_code}
           (e₁ : endpoint coh_2gr_point_constr P I)
           {e₂ e₃ : endpoint coh_2gr_point_constr P I}
           (h : homot_endpoint
                  coh_2gr_paths_lhs
                  coh_2gr_paths_rhs
                  (c P (tt : unit_one_type))
                  (c P (tt : unit_one_type))
                  e₂
                  e₃)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint e₁ e₂)
      (mult_endpoint e₁ e₃).
Proof.
  unfold mult_endpoint.
  use ap_e.
  use ap_e.
  use path_pair.
  - apply refl_e.
  - exact h.
Defined.

Definition rwhisker_endpoint
           {P : poly_code}
           {e₁ e₂ : endpoint coh_2gr_point_constr P I}
           (e₃ : endpoint coh_2gr_point_constr P I)
           (h : homot_endpoint
                  coh_2gr_paths_lhs
                  coh_2gr_paths_rhs
                  (c P (tt : unit_one_type))
                  (c P (tt : unit_one_type))
                  e₁
                  e₂)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint e₁ e₃)
      (mult_endpoint e₂ e₃).
Proof.
  unfold mult_endpoint.
  use ap_e.
  use ap_e.
  use path_pair.
  - exact h.
  - apply refl_e.
Defined.

Definition coh_2gr_homots_point_lhs
           (i : coh_2gr_homots)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c (coh_2gr_homots_point_arg i) (tt : unit_one_type))
      (c (coh_2gr_homots_point_arg i) (tt : unit_one_type))
      (coh_2gr_homots_point_left_endpoint i)
      (coh_2gr_homots_point_right_endpoint i).
Proof.
  induction i.
  - (* inv_adj_triangle_l *)
    exact (trans_e
             (rwhisker_endpoint
                _
                (rinv_homot_endpoint (id_e _ _)))
             (trans_e
                (inv_e (assoc_homot_endpoint _ _ _))
                (lwhisker_endpoint
                   _
                   (linv_homot_endpoint (id_e _ _))))).
  - (* inv_adj_triangle_r *)
    exact (trans_e
             (lwhisker_endpoint
                _
                (rinv_homot_endpoint (id_e _ _)))
             (trans_e
                (assoc_homot_endpoint _ _ _)
                (rwhisker_endpoint
                   _
                   (linv_homot_endpoint (id_e _ _))))).
  - (* triangle *)
    exact (lwhisker_endpoint
             (π₁ I I)
             (lunit_homot_endpoint _)).
  - (* pentagon *)
    exact (trans_e
             (assoc_homot_endpoint _ _ _)
             (assoc_homot_endpoint _ _ _)).
Defined.

Definition coh_2gr_homots_point_rhs
           (i : coh_2gr_homots)
  : homot_endpoint
      coh_2gr_paths_lhs
      coh_2gr_paths_rhs
      (c (coh_2gr_homots_point_arg i) (tt : unit_one_type))
      (c (coh_2gr_homots_point_arg i) (tt : unit_one_type))
      (coh_2gr_homots_point_left_endpoint i)
      (coh_2gr_homots_point_right_endpoint i).
Proof.
  induction i.
  - (* inv_adj_triangle_l *)
    exact (trans_e
             (lunit_homot_endpoint _)
             (inv_e (runit_homot_endpoint _))).
  - (* inv_adj_triangle_r *)
    exact (trans_e
             (runit_homot_endpoint _)
             (inv_e (lunit_homot_endpoint _))).
  - (* triangle *)
    exact (trans_e
             (assoc_homot_endpoint _ _ _)
             (rwhisker_endpoint
                (π₂ I I)
                (runit_homot_endpoint _))).
  - (* pentagon *)
    exact (trans_e
             (lwhisker_endpoint
                _
                (assoc_homot_endpoint _ _ _))
             (trans_e
                (assoc_homot_endpoint _ _ _)
                (rwhisker_endpoint
                   _
                   (assoc_homot_endpoint _ _ _)))).
Defined.

Definition coh_2gr_signature
  : hit_signature.
Proof.
  simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _  ,, _ ,, _ ,, _ ,, _).
  - exact coh_2gr_point_constr.
  - exact coh_2gr_paths.
  - exact coh_2gr_paths_args.
  - exact coh_2gr_paths_lhs.
  - exact coh_2gr_paths_rhs.
  - exact coh_2gr_homots.
  - exact coh_2gr_homots_point_arg.
  - exact (λ _, C unit_one_type).
  - exact (λ _, @c _ _ unit_one_type tt).
  - exact (λ _, @c _ _ unit_one_type tt).
  - exact coh_2gr_homots_point_left_endpoint.
  - exact coh_2gr_homots_point_right_endpoint.
  - exact coh_2gr_homots_point_lhs.
  - exact coh_2gr_homots_point_rhs.
Defined.

(**
Projections.
We define projections for both path algebras and algebras.
This allowing reusing results for the builder.
 *)
Section Coherent2GroupPathAlgebraProjections.
  Variable (X : hit_path_algebra_one_types coh_2gr_signature).

  Definition coh_2gr_carrier_PA
    : one_type
    := pr11 X.

  Definition coh_2gr_unit_PA
    : coh_2gr_carrier_PA
    := pr21 X (inl (inl tt)).

  Definition coh_2gr_inv_PA
             (x : coh_2gr_carrier_PA)
    : coh_2gr_carrier_PA
    := pr21 X (inl (inr x)).

  Definition coh_2gr_mult_PA
             (x y : coh_2gr_carrier_PA)
    : coh_2gr_carrier_PA
    := pr21 X (inr (x ,, y)).

  Definition coh_2gr_lunit_PA
             (x : coh_2gr_carrier_PA)
    : coh_2gr_mult_PA coh_2gr_unit_PA x
      =
      x
    := pr2 X lunit x.

  Definition coh_2gr_runit_PA
             (x : coh_2gr_carrier_PA)
    : coh_2gr_mult_PA x coh_2gr_unit_PA
      =
      x
    := pr2 X runit x.

  Definition coh_2gr_linv_PA
             (x : coh_2gr_carrier_PA)
    : coh_2gr_mult_PA (coh_2gr_inv_PA x) x
      =
      coh_2gr_unit_PA
    := pr2 X linv x.

  Definition coh_2gr_rinv_PA
             (x : coh_2gr_carrier_PA)
    : coh_2gr_unit_PA
      =
      coh_2gr_mult_PA x (coh_2gr_inv_PA x)
    := pr2 X rinv x.

  Definition coh_2gr_assoc_PA
             (x y z : coh_2gr_carrier_PA)
    : coh_2gr_mult_PA x (coh_2gr_mult_PA y z)
      =
      coh_2gr_mult_PA (coh_2gr_mult_PA x y) z
    := pr2 X massoc ((x ,, y) ,, z).

  Definition coh_2gr_inv_adj_triangle_l_l
             (x : coh_2gr_carrier_PA)
    : maponpaths (λ z, coh_2gr_mult_PA z x) (coh_2gr_rinv_PA x)
      @ !(coh_2gr_assoc_PA x (coh_2gr_inv_PA x) x)
      @ maponpaths (λ z, coh_2gr_mult_PA x z) (coh_2gr_linv_PA x)
      =
      sem_homot_endpoint_one_types
        (homot_left_path coh_2gr_signature inv_adj_triangle_l)
        (pr1 X) (pr2 X)
        x (idpath tt).
  Proof.
    unfold coh_2gr_mult_PA, coh_2gr_linv_PA, coh_2gr_rinv_PA ;
    unfold coh_2gr_assoc_PA, coh_2gr_inv_PA.
    simpl.
    rewrite !pathscomp0rid.
    simpl.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply ap_pair_l.
        }
        apply (maponpathscomp (λ q, q ,, x) inr).
      }
      apply (maponpathscomp (λ q, inr (q ,, x))).
    }
    do 2 apply maponpaths.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_r.
      }
      apply (maponpathscomp (λ q, x ,, q) inr).
    }
    apply (maponpathscomp (λ q, inr (x ,, q))).
  Qed.

  Definition coh_2gr_inv_adj_triangle_l_r
             (x : coh_2gr_carrier_PA)
    : sem_homot_endpoint_one_types
        (homot_right_path coh_2gr_signature inv_adj_triangle_l)
        (pr1 X) (pr2 X)
        x (idpath tt)
      = coh_2gr_lunit_PA x @ !(coh_2gr_runit_PA x).
  Proof.
    unfold coh_2gr_lunit_PA, coh_2gr_runit_PA.
    simpl.
    rewrite !pathscomp0rid.
    apply idpath.
  Qed.

  Definition coh_2gr_inv_adj_triangle_r_l
             (x : coh_2gr_carrier_PA)
    : maponpaths (λ z, coh_2gr_mult_PA (coh_2gr_inv_PA x) z) (coh_2gr_rinv_PA x)
      @ coh_2gr_assoc_PA (coh_2gr_inv_PA x) x (coh_2gr_inv_PA x)
      @ maponpaths (λ z, coh_2gr_mult_PA z (coh_2gr_inv_PA x)) (coh_2gr_linv_PA x)
      =
      sem_homot_endpoint_one_types
        (homot_left_path coh_2gr_signature inv_adj_triangle_r)
        (pr1 X) (pr2 X)
        x (idpath tt).
  Proof.
    unfold coh_2gr_mult_PA, coh_2gr_linv_PA, coh_2gr_rinv_PA ;
    unfold coh_2gr_assoc_PA, coh_2gr_inv_PA.
    simpl.
    rewrite !pathscomp0rid.
    simpl.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply ap_pair_r.
        }
        apply (maponpathscomp _ inr).
      }
      apply (maponpathscomp (λ q, inr ((pr21 X) (inl (inr x)),, q)) (pr21 X)).
    }
    do 2 apply maponpaths.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_l.
      }
      apply (maponpathscomp (λ q, q ,, _) inr).
    }
    apply (maponpathscomp (λ q, inr (q ,, _))).
  Qed.

  Definition coh_2gr_inv_adj_triangle_r_r
             (x : coh_2gr_carrier_PA)
    : sem_homot_endpoint_one_types
        (homot_right_path coh_2gr_signature inv_adj_triangle_r)
        (pr1 X) (pr2 X)
        x
        (idpath tt)
      =
      coh_2gr_runit_PA (coh_2gr_inv_PA x)
      @ !(coh_2gr_lunit_PA (coh_2gr_inv_PA x)).
  Proof.
    unfold coh_2gr_lunit_PA, coh_2gr_runit_PA.
    simpl.
    rewrite !pathscomp0rid.
    apply idpath.
  Qed.

  Definition coh_2gr_triangle_l
             (x y : coh_2gr_carrier_PA)
    : maponpaths (λ z, coh_2gr_mult_PA x z) (coh_2gr_lunit_PA y)
      =
      sem_homot_endpoint_one_types
        (homot_left_path coh_2gr_signature triangle)
        (pr1 X) (pr2 X)
        (x,, y) (idpath tt).
  Proof.
    unfold coh_2gr_mult_PA, coh_2gr_lunit_PA.
    simpl.
    rewrite !pathscomp0rid.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_r.
      }
      apply maponpathscomp.
    }
    exact (maponpathscomp (λ q, inr (x,, q)) (pr21 X)  (pr2 X lunit y)).
  Qed.

  Definition coh_2gr_triangle_r
             (x y : coh_2gr_carrier_PA)
    : sem_homot_endpoint_one_types
        (homot_right_path coh_2gr_signature triangle)
        (pr1 X) (pr2 X)
        (x,, y) (idpath tt)
      =
      coh_2gr_assoc_PA x coh_2gr_unit_PA y
      @ maponpaths (λ z, coh_2gr_mult_PA z y) (coh_2gr_runit_PA x).
  Proof.
    unfold coh_2gr_assoc_PA, coh_2gr_runit_PA.
    simpl.
    rewrite !pathscomp0rid.
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_l.
      }
      exact (maponpathscomp (λ q, q ,, y) inr (pr2 X runit x)).
    }
    exact (maponpathscomp (λ q, inr (q,, y)) (pr21 X) (pr2 X runit x)).
  Qed.

  Definition coh_2gr_pentagon_l
             (w x y z : coh_2gr_carrier_PA)
    : coh_2gr_assoc_PA w x (coh_2gr_mult_PA y z)
      @ coh_2gr_assoc_PA (coh_2gr_mult_PA w x) y z
      =
      sem_homot_endpoint_one_types
        (homot_left_path coh_2gr_signature pentagon)
        (pr1 X) (pr2 X)
        (((w,, x),, y),, z) (idpath tt).
  Proof.
    simpl.
    rewrite !pathscomp0rid.
    apply idpath.
  Qed.

  Definition coh_2gr_pentagon_r
             (w x y z : coh_2gr_carrier_PA)
    : sem_homot_endpoint_one_types
        (homot_right_path coh_2gr_signature pentagon)
        (pr1 X) (pr2 X)
        (((w,, x),, y),, z) (idpath tt)
      =
      maponpaths (λ q, coh_2gr_mult_PA w q) (coh_2gr_assoc_PA x y z)
      @ coh_2gr_assoc_PA w (coh_2gr_mult_PA x y) z
      @ maponpaths (λ q, coh_2gr_mult_PA q z) (coh_2gr_assoc_PA w x y).
  Proof.
    simpl.
    rewrite !pathscomp0rid.
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply ap_pair_r.
        }
        apply maponpathscomp.
      }
      apply (maponpathscomp (λ q, inr (w ,, q)) (pr21 X)).
    }
    do 2 apply maponpaths.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_l.
      }
      apply (maponpathscomp (λ q, q ,, z) inr).
    }
    apply (maponpathscomp (λ q, inr (q ,, z)) (pr21 X)).
  Qed.
End Coherent2GroupPathAlgebraProjections.

Section Coherent2GroupAlgebraProjections.
  Variable (X : hit_algebra_one_types coh_2gr_signature).

  Definition coh_2gr_carrier
    : one_type
    := coh_2gr_carrier_PA (pr1 X).

  Definition coh_2gr_unit
    : coh_2gr_carrier
    := coh_2gr_unit_PA (pr1 X).

  Definition coh_2gr_inv
             (x : coh_2gr_carrier)
    : coh_2gr_carrier
    := coh_2gr_inv_PA (pr1 X) x.

  Definition coh_2gr_mult
             (x y : coh_2gr_carrier)
    : coh_2gr_carrier
    := coh_2gr_mult_PA (pr1 X) x y.

  Definition coh_2gr_lunit
             (x : coh_2gr_carrier)
    : coh_2gr_mult coh_2gr_unit x
      =
      x
    := coh_2gr_lunit_PA (pr1 X) x.

  Definition coh_2gr_runit
             (x : coh_2gr_carrier)
    : coh_2gr_mult x coh_2gr_unit
      =
      x
    := coh_2gr_runit_PA (pr1 X) x.

  Definition coh_2gr_linv
             (x : coh_2gr_carrier)
    : coh_2gr_mult (coh_2gr_inv x) x
      =
      coh_2gr_unit
    := coh_2gr_linv_PA (pr1 X) x.

  Definition coh_2gr_rinv
             (x : coh_2gr_carrier)
    : coh_2gr_unit
      =
      coh_2gr_mult x (coh_2gr_inv x)
    := coh_2gr_rinv_PA (pr1 X) x.

  Definition coh_2gr_assoc
             (x y z : coh_2gr_carrier)
    : coh_2gr_mult x (coh_2gr_mult y z)
      =
      coh_2gr_mult (coh_2gr_mult x y) z
    := coh_2gr_assoc_PA (pr1 X) x y z.

  Definition coh_2gr_inv_adj_triangle_l
             (x : coh_2gr_carrier)
    : maponpaths
        (λ z, coh_2gr_mult z x)
        (coh_2gr_rinv x)
      @ !(coh_2gr_assoc _ _ _)
      @ maponpaths
          (λ z, coh_2gr_mult x z)
          (coh_2gr_linv x)
      =
      coh_2gr_lunit x @ !(coh_2gr_runit x).
  Proof.
    refine (_ @ pr2 X inv_adj_triangle_l x (idpath tt) @ _).
    - exact (coh_2gr_inv_adj_triangle_l_l _ x).
    - exact (coh_2gr_inv_adj_triangle_l_r _ x).
  Qed.

  Definition coh_2gr_inv_adj_triangle_r
             (x : coh_2gr_carrier)
    : maponpaths
        (λ z, coh_2gr_mult _ z)
        (coh_2gr_rinv x)
      @ coh_2gr_assoc _ _ _
      @ maponpaths
          (λ z, coh_2gr_mult z _)
          (coh_2gr_linv x)
      =
      coh_2gr_runit (coh_2gr_inv x) @ !(coh_2gr_lunit (coh_2gr_inv x)).
  Proof.
    refine (_ @ pr2 X inv_adj_triangle_r x (idpath tt) @ _).
    - exact (coh_2gr_inv_adj_triangle_r_l _ x).
    - exact (coh_2gr_inv_adj_triangle_r_r _ x).
  Qed.

  Definition coh_2gr_triangle
             (x y : coh_2gr_carrier)
    : maponpaths
        (λ z, coh_2gr_mult x z)
        (coh_2gr_lunit y)
      =
      (coh_2gr_assoc _ _ _)
      @ maponpaths
          (λ z, coh_2gr_mult z y)
          (coh_2gr_runit x).
  Proof.
    refine (_ @ pr2 X triangle (x ,, y) (idpath tt) @ _).
    - exact (coh_2gr_triangle_l _ x y).
    - exact (coh_2gr_triangle_r _ x y).
  Qed.

  Definition coh_2gr_pentagon
             (w x y z : coh_2gr_carrier)
    : coh_2gr_assoc w x (coh_2gr_mult y z)
      @ coh_2gr_assoc (coh_2gr_mult w x) y z
      =
      maponpaths
        (λ q, coh_2gr_mult w q)
        (coh_2gr_assoc x y z)
      @ coh_2gr_assoc w (coh_2gr_mult x y) z
      @ maponpaths
          (λ q, coh_2gr_mult q z)
          (coh_2gr_assoc w x y).
  Proof.
    refine (_ @ pr2 X pentagon (((w ,, x) ,, y) ,, z) (idpath tt) @ _).
    - exact (coh_2gr_pentagon_l _ w x y z).
    - exact (coh_2gr_pentagon_r _ w x y z).
  Qed.
End Coherent2GroupAlgebraProjections.

(** Builder *)
Section Coherent2GroupBuilder.
  Variable (A : one_type)
           (e : A)
           (i : A → A)
           (m : A → A → A)
           (unitl_m : ∏ (x : A), m e x = x)
           (unitr_m : ∏ (x : A), m x e = x)
           (invl_m : ∏ (x : A), m (i x) x = e)
           (invr_m : ∏ (x : A), e = m x (i x))
           (assoc_m : ∏ (x y z : A), m x (m y z) = m (m x y) z)
           (m_invt_l : ∏ (x : A),
                       maponpaths (λ z, m z x) (invr_m x)
                       @ !(assoc_m _ _ _)
                       @ maponpaths (λ z, m x z) (invl_m x)
                       =
                       unitl_m x @ !(unitr_m x))
           (m_invt_r : ∏ (x : A),
                       maponpaths (λ z, m _ z) (invr_m x)
                       @ assoc_m _ _ _
                       @ maponpaths (λ z, m z _) (invl_m x)
                       =
                       unitr_m (i x) @ !(unitl_m (i x)))
           (triangle_m : ∏ (x y : A),
                         maponpaths (λ z, m x z) (unitl_m y)
                         =
                         (assoc_m _ _ _)
                         @ maponpaths (λ z, m z y) (unitr_m x))
           (pentagon_m : ∏ (w x y z : A),
                         assoc_m w x (m y z)
                         @ assoc_m (m w x) y z
                         =
                         maponpaths (λ q, m w q) (assoc_m x y z)
                         @ assoc_m w (m x y) z
                         @ maponpaths (λ q, m q z) (assoc_m w x y)).

  Local Definition make_2gr_prealgebra
    : hit_prealgebra_one_types coh_2gr_signature.
  Proof.
    use make_hit_prealgebra.
    - exact A.
    - apply one_type_isofhlevel.
    - intro x ; induction x as [x | x].
      + induction x as [ | x].
        * exact e.
        * exact (i x).
      + exact (m (pr1 x) (pr2 x)).
  Defined.

  Local Definition make_2gr_path_algebra
    : hit_path_algebra_one_types coh_2gr_signature.
  Proof.
    use make_hit_path_algebra.
    - exact make_2gr_prealgebra.
    - intros j x.
      induction j.
      + (* unitl *)
        apply unitl_m.
      + (* unitr *)
        apply unitr_m.
      + (* invl *)
        apply invl_m.
      + (* invr *)
        apply invr_m.
      + (* assoc *)
        apply assoc_m.
  Defined.

  Definition make_2gr_path_algebra_is_algebra
    : is_hit_algebra_one_types coh_2gr_signature make_2gr_path_algebra.
  Proof.
    intros j x p.
    induction j.
    - (* inv_adj_triangle_l *)
      refine (_ @ m_invt_l x @ _).
      + exact (!(coh_2gr_inv_adj_triangle_l_l _ x)).
      + exact (!(coh_2gr_inv_adj_triangle_l_r _ x)).
    - (* inv_adj_triangle_r *)
      refine (_ @ m_invt_r x @ _).
      + exact (!(coh_2gr_inv_adj_triangle_r_l _ x)).
      + exact (!(coh_2gr_inv_adj_triangle_r_r _ x)).
    - (* triangle *)
      refine (_ @ triangle_m (pr1 x) (pr2 x) @ _).
      + exact (!(coh_2gr_triangle_l _ (pr1 x) (pr2 x))).
      + exact (!(coh_2gr_triangle_r _ (pr1 x) (pr2 x))).
    - (* pentagon *)
      refine (_ @ pentagon_m (pr111 x) (pr211 x) (pr21 x) (pr2 x) @ _).
      + exact (!(coh_2gr_pentagon_l _ (pr111 x) (pr211 x) (pr21 x) (pr2 x))).
      + exact (!(coh_2gr_pentagon_r _ (pr111 x) (pr211 x) (pr21 x) (pr2 x))).
  Qed.

  Definition make_2gr_algebra
    : hit_algebra_one_types coh_2gr_signature.
  Proof.
    use make_algebra.
    - exact make_2gr_path_algebra.
    - exact make_2gr_path_algebra_is_algebra.
  Defined.
End Coherent2GroupBuilder.

(** The loop space of a 2-type is a coherent 2-group *)
Definition loop_space_2gr
           {X : UU}
           (HX : isofhlevel 4 X)
           (x : X)
  : hit_algebra_one_types coh_2gr_signature.
Proof.
  use make_2gr_algebra.
  - use make_one_type.
    + exact (x = x).
    + exact (HX x x).
  - exact (idpath x).
  - exact (λ p, !p).
  - exact (λ p q, p @ q).
  - exact (λ p, idpath p).
  - exact pathscomp0rid.
  - exact pathsinv0l.
  - exact (λ p, !(pathsinv0r p)).
  - exact path_assoc.
  - simpl.
    intro p ; induction p.
    apply idpath.
  - intro p ; induction p.
    apply idpath.
  - intro p ; induction p.
    exact (λ _, idpath _).
  - intro p ; induction p.
    intro p ; induction p.
    exact (λ _ _, idpath _).
Defined.

(**
The automorphism 2-group of `X`.
Assuming univalence, this is just the loopspace of the type of 1-types with basepoint `X`.
Here we construct it without assuming univalence.
 *)
Local Open Scope weq.

(**
We first give some principles to construct equalities between weak equivalences.
In addition, we prove some properties about them.
 *)
Definition path_isweq
           {X Y : UU}
           {f : X → Y}
           (Hf₁ Hf₂ : isweq f)
  : Hf₁ = Hf₂.
Proof.
  apply isapropisweq.
Defined.

Definition path_weq'
           {X Y : UU}
           {f g : X ≃ Y}
           (p : pr1 f = pr1 g)
  : f = g.
Proof.
  induction f as [f Hf], g as [g Hg] ; simpl in *.
  induction p.
  refine (maponpaths (λ z, f ,, z) _).
  apply path_isweq.
Defined.

Definition path_weq
           {X Y : UU}
           {f g : X ≃ Y}
           (p : ∏ (x : X), f x = g x)
  : f = g.
Proof.
  apply path_weq'.
  use funextsec.
  exact p.
Defined.

Definition inv_path_weq'
           {X Y : UU}
           {f g : X ≃ Y}
           (p : pr1 f = pr1 g)
  : !(path_weq' p) = path_weq' (!p).
Proof.
  induction f as [f Hf] ; induction g as [g Hg] ; simpl in *.
  induction p.
  simpl.
  etrans.
  {
    refine (!_).
    apply maponpathsinv0.
  }
  apply maponpaths.
  apply isapropisweq.
Defined.

Definition comp_path_weq'
           {X Y : UU}
           {f g h : X ≃ Y}
           (p : pr1 f = pr1 g)
           (q : pr1 g = pr1 h)
  : path_weq' p @ path_weq' q = path_weq' (p @ q).
Proof.
  induction f as [f Hf]
  ; induction g as [g Hg]
  ; induction h as [h Hh]
  ; simpl in *.
  induction p ; induction q ; simpl.
  etrans.
  {
    refine (!_).
    apply maponpathscomp0.
  }
  apply maponpaths.
  apply isapropisweq.
Defined.

Definition precomp_path_weq'
           {X Y Z : UU}
           (f : X ≃ Y)
           {g h : Y ≃ Z}
           (p : pr1 g = pr1 h)
  : maponpaths
      (λ z, z ∘ f)
      (path_weq' p)
    =
    @path_weq' X Z (g ∘ f) (h ∘ f) (maponpaths (λ z, z ∘ pr1 f)%functions p).
Proof.
  induction g as [g Hg]
  ; induction h as [h Hh]
  ; simpl in *.
  induction p ; simpl.
  etrans.
  {
    apply maponpathscomp.
  }
  etrans.
  {
    refine (!_).
    exact (maponpathscomp _ (λ z, _ ,, z) _).
  }
  simpl.
  apply maponpaths.
  apply isapropisweq.
Qed.

Definition postcomp_path_weq'
           {X Y Z : UU}
           {f g : X ≃ Y}
           (h : Y ≃ Z)
           (p : pr1 f = pr1 g)
  : maponpaths
      (λ z, h ∘ z)
      (path_weq' p)
    =
    @path_weq' X Z (h ∘ f) (h ∘ g) (maponpaths (λ z, (λ x, h(z x))) p).
Proof.
  induction f as [f Hf]
  ; induction g as [g Hg]
  ; simpl in *.
  induction p ; simpl.
  etrans.
  {
    apply (maponpathscomp _ (λ z, h ∘ z)).
  }
  unfold funcomp, weqcomp, make_weq ; simpl.
  etrans.
  {
    refine (!_).
    exact (maponpathscomp
             (λ z, twooutof3c f h z (pr2 h))
             (λ z, (λ q, h(f q)) ,, z)
             _).
  }
  simpl.
  apply maponpaths.
  apply isapropisweq.
Qed.

(** Necessary lemmas about function extensionality *)
Definition funextsec_idpath
           {X Y : UU}
           (f : X → Y)
  : funextsec _ _ _ (λ x, idpath (f x)) = idpath f.
Proof.
  refine (_ @ funextsec_toforallpaths _).
  apply idpath.
Qed.

Definition inv_toforallpaths
           {X : UU}
           {Y : X → UU}
           {f g : ∏ (x : X), Y x}
           (p : f = g)
  : (λ x, !(toforallpaths _ _ _ p x)) = toforallpaths _ _ _ (!p).
Proof.
  induction p.
  apply idpath.
Qed.

Definition inv_funextsec
           {X Y : UU}
           {f g : X → Y}
           (p : ∏ (x : X), f x = g x)
  : !(funextsec _ _ _ p) = funextsec _ _ _ (λ x, !(p x)).
Proof.
  refine (!(funextsec_toforallpaths _) @ _).
  apply maponpaths.
  refine (!(inv_toforallpaths (funextsec _ _ _ p)) @ _) ; simpl.
  use funextsec ; intro x.
  apply maponpaths.
  exact (eqtohomot (toforallpaths_funextsec p) x).
Qed.

Definition comp_toforallpaths
           {X : UU}
           {Y : X → UU}
           {f g h : ∏ (x : X), Y x}
           (p : f = g) (q : g = h)
  : toforallpaths _ _ _ (p @ q)
    =
    (λ x, toforallpaths _ _ _ p x @ toforallpaths _ _ _ q x).
Proof.
  induction p, q.
  apply idpath.
Qed.

Definition comp_funextsec
           {X Y : UU}
           {f g h : X → Y}
           (p : ∏ (x : X), f x = g x)
           (q : ∏ (x : X), g x = h x)
  : funextsec _ _ _ p @ funextsec _ _ _ q
    =
    funextsec _ _ _ (λ x, p x @ q x).
Proof.
  refine (!(funextsec_toforallpaths _) @ _).
  apply maponpaths.
  refine (comp_toforallpaths _ _ @ _).
  use funextsec ; intro x ; simpl.
  rewrite !toforallpaths_funextsec.
  apply idpath.
Qed.

Definition precomp_toforallpaths
           {X Y Z : UU}
           (f : X → Y)
           {g h : Y → Z}
           (p : g = h)
  : toforallpaths
      _ _ _
      (maponpaths (λ z : Y → Z, (z ∘ f)%functions) p)
    =
    (λ x, toforallpaths _ _ _ p (f x)).
Proof.
  induction p.
  apply idpath.
Qed.

Definition precomp_funextsec
           {X Y Z : UU}
           (f : X → Y)
           {g h : Y → Z}
           (p : ∏ (y : Y), g y = h y)
  : maponpaths
      (λ z : Y → Z, (z ∘ f)%functions)
      (funextsec _ _ _ p)
    =
    funextsec _ _ _ (λ x : X, p (f x)).
Proof.
  refine (!(funextsec_toforallpaths _) @ _).
  apply maponpaths.
  refine (precomp_toforallpaths f (funextsec _ _ _ p) @ _).
  use funextsec ; intro x.
  exact (eqtohomot (toforallpaths_funextsec _) (f x)).
Qed.

Definition postcomp_toforallpaths
           {X Y Z : UU}
           {f g : X → Y}
           (h : Y → Z)
           (p : f = g)
  : toforallpaths
      _ _ _
      (maponpaths (λ q : X → Y, (λ x, h(q x))) p)
    =
    (λ x, maponpaths h (toforallpaths _ _ _ p x)).
Proof.
  induction p.
  apply idpath.
Qed.

Definition postcomp_funext
           {X Y Z : UU}
           {f g : X → Y}
           (h : Y → Z)
           (p : ∏ (x : X), f x = g x)
  : maponpaths
      (λ (z : X → Y) (x : X), h (z x))
      (funextsec _ _ _ p)
    =
    funextsec _ _ _ (λ x : X, maponpaths h (p x)).
Proof.
  refine (!(funextsec_toforallpaths _) @ _).
  apply maponpaths.
  refine (postcomp_toforallpaths h _ @ _).
  use funextsec ; intro x ; simpl.
  apply maponpaths.
  exact (eqtohomot (toforallpaths_funextsec p) x).
Qed.

(** The lemmas on `path_weq` we need *)
Definition inv_path_weq
           {X Y : UU}
           {f g : X ≃ Y}
           (p : ∏ (x : X), f x = g x)
  : !(path_weq p) = path_weq (λ x, !(p x)).
Proof.
  refine (inv_path_weq' _ @ _).
  unfold path_weq ; apply maponpaths.
  apply inv_funextsec.
Qed.

Definition comp_path_weq
           {X Y : UU}
           {f g h : X ≃ Y}
           (p : ∏ (x : X), f x = g x)
           (q : ∏ (x : X), g x = h x)
  : path_weq p @ path_weq q
    =
    path_weq (λ x, p x @ q x).
Proof.
  refine (comp_path_weq' _ _ @ _).
  unfold path_weq ; apply maponpaths.
  apply comp_funextsec.
Qed.

Definition precomp_path_weq
           {X Y Z : UU}
           (f : X ≃ Y)
           {g h : Y ≃ Z}
           (p : ∏ (y : Y), g y = h y)
  : maponpaths
      (λ z, z ∘ f)
      (path_weq p)
    =
    @path_weq X Z (g ∘ f) (h ∘ f) (λ x, p (f x)).
Proof.
  refine (precomp_path_weq' _ _ @ _).
  unfold path_weq.
  apply maponpaths.
  exact (precomp_funextsec f p).
Qed.

Definition postcomp_path_weq
           {X Y Z : UU}
           {f g : X ≃ Y}
           (h : Y ≃ Z)
           (p : ∏ (x : X), f x = g x)
  : maponpaths
      (λ z, h ∘ z)
      (path_weq p)
    =
    @path_weq X Z (h ∘ f) (h ∘ g) (λ x, maponpaths h (p x)).
Proof.
  refine (postcomp_path_weq' _ _ @ _).
  unfold path_weq.
  apply maponpaths.
  exact (postcomp_funext h p).
Qed.

Definition homotweq
           {X Y : UU}
           {f g : X ≃ Y}
           {p q : ∏ (x : X), f x = g x}
           (r : ∏ (x : X), p x = q x)
  : path_weq p = path_weq q.
Proof.
  assert (p = q) as H.
  {
    use funextsec.
    exact r.
  }
  induction H.
  apply idpath.
Defined.

(**
The laws to show that weak equivalences on `X` form a coherent weak 2-group.
 *)
Definition weq_id_l
           {X : UU}
           (f : X ≃ X)
  : f ∘ idweq X = f.
Proof.
  use path_weq.
  exact (λ _, idpath _).
Defined.

Definition weq_id_r
           {X : UU}
           (f : X ≃ X)
  : idweq X ∘ f = f.
Proof.
  use path_weq.
  exact (λ _, idpath _).
Defined.

Definition weq_inv_l
           {X : UU}
           (f : X ≃ X)
  : f ∘ invweq f = idweq X.
Proof.
  use path_weq.
  intro x ; simpl.
  exact (homotweqinvweq f x).
Defined.

Definition weq_inv_r
           {X : UU}
           (f : X ≃ X)
  : idweq X = invweq f ∘ f.
Proof.
  use path_weq.
  intro x ; simpl.
  exact (!(homotinvweqweq f x)).
Defined.

Definition weq_assoc
           {X : UU}
           (f g h : X ≃ X)
  : (h ∘ g) ∘ f = h ∘ (g ∘ f).
Proof.
  use path_weq.
  exact (λ _, idpath _).
Defined.

Definition weq_inv_triangle_l
           {X : UU}
           (f : X ≃ X)
  : maponpaths
      (λ z : X ≃ X, f ∘ z)
      (weq_inv_r f)
    @ !(weq_assoc f (invweq f) f)
    @ maponpaths (λ z : X ≃ X, z ∘ f) (weq_inv_l f)
    =
    weq_id_l f @ ! weq_id_r f.
Proof.
  unfold weq_inv_r, weq_assoc, weq_inv_l.
  etrans.
  {
    etrans.
    {
      apply maponpaths_2.
      apply postcomp_path_weq.
    }
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply inv_path_weq.
      }
      etrans.
      {
        apply maponpaths.
        apply precomp_path_weq.
      }
      apply comp_path_weq.
    }
    apply comp_path_weq.
  }
  unfold weq_id_l, weq_id_r.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    apply inv_path_weq.
  }
  etrans.
  {
    apply comp_path_weq.
  }
  apply homotweq.
  intros x ; simpl.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    exact (!(homotweqinvweqweq f x)).
  }
  etrans.
  {
    refine (!_).
    apply maponpathscomp0.
  }
  etrans.
  {
    apply maponpaths.
    apply pathsinv0l.
  }
  apply idpath.
Qed.

Definition weq_inv_triangle_r
           {X : UU}
           (f : X ≃ X)
  : maponpaths (λ z : X ≃ X, z ∘ invweq f) (weq_inv_r f)
    @ weq_assoc (invweq f) f (invweq f)
    @ maponpaths (λ z : X ≃ X, invweq f ∘ z) (weq_inv_l f)
    =
    weq_id_r (invweq f) @ ! weq_id_l (invweq f).
Proof.
  unfold weq_inv_r, weq_assoc, weq_inv_l.
  etrans.
  {
    etrans.
    {
      apply maponpaths_2.
      apply precomp_path_weq.
    }
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        apply postcomp_path_weq.
      }
      apply comp_path_weq.
    }
    apply comp_path_weq.
  }
  unfold weq_id_l, weq_id_r.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    apply inv_path_weq.
  }
  etrans.
  {
    apply comp_path_weq.
  }
  apply homotweq.
  intros x ; simpl.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    apply homotweqweqinvweq.
  }
  apply pathsinv0l.
Qed.

Definition weq_triangle
           {X : UU}
           (f g : X ≃ X)
  : maponpaths (λ z : X ≃ X, z ∘ f) (weq_id_l g) =
    weq_assoc f (idweq X) g
    @ maponpaths (λ z : X ≃ X, g ∘ z) (weq_id_r f).
Proof.
  etrans.
  {
    apply precomp_path_weq.
  }
  refine (!_).
  etrans.
  {
    apply maponpaths.
    apply postcomp_path_weq.
  }
  etrans.
  {
    apply comp_path_weq.
  }
  apply homotweq.
  exact (λ _, idpath _).
Qed.

Definition weq_pentagon
           {X : UU}
           (f₁ f₂ f₃ f₄ : X ≃ X)
  : weq_assoc f₁ f₂ (f₄ ∘ f₃) @ weq_assoc (f₂ ∘ f₁) f₃ f₄
    =
    maponpaths (λ q : X ≃ X, q ∘ f₁) (weq_assoc f₂ f₃ f₄)
    @ weq_assoc f₁ (f₃ ∘ f₂) f₄
    @ maponpaths (λ q : X ≃ X, f₄ ∘ q) (weq_assoc f₁ f₂ f₃).
Proof.
  etrans.
  {
    apply comp_path_weq.
  }
  refine (!_).
  etrans.
  {
    etrans.
    {
      apply maponpaths_2.
      apply precomp_path_weq.
    }
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        apply postcomp_path_weq.
      }
      apply comp_path_weq.
    }
    apply comp_path_weq.
  }
  apply homotweq.
  exact (λ _, idpath _).
Qed.

Definition aut_2gr
           (X : UU)
           (HX : isofhlevel 3 X)
  : hit_algebra_one_types coh_2gr_signature.
Proof.
  use make_2gr_algebra.
  - use make_one_type.
    + exact (X ≃ X).
    + use isofhlevelsnweqtohlevelsn.
      exact HX.
  - exact (idweq X).
  - exact invweq.
  - exact weqcomp.
  - exact weq_id_l.
  - exact weq_id_r.
  - exact weq_inv_l.
  - exact weq_inv_r.
  - exact weq_assoc.
  - exact weq_inv_triangle_l.
  - exact weq_inv_triangle_r.
  - exact weq_triangle.
  - exact weq_pentagon.
Defined.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.priority rt.model.arrival.basic.task_arrival
               rt.model.arrival.basic.arrival_bounds.
Require Import rt.model.schedule.uni.schedule_of_task rt.model.schedule.uni.workload
               rt.model.schedule.uni.schedulability rt.model.schedule.uni.response_time
               rt.model.schedule.uni.service.
Require Import rt.model.schedule.uni.basic.busy_interval rt.model.schedule.uni.basic.platform.
Require Import rt.analysis.uni.basic.workload_bound_fp.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module ResponseTimeAnalysisFP.

  Import Job ScheduleOfTask SporadicTaskset Priority ResponseTime
         TaskArrival ArrivalBounds WorkloadBoundFP Platform Schedulability
         BusyInterval Workload Service.

  (* In this section, we prove that any fixed point in the RTA for uniprocessor
     FP scheduling is a response-time bound. *)
  Section ResponseTimeBound.

    Context {SporadicTask: eqType}.
    Variable task_cost: SporadicTask -> time.
    Variable task_period: SporadicTask -> time.
    Variable task_deadline: SporadicTask -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> SporadicTask.

    (* Assume any job arrival sequence with consistent, non-duplicate arrivals... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_no_duplicate_arrivals: arrival_sequence_is_a_set arr_seq.

    (* ... in which jobs arrive sporadically and have valid parameters. *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period job_arrival job_task arr_seq.
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Consider a task set ts where all tasks have valid parameters... *)
    Variable ts: seq SporadicTask.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* ... and assume that all jobs in the arrival sequence come from the task set. *)
    Hypothesis H_all_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* Next, consider any uniprocessor schedule of this arrival sequence...*)
    Variable sched: schedule Job.
    Hypothesis H_jobs_come_from_arrival_sequence: jobs_come_from_arrival_sequence sched arr_seq.

    (* ... where jobs do not execute before their arrival times nor after completion. *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* Consider an FP policy that indicates a higher-or-equal priority relation,
       and assume that the relation is reflexive and transitive. *)
    Variable higher_eq_priority: FP_policy SporadicTask.
    Hypothesis H_priority_is_reflexive: FP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: FP_is_transitive higher_eq_priority.

    (* Next, assume that the schedule is a work-conserving FP schedule. *)
    Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
    Hypothesis H_respects_fp_policy:
      respects_FP_policy job_arrival job_cost job_task arr_seq sched higher_eq_priority.

    (* Now we proceed with the analysis.
       Let tsk be any task in ts that is to be analyzed. *)
    Variable tsk: SporadicTask.
    Hypothesis H_tsk_in_ts: tsk \in ts.

    (* Recall the definition of response-time bound and the total workload bound W
       for tasks with higher-or-equal priority (with respect to tsk). *)
    Let response_time_bounded_by :=
      is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched.
    Let W := total_workload_bound_fp task_cost task_period higher_eq_priority ts tsk.

    (* Let R be any positive fixed point of the response-time recurrence. *)
    Variable R: time.
    Hypothesis H_R_positive: R > 0.
    Hypothesis H_response_time_is_fixed_point: R = W R.

    (* Since R = W R bounds the workload of higher-or-equal priority
       in any interval of length R, it follows from the busy-interval
       lemmas that R bounds the response-time of job j.
       (For more details, see model/uni/basic/busy_interval.v and
        analysis/uni/basic/workload_bound_fp.v.) *)
    Theorem uniprocessor_response_time_bound_fp:
      response_time_bounded_by tsk R.
    Proof.
      rename H_response_time_is_fixed_point into FIX.
      intros j ARRj JOBtsk.
      set prio := FP_to_JLFP job_task higher_eq_priority.
      apply busy_interval_bounds_response_time with (arr_seq0 := arr_seq)
                                            (higher_eq_priority0 := prio); try (by done).
        - by intros x; apply H_priority_is_reflexive.
        - by intros x z y; apply H_priority_is_transitive.
      apply fp_workload_bound_holds with (job_arrival0 := job_arrival) (task_cost0 := task_cost)
        (task_period0 := task_period) (task_deadline0 := task_deadline)
        (job_deadline0 := job_deadline) (ts0 := ts); try (by done).
      by rewrite JOBtsk.
    Qed.

  End ResponseTimeBound.

End ResponseTimeAnalysisFP.