Require Import rt.util.all.
Require Import rt.model.basic.task rt.model.basic.job rt.model.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
Set Implicit Arguments.

(* Definitions of FP and JLFP/JLDP priority relations. *)
Module Priority.

  Import SporadicTask Schedule.

  Section PriorityDefs.

    (* Assume a given job arrival sequence. *)
    Context {Job: eqType}.
    Variable arr_seq: arrival_sequence Job.

    Section Definitions.

      (* In the following, we define all priority relations as non-strict, i.e., they specify that
         "job_high has higher priority than (or the same priority as) job_low". *)

      (* A JLDP policy is a generic relation between two jobs of an arrival sequence
         that can vary with time. *)
      Definition JLDP_policy := time -> JobIn arr_seq -> JobIn arr_seq -> bool.

      (* FP policy is simply a relation between tasks.
         Because our model of processor platform is based on a generic JLDP policy,
         we generate a JLDP policy from an FP policy whenever required. *)
      Variable sporadic_task: eqType.
      Definition FP_policy := sporadic_task -> sporadic_task -> bool.

    End Definitions.

    Section ValidJLFPPolicy.

      Variable is_higher_priority: JLDP_policy.

      (* A policy is reflexive, since a job has the same priority as itself. *)
      Definition JLFP_is_reflexive :=
        forall t, reflexive (is_higher_priority t).

      (* A policy is transitive. *)
      Definition JLFP_is_transitive :=
        forall t, transitive (is_higher_priority t).

      (* A policy is total, since it must know the priority of any two jobs at any time. *)
      Definition JLFP_is_total :=
        forall t, total (is_higher_priority t).

      (* A JLDP policy is valid iff it satisfies the three properties.
         Note that, for generality, we don't enforce antisymmetry and allow multiple
         jobs with same priority. *)
      Definition valid_JLDP_policy :=
        JLFP_is_reflexive /\ JLFP_is_transitive /\ JLFP_is_total.

    End ValidJLFPPolicy.

    Section MonotonicPriorities.

      Context {sporadic_task: eqType}.
      Variable job_task: Job -> sporadic_task.
      Variable higher_eq_priority: JLDP_policy.

      Definition monotonic_priorities :=
        forall (j j': JobIn arr_seq) t,
          job_task j = job_task j' ->
          job_arrival j < job_arrival j' ->
          higher_eq_priority t j j'.

    End MonotonicPriorities.

    Section ValidFPPolicy.

      Context {sporadic_task: eqType}.

      Variable is_higher_priority: FP_policy sporadic_task.

      Definition FP_is_reflexive := reflexive is_higher_priority.

      Definition FP_is_transitive := transitive is_higher_priority.

      Definition FP_is_total := total is_higher_priority.

      (* We enforce the same restrictions for FP policy: reflexive, transitive, total. *)
      Definition valid_FP_policy :=
        FP_is_reflexive /\ FP_is_transitive /\ FP_is_total.

    End ValidFPPolicy.

  End PriorityDefs.

  Section RateDeadlineMonotonic.

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

    (* Rate-Monotonic and Deadline-Monotonic as priority order *)
    Definition RM (tsk1 tsk2: sporadic_task) := task_period tsk1 <= task_period tsk2.

    Definition DM (tsk1 tsk2: sporadic_task) := task_deadline tsk1 <= task_deadline tsk2.

    (* Rate-Montonic is a valid FP policy. *)
    Lemma rm_is_valid : valid_FP_policy RM.
    Proof.
      unfold valid_FP_policy, FP_is_reflexive, FP_is_transitive, RM;
        repeat (split; try red); first by ins.
      by intros x y z XY YZ; apply leq_trans with (n := task_period x).
      by red; intros tsk1 tsk2; apply/orP; destruct (leqP (task_period tsk1) (task_period tsk2));
        [by left | by right; apply ltnW].
    Qed.

    (* Deadline-Monotonic is a valid FP policy. *)
    Lemma dm_is_valid : valid_FP_policy DM.
    Proof.
      unfold valid_FP_policy, FP_is_reflexive, FP_is_transitive, DM;
      repeat (split; try red); first by ins.
        by intros x y z; apply leq_trans.
        by red; intros tsk1 tsk2; apply/orP; destruct (leqP (task_deadline tsk1) (task_deadline tsk2));
          [by left | by right; apply ltnW].
    Qed.

  End RateDeadlineMonotonic.

  Section GeneralizeFP.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_task: Job -> sporadic_task.
    Variable arr_seq: arrival_sequence Job.
    Variable num_cpus: nat.

    (* We define a function to get from FP to JLDP policy. *)
    Definition FP_to_JLDP (task_hp: FP_policy sporadic_task) : JLDP_policy arr_seq :=
      fun (t: time) (jhigh jlow: JobIn arr_seq) =>
        task_hp (job_task jhigh) (job_task jlow).

    (* With this function, from a valid FP policy comes a valid JLDP policy. *)
    Lemma valid_FP_is_valid_JLDP :
      forall task_hp (FP: valid_FP_policy task_hp),
        valid_JLDP_policy (FP_to_JLDP task_hp).
    Proof.
      unfold FP_to_JLDP, valid_FP_policy, valid_JLDP_policy,
             FP_is_reflexive, FP_is_transitive, FP_is_total,
             JLFP_is_reflexive, JLFP_is_transitive, JLFP_is_total, reflexive, transitive.
      ins; destruct FP as [REFL [TRANS TOTAL]]; repeat (split; try red); des; last by ins.
        by ins; rewrite REFL.
        by intros sched t y x z; apply TRANS.
    Qed.

  End GeneralizeFP.

  Section JLFPDefs.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Context {num_cpus: nat}.
    Context {arr_seq: arrival_sequence Job}.

    Variable is_higher_priority: JLDP_policy arr_seq.

    (* JLFP policy is a JLDP policy where the priorities do not vary with time. *)
    Definition is_JLFP_policy (is_higher_priority: JLDP_policy arr_seq) :=
      forall j1 j2 t t',
        is_higher_priority t j1 j2 -> is_higher_priority t' j1 j2.

    (* Lemma: every FP policy is a JLFP policy. *)
    Variable job_task: Job -> sporadic_task.
    Lemma FP_is_JLFP :
      forall FP_higher_priority,
        is_JLFP_policy (FP_to_JLDP job_task FP_higher_priority).
    Proof.
      by unfold is_JLFP_policy, valid_FP_policy.
    Qed.

  End JLFPDefs.

  Section EDFDefs.

    Context {Job: eqType}.
    Variable arr_seq: arrival_sequence Job.
    Variable job_deadline: Job -> time.

    Definition EDF (t: time) (j1 j2: JobIn arr_seq) :=
      job_arrival j1 + job_deadline j1 <= job_arrival j2 + job_deadline j2.

    (* Lemma: EDF is a JLFP policy. *)
    Lemma edf_JLFP : is_JLFP_policy EDF.
    Proof.
      by unfold is_JLFP_policy, EDF.
    Qed.

    Lemma edf_valid_policy : valid_JLDP_policy EDF.
    Proof.
      unfold valid_JLDP_policy, EDF, JLFP_is_reflexive, JLFP_is_transitive, reflexive, transitive.
      repeat (split; try red).
        by ins; apply leqnn.
        by intros sched t y x z; apply leq_trans.
        by intros _; red; intros j1 j2; apply/orP;
          destruct (leqP (job_arrival j1 + job_deadline j1) (job_arrival j2 + job_deadline j2));
            [by left | by right; apply ltnW].
    Qed.

  End EDFDefs.

End Priority.


Coq < Section Easy015.

Coq < Require Import Classical.

Coq < Load CpdtTactics.

Coq < Variables U V W X: Prop.
U is assumed
V is assumed
W is assumed
X is assumed

Coq < Goal ((U -> V) /\ (W -> X) /\ (V -> W)) -> (U -> X).
1 subgoal

  U : Prop
  V : Prop
  W : Prop
  X : Prop
  ============================
   (U -> V) /\ (W -> X) /\ (V -> W) -> U -> X

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined


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

Require Import Arith List Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import php.

From Undecidability.Shared.Libs.DLW.Wf
  Require Import wf_chains.

Set Implicit Arguments.

Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊆" := incl (at level 70, no associativity).

Section wf_strict_order_list.

  Variable (X : Type) (R : X -> X -> Prop).
  Hypothesis (Rirrefl : forall x, ~ R x x)
             (Rtrans : forall x y z, R x y -> R y z -> R x z).

  Implicit Type l : list X.

  Fact chain_trans n x y : chain R n x y -> n = 0 /\ x = y \/ R x y.
  Proof. induction 1 as [ | ? ? ? ? ? ? [ [] | ] ]; subst; eauto. Qed.

  Corollary chain_irrefl n x :~ chain R (S n) x x.
  Proof.
    intros H.
    apply chain_trans in H as [ (? & _) | H ]; try easy.
    revert H; apply Rirrefl.
  Qed.

  (* Assume a list over approximating the domain of R *)

  Variable (m : list X) (Hm : forall x y, R x y -> x ∊ m).

  Hint Resolve incl_nil_l incl_cons : core.

  Fact chain_list_incl l x y : chain_list R l x y -> l ⊆ m.
  Proof. induction 1; simpl; eauto. Qed.

  (* Any chain of length above length m contains a duplicated
      value (by the PHP) hence a non nil sub-chain with identical
      endpoints, contradicting chain_irrefl *)

  Lemma chain_bounded n x y : chain R n x y -> n <= length m.
  Proof.
    intros H.
    destruct (le_lt_dec n (length m)) as [ | C ]; auto.
    destruct chain_chain_list with (1 := H)
      as (ll & H1 & H2).
    cut (list_has_dup ll).
    + intros H3.
      apply list_has_dup_equiv in H3 as (z & l & u & r & ->).
      apply chain_list_app_inv in H1 as (a & _ & H1).
      apply chain_list_cons_inv in H1 as (<- & k & H3 & H1).
      apply chain_list_app_inv in H1 as (p & H4 & H1).
      apply chain_list_cons_inv in H1 as (<- & _ & _ & _).
      apply chain_list_chain in H4.
      destruct (@chain_irrefl (length u) z).
      constructor 2 with k; auto.
    + apply chain_list_incl in H1.
      apply finite_php_dup with (2 := H1); lia.
  Qed.

  (* Since chains have bounded length, we get WF *)

  Hint Resolve chain_bounded : core.

  Theorem wf_strict_order_list : well_founded R.
  Proof. apply wf_chains; eauto. Qed.

End wf_strict_order_list.

Section wf_strict_order_finite.

  Variable (X : Type) (HX : exists l, forall x : X, x ∊ l)
           (R : X -> X -> Prop)
           (Rirrefl : forall x, ~ R x x)
           (Rtrans : forall x y z, R x y -> R y z -> R x z).

  Theorem wf_strict_order_finite : well_founded R.
  Proof.
    destruct HX as (m & Hm).
    apply wf_strict_order_list with (m := m); auto.
  Qed.

End wf_strict_order_finite.


Require Export euclidean__axioms.
Require Export lemma__betweennesspreserved.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export logic.
Definition lemma__collinearitypreserved : forall A B C a b c, (euclidean__axioms.Col A B C) -> ((euclidean__axioms.Cong A B a b) -> ((euclidean__axioms.Cong A C a c) -> ((euclidean__axioms.Cong B C b c) -> (euclidean__axioms.Col a b c)))).
Proof.
intro A.
intro B.
intro C.
intro a.
intro b.
intro c.
intro H.
intro H0.
intro H1.
intro H2.
assert (* Cut *) (euclidean__axioms.Cong C B B C) as H3.
- apply (@euclidean__axioms.cn__equalityreverse C B).
- assert (* Cut *) (euclidean__axioms.Cong C B b c) as H4.
-- apply (@lemma__congruencetransitive.lemma__congruencetransitive C B B C b c H3 H2).
-- assert (* Cut *) (euclidean__axioms.Cong b c c b) as H5.
--- apply (@euclidean__axioms.cn__equalityreverse b c).
--- assert (* Cut *) (euclidean__axioms.Cong C B c b) as H6.
---- apply (@lemma__congruencetransitive.lemma__congruencetransitive C B b c c b H4 H5).
---- assert (* Cut *) (euclidean__axioms.Cong a b b a) as H7.
----- apply (@euclidean__axioms.cn__equalityreverse a b).
----- assert (* Cut *) (euclidean__axioms.Cong A B b a) as H8.
------ apply (@lemma__congruencetransitive.lemma__congruencetransitive A B a b b a H0 H7).
------ assert (* Cut *) (euclidean__axioms.Cong A B B A) as H9.
------- apply (@euclidean__axioms.cn__equalityreverse A B).
------- assert (* Cut *) (euclidean__axioms.Cong B A A B) as H10.
-------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B A B A H9).
-------- assert (* Cut *) (euclidean__axioms.Cong B A b a) as H11.
--------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B A A B b a H10 H8).
--------- assert ((A = B) \/ ((A = C) \/ ((B = C) \/ ((euclidean__axioms.BetS B A C) \/ ((euclidean__axioms.BetS A B C) \/ (euclidean__axioms.BetS A C B)))))) as H12 by exact H.
assert (* Cut *) (euclidean__axioms.Col a b c) as H13.
---------- assert ((A = B) \/ ((A = C) \/ ((B = C) \/ ((euclidean__axioms.BetS B A C) \/ ((euclidean__axioms.BetS A B C) \/ (euclidean__axioms.BetS A C B)))))) as H13 by exact H12.
assert ((A = B) \/ ((A = C) \/ ((B = C) \/ ((euclidean__axioms.BetS B A C) \/ ((euclidean__axioms.BetS A B C) \/ (euclidean__axioms.BetS A C B)))))) as __TmpHyp by exact H13.
destruct __TmpHyp as [H14|H14].
----------- assert (* Cut *) (euclidean__axioms.Cong A A a b) as H15.
------------ apply (@eq__ind__r euclidean__axioms.Point B (fun A0 => (euclidean__axioms.Col A0 B C) -> ((euclidean__axioms.Cong A0 B a b) -> ((euclidean__axioms.Cong A0 C a c) -> ((euclidean__axioms.Cong A0 B b a) -> ((euclidean__axioms.Cong A0 B B A0) -> ((euclidean__axioms.Cong B A0 A0 B) -> ((euclidean__axioms.Cong B A0 b a) -> (euclidean__axioms.Cong A0 A0 a b))))))))) with (x := A).
-------------intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
intro H20.
intro H21.
exact H16.

