Require Import Utf8 Lia.
Local Set Implicit Arguments.

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

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

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

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


(** 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 (y : natural) (lf2 : natural) : natural := Succ (plus y lf2).


Require Import ZArith.
Require Import Lists.List.
Import ListNotations.
Require Import Coq.extraction.ExtrOcamlNatInt.

(********************************************)
(* Languages definitions                    *)
(********************************************)

(* Logic language *)
Inductive logic : Set :=
  | Land  : logic -> logic -> logic
  | Lor   : logic -> logic -> logic
  | Limpl : logic -> logic -> logic
  | Lneg  : logic -> logic
  | Latom : nat -> logic.

(* Logic without impl *)
Inductive logic_1 : Set :=
  | L1and   : logic_1 -> logic_1 -> logic_1
  | L1or    : logic_1 -> logic_1 -> logic_1
  | L1neg   : logic_1 -> logic_1
  | L1atom  : nat -> logic_1.

(* Literals *)
Inductive literal : Set :=
  | Pos : nat -> literal
  | Neg : nat -> literal.

(* Logic_1 with distributed negations *)
Inductive logic_2 : Set :=
  | L2and   : logic_2 -> logic_2 -> logic_2
  | L2or    : logic_2 -> logic_2 -> logic_2
  | L2lit   : literal -> logic_2.

(* Clauses *)
Definition clause := list literal.

(* CNF *)
Definition logic_3 := list clause.

(* Conversion algorithm from logic to logic_1 *)
Fixpoint remove_impl (l : logic) : logic_1 :=
  match l with
  | Land a b =>
    L1and (remove_impl a) (remove_impl b)
  | Lor a b =>
    L1or (remove_impl a) (remove_impl b)
  | Limpl a b =>
    L1or (L1neg (remove_impl a)) (remove_impl b)
  | Lneg a => L1neg (remove_impl a)
  | Latom a => L1atom a
  end.

(* Conversion algorithm from logic_1 to logic_2 *)
Fixpoint remove_neg' (sign : bool) (l : logic_1) : logic_2 :=
  match l with
  | L1and a b =>
    if sign then L2and (remove_neg' sign a) (remove_neg' sign b)
    else L2or (remove_neg' false a) (remove_neg' false b)
  | L1or a b =>
    if sign then L2or (remove_neg' sign a) (remove_neg' sign b)
    else L2and (remove_neg' false a) (remove_neg' false b)
  | L1neg a =>
    if sign then remove_neg' false a
    else remove_neg' true a
  | L1atom n =>
    if sign then L2lit (Pos n)
    else L2lit (Neg n)
  end.

Definition remove_neg := remove_neg' true.

(* Distribute a clause on a set of clauses *)
Definition merge_clause (c : clause) (l : logic_3) :=
  map (fun c' => c ++ c') l.

(* Double distribute a set of clauses on another one *)
Fixpoint merge (l1 : logic_3) (l2 : logic_3) : logic_3 :=
  match l1 with
  | [] => []
  | c::cs => (merge_clause c l2) ++ (merge cs l2)
  end.

(* Logic_2 to logic_3 conversion *)
Fixpoint cnf' (l : logic_2) : logic_3 :=
  match l with
  | L2and a b => (cnf' a) ++ (cnf' b)
  | L2or a b => merge (cnf' a) (cnf' b)
  | L2lit a => [[a]]
  end.

(* CNF conversion *)
Definition cnf (l : logic) : logic_3 :=
    cnf' (remove_neg (remove_impl l)).

(********************************************)
(* Semantics for the intermediate languages *)
(********************************************)

(* Denotational semantic for the logic language *)
Fixpoint semL (l : logic) (v : nat -> bool) : bool :=
  match l with
  | Land a b =>
    andb (semL a v) (semL b v)
  | Lor a b =>
    orb (semL a v) (semL b v)
  | Limpl a b =>
    implb (semL a v) (semL b v)
  | Lneg a =>
    negb (semL a v)
  | Latom n => v n
  end.

(* Denotational semantic for the logic_1 language *)
Fixpoint semL1 (l : logic_1) (v : nat -> bool) : bool :=
  match l with
  | L1and a b =>
    andb (semL1 a v) (semL1 b v)
  | L1or a b =>
    orb (semL1 a v) (semL1 b v)
  | L1neg a =>
    negb (semL1 a v)
  | L1atom n => v n
  end.

(* Denotational semantic for the logic_2 language *)
Fixpoint semL2 (l : logic_2) (v : nat -> bool) : bool :=
  match l with
  | L2and a b =>
    andb (semL2 a v) (semL2 b v)
  | L2or a b =>
    orb (semL2 a v) (semL2 b v)
  | L2lit (Pos n) => v n
  | L2lit (Neg n) => negb (v n)
  end.

(* Denotational semantic for clauses *)
Fixpoint semC (c : clause) (v : nat -> bool) : bool :=
  match c with
  | [] => false
  | Pos n::xs => orb (v n) (semC xs v)
  | Neg n::xs => orb (negb (v n)) (semC xs v)
  end.

(* Denotational semantic for CNFs *)
Fixpoint semL3 (l : logic_3) (v : nat -> bool) : bool :=
  match l with
  | [] => true
  | c::cs => andb (semC c v) (semL3 cs v)
  end.

(********************************************)
(* Correction proofs                        *)
(********************************************)

(* [remove_impl] preserve the semantic *)
Theorem remove_impl_correct:
  forall l v, semL l v = semL1 (remove_impl l) v.
Proof.
  intros.
  induction l; simpl.
  - rewrite IHl1, IHl2; reflexivity.
  - rewrite IHl1, IHl2; reflexivity.
  - rewrite IHl1, IHl2; unfold implb; destruct semL1; reflexivity.
  - rewrite IHl; reflexivity.
  - reflexivity.
Qed.

(* [remove_neg' false] inverse the denotations *)
Lemma remove_neg_false_negb:
  forall l v, semL2 (remove_neg' false l) v = negb (semL2 (remove_neg' true l) v).
Proof.
  intros.
  induction l; simpl.
  - rewrite IHl1, IHl2, Bool.negb_andb; reflexivity.
  - rewrite IHl1, IHl2, Bool.negb_orb; reflexivity.
  - rewrite IHl, Bool.negb_involutive; reflexivity.
  - reflexivity.
Qed.

(* [remove_neg] preserve the semantic *)
Theorem remove_neg_correct:
  forall l v, semL1 l v = semL2 (remove_neg l) v.
Proof.
  intros.
  induction l; simpl.
  - rewrite IHl1, IHl2; reflexivity.
  - rewrite IHl1, IHl2; reflexivity.
  - rewrite IHl. unfold remove_neg. simpl.
    rewrite remove_neg_false_negb; reflexivity.
  - reflexivity.
Qed.

(* semantic of the union of two clauses *)
Theorem semC_union:
  forall c1 c2 v, semC (c1 ++ c2) v = orb (semC c1 v) (semC c2 v).
Proof.
  intros.
  induction c1; simpl.
  - reflexivity.
  - destruct a; rewrite IHc1, Bool.orb_assoc; reflexivity.
Qed.

(* semantic of the union of two set of clauses *)
Theorem semL3_union:
  forall c1 c2 v, semL3 (c1 ++ c2) v = andb (semL3 c1 v) (semL3 c2 v).
Proof.
  intros.
  induction c1; simpl.
  - reflexivity.
  - rewrite IHc1, Bool.andb_assoc; reflexivity.
Qed.

(* [merge_clause] preserve the semantic *)
Theorem merge_clause_correct:
  forall c l v, semL3 (merge_clause c l) v = orb (semC c v) (semL3 l v).
Proof.
  intros.
  induction l; simpl.
  - rewrite Bool.orb_comm. reflexivity.
  - rewrite semC_union, IHl, Bool.orb_andb_distrib_r; reflexivity.
Qed.

(* [merge] preserve the semantic *)
Theorem merge_correct:
  forall l1 l2 v, orb (semL3 l1 v) (semL3 l2 v) = semL3 (merge l1 l2) v.
Proof.
  intros.
  induction l1; simpl.
  - reflexivity.
  - rewrite semL3_union,
            merge_clause_correct,
            <- IHl1,
            Bool.orb_andb_distrib_l.
    reflexivity.
Qed.

(* [cnf'] preserve the semantic *)
Theorem cnf'_correct:
  forall l v, semL2 l v = semL3 (cnf' l) v.
Proof.
  intros.
  induction l; simpl.
  - rewrite semL3_union, IHl1, IHl2. reflexivity.
  - rewrite <- merge_correct, IHl1, IHl2. reflexivity.
  - destruct l; rewrite Bool.andb_comm, Bool.orb_comm; simpl; reflexivity.
Qed.

(* [cnf] preserve the semantic *)
Theorem cnf_correct:
  forall l v, semL l v = semL3 (cnf l) v.
Proof.
  intros.
  unfold cnf.
  rewrite remove_impl_correct,
          remove_neg_correct,
          cnf'_correct.
  reflexivity.
Qed.

Recursive Extraction cnf.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_betweennotequal.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

(* TODO: rename to lemma_onray_neq_A_C *)
Lemma lemma_onray_strict :
	forall A B C,
	OnRay A B C ->
	neq A C.
Proof.
	intros A B C.
	intros OnRay_AB_C.

	destruct OnRay_AB_C as (J & BetS_J_A_C & _).

	pose proof (lemma_betweennotequal _ _ _ BetS_J_A_C) as (neq_A_C & _).

	exact neq_A_C.
Qed.

End Euclid.


Set Implicit Arguments.
Require Import Arith.

Require Import set.
Require Import order.
Require Import order_elements.
Require Import subset.
Require Import equiv.
Require Import subset_elements.

Proposition subset_reflexive : forall (a:set), subset a a.
Proof.
  (* induction on the order of a *)
  cut(forall (n:nat) (a:set), order a <= n -> subset a a).
  intros H a. apply H with (n:= order a). apply le_n. intro n. elim n.
  (* order a <= 0 *)
  intros a H. cut (a = Empty). intro H'. rewrite H'. unfold subset. simpl.
  reflexivity. apply order_eq_0. symmetry. apply le_n_0_eq. exact H.
  (* order a <= S n *)
  clear n. intros n IH a H. cut(order a < S n \/ order a = S n). intro H'. elim H'.
  (* order a < S n *)
  intro H''. unfold lt in H''. apply IH. apply le_S_n. exact H''.
  (* order a = S n *)
  intro H''. apply subset_elements. intros x Hx. exists x. split. exact Hx.
  unfold equiv. cut (subset x x). intro Hx'. split. exact Hx'. exact Hx'.

  apply IH. apply le_S_n. rewrite <- H''. apply order_elements.
  exact Hx.
  (* clean up *)
  apply le_lt_or_eq. exact H.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Section Relation_Definition.

  Variable A : Type.

  Definition relation := A -> A -> Prop.

  Variable R : relation.

  Section General_Properties_of_Relations.

    Definition reflexive : Prop := forall x:A, R x x.
    Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z.
    Definition symmetric : Prop := forall x y:A, R x y -> R y x.
    Definition antisymmetric : Prop := forall x y:A, R x y -> R y x -> x = y.

    (* for compatibility with Equivalence in  ../PROGRAMS/ALG/  *)
    Definition equiv := reflexive /\ transitive /\ symmetric.

  End General_Properties_of_Relations.

  Section Sets_of_Relations.

    Record preorder : Prop :=
      { preord_refl : reflexive; preord_trans : transitive}.

    Record order : Prop :=
      { ord_refl : reflexive;
	ord_trans : transitive;
	ord_antisym : antisymmetric}.

    Record equivalence : Prop :=
      { equiv_refl : reflexive;
	equiv_trans : transitive;
	equiv_sym : symmetric}.

    Record PER : Prop :=  {per_sym : symmetric; per_trans : transitive}.

  End Sets_of_Relations.

  Section Relations_of_Relations.

    Definition inclusion (R1 R2:relation) : Prop :=
      forall x y:A, R1 x y -> R2 x y.

    Definition same_relation (R1 R2:relation) : Prop :=
      inclusion R1 R2 /\ inclusion R2 R1.

    Definition commut (R1 R2:relation) : Prop :=
      forall x y:A,
	R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.

  End Relations_of_Relations.

End Relation_Definition.

Hint Unfold reflexive transitive antisymmetric symmetric: sets.

Hint Resolve Build_preorder Build_order Build_equivalence Build_PER
  preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl
  equiv_trans equiv_sym per_sym per_trans: sets.

Hint Unfold inclusion same_relation commut: sets.


Set Warnings "-notation-overridden".
Require Import Equations.Type.Loader Equations.Type.Relation Equations.Type.WellFounded.
Import Id_Notations.

Section Lt.
  Inductive le : nat -> nat -> Set :=
    | le_0 x : le 0 x
    | le_S {x y} : le x y -> le (S x) (S y).

  Definition lt x y := le (S x) y.

  Lemma le_eq_lt x y : le x y -> (x = y) + (lt x y).
  Proof.
    induction 1. destruct x. left; constructor.
    right; constructor. constructor.
    dependent elimination IHle as [inl id_refl|inr Hlt].
    left; constructor. right; now constructor.
  Defined.

  Global Instance lt_wf : WellFounded lt.
  Proof.
    intros x. induction x.
    constructor. intros y Hy. depelim Hy.
    constructor. intros y Hy.
    dependent elimination Hy as [@le_S y x Hle].
    apply le_eq_lt in Hle.
    dependent elimination Hle as [inl id_refl|inr Hlt].
    assumption.
    destruct IHx. now apply a.
  Defined.

  Lemma lt_n_Sn n : lt n (S n).
  Proof.
    constructor.
    induction n; now constructor.
  Defined.
End Lt.

#[global]
Hint Resolve lt_n_Sn : Below.

(** Define non-dependent lexicographic products *)

Import Sigma_Notations.
Local Open Scope equations_scope.

Section Lexicographic_Product.

  Variable A : Type.
  Variable B : Type.
  Variable leA : relation A.
  Variable leB : relation B.

  Inductive lexprod : A * B -> A * B -> Type :=
    | left_lex :
      forall {x x':A} {y:B} {y':B},
        leA x x' -> lexprod (x, y) (x', y')
    | right_lex :
      forall {x:A} {y y':B},
        leB y y' -> lexprod (x, y) (x, y').

  Lemma acc_A_B_lexprod :
    forall x:A, Acc leA x -> (well_founded leB) ->
                forall y:B, Acc leB y -> Acc lexprod (x, y).
  Proof.
    induction 1 as [x _ IHAcc]; intros H2 y.
    induction 1 as [x0 H IHAcc0].
    apply Acc_intro.
    destruct y as [x2 y1]; intro Hlex.
    depelim Hlex. apply IHAcc; auto with relations.
    now apply IHAcc0.
  Defined.

  Theorem wf_lexprod :
    well_founded leA ->
    well_founded leB -> well_founded lexprod.
  Proof.
    intros wfA wfB; unfold well_founded.
    destruct x.
    apply acc_A_B_lexprod; auto with relations; intros.
  Defined.

End Lexicographic_Product.

#[export]
Instance wellfounded_lexprod A B R S `(wfR : WellFounded A R, wfS : WellFounded B S) :
  WellFounded (lexprod A B R S) := wf_lexprod A B R S wfR wfS.

#[global]
Hint Constructors lexprod : Below.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype.
From mathcomp Require Import tuple div path bigop prime finset fingroup perm.
Require Import Reals.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Some additional lemmas about ssrnat, seq, finset, tuple *)

Section ssrnat_ext.

Lemma leq_lt_predn : forall a b : nat, a < b -> a <= b.-1.
Proof. move=> a ; case ; first by rewrite ltn0.
move=> b Hab ; rewrite -ltnS prednK //. Qed.

Lemma mul2_inj a b : a.*2 = b.*2 -> a = b.
Proof. rewrite -!muln2; move/eqP; rewrite eqn_pmul2r //; by move/eqP. Qed.

Lemma nat_of_pos_not_0 : forall p, nat_of_pos p <> O.
Proof.
elim => // p H.
contradict H.
rewrite /= NatTrec.doubleE in H.
apply/eqP; rewrite -double_eq0; by apply/eqP.
Qed.

Lemma nat_of_pos_inj : forall i j, nat_of_pos i = nat_of_pos j -> i = j.
Proof.
elim=> [i Hi [] | i Hi [] | j /=].
- move=> j /= [].
  rewrite !NatTrec.doubleE => Hj; f_equal.
  by apply Hi, mul2_inj.
- move=> j /=.
  rewrite !NatTrec.doubleE => Hj.
  have absurd : odd ((nat_of_pos j).*2) by rewrite -Hj /= odd_double.
  by rewrite odd_double in absurd.
- rewrite /= NatTrec.doubleE.
  case => Habsurd.
  suff : False by done.
  move: (@nat_of_pos_not_0 i).
  by destruct (nat_of_pos i).
- move=> j /=.
  rewrite !NatTrec.doubleE => Hj.
  have absurd : odd ((nat_of_pos i).*2) by rewrite Hj /= odd_double.
  by rewrite odd_double in absurd.
- move=> j /= [].
  rewrite !NatTrec.doubleE => Hj; f_equal.
  by apply Hi, mul2_inj.
- rewrite /= NatTrec.doubleE => absurd.
  suff : False by done.
  move: (@nat_of_pos_not_0 i).
  by destruct (nat_of_pos i).
  destruct j => //=;
    rewrite NatTrec.doubleE => absurd ;
      have [//] : False ;
        move: (@nat_of_pos_not_0 j) => H' ;
          by destruct (nat_of_pos j).
Qed.

Lemma bin_of_nat_inj : forall a b, bin_of_nat a = bin_of_nat b -> a = b.
Proof.
move=> a b X.
have : nat_of_bin (bin_of_nat a) = nat_of_bin (bin_of_nat b) by rewrite X.
by rewrite 2!bin_of_natK.
Qed.

Lemma bin_of_nat_nat_of_pos_not_0 : forall i, bin_of_nat (nat_of_pos i) <> 0%num.
Proof.
elim=> // a Ha /=.
rewrite NatTrec.doubleE.
contradict Ha.
by destruct (nat_of_pos a).
Qed.

Lemma expn_2 : forall r, r <= (expn 2 r).-1.
Proof.
case=> // r; rewrite -subn1 ltn_subRL addnC addn1; by apply ltn_expl.
Qed.

End ssrnat_ext.

Section seq_ext.

Variables A B : Type.

Lemma behead_zip : forall n (a : seq A) (b : seq B),
  size a = n.+1 -> size b = n.+1 ->
  zip (behead a) (behead b) = behead (zip a b).
Proof.
elim.
by case=> // h1 [] // [].
by move=> m IH [|h1 t1] // [|h2 t2].
Qed.

Lemma zip_swap : forall (a : seq A) (b : seq B),
  zip a b = map (fun x => (x.2, x.1)) (zip b a).
Proof. elim => [ [] // | h t IH [|hd tl] //=]; by rewrite IH. Qed.

Lemma sumn_big_addn s : sumn s = \sum_ ( i <- s ) i.
Proof.
elim s => [|a l HR] /= ; first by rewrite big_nil.
by rewrite -cat1s big_cat /= big_seq1 HR.
Qed.

Lemma filter_flatten T u (s : seq (seq T)) : filter u (flatten s) = flatten (map (filter u) s).
Proof.
elim s => // hd tl HR.
rewrite -cat1s map_cat !flatten_cat filter_cat -HR.
f_equal ; by rewrite /flatten /= 2!cats0.
Qed.

Lemma drop_take_iota a b c : a <= b <= c ->
  drop a (take b (iota 0 c)) = filter (fun n => a <= n < b) (iota 0 c).
Proof.
move=> /andP [Hab Hbc].
set f := fun n => a <= n < b.
rewrite -(subnKC Hbc) iota_add take_cat size_iota subnn take0 add0n (ltnn b) cats0 filter_cat.
rewrite (_ : filter f (iota b (c-b)) = [::]) ; last first.
  apply/eqP/negPn ; rewrite -has_filter ; apply/hasPn => l.
  rewrite mem_iota (subnKC Hbc) /f negb_and => /andP [H _].
  by rewrite -leqNgt H orbT.
rewrite cats0 -(subnKC Hab) iota_add drop_cat size_iota subnn drop0 add0n (ltnn a) filter_cat.
rewrite (_ : filter f (iota 0 a) = [::]) ; last first.
  apply/eqP/negPn ; rewrite -has_filter ; apply/hasPn => l.
  rewrite mem_iota /f negb_and add0n => /andP [_ H].
  by rewrite -ltnNge H orTb.
rewrite cat0s.
symmetry ; apply/all_filterP/allP.
move=> l.
by rewrite mem_iota /f (subnKC Hab).
Qed.

Lemma take_take : forall (n m :nat) (s : seq A), take n (take (n + m) s) = take n s.
Proof.
elim=> [* | n0 IH m0 z0].
- by rewrite !take0.
- destruct z0 => //=; by rewrite IH.
Qed.

Lemma take_drop_take : forall m n (z : seq A),
  m + n <= size z -> take n (drop m (take (m + n) z)) = (drop m (take (m + n) z)).
Proof.
elim=> [n0 z Hsz | m IH n1 [|hd tl] //=].
- rewrite drop0 add0n take_oversize // size_take.
  case: ifP => // {Hsz}.
  move/negbT; by rewrite -leqNgt.
rewrite addnC addnS => ?; by rewrite IH // addnC.
Qed.

Lemma zip_mask : forall bs (al : seq A) (bl : seq B),
  zip (mask bs al) (mask bs bl) = mask bs (zip al bl).
Proof.
elim=> // h t IH [|a1 a2] [|b1 b2] //=.
- destruct h => //=; by case: mask.
- destruct h => //=; by case: mask.
- destruct h => /=; by rewrite IH.
Qed.

Lemma nseq_add : forall n (a : A) m, nseq (n + m) a = nseq n a ++ nseq m a.
Proof. elim=> // n0 IH a m; by rewrite addSn /= IH. Qed.

Variable def : A.

Lemma nseq_S : forall n, nseq n.+1 def = nseq n def ++ [:: def].
Proof. by elim=> //= n <-. Qed.

Lemma rev_nseq : forall n, rev (nseq n def) = nseq n def.
Proof. elim=> // n H; by rewrite nseq_S rev_cat H /= -nseq_S. Qed.

Lemma nseq_cat : forall (l1 l2 : seq A) n n1, size l1 = n1 ->
  l1 ++ l2 = nseq n def ->
  l1 = nseq n1 def /\ l2 = nseq (n - n1) def.
Proof.
elim/last_ind => [l2 n [] // _ /= ? | h1 t1 IH l2 n []].
- by rewrite subn0.
- by rewrite size_rcons.
- move=> n1; rewrite size_rcons; move=> [] Hh1.
  rewrite cat_rcons => X.
  destruct n.
  * by destruct h1.
  * have [i Hi] : exists i, n.+1 - n1 = i.+1.
      rewrite subSn; last first.
        match goal with | X : ?a = ?b |- _ =>
          have {X}X : (size a = size b) by rewrite X
        end.
        rewrite size_nseq size_cat /= addnS Hh1 in X.
        move/eqP : X; rewrite eqSS; move/eqP => <-.
        by apply leq_addr.
      by exists (n - n1).
   case: (IH (t1 :: l2) _ _ Hh1 X) => IH1.
   rewrite Hi; case=> IH2 IH3; subst t1.
   rewrite nseq_S IH1 -cat_rcons cats0 subSS.
   split; first by done.
   rewrite subSn in Hi; last first.
     have -> : n = (size (nseq n.+1 def)).-1.
       by rewrite size_nseq.
     rewrite -X size_cat /= addnS /= Hh1; by apply leq_addr.
   by case: Hi => ->.
Qed.

Lemma map_nil_inv : forall (f : A -> B) (l : seq A), map f l = [::] -> l = [::].
Proof. by move=> f; case. Qed.

End seq_ext.

Section seq_eqType_ext.

Variables A B : eqType.

Lemma mem_nseq (l : A) k (i : A) : l \in nseq k i -> (l == i).
Proof.
have : nseq k i = nseq (size (nseq k i)) i by rewrite size_nseq.
by move/all_pred1P/allP/(_ l).
Qed.

Lemma in_cat (s : seq A) x : x \in s -> exists hd tl, s = hd ++ x :: tl.
Proof.
elim: s => // h t IH; rewrite in_cons; case/orP.
- move/eqP => ?; subst h.
  by exists [::], t.
- case/IH => h1 [] t1 ht1.
  exists (h ::h1), t1 => /=.
  congruence.
Qed.

Lemma rev_inj : forall (a b : seq A), rev a = rev b -> a = b.
Proof.
elim => [ [] // hb tb | ta ha IH [| hb tb] //].
- rewrite rev_cons -cats1; by destruct (rev tb).
- rewrite rev_cons -cats1; by destruct (rev ha).
- rewrite !rev_cons.
  move/eqseqP; rewrite eqseqE eqseq_rcons.
  case/andP; move/eqP; move/IH => ->; by move/eqP => ->.
Qed.

Lemma sorted_cat (l1 l2 : seq A) (Rel : @rel A) :
  sorted Rel l1 -> sorted Rel l2 ->
  (forall a, a \in l1 -> forall b, b \in l2 -> Rel a b) ->
  sorted Rel (l1 ++ l2).
Proof.
move=> Hl1 Hl2 H.
destruct l1 => //.
rewrite /sorted /= cat_path.
rewrite /sorted in Hl1.
apply/andP; split => //.
destruct l2 => //.
rewrite /sorted in Hl2.
rewrite /= Hl2 andbC /=.
apply H.
by rewrite mem_last.
by rewrite in_cons eqxx.
Qed.

Lemma sorted_is_flattened leT (Htrans : transitive leT) (Hanti : antisymmetric leT) (Hrefl : reflexive leT) : forall n (lst v : seq A),
  n = size lst -> uniq lst -> sorted leT lst ->
  sorted leT v -> (forall i, i \in v -> i \in lst) ->
  v = flatten (map (fun elt => filter (pred1 elt) v) lst).
Proof.
elim=> /=.
  case=> //.
  move=> v _ _ _ Hv H.
  destruct v => //.
  suff : false by done.
  move: (H s).
  rewrite in_cons eqxx /= in_nil.
  by apply.
move=> n0 IH [|hd tl] // v [lst_sz] lst_uniq lst_sorted v_sorted Hincl.
have X1 : v = filter (pred1 hd) v ++ filter (predC (pred1 hd)) v.
  apply eq_sorted with leT => //.
  - apply: sorted_cat.
    + by apply sorted_filter.
    + by apply sorted_filter.
    + move=> a.
      rewrite mem_filter.
      case/andP => /= /eqP ?; subst hd => av b.
      rewrite mem_filter.
      case/andP => /= ba bv.
      apply Hincl in bv.
      rewrite in_cons in bv.
      case/orP : bv.
      * move/eqP => ?; by subst b.
      * move=> btl.
        rewrite /sorted in lst_sorted.
        move: (@subseq_order_path _ _ (Htrans) a [:: b] tl).
        rewrite /= andbC /=.
        apply => //; by rewrite sub1seq.
  - rewrite perm_eq_sym; by apply perm_eqlE, perm_filterC.
rewrite {1}X1 {X1} /=.
f_equal.
simpl in lst_uniq. case/andP : lst_uniq => hdtl tl_uniq.
rewrite (IH tl (filter (predC (pred1 hd)) v) lst_sz tl_uniq).
- f_equal.
  apply eq_in_map => i i_tl.
  rewrite -filter_predI.
  apply eq_in_filter => j j_v /=.
  case/orP : (orbN ( j == i)) => ij.
  + rewrite ij /=.
    apply/negP.
    move/eqP => ?; subst j.
    move/eqP : ij => ?; subst i.
    by rewrite i_tl in hdtl.
  + move/negbTE in ij;  by rewrite ij.
- destruct tl => //=.
  rewrite /= in lst_sorted.
  by case/andP : lst_sorted.
- apply sorted_filter => //.
- move=> i.
  rewrite mem_filter.
  case/andP => /= Hi.
  move/Hincl.
  rewrite in_cons.
  case/orP => // /eqP.
  move=> ?; subst i.
  by rewrite eqxx in Hi.
Qed.

Lemma filter_zip_L m (al : seq A) (bl : seq B) a :
  size al = m -> size bl = m ->
  filter (fun x => x.1 == a) (zip al bl) =
  zip (filter (pred1 a) al) (mask (map (pred1 a) al) bl).
Proof.
move=> mal mbl.
rewrite filter_mask.
symmetry. rewrite filter_mask zip_mask. symmetry.
f_equal.
elim: m al bl mal mbl a.
  case=> //; by case.
move=> m IHm [|a1 a2] // [|b1 b2] // [sza2] [szb2] a /=; by rewrite IHm.
Qed.

Lemma filter_zip_R m (al : seq A) (bl : seq B) b :
  size al = m -> size bl = m ->
  filter (fun x => x.2 == b) (zip al bl) =
  zip (mask (map (pred1 b) bl) al)
     (filter (pred1 b) bl).
Proof.
move=> mal mbl.
rewrite filter_mask.
symmetry. rewrite filter_mask zip_mask. symmetry.
f_equal.
elim: m al bl mal mbl b.
  case=> //; by case.
move=> m IHm [|a1 a2] // [|b1 b2] // [sza2] [szb2] b /=; by rewrite IHm.
Qed.

Lemma undup_nil_inv : forall (l : seq A), undup l = [::] -> l = [::].
Proof.
elim=> // h t IH /=.
case/orP : (orbN (h \in t)) => X.
rewrite X; move/IH => ?; by subst t.
by rewrite (negbTE X).
Qed.

Lemma undup_filter : forall (P : pred B) x, undup (filter P x) = filter P (undup x).
move=> P; elim=> // h t IH /=.
case/orP : (orbN (P h)) => X.
- rewrite X /=.
  case/orP : (orbN (h \in t)) => Y.
  + rewrite Y /=.
    have -> : h \in filter P t by rewrite mem_filter X Y.
    done.
  + rewrite (negbTE Y).
    have -> : h \in filter P t = false by rewrite mem_filter (negbTE Y) andbC.
    by rewrite IH /= X.
- rewrite (negbTE X) IH.
  case/orP : (orbN (h \in t)) => Y.
  + by rewrite Y.
  + by rewrite (negbTE Y) /= (negbTE X).
Qed.

Lemma undup_perm : forall (f : A -> B) p h t, undup (map f p) = h :: t ->
  exists preh : seq A,
    exists pret : seq A,
      perm_eq p (preh ++ pret) /\
      undup (map f preh) = [:: h] /\ undup (map f pret) = t.
Proof.
move=> f p h t p_t.
exists (filter (preim f [pred x | x == h]) p), (filter (preim f [pred x | x \in t]) p).
split.
- apply/perm_eqlP => x.
  rewrite -(@perm_filterC A (preim f [pred x | (x == h)]) p).
  move: x.
  apply/perm_eqlP.
  rewrite perm_cat2l (@eq_in_filter _ _ [pred x | (f x \in t)]) //.
  move=> x X /=.
  case/orP : (orbN (f x == h)) => Y.
  + rewrite Y /=.
    symmetry.
    apply/negP => abs.
    move/eqP : Y => Y; subst h.
    have : uniq (f x :: t).
      rewrite -p_t; by apply undup_uniq.
    by rewrite /= abs.
  - rewrite Y.
    symmetry.
    have Htmp : f x \in map f p by apply/mapP; exists x.
    have {Htmp}Htmp : f x \in h :: t by rewrite -p_t mem_undup.
    rewrite in_cons in Htmp.
    case/orP : Htmp => [Htmp|->//].
    by rewrite Htmp in Y.
- split.
  + rewrite -filter_map undup_filter p_t /= eqxx.
    have -> : filter [pred x | x == h] t = [::]; last by done.
    apply trans_eq with (filter pred0 t); last by apply filter_pred0.
    apply eq_in_filter => i Hi /=.
    apply/negP => X.
    move/eqP : X => X; subst h.
    have : uniq (i :: t).
      rewrite -p_t; by apply undup_uniq.
    rewrite /=.
    case/andP => H1 H2.
    by rewrite Hi in H1.
  + rewrite -filter_map undup_filter p_t /=.
    have -> : h \in t = false.
      apply/negP => X.
      have : uniq (h :: t).
        rewrite -p_t.
        by apply undup_uniq.
      by rewrite /= X.
    apply trans_eq with (filter predT t); last by apply filter_predT.
    by apply eq_in_filter.
Qed.

End seq_eqType_ext.

Section ordered_ranks.

Variable X : finType.

Definition le_rank (x y : X) := enum_rank x <= enum_rank y.

Definition lt_rank x y := le_rank x y && (x != y).

Lemma lt_rank_alt x0 x1 : lt_rank x0 x1 = (enum_rank x0 < enum_rank x1).
Proof.
rewrite /lt_rank /le_rank ltn_neqAle andbC.
apply andb_id2r => _.
case/orP : (orbN (x0 != x1)) => Hcase.
- rewrite Hcase.
  symmetry ; apply/eqP => abs ; move: Hcase.
  apply/negP/negPn/eqP.
  apply: enum_rank_inj => /=.
  by apply ord_inj.
- move/negbTE in Hcase ; rewrite Hcase ; move/negbT/negPn/eqP in Hcase.
  symmetry ; apply/eqP ; by subst.
Qed.

Definition sort_le_rank : seq X -> seq X := sort le_rank.

Variable n : nat.

Definition sort_le_rank_tuple (y : n.-tuple X) : n.-tuple X.
apply Tuple with (sort_le_rank y).
by rewrite size_sort size_tuple.
Defined.

Lemma transitive_le_rank : transitive le_rank.
Proof. rewrite /le_rank /transitive => a b c /leq_trans; by apply. Qed.

Lemma reflexive_le_rank : reflexive le_rank.
Proof. by rewrite /le_rank /reflexive => a. Qed.

Lemma antisymmetric_le_rank : antisymmetric le_rank.
Proof.
rewrite /le_rank /antisymmetric => a b H ; apply enum_rank_inj.
rewrite -eqn_leq in H ; by apply/eqP.
Qed.

Lemma total_le_rank : total le_rank.
Proof.
rewrite /total /le_rank => a b.
case/orP : (orbN (enum_rank a <= enum_rank b)) ; move=> Hcase ; first by rewrite Hcase /=.
move/negbTE in Hcase ; rewrite Hcase /= ; move/negbT in Hcase ; rewrite -ltnNge in Hcase ; by apply ltnW.
Qed.

Lemma lt_le_rank_trans (u v w : X) : lt_rank u v -> le_rank v w -> lt_rank u w.
Proof.
rewrite /lt_rank.
move=> /andP [Huv Diffuv] Hvw.
case/orP : (orbN (u != w)) => Hcase.
- rewrite Hcase andbT.
  apply (transitive_le_rank Huv Hvw).
- move/negPn/eqP in Hcase.
  subst w.
  contradict Diffuv.
  apply/negP/negPn/eqP.
  apply antisymmetric_le_rank.
  by rewrite Huv Hvw.
Qed.

Lemma le_lt_rank_trans (u v w : X) : le_rank u v -> lt_rank v w -> lt_rank u w.
Proof.
rewrite /lt_rank.
move=> Huv /andP [Hvw Diffvw].
case/orP : (orbN (u != w)) => Hcase.
- rewrite Hcase andbT.
  apply (transitive_le_rank Huv Hvw).
- move/negPn/eqP in Hcase.
  subst w.
  contradict Diffvw.
  apply/negP/negPn/eqP.
  apply antisymmetric_le_rank.
  by rewrite Huv Hvw.
Qed.

Lemma lt_le_rank_weak (u v : X) : lt_rank u v -> le_rank u v.
Proof. by rewrite /lt_rank => /andP [H _]. Qed.

Lemma lt_neq_rank (u v : X) : lt_rank u v -> u != v.
Proof. by rewrite /lt_rank => /andP [_ H]. Qed.

End ordered_ranks.

Section finset_ext.

Variable A : finType.

Lemma seq_index_enum_card : forall l (Y : {set A}) i,
  l =i enum Y -> uniq l ->
  i \in Y -> (seq.index i l < #| Y |)%nat.
Proof.
elim => [Y i Hl Hl' Hi | h t IH Y i Hl Hl' Hi /= ].
  have {Hi}Hi : i \in enum Y by rewrite mem_enum.
  by rewrite -Hl in Hi.
case: ifP => // Hif.
  rewrite card_gt0.
  apply/negP.
  move/eqP => Habs.
  by rewrite Habs inE in Hi.
apply leq_ltn_trans with (#|Y :\ h|); last first.
  rewrite (cardsD1 h Y).
  suff : h \in Y by move=> ->; rewrite addnC addn1.
  by rewrite -mem_enum -Hl in_cons eqxx.
apply IH.
- move=> j.
  move H1 : (j \in (enum (Y :\ h))) => [].
    rewrite mem_enum in_setD1 in H1.
    case/andP : H1 => H1.
    rewrite -mem_enum -Hl in_cons.
    case/orP => H1' //.
    by rewrite H1' in H1.
  move: H1.
  rewrite mem_enum in_setD1.
  move/negbT.
  rewrite negb_and.
  case/orP => [|H1].
  - move/negPn/eqP => ?; subst j.
      apply/negP => Habs'.
      rewrite /= in Hl'.
      by rewrite Habs' in Hl'.
  - rewrite -mem_enum -Hl in H1.
    apply/negP/negP.
    move: H1; apply: contra.
    rewrite in_cons.
    move=> ->; by rewrite orbC.
- rewrite /= in Hl'; by case/andP: Hl'.
- apply/setD1P.
  move/negbT in Hif.
  split; last by done.
  move: Hif.
  apply contra.
  by move/eqP => ->.
Qed.

Lemma sorted_enum : sorted (@le_rank A) (enum A).
Proof.
rewrite /sorted.
move HA : (enum A) => Alst.
destruct Alst => //.
apply/(pathP s) => i Hi.
rewrite /le_rank -HA.
destruct Alst => //.
have Hi' : (i < #|A|)%nat.
  rewrite cardE HA.
  by apply (ltn_trans Hi).
rewrite -(@enum_val_nth A (xpredT) s (Ordinal Hi')).
have Hi'' : (i.+1 < #|A|)%nat.
  rewrite cardE HA.
  by apply (leq_ltn_trans Hi).
have -> : (nth s (s0 :: Alst) i) = (nth s (enum A) i.+1).
  by rewrite /= HA.
rewrite -(@enum_val_nth A (xpredT) s (Ordinal Hi'')).
rewrite 2!enum_valK.
by apply leqnSn.
Qed.

Lemma cardsltn1P (s : {set A}) :
  (1 < #| s |) = [exists a, exists b, (a \in s) && (b \in s) && (a != b)].
Proof.
case/boolP : (s == set0) => [ /eqP -> | /set0Pn [] /= a Ha ].
  rewrite cards0 /=.
  apply/esym/negbTE.
  rewrite negb_exists.
  apply/forallP => a.
  rewrite negb_exists.
  apply/forallP => b.
  by rewrite !inE.
case/boolP : (s :\ a == set0) => [sa | ].
  have Hs : s == [set a].
    apply/eqP/setP => /= a'.
    move/eqP/setP/(_ a') in sa.
    rewrite !inE in sa.
    move/negbT in sa.
    rewrite negb_and negbK in sa.
    case/orP : sa => sa.
      move/eqP in sa; subst a'.
      by rewrite inE eqxx.
    rewrite (negbTE sa) inE.
    apply/esym/negbTE.
    apply/eqP => ?; subst a'.
    by rewrite Ha in sa.
  rewrite (eqP Hs) cards1.
  apply/esym/negbTE.
  rewrite negb_exists.
  apply/forallP => b.
  rewrite negb_exists.
  apply/forallP => c.
  rewrite 2!in_set1.
  case/boolP : (b == c).
    move/eqP => ?; subst c; by rewrite /= andbC.
  rewrite /= andbT negb_and => bc.
  case/boolP : (b == a) => // /eqP ?; subst b => /=; by rewrite eq_sym.
case/set0Pn => b Hb.
have -> : 1 < #| s |.
  by rewrite (cardsD1 a s) Ha /= (cardsD1 b (s :\ a)) Hb.
apply/esym; apply/existsP; exists a; apply/existsP; exists b.
rewrite !inE eq_sym in Hb.
case/andP : Hb => -> ->; by rewrite Ha.
Qed.

End finset_ext.

Lemma ord0_false : forall i : 'I_0, False.
Proof. by case=> [] []. Qed.

Lemma ord1 : forall i : 'I_1, i = ord0. Proof. case=> [[]] // ?; exact/eqP. Qed.

Module Two_set.

Section two_set.

Variable X : finType.

Hypothesis HX : #|X| = 2%nat.

Definition val0 := enum_val (cast_ord (sym_eq HX) ord0).

Definition val1 := enum_val (cast_ord (sym_eq HX) (lift ord0 ord0)).

Lemma enum : enum X = val0 :: val1 :: [::].
Proof.
apply (@eq_from_nth _ val0); first by rewrite -cardE HX.
move=> i Hi.
destruct i.
  by rewrite [X in _ = X]/= {2}/val0 (enum_val_nth val0).
destruct i; last first.
  rewrite -cardE HX in Hi.
  by destruct i.
by rewrite [X in _ = X]/= {1}/val1 (enum_val_nth val0).
Qed.

Lemma val0_neq_val1 : val0 != val1.
Proof. rewrite /val0 /val1. apply/eqP. by move/enum_val_inj. Qed.

Lemma neq_val0_val1 : forall x, x != val0 -> x == val1.
Proof.
move=> x xi.
have : x \in X by done.
rewrite -mem_enum enum !inE.
case/orP => // abs.
by rewrite abs in xi.
Qed.

End two_set.

End Two_set.

Notation "t '\_' i" := (tnth t i) (at level 9) : tuple_ext_scope.

Local Open Scope tuple_ext_scope.

Section tuple_ext.

Variable A : Type.

Lemma tcast_take_simpl n m k (H : minn n k = m) (nk : n = k) (t v : k.-tuple A) :
  tcast H [tuple of take n t] = tcast H [tuple of take n v] -> t = v.
Proof.
subst m => /=.
subst n; case => /= Htv.
apply eq_from_tnth => i.
by rewrite (tnth_nth t\_i) [in X in _ = X](tnth_nth t\_i) -(@nth_take k) // -[in X in _ = X](@nth_take k) // Htv.
Qed.

End tuple_ext.

Section tuple_ext_finType.

Variables A B : finType.
Variable n : nat.

Lemma tnth_zip_1 (x1 : n.-tuple A) (x2 : n.-tuple B) i:
  (tnth [tuple of zip x1 x2] i).1 = tnth x1 i.
Proof.
rewrite /tnth.
set def := tnth_default _ _.
destruct def as [def1 def2].
rewrite nth_zip /=; last by rewrite !size_tuple.
apply set_nth_default.
by rewrite size_tuple.
Qed.

Lemma tnth_zip_2 (x1 : n.-tuple A) (x2 : n.-tuple B) i:
  (tnth [tuple of zip x1 x2] i).2 = tnth x2 i.
Proof.
rewrite /tnth.
set def := tnth_default _ _.
destruct def as [def1 def2].
rewrite nth_zip /=; last by rewrite !size_tuple.
apply set_nth_default.
by rewrite size_tuple.
Qed.

Lemma thead_tuple1 : forall (i : 1.-tuple A), [tuple thead i] = i.
Proof. move=> [ [|h []] H] //. by apply val_inj. Qed.

Lemma eq_tcast (t : {:n.-tuple A}) m (t' : {:m.-tuple A}) (H' : m = n) :
  tval t = tval t' -> t = tcast H' t'.
Proof.
subst m.
rewrite tcast_id.
move=> tt'.
by apply val_inj.
Qed.

Lemma eq_tcast2 (t : seq A) m (t' : {:m.-tuple A}) (H : m = n) :
  t = tval t' -> t = tval (tcast H t').
Proof. subst m. by rewrite tcast_id. Qed.

End tuple_ext_finType.

Definition tbehead (n : nat) (T : Type) (t : (n.+1).-tuple T) : n.-tuple T :=
  [tuple of behead t].

Section perm_tuples.

Local Open Scope nat_scope.
Local Open Scope group_scope.

Variables A : finType.
Variable n : nat.
Variable s : 'S_n.

Definition perm_tuple (t : n.-tuple A) : n.-tuple A := [tuple (t \_ (s i)) | i < n].
Definition perm_tuple_set (E : {set n.-tuple A}) := perm_tuple @: E.

End perm_tuples.

Section perm_tuples_facts.

Variable A : finType.

Local Open Scope group_scope.

Lemma perm_tuple_id {m} (b : m.-tuple A) : perm_tuple 1 b = b.
Proof.
apply eq_from_tnth => i.
by rewrite /perm_tuple /= tnth_map /= perm1 tnth_ord_tuple.
Qed.

Variable n : nat.

Lemma perm_tuple_comp (s1 s2 : 'S_n) (b : n.-tuple A) :
  perm_tuple s1 (perm_tuple s2 b) = perm_tuple (s1 * s2) b.
Proof.
apply eq_from_tnth => i.
by rewrite /perm_tuple !tnth_map /= tnth_ord_tuple permM.
Qed.

Lemma perm_tuple_inj (s : 'S_n) : injective (@perm_tuple A n s).
Proof.
rewrite /injective.
move=> a b H.
have H2 : perm_tuple 1 a = perm_tuple 1 b.
- rewrite -(mulVg s).
  rewrite -!perm_tuple_comp.
  f_equal ; apply H.
rewrite !perm_tuple_id in H2 ; apply H2.
Qed.

Lemma perm_tuple0 : forall (u : 'S_0) (t : 0.-tuple A), perm_tuple u t = t.
Proof.
move=> u t.
rewrite (tuple0 t).
have -> : u = 1%g.
  apply/permP => /= x.
  suff : False by done.
  by move/ord0_false in x.
by rewrite perm_tuple_id.
Qed.

Variable B : finType.

Lemma zip_perm_tuple (ta : n.-tuple A) (tb : n.-tuple B) (s : 'S_n) :
  zip_tuple (perm_tuple s ta) (perm_tuple s tb) = perm_tuple s (zip_tuple ta tb).
Proof.
apply eq_from_tnth.
case.
destruct n => //.
case=> [Hi | i Hi].
  rewrite (tnth_nth (thead ta, thead tb)) (tnth_nth (thead (zip_tuple ta tb))).
  rewrite /= enum_ordS /= (tnth_nth (thead ta, thead tb)) /= nth_zip; last
    by rewrite (size_tuple ta) (size_tuple tb).
  by rewrite (tnth_nth (thead ta)) /= (tnth_nth (thead tb)) /=.
rewrite (tnth_nth (thead ta, thead tb)) (tnth_nth (thead (zip_tuple ta tb))) /= enum_ordS /=.
rewrite ltnS in Hi.
rewrite nth_zip; last by rewrite 4!size_map size_enum_ord.
symmetry.
rewrite (nth_map ord0); last by rewrite size_map size_enum_ord.
rewrite (tnth_nth (thead ta, thead tb)) /zip_tuple /=.
rewrite nth_zip; last by rewrite (size_tuple ta) (size_tuple tb).
symmetry.
rewrite (nth_map ord0); last by rewrite size_map size_enum_ord.
rewrite (nth_map ord0); last by rewrite size_map size_enum_ord.
by rewrite (tnth_nth (thead ta)) (tnth_nth (thead tb)).
Qed.

End perm_tuples_facts.

Lemma tcast2tval (T : Type) (m n0 : nat) (H : m = n0) : forall (v : m.-tuple T) w,
  tcast H v = w -> tval v = tval w.
Proof. subst n0. by move=> [v Hv] [w Hw] <- /=. Qed.


Require Import HoTT.
Require Import UnivalenceAxiom.

From GCTT Require Import path_lemmas.

(** We definine the type of monoidal 1-Types (this corresponds to a monoidal category)*)
Definition associative {A : Type}  (m : A-> A -> A) := forall (a b c: A),  m (m a b) c = m a (m b c).
Definition left_identity_mult {A : Type} (m : A->A->A) (e : A) := forall a : A, m e a = a.
Definition right_identity_mult {A : Type} (m : A->A->A) (e : A) := forall a : A, m a e = a.

(* Unneccesary but perhaps easier to just assume *)
Definition coherence_triangle1 {A : Type} {m : A -> A -> A} {e : A}
           (assoc : associative m) (lid : left_identity_mult m e)  :=
  forall a b : A,
    ap (fun x => m x b) (lid a) = assoc e a b @ lid (m a b).

Definition coherence_triangle2 {A : Type} {m : A -> A -> A} {e : A}
           (assoc : associative m) (lid : left_identity_mult m e) (rid : right_identity_mult m e) :=
  forall a b : A,
    ap (fun c => m c b) (rid a) = assoc a e b @ ap (m a) (lid b).

Definition coherence_pentagon {A : Type} {m : A -> A -> A} (assoc : associative m) :=
  forall a b c d: A,
    ap (fun x => m x d) (assoc a b c) =
    assoc (m a b) c d @ assoc a b (m c d) @ (ap (m a) (assoc b c d))^ @ (assoc a (m b c) d)^.

Record Monoidal_1Type : Type := { montype_type :> 1-Type;
                                  montype_mult  : montype_type->montype_type->montype_type;
                                  montype_id : montype_type;
                                  montype_assoc : associative montype_mult;
                                  montype_lid : left_identity_mult montype_mult montype_id ;
                                  montype_rid : right_identity_mult montype_mult montype_id ;
                                  montype_triangle1 : coherence_triangle1 montype_assoc montype_lid ;
                                  montype_triangle2 : coherence_triangle2 montype_assoc montype_lid montype_rid ;
                                  montype_pentagon : coherence_pentagon montype_assoc
                                }.

Global Arguments montype_mult {M} a b : rename.
Global Arguments montype_id {M} : rename.
Global Arguments montype_assoc {M} a b c : rename.
Global Arguments montype_lid {M} a : rename.
Global Arguments montype_rid {M} a : rename.

Infix "⊗" := montype_mult (at level 50,no associativity).

Definition left_faithful {A B : Type} (m : A -> B -> B) :=
  forall (s t : A) (p q : s = t) (b : B),
    ap (fun x => m x b) p = ap (fun x => m x b) q -> p = q.

Section Monoidal_Map.
  (** Definining monoidal maps.  *)
  Record Monoidal_Map (M N : Monoidal_1Type) :=
    {montype_map :> M -> N;
     montype_map_mult (a b : M) : montype_map (a ⊗ b) = (montype_map a) ⊗ (montype_map b) ;
     montype_map_id : montype_map (montype_id) = montype_id;
     montype_map_assoc (a b c : M) :
       ap montype_map (montype_assoc a b c) =
       montype_map_mult (a ⊗ b) c @ ap (fun x => x ⊗ (montype_map c)) (montype_map_mult a b) @
                        montype_assoc (montype_map a) (montype_map b) (montype_map c) @
                        (ap (montype_mult (montype_map a)) (montype_map_mult b c))^
       @ (montype_map_mult a (b ⊗ c))^ ;
     montype_map_lid (x : M)
     : ap montype_map (montype_lid x) =
       montype_map_mult montype_id x @
                        ap (fun s => s ⊗ montype_map x) montype_map_id @ montype_lid (montype_map x);
     montype_map_rid (x : M)
     : ap montype_map (montype_rid x) =
       montype_map_mult x montype_id @ ap (montype_mult (montype_map x)) montype_map_id
                        @ montype_rid (montype_map x) }.

  Global Arguments montype_map_mult {M N} F a b : rename.
  Global Arguments montype_map_id {M N} F : rename.
  Global Arguments montype_map_assoc {M N} F a b c : rename.
  Global Arguments montype_map_lid {M N} F a : rename.
  Global Arguments montype_map_rid {M N} F a : rename.

  Definition monoidal_map_id (M : Monoidal_1Type) : Monoidal_Map M M.
  Proof.
    srapply (Build_Monoidal_Map M M idmap); try reflexivity.
    - intros. simpl.
      rewrite ap_idmap. repeat rewrite concat_p1. apply inverse. apply concat_1p.
  Defined.

  Definition monoidal_map_compose (M N O : Monoidal_1Type) :
    Monoidal_Map M N -> Monoidal_Map N O -> Monoidal_Map M O.
  Proof.
    intros F G.
    srapply @Build_Monoidal_Map.
    - exact (G o F).
    - intros a b.
      refine (ap G (montype_map_mult F a b) @ montype_map_mult G _ _).
    - refine (ap G (montype_map_id F) @ montype_map_id G).
    - intros.
      refine (ap_compose F G _ @ _).
      refine (ap (ap G) (montype_map_assoc F a b c) @ _).
      repeat rewrite ap_pp.
      rewrite (montype_map_assoc G (F a) (F b) (F c)).
      repeat rewrite (concat_pp_p). apply whiskerL.
      repeat rewrite <- (ap_compose G).
      rewrite ap_V. rewrite ap_V.
      rewrite <- (ap_compose (montype_mult (F a)) G (montype_map_mult F b c)).
      rewrite <- (ap_compose (fun x : N => x ⊗ F c) G).
      rewrite inv_pp. rewrite inv_pp.

      repeat rewrite concat_p_pp.
      assert (H : (ap (fun x : N => G (x ⊗ F c)) (montype_map_mult F a b) @ montype_map_mult G (F a ⊗ F b) (F c)) =
                  (montype_map_mult G (F (a ⊗ b)) (F c) @ ap (fun x : N => G x ⊗ G (F c)) (montype_map_mult F a b))).
      { destruct (montype_map_mult F a b). hott_simpl. }
      rewrite H. repeat rewrite concat_pp_p. repeat (apply whiskerL).
      repeat rewrite concat_p_pp. apply whiskerR.
      destruct (montype_map_mult F b c). hott_simpl.
    - intro x.
      refine (ap_compose F G _ @ _).
      refine ( ap (ap G) (montype_map_lid F x) @ _).
      refine (ap_pp G _ _ @ _).
      refine (ap (fun p => p @ ap G (montype_lid (F x))) (ap_pp G _ _) @ _).
      refine (whiskerL _ (montype_map_lid G (F x)) @ _).
      repeat refine (concat_p_pp _ _ _ @ _). apply whiskerR.
      repeat refine (concat_pp_p _ _ _ @ _).
      repeat refine (_ @ concat_p_pp _ _ _). apply whiskerL.
      refine (_ @ whiskerL _ (ap_pp (fun s : O => s ⊗ G (F x)) _ _)^).
      repeat refine (_ @ concat_pp_p _ _ _).
      repeat refine (concat_p_pp _ _ _ @ _). apply whiskerR.
      refine (whiskerR (ap_compose _ G (montype_map_id F))^ _ @ _).
      refine (_ @ whiskerL _ (ap_compose G _ (montype_map_id F))).
      destruct (montype_map_id F). cbn.
      exact (concat_1p _ @ (concat_p1 _)^).
    - intro x.
      refine (ap_compose F G _ @ _ ).
      refine ( ap (ap G) (montype_map_rid F x) @ _).
      refine (ap_pp G _ _ @ _).
      refine (ap (fun p => p @ ap G (montype_rid (F x))) (ap_pp G _ _) @ _).
      refine (whiskerL _ (montype_map_rid G (F x)) @ _).
      repeat refine (concat_p_pp _ _ _ @ _). apply whiskerR.
      repeat refine (concat_pp_p _ _ _ @ _).
      repeat refine (_ @ concat_p_pp _ _ _). apply whiskerL.
      refine (_ @ whiskerL _ (ap_pp (fun s : O => G (F x) ⊗ s) _ _)^).
      repeat refine (_ @ concat_pp_p _ _ _).
      repeat refine (concat_p_pp _ _ _ @ _). apply whiskerR.
      refine (whiskerR (ap_compose _ G (montype_map_id F))^ _ @ _).
      refine (_ @ whiskerL _ (ap_compose G _ (montype_map_id F))).
      destruct (montype_map_id F). cbn.
      exact (concat_1p _ @ (concat_p1 _)^).
  Defined.

  (** Given a 1-Type X, the type X->X is a monoidal 1-type *)
  Definition endomorphism (X : 1-Type) : Monoidal_1Type.
  Proof.
    srapply @Build_Monoidal_1Type.
    - apply (BuildTruncType 1 (X -> X)).
    - intros f g. exact (f o g).
    - cbn. exact idmap.
    - cbn. unfold associative. reflexivity.
    - cbn. unfold left_identity_mult. reflexivity.
    - cbn. unfold right_identity_mult. reflexivity.
    - unfold coherence_triangle1. cbn. reflexivity.
    - unfold coherence_triangle2. cbn. reflexivity.
    - unfold coherence_pentagon. cbn. reflexivity.
  Defined.

  Definition to_endomorphism (M : Monoidal_1Type) : Monoidal_Map M (endomorphism M).
  Proof.
    srapply @Build_Monoidal_Map.
    - simpl. apply montype_mult.
    - intros a b. apply path_arrow. intro c.
      apply montype_assoc.
    - apply path_arrow. apply montype_lid.
    - intros a b c. simpl. hott_simpl.
      transitivity (path_arrow _ _ (fun d : M => ap (fun x : M => x ⊗ d) (montype_assoc a b c)));
        simpl.
      { destruct (montype_assoc a b c). simpl. apply inverse. apply path_forall_1. }
      rewrite (path_forall _ _ (montype_pentagon M a b c) ).
      repeat rewrite path_arrow_pp.
      rewrite path_arrow_V. rewrite path_arrow_V.
      apply whiskerR. apply concat2.
      + apply whiskerL.
        apply inverse.
        refine (ap_functor_arrow _ idmap (montype_mult (a ⊗ b)) (fun x : M => a ⊗ (b ⊗ x)) (fun c0 : M => montype_assoc a b c0) @ _).
        apply (ap (path_arrow (fun b0 : M => (a ⊗ b) ⊗ (c ⊗ b0)) (fun b0 : M => a ⊗ (b ⊗ (c ⊗ b0))))).
        apply path_forall. intro m.
        apply ap_idmap.
      + apply (ap inverse).
        apply inverse.
        refine (ap_functor_arrow idmap _ (montype_mult (b ⊗ c)) (fun x : M => b ⊗ (c ⊗ x)) (fun c0 : M => montype_assoc b c c0) ).
    - intro a. simpl. hott_simpl.
      transitivity (path_arrow _ _ (fun b : M => ap (fun x : M => x ⊗ b) (montype_lid a))).
      { simpl. destruct (montype_lid a). simpl. apply inverse. apply path_forall_1. }
      (* Check (montype_triangle1 M a). *)
      rewrite (path_forall _ _ (montype_triangle1 M a)).
      repeat rewrite path_arrow_pp.
      apply whiskerL.
      apply inverse.
      refine (ap_functor_arrow (montype_mult a) idmap (montype_mult montype_id) idmap montype_lid @ _).
      apply (ap (path_arrow (fun b : M => montype_id ⊗ (a ⊗ b)) (fun b : M => a ⊗ b))).
      apply path_forall. intro b. apply ap_idmap.
    - intro a. simpl. hott_simpl.
      transitivity (path_arrow _ _ (fun b : M => ap (fun x : M => x ⊗ b) (montype_rid a))).
      { simpl. destruct (montype_rid a). simpl. apply inverse. apply path_forall_1. }
      (* Check (montype_triangle2 M a). *)
      rewrite (path_forall _ _ (montype_triangle2 M a)).
      repeat rewrite path_arrow_pp.
      apply whiskerL.
      apply inverse.
      refine (ap_functor_arrow _ _ (montype_mult montype_id) idmap montype_lid ).
  Defined.

  (* Definition old_act_on_prod (M : Monoidal_1Type) (X Y: 1-Type) (a1 : Monoidal_Map M (endomorphism X)) (a2 : Monoidal_Map M (endomorphism Y)): *)
  (*   Monoidal_Map M (endomorphism (BuildTruncType 1 (X*Y))). *)
  (* Proof. *)
  (*   srapply @Build_Monoidal_Map. *)
  (*   - simpl. intro s. *)
  (*     apply (functor_prod (a1 s) (a2 s)). *)
  (*   - intros s t. simpl. *)
  (*     apply (ap011 functor_prod (montype_map_mult a1 _ _) (montype_map_mult a2 _ _)). *)
  (*   - apply (ap011 functor_prod (montype_map_id a1) (montype_map_id a2)). *)
  (*   - intros s t u. simpl. *)
  (*     transitivity (ap011 (functor_prod) (ap a1 (montype_assoc s t u)) (ap a2 (montype_assoc s t u))). *)
  (*     { destruct (montype_assoc s t u). reflexivity. } hott_simpl. *)
  (*     transitivity (ap011 functor_prod *)
  (*                         (((montype_map_mult a1 (s ⊗ t) u @ ap (fun x : (X -> X) => x o (a1 u)) (montype_map_mult a1 s t)) *)
  (*                             @ (ap (montype_mult (a1 s)) (montype_map_mult a1 t u))^) @ (montype_map_mult a1 s (t ⊗ u))^) *)
  (*                         (((montype_map_mult a2 (s ⊗ t) u @ ap (fun y : (Y -> Y) => y o (a2 u)) (montype_map_mult a2 s t)) *)
  (*                             @ (ap (montype_mult (a2 s)) (montype_map_mult a2 t u))^) @ (montype_map_mult a2 s (t ⊗ u))^)). *)
  (*     { apply (ap011 (ap011 functor_prod)). *)
  (*       - refine (montype_map_assoc a1 s t u @ _). simpl. hott_simpl. *)
  (*       - refine (montype_map_assoc a2 s t u @ _). simpl. hott_simpl. } *)
  (*     refine (ap011_pp_pp functor_prod _ _ _ _ @ _). *)
  (*     refine (whiskerR (ap011_pp_pp functor_prod _ _ _ _ ) _ @ _). *)
  (*     refine (whiskerR (whiskerR (ap011_pp_pp functor_prod _ _ _ _ ) _) _ @ _). *)
  (*     apply concat2. *)
  (*     + apply concat2. *)
  (*       * apply whiskerL. *)
  (*         cut (forall (f1 f2 : X -> X) (g1 g2 : Y -> Y) (p : f1 = f2) (q : g1 = g2), *)
  (*                 ap011 functor_prod (ap (fun f => f o (a1 u)) p) (ap (fun g => g o (a2 u)) q) = *)
  (*                 ap (fun f => f o (functor_prod (a1 u) (a2 u))) (ap011 functor_prod p q)). *)
  (*         { intro H. apply H. } *)
  (*           by path_induction. *)
  (*       *  simpl. *)
  (*          cut (forall (f1 f2 : X -> X) (g1 g2 : Y -> Y) (p : f1 = f2) (q : g1 = g2), *)
  (*                  ap011 functor_prod (ap (fun f => (a1 s) o f) p)^ (ap (fun g => (a2 s) o g) q)^ = *)
  (*                  (ap (fun f => (functor_prod (a1 s) (a2 s)) o f) (ap011 functor_prod p q))^). *)
  (*          { intro H. apply H. } *)
  (*            by path_induction.         *)
  (*     + cut (forall (f1 f2 : X -> X) (g1 g2 : Y -> Y) (p : f1 = f2) (q : g1 = g2), *)
  (*               ap011 functor_prod p^ q^ = (ap011 functor_prod p q)^). *)
  (*       { intro H. apply H. } *)
  (*         by path_induction.         *)
  (*   - intro s. *)
  (*     transitivity (ap011 functor_prod (ap a1 (montype_lid s)) (ap a2 (montype_lid s))). *)
  (*     { destruct (montype_lid s). reflexivity. } *)
  (*     transitivity (ap011 functor_prod *)
  (*                         ((montype_map_mult a1 montype_id s @ ap (fun f => f o (a1 s)) (montype_map_id a1))) *)
  (*                         ((montype_map_mult a2 montype_id s @ ap (fun f => f o (a2 s)) (montype_map_id a2)))). *)
  (*     { apply (ap011 (ap011 functor_prod)). *)
  (*       - refine (montype_map_lid a1 s @ _). hott_simpl. *)
  (*       - refine (montype_map_lid a2 s @ _). hott_simpl. } *)
  (*     refine (ap011_pp_pp functor_prod _ _ _ _ @ _). simpl. hott_simpl. apply whiskerL. *)
  (*     cut (forall (f1 f2 : X -> X) (g1 g2 : Y -> Y) (p : f1 = f2) (q : g1 = g2), *)
  (*             ap011 functor_prod (ap (fun f => f o (a1 s)) p) (ap (fun g => g o (a2 s)) q) = *)
  (*             ap (fun f => f o (functor_prod (a1 s) (a2 s))) (ap011 functor_prod p q)). *)
  (*     { intro H.  apply (H _ _ _ _ (montype_map_id a1) (montype_map_id a2)). } *)
  (*       by path_induction. *)
  (*   - intro s. *)
  (*     transitivity (ap011 functor_prod (ap a1 (montype_rid s)) (ap a2 (montype_rid s))). *)
  (*     { destruct (montype_rid s). reflexivity. } *)
  (*     transitivity (ap011 functor_prod *)
  (*                         ((montype_map_mult a1 s montype_id @ ap (montype_mult (a1 s)) (montype_map_id a1))) *)
  (*                         ((montype_map_mult a2 s montype_id @ ap (montype_mult (a2 s)) (montype_map_id a2)))). *)
  (*     { apply (ap011 (ap011 functor_prod)). *)
  (*       - refine (montype_map_rid a1 s @ _). hott_simpl. *)
  (*       - refine (montype_map_rid a2 s @ _). hott_simpl. } *)
  (*     refine (ap011_pp_pp functor_prod _ _ _ _ @ _). simpl. hott_simpl. apply whiskerL. *)
  (*     cut (forall (f1 f2 : X -> X) (g1 g2 : Y -> Y) (p : f1 = f2) (q : g1 = g2), *)
  (*             ap011 functor_prod (ap (fun f => (a1 s) o f) p) (ap (fun g => (a2 s) o g) q) = *)
  (*             ap (fun f => (functor_prod (a1 s) (a2 s)) o f) (ap011 functor_prod p q)). *)
  (*     { intro H.  apply (H _ _ _ _ (montype_map_id a1) (montype_map_id a2)). } *)
  (*       by path_induction. *)
  (* Defined. *)
End Monoidal_Map.

Section Monoidal_Action.
  (** We could define monoidal actions to be [Monoidal_Map M (endomorphism X)],
but the following definition is easier to work with.*)

  Record monoidal_action (M : Monoidal_1Type) (X : 1-Type) :=
    { act :> M -> X -> X;
      montype_act_mult : forall (s t : M) (x : X), act (s ⊗ t) x = act s (act t x) ;
      montype_act_id : forall x : X, act montype_id x = x;
      montype_act_triangle1 : forall (a : M) (x : X),
          ap (fun m : M => act m x) (montype_lid a) = montype_act_mult montype_id a x @ montype_act_id (act a x);
      montype_act_triangle2 : forall (a : M) (x : X),
          ap (fun m : M => act m x) (montype_rid a) = montype_act_mult a montype_id x @ ap (fun y : X => act a y) (montype_act_id x);
      montype_act_pentagon : forall (a b c : M) (x : X),
          ap (fun m : M => act m x) (montype_assoc a b c) =
          montype_act_mult (a ⊗ b) c x @ montype_act_mult a b (act c x) @ (ap (act a) (montype_act_mult b c x))^ @ (montype_act_mult a (b ⊗ c) x)^ }.

  Global Arguments montype_act_mult {M} {X} a s t x : rename.
  Global Arguments montype_act_id {M} {X} a x : rename.

  Definition action_on_path {M} {X} (a : monoidal_action M X) {s t : M} (x : X) (p : s = t)
    := ap (fun s => a s x) p.

  (** A monoidal 1-type acts on itself per definition.  *)
  Definition act_on_self (M : Monoidal_1Type) : monoidal_action M M.
  Proof.
    srapply @Build_monoidal_action.
    - exact montype_mult.
    - apply montype_assoc.
    - apply montype_lid.
    - apply montype_triangle1.
    - apply montype_triangle2.
    - apply montype_pentagon.
  Defined.

  Definition endomorphism_to_action (M : Monoidal_1Type) (X : 1-Type)
             (F : Monoidal_Map M (endomorphism X))
    : monoidal_action M X.
  Proof.
    srapply @Build_monoidal_action.
    - exact F.
    - intros s t. apply ap10.
      apply (montype_map_mult F).
    - apply ap10.
      apply (montype_map_id F).
    - intros a x.
      refine (ap_compose F (fun f => f x) (montype_lid a) @ _).
      rewrite montype_map_lid.
      repeat rewrite ap_pp. simpl. rewrite concat_p1.
      rewrite <- (ap_compose (fun (s : X -> X) (x0 : X) => s (F a x0)) (fun f : X -> X => f x) (montype_map_id F)). simpl.
      rewrite ap_apply_l. rewrite ap_apply_l. reflexivity.
    - intros a x.
      refine (ap_compose F (fun f => f x) (montype_rid a) @ _).
      rewrite montype_map_rid.
      repeat rewrite ap_pp. simpl. rewrite concat_p1.
      rewrite ap_apply_l. apply whiskerL.
      rewrite ap_apply_l.
      apply (ap10_ap_postcompose (F a) (montype_map_id F) x).
    - intros a b c x. simpl.
      refine (ap_compose F (fun f => f x) (montype_assoc a b c) @ _).
      rewrite montype_map_assoc.
      repeat rewrite ap_pp. simpl. rewrite concat_p1.
      rewrite ap_apply_l. rewrite ap_apply_l. rewrite ap_apply_l. rewrite ap_apply_l.
      apply concat2.
      { apply concat2.
        { apply whiskerL.
          apply (ap10_ap_precompose (F c) (montype_map_mult F a b) x ). }
        rewrite ap10_V. apply (ap inverse).
        apply (ap10_ap_postcompose (F a) (montype_map_mult F b c) x). }
      apply (ap10_V (montype_map_mult F a (b ⊗ c)) x).
  Defined.

  Definition monmap_to_action {M : Monoidal_1Type} {X : Monoidal_1Type} (F : Monoidal_Map M X) :
    monoidal_action M X.
  Proof.
    apply endomorphism_to_action.
    apply (monoidal_map_compose M X (endomorphism X) F).
    apply (to_endomorphism).
  Defined.

  Definition act_on_prod (M : Monoidal_1Type) (X Y: 1-Type)
             (act1 : monoidal_action M X) (act2 : monoidal_action M Y) :
    monoidal_action M (BuildTruncType 1 (X*Y)).
  Proof.
    srapply @Build_monoidal_action; simpl.
    - intro s.
      apply (functor_prod (act1 s) (act2 s)).
    - simpl. intros s t x.
      apply path_prod; apply montype_act_mult.
    - simpl. intro x.
      apply path_prod; apply montype_act_id.
    - simpl. intros s x.
      transitivity (path_prod (_,_) (_,_) (ap (fun m : M => act1 m (fst x)) (montype_lid s)) (ap (fun m : M => act2 m (snd x)) (montype_lid s))).
      { destruct (montype_lid s). reflexivity. }
      refine (_ @ path_prod_pp _ _ _ _ _ _ _).
      apply (ap011 (path_prod _ _)); apply montype_act_triangle1.
    - intros s x. simpl.
      transitivity (path_prod (_,_) (_,_) (ap (fun m : M => act1 m (fst x)) (montype_rid s)) (ap (fun m : M => act2 m (snd x)) (montype_rid s))).
      { destruct (montype_rid s). reflexivity. }
      refine (_ @ whiskerL _ (ap_functor_prod _ _ _ _ _ _)^).
      refine (_ @ path_prod_pp _ _ _ _ _ _ _).
      apply (ap011 (path_prod _ _)); apply montype_act_triangle2.
    - intros a b c x. simpl.
      transitivity (path_prod (_,_) (_,_)
                              (ap (fun m : M => act1 m (fst x)) (montype_assoc a b c)) (ap (fun m : M => act2 m (snd x)) (montype_assoc a b c))).
      { destruct (montype_assoc a b c). reflexivity. }
      rewrite (ap_functor_prod).
      repeat rewrite <- path_prod_VV.
      repeat rewrite <- path_prod_pp.
      apply (ap011 (path_prod _ _)); apply montype_act_pentagon.
  Defined.

  (* Definition act_from_monmap (M X : Monoidal_1Type) (F : Monoidal_Map M X) : *)
  (*   monoidal_action M X. *)
  (* Proof. *)
  (*   srapply @Build_monoidal_action. *)
  (*   - intros m x. exact ((F m) ⊗ x). *)
  (*   - intros s t x. simpl. *)
  (*     refine (ap (fun y => y ⊗ x) (montype_map_mult F s t) @ _). *)
  (*     apply montype_assoc. *)
  (*   - intro x. simpl. *)
  (*     exact (ap (fun y => y ⊗ x) (montype_map_id F) @ (montype_lid x)). *)
  (*   - intros a x. simpl. *)
  (*     refine (ap_compose F (fun y : X => y ⊗ x) (montype_lid a) @ _). *)
  (*     rewrite montype_map_lid. *)
  (*     repeat rewrite ap_pp. *)
  (*     rewrite montype_triangle1. *)
  (*     repeat rewrite concat_p_pp. apply whiskerR. *)
  (*     repeat rewrite concat_pp_p. apply whiskerL. *)
  (*     rewrite <- (ap_compose (fun s : X => s ⊗ F a) (fun y : X => y ⊗ x)). *)
  (*     destruct (montype_map_id F). simpl. *)
  (*     destruct (montype_assoc (F montype_id) (F a) x). reflexivity. *)
  (*   - intros a x. simpl. *)
  (*     refine (ap_compose F (fun y : X => y ⊗ x) (montype_rid a) @ _). *)
  (*     rewrite montype_map_rid. *)
  (*     repeat rewrite ap_pp. *)
  (*     rewrite montype_triangle2. *)
  (*     repeat rewrite concat_p_pp. apply whiskerR. *)
  (*     repeat rewrite concat_pp_p. apply whiskerL. *)
  (*     rewrite <- (ap_compose (montype_mult (F a)) (fun y : X => y ⊗ x)). *)
  (*     destruct (montype_map_id F). simpl. *)
  (*     destruct (montype_assoc (F a) (F montype_id)  x). reflexivity. *)
  (*   - intros a b c x. simpl. *)
  (*     refine (ap_compose F (fun y : X => y ⊗ x) (montype_assoc a b c) @ _). *)
  (*     rewrite montype_map_assoc. *)
  (*     repeat rewrite ap_pp. *)
  (*     rewrite montype_pentagon. *)
  (*     repeat rewrite concat_pp_p. apply whiskerL. *)
  (*     repeat rewrite concat_p_pp. apply whiskerR. *)
  (*     refine (ap_pp _ _ _ @ _). *)
  (*     refine (montype_triangle1 M _ _ @ _). *)
End Monoidal_Action.

Section Symmetric_Monoidal_1Type.
  (** Define symmetric monoidal 1-type.  *)

  Definition symmetric {A : Type} (m : A->A->A) := forall a b : A, m a b = m b a.
  Definition coherence_hexagon {A : Type} {m : A -> A -> A} (assoc : associative m)
             (symm : symmetric m) :=
    forall (a b c : A),
      ap (fun x : A => m x c) (symm a b) =
      assoc a b c @ symm a (m b c) @ assoc b c a @ (ap (m b) (symm a c))^ @ (assoc b a c)^.

  Record Symmetric_Monoidal_1Type : Type :=
    { smontype_type :> 1-Type;
      smontype_mult  : smontype_type -> smontype_type -> smontype_type;
      smontype_id : smontype_type;
      smontype_assoc : associative smontype_mult;
      smontype_lid : left_identity_mult smontype_mult smontype_id ;
      smontype_rid : right_identity_mult smontype_mult smontype_id ;
      smontype_sym : symmetric smontype_mult ;
      smontype_sym_inv : forall a b : smontype_type, smontype_sym a b = (smontype_sym b a)^ ;
      smontype_triangle1 : coherence_triangle1 smontype_assoc smontype_lid ;
      smontype_triangle2 : coherence_triangle2 smontype_assoc smontype_lid smontype_rid ;
      smontype_pentagon : coherence_pentagon smontype_assoc;
      smontype_hexagon : coherence_hexagon smontype_assoc smontype_sym
    }.
  Global Arguments smontype_mult {S} a b : rename.
  Global Arguments smontype_id {S} : rename.
  Global Arguments smontype_assoc {S} a b c : rename.
  Global Arguments smontype_lid {S} a : rename.
  Global Arguments smontype_rid {S} a : rename.
  Global Arguments smontype_sym {S} a b : rename.

  Definition forget_symmetry : Symmetric_Monoidal_1Type -> Monoidal_1Type :=
    fun S => Build_Monoidal_1Type S smontype_mult smontype_id smontype_assoc smontype_lid smontype_rid
                                  (smontype_triangle1 S) (smontype_triangle2 S) (smontype_pentagon S).

  Coercion forget_symmetry : Symmetric_Monoidal_1Type >-> Monoidal_1Type.
End Symmetric_Monoidal_1Type.


(** 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 (z : natural) (y : natural) (lf1 : natural) (lf2 : natural)
  : natural := mult z (Succ y).


(** 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 (z : natural) (y : natural) (lf2 : natural) (lf1 : natural)
  : natural := mult lf1 (Succ Zero).


Require Import Bool List Arith Nat Coq.Arith.Div2.
Import ListNotations.

(*=bitn *)
Fixpoint bit_n (l : list bool) : nat :=
  match l with
    | [] => 0
    | a :: tl => 2 * bit_n tl + Nat.b2n a
  end.
(*=End *)
(*=nbit *)
Fixpoint n_bit (n : nat) (k : nat) : option (list bool) :=
    match n with
      | 0 => match k with
             | 0 => Some []
             | S _ => None
             end
      | S n' => match n_bit n' (Nat.div2 k) with
                  | None => None
                  | Some l => Some (Nat.odd k :: l)
                end
    end.
(*=End *)
Compute pow 2 8.
Check leb 2 3.

SearchAbout (_ mod _).
(*=size_n_bit *)
Theorem size_n_bit : forall (n k: nat) (l : list bool),
    n_bit n k = Some l -> length l = n.
(*=End *)
Proof.
  induction n.
  -intros k l.
   induction k.
   +intros.
    inversion H.
    reflexivity.
   +simpl.
    discriminate.
  -intros k l.
   simpl.
   case_eq (n_bit n (Nat.div2 k)).
   +intros.
    inversion H0.
    assert (help1: forall (l' : list bool) (b : bool), length l' = n -> length(b :: l') = S n).
    {
      induction l'.
      -intros b.
       simpl.
       intros.
       rewrite H1.
       reflexivity.
      -intros b.
       simpl.
       intros.
       rewrite H1.
       reflexivity.
    }
    apply help1.
    specialize (IHn (Nat.div2 k)).
    apply IHn.
    exact H.
   +intros.
    discriminate.
Qed.

(* first proof that we need on binary representation *)
(*=nbitn *)
Lemma n_bit_n : forall (l : list bool) (n k : nat),
    n_bit n k = Some l -> bit_n l = k.
(*=End *)
Proof.
  assert (I : forall (l : list bool) (n k : nat), n_bit n k = Some l -> bit_n l = k).
  {
    intros l; induction l; intros n k.
    simpl.
    assert (I_1 : n_bit n k = Some [] -> bit_n [] = k).
    {
      induction k.
      - reflexivity.
       (* the hypothesis is false so we will need to find how to demonstrate this *)
      - assert (I_1_1 : n_bit n (S k) = Some [] -> bit_n [] = S k).
       {
         induction n.
         - discriminate.
         - unfold n_bit; fold n_bit.
           destruct (n_bit n (Nat.div2 (S k))); discriminate.
       }
       exact I_1_1.
    }
    exact I_1.
    assert (I_2 : n_bit n k = Some (a :: l) -> bit_n (a :: l) = k).
    {
      intros H.
      simpl.
      About Nat.div2_odd.
      rewrite (Nat.div2_odd k).
      simpl.
      destruct n; simpl in H.
      - destruct k; discriminate.
      - destruct (n_bit n (Nat.div2 k)) eqn:Hl; try discriminate.
        inversion H; subst.
        erewrite IHl; eauto.
    }
    assumption.
  }
  assumption.
Qed.

(* second proof *)
(*=bitnbit *)
Theorem bit_n_bit : forall (l : list bool) (n : nat),
    n = length l -> (n_bit n (bit_n l)) = Some l.
(*=End *)
Proof.
  assert (I : forall (l : list bool) (n : nat), n = length l -> n_bit n (bit_n l) = Some l).
  {
    induction l.
    assert (I_1 : forall n : nat, n = length ([] : list bool) -> n_bit n (bit_n []) = Some []).
    {
      simpl.
      intros n H.
      rewrite H.
      reflexivity.
    }
    exact I_1.
    assert (I_2 : forall n : nat, n = length (a :: l) -> n_bit n (bit_n (a :: l)) = Some (a :: l)).
    {
      intros n.
      simpl.
      destruct a.
      assert (I_2_1 : n = length (true :: l) -> n_bit n (bit_n (true :: l)) = Some (true :: l)).
      {
        simpl.
        Search (_ + 0).
        rewrite <- plus_n_O.
        intros H.
        rewrite H.
        simpl.
        assert (I_2_1_1 : forall l' : (list bool), bit_n l' + bit_n l' = 2 * bit_n l').
        {
          induction l'.
          -reflexivity.
          -simpl.
           rewrite <- plus_n_O.
           rewrite <- plus_n_O.
           reflexivity.
        }
        rewrite I_2_1_1.
        Search (_ + 1 = S _).
        Search (Nat.div2 _).
        rewrite Nat.add_1_r.
        Check even_div2.
        rewrite <- even_div2.
        -Search (Nat.div2 (2 * _)).
         rewrite div2_double.
         rewrite IHl.
         +assert (I_2_1_2 : forall (n' : nat), Nat.odd (S (2 * n')) = true).
          {
            intros n'.
            induction n'.
            -reflexivity.
            -simpl.
             rewrite <- plus_n_Sm.
             simpl in IHn'.
             rewrite <- IHn'.
             Search (Nat.odd (S (S _))).
             rewrite Nat.odd_succ_succ. reflexivity.
          }
          rewrite I_2_1_2.
          reflexivity.
         +reflexivity.
        -assert (I_2_1_3 : Even.even (2 * bit_n l)).
         {
           (* this is supposed to be trivial -_-_-_-_-_-_-_-_-_-_-_-_- *)
           Check Nat.even_add_mul_2.
           Search (0 + _).
           rewrite <- Nat.add_0_l.
           SearchAbout (even (_ + _)).
           specialize (Nat.even_add_mul_2 0 (bit_n l)).
           intros.
           Check Even.even_equiv.
           apply Even.even_equiv.
           (* even spec *)
           Check Nat.even_spec.
           simpl in H0.
           Search (_ + _ = 2 * _).
           Check I_2_1_1.
           rewrite <- I_2_1_1.
           assert (0 + (bit_n l + bit_n l) = bit_n l + (bit_n l + 0)).
           { simpl. Search (_ + 0). rewrite <- plus_n_O. reflexivity. }
           rewrite H1.
           rewrite Nat.even_spec in H0.
           exact H0.
         }
         exact I_2_1_3.
      }
      exact I_2_1.
      assert (I_2_2 : n = S (length l) -> n_bit n (bit_n l + (bit_n l + 0) + Nat.b2n false) = Some (false :: l)).
      {
        simpl.
        Search (_ + 0).
        rewrite <- plus_n_O.
        rewrite <- plus_n_O.
        intros H.
        rewrite H.
        simpl.
        Search (2 * _ = _).
        assert (I_2_2_0 : forall (n' : nat), 2 * n' = n' + n').
        {
          intros n'. simpl. rewrite <- plus_n_O. reflexivity.
        }
        rewrite <- I_2_2_0.
        rewrite div2_double.
        rewrite IHl.
        -assert (I_2_2_1 : forall (n' : nat), Nat.odd (2 * n') = false).
         {
           induction n'.
           -simpl. Search (Nat.odd 0).
            rewrite Nat.odd_0. reflexivity.
           -simpl.
            Search (_ + 0).
            rewrite <- plus_n_O.
            Search (_ + _ = _ + _).
            rewrite <- plus_Snm_nSm.
            Search (S _ + _).
            rewrite plus_Sn_m.
            Search (Nat.odd (S (S _))).
            rewrite Nat.odd_succ_succ.
            simpl in IHn'.
            rewrite <- plus_n_O in IHn'.
            rewrite IHn'.
            reflexivity.
         }
         rewrite I_2_2_1.
         reflexivity.
        -reflexivity.
      }
      exact I_2_2.
    }
    exact I_2.
  }
  exact I.
Qed.