Require Import BenB.

Definition T := R.
(* De verzameling tijdstippen als reele getallen in seconden. *)
Variable K: Set.
(* De verzameling van verschillende kasten. *)
Variable S: Set.
(* De verzameling van knoppen op het besturingspaneel. *)

(* Functies *)
Variable knopKast (* s *): S -> K.
(* Geeft een kast bij een knop s. *)

(* Predikaten *)
Variable ruimteAanwezig (* t k *): T -> K -> Prop.
(* Op tijdstip t is er rechts van kast k voldoende ruimte
   aanwezig. *)
Variable obstructieGedetecteerd (* t *): T -> Prop.
(* Op tijdstip t is er een obstructie gedetecteerd. *)
Variable noodstop (* t *): T -> Prop.
(* Op tijdstip t is de noodstopknop ingedrukt. *)
Variable isVeiligknop (* t *): T -> Prop.
(* Op tijdstip t is de veiligheidsknop ingedrukt. *)
Variable opdrachtGegeven (* t k *): T -> K -> Prop.
(* Op tijdstip t is de opdracht gegeven om rechts van kast k ruimte te maken. *)
Variable kastBeweegt (* t k *): T -> K -> Prop.
(* Op tijdstip t beweegt kast k. *)
Variable knopGedrukt (* t s *): T -> S -> Prop.
(* Op tijdstip t is op knop s gedrukt. *)

Definition ruimteBespaard :=
(* Er wordt ruimte bespaard als er op elk tijdstip bij 0 of 1 kasten
   ruimte aanwezig is. *)

forall t:T,
    (
       forall k:K,
         ~ruimteAanwezig t k
    )
  \/
    (
       exists k:K,
           ruimteAanwezig t k
         /\
           (
             forall z:K,
                 ruimteAanwezig t z
               ->
                 z = k
           )
    )
.

Definition magBewegen (t:T) :=
(* Het systeem mag bewegen op tijdstip t als er t1 seconden geleden op de
   veiligheidsknop gedrukt is en er in het interval tussen t1 seconden
   geleden en t geen obstructie is en geen noodstop is ingedrukt. *)

exists t1:T,
        (t1 < t)
    /\
        isVeiligknop t1
    /\
        (
            forall d:T,
                    (d > t1)
                /\
                    (d < t)
                ->
                    ~noodstop d
        )

.

Definition isVeilig :=
(* Het systeem is veilig als op alle tijdstippen t de kasten mogen bewegen,
   of als de kasten niet bewegen. *)
forall t:T,
    magBewegen t
  \/
    (
      forall k:K,
        ~kastBeweegt t k
    )
.

Definition allesBereikbaar :=
(* Als er op een knop voor een kast gedrukt wordt en er mag
   30 seconden bewogen worden dan is 30 seconden later bij de
   bijbehorende kast ruimte aanwezig. *)
forall s:S,
    forall t:T,
            knopGedrukt t s
        /\
            (
                forall d:T,
                        (d > t)
                    /\
                        (d <= t+30)
                    ->
                        ~noodstop d
            )
        ->
            ruimteAanwezig (t+30) (knopKast s)

.

(* Specificatie van het geheel *)

(* Als op een willekeurig moment op een of andere knop wordt gedrukt,
   dan is er een zekere tijd later ruimte aanwezig bij de bijbehorende
   kast. *)
Definition diepvriespakhuis :=
forall t:T,
    forall s:S,
            knopGedrukt t s
        ->
            (
                exists d:T,
                        (d>t)
                    /\
                        ruimteAanwezig d (knopKast s)
            )
.


Set Implicit Arguments.

Section TRC.
  Variable A : Type.
  Variable R : A -> A -> Prop.

  Inductive trc : A -> A -> Prop :=
  | TrcRefl : forall a, trc a a
  | TrcFront : forall a b c, R a b -> trc b c -> trc a c.
  Hint Constructors trc : trc.

  Lemma trc_trans : forall a a' a'',
      trc a a' -> trc a' a'' -> trc a a''.
  Proof with eauto with trc.
    induction 1...
  Qed.
End TRC.

Global Hint Constructors trc : trc.
Global Hint Resolve trc_trans : trc.


(** * Distributive lattices *)

Require Import UniMath.Foundations.Preamble.

Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Lattice.Lattice.
Require Import UniMath.Algebra.Lattice.Bounded.
Require Import UniMath.Algebra.Lattice.Complement.

Section Def.

  Context {X : hSet} (L : lattice X).

  (** The normal "∧", "∨" notation conflicts with that for [hProp], whereas
      "+", "×" conflict with notation for types. *)
  Local Notation "x ≤ y" := (Lle L x y).
  Local Notation "x ⊗ y" := (Lmin L x y).
  Local Notation "x ⊕ y" := (Lmax L x y).

  Definition is_distributive : hProp.
  Proof.
    use make_hProp.
    - exact (∏ x y z : X, x ⊗ (y ⊕ z) = ((x ⊗ y) ⊕ (x ⊗ z))).
    - do 3 (apply impred; intro); apply setproperty.
  Defined.

End Def.

Definition distributive_lattice : UU :=
  ∑ (X : hSet) (L : lattice X), is_distributive L.

Section Bounded.
  Context {X : hSet} (L : bounded_lattice X).

  (** The normal "∧", "∨" notation conflicts with that for [hProp], whereas
      "+", "×" conflict with notation for types. *)
  Local Notation "x ≤ y" := (Lle L x y).
  Local Notation "x ⊗ y" := (Lmin L x y).
  Local Notation "x ⊕ y" := (Lmax L x y).

  Lemma distributive_lattice_complements_are_unique :
    is_distributive L -> ∏ x, isaprop (complement L x).
  Proof.
    intros is_distr x; apply invproofirrelevance; intros b a.
    apply subtypePath.
    - intro. apply isapropdirprod; apply setproperty.
    - refine (!islunit_Lmin_Ltop L (pr1 b) @ _ @ islunit_Lmin_Ltop L (pr1 a)).
      refine (_ @ maponpaths (fun z => Lmin L z _) (complement_top_axiom _ _ b)).
      refine (iscomm_Lmin _ _ _ @ _ @ iscomm_Lmin _ _ _).
      refine (!maponpaths (fun z => Lmin L _ z) (complement_top_axiom _ _ a) @ _).
      refine (is_distr _ _ _ @ _ @ !is_distr _ _ _).

      refine (iscomm_Lmax _ _ _ @ _ @iscomm_Lmax _ _ _ ).
      refine (maponpaths _ (iscomm_Lmin _ _ _) @ _ @ maponpaths _ (iscomm_Lmin _ _ _)).
      refine (maponpaths _ (complement_bottom_axiom _ _ b) @ _).
      refine (_ @ !maponpaths _ (complement_bottom_axiom _ _ a)).
      refine (_ @ maponpaths (fun z => Lmax L z _) (iscomm_Lmin _ _ _)).
      reflexivity.
  Qed.

End Bounded.


(*|
##############################################
Idiomatic ways of selecting subterm to rewrite
##############################################

:Link: https://stackoverflow.com/q/44516470
|*)

(*|
Question
********

Suppose we have a conclusion of form: ``a + b + c + d + e``. We also
have a lemma:
|*)

Lemma plus_assoc : forall n m p : nat, n + (m + p) = n + m + p.
Admitted.