------------- exact H14.
------------- exact H.
------------- exact H0.
------------- exact H1.
------------- exact H8.
------------- exact H9.
------------- exact H10.
------------- exact H11.
------------ assert (* Cut *) (euclidean__axioms.Cong a b A A) as H16.
------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a A A b H15).
------------- assert (* Cut *) (~(euclidean__axioms.neq a b)) as H17.
-------------- intro H17.
assert (* Cut *) (euclidean__axioms.neq A A) as H18.
--------------- apply (@euclidean__axioms.axiom__nocollapse a b A A H17 H16).
--------------- assert (* Cut *) (A = A) as H19.
---------------- assert (* Cut *) (False) as H19.
----------------- assert (* Cut *) (A = A) as H19.
------------------ apply (@logic.eq__refl Point A).
------------------ apply (@H18 H19).
----------------- assert (False) as H20 by exact H19.
apply (@logic.eq__refl Point A).
---------------- apply (@H18 H19).
-------------- assert (* Cut *) (a = b) as H18.
--------------- apply (@euclidean__axioms.cn__stability a b H17).
--------------- assert (* Cut *) (euclidean__axioms.Col a b c) as H19.
---------------- left.
exact H18.
---------------- exact H19.
----------- destruct H14 as [H15|H15].
------------ assert (* Cut *) (euclidean__axioms.Cong A A a c) as H16.
------------- apply (@eq__ind__r euclidean__axioms.Point C (fun A0 => (euclidean__axioms.Col A0 B C) -> ((euclidean__axioms.Cong A0 B a b) -> ((euclidean__axioms.Cong A0 C a c) -> ((euclidean__axioms.Cong A0 B b a) -> ((euclidean__axioms.Cong A0 B B A0) -> ((euclidean__axioms.Cong B A0 A0 B) -> ((euclidean__axioms.Cong B A0 b a) -> (euclidean__axioms.Cong A0 A0 a c))))))))) with (x := A).
--------------intro H16.
intro H17.
intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
exact H18.

-------------- exact H15.
-------------- exact H.
-------------- exact H0.
-------------- exact H1.
-------------- exact H8.
-------------- exact H9.
-------------- exact H10.
-------------- exact H11.
------------- assert (* Cut *) (euclidean__axioms.Cong a c A A) as H17.
-------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a A A c H16).
-------------- assert (* Cut *) (~(euclidean__axioms.neq a c)) as H18.
--------------- intro H18.
assert (* Cut *) (euclidean__axioms.neq A A) as H19.
---------------- apply (@euclidean__axioms.axiom__nocollapse a c A A H18 H17).
---------------- assert (* Cut *) (A = A) as H20.
----------------- assert (* Cut *) (False) as H20.
------------------ assert (* Cut *) (A = A) as H20.
------------------- apply (@logic.eq__refl Point A).
------------------- apply (@H19 H20).
------------------ assert (False) as H21 by exact H20.
apply (@logic.eq__refl Point A).
----------------- apply (@H19 H20).
--------------- assert (* Cut *) (a = c) as H19.
---------------- apply (@euclidean__axioms.cn__stability a c H18).
---------------- assert (* Cut *) (euclidean__axioms.Col a b c) as H20.
----------------- right.
left.
exact H19.
----------------- exact H20.
------------ destruct H15 as [H16|H16].
------------- assert (* Cut *) (euclidean__axioms.Cong B B b c) as H17.
-------------- apply (@eq__ind__r euclidean__axioms.Point C (fun B0 => (euclidean__axioms.Col A B0 C) -> ((euclidean__axioms.Cong A B0 a b) -> ((euclidean__axioms.Cong B0 C b c) -> ((euclidean__axioms.Cong C B0 B0 C) -> ((euclidean__axioms.Cong C B0 b c) -> ((euclidean__axioms.Cong C B0 c b) -> ((euclidean__axioms.Cong A B0 b a) -> ((euclidean__axioms.Cong A B0 B0 A) -> ((euclidean__axioms.Cong B0 A A B0) -> ((euclidean__axioms.Cong B0 A b a) -> (euclidean__axioms.Cong B0 B0 b c)))))))))))) with (x := B).
---------------intro H17.
intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
intro H25.
intro H26.
exact H19.

--------------- exact H16.
--------------- exact H.
--------------- exact H0.
--------------- exact H2.
--------------- exact H3.
--------------- exact H4.
--------------- exact H6.
--------------- exact H8.
--------------- exact H9.
--------------- exact H10.
--------------- exact H11.
-------------- assert (* Cut *) (euclidean__axioms.Cong b c B B) as H18.
--------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric b B B c H17).
--------------- assert (* Cut *) (~(euclidean__axioms.neq b c)) as H19.
---------------- intro H19.
assert (* Cut *) (euclidean__axioms.neq B B) as H20.
----------------- apply (@euclidean__axioms.axiom__nocollapse b c B B H19 H18).
----------------- assert (* Cut *) (B = B) as H21.
------------------ assert (* Cut *) (False) as H21.
------------------- assert (* Cut *) (B = B) as H21.
-------------------- apply (@logic.eq__refl Point B).
-------------------- apply (@H20 H21).
------------------- assert (False) as H22 by exact H21.
apply (@logic.eq__refl Point B).
------------------ apply (@H20 H21).
---------------- assert (* Cut *) (b = c) as H20.
----------------- apply (@euclidean__axioms.cn__stability b c H19).
----------------- assert (* Cut *) (euclidean__axioms.Col a b c) as H21.
------------------ right.
right.
left.
exact H20.
------------------ exact H21.
------------- destruct H16 as [H17|H17].
-------------- assert (* Cut *) (euclidean__axioms.BetS b a c) as H18.
--------------- apply (@lemma__betweennesspreserved.lemma__betweennesspreserved B A C b a c H11 H2 H1 H17).
--------------- assert (* Cut *) (euclidean__axioms.Col a b c) as H19.
---------------- right.
right.
right.
left.
exact H18.
---------------- exact H19.
-------------- destruct H17 as [H18|H18].
--------------- assert (* Cut *) (euclidean__axioms.BetS a b c) as H19.
---------------- apply (@lemma__betweennesspreserved.lemma__betweennesspreserved A B C a b c H0 H1 H2 H18).
---------------- assert (* Cut *) (euclidean__axioms.Col a b c) as H20.
----------------- right.
right.
right.
right.
left.
exact H19.
----------------- exact H20.
--------------- assert (* Cut *) (euclidean__axioms.BetS a c b) as H19.
---------------- apply (@lemma__betweennesspreserved.lemma__betweennesspreserved A C B a c b H1 H0 H6 H18).
---------------- assert (* Cut *) (euclidean__axioms.Col a b c) as H20.
----------------- right.
right.
right.
right.
right.
exact H19.
----------------- exact H20.
---------- exact H13.
Qed.


Definition task := forall n m, n < m \/ n = m \/ n > m.


Require Import ZArith.
(** Divisibility *)

Definition divide (a b : Z) : Prop := exists q : Z, b = (q * a)%Z.
Notation "( x | y )" := (divide x y) (at level 0) : Z_scope.

Local Open Scope Z_scope.

Lemma divide_refl_: forall a: Z, (a | a).
Proof.  intros. unfold divide. exists 1. ring.
Qed.

(* ========================================== *)
Lemma divide_mult_left : forall a b c : Z, (a | b) -> ((c * a)%Z | (c * b)%Z).
Proof.
intros. unfold divide.
destruct H.
exists x.
rewrite H.
ring.
Qed.

Require Import Zdiv.
Require Import ZArith.Zorder.
Require Import ssreflect.

Definition gcd (a b d : Z) : Prop := (d | a)%Z /\ (d | b)%Z /\
      (forall x : Z, ((x | a)%Z /\ (x | b)%Z) -> (d >= x)%Z).

(** Trivial properties of [gcd] *)

Lemma gcd_sym : forall a b d : Z, gcd a b d -> gcd b a d.
Proof.
intros. destruct H. destruct H0.
split. apply H0. split. apply H.
intros.
apply H1.
split.
destruct H2. apply H3.
destruct H2. apply H2.
Qed.

Lemma gcd_0 : forall a : Z, gcd a 0 a.
Proof.
intro.
split.
exists 1%Z.
ring.
split.
exists 0%Z.
ring.
intro. move => H.
destruct H.
destruct H.
destruct H0.
rewrite H.

Admitted.

Lemma gcd_minus : forall a b d : Z, gcd a (- b) d -> gcd b a d.
Proof.
 intros. split.
destruct H.
destruct H0.
Admitted.

Lemma gcd_mult : forall a b c d : Z, gcd a b d -> gcd (c * a) (c * b) (c * d).
intros.
split.
destruct H.
destruct H.
exists x.
rewrite H.
ring.
split.
destruct H.
destruct H0.
destruct H0.
exists x.
rewrite H0.
ring.
intros.
destruct H.
destruct H1.
(*apply H2.*)
replace (c * d >= x)%Z with (d >= x / c)%Z.
apply H2.
split.
destruct H0.
destruct H0.
exists x0.
Admitted.


Require Import Logic_and_Set_Theory.
Require Import EoM_Zorns_Lemma.
Require Import L_1_4_10_EoM_Intro.
From Coq Require Import Powerset_facts.
From Coq Require Import Finite_sets.
From Coq Require Import Powerset_Classical_facts.
From Coq Require Import Finite_sets_facts.
From Coq Require Import Constructive_sets.

Lemma chain_subset_is_chain: forall (T A : (Ensemble (Ensemble Formula))) (Gamma : Ensemble Formula),
Included (Ensemble Formula) A T -> chain (Ensemble Formula) Inc (TheSet Gamma) T -> chain (Ensemble Formula) Inc (TheSet Gamma) A.
Proof.
    intros T A Gamma H H1. unfold chain. split. unfold chain in H1.
    +apply H1.
    +split.
    ++unfold chain in H1. destruct H1. destruct H1.
    assert(Inc_Trans: Transitive (Ensemble (Ensemble Formula)) (Included (Ensemble Formula))).
    +++apply Inclusion_is_transitive.
    +++unfold Transitive in Inc_Trans. apply Inc_Trans with (y:=T).
    -apply H. -apply H1.
    ++intros x y H0 H2. apply H1.
    -apply H. apply H0. -apply H. apply H2.
    Qed.

