(* -*- mode: coq; mode: visual-line -*- *)

(** * Theorems about trunctions *)

Require Import HoTT.Basics FunextVarieties.
Require Import HoTT.Truncations HoTT.Types.Bool.

(** ** We can construct an interval type as [Trunc -1 Bool] *)

Local Definition interval := Trunc (-1) Bool.

Local Definition interval_rec (P : Type) (a b : P) (p : a = b)
: interval -> P.
Proof.
  unfold interval; intro x.
  cut { pt : P | pt = b }.
  { apply pr1. }
  { strip_truncations.
    refine (if x then a else b; _).
    destruct x; (reflexivity || assumption). }
Defined.

Local Definition seg : tr true = tr false :> interval
  := path_ishprop _ _.

(** ** From an interval type, and thus from truncations, we can prove function extensionality. *)

Definition funext_type_from_trunc : Funext_type
  := WeakFunext_implies_Funext (NaiveFunext_implies_WeakFunext
    (fun A P f g p =>
      let h := fun (x:interval) (a:A) =>
        interval_rec _ (f a) (g a) (p a) x
        in ap h seg)).

(** As justified by the above proof, we may assume [Funext] given [Trunc]. *)
Global Instance funext_from_trunc : Funext.
Admitted.


Require Import Utf8 Lia.
Local Set Implicit Arguments.

Definition lt' (p1 p2 : nat * nat) : Prop :=
  match p1, p2 with
  | (n1, m1), (n2, m2) => n1 < n2 ∨ n1 = n2 ∧ m1 < m2
  end.

Lemma lt'_wf_aux :
well_founded lt → forall x, Acc lt x → forall y, Acc lt y → Acc lt' (x, y).
Proof.
  intros Hlt x Hx.
  induction Hx as [x _ IHaccx].
  intros y Hy.
  induction Hy as [y _ IHaccy].
  constructor.
  intros (x', y').
  destruct 1 as [ | [] ]; subst ; auto.
Qed.

Lemma lt'_wf : well_founded lt'.
Proof.
  intros (x, y).
  apply lt'_wf_aux ; apply Wf_nat.lt_wf.
Qed.

Ltac lt'_left := simpl ; left ; lia.
Ltac lt'_right := simpl ; right ; split ; [ reflexivity | lia ].
Ltac lt'_solve :=
  match goal with
  | [ W : Acc lt' (?n2, 0) |- Acc lt' (?n1, ?m1) ] =>
    apply (Acc_inv W) ; lt'_left
  | [ W : Acc lt' (S ?n, ?m2) |- Acc lt' (?n, ?m1) ] =>
    apply (Acc_inv W) ; lt'_left
  | [ W : Acc lt' (?n, ?m2) |- Acc lt' (?n, ?m1) ] =>
    apply (Acc_inv W) ; lt'_right
  | [ W : Acc lt' (?n2, ?m2) |- Acc lt' (?n1, ?m1) ] =>
    (* general case *)
    apply (Acc_inv W) ;
    simpl;
    let L := fresh "H_le" in
    assert (n1 <= n2) as L ; [ lia | ] ;
    inversion L ; subst ; [ lt'_right | lt'_left ]
  end.


(* Some tests for contradiction *)

Lemma L1 : forall A B : Prop, A -> ~A -> B.
Proof.
intros; contradiction.
Qed.

Lemma L2 : forall A B : Prop, ~A -> A -> B.
Proof.
intros; contradiction.
Qed.

Lemma L3 : forall A : Prop, ~True -> A.
Proof.
intros; contradiction.
Qed.

Lemma L4 : forall A : Prop, forall x : nat, ~x=x -> A.
Proof.
intros; contradiction.
Qed.

Lemma L5 : forall A : Prop, forall x y : nat, ~x=y -> x=y -> A.
Proof.
intros; contradiction.
Qed.

Lemma L6 : forall A : Prop, forall x y : nat, x=y -> ~x=y -> A.
Proof.
intros; contradiction.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Ext_Cons.Arrow.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Cat.Cat Cat.Cat_Iso.
Require Import NatTrans.NatTrans NatTrans.NatIso.
Require Import Archetypal.Discr.Discr.

(** This module contains facts about discrete categories and discrete
    functors involving natural transformations. *)

(** The fact that dicrete functor from (Discr_Cat A) to Cᵒᵖ is naturally
    isomorphic to the opposite of discrete-opposite functor
    from (Discr_Cat A)ᵒᵖ to C. *)
Section Discr_Func_Iso.
  Context {C : Category} {A : Type} (Omap : A → C).

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Discr_Func_Iso :
    (
      (@Discr_Func (C^op) A Omap) ≃ ((@Discr_Func_op C A Omap)^op)%functor
    )%natiso
    :=
      {|
        iso_morphism :=
          {|
            Trans := fun _ => id
          |};
        inverse_morphism :=
          {|
            Trans := fun _ => id
          |}
      |}
  .

End Discr_Func_Iso.

(** We show that the opposite of the functor from the singleton category that
maps to object x in C is naturally isomorphic to the functor from the
singleton category that maps to object x in Cᵒᵖ. *)
Section Func_From_SingletonCat_Opposite.
  Context {C : Category} (x : C).

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Func_From_SingletonCat_Opposite :
    (
      (((@Func_From_SingletonCat C x)^op)
         ≃ (@Func_From_SingletonCat (C ^op) x))%functor
    )%natiso
    :=
      {|
        iso_morphism :=
          {|
            Trans := fun _ => id
          |};
        inverse_morphism :=
          {|
            Trans := fun _ => id
          |}
      |}
  .

End Func_From_SingletonCat_Opposite.

