Require Import Coq.Lists.List Setoid Coq.Lists.SetoidList Omega.
Require Export Coq.Classes.EquivDec FinTypes.

Set Implicit Arguments.

Fixpoint take n X (L:list X) :=
  match n, L with
    | S n, x::L => x::take n L
    | _, _ => nil
  end.

Lemma take_nil (X:Type) n
  : @take n X nil = nil.
Proof.
  destruct n; eauto.
Qed.

Lemma take_length_le X (L:list X) n
  : n <= length L -> length (take n L) = n.
Proof.
  intros. revert dependent n;induction L;intros; destruct n; simpl in *; try omega; eauto.
  rewrite IHL; eauto; omega.
Qed.

Lemma take_length_ge X (L:list X) n
  : n >= length L -> length (take n L) = length L.
Proof.
  intros. revert dependent n; induction L;intros; destruct n; simpl in *; try omega; eauto.
  rewrite IHL; eauto; omega.
Qed.

Lemma take_length X (L:list X) n
  : length (take n L) = min (length L) n.
Proof.
  decide (n < length L).
  - rewrite take_length_le; try omega.
    rewrite min_r; omega.
  - eapply not_lt in n0.
    rewrite min_l; try omega.
    eapply take_length_ge; eauto.
Qed.

 Lemma map_take X Y (f:X -> Y) (L:list X) n
  : map f (take n L) = take n (map f L).
Proof.
  revert dependent L; induction n;intros; simpl; eauto.
  destruct L; simpl ; eauto.
  f_equal; eauto.
Qed.