(*|
What are idiomatic ways to arbitrarily "insert a pair of parentheses"
into the term? That is, how can we easily choose where to rewrite if
there's more than one available place.

What I generally end up doing is the following:

.. coq:: none
|*)

Goal forall a b c d e, a + b + c + d + e = a + b + c + (d + e).
Proof.
  intros a b c d e.

(*||*)

  replace (a + b + c + d + e) with (a + b + c + (d + e))
    by now rewrite plus_assoc.

(*|
And while this formulation does state exactly what I want to do, it
gets extremely long-winded for formulations more complicated than ``a
+ b + c + ...``.
|*)

(*|
Answer (Gilles 'SO- stop being evil')
*************************************

``rewrite <- lemma`` expects ``lemma`` to be an equality, that is, a
term whose type is of the form ``something1 = something2``. Like with
most other tactics, you can also pass it a function that returns an
equality, that is, a term whose type is of the form ``forall param1
... paramN, something1 = something2``, in which case Coq will look for
a place where it can apply the lemma to parameters to form a subterm
of the goal. Coq's algorithm is deterministic, but letting it choose
is not particularly useful except when performing repeated rewrites
that eventually exhaust all possibilities. Here Coq happens to choose
your desired goal with ``rewrite <- plus_assoc``, but I assume that
this was just an example and you're after a general technique.

You can get more control over where to perform the rewrite by
supplying more parameters to the lemma, to get a more specific
equality. For example, if you want to specify that ``(((a + b) + c) +
d) + e`` should be turned into ``((a + b) + c) + (d + e)``, i.e. that
the associativity lemma should be applied to the parameters ``(a + b)
+ c``, ``d`` and ``e``, you can write
|*)

  Undo. (* .none *) rewrite <- (plus_assoc ((a + b) + c) d e).

(*|
You don't need to supply all the parameters, just enough to pinpoint
the place where you want to apply the lemma. For example, here, it's
enough to specify ``d`` as the second argument. You can do this by
leaving the third parameter out altogether and specifying the wildcard
``_`` as the first parameter.
|*)

  Undo. (* .none *) rewrite <- (plus_assoc _ d).

(*|
Occasionally there are identical subterms and you only want to rewrite
one of them. In this case you can't use the ``rewrite`` family of
tactics alone. One approach is to use ``replace`` with a bigger term
where you pick what you want to change, or event ``assert`` to replace
the whole goal. Another approach is to use the ``set`` tactics, which
lets you give a name to a specific occurrence of a subterm, then rely
on that name to identify specific subterms, and finally call ``subst``
to get rid of the name when you're done.

An alternative approach is to forget about which lemmas to apply, and
just specify how you want to change the goal with something like
``assert`` or a plain ``replace ... with ... .``. Then let automated
tactics such as ``congruence``, ``lia``, ``solve [firstorder]``, etc.
find parameters that make the proof work. With this approach, you do
have to write down big parts of the goal, but you save on specifying
lemmas. Which approach works best depends on where you are on a big
proof and what tends to be stable during development and what isn't.
|*)

(*|
Answer (ejgallego)
******************

IMO your best option is to use the ssreflect pattern selection
language, available in Coq 8.7 or by installing math-comp in earlier
versions. This language is documented in the manual:
https://hal.inria.fr/inria-00258384

Example (for Coq 8.7):
|*)

Reset Initial. (* .none *)
(* Replace with From mathcomp Require ... in Coq < 8.7 *)
From Coq Require Import ssreflect ssrfun ssrbool.

Lemma addnC n m : m + n = n + m. Admitted.
Lemma addnA m n o : m + (n + o) = m + n + o. Admitted.

Lemma example m n o p : n + o + p + m = m + n + o + p.
Proof. by rewrite -[_ + _ + o]addnA -[m + _ + p]addnA [m + _]addnC.
Qed.

(*|
Answer (Anton Trunov)
*********************

If you don't want to prove a helper lemma, then one of your choices is
using Ltac to pattern match on the structure of the equality on your
hands. This way you can bind arbitrary complex subexpressions to
pattern variables:
|*)

Require Import Coq.Arith.Arith.

Goal forall a b c d e,
    (a + 1 + 2) + b + c + d + e = (a + 1 + 2) + (b + c + d) + e -> True.
  intros a b c d e H.
  match type of H
  with ?a + ?b + ?c + ?d + ?e = _ =>
         replace (a + b + c + d + e)
         with (a + (b + c + d) + e) in H
           by now rewrite <- ?plus_assoc
  end.
Abort.

(*|
In the above piece of code ``?a`` stands for ``a + 1 + 2``. This, of
course, doesn't improve anything if you are dealing with simple
variables, it helps only when you are dealing with complex nested
expressions.

Also, if you need to rewrite things in the goal, then you can use
something like this:

.. code-block:: coq

    match goal with
    | |- ?a + ?b + ?c + ?d + ?e = _ => <call your tactics here>
    end.
|*)