Lemma finite_chain_has_maximum:forall (T : (Ensemble (Ensemble Formula))) (Gamma : Ensemble Formula),
chain (Ensemble Formula) Inc (TheSet Gamma) T -> Finite (Ensemble Formula) T ->
(exists (Pi : Ensemble Formula), In (Ensemble Formula) T Pi) ->
exists (max : Ensemble Formula), In (Ensemble Formula) T max /\ forall (Pi' : Ensemble Formula), In (Ensemble Formula) T Pi' -> Inc Pi' max.
intros T Gamma H H0 H1. induction H0.
+destruct H1. exists x. destruct H0.
+assert (exists (Gamma : Ensemble Formula), In (Ensemble Formula) A Gamma).
++apply Chains_Are_Nonempty with (Gamma:=Gamma). apply chain_subset_is_chain with (T:=Add (Ensemble Formula) A x).
+++unfold Included. intros f Hf. apply Union_introl. apply Hf.
+++apply H.
++destruct IHFinite.
+++apply chain_subset_is_chain with (T:=Add (Ensemble Formula) A x).
++++unfold Included. intros f Hf. apply Union_introl. apply Hf.
++++apply H.
+++apply H3.
+++rename x0 into maxA.
assert (H5: Inc maxA x \/ Inc x maxA ).
++++apply H.
+++++apply Union_introl. apply H4.
+++++apply Union_intror. apply In_singleton.
++++destruct H5.
+++++exists x. split.
-apply Union_intror. apply In_singleton.
-intros Pi' H6. destruct H6.
--assert (H7: Inc x0 maxA).
---apply H4. apply H6.
---unfold Inc. unfold Included. intros f Hf.
apply H7 in Hf. apply H5 in Hf. apply Hf.
--apply Singleton_inv in H6. rewrite -> H6.
unfold Inc. unfold Included. intros f Hf. apply Hf.
+++++exists maxA. split.
-apply Union_introl. apply H4.
-intros Pi' H6. destruct H6. rename x0 into Pi'.
--apply H4. apply H6.
--apply Singleton_inv in H6. rewrite <- H6. apply H5.
Qed.

Lemma chain_finite_subset_has_maximum: forall (T D: Ensemble (Ensemble Formula)) (Gamma : Ensemble Formula),
chain (Ensemble Formula) Inc (TheSet Gamma) T -> Included (Ensemble Formula) D T -> Finite (Ensemble Formula) D -> (exists (Gamma':(Ensemble Formula)), In (Ensemble Formula) D Gamma')
->exists (max : Ensemble Formula), In (Ensemble Formula) D max /\ (forall (Pi' : Ensemble Formula), In (Ensemble Formula) D Pi' -> Inc Pi' max).
Proof.
    intros T D Gamma H H0 H1 H2. apply finite_chain_has_maximum with (Gamma := Gamma).
    +apply chain_subset_is_chain with (T:=T).
        ++apply H0.
        ++apply H.
    +apply H1.
    +apply H2.
Qed.

Lemma first_sentence : forall (T : Ensemble (Ensemble Formula)) (Pi : Ensemble Formula),
Inc Pi (UoCE1 T) -> forall (f : Formula), In Formula Pi f -> exists (A : Ensemble Formula), In Formula A f /\ In (Ensemble Formula) T A.
Proof.
    intros T Pi HI f Hf. unfold UoCE1 in HI. unfold Inc in HI.
    unfold Included in HI. apply HI in Hf. apply About_PropUoCEl in Hf.
    unfold PropUoCE2 in Hf. destruct Hf as [A HA].
    exists A. split. apply HA. apply HA.
Qed.

(*Includers of Pi elements:*)
Definition PropIoPE (Pi : Ensemble Formula) (T : Ensemble (Ensemble Formula)) (A : Ensemble Formula) : Prop:=
In (Ensemble Formula) T A /\ (exists (f : Formula), In Formula Pi f /\ In Formula A f /\ (forall (B : Ensemble Formula), In Formula B f -> In (Ensemble Formula) T B -> Inc A B)).

Definition IoPE (Pi : Ensemble Formula) (T : Ensemble (Ensemble Formula)) : (Ensemble (Ensemble Formula)):=
PropIoPE Pi T.

Lemma About_IoPEr : forall (Pi A:Ensemble Formula) (T:Ensemble (Ensemble Formula)),
PropIoPE Pi T A -> In (Ensemble Formula) (IoPE Pi T) A.
Proof. intros Pi A T H. apply H.
Qed.

Lemma About_IoPEl : forall (Pi A:Ensemble Formula) (T:Ensemble (Ensemble Formula)),
In (Ensemble Formula) (IoPE Pi T) A -> PropIoPE Pi T A.
Proof. intros f T H Q. apply Q.
Qed.

Lemma IoPE_Empty_set: forall (T : Ensemble (Ensemble Formula)), IoPE (Empty_set Formula) T = Empty_set (Ensemble Formula).
Proof. intros T. apply Extensionality_Ensembles. unfold Same_set.
split.
+unfold Included. intros X H. apply About_IoPEl in H. unfold PropIoPE in H.
destruct H. destruct H0. rename x into f. destruct H0. destruct H0.
+unfold Included. intros f H. destruct H.
Qed.

Lemma IoPE_Singleton_set:forall (T : Ensemble (Ensemble Formula)) (f : Formula) (A: Ensemble Formula),
In (Ensemble Formula)T A /\ In Formula A f /\ (forall (B:Ensemble Formula), In (Ensemble Formula) T B -> In Formula B f -> Inc A B)
->IoPE (Singleton Formula f) T = Singleton (Ensemble Formula) A.
intros T f A H. apply Extensionality_Ensembles. unfold Same_set.
split. destruct H. destruct H0.
+unfold Included. intros X H2. apply About_IoPEl in H2. unfold PropIoPE in H2.
assert (H3: X=A). destruct H2. destruct H3. destruct H3. destruct H4.
-assert (H6 : Inc X A).
--apply H5. ---apply Singleton_inv in H3. rewrite <- H3.
apply H0.
---apply H.
--assert (Inc A X).
---apply H1. ----apply H2. ----apply Singleton_inv in H3. rewrite -> H3.
apply H4.
---apply Extensionality_Ensembles. unfold Same_set. split.
----apply H6. ----apply H7.
-rewrite -> H3. apply In_singleton.
+destruct H. destruct H0. unfold Included. intros x H2.
apply About_IoPEr. unfold PropIoPE. split.
++apply Singleton_inv in H2. rewrite <- H2. apply H.
++exists f. split.
+++apply In_singleton.
+++split.
++++apply Singleton_inv in H2. rewrite <- H2. apply H0.
++++intros B H3 H4. apply Singleton_inv in H2. rewrite <- H2.
apply H1. -apply H4. -apply H3.
Qed.

Lemma Add_IoPE : forall (T : Ensemble (Ensemble Formula)) (Pi: Ensemble Formula) (f:Formula),
~(In Formula Pi f) -> IoPE (Add Formula Pi f) T = Union (Ensemble Formula) (IoPE Pi T) (IoPE (Singleton Formula f) T).
Proof.
    intros T Pi f H.
    apply Extensionality_Ensembles. unfold Same_set. split.
    +unfold Included. unfold Add. intros A H1. apply About_IoPEl in H1.
    unfold PropIoPE in H1. destruct H1. destruct H1. destruct H1.
    apply Union_inv in H1. destruct H1.
    ++apply Union_introl. apply About_IoPEr. unfold PropIoPE.
    split.
    -apply H0. -exists x. split. --apply H1. --apply H2.
    ++apply Union_intror. apply Singleton_inv in H1.
    rewrite ->H1 in H.
    rewrite -> IoPE_Singleton_set with (A:=A).
    +++apply In_singleton.
    +++split.
    -apply H0.
    -split.
    --rewrite -> H1. destruct H2. apply H2.
    --intros B H3 H4. destruct H2. apply H5.
    ---rewrite <- H1. apply H4. ---apply H3.
    +unfold Included. intros A H1. apply About_IoPEr. unfold PropIoPE.
    apply Union_inv in H1. destruct H1.
    ++split. apply About_IoPEl in H0. unfold PropIoPE in H0.
    destruct H0. destruct H1. destruct H1. destruct H2.
    +++apply H0.
    +++destruct H0. destruct H1. destruct H1. destruct H2.
    exists x. split.
    -apply Union_introl. apply H1.
    -split.
    --apply H2.
    --apply H3.
    ++split.
    -apply About_IoPEl in H0. unfold PropIoPE in H0.
    destruct H0. destruct H1. destruct H1. destruct H2.
    apply H0.
    -apply About_IoPEl in H0. unfold PropIoPE in H0.
    destruct H0. destruct H1. destruct H1. destruct H2.
    exists x. split.
    --apply Union_intror. apply H1.
    --split.
    ---apply H2.
    ---apply H3.
    Qed.

Lemma Union_finite_but_not_add : forall (U : Type) (A : Ensemble U) (x : U),
Finite U A -> ~ In U A x -> Finite U (Union U A (Singleton U (x))).
intros U A x H H3.
assert (H1: Union U A (Singleton U x) = Add U A x).
+apply Extensionality_Ensembles. unfold Same_set.
split.
++unfold Included. intros u Hu. unfold Add. apply Hu.
++unfold Included. intros u Hu. unfold Add in Hu. apply Hu.
+rewrite -> H1. apply Union_is_finite.
-apply H.
-apply H3.
Qed.

Lemma chain_has_minimum: forall (T : Ensemble(Ensemble Formula)) (Gamma : Ensemble Formula),
chain (Ensemble Formula) Inc (TheSet Gamma) T -> exists (min : Ensemble Formula), In (Ensemble Formula) T min /\ forall (A : Ensemble Formula), In (Ensemble Formula) T A -> Inc min A.
Proof.
intros T Gamma H. unfold chain in H.
Admitted.

Lemma chain_with_certain_formula_has_minimum: forall (T: Ensemble (Ensemble Formula)) (f : Formula),
In Formula (UoCE1 T) f -> exists (A : Ensemble Formula),forall (B : Ensemble Formula), In Formula B f -> Inc A B.
Proof.
Admitted.

Lemma IoPE_is_not_empty :forall (T : Ensemble (Ensemble Formula)) (Pi : Ensemble Formula),
(exists f : Formula, In Formula Pi f /\ In Formula (UoCE1 T) f) -> exists (A : Ensemble Formula), In (Ensemble Formula) (IoPE Pi T) A.
Proof.
    Admitted.

Axiom for_a_certain_formula_there_is_a_subset_in_chain:
forall (T : Ensemble (Ensemble Formula)) (Gamma : Ensemble Formula) (f : Formula),
chain (Ensemble Formula) Inc (TheSet Gamma) T -> (In Formula (UoCE1 T) f) -> exists (A : Ensemble Formula),
In (Ensemble Formula) T A /\ In Formula A f /\ (forall (B : Ensemble Formula), In (Ensemble Formula) T B -> In Formula B f -> Inc A B).

Lemma second_sentence : forall (T : Ensemble (Ensemble Formula)) (Pi Gamma : Ensemble Formula),
Finite Formula Pi -> Inc Pi (UoCE1 T) -> chain (Ensemble Formula) Inc (TheSet Gamma) T -> Finite (Ensemble Formula) (IoPE Pi T).
intros T Pi Gamma H H1 Hc.
induction H.
+rewrite IoPE_Empty_set. apply Empty_is_finite.
+rewrite -> Add_IoPE. rename A into Pi'.
++apply Union_preserves_Finite.
+++apply IHFinite. unfold Add in H1.
unfold Inc in H1. unfold Inc. unfold Included. unfold Included in H1.
intros f Hf. apply H1. apply Union_introl. apply Hf.
+++assert (H2: exists (A:Ensemble Formula), In (Ensemble Formula) T A /\ In Formula A x /\ forall (B: Ensemble Formula), In (Ensemble Formula) T B -> In Formula B x -> Inc A B).
++++apply for_a_certain_formula_there_is_a_subset_in_chain with (Gamma:=Gamma).
+++++apply Hc. +++++unfold UoCE1. apply About_PropUoCEr. unfold PropUoCE2.
unfold Inc in H1. unfold Included in H1.
assert (Hx: In Formula (UoCE1 T) x).
-apply H1. apply Union_intror. apply In_singleton.
-unfold UoCE1 in Hx. apply About_PropUoCEl in Hx.
unfold PropUoCE2 in Hx. destruct Hx. exists x0.
apply H2.
++++destruct H2. rename x0 into A. rewrite -> IoPE_Singleton_set with (A:=A).
+++++apply Singleton_is_finite.
+++++split. apply H2. split. -destruct H2. destruct H3. apply H3.
-destruct H2. destruct H3. apply H4.
++apply H0.
Qed.

Lemma UoCE1_has_subset : forall (T : Ensemble (Ensemble Formula)) (Gamma Pi: Ensemble Formula),
chain (Ensemble Formula) Inc (TheSet Gamma) T /\ Inc Pi (UoCE1 T) /\ Finite Formula Pi /\ (exists (f:Formula), In Formula Pi f)
-> exists Pi', In (Ensemble Formula) T Pi' /\ Inc Pi Pi'.
Proof. intros T Gamma Pi H.
Admitted.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype choice ssrnat seq.
From mathcomp Require Import fintype tuple finfun bigop fingroup perm div.
From mathcomp Require Import ssralg zmodp matrix mxalgebra.
From mathcomp Require Import poly polydiv mxpoly binomial.

(******************************************************************************)
(* This file provides additional primitives and theory for bivariate          *)
(* polynomials (polynomials of two variables), represented as polynomials     *)
(* with (univariate) polynomial coefficients :                                *)
(*            'Y == the (generic) second variable (:= 'X%:P).                 *)
(*          p^:P == the bivariate polynomial p['X], for p univariate.         *)
(*               := map_poly polyC p (this notation is defined in poly.v).    *)
(*      u.[x, y] == the bivariate polynomial u evaluated at 'X = x, 'Y = y.   *)
(*               := u.[x%:P].[y].                                             *)
(*       sizeY u == the size of u in 'Y (1 + the 'Y-degree of u, if u != 0).  *)
(*               := \max_(i < size u) size u`_i.                              *)
(*      swapXY u == the bivariate polynomial u['Y, 'X], for u bivariate.      *)
(*    poly_XaY p == the bivariate polynomial p['X + 'Y], for p univariate.    *)
(*               := p^:P \Po ('X + 'Y).                                       *)
(*    poly_XmY p == the bivariate polynomial p['X * 'Y], for p univariate.    *)
(*               := P^:P \Po ('X * 'Y).                                       *)
(* sub_annihilant p q == for univariate p, q != 0, a nonzero polynomial whose *)
(*                  roots include all the differences of roots of p and q, in *)
(*                  all field extensions (:= resultant (poly_XaY p) q^:P).    *)
(* div_annihilant p q == for polynomials p != 0, q with q.[0] != 0, a nonzero *)
(*                  polynomial whose roots include all the quotients of roots *)
(*                  of p by roots of q, in all field extensions               *)
(*                  (:= resultant (poly_XmY p) q^:P).                         *)
(* The latter two "annhilants" provide uniform witnesses for an alternative   *)
(* proof of the closure of the algebraicOver predicate (see mxpoly.v). The    *)
(* fact that the annhilant does not depend on the particular choice of roots  *)
(* of p and q is crucial for the proof of the Primitive Element Theorem (file *)
(* separable.v).                                                              *)
(******************************************************************************)

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

Local Open Scope ring_scope.
Import GRing.Theory.

Local Notation "p ^ f" := (map_poly f p) : ring_scope.
Local Notation eval := horner_eval.

Notation "'Y" := 'X%:P : ring_scope.
Notation "p ^:P" := (p ^ polyC) (at level 2, format "p ^:P") : ring_scope.
Notation "p .[ x , y ]" := (p.[x%:P].[y])
  (at level 2, left associativity, format "p .[ x ,  y ]") : ring_scope.

Section PolyXY_Ring.

Variable R : ringType.
Implicit Types (u : {poly {poly R}}) (p q : {poly R}) (x : R).

Fact swapXY_key : unit. Proof. by []. Qed.
Definition swapXY_def u : {poly {poly R}} := (u ^ map_poly polyC).['Y].
Definition swapXY := locked_with swapXY_key swapXY_def.
Canonical swapXY_unlockable := [unlockable fun swapXY].

Definition sizeY u : nat := \max_(i < size u) (size u`_i).
Definition poly_XaY p : {poly {poly R}} := p^:P \Po ('X + 'Y).
Definition poly_XmY p : {poly {poly R}} := p^:P \Po ('X * 'Y).
Definition sub_annihilant p q := resultant (poly_XaY p) q^:P.
Definition div_annihilant p q := resultant (poly_XmY p) q^:P.

Lemma swapXY_polyC p : swapXY p%:P = p^:P.
Proof. by rewrite unlock map_polyC hornerC. Qed.

Lemma swapXY_X : swapXY 'X = 'Y.
Proof. by rewrite unlock map_polyX hornerX. Qed.

Lemma swapXY_Y : swapXY 'Y = 'X.
Proof. by rewrite swapXY_polyC map_polyX. Qed.

Lemma swapXY_is_additive : additive swapXY.
Proof. by move=> u v; rewrite unlock rmorphB !hornerE. Qed.
Canonical swapXY_addf := Additive swapXY_is_additive.

Lemma coef_swapXY u i j : (swapXY u)`_i`_j = u`_j`_i.
Proof.
elim/poly_ind: u => [|u p IHu] in i j *; first by rewrite raddf0 !coef0.
rewrite raddfD !coefD /= swapXY_polyC coef_map /= !coefC coefMX.
rewrite !(fun_if (fun q : {poly R} => q`_i)) coef0 -IHu; congr (_ + _).
by rewrite unlock rmorphM /= map_polyX hornerMX coefMC coefMX.
Qed.

Lemma swapXYK : involutive swapXY.
Proof. by move=> u; apply/polyP=> i; apply/polyP=> j; rewrite !coef_swapXY. Qed.

Lemma swapXY_map_polyC p : swapXY p^:P = p%:P.
Proof. by rewrite -swapXY_polyC swapXYK. Qed.

Lemma swapXY_eq0 u : (swapXY u == 0) = (u == 0).
Proof. by rewrite (inv_eq swapXYK) raddf0. Qed.

Lemma swapXY_is_multiplicative : multiplicative swapXY.
Proof.
split=> [u v|]; last by rewrite swapXY_polyC map_polyC.
apply/polyP=> i; apply/polyP=> j; rewrite coef_swapXY !coefM !coef_sum.
rewrite (eq_bigr _ (fun _ _ => coefM _ _ _)) exchange_big /=.
apply: eq_bigr => j1 _; rewrite coefM; apply: eq_bigr=> i1 _.
by rewrite !coef_swapXY.
Qed.
Canonical swapXY_rmorphism := AddRMorphism swapXY_is_multiplicative.

Lemma swapXY_is_scalable : scalable_for (map_poly polyC \; *%R) swapXY.
Proof. by move=> p u /=; rewrite -mul_polyC rmorphM /= swapXY_polyC. Qed.
Canonical swapXY_linear := AddLinear swapXY_is_scalable.
Canonical swapXY_lrmorphism := [lrmorphism of swapXY].

Lemma swapXY_comp_poly p u : swapXY (p^:P \Po u) = p^:P \Po swapXY u.
Proof.
rewrite -horner_map; congr _.[_]; rewrite -!map_poly_comp /=.
by apply: eq_map_poly => x; rewrite /= swapXY_polyC map_polyC.
Qed.

Lemma max_size_coefXY u i : size u`_i <= sizeY u.
Proof.
have [ltiu | /(nth_default 0)->] := ltnP i (size u); last by rewrite size_poly0.
exact: (bigmax_sup (Ordinal ltiu)).
Qed.

Lemma max_size_lead_coefXY u : size (lead_coef u) <= sizeY u.
Proof. by rewrite lead_coefE max_size_coefXY. Qed.

Lemma max_size_evalX u : size u.['X] <= sizeY u + (size u).-1.
Proof.
rewrite horner_coef (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> i _.
rewrite (leq_trans (size_mul_leq _ _)) // size_polyXn addnS.
by rewrite leq_add ?max_size_coefXY //= -ltnS (leq_trans _ (leqSpred _)).
Qed.

Lemma max_size_evalC u x : size u.[x%:P] <= sizeY u.
Proof.
rewrite horner_coef (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> i _.
rewrite (leq_trans (size_mul_leq _ _)) // -polyC_exp size_polyC addnC -subn1.
by rewrite (leq_trans _ (max_size_coefXY _ i)) // leq_subLR leq_add2r leq_b1.
Qed.

Lemma sizeYE u : sizeY u = size (swapXY u).
Proof.
apply/eqP; rewrite eqn_leq; apply/andP; split.
  apply/bigmax_leqP=> /= i _; apply/leq_sizeP => j /(nth_default 0) u_j_0.
  by rewrite -coef_swapXY u_j_0 coef0.
apply/leq_sizeP=> j le_uY_j; apply/polyP=> i; rewrite coef_swapXY coef0.
by rewrite nth_default // (leq_trans _ le_uY_j) ?max_size_coefXY.
Qed.

Lemma sizeY_eq0 u : (sizeY u == 0%N) = (u == 0).
Proof. by rewrite sizeYE size_poly_eq0 swapXY_eq0. Qed.

Lemma sizeY_mulX u : sizeY (u * 'X) = sizeY u.
Proof.
rewrite !sizeYE rmorphM /= swapXY_X rreg_size //.
by have /monic_comreg[_ /rreg_lead] := monicX R.
Qed.

Lemma swapXY_poly_XaY p : swapXY (poly_XaY p) = poly_XaY p.
Proof. by rewrite swapXY_comp_poly rmorphD /= swapXY_X swapXY_Y addrC. Qed.

Lemma swapXY_poly_XmY p : swapXY (poly_XmY p) = poly_XmY p.
Proof.
by rewrite swapXY_comp_poly rmorphM /= swapXY_X swapXY_Y commr_polyX.
Qed.

Lemma poly_XaY0 : poly_XaY 0 = 0.
Proof. by rewrite /poly_XaY rmorph0 comp_poly0. Qed.

Lemma poly_XmY0 : poly_XmY 0 = 0.
Proof. by rewrite /poly_XmY rmorph0 comp_poly0. Qed.

End PolyXY_Ring.

Prenex Implicits swapXY sizeY poly_XaY poly_XmY sub_annihilant div_annihilant.
Prenex Implicits swapXYK.

Lemma swapXY_map (R S : ringType) (f : {additive R -> S}) u :
  swapXY (u ^ map_poly f) = swapXY u ^ map_poly f.
Proof.
by apply/polyP=> i; apply/polyP=> j; rewrite !(coef_map, coef_swapXY).
Qed.

Section PolyXY_ComRing.

Variable R : comRingType.
Implicit Types (u : {poly {poly R}}) (p : {poly R}) (x y : R).

Lemma horner_swapXY u x : (swapXY u).[x%:P] = u ^ eval x.
Proof.
apply/polyP=> i /=; rewrite coef_map /= /eval horner_coef coef_sum -sizeYE.
rewrite (horner_coef_wide _ (max_size_coefXY u i)); apply: eq_bigr=> j _.
by rewrite -polyC_exp coefMC coef_swapXY.
Qed.

Lemma horner_polyC u x : u.[x%:P] = swapXY u ^ eval x.
Proof. by rewrite -horner_swapXY swapXYK. Qed.

Lemma horner2_swapXY u x y : (swapXY u).[x, y] = u.[y, x].
Proof. by rewrite horner_swapXY -{1}(hornerC y x) horner_map. Qed.

Lemma horner_poly_XaY p v : (poly_XaY p).[v] = p \Po (v + 'X).
Proof. by rewrite horner_comp !hornerE. Qed.

Lemma horner_poly_XmY p v : (poly_XmY p).[v] = p \Po (v * 'X).
Proof. by rewrite horner_comp !hornerE. Qed.

End PolyXY_ComRing.

Section PolyXY_Idomain.

Variable R : idomainType.
Implicit Types (p q : {poly R}) (x y : R).

Lemma size_poly_XaY p : size (poly_XaY p) = size p.
Proof. by rewrite size_comp_poly2 ?size_XaddC // size_map_polyC. Qed.

Lemma poly_XaY_eq0 p : (poly_XaY p == 0) = (p == 0).
Proof. by rewrite -!size_poly_eq0 size_poly_XaY. Qed.

Lemma size_poly_XmY p : size (poly_XmY p) = size p.
Proof. by rewrite size_comp_poly2 ?size_XmulC ?polyX_eq0 ?size_map_polyC. Qed.

Lemma poly_XmY_eq0 p : (poly_XmY p == 0) = (p == 0).
Proof. by rewrite -!size_poly_eq0 size_poly_XmY. Qed.

Lemma lead_coef_poly_XaY p : lead_coef (poly_XaY p) = (lead_coef p)%:P.
Proof.
rewrite lead_coef_comp ?size_XaddC // -['Y]opprK -polyCN lead_coefXsubC.
by rewrite expr1n mulr1 lead_coef_map_inj //; apply: polyC_inj.
Qed.

Lemma sub_annihilant_in_ideal p q :
    1 < size p -> 1 < size q ->
  {uv : {poly {poly R}} * {poly {poly R}}
   | size uv.1 < size q /\ size uv.2 < size p
   & forall x y,
     (sub_annihilant p q).[y] = uv.1.[x, y] * p.[x + y] + uv.2.[x, y] * q.[x]}.
Proof.
rewrite -size_poly_XaY -(size_map_polyC q) => p1_gt1 q1_gt1.
have [uv /= [ub_u ub_v Dr]] := resultant_in_ideal p1_gt1 q1_gt1.
exists uv => // x y; rewrite -[r in r.[y]](hornerC _ x%:P) Dr.
by rewrite !(hornerE, horner_comp).
Qed.

Lemma sub_annihilantP p q x y :
    p != 0 -> q != 0 -> p.[x] = 0 -> q.[y] = 0 ->
  (sub_annihilant p q).[x - y] = 0.
Proof.
move=> nz_p nz_q px0 qy0.
have p_gt1: size p > 1 by have /rootP/root_size_gt1-> := px0.
have q_gt1: size q > 1 by have /rootP/root_size_gt1-> := qy0.
have [uv /= _ /(_ y)->] := sub_annihilant_in_ideal p_gt1 q_gt1.
by rewrite (addrC y) subrK px0 qy0 !mulr0 addr0.
Qed.

Lemma sub_annihilant_neq0 p q : p != 0 -> q != 0 -> sub_annihilant p q != 0.
Proof.
rewrite resultant_eq0; set p1 := poly_XaY p => nz_p nz_q.
have [nz_p1 nz_q1]: p1 != 0 /\ q^:P != 0 by rewrite poly_XaY_eq0 map_polyC_eq0.
rewrite -leqNgt eq_leq //; apply/eqP/Bezout_coprimepPn=> // [[[u v]]] /=.
rewrite !size_poly_gt0 -andbA => /and4P[nz_u ltuq nz_v _] Duv.
have /eqP/= := congr1 (size \o (lead_coef \o swapXY)) Duv.
rewrite ltn_eqF // !rmorphM !lead_coefM (leq_trans (leq_ltn_trans _ ltuq)) //=.
  rewrite -{2}[u]swapXYK -sizeYE swapXY_poly_XaY lead_coef_poly_XaY.
  by rewrite mulrC mul_polyC size_scale ?max_size_lead_coefXY ?lead_coef_eq0.
rewrite swapXY_map_polyC lead_coefC size_map_polyC.
set v1 := lead_coef _; have nz_v1: v1 != 0 by rewrite lead_coef_eq0 swapXY_eq0.
rewrite [leqRHS]polySpred ?mulf_neq0 // size_mul //.
by rewrite (polySpred nz_v1) addnC addnS polySpred // ltnS leq_addr.
Qed.

Lemma div_annihilant_in_ideal p q :
    1 < size p -> 1 < size q ->
  {uv : {poly {poly R}} * {poly {poly R}}
   | size uv.1 < size q /\ size uv.2 < size p
   & forall x y,
     (div_annihilant p q).[y] = uv.1.[x, y] * p.[x * y] + uv.2.[x, y] * q.[x]}.
Proof.
rewrite -size_poly_XmY -(size_map_polyC q) => p1_gt1 q1_gt1.
have [uv /= [ub_u ub_v Dr]] := resultant_in_ideal p1_gt1 q1_gt1.
exists uv => // x y; rewrite -[r in r.[y]](hornerC _ x%:P) Dr.
by rewrite !(hornerE, horner_comp).
Qed.

Lemma div_annihilant_neq0 p q : p != 0 -> q.[0] != 0 -> div_annihilant p q != 0.
Proof.
have factorX u: u != 0 -> root u 0 -> exists2 v, v != 0 & u = v * 'X.
  move=> nz_u /factor_theorem[v]; rewrite subr0 => Du; exists v => //.
  by apply: contraNneq nz_u => v0; rewrite Du v0 mul0r.
have nzX: 'X != 0 := monic_neq0 (monicX _); have rootC0 := root_polyC _ 0.
rewrite resultant_eq0 -leqNgt -rootE // => nz_p nz_q0; apply/eq_leq/eqP.
have nz_q: q != 0 by apply: contraNneq nz_q0 => ->; rewrite root0.
apply/Bezout_coprimepPn; rewrite ?map_polyC_eq0 ?poly_XmY_eq0 // => [[uv]].
rewrite !size_poly_gt0 -andbA ltnNge => /and4P[nz_u /negP ltuq nz_v _] Duv.
pose u := swapXY uv.1; pose v := swapXY uv.2.
suffices{ltuq}: size q <= sizeY u by rewrite sizeYE swapXYK -size_map_polyC.
have{nz_u nz_v} [nz_u nz_v Dvu]: [/\ u != 0, v != 0 & q *: v = u * poly_XmY p].
  rewrite !swapXY_eq0; split=> //; apply: (can_inj swapXYK).
  by rewrite linearZ rmorphM /= !swapXYK swapXY_poly_XmY Duv mulrC.
have{Duv} [n ltvn]: {n | size v < n} by exists (size v).+1.
elim: n {uv} => // n IHn in p (v) (u) nz_u nz_v Dvu nz_p ltvn *.
have Dp0: root (poly_XmY p) 0 = root p 0 by rewrite root_comp !hornerE rootC0.
have Dv0: root u 0 || root p 0 = root v 0 by rewrite -Dp0 -rootM -Dvu rootZ.
have [v0_0 | nz_v0] := boolP (root v 0); last first.
  have nz_p0: ~~ root p 0 by apply: contra nz_v0; rewrite -Dv0 orbC => ->.
  apply: (@leq_trans (size (q * v.[0]))).
    by rewrite size_mul // (polySpred nz_v0) addnS leq_addr.
  rewrite -hornerZ Dvu !(horner_comp, hornerE) horner_map mulrC size_Cmul //.
  by rewrite horner_coef0 max_size_coefXY.
have [v1 nz_v1 Dv] := factorX _ _ nz_v v0_0; rewrite Dv size_mulX // in ltvn.
have /orP[/factorX[//|u1 nz_u1 Du] | p0_0]: root u 0 || root p 0 by rewrite Dv0.
  rewrite Du sizeY_mulX; apply: IHn nz_u1 nz_v1 _ nz_p ltvn.
  by apply: (mulIf (nzX _)); rewrite mulrAC -scalerAl -Du -Dv.
have /factorX[|v2 nz_v2 Dv1]: root (swapXY v1) 0; rewrite ?swapXY_eq0 //.
  suffices: root (swapXY v1 * 'Y) 0 by rewrite mulrC mul_polyC rootZ ?polyX_eq0.
  have: root (swapXY (q *: v)) 0.
    by rewrite Dvu rmorphM rootM /= swapXY_poly_XmY Dp0 p0_0 orbT.
  by rewrite linearZ rootM rootC0 (negPf nz_q0) /= Dv rmorphM /= swapXY_X.
rewrite ltnS (canRL swapXYK Dv1) -sizeYE sizeY_mulX sizeYE in ltvn.
have [p1 nz_p1 Dp] := factorX _ _ nz_p p0_0.
apply: IHn nz_u _ _ nz_p1 ltvn; first by rewrite swapXY_eq0.
apply: (@mulIf _ ('X * 'Y)); first by rewrite mulf_neq0 ?polyC_eq0 ?nzX.
rewrite -scalerAl mulrA mulrAC -{1}swapXY_X -rmorphM /= -Dv1 swapXYK -Dv Dvu.
by rewrite /poly_XmY Dp rmorphM /= map_polyX comp_polyM comp_polyX mulrA.
Qed.

End PolyXY_Idomain.

Section PolyXY_Field.

Variables (F E : fieldType) (FtoE : {rmorphism F -> E}).

Local Notation pFtoE := (map_poly (GRing.RMorphism.apply FtoE)).

Lemma div_annihilantP (p q : {poly E}) (x y : E) :
    p != 0 -> q != 0 -> y != 0 -> p.[x] = 0 -> q.[y] = 0 ->
  (div_annihilant p q).[x / y] = 0.
Proof.
move=> nz_p nz_q nz_y px0 qy0.
have p_gt1: size p > 1 by have /rootP/root_size_gt1-> := px0.
have q_gt1: size q > 1 by have /rootP/root_size_gt1-> := qy0.
have [uv /= _ /(_ y)->] := div_annihilant_in_ideal p_gt1 q_gt1.
by rewrite (mulrC y) divfK // px0 qy0 !mulr0 addr0.
Qed.

Lemma map_sub_annihilantP (p q : {poly F}) (x y : E) :
     p != 0 -> q != 0 ->(p ^ FtoE).[x] = 0 -> (q ^ FtoE).[y] = 0 ->
  (sub_annihilant p q ^ FtoE).[x - y] = 0.
Proof.
move=> nz_p nz_q px0 qy0; have pFto0 := map_poly_eq0 FtoE.
rewrite map_resultant ?pFto0 ?lead_coef_eq0 ?map_poly_eq0 ?poly_XaY_eq0 //.
rewrite map_comp_poly rmorphD /= map_polyC /= !map_polyX -!map_poly_comp /=.
by rewrite !(eq_map_poly (map_polyC _)) !map_poly_comp sub_annihilantP ?pFto0.
Qed.

Lemma map_div_annihilantP (p q : {poly F}) (x y : E) :
     p != 0 -> q != 0 -> y != 0 -> (p ^ FtoE).[x] = 0 -> (q ^ FtoE).[y] = 0 ->
  (div_annihilant p q ^ FtoE).[x / y] = 0.
Proof.
move=> nz_p nz_q nz_y px0 qy0; have pFto0 := map_poly_eq0 FtoE.
rewrite map_resultant ?pFto0 ?lead_coef_eq0 ?map_poly_eq0 ?poly_XmY_eq0 //.
rewrite map_comp_poly rmorphM /= map_polyC /= !map_polyX -!map_poly_comp /=.
by rewrite !(eq_map_poly (map_polyC _)) !map_poly_comp div_annihilantP ?pFto0.
Qed.

Lemma root_annihilant x p (pEx := (p ^ pFtoE).[x%:P]) :
    pEx != 0 -> algebraicOver FtoE x ->
  exists2 r : {poly F}, r != 0 & forall y, root pEx y -> root (r ^ FtoE) y.
Proof.
move=> nz_px [q nz_q qx0].
have [/size1_polyC Dp | p_gt1] := leqP (size p) 1.
  by rewrite {}/pEx Dp map_polyC hornerC map_poly_eq0 in nz_px *; exists p`_0.
have nz_p: p != 0 by rewrite -size_poly_gt0 ltnW.
have [m le_qm] := ubnP (size q); elim: m => // m IHm in q le_qm nz_q qx0 *.
have nz_q1: q^:P != 0 by rewrite map_poly_eq0.
have sz_q1: size q^:P = size q by rewrite size_map_polyC.
have q1_gt1: size q^:P > 1.
  by rewrite sz_q1 -(size_map_poly FtoE) (root_size_gt1 _ qx0) ?map_poly_eq0.
have [uv _ Dr] := resultant_in_ideal p_gt1 q1_gt1; set r := resultant p _ in Dr.
have /eqP q1x0: (q^:P ^ pFtoE).[x%:P] == 0.
  by rewrite -swapXY_polyC -swapXY_map horner_swapXY !map_polyC polyC_eq0.
have [|r_nz] := boolP (r == 0); last first.
  exists r => // y pxy0; rewrite -[r ^ _](hornerC _ x%:P) -map_polyC Dr.
  by rewrite rmorphD !rmorphM !hornerE q1x0 mulr0 addr0 rootM pxy0 orbT.
rewrite resultant_eq0 => /gtn_eqF/Bezout_coprimepPn[]// [q2 p1] /=.
rewrite size_poly_gt0 sz_q1 => /andP[/andP[nz_q2 ltq2] _] Dq.
pose n := (size (lead_coef q2)).-1; pose q3 := map_poly (coefp n) q2.
have nz_q3: q3 != 0 by rewrite map_poly_eq0_id0 ?lead_coef_eq0.
apply: (IHm q3); rewrite ?(leq_ltn_trans (size_poly _ _)) ?(leq_trans ltq2) //.
have /polyP/(_ n)/eqP: (q2 ^ pFtoE).[x%:P] = 0.
apply: (mulIf nz_px); rewrite -hornerM -rmorphM Dq rmorphM hornerM /= q1x0.
  by rewrite mul0r mulr0.
rewrite coef0; congr (_ == 0); rewrite !horner_coef coef_sum.
rewrite size_map_poly !size_map_poly_id0 ?map_poly_eq0 ?lead_coef_eq0 //.
by apply: eq_bigr => i _; rewrite -rmorphX coefMC !coef_map.
Qed.

Lemma algebraic_root_polyXY x y :
    (let pEx p := (p ^ map_poly FtoE).[x%:P] in
    exists2 p, pEx p != 0 & root (pEx p) y) ->
  algebraicOver FtoE x -> algebraicOver FtoE y.
Proof. by case=> p nz_px pxy0 /(root_annihilant nz_px)[r]; exists r; auto. Qed.

End PolyXY_Field.


Coq < Section Easy006b.

Coq < Require Import Classical.

Coq < Load CpdtTactics.

Coq < Variables Y A W: Prop.
Y is assumed
A is assumed
W is assumed

Coq < Goal ~(Y <-> A) /\ ~Y /\ ~A -> (W /\ ~W).
1 subgoal

  Y : Prop
  A : Prop
  W : Prop
  ============================
   ~ (Y <-> A) /\ ~ Y /\ ~ A -> W /\ ~ W

Unnamed_thm < intros.
1 subgoal

  Y : Prop
  A : Prop
  W : Prop
  H : ~ (Y <-> A) /\ ~ Y /\ ~ A
  ============================
   W /\ ~ W

Unnamed_thm < destruct H.
1 subgoal

  Y : Prop
  A : Prop
  W : Prop
  H : ~ (Y <-> A)
  H0 : ~ Y /\ ~ A
  ============================
   W /\ ~ W

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
destruct H.
auto.
tauto.

Unnamed_thm is defined


Require Import emma_orig.
(* Declaration of basic propositions. *)
Import Utf8_core.
Import ILLVarInt.MILL. (* only this *)
Import FormulaMultiSet. (* and this *)
Require Import restrict2.

Inductive narrative : Prop :=
  Leaf: narrative
| Impl: formula → narrative
| Next: narrative → narrative → narrative
| Paral: narrative → narrative → narrative
| Branch: narrative → narrative → narrative.

Notation "∅" := Leaf.
Notation "a ≻ b" := (Next a b) (at level 90, right associativity).
Notation "a ⋈ b" := (Branch a b) (at level 91, right associativity).
Notation "a ∣∣ b" := (Paral a b) (at level 92, right associativity).
Notation "[ a ]" := (Impl a) (at level 89, right associativity).

Show Obligation Tactic.
Local Obligation Tactic :=
  try solve [intuition; discriminate] ;  Tactics.program_simpl.

Definition simpl_narr b e p q :=
  match b,e with
    | ∅,∅ => [Implies p q]
    | ∅,y=> [Implies p q] ≻ y
    | x,∅ => x ≻ [Implies p q]
    | x,y => x ≻ ([Implies p q] ≻ y)
  end.

Program Fixpoint ν Γ φ (h: Γ ⊢ φ) {struct h}: narrative :=
match h with
  | Id _ _ p => ∅
  | Impl_R _ p q x => ν _ _ x
  | Impl_L _ Δ Δ' p q r _ _ x x0 =>  simpl_narr (ν Δ p x) (ν (q::Δ') r x0) p q
  | Times_R _ Δ Δ' p q heq x x0 => (ν Δ p x) ∣∣ (ν Δ' q x0)
  | Times_L _ p q r _ x => ν _ _ x
  | One_R _ _  => ∅
  | One_L _ p _ x => ν _ _ x
  | And_R _ p q x x0 => (ν _ _ x) ⋈ (ν _ _ x0)
  | And_L_1 _ p q r _ x => ν _ _ x
  | And_L_2 _ p q r _ x => ν _ _ x
  | Oplus_L _ p q r _ x x0 => (ν _ _ x) ⋈ (ν _ _ x0)
  | Oplus_R_1 _ p q x => ν _ _ x
  | Oplus_R_2 _ p q x => ν _ _ x
  | T_ _ => ∅
  | Zero_ _ p x => ∅
  | Bang_D _ p q _ x => ν _ _ x
  | Bang_C _ p q _ x => ν _ _ x
  | Bang_W _ p q _ x => ν _ _ x
end.

Eval vm_compute in (ν _ _ originelle).

(*
[G ⊸ 1] ≻ ([R ⊸ E] ≻ [E ⊸ A] ⋈ [B ⊸ 1] ≻ [R ⊸ 1] ≻ [P ⊸ M])
⋈ [G ⊸ S] ≻ [R ⊸ 1] ≻ ([S ⊸ A] ⋈ [B ⊸ 1] ≻ [S ⊸ A])
 *)


Require Import HoTT.
Require Import HoTT.Categories Category.
Require Import category_lemmas.
Require Import trunc_lemmas.

Require Export monoidal_1type.

Section Localize.

  (* if we have a monoidal action with left_cancellation, we can build a category with objects X and arrows*)
  (* {m : M & m ⊗ x = m ⊗ y} *)
  Definition monoidal_action_morphism (M : Monoidal_1Type) (X : 1-Type) (a : monoidal_action M X) :
    (X -> X -> Type) := fun x y => {s : M & a s x = y}.

  Instance isset_mon_morphism (M : Monoidal_1Type) (X : 1-Type) (a : monoidal_action M X) (x1 x2 : X)
           (left_cancel : left_faithful a)
    (* (left_cancel : forall (s t : M) (p q : s = t) (x : X), *)
    (*              action_on_path a x p = action_on_path a x q -> p = q)  *):
    IsHSet (monoidal_action_morphism M X a x1 x2).
  Proof.
    unfold monoidal_action_morphism.
    intros [s1 p1] [s2 p2].
    apply (trunc_equiv' {q : s1 = s2 & transport (fun s => a s x1 = x2) q p1 = p2}).
    { apply (equiv_path_sigma (fun s : M => a s x1 = x2) (s1; p1) (s2; p2) ). }
    (* apply (trunc_equiv' {q : s1 = s2 & p1 = (ap (fun s => a s x1) q) @ p2}). *)
    apply (trunc_equiv' {q : s1 = s2 & p1 = action_on_path a x1 q @ p2}).
    { apply equiv_functor_sigma_id. intro q. destruct q. simpl. destruct p2. apply equiv_idmap. }
    apply trunc_sigma'.
    + intro p. exact _.
    + simpl.
      intros [q1 r1] [q2 r2]. simpl.
      apply contr_inhabited_hprop. { exact _. }
      apply (left_cancel _ _ q1 q2 x1).
      transitivity (p1 @ p2^).
      { apply moveL_pV. apply r1^. }
      { apply moveR_pV. apply r2. }
  Defined.

  Definition monoidal_action_cat (M : Monoidal_1Type) (X : 1-Type) (a : monoidal_action M X)
             (left_cancel : left_faithful a)
             (* (left_cancel : forall (s t : M) (p q : s = t) (x : X), *)
             (*     action_on_path a x p = action_on_path a x q -> p = q) *)
    : PreCategory.
  Proof.
    srefine (Build_PreCategory (monoidal_action_morphism M X a) _ _ _ _ _ (fun x1 x2 => isset_mon_morphism M X a x1 x2 left_cancel)).
    (* identity *)
    - intro x. exists montype_id. apply montype_act_id.
    (* composition *)
    - intros x y z.
      intros [s1 p1] [s2 p2].
      exists (s1 ⊗ s2).
      exact (montype_act_mult a s1 s2 x @ ap (a s1) p2 @ p1).
    (* associativity *)
    - intros x1 x2 x3 x4 [s1 []] [s2 []] [s3 []]. repeat rewrite ap_1. repeat rewrite concat_p1.
      srapply @path_sigma.
      { apply montype_assoc. }
      cbn.
      refine (transport_paths_Fl (montype_assoc s3 s2 s1) _ @ _).
      rewrite montype_act_pentagon. repeat rewrite inv_pp. repeat rewrite inv_V.
      apply moveR_pM.
      repeat rewrite concat_pp_p. apply whiskerL. apply whiskerL.
      apply inverse. apply inv_pp.
    (* left identity *)
    - simpl.
      intros x1 x2 [s []]. simpl. rewrite concat_p1.
      srapply @path_sigma.
      { apply montype_lid. }
      simpl.
      refine (transport_paths_Fl (montype_lid s) _ @ _).
      apply moveR_Vp. refine (_ @ (concat_p1 _)^). apply inverse.
      apply montype_act_triangle1.
    (* right identity *)
    - simpl.
      intros x1 x2 [s []]. simpl. rewrite concat_p1.
      srapply @path_sigma.
      { apply montype_rid. } simpl.
      refine (transport_paths_Fl (montype_rid s) _ @ _).
      apply moveR_Vp. refine (_ @ (concat_p1 _)^). apply inverse.
      apply montype_act_triangle2.
  Defined.

  Definition include_in_monoidal_action_cat (M : Monoidal_1Type) (X : 1-Type)
             (act : monoidal_action M X)
             (left_cancel : left_faithful act)
             (f : M -> X)

    : Functor (groupoid_category M) (monoidal_action_cat M X act left_cancel).
  Proof.
    srapply @Build_Functor.
    - simpl. exact f.
    - intros a b. simpl.
      intros []. apply (identity (C := monoidal_action_cat M X act left_cancel)).
    - intros a b c. intros p q. destruct q. destruct p.
      apply inverse. apply identity_identity.
    - reflexivity.
  Defined.

  Definition functor_monoidal_action_cat (M N : Monoidal_1Type) (X Y : 1-Type)
             (act1 : monoidal_action M X) (left_cancel1 : left_faithful act1)
             (act2 : monoidal_action N Y) (left_cancel2 : left_faithful act2)
             (f : Monoidal_Map M N)
             (g : X -> Y)
             (act_mult : forall (a : M) (x : X),
                 g (act1 a x) = act2 (f a) (g x))
             (act_mult_assoc : forall (a b : M) (x : X),
                 ap g (montype_act_mult act1 a b x) =
                 act_mult _ x @ ap011 act2 (montype_map_mult f a b) idpath
                          @ montype_act_mult act2 (f a) (f b) (g x)
                          @ (ap011 act2 idpath (act_mult b x))^
                          @ (act_mult a _)^)
             (act_mult_lid : forall (x : X),
                 ap g (montype_act_id act1 x) =
                 act_mult montype_id x
                          @ ap011 act2 (montype_map_id f) idpath
                          @ montype_act_id act2 (g x))
    : Functor (monoidal_action_cat M X act1 left_cancel1)
              (monoidal_action_cat N Y act2 left_cancel2).
  Proof.
    srapply @Build_Functor.
    - exact g.
    - simpl. intros x y.
      intros [s p].
      exists (f s).
      refine (_ @ ap g p).
      apply inverse. apply act_mult.
    - intros x y z.
      intros [s p] [t q]. simpl.
      destruct q. destruct p. simpl.
      repeat rewrite concat_p1.
      apply (path_sigma _ (_;_) (_;_) (montype_map_mult f t s)).
      simpl.
      refine (transport_paths_Fl (montype_map_mult f t s) _ @ _).
      rewrite act_mult_assoc.
      repeat rewrite concat_p_pp. apply whiskerR.
      rewrite ap_V. apply whiskerR.
      apply moveR_pM. rewrite concat_pV.
      apply moveR_pM. rewrite concat_1p.
      apply moveR_pM. apply whiskerR. destruct (montype_map_mult f t s).
      reflexivity.
    - simpl. intro x.
      apply (path_sigma _ (_;_) (_;_) (montype_map_id f)).
      refine (transport_paths_Fl (montype_map_id f) _ @ _).
      rewrite act_mult_lid. simpl.
      repeat rewrite concat_pp_p. apply moveR_Vp. apply moveR_Vp.
      apply whiskerL. apply whiskerR.
      generalize (montype_map_id f). intro p. destruct p.
      reflexivity.
  Defined.

  (* Definition monoidal_action_fun_obj (M : Symmetric_Monoidal_1Type) (X : 1-Type) *)
  (*            (act : monoidal_action M X) (a : M) *)
  (*   : X -> X. *)
  (* Proof. *)
  (*   simpl. apply act. exact a. *)
  (* Defined. *)

  (* Definition monoidal_action_fun_morphism (M : Symmetric_Monoidal_1Type) (X : 1-Type) *)
  (*            (act : monoidal_action M X) (left_cancel : left_faithful act) (a : M) (x y : X) *)
  (*   : morphism (monoidal_action_cat M X act left_cancel) x y -> *)
  (*     morphism (monoidal_action_cat M X act left_cancel) (act a x) (act a y). *)
  (* Proof. *)
  (*   intros [s p]. *)
  (*   exists s. *)
  (*   refine ((montype_act_mult _ _ _ _)^ @ _). *)
  (*   refine (ap10 (ap act (smontype_sym _ _ )^) x @ _). *)
  (*   refine (montype_act_mult _ _ _ _ @ _). *)
  (*   apply (ap (act a) p). *)
  (* Defined. *)

  (* Definition monoidal_action_fun_compose (M : Symmetric_Monoidal_1Type) (X : 1-Type) *)
  (*            (act : monoidal_action M X) (left_cancel : left_faithful act) (a : M) (x y z: X) *)
  (*            (f : morphism (monoidal_action_cat M X act left_cancel) x y) *)
  (*            (g : morphism (monoidal_action_cat M X act left_cancel) y z) *)
  (*   : monoidal_action_fun_morphism M X act left_cancel a x z (g o f)%morphism = *)
  (*     (monoidal_action_fun_morphism M X act left_cancel a y z g o *)
  (*      monoidal_action_fun_morphism M X act left_cancel a x y f)%morphism. *)
  (* Proof. *)
  (*   destruct f as [s p]. destruct g as [t q]. simpl. *)
  (*   destruct p. destruct q. *)
  (*   srapply @path_sigma. *)
  (*   { reflexivity. } *)
  (*   simpl. repeat rewrite concat_p1. *)

  (*   apply inverse. apply moveR_Mp. apply moveR_Vp. apply moveR_pM. *)
  (*   transitivity ((montype_act_mult act _ _ x)^ @ *)
  (*                                                 (ap10 (ap act (ap (fun m => smontype_mult m s) (smontype_sym a t))^) x) *)
  (*                                                 @ (montype_act_mult act _ _ x)). *)
  (*   { destruct (smontype_sym a t). simpl. *)
  (*     rewrite concat_p1. rewrite concat_Vp. reflexivity. } *)
  (*   apply moveR_pM. apply moveR_Vp. *)
  (*   rewrite smontype_hexagon. *)
  (*   assert (H : forall (n1 n2: M) (p: n1 = n2), ap10 (ap act p) x = ap (fun m => act m x) p). *)
  (*   { intros m n. intros []. reflexivity. } *)
  (*   rewrite H. rewrite H. rewrite H. clear H. *)
  (*   rewrite ap_V. repeat rewrite ap_pp. *)
  (*   repeat rewrite ap_V.  *)

  (*   rewrite montype_act_pentagon.  rewrite montype_act_pentagon.  rewrite montype_act_pentagon. *)
  (*   repeat rewrite inv_pp. repeat rewrite inv_V. *)
  (*   repeat rewrite concat_p_pp. *)
  (*   repeat apply whiskerR. *)
  (*   repeat rewrite concat_pp_p. repeat apply whiskerL. *)
  (*   cut (forall (n1 n2 : M) (p : n1 = n2), *)
  (*           (montype_act_mult act t n1 x)^ @ *)
  (*                                            (ap (fun m : M => act m x) (ap (smontype_mult t) p) @ *)
  (*                                                montype_act_mult act t n2 x) = ap (act t) (ap (fun m : M => act m x) p)). *)
  (*   { intro H. apply H. } *)
  (*   intros n1 n2. intros []. simpl. rewrite concat_1p. apply concat_Vp. *)
  (* Qed. *)

  (* Definition monoidal_action_fun_id (M : Symmetric_Monoidal_1Type) (X : 1-Type) *)
  (*            (act : monoidal_action M X) (left_cancel : left_faithful act) (a : M) (x : X) *)
  (*   : monoidal_action_fun_morphism M X act left_cancel a x x 1%morphism = *)
  (*     1%morphism. *)
  (* Proof. *)
  (*   rewrite <- (identity_identity (monoidal_action_cat M X act left_cancel) x). *)
  (*   rewrite monoidal_action_fun_compose. *)
  (*   simpl. *)
  (*   srapply @path_sigma. *)
  (*   - simpl. apply smontype_lid. *)
  (*   - simpl. refine (transport_paths_FlFr (smontype_lid smontype_id) _ @ _). *)

  (* Definition monoidal_action_fun (M : Symmetric_Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X) *)
  (*            (left_cancel : left_faithful act) (a : M) *)
  (*   : Functor (monoidal_action_cat M X act left_cancel) (monoidal_action_cat M X act left_cancel). *)
  (* Proof. *)
  (*   srapply @Build_Functor. *)
  (*   - simpl. apply act. exact a. *)
  (*   - simpl. intros x y. *)
  (*     intros [s p]. *)
  (*     exists s. *)
  (*     refine ((montype_act_mult _ _ _ _)^ @ _). *)
  (*     refine (ap10 (ap act (smontype_sym _ _ )^) x @ _). *)
  (*     refine (montype_act_mult _ _ _ _ @ _). *)
  (*     apply (ap (act a) p). *)
  (*   - simpl. intros x y z. *)
  (*     simpl. *)
  (*     intros [s p] [t q]. *)
  (*     destruct p. destruct q. *)
  (*     srapply @path_sigma. *)
  (*     { reflexivity. } *)
  (*     simpl. repeat rewrite concat_p1. *)

  (*     apply inverse. apply moveR_Mp. apply moveR_Vp. apply moveR_pM. *)
  (*     transitivity ((montype_act_mult act _ _ x)^ @ *)
  (*                   (ap10 (ap act (ap (fun m => smontype_mult m s) (smontype_sym a t))^) x) *)
  (*                    @ (montype_act_mult act _ _ x)). *)
  (*     { destruct (smontype_sym a t). simpl. *)
  (*       rewrite concat_p1. rewrite concat_Vp. reflexivity. } *)
  (*     apply moveR_pM. apply moveR_Vp. *)
  (*     rewrite smontype_hexagon. *)
  (*     assert (H : forall (n1 n2: M) (p: n1 = n2), ap10 (ap act p) x = ap (fun m => act m x) p). *)
  (*     { intros m n. intros []. reflexivity. } *)
  (*     rewrite H. rewrite H. rewrite H. clear H. *)
  (*     rewrite ap_V. repeat rewrite ap_pp. *)
  (*     repeat rewrite ap_V.  *)

  (*     rewrite montype_act_pentagon.  rewrite montype_act_pentagon.  rewrite montype_act_pentagon. *)
  (*     repeat rewrite inv_pp. repeat rewrite inv_V. *)
  (*     repeat rewrite concat_p_pp. *)
  (*     repeat apply whiskerR. *)
  (*     repeat rewrite concat_pp_p. repeat apply whiskerL. *)
  (*     cut (forall (n1 n2 : M) (p : n1 = n2), *)
  (*             (montype_act_mult act t n1 x)^ @ *)
  (*                    (ap (fun m : M => act m x) (ap (smontype_mult t) p) @ *)
  (*                        montype_act_mult act t n2 x) = ap (act t) (ap (fun m : M => act m x) p)). *)
  (*     { intro H. apply H. } *)
  (*     intros n1 n2. intros []. simpl. rewrite concat_1p. apply concat_Vp. *)
  (*   - intro x. simpl. *)
  (*     srapply @path_sigma. *)
  (*     { reflexivity. } *)
  (*     simpl. *)

  (*     apply moveR_Vp. *)

  (* (* Some initial checking whether this category is univalent *) *)
  (* Definition iso_to_id {M : Monoidal_1Type} {X : 1-Type} (a : monoidal_action M X) *)
  (*            {lc : left_faithful a} (x y : monoidal_action_cat M X a lc) : *)
  (*   Isomorphic x y -> x = y. *)
  (* Proof. *)
  (*   intros [[s1 p1] [[s2 p2] H1' H2']]. simpl in *. *)
  (*   destruct ((path_sigma_uncurried (fun s0 : M => a s0 x = x) *)
  (*                                  (s2 ⊗ s1; (montype_act_mult a s2 s1 x @ ap (a s2) p1) @ p2) *)
  (*                                  (montype_id; montype_act_id a x))^-1 H1') as [q1 H1]. simpl in *. *)
  (*   clear H1'. *)
  (*   destruct ((path_sigma_uncurried (fun s0 : M => a s0 y = y) *)
  (*                                  (s1 ⊗ s2; (montype_act_mult a s1 s2 y @ ap (a s1) p2) @ p1) *)
  (*                                  (montype_id; montype_act_id a y))^-1 H2') as [q2 H2]. simpl in *. *)
  (*   clear H2'. *)
  (*   refine (_ @ p1). *)
  (*   refine ((montype_act_id a x)^  @ _). *)
  (*   apply (ap (fun s => a s x)). *)
  (*   unfold left_faithful in lc. *)
  (*   refine (_ @ ap (a s1) p2). *)

  (*   refine (p2^ @ _ @ p1). *)
  (*   refine (ap (a s2) p1^ @ _ @ ap (a s1) p2). *)

  (*   destruct q. destruct p. *)
  Definition left_cancel_localize (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X)
             (left_cancel : left_faithful (@montype_mult M))
    : left_faithful (act_on_prod M M X (act_on_self M) act).
  Proof.
    unfold left_faithful.
    intros s t p q [a x].
    intro H. apply (left_cancel s t p q a).
    refine ((ap_fst_path_prod (z := (s ⊗ a, act s x )) (z' := (t ⊗ a, act t x ))
                (ap (fun m : M => m ⊗ a) p) (ap (fun m : M => act m x) p))^ @ _ @
             ap_fst_path_prod (z := (s ⊗ a, act s x )) (z' := (t ⊗ a, act t x ))
                (ap (fun m : M => m ⊗ a) q) (ap (fun m : M => act m x) q)).
    apply (ap (ap fst)).
    refine (_ @ H @ _).
    - destruct p. reflexivity.
    - destruct q. reflexivity.
  Defined.

  Definition localize_action (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X)
             (left_cancel : left_faithful (@montype_mult M))
             (* (left_cancel : forall (s t : M) (p q : s = t) (a : M), *)
             (*     ap (fun x => x ⊗ a) p = ap (fun x => x ⊗ a) q -> p = q)  *): PreCategory.
  Proof.
    apply (monoidal_action_cat M (BuildTruncType 1 (M*X)) (act_on_prod M M X (act_on_self M) act)).
    apply left_cancel_localize. apply left_cancel.
  Defined.

  Definition include_in_localize_action (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X)
             (left_cancel : left_faithful (@montype_mult M))
             (x0 : X)
    : Functor (groupoid_category M) (localize_action M X act left_cancel).
  Proof.
    srapply @Build_Functor.
    - simpl. intro a. exact (a, x0).
    - simpl. intros a b. intro p. simpl.
      exists montype_id. (* simpl. unfold functor_prod. simpl. *)
      refine (_ @ ap011 pair p (idpath x0)).
      apply montype_act_id.
    - simpl. intros s t u. intros p q. simpl.
      destruct p. destruct q. simpl. rewrite concat_p1.

  Definition group_completion (M : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M))
             (* (left_cancel : forall (s t : M) (p q : s = t) (a : M), *)
             (*     ap (fun x => x ⊗ a) p = ap (fun x => x ⊗ a) q -> p = q) *) : PreCategory :=
    localize_action M M (act_on_self M) left_cancel.

  Definition contr_self_category (M : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M))
             (* (left_cancel : forall (s t : M) (p q : s = t) (a : M), *)
             (*     ap (fun x => x ⊗ a) p = ap (fun x => x ⊗ a) q -> p = q) *)
    : forall x : object (monoidal_action_cat M M (act_on_self M) left_cancel),
      Contr (morphism (monoidal_action_cat M M (act_on_self M) left_cancel) montype_id x).
  Proof.
    simpl. intro a. unfold monoidal_action_morphism. unfold act_on_self. simpl.
    apply (contr_equiv' {s : M & s = a}).
    - srapply @equiv_functor_sigma'.
      { exact equiv_idmap. }
      intro m. simpl.
      apply equiv_concat_l. apply montype_rid.
    - apply contr_basedpaths'.
  Defined.

  (* (* adding the same on both factors is an isomorphism *) *)
  (* Definition add_on_both (M : Monoidal_1Type) (left_cancel : left_faithful (@montype_mult M)) *)
  (*            (s x1 x2 : M) *)
  (*   : morphism (group_completion M left_cancel) (x1, x2) (montype_mult s x1, montype_mult s x2). *)
  (* Proof. *)
  (*   exists s. reflexivity. *)
  (* Defined. *)

  (* Definition isiso_add_on_both (M : Monoidal_1Type) (left_cancel : left_faithful (@montype_mult M)) *)
  (*            (s x1 x2 : M) *)
  (*   : IsIsomorphism (add_on_both M left_cancel s x1 x2). *)
  (* Proof. *)
  (*   srapply @Build_IsIsomorphism. *)
  (*   - exists s. simpl. *)

  (*   srapply @Build_Isomorphic. *)

  Definition act_on_grp_compl (M : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M))
    : M -> Functor (group_completion M left_cancel) (group_completion M left_cancel).
  Proof.
    intro a.
    srapply @Build_Functor.
    - intros [x1 x2]. exact (montype_mult x1 a, x2).
    - intros [x1 x2] y.
      intros [s p].
      exists s.
      apply (path_prod); simpl.
      + refine (_ @ ap (fun m => montype_mult m a) (ap fst p)).
        apply inverse. apply montype_assoc.
      + apply (ap snd p).
    - intros [x1 x2] y z.
      intros [s p]. intros [t q]. destruct q. destruct p.
      simpl. repeat rewrite concat_p1.
      srapply @path_sigma.
      { reflexivity. }
      simpl.
      rewrite ap_fst_path_prod. rewrite ap_snd_path_prod.
      rewrite ap_functor_prod.
      rewrite <- path_prod_pp. rewrite <- path_prod_pp.
      rewrite concat_p1. simpl. rewrite concat_p1.
      apply (ap (fun p => path_prod _ _ p _)).
      rewrite montype_pentagon.
      repeat rewrite concat_p_pp.
      apply whiskerR. rewrite ap_V. apply whiskerR. rewrite concat_Vp.
      apply concat_1p.
    - intros [x1 x2]. simpl.
      srapply @path_sigma.
      { reflexivity. } simpl.
      rewrite ap_fst_path_prod. rewrite ap_snd_path_prod.
      apply (ap (fun p => path_prod _ _ p _)).
      rewrite montype_triangle1.
      destruct (montype_lid (x1 ⊗ a)). rewrite concat_p1.
      apply concat_Vp.
  Defined.

  (* move *)
Definition double_transport {A B : Type} (P : A -> B -> Type)
           {a a' : A} {b b' : B}
           (p : a = a') (q : b = b') :
  P a b -> P a' b'.
Proof.
  destruct p. destruct q. exact idmap.
Defined.
Definition double_transport_compose {A B : Type} (P : A -> B -> Type)
           {a a' a'' : A} {b b' b'' : B}
           (p : a = a') (p' : a' = a'')
           (q : b = b') (q' : b' = b'')
  : double_transport P (p @ p') (q @ q') ==
    double_transport P p' q' o double_transport P p q.
Proof.
  intro x.
  destruct q'. destruct q.
  destruct p'. destruct p. reflexivity.
Defined.

Definition path_functor' {C D : PreCategory} (F G : Functor C D)
           (p0 : forall c : C, F c = G c)
           (p1 : forall (c d : C) (f : morphism C c d),
               double_transport (morphism D) (p0 c) (p0 d) (morphism_of F f )
               = morphism_of G f)
  : F = G.
Proof.
  srapply @Paths.path_functor.
  - apply path_forall. exact p0.
  - apply path_forall. intro s. apply path_forall. intro d.
    apply path_arrow. intro f.
    refine (_ @ p1 _ _ f).
    rewrite <- (apD10_path_forall (object_of F) (object_of G) p0 s).
    rewrite <- (apD10_path_forall (object_of F) (object_of G) p0 d).
    change (path_forall (Core.object_of F) (Core.object_of G) p0) with
    (path_forall F G p0).
    destruct (path_forall F G p0). simpl.
    reflexivity.
Defined.

Definition double_transport_monoidal_action_cat
           (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X)
           (left_cancel : left_faithful act)
           {x x' y y' : monoidal_action_cat M X act left_cancel}
           (q1 : x = x') (q2 : y = y')
           (s : M) (p : act s x = y)
  : double_transport (morphism (monoidal_action_cat M X act left_cancel))
                     q1 q2
                     (s; p)
    = (s; (ap (act s) q1^ @ p @ q2)).
Proof.
  destruct q2. destruct q1. simpl.
  rewrite concat_1p. rewrite concat_p1. reflexivity.
Qed.

  Definition act_on_grp_compl_mult (M : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M))
             (a b : M)
    : act_on_grp_compl M left_cancel (montype_mult a b) =
      ((act_on_grp_compl M left_cancel b) o (act_on_grp_compl M left_cancel a))%functor.
  Proof.
    srapply @path_functor'.
    - intros [x1 x2]. simpl.
      apply path_prod; simpl.
      + apply inverse. apply montype_assoc.
      + reflexivity.
    - intros [x1 x2] y. intros [s p]. destruct p.
      simpl. rewrite ap_fst_path_prod. rewrite ap_snd_path_prod.
      rewrite concat_p1. rewrite concat_p1.
      srefine (double_transport_monoidal_action_cat M _ _ _ _ _ _ _ @ _).
      { apply left_cancel_localize. apply left_cancel. }
      srapply @path_sigma.
      { reflexivity. }
      simpl.
      repeat rewrite <- path_prod_VV. rewrite inv_V. simpl.
      rewrite ap_functor_prod.
      rewrite <- path_prod_pp. rewrite <- path_prod_pp.
      repeat rewrite concat_p1. simpl.
      unfold functor_prod. simpl.
      apply (ap (fun p => path_prod (s ⊗ ((x1 ⊗ a) ⊗ b), s ⊗ x2) (((s ⊗ x1) ⊗ a) ⊗ b, s ⊗ x2)
                                    p idpath)).
      rewrite ap_V.
      apply moveL_Vp. apply (equiv_inj inverse). rewrite inv_V.
      rewrite inv_pp. rewrite inv_pV. rewrite inv_pV. apply inverse.
      refine (montype_pentagon M _ _ _ _ @ _).
      repeat rewrite concat_p_pp. reflexivity.
  Defined.

  (* Definition act_on_grp_compl_id (M : Monoidal_1Type) *)
  (*            (left_cancel : left_faithful (@montype_mult M)) *)
  (*   : act_on_grp_compl M left_cancel montype_id = 1%functor. *)
  (* Proof. *)
  (*   srapply @path_functor'. *)
  (*   - intros [x1 x2]. simpl. *)
  (*     apply path_prod; simpl. *)
  (*     + apply montype_rid. *)
  (*     + reflexivity. *)
  (*   - intros [x1 x2] y. *)
  (*     intros [s p]. destruct p. simpl. *)
  (*     rewrite concat_p1. *)
  (*     srefine (double_transport_monoidal_action_cat M _ _ _ _ _ _ _ @ _). *)
  (*     { apply left_cancel_localize. apply left_cancel. } *)
  (*     srapply @path_sigma. *)
  (*     { reflexivity. } *)
  (*     simpl. *)
  (*     rewrite ap_V. rewrite ap_functor_prod. *)
  (*     apply moveR_Mp. rewrite concat_p1. *)
  (*     rewrite inv_Vp. simpl. *)
  (*     apply moveL_Vp. rewrite <- path_prod_pp. simpl. unfold functor_prod. simpl. *)
  (*     apply (ap (fun p => path_prod (s ⊗ (x1 ⊗ montype_id), s ⊗ x2) (s ⊗ x1, s ⊗ x2) p idpath)). *)
  (*     rewrite montype_triangle2. *)

  Definition act_on_grp_compl_inv (M : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M))
    : M -> Functor (group_completion M left_cancel) (group_completion M left_cancel).
  Proof.
    intro a.
    srapply @Build_Functor.
    - intros [x1 x2]. exact (x1, montype_mult x2 a).
    - intros [x1 x2] y.
      intros [s p].
      exists s.
      apply (path_prod); simpl.
      + apply (ap fst p).
      + refine (_ @ ap (fun m => montype_mult m a) (ap snd p)).
        apply inverse. apply montype_assoc.
    - intros [x1 x2] y z.
      intros [s p]. intros [t q]. destruct q. destruct p.
      simpl. repeat rewrite concat_p1.
      srapply @path_sigma.
      { reflexivity. }
      simpl.
      rewrite ap_fst_path_prod. rewrite ap_snd_path_prod.
      rewrite ap_functor_prod.
      rewrite <- path_prod_pp. rewrite <- path_prod_pp.
      rewrite concat_p1. simpl. rewrite concat_p1.
      apply (ap (fun p => path_prod _ _ _ p)).
      rewrite montype_pentagon.
      repeat rewrite concat_p_pp.
      apply whiskerR. rewrite ap_V. apply whiskerR. rewrite concat_Vp.
      apply concat_1p.
    - intros [x1 x2]. simpl.
      srapply @path_sigma.
      { reflexivity. } simpl.
      rewrite ap_fst_path_prod. rewrite ap_snd_path_prod.
      apply (ap (fun p => path_prod _ _ _ p)).
      rewrite montype_triangle1.
      destruct (montype_lid (x2 ⊗ a)). rewrite concat_p1.
      apply concat_Vp.
  Defined.

  Definition act_on_grp_compl_is_sect (M : Symmetric_Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M)) (a : M):
    NaturalTransformation
      1%functor
      ((act_on_grp_compl_inv M left_cancel a) o (act_on_grp_compl M left_cancel a))%functor.
  Proof.
    srapply @Build_NaturalTransformation.
    - intros [x1 x2]. simpl.
      exists a.
      apply path_prod;
        apply smontype_sym.
    - intros [x1 x2] y. intros [s p].
      simpl. destruct p. simpl.
      rewrite concat_p1. rewrite concat_p1.
      srapply @path_sigma.
      { apply smontype_sym. }
      refine (transport_paths_Fl (smontype_sym a s) _ @ _). simpl.
      rewrite ap_functor_prod.
      rewrite <- path_prod_pp.
      rewrite <- path_prod_pp.
      rewrite <- path_prod_pp.
      rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. simpl. rewrite concat_p1.
      apply moveR_pM.
      rewrite <- path_prod_VV.
      rewrite <- path_prod_pp. unfold functor_prod. simpl.
      transitivity (path_prod (_,_) (_,_)
                              (ap (fun x : M => smontype_mult x x1) (smontype_sym a s))
                              (ap (fun x : M => smontype_mult x x2) (smontype_sym a s)))^.
      { destruct (smontype_sym a s). reflexivity. }
      apply (equiv_inj inverse). rewrite inv_V.
      rewrite <- path_prod_VV.
      rewrite inv_pV. rewrite inv_pV.
      rewrite inv_pV. rewrite inv_pV.
      rewrite smontype_hexagon. rewrite smontype_hexagon.
      rewrite inv_pp. rewrite inv_pp.
      repeat rewrite concat_p_pp.
      reflexivity.
  Defined.

  Definition act_on_grp_compl_is_retr (M : Symmetric_Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M)) (a : M):
    NaturalTransformation
      1%functor
      ((act_on_grp_compl M left_cancel a) o (act_on_grp_compl_inv M left_cancel a))%functor.
  Proof.
    srapply @Build_NaturalTransformation.
    - intros [x1 x2]. simpl.
      exists a.
      apply path_prod;
        apply smontype_sym.
    - intros [x1 x2] y. intros [s p].
      simpl. destruct p. simpl.
      rewrite concat_p1. rewrite concat_p1.
      srapply @path_sigma.
      { apply smontype_sym. }
      refine (transport_paths_Fl (smontype_sym a s) _ @ _). simpl.
      rewrite ap_functor_prod.
      rewrite <- path_prod_pp.
      rewrite <- path_prod_pp.
      rewrite <- path_prod_pp.
      rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. simpl. rewrite concat_p1.
      apply moveR_pM.
      rewrite <- path_prod_VV.
      rewrite <- path_prod_pp. unfold functor_prod. simpl.
      transitivity (path_prod (_,_) (_,_)
                              (ap (fun x : M => smontype_mult x x1) (smontype_sym a s))
                              (ap (fun x : M => smontype_mult x x2) (smontype_sym a s)))^.
      { destruct (smontype_sym a s). reflexivity. }
      apply (equiv_inj inverse). rewrite inv_V.
      rewrite <- path_prod_VV.
      rewrite inv_pV. rewrite inv_pV.
      rewrite inv_pV. rewrite inv_pV.
      rewrite smontype_hexagon. rewrite smontype_hexagon.
      rewrite inv_pp. rewrite inv_pp.
      repeat rewrite concat_p_pp.
      reflexivity.
  Defined.

  Definition act_on_grp_compl_is_retr (M : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M)) (a : M):
    NaturalTransformation
      ((act_on_grp_compl M left_cancel a) o (act_on_grp_compl_inv M left_cancel a))%functor
      1%functor.
  Proof.
    srapply @Build_NaturalTransformation.
    - intros [x1 x2]. simpl.

  Definition split_ess_surj_act_on_grp_compl (M : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult M))
             (a : M)
    : forall (y : group_completion M left_cancel),
      {x : group_completion M left_cancel & Isomorphic (act_on_grp_compl M left_cancel a x) y}.
  Proof.
    intros [y1 y2].
    exists (y1, montype_mult y2 a). simpl.

  (* Proof. *)
  (*   simpl. intros x y. *)
  (*   apply isequiv_fcontr. *)
  (*   intros [[s p] [[t q] h1 h2]]. simpl in *. *)
  (*   assert (isid_s : montype_id = s). *)
  (*     { apply inverse. apply (unital_is_unit s t (ap pr1 h2)). } *)

  (*   assert (isid_t : montype_id = t). *)
  (*     { apply inverse. apply (unital_is_unit t s (ap pr1 h1)). } *)
  (*     destruct isid_s. destruct isid_t. *)
  (*     destruct q. *)

  (*   srapply @BuildContr. *)
  (*   - exists (montype_act_id _ y). *)
  (*     apply Category.path_isomorphic. *)
  (*     unfold Category.morphism_isomorphic. *)
  (*     clear h2 h1.  *)
  (*     srapply @path_sigma.       *)
  (*     + simpl. *)
  (*       destruct (montype_act_id act y). *)
  (*        simpl. reflexivity. *)
  (*     + simpl. *)
  (*       refine (transport_paths_Fl (match *)
  (*     montype_act_id act y as p0 in (_ = y0) *)
  (*     return *)
  (*       ((let (morphism_isomorphic, _) := *)
  (*           Category.Morphisms.idtoiso (monoidal_action_cat M X act left_cancel) p0 in *)
  (*         morphism_isomorphic).1 = montype_id) *)
  (*   with *)
  (*   | 1 => 1 *)
  (*   end) _ @ _). *)
  (*       simpl. *)
  (*       apply moveR_Vp. *)

  (*       clear h2 h1. clear q. *)

  (*     simpl. *)

  (*   srapply @isequiv_adjointify. *)
  (*   - intros [[s p] [[t q] h1 h2]]. simpl in *. *)
  (*     refine (_ @ p). apply inverse. *)
  (*     refine (_ @ montype_act_id act x). *)
  (*     apply (ap (fun var => act var x)). *)
  (*     apply (unital_is_unit s t). *)
  (*     apply (ap pr1 h2). *)
  (*   - unfold Sect. *)
  (*     intros [[s p] [[t q] h1 h2]]. simpl in *. *)
  (*     destruct p. apply Category.path_isomorphic. simpl. *)
  (*     unfold Category.morphism_isomorphic. *)
  (*     srapply @path_sigma. simpl.        *)

  (*     destruct q. simpl. *)
  (*     intro  *)

  (* should be moved *)
  Definition ap_homotopy_idmap {A : Type} (f : A -> A) (h : f == idmap) (a : A):
    ap f (h a) = h (f a).
  Proof.
    cut (forall p : f a = a,
              ap f p = h (f a) @ p @ (h a)^).
    - intro H. refine (H (h a) @ _).
      refine (concat_pp_p _ _ _ @ _).
      refine (whiskerL _ (concat_pV _) @ _). apply concat_p1.
    - intros []. destruct (h (f a)). reflexivity.
  Defined.

  (* Definition ap_homotopic_idmap {A : Type} (f : A -> A) (h : f == idmap) {a b : A} (p : a = b) : *)
  (*   ap f p = (h a) @ p @ (h b)^. *)
  (* Proof. *)
  (*   destruct p. destruct (h a). reflexivity. *)
  (* Defined. *)

  Definition prod_to_groupcompletion (S : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult S))
             (* (left_cancel : forall (s t : S) (p q : s = t) (a : S), *)
             (*     ap (fun x => x ⊗ a) p = ap (fun x => x ⊗ a) q -> p = q) *):
    Functor ((Type_to_Cat S)*(Type_to_Cat S))%category (group_completion S left_cancel).
  Proof.
    srapply @Build_Functor; simpl. { exact idmap. }
    - intros a b [p q].
      unfold monoidal_action_morphism.
      exists montype_id. apply path_prod.
      { apply (montype_lid _ @ p). }
      apply (montype_lid _ @ q).
    - intros [a1 a2] [b1 b2] [c1 c2] [p1 p2] [q1 q2]. simpl in *.
      destruct q2, q1, p2, p1. simpl. repeat rewrite concat_p1.
      srapply @path_sigma;simpl.
      { apply inverse. apply montype_lid. }
      refine (transport_paths_Fl (montype_lid montype_id)^
              (path_prod (functor_prod (montype_mult montype_id) (montype_mult montype_id) (a1, a2)) (a1, a2) (montype_lid a1) (montype_lid a2)) @ _).
      rewrite ap_V. rewrite inv_V.
      apply whiskerR.
      transitivity (path_prod ((montype_id ⊗ montype_id) ⊗ a1, (montype_id ⊗ montype_id) ⊗ a2) (_,_)

                              (ap (fun x : S => montype_mult x a1) (montype_lid montype_id)) (ap (fun x : S => montype_mult x a2) (montype_lid montype_id))).
      { destruct (montype_lid montype_id). reflexivity. }
      rewrite ap_functor_prod.
      rewrite <- path_prod_pp.
      apply (ap011 (path_prod _ _));
      refine (montype_triangle1 S montype_id _ @ _); apply whiskerL;
      apply inverse; simpl; apply ap_homotopy_idmap.
    - intro x. simpl. rewrite concat_p1. rewrite concat_p1. reflexivity.
  Defined.

  Definition to_prod (C : PreCategory) :
    Functor C (C*C)%category.
  Proof.
    apply Functor.prod; apply Functor.identity.
  Defined.

  Definition to_groupcompletion (S : Monoidal_1Type)
             (left_cancel : left_faithful (@montype_mult S))
           (* (left_cancel : forall (s t : S) (p q : s = t) (a : S), *)
           (*       ap (fun x => x ⊗ a) p = ap (fun x => x ⊗ a) q -> p = q) *):
  Functor (Type_to_Cat S) (group_completion S left_cancel) :=
    Functor.compose (prod_to_groupcompletion S left_cancel) (to_prod _).

End Localize.

Section Univalent_GroupGompletion.
  Context (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X)
          (left_cancel_act : left_faithful act).

  Lemma idtoiso_is_concat (x y : monoidal_action_cat M X act left_cancel_act) :
    forall (p : x = y),
      (@idtoiso _ x y p) =
      (montype_id; montype_act_id _ x @ p) :> morphism _ x y.
  Proof.
    intros []. simpl.
    srapply @path_sigma. { reflexivity. }
    simpl. apply (concat_p1 _)^.
  Defined.

  Definition equiv_path_isomorphic {C : PreCategory} (x y : C) (f g : (x <~=~> y)%category) :
    (f = g :> morphism C x y) <~> f = g
    := BuildEquiv _ _ (path_isomorphic f g) _.

  Lemma fiber_idtoiso (x y : monoidal_action_cat M X act left_cancel_act) (f : (x <~=~> y) %category) :
    hfiber (@idtoiso _ x y) f <~>
           ((morphism_isomorphic (Isomorphic := f)).1 = montype_id).
  Proof.
    (* destruct f as [f isiso]. simpl. *)
    (* destruct f as [s q]. simpl. *)
    unfold hfiber.
    transitivity {p : x = y & (montype_id; montype_act_id _ x @ p) = f :> morphism _ x y}.
    - apply equiv_functor_sigma_id.
      intro p.
      refine (_ oE (equiv_path_isomorphic
                      x y
                      _
                      f)^-1).
      apply equiv_concat_l.
      apply inverse. apply idtoiso_is_concat.
    - destruct f as [[s q] isiso]. simpl.
      transitivity {p : x = y &
                        {r : montype_id = s &
                             (montype_act_id act x)^ @ ap (fun a : M => act a x) r @ q = p}}.
      { apply equiv_functor_sigma_id. intro p.
        refine (_ oE (equiv_path_sigma _ _ _ )^-1). simpl.
        apply equiv_functor_sigma_id. intro r.
        destruct r. simpl. destruct p.
        refine (_ oE equiv_moveL_Vp _ _ _).
        refine (equiv_path_inverse _ _ oE _).
        apply equiv_concat_r. apply whiskerR. apply inverse. apply concat_p1. }
      transitivity {r : montype_id = s &
                        {p : x = y &
                             ((montype_act_id act x)^ @ ap (fun a : M => act a x) r) @ q = p}}.
      { srapply @equiv_adjointify.
        - intros [p [r h]]. exact (r; (p; h)).
        - intros [r [p h]]. exact (p; (r; h)).
        - intros [r [p h]]. reflexivity.
        - intros [p [r h]]. reflexivity. }
      refine (equiv_path_inverse _ _ oE _).
      apply equiv_sigma_contr. intro r.
      apply contr_basedpaths.
  Defined.

  Context (unit_is_id : forall s t: M, montype_mult s t = montype_id -> s = montype_id)
          (contr_component_id : forall (a : M), IsHProp (montype_id = a)).

  Definition univalent_monactcat (x y : monoidal_action_cat M X act left_cancel_act) :
    IsEquiv (@Category.idtoiso _ x y).
  Proof.
    apply isequiv_fcontr. intro f.
    srefine (contr_equiv' _ (equiv_inverse (fiber_idtoiso x y f))).
    destruct f as [[s p] isiso]. simpl.
    apply (contr_equiv' (montype_id = s)).
    { apply equiv_path_inverse. }
    apply contr_inhabited_hprop.
    { apply contr_component_id. }
    apply inverse.
    destruct isiso as [[t q] ]. simpl in *.
    apply (unit_is_id s t).
    apply ((equiv_path_sigma _ _ _)^-1 right_inverse).
  Defined.

  (* Definition isiso_monactcat : *)
  (*   forall (x y : monoidal_action_cat M X act left_cancel_act) (f : morphism _ x y), *)
  (*     Category.IsIsomorphism f <~> (montype_id = pr1 f). *)
  (* Proof. *)
  (*   intros. destruct f as [s p].  *)
  (*   apply equiv_iff_hprop. *)
  (*   - intros [[t q] h1 h2]. simpl. apply inverse. *)
  (*     apply (unit_is_id s t). apply (ap pr1 h2). *)
  (*   - simpl. destruct p. intro q. destruct q.  *)
  (*     srapply @Category.Build_IsIsomorphism. *)
  (*     + simpl. unfold monoidal_action_morphism. *)
  (*       exists montype_id.      (* from here *) *)
  (*       refine ((montype_act_mult act _ _ _)^ @ _). *)
  (*       refine (_ @ montype_act_id act x). *)
  (*       apply (ap (fun m => act m x) (montype_lid montype_id)). *)
  (*     + simpl. rewrite concat_p1. *)
  (*       srapply @path_sigma. *)
  (*       * apply montype_lid. *)
  (*       * simpl. *)
  (*         refine (transport_paths_Fl (montype_lid montype_id) _ @ _). *)
  (*         hott_simpl. *)
  (*     + simpl. rewrite concat_p1. *)
  (*       srapply @path_sigma. *)
  (*       * apply montype_lid. *)
  (*       * simpl. *)
  (*         refine (transport_paths_Fl (montype_lid montype_id) _ @ _). *)
  (*         rewrite (montype_act_triangle1 M X act). *)
  (*         rewrite (montype_act_triangle1 M X act). *)
  (*         hott_simpl. *)
  (*         rewrite (ap_to_conjp (fun x : X =>  (montype_act_id act x)^)). *)
  (*         unfold conjp. rewrite inv_pp. hott_simpl. *)
  (* Qed. *)

  (* Definition isomorphic_monactcat_1 (x y : monoidal_action_cat M X act left_cancel_act) : *)
  (*   Category.Isomorphic x y <~> {f : morphism _ x y &  montype_id = f.1} := *)
  (*  (equiv_functor_sigma_id (isiso_monactcat x y)) oE (Category.issig_isomorphic _ x y)^-1. *)

  (* Definition isomorphic_monactcat_2 (x y : monoidal_action_cat M X act left_cancel_act) : *)
  (*   {f : morphism _ x y &  montype_id = f.1} <~> (act montype_id x = y).                           *)
  (* Proof. *)
  (*   srapply @equiv_adjointify. *)
  (*   - intros [[s p] q]. simpl in q. destruct q. exact p. *)
  (*   - intros []. *)
  (*     srapply @exist. *)
  (*     + exists montype_id. reflexivity. *)
  (*     + reflexivity. *)
  (*   - intros []. reflexivity. *)
  (*   - intros [[s p] q]. simpl in q. destruct q. destruct p. reflexivity. *)
  (* Defined. *)

  (* Lemma factorize_idtoiso_1 (x y : monoidal_action_cat M X act left_cancel_act) : *)
  (*   (isomorphic_monactcat_1 x y) o (Category.idtoiso _ (x := x) (y := y)) == *)
  (*   (fun p : x = y => *)
  (*      match p with *)
  (*        idpath => ((montype_id; montype_act_id _ x); idpath) *)
  (*      end).     *)
  (* Proof. *)
  (*   intro p. apply path_sigma_hprop. destruct p. reflexivity. *)
  (* Qed. *)

  (* Lemma factorize_idtoiso_2 (x y : monoidal_action_cat M X act left_cancel_act) : *)
  (*   (isomorphic_monactcat_2 x y) o (fun p : x = y => *)
  (*                                     match p with *)
  (*                                       idpath => ((montype_id; montype_act_id _ x); idpath) *)
  (*                                     end) *)
  (*   == *)
  (*   (concat (montype_act_id _ x)). *)
  (* Proof. *)
  (*   intros []. simpl. apply inverse. apply concat_p1. *)
  (* Defined. *)

  (* Lemma factorize_idtoiso (x y : monoidal_action_cat M X act left_cancel_act) : *)
  (*   (isomorphic_monactcat_2 x y) o (isomorphic_monactcat_1 x y) o (@Category.idtoiso _ x y) == *)
  (*   concat (montype_act_id _ x). *)
  (* Proof. *)
  (*   intro p. *)
  (*   refine (_ @ factorize_idtoiso_2 x y p). *)
  (*   apply (ap (isomorphic_monactcat_2 x y)). *)
  (*   apply factorize_idtoiso_1. *)
  (* Qed. *)
  (* Require Import Morphisms. *)
  (* Require Import Categories. *)
  (* Definition isiso_frompath (x y : monoidal_action_cat M X act left_cancel_act) (p : x = y): *)
  (*   Category.IsIsomorphism *)
  (*     (C := monoidal_action_cat M X act left_cancel_act) *)
  (*     (s := x) (d := y) *)
  (*     (montype_id; montype_act_id _ x @ p). *)
  (* Proof. *)
  (*   srapply @Category.Build_IsIsomorphism. *)
  (*   - hnf. exists montype_id. *)
  (*     exact (montype_act_id _ y @ p^). *)
  (*   - simpl. *)

  (*   intro p. *)
  (*   srapply (@Category.Build_Isomorphic _ x y). *)
  (*   srefine ( *)
  (*            (morphism_isomorphic := _) _). *)

  (* Check Morphisms.Isomorphic. *)
End Univalent_GroupGompletion.


Require Import Nat.

Require Import List.
Import ListNotations.

Class MsArgs : Type :=
{
    A : Type;

    small : list A -> option (A * list A);
    adhoc : list A -> list A;

    split : A -> list A -> list (list A);
    join : list (list A) -> list A;
}.

Coercion A : MsArgs >-> Sortclass.

Unset Guard Checking.
Fixpoint qms (A : MsArgs) (l : list A) {struct l} : list A :=
match l with
    | [] => []
    | [x] => [x]
    | h :: t =>
        let ls := split h t in
        let ls' := map (qms A) ls in
          join ls'
end.

Fixpoint qms' (A : MsArgs) (l : list A) {struct l} : list A :=
match small l with
    | None        => adhoc l
    | Some (h, t) => join (map (qms' A) (split h t))
end.
Set Guard Checking.

#[export]
Instance MsArgs_nat : MsArgs :=
{
    A := nat;

    small l :=
      match l with
          | [] => None
          | h :: t => Some (h, t)
      end;

    adhoc := id;

    split h t :=
       [ filter (fun x => leb x h) t
       ; [h]
       ; filter (fun x => negb (leb x h)) t
       ];

    join := @concat nat
}.

(* Compute qms MsArgs_nat [3; 2; 1; 0]. *)