Section Discr_Func_Arrow_Iso.
  Context {C D : Category} (arrmap : (Arrow (C^op)) → D).

  (** Let A be the discrete categoty of morphisms of Cᵒᵖ and B be the category
of morphisms of C. We show that Aᵒᵖ ≃ Bᵒᵖ. *)
  Definition Discr_Cat_ArrowOp_Discr_Cat_Arrow_Op :
    ((((Discr_Cat (Arrow (C^op)))^op)%category)
       ≃≃ ((Discr_Cat (Arrow C))^op)%category ::> Cat)%isomorphism
    :=
      Opposite_Cat_Iso (Discr_Cat_Iso ((Arrow_OP_Iso C)⁻¹))
  .

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  (** Let A be the discrete categoty of morphisms of Cᵒᵖ and B be the category
of morphisms of C. Let, furthermore, U : B → D be a function we show that
((Discr_Func_op (fun x : B => U x^) ∘ M) ≃ (Discr_Func_op U). Where x^ is
mirrored version of x (from an arrow of C to an arrow of Cᵒᵖ) and M is
Discr_Cat_ArrowOp_Discr_Cat_Arrow_Op defined above.
*)
  Program Definition Discr_Func_Arrow_Iso :
    (
      (
        (Discr_Func_op (fun x : Arrow C => arrmap (Arrow_to_Arrow_OP C x)))
          ∘ (iso_morphism Discr_Cat_ArrowOp_Discr_Cat_Arrow_Op)
      )%functor
        ≃ ((@Discr_Func_op D (Arrow (C^op)) arrmap))%functor
    )%natiso
    :=
      {|
        iso_morphism :=
          {|
            Trans := fun c => id
          |};
        inverse_morphism :=
          {|
            Trans := fun c => id
          |}
      |}
  .

End Discr_Func_Arrow_Iso.

Local Hint Extern 1 =>
match goal with [z : Arrow (Discr_Cat _) |- _] => destruct z as [? ? []] end.

(** The fact that in discrete categories object type and arrow
    type are isomorphic. *)
Program Definition Discr_Hom_Iso (A : Type) :
  (A ≃≃ Arrow (Discr_Cat A) ::> Type_Cat)%isomorphism :=
  (Build_Isomorphism
     Type_Cat
     _
     _
     (fun a => (Build_Arrow (Discr_Cat A) _ _ (eq_refl a)))
     (fun a : (Arrow (Discr_Cat _)) => Orig a)
     _
     _
  ).

Section Discretize.
  Context {C D : Category} {F G : (C –≻ D)%functor} (N : (F –≻ G)%nattrans).

  (** Discretizes a natural transformation. That is, it forgets about the
      arrow maps of the functors and assumes the functors are just discrete
      functors, retaining the object maps of the functors. *)
  Program Definition Discretize :
    ((Discr_Func (F _o)%object) –≻ (Discr_Func (G _o)%object))%nattrans
    :=
    {|
      Trans := Trans N
    |}.

End Discretize.


Require Export division.

Definition square (n : nat) : nat := n * n.

Lemma sq_expand : forall n, square n >= n.
Proof.
  destruct n; try destruct n; eauto. unfold square.
  simpl. repeat apply le_prog. remember (S (S (n + n * (S (S n))))) as k.
  clear. rewrite (plus_comm n k). induction k; simpl; eauto.
Qed.

Lemma sq_inc' : forall n, square n < square (S n).
Proof.
  intros; unfold square. simpl_arith.
  replace (S (n + (n + n * n))) with (S n + (n + n * n)) by eauto.
  rewrite (plus_comm (S _) _). rewrite (plus_comm n (n * n)).
  rewrite <- plus_assoc. remember (n * n) as x. rewrite <- plus_n_Sm.
  remember (n + n) as y. clear. rewrite plus_comm. simpl. apply le_prog.
  induction y; simpl; eauto.
Qed.

Lemma sq_inc : forall x y, x <= y -> square x <= square y.
Proof.
  intros x y; revert x. induction y; intros.
  + inversion H; subst; eauto.
  + inversion H; eauto. clear H H0 m. specialize (IHy x H1).
    eapply le_trans; try eassumption. apply le_rev; apply le_S.
    apply sq_inc'.
Qed.

Lemma sq_inc_strong : forall x y, x < y -> square x < square y.
Proof.
  intros x y; revert x. induction y; intros.
  + inversion H.
  + inversion H.
    - apply sq_inc'.
    - clear H H0 m. specialize (IHy x H1).
    eapply le_trans; try eassumption. apply le_rev; apply le_S.
    apply sq_inc'.
Qed.

Lemma sq_inj : forall x y, square x = square y -> x = y.
Proof.
  intros. destruct (split_crit x y) as [Hb | [Hb | Hb]]; try assumption;
  apply sq_inc_strong in Hb; rewrite H in Hb; destruct (le_contra _ 0 Hb).
Qed.

Lemma sq_mod_four : forall x,
  Nat.modulo (square x) 4 = 0 \/ Nat.modulo (square x) 4 = 1.
Proof.
  intros. eassert (4 > 0) by (apply ltb_refl; eauto).
  destruct (division_uniq x 4 H) as [q [r [Hltr [Heq Huniq]]]].
  destruct (division_uniq (square x) 4 H)
    as [q' [r' [Hltr' [Heqsq Huniq']]]].
  assert (FACT :
    square x = 4 * Nat.div (square x) 4
    + Nat.modulo (square x) 4
  ). {
    assert (Hi := div_modulo_eq (square x) _ H). rewrite (mul_comm 4 _).
    assumption.
  } destruct r; try destruct r; try destruct r; try destruct r.
  + replace (4 * q + 0) with (4 * q) in Heq by (simpl_arith; eauto).
    assert (square x = 4 * (q * (4 * q)) + 0). {
      unfold square. subst x. rewrite <- mul_assoc. simpl_arith; refl.
    } destruct (Huniq' _ _ H H0). subst q' r'.
    destruct (Huniq' _ _ (modulo_less _ _ H) FACT).
    left; congruence.
  + assert (exists qq, square x = 4 * qq + 1). {
      eexists. unfold square; subst x.
      rewrite plus_mul_dist. rewrite (mul_comm _ (4 * q)).
      rewrite plus_mul_dist. rewrite (mul_comm (4 * q + 1) 1).
      replace (1 * (4 * q + 1)) with (4 * q + 1) by (
        simpl; simpl_arith; refl
      ). repeat rewrite <- mul_assoc. rewrite <- plus_mul_dist.
      rewrite plus_assoc. rewrite <- plus_mul_dist. eauto.
    } destruct H0 as [qq Hqq].
    destruct (Huniq' _ _ Hltr Hqq); subst q' r'.
    destruct (Huniq' _ _ (modulo_less _ _ H) FACT).
    right; congruence.
  + remember 4 as z. replace 2 with (2 * 1) in Heq by refl; subst z.
    replace 4 with (2 * 2) in Heq by refl. rewrite <- mul_assoc in Heq.
    rewrite <- plus_mul_dist in Heq.
    assert (exists qq, square x = 4 * qq + 0). {
      eexists. unfold square. subst x. rewrite mul_assoc.
      rewrite <- (mul_assoc 2 _ 2). rewrite (mul_comm _ 2).
      rewrite mul_assoc. replace (2 * 2) with 4 by refl.
      rewrite <- mul_assoc. eauto.
    } destruct H0 as [qq Hqq].
    destruct (Huniq' _ _ H Hqq); subst q' r'.
    destruct (Huniq' _ _ (modulo_less _ _ H) FACT).
    left; congruence.
  + eassert (H1lt4 : 1 < 4) by (apply ltb_refl; eauto).
    assert (exists qq, square x = 4 * qq + 1). {
      eexists. unfold square. subst x.
      rewrite plus_mul_dist. rewrite (mul_comm _ (4 * q)).
      rewrite plus_mul_dist. rewrite (mul_comm (4 * q + 3) 3).
      rewrite plus_mul_dist. replace (3 * 3) with (4 * 2 + 1) by refl.
      repeat rewrite plus_assoc.
      (* first *) replace (4 * q * (4 * q)) with (4 * (q * 4 * q)) by (
        repeat rewrite mul_assoc; refl
      ). (* second *) replace (4 * q * 3) with (4 * (q * 3)) by (
        repeat rewrite mul_assoc; refl
      ). (* third *) replace (3 * (4 * q)) with (4 * (3 * q)) by (
        repeat rewrite mul_assoc; refl
      ). repeat rewrite <- (plus_mul_dist 4). eauto.
    } destruct H0 as [qq Hqq].
    destruct (Huniq' _ _ H1lt4 Hqq); subst q' r'.
    destruct (Huniq' _ _ (modulo_less _ _ H) FACT).
    right; congruence.
  + repeat apply le_rev in Hltr. tinv Hltr.
Qed.


(* -*- mode: coq; mode: visual-line -*-  *)
(** * Localization *)

Require Import HoTT.Basics HoTT.Types.
Require Import Extensions.
Require Import ReflectiveSubuniverse Accessible.

Local Open Scope nat_scope.
Local Open Scope path_scope.

(** Suppose given a family of maps [f : forall (i:I), S i -> T i].  A type [X] is said to be [f]-local if for all [i:I], the map [(T i -> X) -> (S i -> X)] given by precomposition with [f i] is an equivalence.  Our goal is to show that the [f]-local types form a reflective subuniverse, with a reflector constructed by localization.  That is, morally we want to say

<<
Inductive Localize f (X : Type) : Type :=
| loc : X -> Localize X
| islocal_localize : forall i, IsEquiv (fun (g : T i -> X) => g o f i).
>>

This is not a valid HIT by the usual rules, but if we expand out the definition of [IsEquiv] and apply [path_sigma] and [path_forall], then it becomes one.  We get a simpler definition (no 2-path constructors) if we do this with [BiInv] rather than [IsEquiv]:

<<
Inductive Localize f (X : Type) : Type :=
| loc : X -> Localize X
| lsect : forall i (g : S i -> X), T i -> X
| lissect : forall i (g : S i -> X) (s : S i), lsect i g (f i s) = g s
| lretr : forall i (g : S i -> X), T i -> X
| lisretr : forall i (h : T i -> X) (t : T i), lretr i (h o f i) t = h t.
>>

This definition works, and from it one can prove that the [f]-local types form a reflective subuniverse.  However, the proof inextricably involves [Funext].  We can avoid [Funext] in the same way that we did in the definition of a [ReflectiveSubuniverse], by using pointwise path-split precomposition equivalences.  Observe that the assertion [ExtendableAlong n f C] consists entirely of points, paths, and higher paths in [C].  Therefore, for any [n] we might choose, we can define [Localize f X] as a HIT to universally force [ExtendableAlong n (f i) (fun _ => Localize f X)] to hold for all [i].  For instance, when [n] is 2 (the smallest value which will ensure that [Localize f X] is actually [f]-local), we get

<<
Inductive Localize f (X : Type) : Type :=
| loc : X -> Localize X
| lrec : forall i (g : S i -> X), T i -> X
| lrec_beta : forall i (g : S i -> X) (s : T i), lrec i g (f i s) = g s
| lindpaths : forall i (h k : T i -> X) (p : h o f i == k o f i) (t : T i), h t = k t
| lindpaths_beta : forall i (h k : T i -> X) (p : h o f i == k o f i) (s : S i),
                     lindpaths i h k p (f i s) = p s.
>>

However, just as for [ReflectiveSubuniverse], in order to completely avoid [Funext] we need the [oo]-version of path-splitness.  Written out as above, this would involve infinitely many constructors (but it would not otherwise be problematic, so for instance it can be constructed semantically in model categories).  We can't actually write out infinitely many constructors in Coq, of course, but since we have a finite definition of [ooExtendableAlong], we can just assert directly that [ooExtendableAlong (f i) (fun _ => Localize f X)] holds for all [i].

Then, however, we have to express the hypotheses of the induction principle.  We know what these should be for each path-constructor and higher path-constructor, so all we need is a way to package up those infinitely many hypotheses into a single one, analogously to [ooExtendableAlong].  Thus, we begin this file by defining a "dependent" version of [ooExtendableAlong], and of course we start this with a version for finite [n].  *)

(** ** Dependent extendability *)

Fixpoint ExtendableAlong_Over@{a b c d m}
         (n : nat) {A : Type@{a}} {B : Type@{b}} (f : A -> B)
         (C : B -> Type@{c})
         (D : forall b, C b -> Type@{d})
         (ext : ExtendableAlong@{a b c m} n f C)
: Type@{m}
  := match n return ExtendableAlong@{a b c m} n f C -> Type@{m} with
       | 0 => fun _ => Unit
       | S n => fun ext' =>
                (forall (g : forall a, C (f a)) (g' : forall a, D (f a) (g a)),
                  sig@{m m}     (** Control universe parameters *)
                  (fun (rec : forall b, D b ((fst ext' g).1 b)) =>
                         forall a, (fst ext' g).2 a # rec (f a) = g' a )) *
                forall (h k : forall b, C b)
                       (h' : forall b, D b (h b)) (k' : forall b, D b (k b)),
                  ExtendableAlong_Over n f (fun b => h b = k b)
                    (fun b c => c # h' b = k' b) (snd ext' h k)
     end ext.
Check ExtendableAlong_Over@{a b c d m}.
(** [ExtendableAlong_Over] takes 5 universe parameters:
    - size of A
    - size of B
    - size of C
    - size of D
    - size of result (>= A,B,C,D) *)

(** Like [ExtendableAlong], these can be postcomposed with known equivalences. *)
Definition extendable_over_postcompose' (n : nat)
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ExtendableAlong n f C)
           (D E : forall b, C b -> Type)
           (g : forall b c, D b c <~> E b c)
: ExtendableAlong_Over n f C D ext
  -> ExtendableAlong_Over n f C E ext.
Proof.
  revert C ext D E g; simple_induction n n IHn; intros C ext D E g; simpl.
  1:by apply idmap.
  intros ext'.
  split.
  - intros h k.
    exists (fun b => g b ((fst ext h).1 b)
                     ((fst ext' h (fun a => (g _ _)^-1 (k a))).1 b)).
    intros a.
    refine ((ap_transport ((fst ext h).2 a) (g (f a)) _)^ @ _).
    apply moveR_equiv_M.
    exact ((fst ext' h (fun a => (g _ _)^-1 (k a))).2 a).
  - intros p q p' q'.
    refine (IHn (fun b => p b = q b) _
                (fun b => fun c => transport (D b) c ((g b (p b))^-1 (p' b))
                                   = ((g b (q b))^-1 (q' b)))
                _ _
                (snd ext' p q (fun b => (g b (p b))^-1 (p' b))
                              (fun b => (g b (q b))^-1 (q' b)))).
    intros b c.
    refine (_ oE equiv_moveR_equiv_M _ _).
    apply equiv_concat_l.
    refine (_ @ (ap_transport c (g b) _)^).
    apply ap, symmetry, eisretr.
Defined.

Definition extendable_over_postcompose (n : nat)
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ExtendableAlong n f C)
           (D E : forall b, C b -> Type)
           (g : forall b c, D b c -> E b c)
           `{forall b c, IsEquiv (g b c)}
: ExtendableAlong_Over n f C D ext
  -> ExtendableAlong_Over n f C E ext
:= extendable_over_postcompose' n C f ext D E
     (fun b c => Build_Equiv _ _ (g b c) _).

(** And if the dependency is trivial, we obtain them from an ordinary [ExtendableAlong]. *)
Definition extendable_over_const
           (n : nat) {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ExtendableAlong n f C) (D : B -> Type)
: ExtendableAlong n f D
  -> ExtendableAlong_Over n f C (fun b _ => D b) ext.
Proof.
  revert C ext D.
  simple_induction n n IHn; intros C ext D ext'.
  1:exact tt.
  split.
  - intros g g'.
    exists ((fst ext' g').1).
    exact (fun a => transport_const ((fst ext g).2 a) _
                                    @ (fst ext' g').2 a).
  - intros h k h' k'.
    refine (extendable_over_postcompose' _ _ _ _ _ _ _
              (IHn (fun b => h b = k b) (snd ext h k)
                   (fun b => h' b = k' b) (snd ext' h' k'))).
    exact (fun b c => equiv_concat_l (transport_const c (h' b)) (k' b)).
Defined.

(** This lemma will be used in stating the computation rule for localization. *)
Fixpoint apD_extendable_eq (n : nat) {A B : Type} (C : B -> Type) (f : A -> B)
         (ext : ExtendableAlong n f C) (D : forall b, C b -> Type)
         (g : forall b c, D b c)
         (ext' : ExtendableAlong_Over n f C D ext)
         {struct n}
: Type.
Proof.
  destruct n.
  - exact Unit.
  - apply prod.
    + exact (forall (h : forall a, C (f a)) (b : B),
               g b ((fst ext h).1 b) = (fst ext' h (fun a => g (f a) (h a))).1 b).
    + exact (forall h k, apD_extendable_eq
                           n A B (fun b => h b = k b) f (snd ext h k)
                           (fun b c => c # g b (h b) = g b (k b))
                           (fun b c => apD (g b) c)
                           (snd ext' h k _ _)).
Defined.

(** Here's the [oo]-version. *)
Definition ooExtendableAlong_Over
         {A B : Type} (f : A -> B) (C : B -> Type)
         (D : forall b, C b -> Type) (ext : ooExtendableAlong f C)
  := forall n, ExtendableAlong_Over n f C D (ext n).
(** Universe parameters are the same as for [ExtendableAlong_Over]. *)
Check ooExtendableAlong_Over@{a b c d r}.

(** The [oo]-version for trivial dependency. *)
Definition ooextendable_over_const
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ooExtendableAlong f C) (D : B -> Type)
: ooExtendableAlong f D
  -> ooExtendableAlong_Over f C (fun b _ => D b) ext
:= fun ext' n => extendable_over_const n C f (ext n) D (ext' n).

(** A crucial fact: the [oo]-version is inherited by types of homotopies. *)
Definition ooextendable_over_homotopy
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ooExtendableAlong f C)
           (D : forall b, C b -> Type)
           (r s : forall b c, D b c)
: ooExtendableAlong_Over f C D ext
  -> ooExtendableAlong_Over f C (fun b c => r b c = s b c) ext.
Proof.
  intros ext' n.
  revert C ext D r s ext'.
  simple_induction n n IHn; intros C ext D r s ext'.
  1:exact tt.
  split.
  - intros g g'.
    simple refine (_;_); simpl.
    + intros b.
      refine (_ @ (fst (snd (ext' 2) _ _
                            (fun b' => r b' ((fst (ext n.+1) g).1 b'))
                            (fun b' => s b' ((fst (ext n.+1) g).1 b')))
                       (fun _ => 1) _).1 b).
      * refine (transport2 (D b) (p := 1) _ _).
        refine ((fst (snd (snd (ext 3) _ _) (fun b' => 1)
                          ((fst (snd (ext 2) _ _) (fun a : A => 1)).1)
                ) _).1 b); intros a.
        symmetry; refine ((fst (snd (ext 2) _ _) (fun a' => 1)).2 a).
      * intros a; simpl.
        refine (_ @
          ap (transport (D (f a)) ((fst (ext n.+1) g).2 a)^) (g' a)
          @ _);
        [ symmetry; by apply apD
        | by apply apD ].
    + intros a; simpl.
      set (h := (fst (ext n.+1) g).1).
      match goal with
          |- context[   (fst (snd (ext' 2) _ _ ?k1 ?k2) (fun _ => 1) ?l).1 ]
          => pose (p := (fst (snd (ext' 2) _ _  k1  k2) (fun _ => 1) l).2 a);
            simpl in p
      end.
      rewrite transport_paths_Fl in p.
      apply moveL_Mp in p.
      refine (ap (transport _ _) (1 @@ p) @ _); clear p.
      unfold transport2; rewrite concat_p_pp.
      match goal with
          |- transport ?P ?p ((ap ?f ?q @ ap ?f ?r) @ ?s) = ?t
          => refine (ap (transport P p) ((ap_pp f q r)^ @@ (idpath s)) @ _)
      end.
      pose (p := (fst (snd (snd (ext 3) h h) (fun b' : B => 1)
                           ((fst (snd (ext 2) h h) (fun a0 : A => 1)).1))
                      (fun a' : A => ((fst (snd (ext 2) h h)
                                           (fun a' : A => 1)).2 a')^)).2 a);
        simpl in p.
      refine (ap (transport _ _) (ap (ap _) (p @@ 1) @@ 1) @ _); clear p.
      rewrite concat_Vp; simpl; rewrite concat_1p.
      refine (transport_paths_FlFr_D _ _ @ _).
      Open Scope long_path_scope.
      Local Opaque transport_pV. (* work around bug 4533 *)
      rewrite !ap_pp, !concat_p_pp, ap_transport_pV, !concat_p_pp.
      Local Transparent transport_pV. (* work around bug 4533 *)
      refine ((((_  @@ 1) @ concat_1p _) @@ 1 @@ 1 @@ 1) @ _).
      * rewrite ap_V, concat_pp_p.
        do 2 apply moveR_Vp.
        rewrite concat_p1.
        symmetry; apply transport_pV_ap.
      * rewrite !concat_pp_p.
        refine ((1 @@ _) @ (concat_p1 _)).
        apply moveR_Vp; rewrite concat_p1.
        apply transport_pV_ap.
      Close Scope long_path_scope.
  - intros h k h' k'.
    refine (extendable_over_postcompose' _ _ _ _ _ _
             (fun b c => equiv_cancelL (apD (r b) c) _ _) _).
    refine (IHn _ _ _ _ _
                (fun n => snd (ext' n.+1) h k
                              (fun b => r b (h b)) (fun b => s b (k b)))).
Qed.

(** ** Local types *)

Import IsLocal_Internal.

Definition islocal_equiv_islocal (f : LocalGenerators@{a})
           (X : Type@{i}) {Y : Type@{j}}
           (Xloc : IsLocal@{i i' a} f X)
           (g : X -> Y) `{IsEquiv@{i j} _ _ g}
: IsLocal@{j j' a} f Y.
Proof.
  intros i.
  (** We have to fiddle with the max universes to get this to work, since [ooextendable_postcompose] requires the max universe in both cases to be the same, whereas we don't want to assume that the hypothesis and conclusion are related in any way. *)
  apply lift_ooextendablealong@{a a a a a a j j j k j'}.
  refine (ooextendable_postcompose@{a a i j k k k k k k}
            _ _ (f i) (fun _ => g) _).
  apply lift_ooextendablealong@{a a a a a a i i i i' k}.
  apply Xloc.
Defined.

(** ** Localization as a HIT *)

Module Export LocalizationHIT.

  Cumulative Private Inductive Localize (f : LocalGenerators@{a}) (X : Type@{i})
  : Type@{max(a,i)} :=
  | loc : X -> Localize f X.

  Arguments loc {f X} x.

  (** Note that the following axiom actually contains a point-constructor.  We could separate out that point-constructor and make it an actual argument of the private inductive type, thereby getting a judgmental computation rule for it.  However, since locality is an hprop, there seems little point to this. *)
  Axiom islocal_localize
  : forall (f : LocalGenerators@{a}) (X : Type@{i}),
      IsLocal@{i k a} f (Localize f X).

  Definition Localize_ind
           (f : LocalGenerators@{a}) (X : Type@{i})
           (P : Localize f X -> Type@{j})
           (loc' : forall x, P (loc x))
           (islocal' : forall i, ooExtendableAlong_Over@{a a i j k}
                                   (f i) (fun _ => Localize@{a i} f X)
                                   (fun _ => P)
                                   (islocal_localize@{a i k} f X i))
           (z : Localize f X)
  : P z
    := match z with
         | loc x => fun _ => loc' x
       end islocal'.

  (** We now state the computation rule for [islocal_localize].  Since locality is an hprop, we never actually have any use for it, but the fact that we can state it is a reassuring check that we have defined a meaningful HIT. *)
  Axiom Localize_ind_islocal_localize_beta :
    forall (f : LocalGenerators) (X : Type)
           (P : Localize f X -> Type)
           (loc' : forall x, P (loc x))
           (islocal' : forall i, ooExtendableAlong_Over
                                   (f i) (fun _ => Localize f X)
                                   (fun _ => P)
                                   (islocal_localize f X i))
           i n,
      apD_extendable_eq n (fun _ => Localize f X) (f i)
                        (islocal_localize f X i n) (fun _ => P)
                        (fun _ => Localize_ind f X P loc' islocal')
                        (islocal' i n).

End LocalizationHIT.

(** Now we prove that localization is a reflective subuniverse. *)

Section Localization.

  Context (f : LocalGenerators).

  (** The induction principle is an equivalence. *)
  Definition ext_localize_ind (X : Type)
      (P : Localize f X -> Type)
      (Ploc : forall i, ooExtendableAlong_Over
                          (f i) (fun _ => Localize f X)
                          (fun _ => P) (islocal_localize f X i))
  : ooExtendableAlong loc P.
  Proof.
    intros n; generalize dependent P.
    simple_induction n n IHn; intros P Ploc.
    1:exact tt.
    split.
    - intros g.
      exists (Localize_ind f X P g Ploc).
      intros x; reflexivity.
    - intros h k; apply IHn; intros i m.
      apply ooextendable_over_homotopy.
      exact (Ploc i).
  Defined.

End Localization.

Definition Loc@{a i} (f : LocalGenerators@{a}) : ReflectiveSubuniverse@{i}.
Proof.
  simple notypeclasses refine (Build_ReflectiveSubuniverse
                                 (Build_Subuniverse (IsLocal f) _ _)
                                 (fun A => Build_PreReflects _ A (Localize f A) _ (@loc f A))
                                 (fun A => Build_Reflects _ _ _ _)).
  - (** Typeclass inference can find this, but we give it explicitly to prevent extra universes from cropping up. *)
    intros ? T; unfold IsLocal.
    nrefine (istrunc_forall@{a i i}); try assumption.
    intros i.
    apply ishprop_ooextendable@{a a i i i
                                i i i i i
                                i i i i i}.
  - apply islocal_equiv_islocal.
  - apply islocal_localize.
  - cbn. intros Q Q_inO.
    apply ext_localize_ind; intros ?.
    apply ooextendable_over_const.
    apply Q_inO.
Defined.

(** Here is the "real" definition of the notation [IsLocal].  Defining it this way allows it to inherit typeclass inference from [In], unlike (for instance) the slightly annoying case of [IsTrunc n] versus [In (Tr n)]. *)
Notation IsLocal f := (In (Loc f)).

Section LocalTypes.
  Context (f : LocalGenerators).

  (** A remark on universes: recall that [ooExtendableAlong] takes four universe parameters, three for the sizes of the types involved and one for the max of all of them.  In the definition of [IsLocal f X] we set that max universe to be the same as the size of [X], so that [In (Loc f) X] would lie in the same universes as [X], which is necessary for our definition of a reflective subuniverse.  However, in practice we may need this extendability property with the max universe being larger, to avoid coalescing universes undesiredly.  Thus, in making it available by the following name, we also insert a [lift] to generalize the max universe. *)
  Definition ooextendable_islocal {X : Type@{i}} {Xloc : IsLocal f X} i
  : ooExtendableAlong@{a a i k} (f i) (fun _ => X)
    := (lift_ooextendablealong _ _ (Xloc i)).

  Global Instance islocal_loc (X : Type) : IsLocal f (Localize f X)
    := islocal_localize f X.

  Global Instance isequiv_precomp_islocal `{Funext}
         {X : Type} `{IsLocal f X} i
  : IsEquiv (fun g => g o f i)
  := isequiv_ooextendable (fun _ => X) (f i) (ooextendable_islocal i).

  (** The non-dependent eliminator *)
  Definition Localize_rec {X Z : Type} `{IsLocal f Z} (g : X -> Z)
  : Localize f X -> Z.
  Proof.
    refine (Localize_ind f X (fun _ => Z) g _); intros i.
    apply ooextendable_over_const.
    apply ooextendable_islocal.
  Defined.

  Definition local_rec {X} `{IsLocal f X} {i} (g : lgen_domain f i -> X)
  : lgen_codomain f i -> X
  := (fst (ooextendable_islocal i 1%nat) g).1.

  Definition local_rec_beta {X} `{IsLocal f X} {i} (g : lgen_domain f i -> X) s
  : local_rec g (f i s) = g s
    := (fst (ooextendable_islocal i 1%nat) g).2 s.

  Definition local_indpaths {X} `{IsLocal f X} {i} {h k : lgen_codomain f i -> X}
             (p : h o f i == k o f i)
  : h == k
    := (fst (snd (ooextendable_islocal i 2) h k) p).1.

  Definition local_indpaths_beta {X} `{IsLocal f X} {i} (h k : lgen_codomain f i -> X)
             (p : h o f i == k o f i) s
  : local_indpaths p (f i s) = p s
    := (fst (snd (ooextendable_islocal i 2) h k) p).2 s.

End LocalTypes.

Arguments local_rec : simpl never.
Arguments local_rec_beta : simpl never.
Arguments local_indpaths : simpl never.
Arguments local_indpaths_beta : simpl never.

(** ** Localization and accessibility *)

(** Localization subuniverses are accessible, essentially by definition.  Without the universe annotations, [a] and [i] get collapsed. *)
Global Instance accrsu_loc@{a i} (f : LocalGenerators@{a}) : IsAccRSU@{a i} (Loc@{a i} f).
Proof.
  unshelve econstructor.
  - exact f.
  - intros; split; apply idmap.
Defined.

(** Conversely, if a subuniverse is accessible, then the corresponding localization subuniverse is equivalent to it, and moreover exists at every universe level and satisfies its computation rules judgmentally.  This is called [lift_accrsu] but in fact it works equally well to *lower* the universe level, as long as both levels are no smaller than the size [a] of the generators. *)
Definition lift_accrsu@{a i j} (O : Subuniverse@{i}) `{IsAccRSU@{a i} O}
  : ReflectiveSubuniverse@{j}
  := Loc@{a j} (acc_lgen O).

(** The lifted universe agrees with the original one, on any universe contained in both [i] and [j] *)
Global Instance O_eq_lift_accrsu@{a i j k} (O : Subuniverse@{i}) `{IsAccRSU@{a i} O}
  : O_eq@{i j k} O (lift_accrsu@{a i j} O).
Proof.
  (** Anyone stepping through this proof should do [Set Printing Universes]. *)
  split; intros A A_inO.
  - intros i.
    assert (e := fst (inO_iff_islocal O A) A_inO i).
    apply (lift_ooextendablealong@{a a a a a a i j k i j} (acc_lgen O i) (fun _ => A)).
    exact e.
  - apply (inO_iff_islocal O).
    intros i.
    pose (e := A_inO i).
    apply (lift_ooextendablealong@{a a a a a a j i k j i} (acc_lgen O i) (fun _ => A)).
    exact e.
Defined.

Definition O_leq_lift_accrsu@{a i1 i2}
           (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1}
           `{O_leq@{i1 i2 i2} O1 O2}
  : O_leq@{i2 i2 i2} (lift_accrsu@{a i1 i2} O1) O2.
Proof.
  intros B B_inO1.
  apply (inO_leq@{i1 i2 i2} O1 O2).
  apply (snd (inO_iff_islocal O1 B)).
  intros i. specialize (B_inO1 i).
  apply (lift_ooextendablealong@{a a a a a a i2 i1 i2 i2 i1} (acc_lgen O1 i) (fun _ => B)).
  exact B_inO1.
Defined.

(** Similarly, because localization is a HIT that has an elimination rule into types in *all* universes, for accessible reflective subuniverses we can show that containment implies connectedness properties with the universe containments in the other order. *)
Definition isconnected_O_leq'@{a i1 i2}
           (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1}
           (** Compared to [O_leq@{i1 i2 i1}] and [A : Type@{i1}] in [isconnected_O_leq], these two lines are what make [i2 <= i1] instead of vice versa. *)
           `{O_leq@{i1 i2 i2} O1 O2} (A : Type@{i2})
           `{IsConnected O2 A}
  : IsConnected O1 A.
Proof.
  (** Anyone stepping through this proof should do [Set Printing Universes]. *)
  srefine (isconnected_O_leq O1 (lift_accrsu@{a i1 i1} O1) A).
  1-2:exact _.
  change (Contr@{i1} (Localize@{a i2} (acc_lgen@{a i1} O1) A)).
  (** At this point you should also do [Unset Printing Notations] to see the universe annotation on [IsTrunc] change. *)
  refine (contr_equiv'@{i2 i1} _ 1%equiv).
  change (IsConnected@{i2} (lift_accrsu@{a i1 i2} O1) A).
  srapply (isconnected_O_leq _ O2).
  rapply O_leq_lift_accrsu.
Defined.

(** And similarly for connected maps. *)
Definition conn_map_O_leq'@{a i1 i2}
           (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1}
           `{O_leq@{i1 i2 i2} O1 O2} {A B : Type@{i2}}
           (f : A -> B) `{IsConnMap O2 A B f}
  : IsConnMap O1 f.
Proof.
  (** Anyone stepping through this proof should do [Set Printing Universes]. *)
  intros b.
  apply (isconnected_equiv' O1 (hfiber@{i2 i2} f b)).
  - srapply equiv_adjointify.
    1-2:intros [u p]; exact (u;p).
    all:intros [u p]; reflexivity.
  - apply (isconnected_O_leq' O1 O2).
    apply isconnected_hfiber_conn_map.
Defined.

(** The same is true for inverted maps, too. *)
Definition O_inverts_O_leq'@{a i1 i2}
           (O1 : ReflectiveSubuniverse@{i1}) (O2 : ReflectiveSubuniverse@{i2}) `{IsAccRSU@{a i1} O1}
           `{O_leq@{i1 i2 i2} O1 O2} {A B : Type@{i2}}
           (f : A -> B) `{O_inverts O2 f}
  : O_inverts O1 f.
Proof.
  assert (oleq := O_leq_lift_accrsu O1 O2).
  assert (e := O_inverts_O_leq (lift_accrsu@{a i1 i2} O1) O2 f); clear oleq.
  nrapply (O_inverts_O_leq O1 (lift_accrsu@{a i1 i1} O1) f).
  1:exact _.
  (** It looks like we can say [exact e], but that would collapse the universes [i1] and [i2].  You can check with [Set Printing Universes. Unset Printing Notations.] that [e] and the goal have different universes.  So instead we do this: *)
  refine (@isequiv_homotopic _ _ _ _ e _).
  apply O_indpaths; intros x; reflexivity.
Defined.


(*
   雪江明彦「代数学1群論入門」日本評論社
   本文に沿って、coqにて展開する。

   2011_03_19 Sectionを使い、群に共通の定義をまとめて定義した。
   2011_03_20 Ltac でtacticsをまとめた。
   *)

Require Import Setoid.                      (* rewrite at *)

Section Group.
  Variable G : Set.
  (* 演算子 *)
  Variable App : G -> G -> G.
  Infix "**" := App (at level 61, left associativity).
  (* 定義 2.1.1 (1) *) (* 単位元 *)
  Variable E : G.
  (* 定義 2.1.1 (2) *) (* 逆元 *)
  Variable Inv : G -> G.

  (* 定義 2.1.1 (1) *) (* 単位元 *)
  Axiom identity_r :
    forall x, x ** E = x.
  Axiom identity_l :
    forall x, E ** x = x.

  (* 定義 2.1.1 (2) *) (* 逆元 *)
  Axiom inverse_r :
    forall x, x ** (Inv x) = E.
  Axiom inverse_l :
    forall x, (Inv x) ** x = E.

  (* 定義 2.1.1 (3) *) (* 結合則 *)
  Axiom associative_law :
    forall x y z, x ** (y ** z) = (x ** y) ** z.

  (* 暗黙の裏公理。両辺にxを掛ける *)
  Axiom right_law :
    forall a b x, a = b -> a ** x = b ** x.
  Axiom left_law :
    forall a b x, a = b -> x ** a = x ** b.

  (* 例題 2.1.7 *)
  Goal forall x y z w : G,
    x ** ((y ** z) ** w) = (x ** y) ** (z ** w).
  Proof.
    intros.
    rewrite <- associative_law.
    rewrite associative_law.
    reflexivity.
  Qed.

  Ltac insert_inv_l B A :=                  (* B の左に (Inv A) ** A を掛ける *)
    rewrite <- (identity_l B);
      rewrite <- (inverse_l A).

  Ltac insert_inv_r B A :=                  (* B の右に A ** (Inv A) を掛ける *)
    rewrite <- (identity_r B);
      rewrite <- (inverse_r A).

  (* 命題 2.1.8 (1) *) (* 簡約法則 *)
  Theorem reduce_law_l :
    forall a b c : G, a ** b = a ** c -> b = c.
  Proof.
    intros.
    insert_inv_l b a.
    insert_inv_l c a.
    rewrite <- associative_law.
    rewrite <- associative_law.
    eapply (left_law _ _ (Inv a)).
    apply H.
  Qed.

  Theorem reduce_law_r :
    forall b c a : G, b ** a = c ** a -> b = c.
  Proof.
    intros.
    insert_inv_r b a.
    insert_inv_r c a.
    rewrite associative_law.
    rewrite associative_law.
    eapply (right_law _ _ (Inv a)).
    apply H.
  Qed.

  (*
     b = Inv a ** c
     --------------
     a ** b = c
     *)
  Ltac r_to_l A :=
    eapply (reduce_law_l A _ _);
      repeat (rewrite associative_law);
        try (rewrite inverse_r);            (* rewrite (inverse_r a). *)
          try (rewrite inverse_l);          (* 実行されないかも *)
            try (rewrite identity_l).       (* rewrite (identity_l c). *)

  (*
     a = c ** Inv b
     --------------
     a ** b = c
     *)
  Ltac l_to_r B :=
    eapply (reduce_law_r _ _ B);
      repeat (rewrite <- associative_law);
        try (rewrite inverse_l);            (* rewrite (inverse_l b). *)
          try (rewrite inverse_r);          (* 実行されないかも *)
            try (rewrite identity_r).       (* rewrite (identity_r c). *)

  (* 命題 2.1.8 (2) *)
  Goal forall a b c,
    a ** b = c -> b = (Inv a) ** c.
  Proof.
    intros.
    r_to_l a.
    apply H.
  Qed.

  Goal forall a b c,
    a ** b = c -> a = c ** (Inv b).
  Proof.
    intros.
    l_to_r b.
    apply H.
  Qed.

  (* 例題 2.1.9 *)
  Goal forall x y z,
    x ** (Inv y) ** z ** x ** y ** x = E ->
    z = y ** (Inv x) ** (Inv x) ** (Inv y) ** (Inv x).
  Proof.
    intros.
    r_to_l (Inv y).
    (*
       eapply (reduce_law_l (Inv y) _ _).
       repeat rewrite associative_law.
       rewrite inverse_l.
       rewrite identity_l.
       *)
    r_to_l x.
    (*
       eapply (reduce_law_l x _ _).
       repeat rewrite associative_law.
       rewrite inverse_r.
       rewrite identity_l.
       *)
    l_to_r x.
    (*
       eapply (reduce_law_r _ _ x).
       repeat rewrite <- associative_law.
       rewrite inverse_l.
       rewrite identity_r.
       *)
    l_to_r y.
    (*
       eapply (reduce_law_r _ _ y).
       repeat rewrite <- associative_law.
       rewrite inverse_l.
       rewrite identity_r.
       *)
    l_to_r x.
    (*
       eapply (reduce_law_r _ _ x).
       repeat rewrite <- associative_law.
       rewrite inverse_l.
       *)
    repeat rewrite associative_law.
    apply H.
  Qed.

  (* 命題 2.1.10 (1) *) (* 単位元の唯一性 *)
  Theorem identity_uniqueness :
    forall x E',
      E' ** x = x -> E' = E.
  Proof.
    intros.
    eapply (reduce_law_r _ _ x).
    rewrite (identity_l x).
    apply H.
  Qed.

  (* 命題 2.1.10 (2) *) (* 逆元の一意性 *)
  Goal forall b b',
    b ** b' = E -> b' = Inv b.
  Proof.
    intros.
    eapply (reduce_law_l b _ _).
    rewrite inverse_r.
    apply H.
  Qed.

  (* 命題 2.1.10 (3) *)
  Theorem inv_inv:
    forall a b,
      (Inv b) ** (Inv a) = Inv (a ** b).
  Proof.
    assert (forall a b, (Inv b) ** (Inv a) ** a ** b = E).
    intros.
    r_to_l b.
    (*
       apply (reduce_law_l b _ _).
       repeat rewrite associative_law.
       rewrite inverse_r.
       rewrite identity_l.
       *)
    rewrite identity_r.
    r_to_l a.
    (*
       apply (reduce_law_l a _ _).
       repeat rewrite associative_law.
       rewrite inverse_r.
       rewrite identity_l.
       *)
    reflexivity.
    (* END assert *)

    intros.
    apply (reduce_law_r _ _ (a ** b)).
    rewrite (inverse_l (a ** b)).
    repeat rewrite associative_law.
    eapply H.
  Qed.

  (* 命題 2.1.10 (4) *)
  Axiom inverse_inverse :
    forall x, Inv (Inv x) = x.
End Group.

(* 群 G *)
Variable G : Set.
(* 演算子 *)
Variable AppG : G -> G -> G.
Infix "**" := AppG (at level 61, left associativity).
(* 定義 2.1.1 (1) *) (* 単位元 *)
Variable EG : G.
(* 定義 2.1.1 (2) *) (* 逆元 *)
Variable InvG : G -> G.
(* 公理や定理 *)
Let identity_g_r := identity_r G AppG EG.
Let identity_g_l := identity_l G AppG EG.
Check identity_g_l.
Let inverse_g_r := inverse_r G AppG EG InvG.
Let inverse_g_l := inverse_l G AppG EG InvG.
Check inverse_g_l.
Let associative_g_law := associative_law G AppG.
Let right_law_g := right_law G AppG.
Let left_law_g := left_law G AppG.
Let reduce_law_g_r :=  reduce_law_r G AppG EG InvG.
Let reduce_law_g_l :=  reduce_law_l G AppG EG InvG.
Check reduce_law_g_l.
Let inv_inv_g := inv_inv G AppG EG InvG.

(* 群 H *)
Variable H : Set.
Variable AppH : H -> H -> H.
Infix "++" := AppH (at level 61, left associativity).
Variable EH : H.
Variable InvH : H -> H.
Let identity_h_r := identity_r H AppH EH.
Let identity_h_l := identity_l H AppH EH.
Check identity_h_l.
Let inverse_h_r := inverse_r H AppH EH InvH.
Let inverse_h_l := inverse_l H AppH EH InvH.
Check inverse_h_l.
Let associative_h_law := associative_law H AppH.
Let right_law_h := right_law H AppH.
Let left_law_h := left_law H AppH.
Let reduce_law_h_r :=  reduce_law_r H AppH EH InvH.
Let reduce_law_h_l :=  reduce_law_l H AppH EH InvH.

(* phi : G -> H が群の準同型写像 *)
Variable phi : G -> H.

Axiom homomorphism_phi :
  forall a b : G, phi (a ** b) = (phi a) ++ (phi b).

(* 命題 2.5.2 *)
(* 全単射写像 phi : G -> H が群の準同型写像なら、GとHは同型である *)

(* phi が全単射なら、phi は単射である。 *)
Axiom injective_phi :
  forall a b, (phi a) = (phi b) -> a = b.

(* phi が全単射なら、逆写像 psi が存在する *)
Variable psi : H -> G.
Axiom inverse_phi :
  forall x, phi (psi x) = x.

(* 逆写像 psi は準同型写像である。 *)
Lemma t_2_5_2 :
  forall x y,
    (psi x) ** (psi y) = psi (x ++ y).
Proof.
  intros.
  apply injective_phi.
  rewrite inverse_phi.
  rewrite homomorphism_phi.
  rewrite inverse_phi.
  rewrite inverse_phi.
  reflexivity.
Qed.
(*
   題意から、phi : G -> H は準同型写像である。
   Lemma t_2_5_2から、phiの逆写像 psi : H -> G は準同型写像である。
   写像とその逆写像の両方が準同型写像であるので、G と H は同型である。
   *)

Theorem homomorphism_phi_identity :
  phi EG = EH.
Proof.
  eapply (reduce_law_h_r _ _ (phi EG)).
  rewrite identity_h_l.
  rewrite <- homomorphism_phi.
  rewrite identity_g_l.
  reflexivity.
Qed.

(* 命題 2.5.3 (2) *)
Theorem homomorphism_phi_inverse :
  forall x, phi (InvG x) = InvH (phi x).
Proof.
  intros.
  eapply (reduce_law_h_r _ _ (phi x)).
  rewrite inverse_h_l.
  rewrite <- homomorphism_phi.
  rewrite inverse_g_l.
  apply homomorphism_phi_identity.
Qed.

(* Img(phi) = {(phi x) | x : G} は、Hの(部分)群である *)
Goal forall x y, exists z,
  (phi x) ++ (phi y) = phi z.
Proof.
  intros.
  exists (x ** y).
  rewrite <- homomorphism_phi.
  reflexivity.
Qed.

Goal forall x, exists y,
  InvH (phi x) = phi y.
Proof.
  intros.
  exists (InvG x).
  rewrite <- homomorphism_phi_inverse.
  reflexivity.
Qed.

(* 恒等写像は、準同型写像である *)
Variable IdG : G -> G.
Axiom Identity_function : forall a, a = IdG a.

Goal forall x y : G, (IdG x) ** (IdG y) = IdG (x ** y).
Proof.
  intros.
  repeat (rewrite <- Identity_function).
  reflexivity.
Qed.

(* 群GからGへの同型写像をGの自己同型写像とよぶ。その集合をAut(G)で表す。
   恒等写像は同型写像であるから、自己同型写像である。IdG∈Aut(G)。
   同型写像と同型写像の合成の演算を @@ とおく。
   自己同型写像は @@ に対して閉じている（同型でなくても閉じているから）。
   自己同型写像の集合 Aut(G) は、IdG を単位元とした群である。
*)

(* 命題 2.5.17 *)
(* Tht : G -> Aut(G) を下記のとおり定義する。
   （g∈Gに対して、(Tht g)∈Aut(G)である）
   任意のgが固定されたとき、(Tht g)は、群Gの自己同型写像であることを示す。
   *)

Variable Tht : G -> (G -> G).               (* G -> Aut(G) *)
Axiom define_tht :
  forall g h : G, Tht g h = g ** h ** (InvG g).

Lemma p2_5_17 : forall g h1 h2 : G,
  Tht g (h1 ** h2) = (Tht g h1) ** (Tht g h2).
Proof.
  intros.
  repeat (rewrite define_tht).
  repeat (rewrite associative_g_law).
  rewrite <- associative_g_law at 1.
  (* rewriteはできるところはすべてrewriteするので、最初のところだけに限定する。 *)
  rewrite <- (identity_g_l (h2 ** InvG g)).
  rewrite <- (inverse_g_l g).
  repeat (rewrite associative_g_law).
  reflexivity.
Qed.

(* 命題 2.5.22 *)
(* Tht : G -> Aut(G) を上記のとおり定義する。
   （g∈Gに対して、(Tht g)∈Aut(G)である）
   Thtは、群Gから群Aut(G)への準同型写像であることを示す。
   ただし、群Aut(G)の積は、写像の合成（以下のDot）で定義する。
*)

Variable Dot : (G -> G) -> (G -> G) -> (G -> G).
Infix "@@" := Dot (at level 51, right associativity).
Axiom define_dot :
  forall f g : G -> G,
    forall x : G, (f @@ g) x = f (g x).

Lemma p2_5_22 : forall g1 g2 h : G,
  ((Tht g1) @@ (Tht g2)) h = Tht (g1 ** g2) h.
Proof.
  intros.
  rewrite define_dot.
  repeat (rewrite define_tht).
  rewrite <- inv_inv_g.
  repeat (rewrite associative_g_law).
  reflexivity.
Qed.

(* END *)


From Hammer Require Import Hammer.

Require Export ZArith_base.
Require Import Zbool Omega ZArithRing Zcomplements Setoid Morphisms.
Local Open Scope Z_scope.

Notation Zdiv_eucl_POS := Z.pos_div_eucl (compat "8.3").
Notation Zdiv_eucl := Z.div_eucl (compat "8.3").
Notation Zdiv := Z.div (compat "8.3").
Notation Zmod := Z.modulo (compat "8.3").

Notation Zdiv_eucl_eq := Z.div_eucl_eq (compat "8.3").
Notation Z_div_mod_eq_full := Z.div_mod (compat "8.3").
Notation Zmod_POS_bound := Z.pos_div_eucl_bound (compat "8.3").
Notation Zmod_pos_bound := Z.mod_pos_bound (compat "8.3").
Notation Zmod_neg_bound := Z.mod_neg_bound (compat "8.3").

Lemma Z_div_mod_POS :
forall b:Z,
b > 0 ->
forall a:positive,
let (q, r) := Z.pos_div_eucl a b in Zpos a = b * q + r /\ 0 <= r < b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_mod_POS".
intros b Hb a. Z.swap_greater.
generalize (Z.pos_div_eucl_eq a b Hb) (Z.pos_div_eucl_bound a b Hb).
destruct Z.pos_div_eucl. rewrite Z.mul_comm. auto.
Qed.

Theorem Z_div_mod a b :
b > 0 ->
let (q, r) := Z.div_eucl a b in a = b * q + r /\ 0 <= r < b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_mod".
Z.swap_greater. intros Hb.
assert (Hb' : b<>0) by (now destruct b).
generalize (Z.div_eucl_eq a b Hb') (Z.mod_pos_bound a b Hb).
unfold Z.modulo. destruct Z.div_eucl. auto.
Qed.

Definition Remainder r b :=  0 <= r < b \/ b < r <= 0.

Definition Remainder_alt r b :=  Z.abs r < Z.abs b /\ Z.sgn r <> - Z.sgn b.

Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b.
Proof. hammer_hook "Zdiv" "Zdiv.Remainder_equiv".
intros; unfold Remainder, Remainder_alt; omega with *.
Qed.

Hint Unfold Remainder.

Theorem Z_div_mod_full a b :
b <> 0 ->
let (q, r) := Z.div_eucl a b in a = b * q + r /\ Remainder r b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_mod_full".
intros Hb.
generalize (Z.div_eucl_eq a b Hb)
(Z.mod_pos_bound a b) (Z.mod_neg_bound a b).
unfold Z.modulo. destruct Z.div_eucl as (q,r).
intros EQ POS NEG.
split; auto.
red; destruct b.
now destruct Hb. left; now apply POS. right; now apply NEG.
Qed.

Lemma Z_mod_remainder a b : b<>0 -> Remainder (a mod b) b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_remainder".
unfold Z.modulo; intros Hb; generalize (Z_div_mod_full a b Hb); auto.
destruct Z.div_eucl; tauto.
Qed.

Lemma Z_mod_lt a b : b > 0 -> 0 <= a mod b < b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_lt".  exact ((fun Hb => Z.mod_pos_bound a b (Z.gt_lt _ _ Hb))). Qed.

Lemma Z_mod_neg a b : b < 0 -> b < a mod b <= 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_neg".  exact ((Z.mod_neg_bound a b)). Qed.

Lemma Z_div_mod_eq a b : b > 0 -> a = b*(a/b) + (a mod b).
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_mod_eq".
intros Hb; apply Z.div_mod; auto with zarith.
Qed.

Lemma Zmod_eq_full a b : b<>0 -> a mod b = a - (a/b)*b.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_eq_full".   intros. rewrite Z.mul_comm. now apply Z.mod_eq. Qed.

Lemma Zmod_eq a b : b>0 -> a mod b = a - (a/b)*b.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_eq".   intros. apply Zmod_eq_full. now destruct b. Qed.

Theorem Zdiv_eucl_exist : forall (b:Z)(Hb:b>0)(a:Z),
{qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_eucl_exist".
intros b Hb a.
exists (Z.div_eucl a b).
exact (Z_div_mod a b Hb).
Qed.

Arguments Zdiv_eucl_exist : default implicits.

Theorem Zdiv_mod_unique b q1 q2 r1 r2 :
0 <= r1 < Z.abs b -> 0 <= r2 < Z.abs b ->
b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_mod_unique".
intros Hr1 Hr2 H. rewrite <- (Z.abs_sgn b), <- !Z.mul_assoc in H.
destruct (Z.div_mod_unique (Z.abs b) (Z.sgn b * q1) (Z.sgn b * q2) r1 r2); auto.
split; trivial.
apply Z.mul_cancel_l with (Z.sgn b); trivial.
rewrite Z.sgn_null_iff, <- Z.abs_0_iff. destruct Hr1; Z.order.
Qed.

Theorem Zdiv_mod_unique_2 :
forall b q1 q2 r1 r2:Z,
Remainder r1 b -> Remainder r2 b ->
b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_mod_unique_2".  exact (Z.div_mod_unique). Qed.

Theorem Zdiv_unique_full:
forall a b q r, Remainder r b ->
a = b*q + r -> q = a/b.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_unique_full".  exact (Z.div_unique). Qed.

Theorem Zdiv_unique:
forall a b q r, 0 <= r < b ->
a = b*q + r -> q = a/b.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_unique".   intros; eapply Zdiv_unique_full; eauto. Qed.

Theorem Zmod_unique_full:
forall a b q r, Remainder r b ->
a = b*q + r ->  r = a mod b.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_unique_full".  exact (Z.mod_unique). Qed.

Theorem Zmod_unique:
forall a b q r, 0 <= r < b ->
a = b*q + r -> r = a mod b.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_unique".   intros; eapply Zmod_unique_full; eauto. Qed.

Lemma Zmod_0_l: forall a, 0 mod a = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_0_l".
destruct a; simpl; auto.
Qed.

Lemma Zmod_0_r: forall a, a mod 0 = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_0_r".
destruct a; simpl; auto.
Qed.

Lemma Zdiv_0_l: forall a, 0/a = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_0_l".
destruct a; simpl; auto.
Qed.

Lemma Zdiv_0_r: forall a, a/0 = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_0_r".
destruct a; simpl; auto.
Qed.

Ltac zero_or_not a :=
destruct (Z.eq_dec a 0);
[subst; rewrite ?Zmod_0_l, ?Zdiv_0_l, ?Zmod_0_r, ?Zdiv_0_r;
auto with zarith|].

Lemma Zmod_1_r: forall a, a mod 1 = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_1_r".   intros. zero_or_not a. apply Z.mod_1_r. Qed.

Lemma Zdiv_1_r: forall a, a/1 = a.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_1_r".   intros. zero_or_not a. apply Z.div_1_r. Qed.

Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r
: zarith.

Lemma Zdiv_1_l: forall a, 1 < a -> 1/a = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_1_l".  exact (Z.div_1_l). Qed.

Lemma Zmod_1_l: forall a, 1 < a ->  1 mod a = 1.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_1_l".  exact (Z.mod_1_l). Qed.

Lemma Z_div_same_full : forall a:Z, a<>0 -> a/a = 1.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_same_full".  exact (Z.div_same). Qed.

Lemma Z_mod_same_full : forall a, a mod a = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_same_full".   intros. zero_or_not a. apply Z.mod_same; auto. Qed.

Lemma Z_mod_mult : forall a b, (a*b) mod b = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_mult".   intros. zero_or_not b. apply Z.mod_mul. auto. Qed.

Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_mult_full".  exact (Z.div_mul). Qed.

Lemma Z_div_pos: forall a b, b > 0 -> 0 <= a -> 0 <= a/b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_pos".   intros. apply Z.div_pos; auto with zarith. Qed.

Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_ge0".
intros; generalize (Z_div_pos a b H); auto with zarith.
Qed.

Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_lt".   intros. apply Z.div_lt; auto with zarith. Qed.

Theorem Zdiv_small: forall a b, 0 <= a < b -> a/b = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_small".  exact (Z.div_small). Qed.

Theorem Zmod_small: forall a n, 0 <= a < n -> a mod n = a.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_small".  exact (Z.mod_small). Qed.

Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a/c >= b/c.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_ge".   intros. apply Z.le_ge. apply Z.div_le_mono; auto with zarith. Qed.

Lemma Z_div_le : forall a b c:Z, c > 0 -> a <= b -> a/c <= b/c.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_le".   intros. apply Z.div_le_mono; auto with zarith. Qed.

Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b*(a/b) <= a.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mult_div_ge".   intros. apply Z.mul_div_le; auto with zarith. Qed.

Lemma Z_mult_div_ge_neg : forall a b:Z, b < 0 -> b*(a/b) >= a.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mult_div_ge_neg".   intros. apply Z.le_ge. apply Z.mul_div_ge; auto with zarith. Qed.

Lemma Z_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_exact_full_1".   intros a b. zero_or_not b. rewrite Z.div_exact; auto. Qed.

Lemma Z_div_exact_full_2 : forall a b:Z, b <> 0 -> a mod b = 0 -> a = b*(a/b).
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_exact_full_2".   intros; rewrite Z.div_exact; auto. Qed.

Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_le".   intros. apply Z.mod_le; auto. Qed.

Theorem Zdiv_lt_upper_bound:
forall a b q, 0 < b -> a < q*b -> a/b < q.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_lt_upper_bound".   intros a b q; rewrite Z.mul_comm; apply Z.div_lt_upper_bound. Qed.

Theorem Zdiv_le_upper_bound:
forall a b q, 0 < b -> a <= q*b -> a/b <= q.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_le_upper_bound".   intros a b q; rewrite Z.mul_comm; apply Z.div_le_upper_bound. Qed.

Theorem Zdiv_le_lower_bound:
forall a b q, 0 < b -> q*b <= a -> q <= a/b.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_le_lower_bound".   intros a b q; rewrite Z.mul_comm; apply Z.div_le_lower_bound. Qed.

Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r ->
p / r <= p / q.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_le_compat_l".   intros; apply Z.div_le_compat_l; auto with zarith. Qed.

Theorem Zdiv_sgn: forall a b,
0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn b.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_sgn".
destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl;
destruct Z.pos_div_eucl as (q,r); destruct r; omega with *.
Qed.

Lemma Z_mod_plus_full : forall a b c:Z, (a + b * c) mod c = a mod c.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_plus_full".   intros. zero_or_not c. apply Z.mod_add; auto. Qed.

Lemma Z_div_plus_full : forall a b c:Z, c <> 0 -> (a + b * c) / c = a / c + b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_plus_full".  exact (Z.div_add). Qed.

Theorem Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_plus_full_l".  exact (Z.div_add_l). Qed.

Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_opp_opp".   intros. zero_or_not b. apply Z.div_opp_opp; auto. Qed.

Lemma Zmod_opp_opp : forall a b:Z, (-a) mod (-b) = - (a mod b).
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_opp_opp".   intros. zero_or_not b. apply Z.mod_opp_opp; auto. Qed.

Lemma Z_mod_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a) mod b = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_zero_opp_full".   intros. zero_or_not b. apply Z.mod_opp_l_z; auto. Qed.

Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 ->
(-a) mod b = b - (a mod b).
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_nz_opp_full".   intros. zero_or_not b. apply Z.mod_opp_l_nz; auto. Qed.

Lemma Z_mod_zero_opp_r : forall a b:Z, a mod b = 0 -> a mod (-b) = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_zero_opp_r".   intros. zero_or_not b. apply Z.mod_opp_r_z; auto. Qed.

Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 ->
a mod (-b) = (a mod b) - b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_nz_opp_r".   intros. zero_or_not b. apply Z.mod_opp_r_nz; auto. Qed.

Lemma Z_div_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a)/b = -(a/b).
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_zero_opp_full".   intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed.

Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 ->
(-a)/b = -(a/b)-1.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_nz_opp_full".   intros a b. zero_or_not b. intros; rewrite Z.div_opp_l_nz; auto. Qed.

Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b).
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_zero_opp_r".   intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed.

Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 ->
a/(-b) = -(a/b)-1.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_nz_opp_r".   intros a b. zero_or_not b. intros; rewrite Z.div_opp_r_nz; auto. Qed.

Lemma  Zdiv_mult_cancel_r : forall a b c:Z,
c <> 0 -> (a*c)/(b*c) = a/b.
Proof. intros. zero_or_not b. apply Z.div_mul_cancel_r; auto. Qed.

Lemma Zdiv_mult_cancel_l : forall a b c:Z,
c<>0 -> (c*a)/(c*b) = a/b.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_mult_cancel_l".
intros. rewrite (Z.mul_comm c b); zero_or_not b.
rewrite (Z.mul_comm b c). apply Z.div_mul_cancel_l; auto.
Qed.

Lemma Zmult_mod_distr_l: forall a b c,
(c*a) mod (c*b) = c * (a mod b).
Proof. hammer_hook "Zdiv" "Zdiv.Zmult_mod_distr_l".
intros. zero_or_not c. rewrite (Z.mul_comm c b); zero_or_not b.
rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto.
Qed.

Lemma Zmult_mod_distr_r: forall a b c,
(a*c) mod (b*c) = (a mod b) * c.
Proof. hammer_hook "Zdiv" "Zdiv.Zmult_mod_distr_r".
intros. zero_or_not b. rewrite (Z.mul_comm b c); zero_or_not c.
rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto.
Qed.

Theorem Zmod_mod: forall a n, (a mod n) mod n = a mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_mod".   intros. zero_or_not n. apply Z.mod_mod; auto. Qed.

Theorem Zmult_mod: forall a b n,
(a * b) mod n = ((a mod n) * (b mod n)) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zmult_mod".   intros. zero_or_not n. apply Z.mul_mod; auto. Qed.

Theorem Zplus_mod: forall a b n,
(a + b) mod n = (a mod n + b mod n) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zplus_mod".   intros. zero_or_not n. apply Z.add_mod; auto. Qed.

Theorem Zminus_mod: forall a b n,
(a - b) mod n = (a mod n - b mod n) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zminus_mod".
intros.
replace (a - b) with (a + (-1) * b); auto with zarith.
replace (a mod n - b mod n) with (a mod n + (-1) * (b mod n)); auto with zarith.
rewrite Zplus_mod.
rewrite Zmult_mod.
rewrite Zplus_mod with (b:=(-1) * (b mod n)).
rewrite Zmult_mod.
rewrite Zmult_mod with (b:= b mod n).
repeat rewrite Zmod_mod; auto.
Qed.

Lemma Zplus_mod_idemp_l: forall a b n, (a mod n + b) mod n = (a + b) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zplus_mod_idemp_l".
intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto.
Qed.

Lemma Zplus_mod_idemp_r: forall a b n, (b + a mod n) mod n = (b + a) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zplus_mod_idemp_r".
intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto.
Qed.

Lemma Zminus_mod_idemp_l: forall a b n, (a mod n - b) mod n = (a - b) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zminus_mod_idemp_l".
intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto.
Qed.

Lemma Zminus_mod_idemp_r: forall a b n, (a - b mod n) mod n = (a - b) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zminus_mod_idemp_r".
intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto.
Qed.

Lemma Zmult_mod_idemp_l: forall a b n, (a mod n * b) mod n = (a * b) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zmult_mod_idemp_l".
intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto.
Qed.

Lemma Zmult_mod_idemp_r: forall a b n, (b * (a mod n)) mod n = (b * a) mod n.
Proof. hammer_hook "Zdiv" "Zdiv.Zmult_mod_idemp_r".
intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto.
Qed.

Section EqualityModulo.
Variable N:Z.

Definition eqm a b := (a mod N = b mod N).
Infix "==" := eqm (at level 70).

Lemma eqm_refl : forall a, a == a.
Proof. hammer_hook "Zdiv" "Zdiv.eqm_refl".   unfold eqm; auto. Qed.

Lemma eqm_sym : forall a b, a == b -> b == a.
Proof. hammer_hook "Zdiv" "Zdiv.eqm_sym".   unfold eqm; auto. Qed.

Lemma eqm_trans : forall a b c,
a == b -> b == c -> a == c.
Proof. hammer_hook "Zdiv" "Zdiv.eqm_trans".   unfold eqm; eauto with *. Qed.

Instance eqm_setoid : Equivalence eqm.
Proof. hammer_hook "Zdiv" "Zdiv.eqm_setoid".
constructor; [exact eqm_refl | exact eqm_sym | exact eqm_trans].
Qed.

Instance Zplus_eqm : Proper (eqm ==> eqm ==> eqm) Z.add.
Proof. hammer_hook "Zdiv" "Zdiv.Zplus_eqm".
unfold eqm; repeat red; intros. rewrite Zplus_mod, H, H0, <- Zplus_mod; auto.
Qed.

Instance Zminus_eqm : Proper (eqm ==> eqm ==> eqm) Z.sub.
Proof. hammer_hook "Zdiv" "Zdiv.Zminus_eqm".
unfold eqm; repeat red; intros. rewrite Zminus_mod, H, H0, <- Zminus_mod; auto.
Qed.

Instance Zmult_eqm : Proper (eqm ==> eqm ==> eqm) Z.mul.
Proof. hammer_hook "Zdiv" "Zdiv.Zmult_eqm".
unfold eqm; repeat red; intros. rewrite Zmult_mod, H, H0, <- Zmult_mod; auto.
Qed.

Instance Zopp_eqm : Proper (eqm ==> eqm) Z.opp.
Proof. hammer_hook "Zdiv" "Zdiv.Zopp_eqm".
intros x y H. change ((-x)==(-y)) with ((0-x)==(0-y)). now rewrite H.
Qed.

Lemma Zmod_eqm : forall a, (a mod N) == a.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_eqm".
intros; exact (Zmod_mod a N).
Qed.

End EqualityModulo.

Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c).
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_Zdiv".
intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c.
rewrite Z.mul_comm. apply Z.div_div; auto with zarith.
Qed.

Theorem Zdiv_mult_le:
forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_mult_le".
intros. zero_or_not b. apply Z.div_mul_le; auto with zarith. Qed.

Lemma Zmod_divides : forall a b, b<>0 ->
(a mod b = 0 <-> exists c, a = b*c).
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_divides".
intros. rewrite Z.mod_divide; trivial.
split; intros (c,Hc); exists c; subst; auto with zarith.
Qed.

Lemma Zdiv2_div : forall a, Z.div2 a = a/2.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv2_div".  exact (Z.div2_div). Qed.

Lemma Zmod_odd : forall a, a mod 2 = if Z.odd a then 1 else 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_odd".
intros a. now rewrite <- Z.bit0_odd, <- Z.bit0_mod.
Qed.

Lemma Zmod_even : forall a, a mod 2 = if Z.even a then 0 else 1.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_even".
intros a. rewrite Zmod_odd, Zodd_even_bool. now destruct Z.even.
Qed.

Lemma Zodd_mod : forall a, Z.odd a = Zeq_bool (a mod 2) 1.
Proof. hammer_hook "Zdiv" "Zdiv.Zodd_mod".
intros a. rewrite Zmod_odd. now destruct Z.odd.
Qed.

Lemma Zeven_mod : forall a, Z.even a = Zeq_bool (a mod 2) 0.
Proof. hammer_hook "Zdiv" "Zdiv.Zeven_mod".
intros a. rewrite Zmod_even. now destruct Z.even.
Qed.

Lemma Z_mod_same : forall a, a > 0 -> a mod a = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_same".
intros; apply Z_mod_same_full.
Qed.

Lemma Z_div_same : forall a, a > 0 -> a/a = 1.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_same".
intros; apply Z_div_same_full; auto with zarith.
Qed.

Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_plus".
intros; apply Z_div_plus_full; auto with zarith.
Qed.

Lemma Z_div_mult : forall a b:Z, b > 0 -> (a*b)/b = a.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_mult".
intros; apply Z_div_mult_full; auto with zarith.
Qed.

Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_plus".
intros; apply Z_mod_plus_full; auto with zarith.
Qed.

Lemma Z_div_exact_1 : forall a b:Z, b > 0 -> a = b*(a/b) -> a mod b = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_exact_1".
intros; apply Z_div_exact_full_1; auto with zarith.
Qed.

Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b*(a/b).
Proof. hammer_hook "Zdiv" "Zdiv.Z_div_exact_2".
intros; apply Z_div_exact_full_2; auto with zarith.
Qed.

Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> (-a) mod b = 0.
Proof. hammer_hook "Zdiv" "Zdiv.Z_mod_zero_opp".
intros; apply Z_mod_zero_opp_full; auto with zarith.
Qed.

Fixpoint Zmod_POS (a : positive) (b : Z) : Z  :=
match a with
| xI a' =>
let r := Zmod_POS a' b in
let r' := (2 * r + 1) in
if r' <? b then r' else (r' - b)
| xO a' =>
let r := Zmod_POS a' b in
let r' := (2 * r) in
if r' <? b then r' else (r' - b)
| xH => if 2 <=? b then 1 else 0
end.

Definition Zmod' a b :=
match a with
| Z0 => 0
| Zpos a' =>
match b with
| Z0 => 0
| Zpos _ => Zmod_POS a' b
| Zneg b' =>
let r := Zmod_POS a' (Zpos b') in
match r  with Z0 =>  0 |  _  =>   b + r end
end
| Zneg a' =>
match b with
| Z0 => 0
| Zpos _ =>
let r := Zmod_POS a' b in
match r with Z0 =>  0 | _  =>  b - r end
| Zneg b' => - (Zmod_POS a' (Zpos b'))
end
end.

Theorem Zmod_POS_correct a b : Zmod_POS a b = snd (Z.pos_div_eucl a b).
Proof. hammer_hook "Zdiv" "Zdiv.Zmod_POS_correct".
induction a as [a IH|a IH| ]; simpl; rewrite ?IH.
destruct (Z.pos_div_eucl a b) as (p,q); simpl;
case Z.ltb_spec; reflexivity.
destruct (Z.pos_div_eucl a b) as (p,q); simpl;
case Z.ltb_spec; reflexivity.
case Z.leb_spec; trivial.
Qed.

Theorem Zmod'_correct: forall a b, Zmod' a b = a mod b.
Proof. hammer_hook "Zdiv" "Zdiv.Zmod'_correct".
intros a b; unfold Z.modulo; case a; simpl; auto.
intros p; case b; simpl; auto.
intros p1; refine (Zmod_POS_correct _ _); auto.
intros p1; rewrite Zmod_POS_correct; auto.
case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
intros p; case b; simpl; auto.
intros p1; rewrite Zmod_POS_correct; auto.
case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
intros p1; rewrite Zmod_POS_correct; simpl; auto.
case (Z.pos_div_eucl p (Zpos p1)); auto.
Qed.

Theorem Zdiv_eucl_extended :
forall b:Z,
b <> 0 ->
forall a:Z,
{qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Z.abs b}.
Proof. hammer_hook "Zdiv" "Zdiv.Zdiv_eucl_extended".
intros b Hb a.
destruct (Z_le_gt_dec 0 b) as [Hb'|Hb'].
- assert (Hb'' : b > 0) by omega.
rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
- assert (Hb'' : - b > 0) by omega.
destruct (Zdiv_eucl_exist Hb'' a) as ((q,r),[]).
exists (- q, r).
split.
+ rewrite <- Z.mul_opp_comm; assumption.
+ rewrite Z.abs_neq; [ assumption | omega ].
Qed.

Arguments Zdiv_eucl_extended : default implicits.

Require Import PeanoNat.

Lemma div_Zdiv (n m: nat): m <> O ->
Z.of_nat (n / m) = Z.of_nat n / Z.of_nat m.
Proof. hammer_hook "Zdiv" "Zdiv.div_Zdiv".
intros.
apply (Zdiv_unique _ _ _ (Z.of_nat (n mod m))).
split. auto with zarith.
now apply inj_lt, Nat.mod_upper_bound.
rewrite <- Nat2Z.inj_mul, <- Nat2Z.inj_add.
now apply inj_eq, Nat.div_mod.
Qed.

Lemma mod_Zmod (n m: nat): m <> O ->
Z.of_nat (n mod m) = (Z.of_nat n) mod (Z.of_nat m).
Proof. hammer_hook "Zdiv" "Zdiv.mod_Zmod".
intros.
apply (Zmod_unique _ _ (Z.of_nat n / Z.of_nat m)).
split. auto with zarith.
now apply inj_lt, Nat.mod_upper_bound.
rewrite <- div_Zdiv, <- Nat2Z.inj_mul, <- Nat2Z.inj_add by trivial.
now apply inj_eq, Nat.div_mod.
Qed.


From CoqAlgs Require Export Ord.
From CoqAlgs Require Export Sorting.Sort.

From CoqAlgs Require Export BTree.
From CoqAlgs Require Export BST.

From CoqAlgs Require Export ListLemmas.

Function insertBT {A : Type} (cmp : A -> A -> bool) (x : A) (t : BTree A) : BTree A :=
match t with
    | empty => node x empty empty
    | node v l r =>
        if cmp x v
        then node v (insertBT cmp x l) r
        else node v l (insertBT cmp x r)
end.

Fixpoint fromList
  {A : Type} (cmp : A -> A -> bool) (l : list A) : BTree A :=
match l with
    | [] => empty
    | h :: t => insertBT cmp h (fromList cmp t)
end.

Definition treeSort
  {A : Type} (cmp : A -> A -> bool) (l : list A) : list A :=
    inorder (fromList cmp l).

Lemma Elem_insertBT :
  forall {A : Type} (cmp : A -> A -> comparison) (x y : A) (t : BTree A),
    Elem x (insertBT cmp y t) -> (* cmp x y = Eq *) x = y \/ Elem x t.
Proof.
  intros until t. revert x.
  functional induction (insertBT cmp y t);
  Elems'.
Qed.

(* TODO: split definition of BSTs into two *)Lemma isBST_insertBT :
  forall {A : Ord} (x : A) (t : BTree A),
    isBST cmp t -> isBST cmp (insertBT cmp x t).
Proof.
  intros until t.
  functional induction insertBT cmp x t;
  isBST'; Elems.
    apply Elem_insertBT in H. inv H.
      unfold comparison2bool in e0. trich.
      specialize (IHb0 H3). admit.
    apply Elem_insertBT in H. inv H. admit.
Admitted.

Lemma countBT_insertBT :
  forall (A : Type) (cmp : A -> A -> bool) (p : A -> bool) (x : A) (t : BTree A),
    countBT p (insertBT cmp x t) =
      (if p x then 1 else 0) + countBT p t.
Proof.
  intros until t.
  functional induction insertBT cmp x t;
  cbn; lia.
Qed.

Lemma isBST_fromList :
  forall {A : Ord} (l : list A),
    isBST cmp (fromList cmp l).
Proof.
  induction l as [| h t]; cbn.
    constructor.
    apply isBST_insertBT. assumption.
Qed.

Lemma Sorted_treeSort :
  forall {A : Ord} (l : list A),
    Sorted cmp (treeSort cmp l).
Proof.
  unfold treeSort. intros. apply Sorted_inorder, isBST_fromList.
Qed.

Lemma perm_treeSort :
  forall {A : Type} (cmp : A -> A -> bool) (l : list A),
    perm (treeSort cmp l) l.
Proof.
  induction l as [| h t]; intro; cbn.
    reflexivity.
    rewrite count_toList, countBT_insertBT, <- count_toList, <- IHt. reflexivity.
Qed.

Lemma Permutation_treeSort_aux :
  forall {A : Type} (cmp : A -> A -> bool) (x : A) (t : BTree A),
    Permutation (inorder (insertBT cmp x t)) (x :: inorder t).
Proof.
  induction t as [| v l r]; cbn.
    reflexivity.
    destruct (cmp x v); cbn.
      rewrite r. cbn. reflexivity.
      rewrite IHt1, Permutation_app_comm, perm_swap. cbn.
        constructor. rewrite Permutation_app_comm, Permutation_middle.
          reflexivity.
Qed.

Lemma Permutation_treeSort :
  forall {A : Type} (cmp : A -> A -> bool) (l : list A),
    Permutation (treeSort cmp l) l.
Proof.
  induction l as [| h t]; cbn.
    reflexivity.
    rewrite Permutation_treeSort_aux. constructor. assumption.
Qed.

#[export]
Instance Sort_treeSort {A : Ord} : Sort cmp :=
{
    sort := treeSort cmp;
    Sorted_sort := Sorted_treeSort;
    Permutation_sort := Permutation_treeSort cmp;
}.


(* fmsetoidlist Library *)
(* v0   Olivier Laurent *)

(** * Finite Multiset over Lists
   We define an axiomatization of finite multiset through their relation with lists.
   Equality is an equivalence relation.
   An implementation of the axioms is provided for every type
   by lists up to permutation. *)

Require Import Relations.
Require Import Morphisms.
Require Import List.
Require Import Permutation.

(** * Axiomatization *)

(** A finite multiset with elements in [A] is a type [M]
    related with [list A] as follows: *)
Class FinMultisetoid M A :=
{
  meq : relation M;
  mequiv : Equivalence meq;
  empty : M;
  add : A -> M -> M;
  add_meq : Proper (eq ==> meq ==> meq) add;
  elts : M -> list A;
  elts_empty : elts empty = @nil A;
  elts_add : forall a m, Permutation (elts (add a m)) (a :: elts m);
  perm_meq : forall l1 l2, Permutation l1 l2 ->
               meq (fold_right add empty l1) (fold_right add empty l2);
  meq_perm : forall m1 m2, meq m1 m2 -> Permutation (elts m1) (elts m2);
  retract_meq : forall m, meq (fold_right add empty (elts m)) m
}.

(** [Mst] and [Elt] define a finite multiset construction over a type [K]
    if for any [A] in [K], [Mst A] is a finite multiset with elements [Elt A]. *)
Definition FMoidConstructor K Mst Elt :=
  forall A : K, FinMultisetoid (Mst A) (Elt A).

(** * Constructions and properties over finite multisets *)

Section FMSet2List.

Context {M A : Type}.
Context {fm : FinMultisetoid M A}.

Global Instance mequivalence : Equivalence meq := mequiv.

Definition list2fm l := fold_right add empty l.

Global Instance list2fm_perm : Proper (@Permutation A ==> meq) list2fm := perm_meq.

Global Instance elts_perm' : Proper (meq ==> @Permutation A) elts := meq_perm.

Lemma list2fm_retract : forall m, meq (list2fm (elts m)) m.
Proof.
apply retract_meq.
Qed.

Lemma list2fm_nil : list2fm nil = empty.
Proof.
reflexivity.
Qed.

Lemma list2fm_elt : forall l1 l2 a,
  meq (list2fm (l1 ++ a :: l2)) (add a (list2fm (l1 ++ l2))).
Proof.
intros l1 l2 a.
change (add a (list2fm (l1 ++ l2)))
  with (list2fm (a :: l1 ++ l2)).
apply perm_meq.
symmetry.
apply Permutation_middle.
Qed.

Lemma list2fm_cons : forall l a, meq (list2fm (a :: l)) (add a (list2fm l)).
Proof.
intros l a.
rewrite <- (app_nil_l (a :: l)).
rewrite list2fm_elt.
reflexivity.
Qed.

Lemma elts_perm : forall l, Permutation (elts (list2fm l)) l.
Proof.
induction l.
- simpl ; rewrite elts_empty.
  reflexivity.
- simpl ; rewrite elts_add.
  rewrite IHl.
  reflexivity.
Qed.

Lemma elts_eq_nil : forall m, elts m = nil -> meq m empty.
Proof.
intros m Heq.
assert (Hr := retract_meq m) ; rewrite Heq in Hr ; simpl in Hr.
rewrite Hr ; reflexivity.
Qed.

Lemma add_swap : forall m a b, meq (add a (add b m)) (add b (add a m)).
Proof.
intros m a b.
rewrite <- list2fm_retract.
rewrite ? elts_add.
rewrite perm_swap.
rewrite <- 2 elts_add.
rewrite list2fm_retract.
reflexivity.
Qed.

Definition sum m1 m2 := list2fm (elts m1 ++ elts m2).

Lemma elts_sum : forall m1 m2,
  Permutation (elts (sum m1 m2)) (elts m1 ++ elts m2).
Proof.
intros.
apply elts_perm.
Qed.

Lemma sum_empty_left : forall m, meq (sum empty m) m.
Proof.
intros m.
unfold sum.
rewrite elts_empty.
apply retract_meq.
Qed.

Lemma sum_empty_right : forall m, meq (sum m empty) m.
Proof.
intros m.
unfold sum.
rewrite elts_empty.
rewrite app_nil_r.
apply retract_meq.
Qed.

Lemma sum_comm : forall m1 m2, meq (sum m1 m2) (sum m2 m1).
Proof.
intros m1 m2.
unfold sum.
rewrite Permutation_app_comm.
reflexivity.
Qed.

Lemma sum_ass : forall m1 m2 m3, meq (sum (sum m1 m2) m3) (sum m1 (sum m2 m3)).
Proof.
intros m1 m2 m3.
unfold sum.
apply perm_meq.
etransitivity.
- apply Permutation_app_tail.
  apply elts_perm.
- rewrite <- app_assoc.
  apply Permutation_app_head.
  symmetry.
  apply elts_perm.
Qed.

Lemma list2fm_app : forall l1 l2,
  meq (list2fm (l1 ++ l2)) (sum (list2fm l1) (list2fm l2)).
Proof.
intros l1 l2.
unfold sum.
apply perm_meq.
etransitivity.
- apply Permutation_app_tail.
  symmetry.
  apply elts_perm.
- apply Permutation_app_head.
  symmetry.
  apply elts_perm.
Qed.

Global Instance sum_meq : Proper (meq ==> meq ==> meq) sum.
Proof.
intros m1 m2 Heq m1' m2' Heq'.
unfold sum.
apply meq_perm in Heq.
apply meq_perm in Heq'.
apply perm_meq.
apply Permutation_app ; assumption.
Qed.

End FMSet2List.

Section Fmmap.

Context {M A N B: Type}.
Context {fm : FinMultisetoid M A}.
Context {fm' : FinMultisetoid N B}.
Variable f : A -> B.

Definition fmmap (m : M) := list2fm (map f (elts m)).

Global Instance fmmap_meq : Proper (meq ==> meq) fmmap.
Proof.
intros l1 l2 Heq.
apply perm_meq.
apply Permutation_map.
apply meq_perm.
assumption.
Qed.

Lemma list2fm_map : forall l, meq (list2fm (map f l)) (fmmap (list2fm l)).
Proof.
intros l.
apply perm_meq.
apply Permutation_map.
symmetry.
apply elts_perm.
Qed.

Lemma elts_fmmap : forall m, Permutation (elts (fmmap m)) (map f (elts m)).
Proof.
intros m.
rewrite <- (list2fm_retract m) at 1.
remember (elts m) as l.
clear m Heql.
induction l.
- simpl.
  unfold fmmap.
  rewrite elts_empty.
  simpl.
  rewrite elts_empty.
  reflexivity.
- etransitivity.
  + apply elts_perm.
  + apply Permutation_map.
    apply elts_perm.
Qed.

End Fmmap.

(** * Lists up to permutation as finite multisets *)

Lemma fold_id {A} : forall l, fold_right (@cons A) nil l = l.
Proof.
induction l.
- reflexivity.
- simpl.
  f_equal.
  assumption.
Qed.

Fact FMoidConstr_list : FMoidConstructor _ list id.
Proof with try reflexivity.
intros A.
split with (@Permutation A) (@nil A) (@cons A) id...
- apply Permutation_Equivalence.
- intros a1 a2 Heq l1 l2 HP ; subst.
  apply Permutation_cons...
  assumption.
- intros l1 l2 HP.
  rewrite 2 fold_id.
  assumption.
- intros l1 l2 HP.
  assumption.
- intros m.
  rewrite fold_id...
Defined.


Require Import Helix.Util.VecUtil.

Require Import Coq.Arith.Arith.
Require Import Coq.Program.Basics. (* for \circ notation *)
Require Export Coq.Vectors.Vector.
Require Import Coq.micromega.Lia.

Require Import MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders.
Require Import MathClasses.orders.minmax MathClasses.orders.orders MathClasses.orders.rings.
Require Import MathClasses.theory.rings MathClasses.theory.abs.
Require Import MathClasses.theory.naturals.

Require Export CoLoR.Util.Vector.VecUtil.
Import VectorNotations.

Require Import Helix.Tactics.HelixTactics.

(* Various definitions related to vector equality and setoid rewriting *)

Section VectorSetoid.

  Global Instance vec_Equiv `{Equiv A} {n}: Equiv (vector A n)
    := Vforall2 (n:=n) equiv.

  Global Instance vec_Equivalence `{Ae: Equiv A} {n:nat}
         `{!Equivalence (@equiv A _)}
    : Equivalence (@vec_Equiv A Ae n).
  Proof.
    unfold vec_Equiv.
    apply Vforall2_equiv.
    assumption.
  Qed.

  Global Instance vec_Setoid `{Setoid A} {n}: Setoid (vector A n).
  Proof.
    unfold Setoid.
    apply vec_Equivalence.
  Qed.

End VectorSetoid.

Global Instance Vconst_proper (A:Type) `{Ae: Equiv A}:
  Proper ((=) ==> forall_relation
              (fun (n : nat) => (@vec_Equiv A _ n)))
         (@Vconst A).
Proof.
  intros a a' aa'.
  intros n.
  induction n.
  - crush.
  -
    simpl.
    unfold equiv, vec_Equiv.
    rewrite Vforall2_cons_eq.
    split; assumption.
Qed.

(* We also have `Proper` instance for `Vold_left_rev` called `Vfold_left_rev_Vforall2` *)
Global Instance Vfold_left_rev_proper
       (A B : Type)
       `{Ae: Equiv A}
       `{Be: Equiv B}:
  Proper (((=) ==> (=) ==> (=)) ==>
                            forall_relation
                            (fun (n : nat) => (=) ==> (@vec_Equiv B _ n) ==> (=)))
         (@Vfold_left_rev A B).
Proof.
  intros f f' Ef n a a' Ea v v' Ev.

  induction v; simpl; intros.
  -
    VOtac.
    simpl.
    apply Ea.
  -
    revert Ev. VSntac v'.
    unfold vec_Equiv.
    rewrite Vforall2_cons_eq. intuition. simpl.
    apply Ef; auto.
Qed.

Global Instance Vfold_left_rev_arg_proper
       (A B : Type)
       `{Ae: Equiv A}
       `{Aeq: Equivalence A Ae}
       `{Be: Equiv B}
       (f : A → B → A)
       `{f_mor: !Proper ((=) ==> (=) ==> (=)) f}
       (n : nat)
       (initial : A)
  :
    Proper ((=) ==> (=)) (@Vfold_left_rev A B f n initial).
Proof.
  intros v v' Ev.
  induction n; simpl; intros.
  -
    dep_destruct v.
    dep_destruct v'.
    reflexivity.
  -
    dep_destruct v.
    dep_destruct v'.
    simpl.
    apply f_mor.
    apply IHn.
    apply Ev.
    apply Ev.
Qed.

Global Instance Vfold_right_proper
       (A B : Type)
       `{Ae: Equiv A}
       `{Be: Equiv B}:
  Proper (((=) ==> (=) ==> (=)) ==>
                            forall_relation
                            (fun (n : nat) => (@vec_Equiv A _ n) ==> (=) ==> (=)))
         (@Vfold_right A B).
Proof.
  intros f f' Ef n v v' Ev a a' Ea.

  induction v; simpl; intros.
  -
    VOtac.
    simpl.
    apply Ea.
  -
    revert Ev. VSntac v'.
    unfold vec_Equiv.
    rewrite Vforall2_cons_eq. intuition. simpl.
    apply Ef; auto.
Qed.

Global Instance Vfold_right_arg_proper
       (A B : Type)
       `{Ae: Equiv A}
       `{Be: Equiv B}
       (f: A → B → B)
       `{f_mor: !Proper ((=) ==> (=) ==> (=)) f}
       {n:nat}
  :
    Proper ((@vec_Equiv A _ n) ==> (=) ==> (=))
         (@Vfold_right A B f n).
Proof.
  apply Vfold_right_proper.
  apply f_mor.
Qed.

Lemma Vcons_single_elim `{Ae: Equiv A} : forall a1 a2,
    Vcons a1 (@Vnil A) = Vcons a2 (@Vnil A) <-> a1 = a2.
Proof.
  intros a1 a2.
  unfold equiv, vec_Equiv.
  rewrite Vforall2_cons_eq.
  assert(Vforall2 equiv (@Vnil A) (@Vnil A)).
  constructor.
  split; tauto.
Qed.

Lemma Vcons_equiv_elim (A:Type) `{Equiv A}: forall a1 a2 n (v1 v2 : vector A n),
    Vcons a1 v1 = Vcons a2 v2 -> a1 = a2 /\ v1 = v2.
Proof.
  intros. auto.
Qed.

Lemma Vcons_equiv_intro (A:Type) `{Equiv A} : forall a1 a2 n (v1 v2 : vector A n),
    a1 = a2 -> v1 = v2 -> Vcons a1 v1 = Vcons a2 v2.
Proof.
  intros.
  apply Vforall2_cons_eq; auto.
Qed.

Global Instance Vcons_proper (A:Type) `{Equiv A}:
  Proper ((=) ==> forall_relation
              (fun (n : nat) => (@vec_Equiv A _ n) ==> (@vec_Equiv A _ (S n))))
         (@Vcons A).
Proof.
  intros a a' Ea.
  intros n.
  intros b b' Eb.
  induction n.
  -
    dep_destruct b.
    dep_destruct b'.
    apply Vcons_single_elim, Ea.
  -
    eapply Vcons_equiv_intro; auto.
Qed.

Global Instance Vcons_arg_proper (A:Type) `{As: Setoid A} {n} {x:A}:
  Proper ((@vec_Equiv A _ n) ==> (@vec_Equiv A _ (S n)))
         (@Vcons A x n).
Proof.
  apply Vcons_proper; reflexivity.
Qed.

Global Instance Vapp_proper `{Sa: Setoid A} (n1 n2:nat):
  Proper ((=) ==>  (=) ==> (=)) (@Vapp A n1 n2).
Proof.
  intros a0 a1 aEq b0 b1 bEq.
  induction n1.
  VOtac. auto.

  dep_destruct a0.
  dep_destruct a1.
  rewrite 2!Vapp_cons.

  assert (h=h0).
  apply aEq.

  rewrite H.

  unfold equiv, vec_Equiv.
  apply Vforall2_cons_eq.
  split. reflexivity.

  unfold equiv, vec_Equiv in IHn1.
  apply IHn1.
  apply aEq.
Qed.

Global Instance Vhead_proper `{Equiv A} n:
  Proper ((=) ==> (=)) (@Vhead A n).
Proof.
  intros a b E.
  dep_destruct a.  dep_destruct b.
  unfold equiv, vec_Equiv, vec_Equiv, relation in E.
  rewrite Vforall2_cons_eq in E.
  intuition.
Qed.

Global Instance Vtail_proper `{Equiv A} n:
  Proper ((=) ==> (=)) (@Vtail A n).
Proof.
  intros a b E.
  unfold equiv, vec_Equiv, vec_Equiv, relation in E.
  apply Vforall2_tail in E.
  unfold vec_Equiv.
  assumption.
Qed.

Global Instance Ptail_proper `{Sa: Setoid A} `{Sb: Setoid B} (n:nat):
  Proper ((=) ==> (=)) (@Ptail A B n).
Proof.
  intros x y E.
  destruct x as [xa xb].
  destruct y as [ya yb].
  destruct E as [E1 E2].
  simpl in E1. simpl in E2.
  unfold Ptail.
  rewrite E1, E2.
  reflexivity.
Qed.

(* Handy tactics to break down equality of two vectors into element-wise equality of theirm elements using index *)
Ltac vec_index_equiv j jc :=
  match goal with
  | [ |- vec_Equiv _ _] => let j' := fresh j in
                   let jc' := fresh jc in
                   apply Vforall2_intro_nth;
                   intros j' jc'
  | [ |- _ = _] => let j' := fresh j in
                   let jc' := fresh jc in
                   unfold equiv, vec_Equiv;
                   apply Vforall2_intro_nth;
                   intros j' jc'
  | [ |- _ ≡ _] => let j' := fresh j in
                   let jc' := fresh jc in
                   apply Veq_nth; intros j' jc'
 end.

Lemma Vfold_right_Vmap_equiv
      {A B C: Type}
      `{Setoid B}
      {n: nat}
      (f : A->B->B)
      (g : C->A)
      (x : vector C n)
      (z:B)
  : Vfold_right f (Vmap g x) z = Vfold_right (f∘g) x z.
Proof.
  rewrite Vfold_right_Vmap.
  reflexivity.
Qed.

Lemma Vmap_as_Vbuild {A B:Type} :
  ∀ (n : nat) (v : vector A n) (f:A->B),
    Vmap f v ≡ Vbuild (λ (j : nat) (jd : (j < n)%nat), f (Vnth v jd)).
Proof.
  intros n v f.
  vec_index_equiv i ip.
  rewrite Vnth_map.
  rewrite Vbuild_nth.
  reflexivity.
Qed.

Lemma Vmap2_cons_hd: forall A B C `{Setoid C} (f:A->B->C) n (a:vector A (S n)) (b:vector B (S n)),
    Vmap2 f a b = Vcons (f (Vhead a) (Vhead b)) (Vmap2 f (Vtail a) (Vtail b)).
Proof.
  intros.
  dep_destruct a.
  dep_destruct b.
  reflexivity.
Qed.

Lemma Vmap2_cons: forall A B C `{Setoid C} (f:A->B->C) n (a:A) (b:B) (a':vector A n) (b':vector B n),
    Vmap2 f (Vcons a a') (Vcons b b') = Vcons (f a b) (Vmap2 f a' b').
Proof.
  intros.
  reflexivity.
Qed.

Lemma Vmap2_comm
      (A B:Type)
      `{CO:Commutative B A f}
      `{SB: !Setoid B} {n:nat}:
  Commutative (Vmap2 f (n:=n)).
Proof.
  unfold Commutative.
  intros a b.
  induction n.
  dep_destruct a.
  dep_destruct b.
  reflexivity.
  rewrite Vmap2_cons_hd by apply SB.

  setoid_rewrite <- Vmap2_cons; auto.
  simpl.
  rewrite commutativity.
  apply Vcons_proper.
  reflexivity.
  apply IHn.
Qed.

Lemma hd_equiv: forall `{Equiv A} {n} (u v: vector A (S n)), u=v -> (Vhead u) = (Vhead v).
Proof.
  intros.
  f_equiv.
  assumption.
Qed.

Lemma vector1_equiv_Vhead_equiv
      {A: Type}
      `{As: Equiv A}
      {a b: vector A 1}:
  Vhead a = Vhead b -> a = b.
Proof.
  intros H.
  dep_destruct a.
  dep_destruct b.
  dep_destruct x.
  dep_destruct x0.
  apply Vcons_single_elim.
  simpl in H.
  assumption.
Qed.

Global Instance Vmap_proper (A B:Type) `{Ae: Equiv A} `{Be: Equiv B}:
  Proper (
      ((=) ==> (=)) ==> (forall_relation
                       (fun (n : nat) => (@vec_Equiv A _ n) ==> (@vec_Equiv B _ n))))
         (@Vmap A B).
Proof.
    intros f f' Ef n v v' Ev.
    induction n.
    -
      VOtac; auto.
    -
      dep_destruct v. dep_destruct v'.
      split.
      +
        inversion Ev.
        apply Ef, H.
      + apply IHn, Ev.
Qed.

Global Instance Vmap_arg_proper  (M N:Type) `{Me:!Equiv M} `{Ne: !Equiv N} (f : M->N)
       `{fP: !Proper (Me ==> Ne) f} (n:nat):
  Proper ((@vec_Equiv M _ n) ==> (@vec_Equiv N _ n)) (@Vmap M N f n).
Proof.
  intros a b Ea.
  induction n.
  -
    VOtac; auto.
  -
    dep_destruct a. dep_destruct b.
    split.
    apply fP, Ea.
    apply IHn, Ea.
Qed.

Global Instance VBreak_proper (A:Type) `{Setoid A} (n1 n2:nat) `{Plus nat}:
  Proper ((=) ==> (=)) (@Vbreak A n1 n2).
Proof.
  intros v v1 vE.
  induction n1.
  simpl. setoid_rewrite vE. reflexivity.
  assert (V1: v ≡ Vapp (fst (Vbreak (n1:=1) v)) (snd (Vbreak (n1:=1) v))).
  {
    simpl. dep_destruct v. reflexivity.
  }
  assert (V2: v1 ≡ Vapp (fst (Vbreak (n1:=1) v1)) (snd (Vbreak (n1:=1) v1))).
  {
    simpl. dep_destruct v1. reflexivity.
  }
  rewrite V1. clear V1. rewrite V2. clear V2.
  dep_destruct v. dep_destruct v1.
  simpl.

  assert (E: Vbreak x = Vbreak x0).
  {
    apply IHn1.  apply vE.
  }
  f_equiv.
  +
    apply Vcons_proper.
    inversion vE.
    auto.
    rewrite E.
    reflexivity.
  +
    rewrite E.
    reflexivity.
Qed.

Section Vnth.

  Lemma Vnth_arg_equiv:
    ∀ (A : Type) (Ae : Equiv A) (n : nat) (v1 v2 : vector A n)
      (i : nat) (ip : i < n), v1 = v2 → Vnth v1 ip = Vnth v2 ip.
  Proof.
    intros A Ae n v1 v2 i ip E.
    unfold equiv, vec_Equiv in E.
    apply Vforall2_elim_nth with (i:=i) (ip:=ip) in E.
    assumption.
  Qed.

  Lemma Vnth_equiv `{Equiv A}: forall n (v1 v2 : vector A n) i1 (h1 : i1<n) i2 (h2 : i2<n),
      i1 = i2 -> v1 = v2 -> Vnth v1 h1 = Vnth v2 h2.
  Proof.
    intros n v1 v2 i1 h1 i2 h2 Ei Ev.
    rewrite Vnth_eq with (h2:=h2) by assumption.
    apply Vnth_arg_equiv.
    assumption.
  Qed.

  Global Instance Vnth_aux_arg_proper {n j : nat} (jc:j<n) (A:Type) `{Equiv A}:
    Proper ((=) ==> (=)) (@Vnth_aux A n j jc).
  Proof.
    intros x y E.
    dependent induction n.
    -
      VOtac.
      nat_lt_0_contradiction.
    -
      rewrite (VSn_eq x).
      rewrite (VSn_eq y).
      simpl.
      break_match.
      +
        rewrite (VSn_eq x) in E.
        rewrite (VSn_eq y) in E.
        apply E.
      +
        apply IHn.
        rewrite (VSn_eq x) in E.
        rewrite (VSn_eq y) in E.
        apply E.
  Qed.

  Global Instance Vnth_proper {n : nat} (A:Type) `{Equiv A}:
    Proper ((=) ==> (forall_relation
                     (fun i => pointwise_relation (i < n)%nat equiv)))
           (@Vnth A n).
  Proof.
    intros x y E i ic.
    dependent induction n.
    -
      VOtac.
      nat_lt_0_contradiction.
    -
      rewrite (VSn_eq x).
      rewrite (VSn_eq y).
      simpl.
      break_match.
      +
        rewrite (VSn_eq x) in E.
        rewrite (VSn_eq y) in E.
        apply E.
      +
        apply IHn.
        rewrite (VSn_eq x) in E.
        rewrite (VSn_eq y) in E.
        apply E.
  Qed.

End Vnth.

Global Instance Vmap2Indexed_proper
       `{Equiv A, Equiv B, Equiv C} {n:nat}
  :
    Proper (((=) ==> (=) ==> (=) ==> (=)) ==> (=) ==> (=) ==> (=))
           (@Vmap2Indexed A B C n).
Proof.
  intros fa fb Ef a a' Ea b b' Eb.
  unfold Vmap2Indexed.

  vec_index_equiv i ip.
  rewrite 2!Vbuild_nth.
  apply Ef.
  - reflexivity.
  - apply Vnth_equiv.
    reflexivity.
    assumption.
  - apply Vnth_equiv.
    reflexivity.
    assumption.
Qed.

Global Instance Vmap2SigIndexed_proper
       `{Equiv A, Equiv B, Equiv C} {n:nat}
  :
    Proper (((=) ==> (=) ==> (=) ==> (=)) ==> (=) ==> (=) ==> (=))
           (@Vmap2SigIndexed A B C n).
Proof.
  intros fa fb Ef a a' Ea b b' Eb.
  unfold Vmap2SigIndexed.

  vec_index_equiv i ip.
  rewrite 2!Vbuild_nth.
  apply Ef.
  - reflexivity.
  - apply Vnth_equiv.
    reflexivity.
    assumption.
  - apply Vnth_equiv.
    reflexivity.
    assumption.
Qed.

(* TODO: Check why this is needed *)
Global Instance indexed_vector_equiv `{Equiv A} {n}:
  Equiv (∀ i : nat, i < n → vector A n)
  :=  @forall_relation nat
                       (fun i : nat =>  forall _ : i<n, vector A n)
                       (fun i : nat =>  @pointwise_relation (i < n)
                                                       (vector A n) (=)).

(* @jwiegley version: *)
Global Instance Vbuild_proper {n : nat} {A:Type} `{Equiv A}:
  Proper ((forall_relation
             (fun i => pointwise_relation (i < n)%nat equiv)) ==> equiv)
         (@Vbuild A n).
Proof.
  intros f f' E.
  unfold forall_relation, pointwise_relation in E.
  unfold equiv, vec_Equiv; apply Vforall2_intro_nth; intros j jc.
  rewrite 2!Vbuild_nth.
  apply E.
Qed.

Global Instance Vfold_right_indexed'_proper
       {n: nat}
       {A B: Type}
       `{EQa: Equiv A}
       `{EQb: Equiv B}
  :

    Proper((eq) ==>
                ((eq) ==> (equiv) ==> (equiv) ==> (equiv)) ==>
                (equiv) ==> (equiv) ==> (equiv))
          (@Vfold_right_indexed' n A B).
Proof.
  intros i i' Ei f f' Ef v v' Ev b b' Eb.
  subst i'.

  revert i.
  induction n; intros.
  -
    dep_destruct v.
    dep_destruct v'.
    simpl.
    apply Eb.
  -
    dep_destruct v.
    dep_destruct v'.
    simpl.
    apply Ef; auto.
    inversion Ev; auto.
    apply IHn.
    inversion Ev; auto.
Qed.


Require Import Reals.
Require Import Rfunction_classes.
Require Import Ranalysis_def Ranalysis_facts.

Local Open Scope R_scope.

(** * Definition of the nth derivative *)

Program Fixpoint nth_derive {n : nat} (f : R -> R) (pr : D n f) : R -> R := match n with
   | O   => f
   | S m => @nth_derive m (derive f _) _
end.
Next Obligation.
inversion pr ; assumption.
Qed.
Next Obligation.
apply D_derive ; assumption.
Qed.

Program Fixpoint nth_derive_Rball {n : nat} c r f (pr: D_Rball c r n f): R -> R :=
match n with
  | 0   => f
  | S m => @nth_derive_Rball m c r (derive_Rball c r f _) _
end.
Next Obligation.
inversion pr ; assumption.
Qed.
Next Obligation.
apply D_Rball_derive ; assumption.
Qed.

Definition nth_derive' {m : nat} (n : nat) f (pr : D m f) (nlem : (n <= m)%nat) : R -> R :=
  nth_derive f (D_le _ _ _ nlem pr).

Definition nth_derive_Rball' {m : nat} c r n f (pr: D_Rball c r m f)
  (nlem: (n <= m)%nat) : R -> R :=
  nth_derive_Rball c r f (D_Rball_le _ _ _ _ _ nlem pr).


Theorem backward_large : (forall A B C : Prop, A -> (A->B) -> (B->C) -> C).

Proof.
  intros A B C.
  intros proof_of_A.
  intros A_implies_B.
  pose (proof_of_B := A_implies_B proof_of_A).
  intros B_implies_C.
  pose (proof_of_C := B_implies_C proof_of_B).
  exact proof_of_C.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics HoTT.Types UnivalenceImpliesFunext.
Require Import TruncType HProp HSet.
Require Import Spaces.Int.
Require Import HIT.Coeq HIT.Circle HIT.Flattening Truncations.
Import TrM.

Local Open Scope path_scope.

(** * Quotients by free actions of [Int] *)

(** We will show that if [Int] acts freely on a set, then the set-quotient of that action can be defined without a 0-truncation, giving it a universal property for mapping into all types. *)

Section FreeIntAction.

  Context `{Univalence}.
  Context (R : Type) `{IsHSet R}.

  (** A free action by [Int] is the same as a single autoequivalence [f] (the action of [1]) whose iterates are all pointwise distinct. *)
  Context (f : R <~> R)
          (f_free : forall (r : R) (n m : Int),
                      (int_iter f n r = int_iter f m r) -> (n = m)).

  (** We can then define the quotient to be the coequalizer of [f] and the identity map.  This gives it the desired universal property for all types; it remains to show that this definition gives a set. *)
  Let RmodZ := Coeq f idmap.

  (** Together, [R] and [f] define a fibration over [S1].  By the flattening lemma, its total space is equivalent to the quotient. *)
  Global Instance isset_RmodZ : IsHSet RmodZ.
  Proof.
    refine (trunc_equiv'
              { z : S1 & S1_rec Type R (path_universe f) z}
              (_ oE (@equiv_flattening _ Unit Unit idmap idmap
                                  (fun _ => R) (fun _ => f))^-1
              oE _));
    try exact _.
    - unshelve erapply equiv_adjointify.
      + simple refine (Wtil_rec _ _ _).
        * intros u r; exact (coeq r).
        * intros u r; cbn. exact ((cglue r)^).
      + simple refine (Coeq_rec _ _ _).
        * exact (cct tt).
        * intros r; exact ((ppt tt r)^).
      + refine (Coeq_ind _ (fun a => 1) _); cbn; intros b.
        rewrite transport_paths_FlFr, concat_p1, ap_idmap.
        apply moveR_Vp; rewrite concat_p1.
        rewrite ap_compose.
        rewrite (Coeq_rec_beta_cglue
                   (Wtil Unit Unit idmap idmap (unit_name R) (unit_name f))
                   (cct tt) (fun r => (ppt tt r)^) b).
        rewrite ap_V; symmetry.
        refine (inverse2
                  (Wtil_rec_beta_ppt
                     RmodZ (unit_name (fun r => coeq r))
                     (unit_name (fun r => (cglue r)^)) tt b) @ inv_V _).
      + simple refine (Wtil_ind _ _ _); cbn.
        { intros [] ?; reflexivity. }
        intros [] r; cbn.
        rewrite transport_paths_FlFr, concat_p1, ap_idmap.
        apply moveR_Vp; rewrite concat_p1.
        rewrite ap_compose.
        refine (_ @ ap (ap _) (Wtil_rec_beta_ppt
                   RmodZ (unit_name (fun r => coeq r))
                   (unit_name (fun r => (cglue r)^)) tt r)^).
        rewrite ap_V.
        rewrite (Coeq_rec_beta_cglue
                   (Wtil Unit Unit idmap idmap (unit_name R) (unit_name f))
                   (cct tt) (fun r0 : R => (ppt tt r0)^) r).
        symmetry; apply inv_V.
    - refine (equiv_functor_sigma' 1 _); intros x.
      apply equiv_path.
      revert x; refine (S1_ind _ 1 _); cbn.
      rewrite transport_paths_FlFr, concat_p1.
      apply moveR_Vp; rewrite concat_p1.
      rewrite S1_rec_beta_loop.
      unfold loop.
      exact (Coeq_rec_beta_cglue _ _ _ _).
    - intros xu yv.
      refine (trunc_equiv' (n := -1) _ (equiv_path_sigma _ xu yv)).
      destruct xu as [x u], yv as [y v]; cbn.
      apply hprop_allpath.
      intros [p r] [q s].
      set (P := S1_rec Type R (path_universe f)) in *.
      assert (forall z, IsHSet (P z)).
      { simple refine (S1_ind _ _ _); cbn beta.
        - exact _.
        - apply path_ishprop. }
      apply path_sigma_hprop; cbn.
      assert (t := r @ s^); clear r s.
      assert (xb := merely_path_is0connected S1 base x).
      assert (yb := merely_path_is0connected S1 base y).
      strip_truncations. destruct xb, yb.
      revert p q t.
      equiv_intro (equiv_loopS1_int^-1) n.
      equiv_intro (equiv_loopS1_int^-1) m.
      subst P.
      rewrite !S1_action_is_iter.
      intros p. apply ap.
      exact (f_free u n m p).
  Qed.

  (** TODO: Prove that this [RmodZ] is equivalent to the set-quotient of [R] by a suitably defined equivalence relation. *)

End FreeIntAction.