(* In this file we show:
   1. If a displayed category over a monoidal category has the structure of a displayed monoidal category,
      then has the total category the structure of a monoidal category.
   2. The projection from the total category (equipped with this monoidal structure) to the base (monoidal) category
      is a strict monoidal functor.
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesCurried.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.DisplayedMonoidalCurried.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsCurried.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section MonoidalTotalCategory.

  Context (C : category) (T : tensor_data C) (I : C) (α : associator_data T) (lu : leftunitor_data T I) (ru : rightunitor_data T I) (tid : tensorfunctor_id T) (tcomp : tensorfunctor_comp T) (αnat : associator_naturality α) (αiso : associator_is_natiso α) (lunat : leftunitor_naturality lu) (luiso : leftunitor_is_natiso lu) (runat : rightunitor_naturality ru) (ruiso : rightunitor_is_natiso ru) (tri : triangle_identity lu ru α) (pen : pentagon_identity α)
          (D : disp_cat C) (dtd : displayedtensor_data C D T) (i : D I) (dα : displayedassociator_data C D T α dtd) (dlu : displayedleftunitor_data C D T I lu dtd i) (dru : displayedrightunitor_data C D T I ru dtd i) (dtid : displayedtensor_id C D T tid dtd) (dtcomp : displayedtensor_comp C D T tcomp dtd) (dαnat : displayedassociator_naturality C D T α αnat dα ) (dαiso : displayedassociator_is_nat_iso C D T α αiso dα ) (dlunat : displayedleftunitor_naturality C D T I lu lunat dlu ) (dluiso : displayedleftunitor_is_nat_iso C D T I lu luiso dlu) (drunat : displayedrightunitor_naturality C D T I ru runat dru ) (druiso : displayedrightunitor_is_nat_iso C D T I ru ruiso dru) (dtri : displayedtriangle_identity C D T I α lu ru tri dlu dru dα) (dpen : displayedpentagon_identity C D T α pen dα).

  Notation ToD := (total_category D).
  Notation "x ⊗_{ T } y" := (tensoronobjects_from_tensordata T x y) (at level 31).
  Notation "f ⊗^{ T } g" := (tensoronmorphisms_from_tensordata T  _ _ _ _ f g) (at level 31).
  Notation "a ⊗_{{ dtd }} b" := (displayedtensoronobjects_from_displayedtensordata _ _ _ dtd _ _ a b) (at level 31).
  Notation "f' ⊗^{{ dtd }} g'" := (displayedtensoronmorphisms_from_displayedtensordata dtd _ _ _ _ _ _ _ _ _ _ f' g'  ) (at level 31).

  (** DATA **)
  Definition totalcategory_tensordata : tensor_data ToD.
  Proof.
    use tpair.
    + intros xa yb.
      exact ((pr1 xa) ⊗_{T} (pr1 yb) ,, (pr2 xa) ⊗_{{dtd}} (pr2 yb)).
    +  intros xa yb xa' yb' f g.
       split with (pr1 f ⊗^{T} pr1 g).
       apply (pr2 dtd).
       - exact (pr2 f).
       - exact (pr2 g).
  Defined.
  Notation TtD := totalcategory_tensordata.

  Definition totalcategory_associatordata : associator_data TtD.
  Proof.
    intros x y z.
    use tpair.
    + exact (α (pr1 x) (pr1 y) (pr1 z)).
    + exact (dα (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)).
  Defined.
  Notation TαD := totalcategory_associatordata.

  Definition totalcategory_unitdata : ToD := (I,,i).
  Notation TuD := totalcategory_unitdata.

  Definition totalcategory_leftunitordata : leftunitor_data TtD TuD.
  Proof.
    intro x.
    use tpair.
    + apply lu.
    + exact (dlu (pr1 x) (pr2 x)).
  Defined.
  Notation TluD := totalcategory_leftunitordata.

  Definition totalcategory_rightunitordata : rightunitor_data TtD TuD.
  Proof.
    intro x.
    use tpair.
    + apply ru.
    + exact (dru (pr1 x) (pr2 x)).
  Defined.
  Notation TruD := totalcategory_rightunitordata.

  Definition totalcategory_monoidalcatdata : (monoidalcategory_data ToD) := (TtD,,TuD,,TluD,,TruD,,TαD).

  (** PROPERTIES **)
  Lemma totalcategory_tensorfunctorid : tensorfunctor_id TtD.
  Proof.
    intros x y.
    use total2_paths_b.
    + apply tid.
    + apply (dtid (pr1 x) (pr1 y) (pr2 x) (pr2 y)).
  Qed.

  Lemma totalcategory_tensorfunctorcomp : tensorfunctor_comp TtD.
  Proof.
    intros x y x' y' x'' y'' f f' g g'.
    use total2_paths_b.
    + use tcomp.
    + use (((dtcomp (pr1 x) (pr1 y) (pr1 x') (pr1 y') (pr1 x'') (pr1 y'')
                         (pr2 x) (pr2 y) (pr2 x') (pr2 y') (pr2 x'') (pr2 y'')
                         (pr1 f) (pr1 g) (pr1 f') (pr1 g')
                         (pr2 f) (pr2 g) (pr2 f') (pr2 g')))).
  Qed.

  Lemma totalcategory_associatornaturality : associator_naturality TαD.
  Proof.
    intros x x' y y' z z' f g h.
    use total2_paths_b.
    - exact (αnat (pr1 x) (pr1 x') (pr1 y) (pr1 y') (pr1 z) (pr1 z') (pr1 f) (pr1 g) (pr1 h)).
    - exact (dαnat (pr1 x) (pr1 x') (pr1 y) (pr1 y') (pr1 z) (pr1 z')
                        (pr2 x) (pr2 x') (pr2 y) (pr2 y') (pr2 z) (pr2 z')
                        (pr1 f) (pr1 g) (pr1 h) (pr2 f) (pr2 g) (pr2 h)).
  Qed.

(* The following part has holes because of the migration from [iso] to [z_iso] as notion of isomorphism.
   It compiled at the moment of commenting it. But at the price of three "Admitted".

  Lemma totalcategory_associatorisnatiso : associator_is_natiso TαD.
  Proof.
    intros x y z.
    use tpair.
    + use tpair.
    - exact (pr1 (αiso (pr1 x) (pr1 y) (pr1 z))).
    - cbn.
      set (pf :=  (((pr2 (pr1 (pr2(pr1 C)))) _ _) (pr1 (αiso (pr1 x) (pr1 y) (pr1 z))))).
      (* pf : Isos.inv_from_iso (Isos.z_iso_to_iso (α (pr1 x) (pr1 y) (pr1 z),, αiso (pr1 x) (pr1 y) (pr1 z))) = pr1 (αiso (pr1 x) (pr1 y) (pr1 z))) *)
      admit.
      (*
      exact (transportf (*(mor_disp (pr2 x ⊗_{{ dtd}} (pr2 y ⊗_{{ dtd}} pr2 z))
          ((pr2 x ⊗_{{ dtd}} pr2 y) ⊗_{{ dtd}} pr2 z))*) _ pf (pr1 (dαiso (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)))).
*)
      + use tpair.
        - use total2_paths_b.
          -- exact (pr1 (pr2 (αiso (pr1 x) (pr1 y) (pr1 z)))).
          -- admit. (* etrans. { apply mor_disp_transportf_prewhisker. }
             apply transportb_transpose_right.
             etrans.
             { apply transport_f_f. }

             etrans. {
              apply maponpaths.
              apply (pr2 (pr2 (dαiso (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)))).
             }
             etrans. { apply transport_f_f. }
             apply transportf_set.
             apply homset_property. *)
        - use total2_paths_b.
          -- exact (pr2 (pr2 (αiso (pr1 x) (pr1 y) (pr1 z)))).
          -- admit.
             (* etrans. { apply mor_disp_transportf_postwhisker. }
             apply transportb_transpose_right.
             etrans.
             { apply transport_f_f. }

             etrans. {
              apply maponpaths.
              apply (pr1 (pr2 (dαiso (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)))).
            }
            etrans. { apply transport_f_f. }
            apply transportf_set.
             apply homset_property.
  Qed.
       *)
      Admitted.

  Lemma totalcategory_leftunitornaturality : leftunitor_naturality TluD.
  Proof.
    intros x y f.
    use total2_paths_b.
    + exact (lunat (pr1 x) (pr1 y) (pr1 f)).
    + exact (dlunat (pr1 x) (pr1 y) (pr2 x) (pr2 y) (pr1 f) (pr2 f)).
  Qed.

  Lemma totalcategory_leftunitorisnatiso : leftunitor_is_natiso TluD.
  Proof.
    intros x.
    use tpair.
    + use tpair.
    - exact (pr1 (luiso (pr1 x))).
    - set (pf (*: Isos.inv_from_iso (Isos.z_iso_to_iso (lu (pr1 x),, luiso (pr1 x))) = pr1 (luiso (pr1 x))*)
           := (((pr2 (pr1 (pr2(pr1 C)))) _ _) (pr1 (luiso (pr1 x))))
          ).
      admit. (*
      exact (transportf _ pf (pr1 (dluiso (pr1 x) (pr2 x)))). *)
      + use tpair.
        - use total2_paths_b.
          -- exact (pr1 (pr2 (luiso (pr1 x)))).
          -- admit. (* etrans.
             { apply mor_disp_transportf_prewhisker. }
             apply transportb_transpose_right.
             etrans.
             { apply transport_f_f. }
             etrans. {
              apply maponpaths.
              apply (pr2 (pr2 (dluiso (pr1 x) (pr2 x)))).
             }
             etrans. { apply transport_f_f. }
             apply transportf_set.
             apply homset_property. *)
        - use total2_paths_b.
          -- exact (pr2 (pr2 (luiso (pr1 x)))).
          -- admit. (* etrans.
             { apply mor_disp_transportf_postwhisker. }
             apply transportb_transpose_right.
             etrans.
             { apply transport_f_f. }
             etrans. {
              apply maponpaths.
              apply (pr1 (pr2 (dluiso (pr1 x) (pr2 x)))).
             }
             etrans. { apply transport_f_f. }
             apply transportf_set.
             apply homset_property.
  Qed. *)
             Admitted.

  Lemma totalcategory_rightunitornaturality : rightunitor_naturality TruD.
  Proof.
    intros x y f.
    use total2_paths_b.
    + exact (runat (pr1 x) (pr1 y) (pr1 f)).
    + exact (drunat (pr1 x) (pr1 y) (pr2 x) (pr2 y) (pr1 f) (pr2 f)).
  Qed.

  Lemma totalcategory_rightunitorisnatiso : rightunitor_is_natiso TruD.
  Proof.
    intros x.
    use tpair.
    + use tpair.
    - exact (pr1 (ruiso (pr1 x))).
    - set (pf (*: Isos.inv_from_iso (Isos.z_iso_to_iso (lu (pr1 x),, luiso (pr1 x))) = pr1 (luiso (pr1 x))*)
           := (((pr2 (pr1 (pr2(pr1 C)))) _ _) (pr1 (ruiso (pr1 x))))
          ).
      admit.
      (* exact (transportf _ pf (pr1 (druiso (pr1 x) (pr2 x)))). *)
      + use tpair.
        - use total2_paths_b.
          -- exact (pr1 (pr2 (ruiso (pr1 x)))).
          -- admit. (* etrans.
             { apply mor_disp_transportf_prewhisker. }
             apply transportb_transpose_right.
             etrans.
             { apply transport_f_f. }

             etrans. {
              apply maponpaths.
              apply (pr2 (pr2 (druiso (pr1 x) (pr2 x)))).
            }
            etrans. { apply transport_f_f. }

             apply transportf_set.
             apply homset_property.

*)
        - use total2_paths_b.
          -- exact (pr2 (pr2 (ruiso (pr1 x)))).
          -- admit. (* etrans.
             { apply mor_disp_transportf_postwhisker. }
             apply transportb_transpose_right.
             etrans.
             { apply transport_f_f. }

             etrans. {
              apply maponpaths.
              apply (pr1 (pr2 (druiso (pr1 x) (pr2 x)))).
            }
            etrans. { apply transport_f_f. }

             apply transportf_set.
             apply homset_property.
  Qed. *)
             Admitted.

  Lemma totalcategory_triangleidentity : triangle_identity TluD TruD TαD.
  Proof.
    intros x y.
    use total2_paths_b.
    + exact (tri (pr1 x) (pr1 y)).
    + exact (dtri (pr1 x) (pr1 y) (pr2 x) (pr2 y)).
  Qed.

  Lemma totalcategory_pentagonidentity : pentagon_identity TαD.
  Proof.
    intros w x y z.
    use total2_paths_b.
    + exact (pen (pr1 w) (pr1 x) (pr1 y) (pr1 z)).
    + exact (dpen (pr1 w) (pr1 x) (pr1 y) (pr1 z) (pr2 w) (pr2 x) (pr2 y) (pr2 z)).
  Qed.

  Definition totalcategory_monoidallaws : monoidal_laws totalcategory_monoidalcatdata :=
    (totalcategory_tensorfunctorid,, totalcategory_tensorfunctorcomp,,
                                     totalcategory_associatornaturality,, totalcategory_associatorisnatiso,,
                                     totalcategory_leftunitornaturality,, totalcategory_leftunitorisnatiso,,
                                     totalcategory_rightunitornaturality,, totalcategory_rightunitorisnatiso,,
                                     totalcategory_triangleidentity,, totalcategory_pentagonidentity).

  Definition totalcategory_monoidalcat : monoidalcategory ToD := (totalcategory_monoidalcatdata,, totalcategory_monoidallaws).

  Notation π := (pr1_category D).
  Definition MC : monoidalcategory_data C := (T,,I,,lu,,ru,,α).

  Definition projection_tensorpreservingdata : tensor_preserving_data ToD C totalcategory_monoidalcatdata MC π := λ x y, identity (π x ⊗_{ MC} π y).
  Definition projection_unitpreservingdata : unit_preserving_data ToD C totalcategory_monoidalcatdata MC π := identity I.

  Definition projection_monoidalfunctordata : monoidalfunctor_data ToD C totalcategory_monoidalcatdata MC π :=
  (projection_tensorpreservingdata,,projection_unitpreservingdata).

  Lemma projection_tensornaturality : tensor_preserving_data_is_natural ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata.
  Proof.
    intros xx yy zz ww ff' gg'.
    exact ((pr1 (pr1 (pr2 (pr1 C))) _ _ (pr1 ff' ⊗^{T} pr1 gg')) @ (pathsinv0 (pr2 (pr1 (pr2 (pr1 C))) _ _ (pr1 ff' ⊗^{T} pr1 gg')))).
  Qed.

  Lemma projection_preservesassociativity : preserves_associativity ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata.
  Proof.
    intros xx yy zz.
    rewrite (pr1 (pr1 (pr2 (pr1 C)))).
    rewrite (pr2 (pr1 (pr2 (pr1 C)))).
    rewrite tid.
    rewrite tid.
    rewrite (pr1 (pr1 (pr2 (pr1 C)))).
    rewrite (pr2 (pr1 (pr2 (pr1 C)))).
    apply idpath.
  Qed.

  Lemma projection_preservesleftunitality : preserves_leftunitality ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata projection_unitpreservingdata.
  Proof.
    intro xx.
    rewrite tid.
    rewrite (pr1 (pr1 (pr2 (pr1 C)))).
    rewrite (pr1 (pr1 (pr2 (pr1 C)))).
    apply idpath.
  Qed.

  Lemma projection_preservesrightunitality : preserves_rightunitality ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata projection_unitpreservingdata.
  Proof.
    intro xx.
    rewrite tid.
    rewrite (pr1 (pr1 (pr2 (pr1 C)))).
    rewrite (pr1 (pr1 (pr2 (pr1 C)))).
    apply idpath.
  Qed.

  Definition projection_monoidallaws : monoidalfunctor_laws ToD C totalcategory_monoidalcatdata MC π projection_monoidalfunctordata
    := (projection_tensornaturality,,projection_preservesassociativity,,projection_preservesleftunitality,,projection_preservesrightunitality).

  Definition projection_monoidalfunctor : monoidalfunctor ToD C totalcategory_monoidalcatdata MC π
    := (projection_monoidalfunctordata,,projection_monoidallaws).

  Lemma projection_strictlytensorpreserving : is_strictlytensorpreserving ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata.
  Proof.
    intros xx yy.
    use tpair.
    + apply idpath.
    + apply idpath.
  Qed.

  Lemma projection_strictlyunitpreserving : is_strictlyunitpreserving ToD C totalcategory_monoidalcatdata MC π projection_unitpreservingdata.
  Proof.
    use tpair.
    + apply idpath.
    + apply idpath.
  Qed.
*)
End MonoidalTotalCategory.


Require Import HoTT.HoTT GenericZipAndTraverse.PolynomialFunctors.

Definition zipExtension (p : Polynomial) {A B : Type}
  : Pullback
      (pr1 (P := fun i => Direction p i -> A))
      (pr1 (P := fun i => Direction p i -> B))
    <~> Extension p (A * B).
Proof.
  refine (
    equiv_functor_sigma_id (fun i => equiv_prod_coind _ _)
    oE (equiv_functor_sigma_pb
      (Q := fun '(i; i'; w) => (Direction p i -> A) * (Direction p i' -> B))
      (equiv_pr1 (fun i => {i' : Position p & i = i'}))^-1)^-1
    oE _
  ).
  make_equiv.
Defined.

Definition zip (F : Type -> Type) `{IsPolynomialFunctor F} {A B : Type}
  : Pullback
      (pr1 o equivalenceToExtension F A)
      (pr1 o equivalenceToExtension F B)
    <~> F (A * B) :=
  (equivalenceToExtension F (A * B))^-1
  oE zipExtension (polynomial F)
  oE (equiv_sigma_prod (fun '(x', y') => pr1 x' = pr1 y'))^-1
  oE equiv_functor_sigma_pb
    (equivalenceToExtension F A *E equivalenceToExtension F B)
  oE equiv_sigma_prod _.

Notation unzip F := (zip F)^-1.

Context `{Funext}.
Open Scope nat_scope.

Eval compute in
  zip Tree
    ( node leaf 2    (node leaf 4     leaf)
    ; node leaf true (node leaf false leaf)
    ; idpath
    ).

Eval compute in unzip Tree (node leaf (0, false) (node leaf (1, true) leaf)).


Require Export encompass conv.
From mathcomp Require Import all_ssreflect all_algebra vector reals normedtype.
From mathcomp Require Import classical_sets boolp mathcomp_extra.
Require Import counterclockwise.

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

From mathcomp.algebra_tactics Require Import ring.
From mathcomp.zify Require Import zify.

Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory.

Section hull_def.
Local Open Scope classical_set_scope.
Local Open Scope ring_scope.
Definition hull (R : realType) (T : lmodType R) (X : set T) : set T :=
  [set p : T | exists n (g : 'I_n -> T) (d : 'I_n -> R),
    [/\ (forall i, 0 <= d i)%R,
    (\sum_(i < n) d i = 1%R),
    g @` setT `<=` X &
    p = \sum_(i < n) (d i) *: (g i)] ].
End hull_def.

Module Spec := SpecKA(ccw_KA).

Section spec.
Variable R : realType.
Let Plane := Plane R.

Open Scope ring_scope.
Open Scope order_scope.

Section hull_prop.
Local Open Scope classical_set_scope.
Variable A : lmodType R.
Implicit Types X Y : set A.

Lemma subset_hull X : X `<=` hull X.
Proof.
move=> x xX; rewrite /hull; exists 1%N, (fun=> x), (fun=>1%R).
split=> //; first by move=>_; exact ler01.
- by rewrite big_ord_recl big_ord0 addr0.
- by move=> d [i _ <-].
- by rewrite big_ord_recl big_ord0 scale1r addr0.
Qed.

Lemma hull0 : hull set0 = set0 :> set A.
Proof.
rewrite funeqE => d; rewrite propeqE; split => //.
move=> [n [g [e [e0 e1 gX ->{d}]]]].
destruct n as [|n]; first by rewrite big_ord0 in e1; move:(@ltr01 R); rewrite e1 ltxx.
exfalso; apply: (gX (g ord0)); exact/imageP.
Qed.

Lemma hull_eq0 X : (hull X == set0) = (X == set0).
Proof.
apply/idP/idP=> [/eqP abs|]; last by move=> /eqP ->; rewrite hull0.
apply/negPn/negP => /set0P[/= d] => dX.
move: abs; rewrite funeqE => /(_ d); rewrite propeqE /set0 => -[H _]; apply H.
exact/subset_hull.
Qed.

Lemma hull_monotone X Y : X `<=` Y -> hull X `<=` hull Y.
Proof.
move=> H a [n [g [d [d0 d1 gX ae]]]]; exists n, g, d; split => //.
by eapply subset_trans; first exact: gX.
Qed.

Lemma hull2 (x y : A) :
  hull [set x; y]%classic = ((fun t => x <| t |> y) @` `[0%R, 1%R])%classic.
Proof.
rewrite eqEsubset; split; last first.
   move=> z [t /andP [t0 t1]] <-.
   rewrite bnd_simp in t0, t1.
   exists 2%N, (fun i => if i == 0 then x else y),
               (fun i => if i == 0 then t else `1- t).
   split; first by case; case=>//= n _; rewrite subr_ge0.
   - by rewrite big_ord_recl big_ord1/= addrCA subrr addr0.
   - by move=>a[]; case; case=>/= [|n] _ _ <-; [left|right].
   - by rewrite big_ord_recl big_ord1.
move=>z [n][g][d][d0 d1 gxy ->].
move:d1=>/esym/eqP; rewrite -subr_eq0 (bigID [pred i | g i == x])//= opprD.
rewrite addrCA addrC subr_eq0=>/eqP/esym=>d1.
exists (\sum_(i < n | g i == x) d i).
   rewrite inE; apply/andP; rewrite 2!bnd_simp {2}d1 -[(_<=1)%R]subr_ge0 opprB.
   by rewrite addrCA subrr addr0; split; apply sumr_ge0.
rewrite/conv {2}d1 opprB addrCA subrr addr0 [RHS](bigID [pred i | g i == x])//=.
congr (_ + _); rewrite scaler_suml; apply: congr_big=>// i.
   by move=> /eqP ->.
have /gxy[->|->//] : range g (g i) by [].
by rewrite eqxx.
Qed.

Lemma hull_convex X : forall x y,
  (hull X) x -> (hull X) y -> hull [set x; y] `<=` hull X.
Proof.
move=> + + [n][g][d][d0 d1 gX->] [m][h][e][e0 e1 hX ->].
rewrite hull2=>_ _ x [t] /andP.
rewrite !bnd_simp -[(_ <= 1)%R]subr_ge0 => [[t0 t1]] <-.
exists (n + m)%N, (fun i=> match split i with inl i => g i | inr i => h i end),
                  (fun i=> match split i with inl i => t * (d i)
                                            | inr i => (`1- t) * e i end); split.
- by move=>i; case: (split i)=>j; apply mulr_ge0.
- rewrite big_split_ord/= -{1}(add_onemK t); congr +%R.
    rewrite -{3}(mulr1 t) -{1}d1 mulr_sumr; apply congr_big=>// i _.
    case: (splitP (lshift m i)).
      by move=>j ij; congr (_ * d _); apply val_inj.
    by move=> k/= ink; move: (ltn_ord i); rewrite ink -ltn_subRL subnn ltn0.
  rewrite -{2}(mulr1 (`1- t)) -{1}e1 mulr_sumr; apply congr_big=>// i _.
  case: (splitP (rshift n i))=>/=.
    by move=> j/= nij; move: (ltn_ord j); rewrite -nij -ltn_subRL subnn ltn0.
  by move=>j /eqP; rewrite eqn_add2l=>/eqP ij; congr (_ * e _); apply val_inj.
- by move=>y/= [i] _; case: split=>j <-; [ apply gX | apply hX ].
- rewrite big_split_ord /conv; congr +%R; rewrite scaler_sumr;
   apply congr_big => // i _; rewrite scalerA.
  + case: (splitP (lshift m i)).
      by move=> j ij; congr (_ * d _ *: g _); apply val_inj.
    by move=> k/= ink; move: (ltn_ord i); rewrite ink -ltn_subRL subnn ltn0.
  + case: (splitP (rshift n i)) =>/=.
      by move=> j/= nij; move: (ltn_ord j); rewrite -nij -ltn_subRL subnn ltn0.
    by move=> j /eqP; rewrite eqn_add2l => /eqP ij; congr (_ * e _ *: h _); apply val_inj.
Qed.

End hull_prop.

Let oriented := fun p q r : Plane => 0%:R <= det p q r.

Lemma is_left_oriented (p q r : Plane) :
  encompass.is_left oriented p q r = oriented p q r.
Proof.
apply/idP/idP; last by rewrite/encompass.is_left; move=>->; rewrite !orbT.
by move=>/or3P[| |//] /eqP re; subst r; rewrite /oriented det_cyclique; [ rewrite det_cyclique |]; rewrite det_alternate.
Qed.

Lemma encompass_correct (l : seq Plane) (p : Plane) :
  uniq l ->
  (3 <= size l)%N ->
  encompass (ccw (R:=R)) l l ->
  encompass oriented [:: p] l ->
  exists t : 'I_(size l) -> R,
    (forall i, 0 <= t i)%R /\ (\sum_i t i = 1%:R) /\ p = \sum_i t i *: l`_i.
Proof.
move: l p.
have orientedW: forall a b c, encompass.is_left oriented a b c -> oriented a b c.
   move=>a b c /or3P[| |//] /eqP<-; rewrite /oriented.
         by rewrite 2!det_cyclique det_alternate.
      by rewrite det_cyclique det_alternate.
have H3 a b c p : uniq [:: a; b; c] ->
    encompass (ccw (R:=R)) [:: a; b; c] [:: a; b; c] ->
    encompass oriented [::p] [:: a; b; c] ->
    exists t : 'I_3 -> R, (forall i, 0 <= t i)%R /\ (\sum_i t i = 1%:R) /\ p = \sum_i t i *: [:: a; b; c]`_i.
  rewrite/uniq !in_cons negb_or 2!in_nil 2!orbF=>/andP [/andP[/negPf ab /negPf ac] /andP[/negPf bc _]] /andP[/andP [_ /andP [h _]] _] /= /andP [/andP [/orientedW cap _]] /andP [/andP [/orientedW abp _]] /andP [/andP [/orientedW bcp _] _].
  move: h; rewrite/encompass.is_left bc eq_sym ab =>/= cab.
  exists (fun i => [:: det c p b / det c a b; det c a p / det c a b; det p a b / det c a b]`_i); split.
      case; case; [| case; [| case=>//]]; move=>/= _; (apply mulr_ge0; [| by rewrite invr_ge0; apply ltW]).
      - by rewrite 2!det_cyclique.
      - by [].
      - by rewrite det_cyclique.
   move: cab; rewrite /ccw lt0r=>/andP[cab _].
   split.
      by rewrite !big_ord_recr big_ord0 /= add0r -2!mulrDl addrC addrA -decompose_det divff.
   rewrite !big_ord_recr big_ord0 /= add0r.
   apply (scalerI cab).
   rewrite 2!scalerDr 3!scalerA 3!mulrA 3![det c a b * _]mulrC -3!mulrA divff// 3!mulr1.
   apply/pair_eqP; apply/andP; split; apply/eqP; rewrite !develop_det /xcoord /ycoord; cbn; ring.
move=> l p.
elim: l=>// a; case=>// b; case=>// c; case.
   by move=>IHl abc _; apply H3.
move=>d l IHl lu sl ll lp.
case labp: (oriented b (last d l) p).
   move:H3=>/(_ a b (last d l) p); case.
      - move: lu; apply subseq_uniq=>/=.
        by rewrite eq_refl eq_refl -/(subseq [:: last d l] (c :: d :: l)) sub1seq in_cons mem_last orbT.
      - apply (Spec.encompassll_subseq lu)=>//.
        by rewrite /= eq_refl /= eq_refl -/(subseq [:: last d l] (c :: d :: l)) sub1seq in_cons mem_last orbT.
      - apply/andP; split.
         by move:lp=>/andP[lp _]; move:lp.
      apply/andP; split.
         by move:lp=>/andP[_ /andP[ap _]].
      by rewrite /=/encompass.is_left labp !orbT.
   move=>f [f0 [f1 fp]].
   exists (fun i:'I_(size l).+4 => (i == ord0)%:R * f ord0 + (i == lift ord0 ord0)%:R * f (lift ord0 ord0) + (i == ord_max)%:R * f ord_max).
   split.
      move=>i.
      apply addr_ge0; [apply addr_ge0|]; apply mulr_ge0; try apply f0; apply ler0n.
   split; rewrite big_ord_recr /= eq_refl mul1r 2!mul0r 2!add0r big_ord_recl /= mul1r 2!mul0r 2!addr0 big_ord_recl /= mul1r 2!mul0r addr0 add0r.
      rewrite -f1 ![\sum_i f _]big_ord_recl big_ord0 addr0 -!addrA; congr (_ + (_ + _)).
      rewrite -[f (lift _ (lift _ _))]add0r; congr (_ + f _); last by apply val_inj.
      rewrite -{3}(mul0r (\sum_(i < (size l).+1) 0)) mulr_sumr.
      apply congr_big=>// [[i ilt]] _.
   have ->: (widen_ord (leqnSn (size l).+3) (lift ord0 (lift ord0 (Ordinal ilt))) == ord_max) = false.
         by apply /negP=>/eqP/(f_equal val)/=; rewrite /bump/= 2!add1n=>/eqP; rewrite 2!eqSS=>/eqP ile; move:ilt; rewrite -ile ltnn.
      by rewrite 3!mul0r 2!addr0.
   rewrite fp ![\sum_i f _ *: _]big_ord_recl big_ord0 addr0 -!addrA; congr (_ + (_ + _)).
   rewrite (nth_last _ (d :: l))/= -[f (lift _ (lift _ _)) *: _]add0r; congr (_ + f _ *: _); last by apply val_inj.
   rewrite -{1}(scale0r (\sum_(i < (size l).+1) 0)) scaler_sumr.
   apply congr_big=>// [[i ilt]] _.
   have ->: (widen_ord (leqnSn (size l).+3) (lift ord0 (lift ord0 (Ordinal ilt))) == ord_max) = false.
      by apply /negP=>/eqP/(f_equal val)/=; rewrite /bump/= 2!add1n=>/eqP; rewrite 2!eqSS=>/eqP ile; move:ilt; rewrite -ile ltnn.
   by rewrite 2!mul0r 2!addr0 2!scale0r.
case: IHl.
   - by move: lu=>/andP[_ lu].
   - by [].
   - move: ll=>/Spec.encompassll_subseq; apply=>//; apply subseq_cons.
   - apply/andP; split.
      2: by move: lp=>/andP[_ /andP [_ lp]].
   rewrite/= andbT; apply/or3P/Or33.
   by rewrite/oriented det_inverse 2!det_cyclique leNgt oppr_lt0; apply/negP=>/ltW; move: labp; rewrite /oriented=>->.
move=>f [f0 [f1 fp]].
exists (fun i=>
   match ord_S_split i with
   | inleft j => f (proj1_sig j)
   | inright _ => 0%:R
   end).
split.
   by move=>i; case: (ord_S_split i).
split; rewrite big_ord_recl; (case (ord_S_split ord0); [ by move=>[j H] | move=>_]); [| rewrite scale0r]; rewrite add0r.
   rewrite -f1; apply congr_big=>// [[i ilt]] _.
   case (ord_S_split _)=>// [[j jlt]] /=; congr (f _); apply val_inj=>/=.
   by move:jlt=>/(f_equal val)=>/=/eqP; rewrite /bump/= 2!add1n eqSS=>/eqP.
rewrite fp; apply congr_big=>// [[i ilt]] _.
case (ord_S_split _)=>// [[j jlt]] /=; congr (f _ *: _); apply val_inj=>/=.
by move:jlt=>/(f_equal val)=>/=/eqP; rewrite /bump/= 2!add1n eqSS=>/eqP.
Qed.

Lemma detD (p q r : Plane) : det 0 p (q+r) = det 0 p q + det 0 p r.
Proof. by rewrite 3!det_scalar_productE /scalar_product/=; ring. Qed.

Lemma det_sum (p : Plane) (n : nat) (f : 'I_n -> Plane) :
  det 0 p (\sum_(i < n) f i) = \sum_(i < n) det 0 p (f i).
Proof.
elim: n f.
   by move=>f; rewrite 2!big_ord0 -det_cyclique det_alternate.
move=>n IHn f.
by rewrite 2!big_ord_recl detD IHn.
Qed.

Lemma encompass_complete (l : seq Plane) (p : Plane) :
  uniq l ->
  (3 <= size l)%N ->
  encompass (ccw (R:=R)) l l ->
  (exists t : 'I_(size l) -> R,
    (forall i, 0 <= t i)%R /\
    (\sum_i t i = 1%:R) /\
    p = \sum_i t i *: l`_i) ->
  encompass oriented [:: p] l.
Proof.
move=>lu ls ll [f [f0 [f1 fp]]]; subst p.
rewrite encompass_all_index; apply/andP; split.
   by case: l lu ls ll f f0 f1.
apply/forallP=>[[i ilt]].
rewrite/= andbT is_left_oriented /oriented.
wlog: l lu ls ll f f0 f1 i ilt / l`_i == 0%R.
   move=>h.
   set l' := [seq x - l`_i | x <- l].
   have subl': forall a b, (a < size l) -> (b < size l) -> l'`_a - l'`_b = l`_a - l`_b.
      by move=>a b al bl; rewrite (nth_map (GRing.zero _))// (nth_map (GRing.zero _))// opprD [-_ - - _]addrC -!addrA; congr GRing.add; rewrite addrA subrr add0r.
   suff: (0%:R <= det l'`_i l'`_(Zp_succ (Ordinal ilt)) (\sum_(i0 < size l) f i0 *: l'`_i0))%R.
      congr (_ <= _)%R; rewrite 2!det_scalar_productE; congr (scalar_product _ (rotate _)).
      - by apply subl'=>//; case: (Zp_succ (Ordinal ilt)).
      - rewrite [l'`_i](nth_map (GRing.zero _))// subrr subr0 -[l`_i]scale1r.
      have->: (1 = 1%:R)%R by [].
      rewrite -f1 scaler_suml -sumrB; apply congr_big=>// [[j jlt]] _.
      by rewrite -scalerBr (nth_map (GRing.zero _)).
   move:h=>/(_ l'); rewrite size_map; apply.
      - rewrite map_inj_uniq=>//; apply addIr.
      - by [].
      - rewrite Spec.encompassll_spec.
         2: by rewrite map_inj_uniq=>//; apply addIr.
      apply/andP; split.
         by destruct l.
      rewrite size_map.
      apply/forallP=>[[a alt]].
      apply/forallP=>[[b blt]].
      apply/forallP=>[[c clt]].
      apply/implyP=>abc.
      rewrite /ccw_KA.OT /ccw det_scalar_productE subl'// subl'//.
      by move:ll; rewrite Spec.encompassll_spec=>// /andP[_] /forallP /(_ (Ordinal alt)) /forallP /(_ (Ordinal blt)) /forallP /(_ (Ordinal clt)) /implyP /(_ abc); rewrite /ccw_KA.OT /ccw det_scalar_productE.
      - apply f0.
      - exact f1.
      - by rewrite (nth_map (GRing.zero _))// subrr.
move=>/eqP li0; rewrite li0 det_sum; apply sumr_ge0=>[[j jlt]] _.
rewrite det_scalar_productE 2!subr0 rotateZ scalar_productZR; apply mulr_ge0.
   apply f0.
move:ll; rewrite encompassE =>/andP[_ /allP ll].
have/ll: l`_(Ordinal jlt) \in l by rewrite mem_nth.
rewrite encompass_all_index=>/andP[_] /forallP /(_ (Ordinal ilt))/=; rewrite andbT.
rewrite li0// => /or3P[/eqP ->|/eqP ->|].
- by rewrite -{2}(scale0r 0) rotateZ scalar_productZR mul0r.
- by rewrite scalar_product_rotatexx.
- by rewrite /ccw det_scalar_productE 2!subr0=>/ltW.
Qed.

Lemma encompassP (l : seq Plane) (p : Plane) :
  uniq l ->
  (3 <= size l)%N ->
  encompass (ccw (R:=R)) l l ->
  reflect (p \in hull (fun x => x \in l)) (encompass oriented [:: p] l).
Proof.
move=>lu ls ll; apply/(iffP idP).
   move=>/(encompass_correct lu ls ll)[f [f0 [f1 ->]]].
   rewrite inE/hull/=; exists (size l), (fun i=> l`_i), f; split => //.
   by move =>// x/= [i] _ <-{x}; exact: (@mem_nth Plane).
rewrite inE/hull/= =>[[n [g [d [d0 d1 gl pe]]]]].
apply encompass_complete=>//.
exists (fun i=> \sum_(j < n | g j == l`_i) d j); split.
   by move=>i; apply sumr_ge0.
split.
   rewrite -(big_map (fun i: 'I_(size l) => l`_i) xpredT (fun x=> \sum_(j < n | g j == x) d j)).
   rewrite (map_comp (fun i : nat => l`_i) (@nat_of_ord (size l))).
   move:(val_enum_ord (size l)); rewrite enumT=>->.
   rewrite map_nth_iota0// take_size -big_partition//.
   by apply/allP=>i _; apply gl.
transitivity (\sum_(i < size l) \sum_(j < n | g j == l`_i) d j *: g j).
   rewrite -(big_map (fun i: 'I_(size l) => l`_i) xpredT (fun x=> \sum_(j < n | g j == x) d j *: g j)).
   rewrite (map_comp (fun i : nat => l`_i) (@nat_of_ord (size l))).
   move:(val_enum_ord (size l)); rewrite enumT=>->.
   rewrite map_nth_iota0// take_size -big_partition//.
   by apply/allP=>i _; apply gl.
apply congr_big=>//i _.
rewrite scaler_suml.
by apply congr_big=>//j/eqP->.
Qed.

End spec.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defoppositeside_1 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_2 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable axiom_betweennesssymmetry_3 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable postulate_Pasch_outer_4 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B C Q /\ ~(col_ B Q A))) -> (betS_ A X Q /\ betS_ B P X)))).
Variable defcollinear_5 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_6 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_7 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_8 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_9 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_10 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_11 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_inequalitysymmetric_12 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_13 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_collinearorder_14 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_betweennotequal_15 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).

Theorem lemma_9_5a_16 : (forall A B C P Q R : Universe, ((tS_ P A B C /\ (betS_ R P Q /\ (~(col_ R Q C) /\ col_ A B R))) -> tS_ Q A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Import Mid.Reduce.

Local Open Scope Z.
Section Integer.

Variable n:Z.
Hypothesis Hn: n > 0.

Notation "ℤ.lst A" := (ZofList n A) (at level 65, right associativity).

Fixpoint Carrying_n (p:nat) (a:Z) (l:list Z) : list Z := match p,a,l with
| _,  0,[]     => []
| _,  a,[]     => [a]
| 0%nat,  a,h::q   => (h + a) :: q
| S p,a,h :: q => getResidue n (h + a) :: Carrying_n p (getCarry n (h + a)) q
end.

Lemma Carry_n_step: forall m a h q, Carrying_n (S m) a (h :: q) = getResidue n (h + a) :: Carrying_n m (getCarry n (h + a)) q.
Proof. intros; simpl ; flatten. Qed.

Lemma Carry_n_step2: forall m a h q, Carrying_n (S m) a (h :: q) = getResidue n (a + h) :: Carrying_n m (getCarry n (a + h)) q.
Proof. intros; simpl ; replace (h + a) with (a + h) by omega ; flatten. Qed.

Lemma Carry_n_step_0 : forall h q a, Carrying_n 0 a (h :: q) = (h + a) :: q.
Proof. intros ; simpl; flatten. Qed.

Lemma Carry_n_step_02 : forall h q a, Carrying_n 0 a (h :: q) = (a + h) :: q.
Proof. intros ; simpl ; replace (h + a) with (a + h) by omega ; flatten. Qed.

Lemma Carrying_n_length: forall l (m:nat) a, (m < length l)%nat -> length (Carrying_n m a l) = length l.
Proof. induction l as [|h q IHl]; intros [] a Hm; simpl ; flatten ; go. Qed.

Lemma Carrying_n_Zlength: forall l (m:nat) a, m < length l -> Zlength (Carrying_n m a l) = Zlength l.
Proof. convert_length_to_Zlength Carrying_n_length. Qed.

Lemma CarrynPreserveConst : forall m l a , a + (ℤ.lst l)  = ℤ.lst Carrying_n m a l.
Proof.
  assert(Hn0: 2 ^ n * 0 = 0) by (symmetry ; apply Zmult_0_r_reverse).
  induction m ; intros l a.
  - simpl ; flatten ; try rewrite <- ZofList_add ; go.
  - simpl ; flatten ; go ;
    rewrite! ZofList_cons ;
    rewrite <- IHm ;
    rewrite <- Zplus_assoc_reverse ;
    rewrite <- Zred_factor4 ;
    rewrite <- Zplus_assoc_reverse ;
    rewrite residuteCarry ; go.
Qed.

Corollary CarrynPreserve : forall m l, ℤ.lst l = ℤ.lst Carrying_n m 0 l.
Proof.
  intros.
  simpl.
  rewrite -CarrynPreserveConst.
  omega.
Qed.

End Integer.

Theorem Zcarry_n_bounds_length:
  forall l,
    length l = 16%nat ->
    Forall (fun x => -2^62 < x < 2^62) l ->
    forall j, 0 <= j < 16 ->
    Forall (fun x => - 2^63 < x < 2^63) (Carrying_n 16 (Z.to_nat j) 0 l).
Proof.
  intros l H HForalll i Hi.
  apply (nth_Forall _ _ _ 0).
  intros j.
  assert(Hi': exists i', Z.to_nat i = i') by eauto.
  destruct Hi' as [i' Hi'].
    assert(Hi'': 0 <= i' < 16).
    subst ; rewrite Z2Nat.id ; omega.
  apply destruct_length_16 in H ; do 16 destruct H.
  rewrite Hi'.
  subst l.
  assert(Hi''': (i' = 0 \/ i' = 1 \/ i' = 2 \/ i' = 3 \/ i' = 4 \/ i' = 5 \/ i' = 6 \/ i' = 7 \/ i' = 8 \/ i' = 9 \/
       i' = 10 \/ i' = 11 \/ i' = 12 \/ i' = 13 \/ i' = 14 \/ i' = 15 \/ 15 < i')%nat) by omega.
  assert(H16 : 16 > 0) by reflexivity.
  assert(H216262: 2^16 < 2^63) by reflexivity.
  assert(H262263: 2^62 < 2^63) by reflexivity.
  assert(H263262: - 2^63 < - 2^62) by reflexivity.
  assert(H2630: - 2^63 < 0) by reflexivity.
  assert(i' = 0%nat ∨ i' = 1%nat ∨ i' = 2%nat ∨ i' = 3%nat ∨ i' = 4%nat ∨ i' = 5%nat ∨ i' = 6%nat ∨ i' = 7%nat ∨ i' = 8%nat ∨ i' = 9%nat ∨ i' = 10%nat ∨ i' = 11%nat ∨ i' = 12%nat ∨ i' = 13%nat ∨ i' = 14%nat ∨ i' = 15%nat) by omega.
  move: HForalll.
  rewrite ?Forall_cons => HForalll.
  repeat match goal with
    | [H : (_ /\ _) /\ _ |-_] => destruct H
  end.
  clear Hi Hi' i Hi''' H17.
  rename H into Hi'.
  assert(HH : forall k, 0 ≤ getResidue 16 k ∧ getResidue 16 k < 2 ^ 16) by (clear ; intro; eapply getResidue_bounds ; omega).
  repeat match goal with
    | _ => rewrite Carry_n_step
    | _ => rewrite Carry_n_step_0
    | [H : _ \/ _ |- _ ] => destruct H ; try subst i'
    | _ => unfold nth ; flatten ; try omega
  end;
  repeat match goal with
    | _ => omega
    | [ HH : context[getResidue] |- - 2 ^ 63 < getResidue 16 (?x) ∧ getResidue 16 (?x) < 2 ^ 63 ] => specialize HH with x
    | [ |- context[2 ^ 63] ] => change (-2^63) with ((-2^62) + (-2^62)); change (2^63) with ((2^62) + (2^62))
    | [ |- _ < _ ∧ _ < _ ] => apply Add_interval_mono
    | [ |- -2^62 < getCarry _ _ ∧ _ < _ ] => apply getCarry_bound_str63
  end.
Qed.
(* THIS QED IS REALLY SLOW... could be improved by reflection ... *)

Lemma Carry_n_length_False: forall (h:Z) (q:list Z), Carrying_n 16 15 0 (h :: q) = [] -> False.
Proof. intros ; rewrite Carry_n_step in H ; false. Qed.

Local Close Scope Z.

Lemma Carrying_n_1_nat : forall i o z m,
  nth (S i) (Carrying_n m i z o) 0 = nth (S i) o 0.
Proof.
  induction i as [|i iHi]; intros [| h q ] z m; simpl; flatten ; try reflexivity.
  all: simpl ; apply iHi; simpl in H ; omega.
Qed.

Local Open Scope Z.
Lemma Carrying_n_1 : forall i o z m,
  0 <= i ->
  nth (Z.to_nat (i + 1)) (Carrying_n m (Z.to_nat i) z o) 0 = nth (Z.to_nat (i + 1)) o 0.
Proof.
  intros.
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)).
  apply Carrying_n_1_nat.
  rewrite Z2Nat.inj_add ; try omega.
  change (Z.to_nat 1) with 1%nat.
  omega.
Qed.

Local Close Scope Z.