Lemma take_app_le n X (L L':list X)
  : n <= length L
    -> take n (L ++ L') = take n L.
Proof.
  intros. revert dependent L; induction n; intros ; simpl; eauto.
  destruct L; [cbn in H; omega| ] ; simpl.
  rewrite IHn; eauto. simpl in *; omega.
Qed.

Lemma take_app_ge n X (L L':list X)
  : n >= length L
    -> take n (L ++ L') = L ++ take (n - length L) L'.
Proof.
  intros. revert dependent L; induction n;intros; simpl; eauto.
  - destruct L; simpl in *; eauto. exfalso; omega.
  - destruct L; simpl in *; eauto.
    rewrite IHn; eauto. omega.
Qed.

Lemma take_eq_ge n X (L:list X)
  : n >= |L| -> take n L = L.
Proof.
  intros. revert dependent L; induction n;intros; destruct L; simpl in *; eauto.
  - exfalso; omega.
  - rewrite IHn; eauto. omega.
Qed.

Lemma take_app_eq n X (L L':list X)
  : n = length L
    -> take n (L ++ L') = L.
Proof.
  intros. subst. revert dependent L'; induction L;intros; simpl; eauto.
  f_equal; eauto.
Qed.

Lemma take_take_lt X (L:list X) n m
  : n < m
    -> take n L = take n (take m L).
Proof.
  intros. revert dependent L; revert dependent m;  induction n;intros; destruct L, m; simpl; eauto.
  - omega.
  - erewrite IHn; eauto. omega.
Qed.

Lemma take_one X (L:list X) x k
  : k > 0
    -> take k (x::L) = x :: take (k - 1) L.
Proof.
  intros; destruct k; simpl.
  - omega.
  - f_equal. f_equal. omega.
Qed.


(** * Maps: Total and Partial Maps *)

(** This file is almost identical to the [Maps] chapter of Software
    Foundations volume 1 (Logical Foundations), except that it implements
    functions from [nat] to [A] rather than functions from [id] to [A].

    Maps (or dictionaries) are ubiquitous data structures, both in
    software construction generally and in the theory of programming
    languages in particular; we're going to need them in many places
    in the coming chapters.  They also make a nice case study using
    ideas we've seen in previous chapters, including building data
    structures out of higher-order functions (from [Basics] and
    [Poly]) and the use of reflection to streamline proofs (from
    [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we start.

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems
    involving objects of specific types. *)

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about their behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := nat -> A.

(** Intuitively, a total map over an element type [A] _is_ just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : nat) (v : A) :=
  fun x' => if beq_nat x x' then v else m x'.

(** This definition is a nice example of higher-order programming.
    The [t_update] function takes a _function_ [m] and yields a new
    function [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) 1 false) 3 true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

Example update_example1 : examplemap 0 = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap 1 = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap 2 = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap 3 = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave.  Even if you don't work the following
    exercises, make sure you thoroughly understand the statements of
    the lemmas!  (Some of the proofs require the functional
    extensionality axiom, which is discussed in the [Logic]
    chapter and included in the Coq standard library.) *)

(** **** Exercise: 1 star, optional (t_apply_empty)  *)
(** First, the empty map returns its default element for all keys: *)
Lemma t_apply_empty:  forall A x v, @t_empty A v x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(** **** Exercise: 2 stars (beq_idP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_nat x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** Using the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : nat) (v : A) :=
  t_update m x (Some v).

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma apply_empty : forall A x, @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(** $Date: 2017-08-22 17:13:32 -0400 (Tue, 22 Aug 2017) $ *)


From Coq Require Import NArith ZArith Lia.

From Vyper Require Import Logic2.

(**************************************************************************)

Lemma N_ltb_lt_quad (a b c d: N):
  ((a <? b)%N = (c <? d)%N) <-> ((a < b)%N <-> (c < d)%N).
Proof.
apply relation_quad; apply N.ltb_lt.
Qed.

Lemma Z_ltb_lt_quad (a b c d: Z):
  ((a <? b)%Z = (c <? d)%Z) <-> ((a < b)%Z <-> (c < d)%Z).
Proof.
apply relation_quad; apply Z.ltb_lt.
Qed.

Lemma N_leb_le_quad (a b c d: N):
  ((a <=? b)%N = (c <=? d)%N) <-> ((a <= b)%N <-> (c <= d)%N).
Proof.
apply relation_quad; apply N.leb_le.
Qed.

Lemma Z_leb_le_quad (a b c d: Z):
  ((a <=? b)%Z = (c <=? d)%Z) <-> ((a <= b)%Z <-> (c <= d)%Z).
Proof.
apply relation_quad; apply Z.leb_le.
Qed.

Lemma N2Z_ltb (n m: N):
  (n <? m)%N = (Z.of_N n <? Z.of_N m)%Z.
Proof.
apply (relation_quad N.ltb_lt Z.ltb_lt).
apply N2Z.inj_lt.
Qed.

Lemma N2Z_leb (n m: N):
  (n <=? m)%N = (Z.of_N n <=? Z.of_N m)%Z.
Proof.
apply (relation_quad N.leb_le Z.leb_le).
apply N2Z.inj_le.
Qed.

(**************************************************************************)

Lemma Z_shiftr_pow2 (n: Z) (B: (0 <= n)%Z):
  Z.shiftr (2 ^ n) n = 1%Z.
Proof.
rewrite (Z.shiftr_div_pow2 _ _ B).
apply Z.div_same.
now apply Z.pow_nonzero.
Qed.

Lemma Z_ltb_irrefl (n: Z):
  (n <? n)%Z = false.
Proof.
remember (n <? n)%Z as L.
destruct L; trivial.
symmetry in HeqL.
rewrite Z.ltb_lt in HeqL.
apply Z.lt_irrefl in HeqL.
contradiction.
Qed.

Lemma N_ltb_irrefl (n: N):
  (n <? n)%N = false.
Proof.
remember (n <? n)%N as L.
destruct L; trivial.
symmetry in HeqL.
rewrite N.ltb_lt in HeqL.
apply N.lt_irrefl in HeqL.
contradiction.
Qed.

(**************************************************************************)

Lemma Z_land_pow2_shift (n m: Z) (BM: (0 <= m)%Z):
  Z.land n (2 ^ m) = Z.shiftl (Z.land (Z.shiftr n m) 1) m.
Proof.
rewrite<- (Z_shiftr_pow2 m BM).
rewrite<- Z.shiftr_land.
rewrite<- (Z.ldiff_ones_r _ _ BM).
rewrite Z.ldiff_land.
rewrite<- Z.land_assoc.
f_equal.
apply Z.bits_inj'. intros k Bk.
rewrite Z.land_spec.
rewrite (Z.lnot_spec _ _ Bk).
rewrite (Z.testbit_ones _ _ BM).
rewrite (Z.pow2_bits_eqb _ _ BM).
rewrite<- Z.leb_le in Bk.
rewrite Bk.
rewrite Bool.andb_true_l.
remember (m =? k)%Z as MK. symmetry in HeqMK.
destruct MK.
{
  rewrite Z.eqb_eq in HeqMK. subst.
  now rewrite Z_ltb_irrefl.
}
trivial.
Qed.

Lemma Z_mul_pos_iff_l (n m: Z) (BM: (0 < m)%Z):
  (0 < n)%Z <-> (0 < n * m)%Z.
Proof.
split. { intro. apply Z.mul_pos_pos; assumption. }
apply (Z.mul_pos_cancel_r _ _ BM).
Qed.

Lemma Z_mul_pos_iff_r (n m: Z) (BN: (0 < n)%Z):
  (0 < m)%Z <-> (0 < n * m)%Z.
Proof.
split. { apply (Z.mul_pos_pos _ _ BN). }
apply (Z.mul_pos_cancel_l _ _ BN).
Qed.

Lemma Z_shiftl_pos_iff (n m: Z) (BM: (0 <= m)%Z):
 (0 < n)%Z <-> (0 < Z.shiftl n m)%Z.
Proof.
rewrite (Z.shiftl_mul_pow2 _ _ BM).
apply Z_mul_pos_iff_l.
apply Z.pow_pos_nonneg.
{ rewrite<- Z.ltb_lt. trivial. }
assumption.
Qed.

Lemma Z_odd_land_1 (n: Z) (B: (0 <= n)%Z):
  Z.odd n = (0 <? Z.land n 1)%Z.
Proof.
destruct n; now try destruct p.
Qed.

Lemma Z_testbit_alt (n m: Z) (BN: (0 <= n)%Z) (BM: (0 <= m)%Z):
  Z.testbit n m = (0 <? Z.land n (2 ^ m))%Z.
Proof.
rewrite (Z_land_pow2_shift _ _ BM).
assert (Q: forall x, ((0 <? Z.shiftl x m) = (0 <? x))%Z).
{
  intro x.
  rewrite Z_ltb_lt_quad.
  symmetry.
  apply Z_shiftl_pos_iff.
  assumption.
}
rewrite Q. clear Q.
rewrite Z.testbit_odd.
apply Z_odd_land_1.
apply Z.shiftr_nonneg.
assumption.
Qed.

Lemma Z_testbit_high (a n: Z)
                      (B: (0 <= n)%Z)
                      (A: (0 <= a < 2 ^ n)%Z):
  Z.testbit a n = false.
Proof.
rewrite<- (Z.mod_small a (2 ^ n)%Z A).
apply Z.mod_pow2_bits_high.
split. { assumption. }
apply Z.le_refl.
Qed.

(**************************************************************************)

Lemma Z_to_N_land (x y: Z) (BX: (0 <= x)%Z) (BY: (0 <= y)%Z):
  Z.to_N (Z.land x y) = N.land (Z.to_N x) (Z.to_N y).
Proof.
apply N.bits_inj. intro n.
rewrite N.land_spec.
remember (Z.of_N n) as m.
assert (NM: n = Z.to_N m).
{ subst m. symmetry. apply N2Z.id. }
repeat rewrite NM.
assert (BM: (0 <= m)%Z).
{ subst. apply N2Z.is_nonneg. }
repeat rewrite<- Z2N.inj_testbit; try assumption.
repeat rewrite Z2N.id; try assumption.
{ apply Z.land_spec. }
rewrite Z.land_nonneg. tauto.
Qed.

Lemma N_to_Z_land (x y: N):
  Z.of_N (N.land x y) = Z.land (Z.of_N x) (Z.of_N y).
Proof.
rewrite<- (Z2N.id (Z.land (Z.of_N x) (Z.of_N y))).
{
  f_equal.
  rewrite Z_to_N_land; try apply N2Z.is_nonneg.
  repeat rewrite N2Z.id.
  trivial.
}
apply Z.land_nonneg. left. apply N2Z.is_nonneg.
Qed.

Lemma Z_to_N_lor (x y: Z) (BX: (0 <= x)%Z) (BY: (0 <= y)%Z):
  Z.to_N (Z.lor x y) = N.lor (Z.to_N x) (Z.to_N y).
Proof.
apply N.bits_inj. intro n.
rewrite N.lor_spec.
remember (Z.of_N n) as m.
assert (NM: n = Z.to_N m).
{ subst m. symmetry. apply N2Z.id. }
repeat rewrite NM.
assert (BM: (0 <= m)%Z).
{ subst. apply N2Z.is_nonneg. }
repeat rewrite<- Z2N.inj_testbit; try assumption.
repeat rewrite Z2N.id; try assumption.
{ apply Z.lor_spec. }
rewrite Z.lor_nonneg. tauto.
Qed.

Lemma N_to_Z_lor (x y: N):
  Z.of_N (N.lor x y) = Z.lor (Z.of_N x) (Z.of_N y).
Proof.
rewrite<- (Z2N.id (Z.lor (Z.of_N x) (Z.of_N y))).
{
  f_equal.
  rewrite Z_to_N_lor; try apply N2Z.is_nonneg.
  repeat rewrite N2Z.id.
  trivial.
}
apply Z.lor_nonneg. split; apply N2Z.is_nonneg.
Qed.

Lemma Z_to_N_lxor (x y: Z) (BX: (0 <= x)%Z) (BY: (0 <= y)%Z):
  Z.to_N (Z.lxor x y) = N.lxor (Z.to_N x) (Z.to_N y).
Proof.
apply N.bits_inj. intro n.
rewrite N.lxor_spec.
remember (Z.of_N n) as m.
assert (NM: n = Z.to_N m).
{ subst m. symmetry. apply N2Z.id. }
repeat rewrite NM.
assert (BM: (0 <= m)%Z).
{ subst. apply N2Z.is_nonneg. }
repeat rewrite<- Z2N.inj_testbit; try assumption.
repeat rewrite Z2N.id; try assumption.
{ apply Z.lxor_spec. }
rewrite Z.lxor_nonneg. tauto.
Qed.

Lemma N_to_Z_lxor (x y: N):
  Z.of_N (N.lxor x y) = Z.lxor (Z.of_N x) (Z.of_N y).
Proof.
rewrite<- (Z2N.id (Z.lxor (Z.of_N x) (Z.of_N y))).
{
  f_equal.
  rewrite Z_to_N_lxor; try apply N2Z.is_nonneg.
  repeat rewrite N2Z.id.
  trivial.
}
apply Z.lxor_nonneg. split; intro; apply N2Z.is_nonneg.
Qed.

(**************************************************************************)

Lemma N_testbit_alt (n m: N):
  N.testbit n m = (0 <? N.land n (2 ^ m))%N.
Proof.
rewrite<- Z.testbit_of_N.
replace (0 <? N.land n (2 ^ m))%N with (0 <? Z.land (Z.of_N n) (2 ^ (Z.of_N m)))%Z.
2:{
  rewrite N2Z_ltb.
  rewrite N_to_Z_land.
  cbn.
  repeat f_equal.
  rewrite N2Z.inj_pow.
  trivial.
}
apply Z_testbit_alt; apply N2Z.is_nonneg.
Qed.

(**************************************************************************)

Definition N_0_lt_pow2 (n: N):
  (0 < 2 ^ n)%N.
Proof.
case (N.eq_0_gt_0_cases (2 ^ n)); intro; try assumption.
apply N.pow_nonzero in H. { contradiction. }
discriminate.
Qed.

Definition Z_0_lt_pow2 (n: Z) (B: (0 <= n)%Z):
  (0 < 2 ^ n)%Z.
Proof.
assert (A := N_0_lt_pow2 (Z.to_N n)).
apply N2Z.inj_lt in A.
rewrite N2Z.inj_pow in A.
cbn in A.
now rewrite Z2N.id in A.
Qed.

Lemma N_ne_0_gt_0 (n: N):
  n <> 0%N <-> (0 < n)%N.
Proof.
split; intro H.
{ assert (CN := N.eq_0_gt_0_cases n). tauto. }
destruct n. { now apply N.lt_irrefl in H. }
discriminate.
Qed.

Lemma N_div_0_r (n: N):
  (n / 0 = 0)%N.
Proof.
now destruct n.
Qed.

Lemma Z_div_0_r (n: Z):
  (n / 0 = 0)%Z.
Proof.
now destruct n.
Qed.

Lemma N_div_le (n: N) (d: N):
  (n / d <= n)%N.
Proof.
assert (CN := N.eq_0_gt_0_cases n).
assert (CD := N.eq_0_gt_0_cases d).
case CN; intro. { subst. cbn. apply N.le_refl. }
case CD; intro. { subst. rewrite N_div_0_r. now apply N.lt_le_incl. }
assert (D: N.succ (N.pred d) = d).
{ apply N.succ_pred_pos. assumption. }
remember (N.pred d) as k. clear Heqk. subst.
assert (CK := N.eq_0_gt_0_cases k).
case CK; intro. { subst. cbn. now rewrite N.div_1_r. }
apply N.lt_le_incl.
apply N.div_lt. { assumption. }
now apply N.lt_pred_lt_succ.
Qed.

Lemma Z_div_nonneg (a b: Z)
                    (A: (0 <= a)%Z)
                    (B: (0 <= b)%Z):
  (0 <= a / b)%Z.
Proof.
destruct b. { rewrite Zdiv_0_r. apply Z.le_refl. }
{ apply Z.div_pos; easy. }
easy.
Qed.

Lemma Z_abs_div_le (a b: Z):
  (Z.abs a / Z.abs b <= Z.abs a)%Z.
Proof.
assert(A := Z.abs_nonneg a).
assert(B := Z.abs_nonneg b).
apply Z2N.inj_le. { now apply Z_div_nonneg. }
{ assumption. }
rewrite Z2N.inj_div; try assumption.
apply N_div_le.
Qed.

Lemma Z_abs_sgn (a b: Z):
  Z.abs (Z.sgn a * b)%Z = match a with
                          | 0%Z => 0%Z
                          | _ => Z.abs b
                          end.
Proof.
now destruct a, b.
Qed.

Lemma Z_sgn_abs (a: Z):
  (Z.sgn a * Z.abs a)%Z = a.
Proof.
now destruct a.
Qed.

Lemma Z_add_nocarry_lor (a b: Z) (H: Z.land a b = 0%Z):
  (a + b = Z.lor a b)%Z.
Proof.
rewrite Z.add_nocarry_lxor by assumption.
apply Z.lxor_lor. assumption.
Qed.

Lemma Z_land_pow2_small (a b: Z) (A: (0 <= a < 2 ^ b)%Z) (B: (0 <= b)%Z):
  Z.land a (2 ^ b) = 0%Z.
Proof.
rewrite Arith2.Z_land_pow2_shift by tauto.
replace (Z.shiftr a b) with 0%Z. { cbn. apply Z.shiftl_0_l. }
rewrite Z.shiftr_div_pow2 by tauto.
symmetry. apply Z.div_small. exact A.
Qed.

Lemma Z_testbit_flag_mul_pow2 (f: bool) (k: Z) (K: (0 <= k)%Z):
  Z.testbit ((if f then 1 else 0) * 2 ^ k) k = f.
Proof.
destruct f.
{ rewrite Z.mul_1_l. apply Z.pow2_bits_true. assumption. }
rewrite Z.mul_0_l. apply Z.bits_0.
Qed.

(* A version of Z.bits_above_log2 with a different bound. *)
Lemma Z_testbit_small (a n: Z) (A: (0 <= a)%Z)
                               (B: (a < 2 ^ n)%Z):
  Z.testbit a n = false.
Proof.
destruct a. { apply Z.testbit_0_l. }
{ apply Z.bits_above_log2. trivial. now apply Z.log2_lt_pow2. }
exfalso. rewrite<- Z.leb_le in A. cbn in A. discriminate.
Qed.

(**************************************************************************)

Lemma Z_pos_ne_0 (a: positive):
  Z.pos a <> 0%Z.
Proof.
discriminate.
Qed.

Lemma Z_0_lt_pos (a: positive):
  (0 < Z.pos a)%Z.
Proof.
rewrite<- Z.ltb_lt.
trivial.
Qed.

Lemma Z_ceiling_via_floor (a b: Z) (B: (0 <= b)%Z):
  (- ((- a) / b) = (a + b - 1) / b)%Z.
Proof.
destruct b as [|b|b]. { now repeat rewrite Z_div_0_r. }
{
  assert (D := Z.div_mod (-a) (Z.pos b) (Z_pos_ne_0 b)).
  assert (E := Z.div_mod (a + Z.pos b - 1) (Z.pos b) (Z_pos_ne_0 b)).
  assert (P := Z.mod_pos_bound (-a) (Z.pos b) (Z_0_lt_pos b)).
  assert (Q := Z.mod_pos_bound (a + Z.pos b - 1) (Z.pos b) (Z_0_lt_pos b)).
  nia.
}
rewrite<- Z.leb_le in B. discriminate.
Qed.

(**************************************************************************)

Lemma Z_land_lxor_distr_l (a b c: Z):
  Z.land (Z.lxor a b) c = Z.lxor (Z.land a c) (Z.land b c).
Proof.
apply Z.bits_inj. intro.
repeat (rewrite Z.land_spec || rewrite Z.lxor_spec).
destruct (Z.testbit a n); destruct (Z.testbit b n); destruct (Z.testbit c n); easy.
Qed.

Lemma Z_land_lxor_distr_r (a b c: Z):
  Z.land a (Z.lxor b c) = Z.lxor (Z.land a b) (Z.land a c).
Proof.
apply Z.bits_inj. intro.
repeat (rewrite Z.land_spec || rewrite Z.lxor_spec).
destruct (Z.testbit a n); destruct (Z.testbit b n); destruct (Z.testbit c n); easy.
Qed.

(**************************************************************************)

(* This is a version of Z.log2_lt_pow2 but a can be 0 and b cannot. *)
Lemma Z_log2_lt_pow2 (a b: Z) (BA: (0 <= a)%Z) (BB: (0 < b)%Z):
    (a < 2 ^ b <-> Z.log2 a < b)%Z.
Proof.
destruct a.
{
  cbn. assert (P: (0 < 2 ^ b)%Z). apply Z_0_lt_pow2. { apply Z.lt_le_incl. assumption. }
  tauto.
}
{ apply Z.log2_lt_pow2. rewrite<- Z.ltb_lt. trivial. }
rewrite<- Z.leb_le in BA. discriminate.
Qed.

(**************************************************************************)

Lemma Z_mod_add_l (a b c m: Z)
                  (H: (b mod m = c mod m)%Z):
  ((a + b) mod m = (a + c) mod m)%Z.
Proof.
rewrite<- (Zplus_mod_idemp_r b a).
rewrite<- (Zplus_mod_idemp_r c a).
rewrite H.
trivial.
Qed.

Lemma Z_mod_add_r (a b c m: Z)
                  (H: (a mod m = b mod m)%Z):
  ((a + c) mod m = (b + c) mod m)%Z.
Proof.
rewrite<- (Zplus_mod_idemp_l a c).
rewrite<- (Zplus_mod_idemp_l b c).
rewrite H.
trivial.
Qed.

(**************************************************************************)

Lemma Nat2N_inj_div (a b: nat):
  N.of_nat (a / b) = (N.of_nat a / N.of_nat b)%N.
Proof.
destruct b. { cbn. now rewrite N_div_0_r. }
assert (BNZ: S b <> 0) by discriminate.
assert (D := Nat.div_mod a (S b) BNZ).
remember (a / S b) as q.
remember (a mod S b) as r.
apply N.div_unique with (r := N.of_nat r).
{
  unfold N.lt.
  rewrite<- Nat2N.inj_compare.
  apply Nat.compare_lt_iff.
  subst. apply (Nat.mod_upper_bound _ _ BNZ).
}
rewrite<- Nat2N.inj_mul.
rewrite<- Nat2N.inj_add.
now rewrite D.
Qed.

Lemma Nat2N_inj_mod (a b: nat) (ok: b <> 0):
  N.of_nat (a mod b) = (N.of_nat a mod N.of_nat b)%N.
Proof.
destruct b. { contradiction. }
rewrite Nat.mod_eq by discriminate.
rewrite Nat2N.inj_sub.
rewrite Nat2N.inj_mul.
rewrite Nat2N_inj_div.
symmetry. apply N.mod_eq.
discriminate.
Qed.

(**************************************************************************)
(** This is a strenghtening of Pos.size_nat_monotone from [p < q] to [p <= q]. *)
Lemma Pos_size_nat_monotone (p q: positive) (LE: (p <= q)%positive):
  (Pos.size_nat p <= Pos.size_nat q)%nat.
Proof.
remember (Pos.compare p q) as cmp. symmetry in Heqcmp. destruct cmp.
{ apply Pos.compare_eq in Heqcmp. subst. apply Nat.le_refl. }
{ apply Pos.size_nat_monotone. exact Heqcmp. }
contradiction.
Qed.


Require Import NaturalNumbers.
Require Export ssreflect.

Theorem Plus_unit_l :
    forall n, Plus Z n n.
Proof. autoP. Qed.

    Theorem Plus_unit_r n : Plus n Z n.
Proof.
    elim n => [|m IHm]; autoP.
Qed.

Theorem Plus_uniq :
    forall x y z1 z2, Plus x y z1 -> Plus x y z2 -> z1 = z2.
Proof.
    elim => [y z1 z2 H1 H2|x0 IH y z1 z2 H1 H2].
    + (* x == Z *)
      inversion H1.
      inversion H2.
      subst n n0 y => //.
    + (* x ==  (S x0)*)
      inversion H1.
      inversion H2.
      specialize (IH y l l0 H0 H6).
      rewrite IH => //.
Qed.

Theorem Plus_close :
    forall x y, exists z, Plus x y z.
Proof.
    move => x y.
    elim x => [|x0 IHx].

    + (* x == Z *)
      exists y; apply Plus_unit_l.

    + (* x == (S x0) *)
      induction IHx as [z H].
      exists (S z).
      apply P_Succ => //.
Qed.

Theorem P_Succ_r :
    forall x y z, Plus x y z -> Plus x (S y) (S z).
Proof.
    elim.

    + (* x == Z *)
      move => y z H.
      inversion H.
      apply Plus_unit_l.

    + (* x == (S x0) *)
      move => x0 IH y z H.
      inversion H.
      apply P_Succ.
      apply (IH y l) =>//.
Qed.

Theorem Plus_comm :
    forall x y z, Plus x y z -> Plus y x z.
Proof.
    elim => [|n IHn].

    + (* x == Z *)
      move => y z H.
      inversion H.
      apply Plus_unit_r.

    + (* x == (S n) *)
      move => y z H.
      inversion H.
      apply P_Succ_r.
      apply IHn => //.
Qed.

Theorem Plus_assoc :
    forall x y z xy xyz,
    Plus x y xy -> Plus xy z xyz ->
    exists yz, Plus y z yz /\ Plus x yz xyz.
Proof.
    elim => [| x0 IHx].

    + (* x == Z *)
      move => y z xy xyz Hl Hr.
      inversion Hl.
      inversion Hr.

      - subst n n0 xy.
        exists xyz.
        split; apply Plus_unit_l.

      - subst n xy.
        exists (S l).
        split.
        apply P_Succ=> //.
        apply Plus_unit_l.

    + (* x == (S x0)*)
      move => y z xy xyz Hl Hr.
      inversion Hl; move => {Hl}.
      subst n m xy.
      inversion Hr => {Hr}.
      subst n m xyz.
      specialize (IHx y z l l0 H0 H1).
      inversion IHx as [yz [Hl Hr]].
      exists yz; split => //.
      apply P_Succ => //.
Qed.

Theorem Times_uniq :
    forall x y z z', Times x y z -> Times x y z' -> z = z'.
Proof.
    elim => [|x0 IHx].
    + move => y z z' H1 H2.
      inversion H1; inversion H2  => //.
    + move => y z z' H1 H2.
      inversion H1; inversion H2 => {H1 H2}.
      subst n m o n0 m0 o0.
      suff ll : l = l0.
      - subst l0.
        apply (Plus_uniq y l) => //.
      - apply (IHx y l l0) => //.
Qed.

Theorem Times_close :
    forall x y, exists z, Times x y z.
Proof.
    move => x y.
    elim  x=> [|x0 IHx].
    + exists Z; apply T_Zero.
    + inversion IHx as [z H]; move => {IHx}.
      induction (Plus_close y z) as [yz Hyz].
      exists yz.
      apply T_Succ with (l := z) => //.
Qed.

Theorem Times_zero_l :
    forall n, Times Z n Z.
Proof. autoP. Qed.

Theorem Times_zero_r :
    forall n, Times n Z Z.
Proof.
    elim => [|n0 IHn].
    + autoP.
    + apply T_Succ with (l := Z); autoP.
Qed.

Lemma T_Succ_r :
    forall n m l o,
    Times n m l -> Plus n l o -> Times n (S m) o.
Proof.
    move => n m.
    induction n,  m; move => l o H1 H2; inversion H1 => {H1}; inversion H2 => {H2}.
    + subst n l n0 o.
      apply T_Zero.
    + subst n l n0 o.
      apply T_Zero.
    + subst n0 m o0 n1 m0 o.
      apply T_Succ with (l := n).
      - apply IHn with (l := Z).
        apply Times_zero_r.
        apply Plus_unit_r.
      - apply P_Succ.
        inversion H3 => {H3}; subst n0 l0.
        suff nl : l1 = n.
        * subst l1.
          apply P_Zero.
        * suff lz : l = Z.
          subst l.
          apply (Plus_uniq n Z) => //.
          apply Plus_unit_r.
          apply (Times_uniq n Z) => //.
          apply Times_zero_r.
    + subst n0 m0 o0 n1 m1 o.
      inversion H3 => {H3}; subst n0 m0 l.
      specialize (Plus_close n l0); move => [z Hz].
      apply T_Succ with (l := z).
      - apply IHn with (l := l0) => //.
      - apply P_Succ.
        apply (Plus_comm n (S l2) l1) in H6.
        inversion H6 => {H6}; subst n0 m0 l1.
        specialize (Plus_assoc m l0 n l2 l H1 H2).
        move => [z_ [H3 H4]].
        apply P_Succ.
        suff zz : z = z_.
        * subst z_ => //.
        * apply (Plus_uniq n l0) => //.
          apply Plus_comm => //.
Qed.

Theorem Times_comm :
    forall x y z, Times x y z -> Times y x z.
Proof.
    elim => [| x0 IHx].
    + move => y z H; inversion H; subst n z.
      apply Times_zero_r.
    + move => y z H; inversion H; subst n m o.
      apply T_Succ_r with (l := l) => //.
      apply IHx => //.
Qed.

Theorem Times_eq_Z :
    forall x y, Times x y Z -> x = Z \/ y = Z.
Proof.
    move => x y.
    induction x, y => H.
    + left => //.
    + left => //.
    + right => //.
    + inversion H; subst n m o.
      inversion H2.
Qed.

Lemma dist_l :
    forall x y z yz xyxz , Times x yz xyxz -> Plus y z yz ->
    exists xy xz, Times x y xy /\ Times x z xz /\ Plus xy xz xyxz.
Proof.
    elim => [|x_ IHx] => y z yz xyxz HT HP.
    + inversion HT; subst n xyxz.
      exists Z, Z; autoP.
    + inversion HT; subst n m o.
      move : (IHx y z yz l H0 HP) => [xy_ [xz_ [Hxy_ [Hxz_ Hl]]]].
      move : (Plus_close y xy_) => [xy Hxy].
      move : (Plus_close z xz_) => [xz Hxz].
      exists xy, xz; split; [|split].
      - apply T_Succ with (l := xy_) => //.
      - apply T_Succ with (l := xz_) => //.
      - move : (Plus_assoc y z l yz xyxz HP H1) => [zl [Hzl Hyzl]].
        apply Plus_comm in Hzl.
        move  : (Plus_assoc xy_ xz_ z l zl Hl Hzl) => [xz' [Hxz' Hzl']].
        apply Plus_comm in Hxz; apply Plus_comm in Hxy.
        move : (Plus_uniq xz_ z xz xz' Hxz Hxz') => xzxz; subst xz'.
        apply Plus_comm in Hzl'.
        apply Plus_comm in Hyzl.
        move : (Plus_assoc xz xy_ y zl xyxz Hzl' Hyzl) => [xy' [Hxy' Hyz']].
        move : (Plus_uniq xy_ y xy xy' Hxy Hxy') => xyxy; subst xy'.
        apply Plus_comm => //.
Qed.

Lemma dist_r :
    forall x y z xy xzyz, Times xy z xzyz -> Plus x y xy ->
    exists xz yz, Times x z xz /\ Times y z yz /\ Plus xz yz xzyz.
Proof.
    move => x y z xy xzyz HT HP.
    apply Times_comm in HT.
    move : (dist_l z x y xy xzyz HT HP) => [xz [yz [Hxz [Hyz H]]]].
    exists xz, yz; split; [|split] => //; apply Times_comm => //.
Qed.

Theorem Times_assoc :
    forall x y z xy xyz,
    Times x y xy -> Times xy z xyz  ->
    exists yz, Times y z yz /\ Times x yz xyz.
Proof.
    move => x y; move : x.
    induction y => x z xy xyz H1 H2.
    + apply Times_comm in H1.
      inversion H1; subst n xy.
      inversion H2; subst n xyz.
      exists Z; split => //.
      apply Times_zero_r.
    + apply Times_comm in H1.
      inversion H1; subst n m o.
      move : (Times_close y z) => [yz_ Hyz_].
      move : (Plus_close z yz_) => [yz Hyz].
      exists yz; split.
      - apply T_Succ with (l := yz_) => //.
      - move : (dist_r x l z xy xyz H2 H3) => [xz [lz [Hzx [Hlz Hxyz]]]].
        move : (Times_close x yz) => [xyz' H].
        move :  (dist_l x z yz_ _ _ H Hyz) => [xz' [yz' [Hxz [Hxyz_ Hxyz']]]].
        move : (Times_uniq x z _ _ Hzx Hxz) => xzxz; subst xz'.
        apply Times_comm in H0.
        move : (IHy x z l lz H0 Hlz) => [yz'' [Hyz'' Hlz']].
        move : (Times_uniq y z _ _ Hyz_ Hyz'') => yzyz; subst yz''.
        suff : xyz = xyz'.
          move => -> //.
        apply (Plus_uniq xz lz) => //.
        suff  : lz = yz'.
          move => -> //.
        apply (Times_uniq x yz_) => //.
Qed.

(* Theorem 2.11 (CompareNat1) *)
Theorem LessThan1_Z_Sn :
    forall n : peano, LessThan1 Z (S n).
Proof.
    induction n as [| n' H'].

        (* Case : n = Z *)
        apply L1_Succ.

        (* Case : n = S n' *)
        apply (L1_Trans _ (S n') _ H').
        apply L1_Succ.
Qed.

(* Theorem 2.11 (CompareNat2) *)
Theorem LessThan2_Z_Sn :
    forall n : peano, LessThan2 Z (S n).
Proof.
    apply L2_Zero.
Qed.

(* Theorem 2.11 (CompareNat3) *)
Theorem LessThan3_Z_Sn :
    forall n : peano, LessThan3 Z (S n).
Proof.
    induction n as [| n' H].

        (* Case : n = Z *)
        apply L3_Succ.

        (* Case : n = S n' *)
        apply (L3_SuccR _ _ H).
Qed.

(* Theorem 2.12 (CompareNat1) *)
Theorem LessThan1_prev :
    forall n1 n2 : peano, LessThan1 (S n1) (S n2) -> LessThan1 n1 n2.
Proof.
Admitted.

(* Theorem 2.12 (CompareNat2) *)
Theorem LessThan2_prev :
    forall n1 n2 : peano, LessThan2 (S n1) (S n2) -> LessThan2 n1 n2.
Proof.
Admitted.

(* Theorem 2.12 (CompareNat3) *)
Theorem LessThan3_prev :
    forall n1 n2 : peano, LessThan3 (S n1) (S n2) -> LessThan3 n1 n2.
Proof.
Admitted.

(* Theorem 2.13 (CompareNat1) *)
Theorem LessThan1_trans :
    forall n1 n2 n3 : peano,
    LessThan1 n1 n2 -> LessThan1 n2 n3 -> LessThan1 n1 n3.
Proof.
    apply L1_Trans.
Qed.

(* Theorem 2.13 (CompareNat2) *)
Theorem LessThan2_trans :
    forall n1 n2 n3 : peano,
    LessThan2 n1 n2 -> LessThan2 n2 n3 -> LessThan2 n1 n3.
Proof.
Admitted.

(* Theorem 2.13 (CompareNat3) *)
Theorem LessThan3_trans :
    forall n1 n2 n3 : peano,
    LessThan3 n1 n2 -> LessThan3 n2 n3 -> LessThan3 n1 n3.
Proof.
Admitted.

(* Theorem 2.14 (1) (2) *)
Theorem LessThan_equiv_1_2 :
    forall n1 n2 : peano, LessThan1 n1 n2 <-> LessThan2 n1 n2.
Proof.
Admitted.

(* Theorem 2.14 (2) (3) *)
Theorem LessThan_equiv_2_3 :
    forall n1 n2 : peano, LessThan2 n1 n2 <-> LessThan3 n1 n2.
Proof.
Admitted.

(* Theorem 2.14 (1) (3) *)
Theorem LessThan_equiv_1_3 :
    forall n1 n2 : peano, LessThan1 n1 n2 <-> LessThan3 n1 n2.
Proof.
Admitted.

Theorem EvalTo_total :
    forall e, exists n, EvalTo e n.
Proof.
    move => e.
    (* inversion e as [n| x y | x y]. *)
    induction e as [n | x [x_ Hx] y [y_ Hy]| x [x_ Hx] y [y_ Hy]].
    +   exists n.
        apply E_Const.
    +   move : (Plus_close x_ y_) => [xy Hxy].
        exists xy.
        apply (E_Plus x y x_ y_ xy) => //.
    +   move : (Times_close x_ y_) => [xy Hxy].
        exists xy.
        apply (E_Times x y x_ y_ xy) => //.
Qed.

Theorem EvalTo_uniq :
    forall e x y, EvalTo e x -> EvalTo e y -> x = y.
Proof.
    elim => [|e_ He_|e_ He_].
    +   move => p x y H1 H2.
        inversion H1; inversion H2.
        subst n n0 p => //.
    +   move => e He x y H1 H2.
        inversion H1; inversion H2.
        subst e1 e2 n e0 e3 n4.
        suff H : n1 = n0 /\ n2 = n3.
        -   inversion H.
            subst n0 n3.
            apply (Plus_uniq n1 n2) => //.
        -   split.
            *   apply He_ => //.
            *   apply He => //.
    +   move => e He x y H1 H2.
        inversion H1; inversion H2.
        subst e1 e2 n e0 e3 n4.
        suff H : n1 = n0 /\ n2 = n3.
        -   inversion H.
            subst n0 n3.
            apply (Times_uniq n1 n2) => //.
        -   split.
            *   apply He_ => //.
            *   apply He => //.
Qed.

Theorem EPlus_comm :
    forall X Y xy, EvalTo (EPlus X Y) xy -> EvalTo (EPlus Y X) xy.
Proof.
    move => X Y xy H.
    inversion H.
    apply (E_Plus Y X n2 n1) => //.
    apply Plus_comm => //.
Qed.

Theorem EPlus_assoc :
    forall X Y Z xyz,
    EvalTo (EPlus (EPlus X Y) Z) xyz -> EvalTo (EPlus X (EPlus Y Z)) xyz.
Proof.
    move => X Y Z xyz H.
    inversion H.
    inversion H2.
    subst e1 e2 n e0 e3 n4.
    move : (Plus_close n3 n2) => [yz Hyz].
    apply (E_Plus _ _ n0 yz) => //.
    +   apply (E_Plus Y Z n3 n2) => //.
    +   move :  (Plus_assoc n0 n3 n2 n1 xyz H11 H5) => [yz_ [Hyz_ Hxyz]].
        suff : yz = yz_.
        -   move => -> //.
        -   apply (Plus_uniq n3 n2) => //.
Qed.

Theorem ETimes_comm :
    forall X Y n, EvalTo (ETimes X Y) n -> EvalTo (ETimes Y X) n.
Proof.
    move => X Y n H.
    inversion H.
    apply (E_Times Y X n2 n1) => //.
    apply Times_comm => //.
Qed.

Theorem ETimes_assoc :
    forall X Y Z xyz,
    EvalTo (ETimes (ETimes X Y) Z) xyz -> EvalTo (ETimes X (ETimes Y Z)) xyz.
Proof.
    move => X Y Z xyz H.
    inversion H.
    inversion H2.
    subst e1 e2 n e0 e3 n4.
    move : (Times_close n3 n2) => [yz Hyz].
    apply (E_Times _ _ n0 yz) => //.
    +   apply (E_Times Y Z n3 n2) => //.
    +   move :  (Times_assoc n0 n3 n2 n1 xyz H11 H5) => [yz_ [Hyz_ Hxyz]].
        suff : yz = yz_.
        -   move => -> //.
        -   apply (Times_uniq n3 n2) => //.
Qed.

Theorem ReduceTo_progress :
    forall e, (exists n, e = ENum n) \/ (exists e', ReduceTo e e').
Proof.
    move => e.
    induction e.
    +   left; exists p => //.
    +   move : IHe1 => [[x Hx]|[X HX]]; move : IHe2 => [[y Hy] | [Y HY]].
        -   subst e1 e2.
            move : (Plus_close x y) => [xy Hxy].
            right; exists (ENum xy).
            apply (R_Plus x y xy) => //.
        -   subst e1.
            right.
            exists (EPlus (ENum x) Y).
            apply R_PlusR => //.
        -   subst e2; right.
            exists (EPlus X (ENum y)).
            apply R_PlusL => //.
        -   right.
            exists (EPlus e1 Y).
            apply R_PlusR => //.
    +   move : IHe1 => [[x Hx]|[X HX]]; move : IHe2 => [[y Hy] | [Y HY]].
        -   subst e1 e2.
            move : (Times_close x y) => [xy Hxy].
            right; exists (ENum xy).
            apply (R_Times x y xy) => //.
        -   subst e1.
            right.
            exists (ETimes (ENum x) Y).
            apply R_TimesR => //.
        -   subst e2; right.
            exists (ETimes X (ENum y)).
            apply R_TimesL => //.
        -   right.
            exists (ETimes e1 Y).
            apply R_TimesR => //.
Qed.

Theorem DetReduceTo_uniq :
    forall X Y1 Y2, DetReduceTo X Y1 -> DetReduceTo X Y2 -> Y1 = Y2.
Proof.
    move => X; induction X => Y1 Y2 H1 H2.
    +   inversion H1.
    +   inversion H1; subst X1 X2 Y1; inversion H2.
        *   subst n0 m0 Y2.
            move : (Plus_uniq n m l l0 H4 H5) -> => //.
        *   subst e1 e2 Y2.
            inversion H5.
        *   subst n1 e2 Y2.
            inversion H5.
        *   subst e1 e2 Y2.
            inversion H4.
        *   subst e0 e3 Y2.
            suff : e1' = e1'0.
            -   move => -> //.
            -   apply IHX1 => //.
        *   subst e1 e2 Y2.
            inversion H4.
        *   subst n1 e2 Y2.
            inversion H4.
        *   subst e1 e0 Y2.
            inversion H5.
        *   subst n0 e0 Y2.
            move : (IHX2 e2' e2'0 H4 H5) -> => //.
    +   inversion H1; subst X1 X2 Y1; inversion H2.
        *   subst n0 m0 Y2.
            move : (Times_uniq n m l l0 H4 H5) -> => //.
        *   subst e1 e2 Y2.
            inversion H5.
        *   subst n1 e2 Y2.
            inversion H5.
        *   subst e1 e2 Y2.
            inversion H4.
        *   subst e0 e3 Y2.
            suff : e1' = e1'0.
            -   move => -> //.
            -   apply IHX1 => //.
        *   subst e1 e2 Y2.
            inversion H4.
        *   subst n1 e2 Y2.
            inversion H4.
        *   subst e1 e0 Y2.
            inversion H5.
        *   subst n0 e0 Y2.
            move : (IHX2 e2' e2'0 H4 H5) -> => //.
Qed.

Theorem DetReduceTo_ReduceTo :
    forall X Y, DetReduceTo X Y -> ReduceTo X Y.
Proof.
    elim.
    +   move => x Y H.
        inversion H.
    +   move => a IHa b IHb Y H.
        inversion H.
        *   subst a b Y.
            apply R_Plus => //.
        *   subst e1 e2 Y.
            apply R_PlusL.
            apply IHa => //.
        *   subst a b Y.
            apply R_PlusR.
            apply IHb => //.
    +   move => a IHa b IHb Y H.
        inversion H.
        *   subst a b Y.
            apply R_Times => //.
        *   subst e1 e2 Y.
            apply R_TimesL.
            apply IHa => //.
        *   subst a b Y.
            apply R_TimesR.
            apply IHb => //.
Qed.

Lemma MR_PlusR :
    forall X Y Y', MultiReduceTo Y Y' ->
    MultiReduceTo (EPlus X Y) (EPlus X Y').
Proof.
    move => X Y Y' H.
    elim H.
    +   move => e.
        apply MR_Zero.
    +   move => e e' He.
        apply MR_One.
        apply R_PlusR => //.
    +   move => x y z Hxy IHxy Hyz IHyz.
        apply (MR_Multi _ _ _ IHxy IHyz).
Qed.

Lemma MR_PlusL :
    forall X X' Y, MultiReduceTo X X' ->
    MultiReduceTo (EPlus X Y) (EPlus X' Y).
Proof.
    move => X Y Y' H.
    elim H.
    +   move => e.
        apply MR_Zero.
    +   move => e e' He.
        apply MR_One.
        apply R_PlusL => //.
    +   move => x y z Hxy IHxy Hyz IHyz.
        apply (MR_Multi _ _ _ IHxy IHyz).
Qed.

Lemma MR_TimesR :
    forall X Y Y', MultiReduceTo Y Y' ->
    MultiReduceTo (ETimes X Y) (ETimes X Y').
Proof.
    move => X Y Y' H.
    elim H.
    +   move => e.
        apply MR_Zero.
    +   move => e e' He.
        apply MR_One.
        apply R_TimesR => //.
    +   move => x y z Hxy IHxy Hyz IHyz.
        apply (MR_Multi _ _ _ IHxy IHyz).
Qed.

Lemma MR_TimesL :
    forall X X' Y, MultiReduceTo X X' ->
    MultiReduceTo (ETimes X Y) (ETimes X' Y).
Proof.
    move => X Y Y' H.
    elim H.
    +   move => e.
        apply MR_Zero.
    +   move => e e' He.
        apply MR_One.
        apply R_TimesL => //.
    +   move => x y z Hxy IHxy Hyz IHyz.
        apply (MR_Multi _ _ _ IHxy IHyz).
Qed.

Theorem ReduceTo_weak_normal :
    forall e, exists n, MultiReduceTo e (ENum n).
Proof.
    elim.
    +   move => x; exists x.
        apply MR_Zero.
    +   move => X [x Hx] Y [y Hy].
        move : (Plus_close x y) => [xy Hxy].
        exists xy.
        refine (MR_Multi _ (EPlus X (ENum y)) _ _ _).
        -   apply MR_PlusR => //.
        -   refine (MR_Multi _ (EPlus (ENum x) (ENum y)) _ _ _ ).
            *   apply MR_PlusL => //.
            *   apply MR_One.
                apply R_Plus => //.
    +   move => X [x Hx] Y [y Hy].
        move : (Times_close x y) => [xy Hxy].
        exists xy.
        refine (MR_Multi _ (ETimes X (ENum y)) _ _ _).
        -   apply MR_TimesR => //.
        -   refine (MR_Multi _ (ETimes (ENum x) (ENum y)) _ _ _ ).
            *   apply MR_TimesL => //.
            *   apply MR_One.
                apply R_Times => //.
Qed.

Theorem ReduceTo_confl :
   forall X Y1 Y2, ReduceTo X Y1 -> ReduceTo X Y2 ->
    exists Z, MultiReduceTo Y1 Z /\ MultiReduceTo Y2 Z.
Proof.
    elim.
    +   move => x Y1 Y2 H1.
        inversion H1.
    +   move => A HA B HB Y1 Y2 H1 H2.
        inversion H1; inversion H2.
        -   subst A B Y1 Y2.
            inversion H5; inversion H7.
            subst n0 m0.
            move : (Plus_uniq n m l l0 H4 H8) ->.
            exists (ENum l0); split; apply MR_Zero.
        -   subst A B Y1 Y2 e1 e2.
            inversion H8.
        -   subst A B e1 e2 Y1 Y2.
            inversion H8.
        -   subst A B e1 e2 Y1 Y2.
            inversion H4.
        -   subst A B e0 e3 Y1 Y2.
            move : (HA e1' e1'0 H4 H8) => [Z [HZ1 HZ2]].
            exists (EPlus Z e2); split; apply MR_PlusL => //.
        -   subst A B e0 e3 Y1 Y2.
            exists (EPlus e1' e2'); split.
            *   apply MR_PlusR; apply MR_One => //.
            *   apply MR_PlusL; apply MR_One => //.
        -   subst A B e1 e2 Y1 Y2.
            inversion H4.
        -   subst A B e0 e3 Y1 Y2.
            exists (EPlus e1' e2'); split.
            *   apply MR_PlusL; apply MR_One => //.
            *   apply MR_PlusR; apply MR_One => //.
        -   subst A B e0 e3 Y1 Y2.
            move : (HB e2' e2'0 H4 H8) => [z [Hz1 Hz2]].
            exists (EPlus e1 z); split; apply MR_PlusR => //.
    +   move => A HA B HB Y1 Y2 H1 H2.
        inversion H1; inversion H2.
        -   subst A B Y1 Y2.
            inversion H5; inversion H7.
            subst n0 m0.
            move : (Times_uniq n m l l0 H4 H8) ->.
            exists (ENum l0); split; apply MR_Zero.
        -   subst A B Y1 Y2 e1 e2.
            inversion H8.
        -   subst A B e1 e2 Y1 Y2.
            inversion H8.
        -   subst A B e1 e2 Y1 Y2.
            inversion H4.
        -   subst A B e0 e3 Y1 Y2.
            move : (HA e1' e1'0 H4 H8) => [Z [HZ1 HZ2]].
            exists (ETimes Z e2); split; apply MR_TimesL => //.
        -   subst A B e0 e3 Y1 Y2.
            exists (ETimes e1' e2'); split.
            *   apply MR_TimesR; apply MR_One => //.
            *   apply MR_TimesL; apply MR_One => //.
        -   subst A B e1 e2 Y1 Y2.
            inversion H4.
        -   subst A B e0 e3 Y1 Y2.
            exists (ETimes e1' e2'); split.
            *   apply MR_TimesL; apply MR_One => //.
            *   apply MR_TimesR; apply MR_One => //.
        -   subst A B e0 e3 Y1 Y2.
            move : (HB e2' e2'0 H4 H8) => [z [Hz1 Hz2]].
            exists (ETimes e1 z); split; apply MR_TimesR => //.
Qed.

Theorem EvalTo_MultiReduceTo :
    forall e n, EvalTo e n -> MultiReduceTo e (ENum n).
Proof.
    elim.
    +   move => m n H.
        inversion H.
        subst n0 m.
        apply MR_Zero.
    +   move => x Hx y Hy n H.
        inversion H.
        subst e1 e2 n0.
        move : (Hx n1 H2) => H1 {H2 Hx}.
        move : (Hy n2 H3) => H2 {H3 Hy}.
        refine (MR_Multi _ (EPlus x (ENum n2))_ _ _).
        *   apply MR_PlusR => //.
        *   refine (MR_Multi _ (EPlus (ENum n1) (ENum n2))_ _ _).
            -   apply MR_PlusL => //.
            -   apply MR_One.
                apply R_Plus => //.
    +   move => x Hx y Hy n H.
        inversion H.
        subst e1 e2 n0.
        move : (Hx n1 H2) => H1 {H2 Hx}.
        move : (Hy n2 H3) => H2 {H3 Hy}.
        refine (MR_Multi _ (ETimes x (ENum n2))_ _ _).
        *   apply MR_TimesR => //.
        *   refine (MR_Multi _ (ETimes (ENum n1) (ENum n2))_ _ _).
            -   apply MR_TimesL => //.
            -   apply MR_One.
                apply R_Times => //.
Qed.

Lemma MR_eq :
    forall x y, MultiReduceTo (ENum x) (ENum y) -> x = y.
Proof.
    move => x y H.
    inversion H => //.
    +   inversion H0.
    +   subst e e''.
        (* move : (ReduceTo_weak_normal e') => [z Hz]. *)
        inversion H0; inversion H1.
        -   subst e e' e0.
            inversion H5 => //.
        -   subst e e' e0 e'0.
            inversion H4.
        -   subst e e' e0 e''.
Admitted.

Theorem MultiReduceTo_EvalTo :
    forall e n, MultiReduceTo e (ENum n) -> EvalTo e n.
Proof.
Admitted.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Theorem plus_1_1 : forall n : nat, 1 + n = S n.
1 subgoal

  ============================
  forall n : nat, 1 + n = S n

plus_1_1 < Proof.
1 subgoal

  ============================
  forall n : nat, 1 + n = S n

plus_1_1 < intros n.
1 subgoal

  n : nat
  ============================
  1 + n = S n

plus_1_1 < reflexivity.
No more subgoals.

plus_1_1 < Qed.
Proof.
intros n.
reflexivity.

Qed.
plus_1_1 is defined

Coq < Theorem mult_0_1 : forall n : nat , 0 * n = 0.
1 subgoal

  ============================
  forall n : nat, 0 * n = 0

mult_0_1 < Proof.
1 subgoal

  ============================
  forall n : nat, 0 * n = 0

mult_0_1 < intros n.
1 subgoal

  n : nat
  ============================
  0 * n = 0

mult_0_1 < reflexivity.
No more subgoals.

mult_0_1 < Qed.
Proof.
intros n.
reflexivity.

Qed.
mult_0_1 is defined


Inductive AList (A : Type) : Type :=
| Single : A -> AList A
| Append : AList A -> AList A -> AList A.

Arguments Single {A} _.
Arguments Append {A} _ _.

Inductive CList (A : Type) : Type :=
| Nil    : CList A
| NotNil : AList A -> CList A.

Arguments Nil    {A}.
Arguments NotNil {A} _.

Definition append {A : Type} (l1 l2 : CList A) : CList A :=
match l1, l2 with
| Nil       , _          => l2
| _         , Nil        => l1
| NotNil l1', NotNil l2' => NotNil (Append l1' l2')
end.

Fixpoint hd {A : Type} (l : AList A) : A :=
match l with
| Single h    => h
| Append l' _ => hd l'
end.

Fixpoint last {A : Type} (l : AList A) : A :=
match l with
| Single x    => x
| Append _ l' => last l'
end.

Require Import List.
Import ListNotations.

Fixpoint toListA {A : Type} (l : AList A) : list A :=
match l with
| Single x     => [x]
| Append l1 l2 => toListA l1 ++ toListA l2
end.

Definition toListC {A : Type} (l : CList A) : list A :=
match l with
| Nil       => []
| NotNil l' => toListA l'
end.

Lemma append_spec :
  forall {A : Type} (l1 l2 : CList A),
    toListC (append l1 l2) = toListC l1 ++ toListC l2.
Proof.
  destruct l1 as [| [|]], l2 as []; cbn; try reflexivity.
  symmetry. apply app_nil_r.
Qed.


Require Export hott_lemmas.

Open Scope type.

Section MonoidalGroupoids.

Section MonoidalStructure.

Context {X : Type} (e : X) (m : X -> X -> X).

Definition IsAssociative : Type
  := forall a b c : X, m (m a b) c = m a (m b c).

Definition IsLeftUnital : Type
  := forall b : X, m e b = b.

Definition IsRightUnital : Type
  := forall a : X, m a e = a.

Definition IsPentagonCoherent (alpha : IsAssociative) : Type
  := forall a b c d : X,
      alpha (m a b) c d @ alpha a b (m c d)
      = ap011 m (alpha a b c) (idpath d) @ alpha a (m b c) d @ ap011 m (idpath a) (alpha b c d).

Definition IsTriangleCoherent (alpha : IsAssociative) (lambda : IsLeftUnital) (rho : IsRightUnital) : Type
  := forall a b : X,
      alpha a e b @ ap011 m (idpath a) (lambda b)
      = ap011 m (rho a) (idpath b).

End MonoidalStructure.

Class MonoidalGroupoid := {
  mgcarrier : Type;
  mgtrunc : IsTrunc 1 mgcarrier;
  mg_e : mgcarrier;
  mg_m : mgcarrier -> mgcarrier -> mgcarrier;
  mg_alpha : IsAssociative mg_m;
  mg_lambda : IsLeftUnital mg_e mg_m;
  mg_rho : IsRightUnital mg_e mg_m;
  mg_pentagon : IsPentagonCoherent mg_m mg_alpha;
  mg_triangle : IsTriangleCoherent mg_e mg_m mg_alpha mg_lambda mg_rho
  }.
Coercion mgcarrier : MonoidalGroupoid >-> Sortclass.

Definition mg_mm {M : MonoidalGroupoid} {a b a' b'} (pa : a = a') (pb : b = b')
  : mg_m a b = mg_m a' b'
  := ap011 mg_m pa pb.

Definition mg_mmm {M : MonoidalGroupoid} {a b a' b'} {pa pa' : a = a'} {pb pb' : b = b'}
  (fa : pa = pa') (fb : pb = pb')
  : mg_mm pa pb = mg_mm pa' pb'
  := ap011 mg_mm fa fb.

Section Naturality.

Context {M : MonoidalGroupoid}.

Definition alpha_natural {a b c a' b' c'} (pa : a = a') (pb : b = b') (pc : c = c')
  : mg_alpha a b c @ mg_mm pa (mg_mm pb pc) = mg_mm (mg_mm pa pb) pc @ mg_alpha a' b' c'.
Proof.
  induction pa, pb, pc.
  exact (concat_p1 _ @ (concat_1p _)^).
Defined.

Definition lambda_natural {b b'} (pb : b = b')
  : mg_lambda b @ pb = mg_mm (idpath mg_e) pb @ mg_lambda b'.
Proof.
  induction pb;
  exact (concat_p1 _ @ (concat_1p _)^).
Defined.

Definition rho_natural {a a'} (pa : a = a')
  : mg_rho a @ pa = mg_mm pa (idpath mg_e) @ mg_rho a'.
Proof.
  induction pa;
  exact (concat_p1 _ @ (concat_1p _)^).
Defined.

End Naturality.

Section DerivedCoherence.

Context {M : MonoidalGroupoid}.

Definition rho_a_e (a : M)
  : mg_rho (mg_m a mg_e) = mg_mm (mg_rho a) (idpath mg_e).
Proof.
  apply (cancelR _ _ (mg_rho a)).
  exact (rho_natural (mg_rho a)).
Defined.

Definition lambda_e_b (b : M)
  : mg_lambda (mg_m mg_e b) = mg_mm (idpath mg_e) (mg_lambda b).
Proof.
  apply (cancelR _ _ (mg_lambda b)).
  exact (lambda_natural (mg_lambda b)).
Defined.

Definition alpha_lambda (a b : M)
  : mg_alpha mg_e a b @ mg_lambda (mg_m a b) = mg_mm (mg_lambda a) (idpath b).
Proof.
  apply (cancelL (mg_lambda _) _ _); refine (concat_p_pp _ _ _ @ _);
    refine (whiskerR (lambda_natural (mg_alpha mg_e a b)) _ @ concat_pp_p _ _ _ @ _).
  refine (whiskerL _ (lambda_natural (mg_lambda (mg_m a b))) @ concat_p_pp _ _ _ @ _).
  refine (_ @ (lambda_natural (mg_mm (mg_lambda a) (idpath b)))^); apply whiskerR.
  apply (cancelL (mg_alpha _ _ _) _ _); refine (concat_p_pp _ _ _ @ _);
    refine (_ @ (alpha_natural (idpath mg_e) (mg_lambda a) (idpath b))^);
    refine (concat_pp_p _ _ _ @ _).
  apply (cancelL (mg_mm (mg_alpha _ _ _) idpath) _ _);
    refine (concat_p_pp _ _ _ @ concat_p_pp _ _ _ @ _ @ concat_pp_p _ _ _);
    refine (whiskerR (mg_pentagon mg_e mg_e a b)^ _ @ concat_pp_p _ _ _ @ _).
  refine (whiskerL _ (mg_triangle mg_e (mg_m a b)) @ _).
  refine (alpha_natural (mg_rho mg_e) idpath idpath @ _); apply whiskerR.
  refine (_ @ (ap011_pqpq mg_m (mg_alpha mg_e mg_e a) (mg_mm idpath (mg_lambda a)) idpath idpath)^);
    exact (mg_mmm (mg_triangle _ _)^ idpath).
Defined.

Definition alpha_rho (a b : M)
  : mg_alpha a b mg_e @ mg_mm (idpath a) (mg_rho b) = mg_rho (mg_m a b).
Proof.
  apply (cancelL (mg_rho _) _ _); refine (concat_p_pp _ _ _ @ _).
  refine (whiskerR (rho_natural (mg_alpha a b mg_e)) _ @ concat_pp_p _ _ _ @ _).
  refine (whiskerL _ (rho_natural (mg_mm (idpath a) (mg_rho b))) @ concat_p_pp _ _ _ @ _).
  refine (_ @ (rho_natural (mg_rho (mg_m a b)))^); apply whiskerR.
  refine (_ @ mg_triangle (mg_m a b) mg_e).
  apply (cancelR _ _ (mg_alpha _ _ _)); refine (concat_pp_p _ _ _ @ _ @ concat_p_pp _ _ _).
  refine (whiskerL _ (alpha_natural idpath (mg_rho _) idpath)^ @ concat_p_pp _ _ _ @ _).
  refine (_ @ concat_pp_p _ _ _ @ whiskerL _ (alpha_natural idpath idpath (mg_lambda _))).
  refine (_ @ concat_p_pp _ _ _ @ whiskerR (mg_pentagon _ _ _ _)^ _); apply whiskerL.
  refine (_ @ (ap011_pqpq mg_m idpath idpath (mg_alpha b mg_e mg_e) (mg_mm idpath (mg_lambda mg_e)))^);
    exact (mg_mmm idpath (mg_triangle _ _)^).
Defined.

Definition lambda_rho_e
  : mg_lambda mg_e = mg_rho mg_e.
Proof.
  apply (cancelL (mg_rho (mg_m mg_e mg_e)) _ _).
  refine (rho_natural (mg_lambda mg_e) @ _).
  refine (_ @ (rho_natural (mg_rho mg_e))^); apply whiskerR.
  refine ((alpha_lambda mg_e mg_e)^ @ _).
  apply (cancelR _ _ (mg_lambda mg_e)); refine (concat_pp_p _ _ _ @ _).
  refine (whiskerL _ (lambda_natural (mg_lambda mg_e)) @ concat_p_pp _ _ _ @ _); apply whiskerR.
  apply mg_triangle.
Defined.

End DerivedCoherence.

Class MonoidalFunctor (A B : MonoidalGroupoid) := {
  mg_f : A -> B;
  mg_f0 : mg_e = mg_f mg_e;
  mg_f2 : forall a b : A, mg_m (mg_f a) (mg_f b) = mg_f (mg_m a b);
  mg_dalpha : forall a b c : A,
    mg_alpha (mg_f a) (mg_f b) (mg_f c) @ (mg_mm idpath (mg_f2 b c) @ mg_f2 a (mg_m b c))
    = (mg_mm (mg_f2 a b) idpath @ mg_f2 (mg_m a b) c) @ ap mg_f (mg_alpha a b c);
  mg_dlambda : forall b : A,
    mg_lambda (mg_f b) = mg_mm mg_f0 idpath @ mg_f2 mg_e b @ ap mg_f (mg_lambda b);
  mg_drho : forall a : A,
    mg_rho (mg_f a) = mg_mm idpath mg_f0 @ mg_f2 a mg_e @ ap mg_f (mg_rho a)
  }.
Coercion mg_f : MonoidalFunctor >-> Funclass.

Definition mg_f2_natural {A B : MonoidalGroupoid} (F : MonoidalFunctor A B)
  {a b a' b' : A} (pa : a = a') (pb : b = b')
  : mg_f2 a b @ ap mg_f (mg_mm pa pb)
    = mg_mm (ap mg_f pa) (ap mg_f pb) @ mg_f2 a' b'.
Proof.
  induction pa, pb; exact (concat_p1 _ @ (concat_1p _)^).
Defined.

Definition MonoidalFunctor_id (A : MonoidalGroupoid)
  : MonoidalFunctor A A.
Proof.
  srapply @Build_MonoidalFunctor.
  + exact idmap.
  + constructor.
  + constructor.
  + intros. simpl. refine (concat_p1 _ @ (ap_idmap _)^ @ (concat_1p _)^).
  + intros. simpl. refine ((ap_idmap _)^ @ (concat_1p _)^).
  + intros. simpl. refine ((ap_idmap _)^ @ (concat_1p _)^).
Defined.

Definition MonoidalFunctor_comp {A B C : MonoidalGroupoid}
  (G : MonoidalFunctor B C) (F : MonoidalFunctor A B)
  : MonoidalFunctor A C.
Proof.
  srapply @Build_MonoidalFunctor.
  + exact (fun x => G (F x)).
  + simpl. exact (@mg_f0 B C G @ ap G (@mg_f0 A B F)).
  + intros; simpl.
    exact (@mg_f2 B C G (F a) (F b) @ ap G (@mg_f2 A B F a b)).
  + intros; simpl.
    refine (whiskerL _ (whiskerR (ap011_pqpq mg_m idpath idpath (mg_f2 (F b) (F c)) (ap G (mg_f2 b c)))^ _) @ _ @ whiskerR (whiskerR (ap011_pqpq mg_m (mg_f2 (F a) (F b)) (ap G (mg_f2 a b)) idpath idpath) _) _).
    refine (whiskerL _ (concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _) _) @ _);
      refine (whiskerL _ (whiskerR (whiskerL _ (mg_f2_natural G (idpath (F a)) (mg_f2 b c))^ @ concat_p_pp _ _ _) _ @ concat_pp_p _ _ _) @ _).
    refine (concat_p_pp _ _ _ @ whiskerR (mg_dalpha _ _ _ @ concat_pp_p _ _ _) _ @ concat_pp_p _ _ _ @ _);
      refine (_ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _); apply whiskerL.
    refine (whiskerL _ (ap_pp _ _ _)^ @ concat_pp_p _ _ _ @ whiskerL _ ((ap_pp _ _ _)^ @ ap (ap G) (mg_dalpha a b c) @ ap_pp _ _ _ @ whiskerR (ap_pp _ _ _) _ @ concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ _).
    refine (whiskerR (mg_f2_natural G (mg_f2 a b) (idpath (F c))) _ @ concat_pp_p _ _ _ @ _); apply whiskerL;
      refine (concat_p_pp _ _ _ @ _); apply whiskerL.
    exact (ap_compose F G _)^.
  + intros; simpl.
    refine (_ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _ @ whiskerR (whiskerR (ap011_pqpq mg_m mg_f0 (ap G mg_f0) idpath idpath) _) _).
    refine (mg_dlambda (F b) @ concat_pp_p _ _ _ @ _); apply whiskerL.
    refine (_ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _));
      refine (_ @ concat_p_pp _ _ _ @ whiskerR (mg_f2_natural G mg_f0 idpath) _); apply whiskerL.
    refine (_ @ whiskerL _ (whiskerL _ (ap_compose F G (mg_lambda b))^)).
    refine (_ @ ap_pp G _ _ @ whiskerR (ap_pp G _ _) _ @ concat_pp_p _ _ _);
      apply ap; exact (mg_dlambda b).
  + intros; simpl.
    refine (_ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _ @ whiskerR (whiskerR (ap011_pqpq mg_m idpath idpath mg_f0 (ap G mg_f0)) _) _).
    refine (mg_drho (F a) @ concat_pp_p _ _ _ @ _); apply whiskerL.
    refine (_ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _));
      refine (_ @ concat_p_pp _ _ _ @ whiskerR (mg_f2_natural G idpath mg_f0) _); apply whiskerL.
    refine (_ @ whiskerL _ (whiskerL _ (ap_compose F G (mg_rho a))^)).
    refine (_ @ ap_pp G _ _ @ whiskerR (ap_pp G _ _) _ @ concat_pp_p _ _ _);
      apply ap; exact (mg_drho a).
Defined.

Class MonoidalNatIso {A B} (F G : MonoidalFunctor A B) := {
  mg_nt : F == G;
  mg_nt0 : @mg_f0 _ _ F @ mg_nt mg_e = @mg_f0 _ _ G;
  mg_nt2 : forall a b : A,
    @mg_f2 _ _ F a b @ mg_nt (mg_m a b)
    = ap011 mg_m (mg_nt a) (mg_nt b) @ @mg_f2 _ _ G a b
  }.

Lemma MonoidalNatIso_V {A B : MonoidalGroupoid} (F G : MonoidalFunctor A B)
  : MonoidalNatIso F G -> MonoidalNatIso G F.
Proof.
  intro eta.
  srapply @Build_MonoidalNatIso.
  + intro x. exact (mg_nt x)^.
  + simpl. refine (whiskerR (@mg_nt0 _ _ _ _ eta)^ _ @ _).
    exact (concat_pp_p _ _ _ @ whiskerL _ (concat_pV _) @ concat_p1 _).
  + simpl. intros.
    refine (_ @ whiskerR (ap011_VV _ _ _)^ _).
    apply moveL_Vp; refine (concat_p_pp _ _ _ @ _); apply moveR_pV.
    exact (mg_nt2 a b)^.
Defined.

Lemma MonoidalFunctor_comp_associative {A B C D : MonoidalGroupoid}
  (H : MonoidalFunctor C D) (G : MonoidalFunctor B C) (F : MonoidalFunctor A B)
  : MonoidalNatIso
      (MonoidalFunctor_comp (MonoidalFunctor_comp H G) F)
      (MonoidalFunctor_comp H (MonoidalFunctor_comp G F)).
Proof.
  srapply @Build_MonoidalNatIso.
  + simpl; constructor.
  + simpl. refine (concat_p1 _ @ concat_pp_p _ _ _ @ _).
    apply whiskerL.
    refine (_ @ (ap_pp H _ _)^).
    apply whiskerL.
    apply ap_compose.
  + intros; simpl. refine (concat_p1 _ @ concat_pp_p _ _ _ @ _ @ (concat_1p _)^).
    apply whiskerL.
    refine (_ @ (ap_pp H _ _)^).
    apply whiskerL.
    apply ap_compose.
Defined.

Lemma MonoidalFunctor_comp_left_unital {A B : MonoidalGroupoid}
  (F : MonoidalFunctor A B)
  : MonoidalNatIso (MonoidalFunctor_comp F (MonoidalFunctor_id A)) F.
Proof.
  srapply @Build_MonoidalNatIso; simpl.
  + constructor.
  + simpl. exact (concat_p1 _ @ concat_p1 _).
  + intros; simpl. exact (concat_p1 _ @ concat_p1 _ @ (concat_1p _)^).
Defined.

Lemma MonoidalFunctor_comp_right_unital {A B : MonoidalGroupoid}
  (F : MonoidalFunctor A B)
  : MonoidalNatIso (MonoidalFunctor_comp (MonoidalFunctor_id B) F) F.
Proof.
  srapply @Build_MonoidalNatIso; simpl.
  + constructor.
  + simpl. exact (concat_p1 _ @ concat_1p _ @ ap_idmap _).
  + intros; simpl. exact (concat_p1 _ @ concat_1p _ @ ap_idmap _ @ (concat_1p _)^).
Defined.

Lemma MonoidalNatIso_vcomp {A B : MonoidalGroupoid} {F G H : MonoidalFunctor A B}
  (theta : MonoidalNatIso F G) (eta : MonoidalNatIso G H)
  : MonoidalNatIso F H.
Proof.
  srapply @Build_MonoidalNatIso.
  + intro x. exact (mg_nt x @ mg_nt x).
  + simpl. refine (concat_p_pp _ _ _ @ _).
    exact (whiskerR mg_nt0 _ @ mg_nt0).
  + intros; simpl.
    refine (_ @ whiskerR (ap011_pqpq mg_m (mg_nt a) (mg_nt a) (mg_nt b) (mg_nt b)) _).
    refine (concat_p_pp _ _ _ @ _ @ concat_p_pp _ _ _).
    refine (whiskerR (mg_nt2 a b) _ @ concat_pp_p _ _ _ @ _); apply whiskerL.
    exact (mg_nt2 a b).
Defined.

Lemma MonoidalNatIso_hcomp {A B C : MonoidalGroupoid}
  {G1 G2 : MonoidalFunctor B C} {F1 F2 : MonoidalFunctor A B}
  (eta : MonoidalNatIso G1 G2) (theta : MonoidalNatIso F1 F2)
  : MonoidalNatIso (MonoidalFunctor_comp G1 F1) (MonoidalFunctor_comp G2 F2).
Proof.
  srapply @Build_MonoidalNatIso; simpl.
  + intro x. exact (mg_nt (F1 x) @ ap G2 (mg_nt x)).
  + simpl.
    refine (concat_pp_p _ _ _ @ _ @ concat_p_pp _ _ _ @ whiskerR mg_nt0 _); apply whiskerL.
    refine (concat_p_pp _ _ _ @ _ @ concat_pp_p _ _ _ @ whiskerL _ ((ap_pp _ _ _)^ @ ap (ap G2) mg_nt0));
    apply whiskerR.
    exact (homotopy_square mg_nt mg_f0)^.
  + intros; simpl.
    refine (_ @ whiskerR (ap011_pqpq mg_m _ _ _ _) _).
    refine (concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _ @ whiskerR (homotopy_square mg_nt (@mg_f2 _ _ F1 a b))^ _ @ concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ _).
    refine (whiskerL _ ((ap_pp _ _ _)^ @ ap (ap G2) (mg_nt2 a b) @ ap_pp _ _ _) @ _);
    refine (concat_p_pp _ _ _ @ _ @ concat_pp_p _ _ _); apply whiskerR.
    refine (whiskerR (mg_nt2 (F1 a) (F1 b)) _ @ concat_pp_p _ _ _ @ _ @ concat_p_pp _ _ _); apply whiskerL.
    (* this would need a lemma ... *)
    generalize (mg_nt a) as p; induction p; generalize (mg_nt b) as q; induction q.
    exact (concat_p1 _ @ (concat_1p _)^).
Defined.

Definition MonoidalEquivalence (M N : MonoidalGroupoid) : Type
  := {F : MonoidalFunctor M N & {G : MonoidalFunctor N M & (MonoidalNatIso (MonoidalFunctor_comp G F) (MonoidalFunctor_id M)) * (MonoidalNatIso (MonoidalFunctor_comp F G) (MonoidalFunctor_id N))}}.

Section UniversalProperty.

Class IsFunctor (F : forall X : Type, IsHSet X -> MonoidalGroupoid) := {
  F_arr : forall (X Y : Type) (T_X : IsHSet X) (T_Y : IsHSet Y) (f : X -> Y),
          MonoidalFunctor (F X T_X) (F Y T_Y);
  F_id : forall (X : Type) (T_X : IsHSet X),
          MonoidalNatIso (F_arr X X T_X T_X (fun x => x)) (MonoidalFunctor_id (F X T_X));
  F_comp : forall (X Y Z : Type) (T_X : IsHSet X) (T_Y : IsHSet Y) (T_Z : IsHSet Z)
            (g : Y -> Z) (f : X -> Y),
            MonoidalNatIso (MonoidalFunctor_comp (F_arr Y Z T_Y T_Z g) (F_arr X Y T_X T_Y f)) (F_arr X Z T_X T_Z (g o f))
  }.

Class IsFreeFunctor (F : forall X : Type, IsHSet X -> MonoidalGroupoid) := {
  free_functor : IsFunctor F;
  Phi : forall (X : Type) (T_X : IsHSet X)
        (M : MonoidalGroupoid) (G : MonoidalFunctor (F X T_X) M),
        X -> @mgcarrier M;
  Phi_nat_M : forall (X : Type) (T_X : IsHSet X)
              (M : MonoidalGroupoid) (G : MonoidalFunctor (F X T_X) M)
              (N : MonoidalGroupoid) (H : MonoidalFunctor M N),
              H o Phi X T_X M G == Phi X T_X N (MonoidalFunctor_comp H G);
  Psi : forall (X : Type) (T_X : IsHSet X)
        (M : MonoidalGroupoid) (g : X -> @mgcarrier M),
        MonoidalFunctor (F X T_X) M;
  Psi_nat_X : forall (X : Type) (T_X : IsHSet X)
              (M : MonoidalGroupoid) (g : X -> @mgcarrier M)
              (Y : Type) (T_Y : IsHSet Y) (h : Y -> X),
              MonoidalNatIso
                (MonoidalFunctor_comp (Psi X T_X M g) (@F_arr F free_functor Y X T_Y T_X h))
                (Psi Y T_Y M (g o h));
  Theta : forall (X : Type) (T_X : IsHSet X) (M : MonoidalGroupoid),
          Phi X T_X M o Psi X T_X M == idmap;
  Chi : forall (X : Type) (T_X : IsHSet X)
          (M : MonoidalGroupoid) (G : MonoidalFunctor (F X T_X) M),
          MonoidalNatIso (Psi X T_X M (Phi X T_X M G)) G
  }.

End UniversalProperty.

(** If a monoidal functor determines an equivalence, then it determines a monoidal equivalence **)
Section Inverse.

Context (M N : MonoidalGroupoid) (F : MonoidalFunctor M N) (equiv: IsEquiv F).
Let G := F^-1.
Let h := eissect F : Sect F G.
Let k := eisretr F : Sect G F.
Let d := eisadj F : forall m : M, k (F m) = ap F (h m).
Let d' := eisadj F^-1 : forall n : N, h (G n) = ap G (k n).

  Lemma MonoidalFunctor_equiv_inverse_G0
    : mg_e = G mg_e.
  Proof.
    exact ((h mg_e)^ @ ap G mg_f0^).
  Defined.
  Let G0 := MonoidalFunctor_equiv_inverse_G0.

  Lemma MonoidalFunctor_equiv_inverse_G2
    : forall a b : N, mg_m (G a) (G b) = G (mg_m a b).
  Proof.
    intros. exact ((h _)^ @ ap G (mg_f2 _ _)^ @ ap G (mg_mm (k _) (k _))).
  Defined.
  Let G2 := MonoidalFunctor_equiv_inverse_G2.

  Lemma MonoidalFunctor_equiv_inverse_Galpha
    : forall a b c : N, mg_alpha (G a) (G b) (G c) @ (mg_mm 1 (G2 b c) @ G2 a (mg_m b c)) = (mg_mm (G2 a b) 1 @ G2 (mg_m a b) c) @ ap G (mg_alpha a b c).
  Proof.
    intros.
    refine (whiskerR ((ap_idmap _)^ @ moveL_Vp _ _ _ (homotopy_square h (mg_alpha _ _ _))) _ @ concat_pp_p _ _ _ @ _); (* 10 *)
    apply moveR_Vp.
    refine (_ @ concat_p_pp _ _ _ @ whiskerR (moveR_Vp _ _ _ (homotopy_square h (mg_mm (h (mg_m (G a) (G b))) (h (G c))))) _); (* 5 *)
    apply moveL_Vp;
    repeat rewrite ap_idmap; repeat rewrite (ap_compose F G).
    repeat rewrite concat_pp_p. refine (whiskerR (ap (ap G) (moveL_Vp _ _ _ (homotopy_square_2 F mg_m mg_m mg_f2 (h (mg_m (G a) (G b))) (h (G c))))) _ @ _); (* 9 *)
    repeat rewrite <- d; repeat rewrite ap_pp; repeat rewrite concat_pp_p.
    apply moveL_Mp.
    refine (concat_p_pp _ _ _ @ concat_p_pp _ _ _ @ _).
    change (G2 (F (mg_m (G a) (G b))) (F (G c)) @ (ap G (mg_f2 (mg_m (G a) (G b)) (G c)) @ (ap G (ap F (mg_alpha (G a) (G b) (G c))) @ (h (mg_m (G a) (mg_m (G b) (G c))) @ (mg_mm 1 (G2 b c) @ G2 a (mg_m b c))))) = mg_mm (h (mg_m (G a) (G b))) (h (G c)) @ (mg_mm (G2 a b) 1 @ ((h (mg_m (G (mg_m a b)) (G c)))^ @ (ap G (mg_f2 (G (mg_m a b)) (G c))^ @ (ap G (mg_mm (k (mg_m a b)) (k c)) @ ap G (mg_alpha a b c)))))). (* 6 *)
    refine (whiskerR (moveR_Vp _ _ _ (homotopy_square_2 G mg_m mg_m G2 (mg_f2 (G a) (G b)) (idpath (F (G c)))))^ _ @ concat_pp_p _ _ _ @ _); (* 8 *)
    apply moveR_Vp; refine (concat_pp_p _ _ _ @ _).
    refine (_ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _ @ whiskerR (moveL_pV _ _ _ (ap011_p11q mg_m (ap G (mg_f2 (G a) (G b))) (h (G c)) @ (ap011_1qp1 mg_m (ap G (mg_f2 (G a) (G b))) (h (G c)))^))^ _). (* 3 *)
    refine (_ @ whiskerL _ (whiskerL _ (whiskerR (moveL_Vp _ _ _ (ap011_1qp1 mg_m (h (mg_m (G a) (G b))) (h (G c)))) _ @ concat_pp_p _ _ _))). (* 2 *)
    refine (_ @ concat_p_pp _ _ _ @ whiskerR (moveL_pV _ _ _ (ap011_1qp1 mg_m (ap G (mg_mm (k a) (k b))) (h (G c))))^ _). (* 4 *)
    refine (_ @ whiskerL _ (whiskerR ((ap011_VV mg_m (G2 a b) idpath)^ @ ap (fun z => ap011 mg_m z idpath) (ap inverse (whiskerR (whiskerL _ (ap_V G _)) _ @ concat_pp_p _ _ _ @ whiskerL _ (whiskerL _ (inv_V _)^ @ (inv_pp _ _)^)) @ inv_VV _ _) @ ap011_pp1 mg_m _ (h (mg_m (G a) (G b))) @ whiskerR (ap011_pp1 mg_m (ap G (mg_mm (k a) (k b)))^ (ap G (mg_f2 (G a) (G b))) @ whiskerR (ap011_VV mg_m (ap G (mg_mm (k a) (k b))) idpath) _) _) _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _)); (* 1 *)
    refine (_ @ whiskerL _ ((concat_1p _)^ @ whiskerR (concat_Vp _)^ _ @ concat_pp_p _ _ _)).
    refine (_ @ whiskerL _ (concat_pp_p _ _ _ @ concat_pp_p _ _ _));
    refine (_ @ concat_pp_p _ _ _ @ whiskerR (ap (ap011 mg_m _) (d' _)^) _);
    refine (_ @ concat_p_pp _ _ _ @ whiskerR (homotopy_square_2 G mg_m mg_m G2 (mg_mm (k a) (k b)) (k c)) _); (* 7 *)
    apply whiskerL.
    refine (_ @ (ap_pp G _ _)^ @ ap (ap G) (alpha_natural (k a) (k b) (k c)) @ ap_pp G _ _). (* 12 *)
    refine (concat_p_pp _ _ _ @ whiskerR (ap_pp G _ _)^ _ @ concat_p_pp _ _ _ @ whiskerR ((ap_pp G _ _)^ @ ap (ap G) (mg_dalpha (G a) (G b) (G c))^ @ ap_pp G _ _ @ whiskerL _ (ap_pp G _ _)) _ @ concat_pp_p _ _ _ @ whiskerL _ (concat_pp_p _ _ _) @ _); (* 11 *)
    apply whiskerL.
    srapply (cancelL (G2 _ _) _ _);
    refine (whiskerL _ (whiskerL _ (whiskerL _ (concat_p_pp _ _ _) @ concat_p_pp _ _ _) @ concat_p_pp _ _ _) @ concat_p_pp _ _ _ @ _ @ (homotopy_square_2 G mg_m mg_m G2 (k a) (mg_mm (k b) (k c)))^); (* 7' *)
    apply whiskerR.
    refine (concat_p_pp _ _ _ @ whiskerR (homotopy_square_2 G mg_m mg_m G2 (idpath (F (G a))) (mg_f2 (G b) (G c))) _ @ concat_pp_p _ _ _ @ _). (* 8' *)
    refine (whiskerR (moveL_pV _ _ _ (ap011_1qp1 mg_m (h _) (ap G (mg_f2 (G b) (G c))) @ (ap011_p11q mg_m (h _) (ap G (mg_f2 (G b) (G c))))^)) _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ _). (* 3' *)
    refine (_ @ ap011_p11q mg_m (h (G a)) (ap G (mg_mm (k b) (k c))) @ ap (fun z => ap011 mg_m z _) (d' a)); (* 4' *)
    apply whiskerL.
    refine (whiskerL _ (whiskerR (moveR_pV _ _ _ (moveL_Vp _ _ _ (ap011_p11q mg_m (h _) (h _))))^ _ @ concat_pp_p _ _ _) @ _). (* 2' *)
    apply moveR_Mp;
    refine (_ @ ap011_1pp mg_m _ _ @ whiskerR (ap (ap011 mg_m idpath) (ap_V G _) @ ap011_VV mg_m idpath _) _);
    apply moveR_Mp;
    refine (_ @ ap (ap011 mg_m idpath) (concat_pp_p _ _ _) @ ap011_1pp mg_m _ _ @ whiskerR (ap011_VV mg_m idpath _) _); (* 1' *)
    refine (whiskerL _ (whiskerL _ (concat_p_pp _ _ _) @ concat_p_pp _ _ _) @ concat_p_pp _ _ _ @ _ @ concat_1p _);
    apply whiskerR;
    apply moveR_Vp; refine (_ @ (concat_p1 _)^).
    refine (_ @ ((ap_idmap _)^ @ moveL_Vp _ _ _ (homotopy_square h (mg_mm (h _) (h _))))^); (* 5' *)
    apply moveL_Vp;
    refine (concat_p_pp _ _ _ @ concat_p_pp _ _ _ @ _);
    apply whiskerR.
    unfold G2, MonoidalFunctor_equiv_inverse_G2;
    refine (whiskerR (concat_p_pp _ _ _ @ whiskerR (concat_p_pp _ _ _ @ whiskerR (concat_pV _) _ @ concat_1p _) _) _ @ concat_pp_p _ _ _ @ whiskerR (ap_V G _) _ @ _); (* 6' *)
    apply moveR_Vp.
    rewrite (ap_compose F G); repeat rewrite <- ap_pp; apply ap.
    refine (_ @ (homotopy_square_2 F mg_m mg_m mg_f2 (h _) (h _))^); apply whiskerR; repeat rewrite d; constructor.
  Qed.

  Lemma MonoidalFunctor_equiv_inverse_Glambda
    : forall b : N, mg_lambda (G b) = (mg_mm G0 1 @ G2 mg_e b) @ ap G (mg_lambda b).
  Proof.
    intros.
    refine ((ap_idmap _)^ @ moveL_Vp _ _ _ (homotopy_square h (mg_lambda (G b))) @ _); (* 1 *)
    apply moveR_Vp; apply moveR_pM.
    refine (ap_compose F G _ @ ap (ap G) ((moveR_Vp _ _ _ (mg_dlambda (G b)))^ @ whiskerR (inv_pp _ _) _) @ ap_pp G _ _ @ whiskerR (ap_pp G _ _) _ @ concat_pp_p _ _ _ @ _);  (* 9 *)
    repeat rewrite ap_V;
    apply moveR_Vp; apply moveR_Vp.
    refine (_ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _); apply moveL_pV;
    refine (whiskerL _ (d' _) @ (ap_pp G _ _)^ @ ap (ap G) (lambda_natural (k b)) @ ap_pp G _ _ @ _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _); (* 10 *)
    apply whiskerR.
    refine (moveL_Vp _ _ _ (homotopy_square_2 G mg_m mg_m G2 idpath (k b)) @ _); (* 11 *)
    apply moveR_Vp;
    refine (_ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _);
    apply whiskerR;
    refine (ap (mg_mm idpath) (d' b)^ @ _).
    srapply (cancelL (mg_mm G0 idpath) _ _ _);
    srefine (_ @ concat_pp_p _ _ _);
    refine (ap011_p11q mg_m G0 (h (G b)) @ (ap011_1qp1 mg_m G0 (h (G b)))^ @ _); (* 6 *)
    apply whiskerR.
    unfold G0, MonoidalFunctor_equiv_inverse_G0;
    refine (_ @ concat_p_pp _ _ _ @ whiskerR (concat2 (ap011_VV mg_m (h mg_e) idpath)^ ((ap011_VV mg_m (ap G mg_f0) idpath)^ @ ap (fun z => ap011 mg_m z idpath) (ap_V G _)^) @ (ap011_pp1 _ _ _)^) _); (* 7 *)
    apply moveL_Vp; apply moveL_Vp.
    refine (whiskerR (moveR_pV _ _ _ (homotopy_square_2 G mg_m mg_m G2 mg_f0 idpath))^ _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ _); (* 8 *)
    apply whiskerL; refine (_ @ concat_p_pp _ _ _); apply whiskerL;
    apply moveR_Vp.
    refine (ap011_p11q mg_m (h mg_e) (h (G b)) @ _). (* 2 *)
    unfold G2, MonoidalFunctor_equiv_inverse_G2;
    refine (_ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _);
    apply moveL_Vp;
    refine (_ @ whiskerR (ap_V G _)^ _);
    apply moveL_Vp. (* 4 *)
    refine (_ @ concat_p_pp _ _ _ @ whiskerR ((ap_pp G _ _)^ @ ap (ap G) (homotopy_square_2 F mg_m mg_m mg_f2 (h mg_e) (h (G b)) @ whiskerR (ap011 (ap011 mg_m) (d _)^ (d _)^) _) @ ap_pp G _ _) _ @ concat_pp_p _ _ _); (* 5 *)
    apply whiskerL.
    refine (whiskerL _ (ap_idmap _)^ @ homotopy_square h (ap011 mg_m (h mg_e) (h (G b))) @ _); (* 3 *)
    apply whiskerR; apply ap_compose.
  Qed.

  Lemma MonoidalFunctor_equiv_inverse_Grho
    : forall a : N, mg_rho (G a) = (mg_mm 1 G0 @ G2 a mg_e) @ ap G (mg_rho a).
  Proof.
    intros.
    refine ((ap_idmap _)^ @ moveL_Vp _ _ _ (homotopy_square h (mg_rho (G a))) @ _); (* 1 *)
    apply moveR_Vp; apply moveR_pM.
    refine (ap_compose F G _ @ ap (ap G) ((moveR_Vp _ _ _ (mg_drho (G a)))^ @ whiskerR (inv_pp _ _) _) @ ap_pp G _ _ @ whiskerR (ap_pp G _ _) _ @ concat_pp_p _ _ _ @ _);  (* 9 *)
    repeat rewrite ap_V;
    apply moveR_Vp; apply moveR_Vp.
    refine (_ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _); apply moveL_pV;
    refine (whiskerL _ (d' _) @ (ap_pp G _ _)^ @ ap (ap G) (rho_natural (k a)) @ ap_pp G _ _ @ _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _); (* 10 *)
    apply whiskerR.
    refine (moveL_Vp _ _ _ (homotopy_square_2 G mg_m mg_m G2 (k a) idpath) @ _); (* 11 *)
    apply moveR_Vp;
    refine (_ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _);
    apply whiskerR;
    refine (ap (fun z => mg_mm z idpath) (d' a)^ @ _).
    srapply (cancelL (mg_mm idpath G0) _ _ _);
    srefine (_ @ concat_pp_p _ _ _);
    refine (ap011_1qp1 mg_m (h (G a)) G0 @ (ap011_p11q mg_m (h (G a)) G0)^ @ _); (* 6 *)
    apply whiskerR.
    unfold G0, MonoidalFunctor_equiv_inverse_G0;
    refine (_ @ concat_p_pp _ _ _ @ whiskerR (concat2 (ap011_VV mg_m idpath (h mg_e))^ ((ap011_VV mg_m idpath (ap G mg_f0))^ @ ap (ap011 mg_m idpath) (ap_V G _)^) @ (ap011_1pp _ _ _)^) _); (* 7 *)
    apply moveL_Vp; apply moveL_Vp.
    refine (whiskerR (moveR_pV _ _ _ (homotopy_square_2 G mg_m mg_m G2 idpath mg_f0))^ _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ _); (* 8 *)
    apply whiskerL; refine (_ @ concat_p_pp _ _ _); apply whiskerL;
    apply moveR_Vp.
    refine (ap011_1qp1 mg_m (h (G a)) (h mg_e) @ _). (* 2 *)
    unfold G2, MonoidalFunctor_equiv_inverse_G2;
    refine (_ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _);
    apply moveL_Vp;
    refine (_ @ whiskerR (ap_V G _)^ _);
    apply moveL_Vp. (* 4 *)
    refine (_ @ concat_p_pp _ _ _ @ whiskerR ((ap_pp G _ _)^ @ ap (ap G) (homotopy_square_2 F mg_m mg_m mg_f2 (h (G a)) (h mg_e) @ whiskerR (ap011 (ap011 mg_m) (d _)^ (d _)^) _) @ ap_pp G _ _) _ @ concat_pp_p _ _ _); (* 5 *)
    apply whiskerL.
    refine (whiskerL _ (ap_idmap _)^ @ homotopy_square h (ap011 mg_m (h (G a)) (h mg_e)) @ _); (* 3 *)
    apply whiskerR; apply ap_compose.
  Qed.

Lemma MonoidalFunctor_equiv_inverse
  : MonoidalFunctor N M.
Proof.
  srapply @Build_MonoidalFunctor.
  + exact G.
  + exact G0.
  + exact G2.
  + exact MonoidalFunctor_equiv_inverse_Galpha.
  + exact MonoidalFunctor_equiv_inverse_Glambda.
  + exact MonoidalFunctor_equiv_inverse_Grho.
Defined.

Lemma MonoidalFunctor_equiv_inverse_Sect
  : MonoidalNatIso (MonoidalFunctor_comp MonoidalFunctor_equiv_inverse F) (MonoidalFunctor_id M).
Proof.
  srapply @Build_MonoidalNatIso; simpl.
  + exact h.
  + unfold G0, MonoidalFunctor_equiv_inverse_G0.
    refine (concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ _); apply moveR_Vp.
    refine (whiskerR (ap_V G _) _ @ _ @ (concat_p1 _)^); apply moveR_Vp; constructor.
  + intros; unfold G2, MonoidalFunctor_equiv_inverse_G2.
    refine (concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ _ @ (concat_p1 _)^);
    apply moveR_Vp.
    refine (whiskerR (ap_V G _) _ @ _);
    apply moveR_Vp.
    refine (concat_p_pp _ _ _ @ whiskerR ((ap_pp G _ _)^ @ ap (ap G) (whiskerR (ap011 mg_mm (d _) (d _)) _ @ (homotopy_square_2 F mg_m mg_m mg_f2 (h a) (h b))^) @ ap_pp G _ _) _ @ concat_pp_p _ _ _ @ _);
    apply whiskerL.
    refine (whiskerR (ap_compose _ _ _)^ _ @ _).
    refine ((homotopy_square h (ap011 mg_m (h a) (h b)))^ @ _);
    apply whiskerL; apply ap_idmap.
Defined.

Lemma MonoidalFunctor_equiv_inverse_Retr
  : MonoidalNatIso (MonoidalFunctor_comp F MonoidalFunctor_equiv_inverse) (MonoidalFunctor_id N).
Proof.
  srapply @Build_MonoidalNatIso; simpl.
  + exact k.
  + unfold G0, MonoidalFunctor_equiv_inverse_G0.
    refine (whiskerR (whiskerL _ (ap_pp F _ _ @ whiskerL _ (ap_compose _ _ _)^) @ concat_p_pp _ _ _) _ @ concat_pp_p _ _ _ @ _).
    refine (whiskerL _ ((homotopy_square k mg_f0^)^ @ whiskerL _ (ap_idmap _)) @ concat_p_pp _ _ _ @ _); apply moveR_pV.
    refine (concat_pp_p _ _ _ @ _ @ concat_p1 _ @ (concat_1p _)^); apply whiskerL.
    refine (whiskerR (ap_V F _) _ @ _); apply moveR_Vp; refine (_ @ (concat_p1 _)^).
    apply d.
  + intros; unfold G2, MonoidalFunctor_equiv_inverse_G2.
    repeat rewrite (ap_pp F _ _).
    refine (whiskerR (concat_p_pp _ _ _) _ @ concat_pp_p _ _ _ @ whiskerL _ (whiskerR (ap_compose _ _ _)^ _) @ _ @ (concat_p1 _)^).
    refine (whiskerL _ ((homotopy_square k (mg_mm (k a) (k b)))^ @ whiskerL _ (ap_idmap _)) @ concat_p_pp _ _ _ @ _ @ (concat_1p _)); apply whiskerR.
    repeat rewrite ap_V.
    repeat rewrite <- d.
    refine (concat_pp_p _ _ _ @ _); apply moveR_Mp.
    refine (concat_pp_p _ _ _ @ _ @ (concat_p1 _)^); apply moveR_Vp.
    repeat rewrite <- ap_V.
    repeat rewrite <- ap_compose.
    refine ((homotopy_square k (mg_f2 (G a) (G b))^)^ @ _); apply whiskerL; apply ap_idmap.
Qed.

Lemma MonoidalEquivalence_from_equivalence
  : MonoidalEquivalence M N.
Proof.
  exists F.
  exists MonoidalFunctor_equiv_inverse.
  exact (MonoidalFunctor_equiv_inverse_Sect, MonoidalFunctor_equiv_inverse_Retr).
Defined.

End Inverse.

End MonoidalGroupoids.


(* Exercise 21 *)

Require Import BenB.

Definition D:=R.

Variables P Q S T : D -> Prop.

Theorem exercise_021 : ~((forall x : D, P (x+2)) /\ (exists x : D, ~ P (x-3))).
Proof.
neg_i (forall x:D, P (x - 3)) a1.
exi_e (exists x:D, ~P (x - 3)) a a2.
con_e2 (forall x:D, P (x+2)).
hyp a1.
neg_i (P (a-3)) a3.
hyp a2.
all_e (forall x:D, P (x - 3)) a.
hyp a3.
all_i a.
neg_e' (forall x:D, P (x-3)) a2.
neg_i (P (a-3)) a3.
hyp a2.
all_e (forall x:D, P (x-3)) a.
hyp a3.
all_i b.
replace (b - 3) with (b - 5 + 2).
all_e (forall x:D, P (x + 2)) (b - 5).
con_e1 (exists x:D, ~P (x - 3)).
hyp a1.
lin_solve.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) (lf2 : natural)
  : natural := plus (Succ y) Zero.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (lf2 : natural) (y : natural) (x : natural)
  : natural := plus (Succ Zero) y.


Require Import  prosa.classic.util.all.
Require Import  prosa.classic.model.time
                prosa.classic.model.arrival.basic.task
                prosa.classic.model.arrival.basic.job.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop div.

Module PolicyTDMA.

  Import Time.

  (** In this section, we define the TDMA policy.*)
  Section TDMA.
    (* The TDMA policy is based on two properties.
      (1) Each task has a fixed, reserved time slot for execution;
      (2) These time slots are ordered in sequence to form a TDMA cycle, which repeats along the timeline.
      An example of TDMA schedule is illustrated in the following.
      ______________________________
      | s1 |  s2  |s3| s1 |  s2  |s3|...
      --------------------------------------------->
      0                                            t
    *)
    Variable Task: eqType.
    (* With each task, we associate the duration of the corresponding TDMA slot. *)
    Definition TDMA_slot:= Task -> duration.
    (* Moreover, within each TDMA cycle, task slots are ordered according to some relation. *)
    Definition TDMA_slot_order:= rel Task.

  End TDMA.

  (** In this section, we define the properties of TDMA and prove some basic lemmas. *)
  Section PropertiesTDMA.

    Context {Task:eqType}.

    (* Consider any task set ts... *)
    Variable ts: {set Task}.

    (* ...and any slot order (i.e, slot_order slot1 slot2 means that slot1 comes before slot2 in a TDMA cycle). *)
    Variable slot_order: TDMA_slot_order Task.

    (* First, we define the properties of a valid time slot order. *)
    Section Relation.
      (* Time slot order must transitive... *)
      Definition slot_order_is_transitive:= transitive slot_order.

      (* ..., totally ordered over the task set... *)
      Definition slot_order_is_total_over_task_set :=
        total_over_list slot_order ts.

      (* ... and antisymmetric over task set. *)
      Definition slot_order_is_antisymmetric_over_task_set :=
        antisymmetric_over_list slot_order ts.

    End Relation.

    (* Next, we define some properties of task time slots *)
    Section TimeSlot.

      (* Consider any task in task set ts*)
      Variable task: Task.
      Hypothesis H_task_in_ts: task \in ts.

      (* Consider any TDMA slot assignment for these tasks *)
      Variable task_time_slot: TDMA_slot Task.

      (* A valid time slot must be positive *)
      Definition is_valid_time_slot:=
        task_time_slot task > 0.

      (* We define the TDMA cycle as the sum of all the tasks' time slots *)
      Definition TDMA_cycle:=
        \sum_(tsk <- ts) task_time_slot tsk.

       (* We define the function returning the slot offset for each task:
         i.e., the distance between the start of the TDMA cycle and
         the start of the task time slot *)
      Definition Task_slot_offset:=
        \sum_(prev_task <- ts | slot_order prev_task task && (prev_task != task)) task_time_slot prev_task.

      (* The following function tests whether a task is in its time slot at instant t *)
      Definition Task_in_time_slot (t:time):=
       ((t + TDMA_cycle - (Task_slot_offset)%% TDMA_cycle) %% TDMA_cycle)
        < (task_time_slot task).

      Section BasicLemmas.

        (* Assume task_time_slot is valid time slot*)
        Hypothesis time_slot_positive:
          is_valid_time_slot.

        (* Obviously, the TDMA cycle is greater or equal than any task time slot which is
          in TDMA cycle *)
        Lemma TDMA_cycle_ge_each_time_slot:
          TDMA_cycle >= task_time_slot task.
        Proof.
        rewrite /TDMA_cycle (big_rem task) //.
        apply:leq_trans; last by exact: leq_addr.
        by apply leqnn.
        Qed.

        (* Thus, a TDMA cycle is always positive *)
        Lemma TDMA_cycle_positive:
          TDMA_cycle > 0.
        Proof.
        move:time_slot_positive. move/leq_trans;apply;apply TDMA_cycle_ge_each_time_slot.
        Qed.

        (* Slot offset is less then cycle *)
        Lemma Offset_lt_cycle:
          Task_slot_offset < TDMA_cycle.
        Proof.
        rewrite /Task_slot_offset /TDMA_cycle big_mkcond.
        apply leq_ltn_trans with (n:=\sum_(prev_task <- ts )if prev_task!=task then task_time_slot prev_task else 0).
        - apply leq_sum. intros* T. case (slot_order i task);auto.
        - rewrite -big_mkcond. rewrite-> bigD1_seq with (j:=task);auto.
          rewrite -subn_gt0 -addnBA. rewrite subnn addn0 //.
          trivial. apply (set_uniq ts).
        Qed.

        (* For a task, the sum of its slot offset and its time slot is
          less then or equal to cycle. *)
        Lemma Offset_add_slot_leq_cycle:
          Task_slot_offset + task_time_slot task <= TDMA_cycle.
        Proof.
        rewrite /Task_slot_offset /TDMA_cycle.
        rewrite addnC (bigD1_seq task) //=. rewrite leq_add2l.
        rewrite big_mkcond.
        replace (\sum_(i <- ts | i != task) task_time_slot i)
        with (\sum_(i <- ts ) if i != task then task_time_slot i else 0).
        apply leq_sum. intros*T. case (slot_order i task);auto.
        by rewrite -big_mkcond. apply (set_uniq ts).
        Qed.

      End BasicLemmas.

    End TimeSlot.

    (* In this section, we prove that no two tasks share the same time slot at any time. *)
    Section InTimeSlotUniq.

      (* Consider any TDMA slot assignment for these tasks *)
      Variable task_time_slot: TDMA_slot Task.

      (* Assume that slot order is total... *)
      Hypothesis slot_order_total:
        slot_order_is_total_over_task_set.

      (*..., antisymmetric... *)
      Hypothesis slot_order_antisymmetric:
        slot_order_is_antisymmetric_over_task_set.

      (*... and transitive. *)
      Hypothesis slot_order_transitive:
        slot_order_is_transitive.

      (* Then, we can prove that the difference value between two offsets is
        at least a slot *)
      Lemma relation_offset:
        forall tsk1 tsk2, tsk1 \in ts -> tsk2 \in ts ->
        slot_order tsk1 tsk2 -> tsk1 != tsk2 ->
        Task_slot_offset tsk2 task_time_slot >= Task_slot_offset tsk1 task_time_slot + task_time_slot tsk1 .
      Proof.
      intros* IN1 IN2 ORDER NEQ.
      rewrite /Task_slot_offset big_mkcond addnC.
      replace (\sum_(tsk <- ts | slot_order tsk tsk2 && (tsk != tsk2)) task_time_slot tsk)
        with (task_time_slot tsk1 + \sum_(tsk <- ts )if slot_order tsk tsk2 && (tsk != tsk1) && (tsk!=tsk2) then task_time_slot tsk else O).
      rewrite leq_add2l. apply leq_sum_seq. intros* IN T.
      case (slot_order i tsk1)eqn:SI2;auto. case (i==tsk1)eqn:IT2;auto;simpl.
      case (i==tsk2)eqn:IT1;simpl;auto.
      - by move/eqP in IT1;rewrite IT1 in SI2;apply slot_order_antisymmetric in ORDER;auto;apply ORDER in SI2;move/eqP in NEQ.
      - by rewrite (slot_order_transitive _ _ _ SI2 ORDER).
      - symmetry. rewrite big_mkcond /=. rewrite->bigD1_seq with (j:=tsk1);auto;last by apply (set_uniq ts).
        move/eqP /eqP in ORDER. move/eqP in NEQ. rewrite ORDER //=. apply /eqP.
        have TS2: (tsk1 != tsk2) = true . apply /eqP;auto. rewrite TS2.
        rewrite eqn_add2l. rewrite big_mkcond. apply/eqP. apply eq_bigr;auto.
        intros* T. case(i!=tsk1);case (slot_order i tsk2);case (i!=tsk2) ;auto.
      Qed.

      (* Then, we proved that no two tasks share the same time slot at any time. *)
      Lemma task_in_time_slot_uniq:
        forall tsk1 tsk2 t, tsk1 \in ts -> task_time_slot tsk1 > 0 ->
        tsk2 \in ts -> task_time_slot tsk2 > 0 ->
        Task_in_time_slot tsk1 task_time_slot t ->
        Task_in_time_slot tsk2 task_time_slot t ->
        tsk1 = tsk2.
      Proof.
      intros* IN1 SLOT1 IN2 SLOT2.
      rewrite /Task_in_time_slot.
      set cycle:=TDMA_cycle task_time_slot.
      set O1:= Task_slot_offset tsk1 task_time_slot.
      set O2:= Task_slot_offset tsk2 task_time_slot.
      have CO1: O1 < cycle by apply Offset_lt_cycle.
      have CO2: O2 < cycle by apply Offset_lt_cycle.
      have C: cycle > 0 by apply (TDMA_cycle_positive tsk1).
      have GO1:O1 %% cycle = O1 by apply modn_small,Offset_lt_cycle. rewrite GO1.
      have GO2:O2 %% cycle = O2 by apply modn_small,Offset_lt_cycle. rewrite GO2.
      have SO1:O1 + task_time_slot tsk1 <= cycle by apply (Offset_add_slot_leq_cycle tsk1).
      have SO2:O2 + task_time_slot tsk2 <= cycle by apply (Offset_add_slot_leq_cycle tsk2).
      repeat rewrite mod_elim;auto.
      case (O1 <= t%%cycle)eqn:O1T;case (O2 <= t %%cycle)eqn:O2T;intros G1 G2;try ssromega.
      apply util.nat.ltn_subLR in G1;apply util.nat.ltn_subLR in G2. case (tsk1==tsk2) eqn:NEQ;move/eqP in NEQ;auto.
      destruct (slot_order_total tsk1 tsk2) as [order |order];auto;apply relation_offset in order;
      fold O1 O2 in order;try ssromega;auto. by move/eqP in NEQ. apply /eqP;auto.
      Qed.

    End InTimeSlotUniq.

  End PropertiesTDMA.

End PolicyTDMA.


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

From Coq
  Require Import Arith List.

From KruskalTrees
  Require Import notations.

Import ListNotations.

Set Implicit Arguments.

Section list_sum.

  Variables (X : Type) (f : X -> nat).

  Fixpoint list_sum l :=
    match l with
      | []   => 0
      | x::l => f x + list_sum l
    end.

  Fact list_sum_app l m : list_sum (l++m) = list_sum l + list_sum m.
  Proof.
    induction l as [ | x l IHl ]; simpl; auto.
    now rewrite IHl, plus_assoc.
  Qed.

  Hint Resolve le_trans le_plus_l le_plus_r : core.

  Fact list_sum_in x l : x ∈ l -> f x <= list_sum l.
  Proof.
    induction l as [ | y l IHl ].
    + intros [].
    + intros [ <- | Hl%IHl ]; simpl; eauto.
  Qed.

End list_sum.


Require Import ZArith ROmega.
Open Scope Z_scope.

(* Pierre L: examples gathered while debugging romega. *)

Lemma test_romega_0 :
 forall m m',
  0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
Proof.
intros.
romega.
Qed.

Lemma test_romega_0b :
 forall m m',
  0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
Proof.
intros m m'.
romega.
Qed.

Lemma test_romega_1 :
 forall (z z1 z2 : Z),
    z2 <= z1 ->
    z1 <= z2 ->
    z1 >= 0 ->
    z2 >= 0 ->
    z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 ->
    z >= 0.
Proof.
intros.
romega.
Qed.

Lemma test_romega_1b :
 forall (z z1 z2 : Z),
    z2 <= z1 ->
    z1 <= z2 ->
    z1 >= 0 ->
    z2 >= 0 ->
    z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 ->
    z >= 0.
Proof.
intros z z1 z2.
romega.
Qed.

Lemma test_romega_2 : forall a b c:Z,
 0<=a-b<=1 -> b-c<=2 -> a-c<=3.
Proof.
intros.
romega.
Qed.

Lemma test_romega_2b : forall a b c:Z,
 0<=a-b<=1 -> b-c<=2 -> a-c<=3.
Proof.
intros a b c.
romega.
Qed.

Lemma test_romega_3 : forall a b h hl hr ha hb,
 0 <= ha - hl <= 1 ->
 -2 <= hl - hr <= 2 ->
 h =b+1 ->
 (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
 (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
 (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
 (-2 <= ha-hr <=2 -> hb = a  + 1) ->
 0 <= hb - h <= 1.
Proof.
intros.
romega.
Qed.

Lemma test_romega_3b : forall a b h hl hr ha hb,
 0 <= ha - hl <= 1 ->
 -2 <= hl - hr <= 2 ->
 h =b+1 ->
 (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
 (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
 (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
 (-2 <= ha-hr <=2 -> hb = a  + 1) ->
 0 <= hb - h <= 1.
Proof.
intros a b h hl hr ha hb.
romega.
Qed.

Lemma test_romega_4 : forall hr ha,
 ha = 0 ->
 (ha = 0 -> hr =0) ->
 hr = 0.
Proof.
intros hr ha.
romega.
Qed.

Lemma test_romega_5 : forall hr ha,
 ha = 0 ->
 (~ha = 0 \/ hr =0) ->
 hr = 0.
Proof.
intros hr ha.
romega.
Qed.

Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False.
Proof.
intros.
romega.
Qed.

Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False.
Proof.
intros z.
romega.
Qed.

Lemma test_romega_7 : forall z,
  0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
Proof.
intros.
romega.
Qed.

Lemma test_romega_7b : forall z,
  0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
Proof.
intros.
romega.
Qed.

(* Magaud #240 *)

Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x.
intros.
romega.
Qed.

Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x.
intros x y.
romega.
Qed.

(* Besson #1298 *)

Lemma test_romega9 : forall z z':Z, z<>z' -> z'=z -> False.
intros.
romega.
Qed.