(* Sequent Calculus for Second-Order Propositional Additive Linear Logic *)

From Coq Require Import PeanoNat Wf_nat Lia List.
From OLlibs Require Import dectype.
From Quantifiers Require Import term_tactics.

#[local] Hint Resolve in_in_remove : term_db.

Parameter atom : Type. (* second-order constants *)
Parameter vatom : DecType. (* variables for quantification *)

(** * Formulas *)

(** formulas *)
(** second-order formulas in the langage: true, conjunction, universal quantification *)
Inductive formula :=
| var : vatom -> formula
| dvar : nat -> formula
| cst : atom -> formula
| top : formula
| wdg : formula -> formula -> formula
| frl : vatom -> formula -> formula.

Ltac formula_induction A :=
  (try intros until A) ;
  let X := fresh "X" in
  let K := fresh "k" in
  let P := fresh "P" in
  let A1 := fresh A in
  let A2 := fresh A in
  let Y := fresh "X" in
  induction A as [ X | K | P | | A1 A2 | Y A ] ; simpl ; intros ;
    try (f_equal ; intuition) ; try ((rnow idtac) ; fail) ; try (rcauto ; fail).

(** size of formulas *)
Fixpoint fsize A :=
match A with
| var _ => 1
| dvar _ => 1
| cst _ => 1
| top => 1
| wdg B C => S (fsize B + fsize C)
| frl _ B => S (fsize B)
end.

(** lift indexes above [k] in [formula] [A] *)
Fixpoint fup k A :=
match A with
| var X => var X
| dvar n => if n <? k then dvar n else dvar (S n)
| cst R => cst R
| top => top
| wdg B C => wdg (fup k B) (fup k C)
| frl X B => frl X (fup k B)
end.
Notation fupz := (fup 0).

Lemma fsize_fup : forall k A, fsize (fup k A) = fsize A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite fsize_fup : term_db.

Lemma fup_fup_com : forall k A,
  fup (S k) (fupz A) = fupz (fup k A).
Proof. formula_induction A. Qed.
#[local] Hint Rewrite fup_fup_com : term_db.

(** substitutes [formula] [F] for variable [X] in [formula] [A] (capture is possible) *)
Fixpoint subs X F A :=
match A with
| dvar k => dvar k
| var Y => if eq_dt_dec Y X then F else var Y
| cst R => cst R
| top => top
| wdg B C => wdg (subs X F B) (subs X F C)
| frl Y B => frl Y (if eq_dt_dec Y X then B else subs X F B)
end.

Lemma fsize_subs_dvar : forall k X A, fsize (subs X (dvar k) A) = fsize A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite fsize_subs_dvar : term_db.

Lemma fup_subs_com : forall k X F A,
  fup k (subs X F A) = subs X (fup k F) (fup k A).
Proof. now formula_induction A ; rcauto ; f_equal. Qed.
#[local] Hint Rewrite fup_subs_com : term_db.

(** substitutes [formula] [F] for index [n] in [formula] [A] and decreases indexes above [n] *)
Fixpoint nsubs n F A :=
match A with
| var X => var X
| dvar k => match n ?= k with
            | Eq => F
            | Lt => dvar (pred k)
            | Gt => dvar k
            end
| cst R => cst R
| top => top
| wdg B C => wdg (nsubs n F B) (nsubs n F C)
| frl X B => frl X (nsubs n F B)
end.

Lemma nsubs_fup_com : forall k F A,
  nsubs (S k) (fupz F) (fupz A) = fupz (nsubs k F A).
Proof. formula_induction A ; rcauto.
now destruct k0; destruct k; inversion Heq.
Qed.
#[local] Hint Rewrite nsubs_fup_com : term_db.

Fixpoint freevars A :=
match A with
| var X => X :: nil
| dvar _ => nil
| cst _ => nil
| top => nil
| wdg B C => (freevars B) ++ (freevars C)
| frl X B => remove eq_dt_dec X (freevars B)
end.
Notation closed A := (freevars A = nil).

Lemma closed_nofreevars A X : closed A -> ~ In X (freevars A).
Proof. intros Hc Hin. rewrite Hc in Hin. destruct Hin. Qed.

Lemma freevars_fup k A : freevars (fup k A) = freevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite freevars_fup : term_db.

Lemma freevars_nsubs n F (Hc : closed F) A : freevars (nsubs n F A) = freevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite freevars_nsubs using assumption : term_db.

Lemma nfree_subs X F A : ~ In X (freevars A) -> subs X F A = A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite nfree_subs using try tauto;
                                       try apply closed_nofreevars; tauto : term_db.

Lemma nsubs_subs_com X F n G (Hin : ~ In X (freevars G)) A :
  nsubs n G (subs X F A) = subs X (nsubs n G F) (nsubs n G A).
Proof. formula_induction A. Qed.
#[local] Hint Rewrite nsubs_subs_com using try tauto;
                                           try apply closed_nofreevars; tauto : term_db.

Lemma nsubs_z_fup F A : nsubs 0 F (fupz A) = A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite nsubs_z_fup : term_db.

(** * Proofs *)

(** Proofs *)
(** two-sided sequent calculus for second-order (additive) linear logic with connectives:
    top, with, forall *)
Inductive prove : formula -> formula -> Type :=
| ax : forall A, prove A A
| topr : forall C, prove C top
| wdgr { C A B } : prove C A -> prove C B -> prove C (wdg A B)
| wdgll { A C } : forall B, prove A C -> prove (wdg A B) C
| wdglr { A C } : forall B, prove A C -> prove (wdg B A) C
| frlr { X C A } : prove (fupz C) (subs X (dvar 0) (fupz A)) -> prove C (frl X A)
| frll { X A C } : forall F, closed F -> prove (subs X F A) C -> prove (frl X A) C.
#[local] Hint Constructors prove : term_db.

(** height of proofs *)
Fixpoint psize {A B} (pi : prove A B) :=
match pi with
| ax _ => 1
| topr _ => 1
| wdgr pi1 pi2 => S (max (psize pi1) (psize pi2))
| wdgll _ pi1 => S (psize pi1)
| wdglr _ pi1 => S (psize pi1)
| frlr pi1 => S (psize pi1)
| frll _ _ pi1 => S (psize pi1)
end.

(** substitutes [cterm] [u] for index [n] in proof [pi] and decreases indexes above [n] *)
Theorem psubs k F (Hc : closed F) {C A} (pi : prove C A) :
  { pi' : prove (nsubs k F C) (nsubs k F A) | psize pi' = psize pi }.
Proof.
revert k F Hc; induction pi; intros k F' Hc;
  try (destruct (IHpi k F' Hc) as [pi' Hs]);
  try (destruct (IHpi1 k F' Hc) as [pi1' Hs1]);
  try (destruct (IHpi2 k F' Hc) as [pi2' Hs2]).
- now exists (ax _).
- now exists (topr _).
- exists (wdgr pi1' pi2'). cbn. auto.
- exists (wdgll _ pi'). cbn. auto.
- exists (wdglr _ pi'). cbn. auto.
- clear pi' Hs.
  rewrite <- (freevars_fup 0) in Hc.
  destruct (IHpi (S k) _ Hc) as [pi' Hs].
  cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  exists (frlr pi'). reflexivity.
- cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  rewrite <- (freevars_nsubs k F' Hc) in e.
  exists (frll _ e pi'). reflexivity.
Qed.

(** lift indexes above [k] in proof [pi] *)
Theorem pup k {C A} (pi : prove C A) : { pi' : prove (fup k C) (fup k A) | psize pi' = psize pi }.
Proof.
induction pi in k |- *;
  try (destruct (IHpi k) as [pi' Hs]) ;
  try (destruct (IHpi1 k) as [pi1' Hs1]) ;
  try (destruct (IHpi2 k) as [pi2' Hs2]).
- now exists (ax _).
- now exists (topr _).
- exists (wdgr pi1' pi2'). cbn. auto.
- exists (wdgll _ pi'). cbn. auto.
- exists (wdglr _ pi'). cbn. auto.
- clear pi' Hs.
  destruct (IHpi (S k)) as [pi' Hs].
  cbn. rewrite <- Hs. clear Hs.
  revert pi'.
  rnow change (dvar 0) with (fup (S k) (dvar 0)).
  exists (frlr pi'). reflexivity.
- cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  rewrite <- (freevars_fup k) in e.
  exists (frll _ e pi'). reflexivity.
Qed.

(** * Cut Elimination *)

Theorem cutr A B C : prove A B -> prove B C -> prove A C.
Proof.
enough (forall n, forall A B C (pi1 : prove A B) (pi2 : prove B C),
              n = psize pi1 + psize pi2 -> prove A C) as H
  by (intros pi1 pi2 ; apply (H _ _ _ _ pi1 pi2 eq_refl)). clear A B C.
induction n as [n IH0] using (well_founded_induction_type lt_wf) ; intros ; subst.
assert (forall A B C (pi1' : prove A B) (pi2' : prove B C),
               psize pi1' + psize pi2' < psize pi1 + psize pi2 -> prove A C) as IH
  by (intros; eapply IH0; eauto); clear IH0.
destruct pi2; intuition.
- apply wdgr.
  + apply (IH _ _ _ pi1 pi2_1). cbn. lia.
  + apply (IH _ _ _ pi1 pi2_2). cbn. lia.
- enough (forall A D (pi1 : prove A D) A0 B C (pi2 : prove A0 C)
            (IH : forall A1 B0 C0 (pi1' : prove A1 B0) (pi2' : prove B0 C0),
                   psize pi1' + psize pi2' < psize pi1 + psize (wdgll B pi2) -> prove A1 C0),
         D = wdg A0 B -> prove A C)
    as IH2 by refine (IH2 _ _ _ _ _ _ _ IH eq_refl); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst; intuition;
    try (constructor ; apply (IH _ _ _ pi1 (wdgll _ pi2)); cbn; lia).
  + apply (IH _ _ _ pi1_1 pi2). cbn. lia.
  + apply (frll F e).
    apply (IH _ _ _ pi1 (wdgll _ pi2)). cbn. lia.
- enough (forall A D (pi1 : prove A D) A0 B C (pi2 : prove A0 C)
            (IH : forall A1 B0 C0 (pi1' : prove A1 B0) (pi2' : prove B0 C0),
                psize pi1' + psize pi2' < psize pi1 + psize (wdglr B pi2) -> prove A1 C0),
         D = wdg B A0 -> prove A C)
    as IH2 by refine (IH2 _ _ _ _ _ _ _ IH eq_refl) ; clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst; intuition;
    try (constructor; apply (IH _ _ _ pi1 (wdglr _ pi2)); cbn; lia).
  + apply (IH _ _ _ pi1_2 pi2). cbn. lia.
  + apply (frll F e).
    apply (IH _ _ _ pi1 (wdglr _ pi2)). cbn. lia.
- destruct (pup 0 pi1) as [pi1' Hs].
  apply frlr, (IH _ _ _ pi1' pi2). cbn. lia.
- enough (forall A D (pi1 : prove A D) X A0 C F e (pi2 : prove (subs X F A0) C)
            (IH : forall A1 B C0 (pi1' : prove A1 B) (pi2' : prove B C0),
                   psize pi1' + psize pi2' < psize pi1 + psize (frll F e pi2) -> prove A1 C0),
         D = frl X A0 -> prove A C)
    as IH2 by refine (IH2 _ _ _ _ _ _ _ _ _ IH eq_refl); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor ; apply (IH _ _ _ pi1 (frll _ e pi2)); cbn; lia).
  + apply (frll F e). assumption.
  + destruct (psubs 0 F e pi1) as [pi1' Hs].
    simpl in IH. rewrite <- Hs in IH. clear Hs.
    revert pi1' IH. autorewrite with term_db. intros pi1' IH.
    apply (IH _ _ _ pi1' pi2). cbn. lia.
  + apply (frll F e), (IH _ _ _ pi1 (frll F0 e0 pi2)). cbn. lia.
Qed.

(** * Hilbert style properties *)

Lemma frl_elim : forall A F X, closed F -> prove (frl X A) (subs X F A).
Proof.
intros A F X Hc.
rnow apply (frll F).
Qed.

Lemma frl_wdg : forall A B X, prove (frl X (wdg A B)) (wdg (frl X A) (frl X B)).
Proof.
intros A B X.
repeat constructor; simpl;
  apply (frll (dvar 0)); simpl; do 2 constructor.
Qed.

Lemma frl_nfree : forall A X, ~ In X (freevars A) -> prove A (frl X A).
Proof.
intros A X Hnf.
rewrite <- (freevars_fup 0) in Hnf.
rnow apply frlr.
Qed.

(** * Other properties *)

(** Axiom expansion *)
Lemma ax_exp : forall A, prove A A.
Proof.
enough (Hn : forall n A, fsize A = n -> prove A A) by (intros A; refine (Hn _ _ eq_refl)).
induction n as [n IH] using (well_founded_induction_type lt_wf); intros; subst.
destruct A.
- apply ax.
- apply ax.
- apply ax.
- apply topr.
- apply wdgr; [ apply wdgll | apply wdglr ]; refine (IH _ _ _ eq_refl); cbn; lia.
- apply frlr.
  cbn. apply (frll (dvar 0) eq_refl). constructor.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-05-20
- Frederic Blanqui, 2005-02-25

Ring structure.

- Ly Kim Quyen, 2013-08-22

Remove Module Type structure by Section to be able to use in Rainbow.
*)

Set Implicit Arguments.

Require Export Ring Ring_theory.
Require Import LogicUtil RelExtras2 Setoid EqUtil ZUtil Morphisms.

(***********************************************************************)
(** ** Ring structure type. *)

Section Ring.

  Variable e : Eqset.

  Definition eqA := eqA e.

  Definition sid_theoryA := sid_theoryA e.

  Add Setoid A eqA sid_theoryA as A_Setoid.

  Hint Resolve (Seq_refl A eqA sid_theoryA) : sets.
  Hint Resolve (Seq_trans A eqA sid_theoryA) : sets.
  Hint Resolve (Seq_sym A eqA sid_theoryA) : sets.

  Record Ring := mkRing {
    A0 : A;
    A1 : A;
    Aadd : A -> A -> A;
    Amul : A -> A -> A;
    Aopp : A -> A;
    Asub : A -> A -> A;
    Aring : ring_theory A0 A1 Aadd Amul Asub Aopp eqA
  }.

  Variable r: Ring.

  (* Need to declare ring as a morphism to be able to define a [Add
  Ring] later. *)

  Parameter Aadd_mor : Proper (eqA ==> eqA ==> eqA) (Aadd r).
  Parameter Amul_mor : Proper (eqA ==> eqA ==> eqA) (Amul r).
  Parameter Aopp_mor : Proper (eqA ==> eqA) (Aopp r).
  Parameter Asub_mor : Proper (eqA ==> eqA ==> eqA) (Asub r).

End Ring.

(***********************************************************************)
(** ** Properties of rings. *)

Section RingTheory.

  Variable e : Eqset.

  Variable r: Ring e.

  Notation Aring := (Aring r).

  Notation eqA := (eqA e).

  Notation sid_theoryA := (sid_theoryA e).

  Add Setoid A eqA sid_theoryA as A_Setoid'.

  Add Ring Aring : Aring.

  (***********************************************************************)
  (** Boolean equality *)

  Notation eqA_dec := (eqA_dec e).

  Definition beqA x y :=
    match eqA_dec x y with
      | left _ => true
      | right _ => false
    end.

  Notation "x =A= y" := (eqA x y) (at level 70).

  Lemma beqA_ok : forall x y, beqA x y = true <-> x =A= y.

  Proof.
  intros. unfold beqA. case (eqA_dec x y); intuition.
  Qed.

  (***********************************************************************)
  (** Power function *)

  Notation A0 := (A0 r).
  Notation "0" := A0.

  Notation A1 := (A1 r).
  Notation "1" := A1.

  Notation Aadd := (Aadd r).
  Notation "x + y" := (Aadd x y).

  Notation Amul := (Amul r).
  Notation "x * y" := (Amul x y).

  Notation Aopp := (Aopp r).
  Notation "- x" := (Aopp x).

  Notation Asub := (Asub r).
  Notation "x - y" := (Asub x y).

  Fixpoint power x n {struct n} :=
    match n with
      | 0 => 1
      | S n' => x * power x n'
    end.

  Notation "x ^ n" := (power x n).

  Lemma power_add : forall x n1 n2, x ^ (n1 + n2) =A= x ^ n1 * x ^ n2.

  Proof.
  induction n1; simpl; intros. ring. rewrite IHn1. ring.
  Qed.

  Add Morphism power with signature eqA ==> @eq nat ==> eqA as power_eqA.

  Proof.
    induction y0; simpl; intros. refl. rewrite IHy0. rewrite H. refl.
  Qed.

  (***********************************************************************)
  (** Properties of ring type *)

  Lemma Aadd_0_r : forall x, x + 0 =A= x.

  Proof.
  intros. ring.
  Qed.

  Lemma Amul_0_l : forall x, 0 * x =A= 0.

  Proof.
  intros. ring.
  Qed.

  Lemma Asub_def : forall x y, x - y =A= x + - y.

  Proof.
  intros. ring.
  Qed.

  Lemma Aopp_def : forall x, x + (-x) =A= 0.

  Proof.
  intros. ring.
  Qed.

  Lemma Aopp_opp : forall x, - - x =A= x.

   Proof.
   intros. ring.
   Qed.

  Lemma add_minus : forall x y, x =A= x + y - y.

  Proof.
  intros. ring.
  Qed.

  Lemma add_permute : forall n m p, n + (m + p) =A= m + (n + p).

  Proof.
  intros. ring.
  Qed.

End RingTheory.

(***********************************************************************)
(** ** Integers as a ring. *)

Require Import ZArith.

Section Int.

  Definition ZA := Z.
  Definition ZeqA := Z.eq.

  Definition Zsid_theoryA : Setoid_Theory ZA ZeqA.

  Proof.
    unfold ZeqA. constructor.
    unfold Reflexive. refl.
    unfold Symmetric. sym. hyp.
    unfold Transitive. intros. trans y; hyp.
  Qed.

End Int.

Section Int_Eqset_dec.

  Definition ZeqA_dec := dec_beq beq_Z_ok.

End Int_Eqset_dec.

Section IntRing.

  Add Setoid ZA ZeqA Zsid_theoryA as ZA_Setoid.

  Definition ZA0 := 0%Z.
  Definition ZA1 := 1%Z.

  Definition ZAadd := Zplus.

  Add Morphism ZAadd with signature ZeqA ==> ZeqA ==> ZeqA as ZAdd_mor.

  Proof.
    intros. rewrite H. rewrite H0. refl.
  Qed.

  Definition ZAmul := Zmult.

  Add Morphism ZAmul with signature ZeqA ==> ZeqA ==> ZeqA as ZAmul_mor.

  Proof.
    intros. rewrite H. rewrite H0. refl.
  Qed.

  Definition ZAopp := Zopp.

  Add Morphism ZAopp with signature ZeqA ==> ZeqA as ZAopp_mor.

  Proof.
    intros. rewrite H. refl.
  Qed.

  Definition ZAsub : Z -> Z -> Z := fun x y => Zplus x (Zopp y).

  Add Morphism ZAsub with signature ZeqA ==> ZeqA ==> ZeqA as ZAsub_mor.

  Proof.
    intros. rewrite H. rewrite H0. refl.
  Qed.

  Lemma ZAring : ring_theory ZA0 ZA1 ZAadd ZAmul ZAsub ZAopp ZeqA.

  Proof.
    constructor.
    exact Zplus_0_l.
    exact Zplus_comm.
    exact Zplus_assoc.
    exact Zmult_1_l.
    exact Zmult_comm.
    exact Zmult_assoc.
    exact Zmult_plus_distr_l.
    refl.
    intro. unfold ZeqA, ZA0, ZAadd, ZAopp, Z.eq. omega.
  Qed.

End IntRing.

(***********************************************************************)
(** ** Rational numbers as a ring .*)

Require Import QArith.

Section Rat_Eqset.

  Definition QA := Q.

  Definition QeqA := Qeq.

  Definition Qsid_theoryA : Setoid_Theory QA QeqA.

  Proof.
    unfold QeqA. constructor.
    unfold Reflexive. refl.
    unfold Symmetric. sym. hyp.
    unfold Transitive. intros. transitivity y; hyp.
  Qed.

End Rat_Eqset.

Section Rat_Eqset_dec.

  Lemma QeqA_dec : forall x y, {QeqA x y} + {~QeqA x y}.

  Proof.
    unfold QeqA. unfold Qeq. intros. apply (dec_beq beq_Z_ok).
  Defined.

  (* Define beqAq of type Q. *)

  Definition QbeqA x y :=
    match QeqA_dec x y with
      | left _ => true
      | right _ => false
    end.

  Notation "x =A= y" := (QeqA x y) (at level 70).

  Lemma QbeqA_ok : forall x y, QbeqA x y = true <-> x =A= y.

  Proof.
  intros. unfold QbeqA. case (QeqA_dec x y); intuition.
  Qed.

End Rat_Eqset_dec.

Section RatRing.

  Add Setoid QA QeqA Qsid_theoryA as QA_Setoid.

  Definition QA0 := 0#1.
  Definition QA1 := 1#1.

  Definition QAadd := Qplus.

  Add Morphism QAadd with signature QeqA ==> QeqA ==> QeqA as QAdd_mor.

  Proof.
    intros. rewrite H. rewrite H0. refl.
  Qed.

  Definition QAmul := Qmult.

  Add Morphism QAmul with signature QeqA ==> QeqA ==> QeqA as QAmul_mor.

  Proof.
    intros. rewrite H. rewrite H0. refl.
  Qed.

  Definition QAopp := Qopp.

  Add Morphism QAopp with signature QeqA ==> QeqA as QAopp_mor.

  Proof.
    intros. rewrite H. refl.
  Qed.

  Definition QAsub : Q -> Q -> Q := fun x y => Qplus x (Qopp y).

  Add Morphism QAsub with signature QeqA ==> QeqA ==> QeqA as QAsub_mor.

  Proof.
    intros. rewrite H. rewrite H0. refl.
  Qed.

  Definition QAring := Qsrt.

  Notation "x ^ n" := (Qpower x n).
  Notation "x =A= y" := (QeqA x y) (at level 70).

  Lemma Qpower_add : forall x n1 n2, x ^ (n1 + n2) =A= x ^ n1 * x ^ n2.

  Proof.
    induction n1; simpl in *; intros; try discr; unfold QeqA; try ring.
    unfold Qpower. destruct n2; try ring.
    unfold Qpower_positive.

  Admitted.

  Add Morphism Qpower with signature QeqA ==> @eq Z ==> QeqA as Qpower_eqA.

  Proof.
    induction y0; simpl; intros. refl. rewrite H. refl.
    unfold QeqA. rewrite H. refl.
  Qed.

End RatRing.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import choice fintype tuple finfun bigop finset binomial.
From mathcomp Require Import fingroup.

(******************************************************************************)
(* This file contains the definition and properties associated to the group   *)
(* of permutations of an arbitrary finite type.                               *)
(*     {perm T} == the type of permutations of a finite type T, i.e.,         *)
(*                 injective (finite) functions from T to T. Permutations     *)
(*                 coerce to CiC functions.                                   *)
(*         'S_n == the set of all permutations of 'I_n, i.e., of {0,.., n-1}  *)
(*  perm_on A u == u is a permutation with support A, i.e., u only displaces  *)
(*                 elements of A (u x != x implies x \in A).                  *)
(*    tperm x y == the transposition of x, y.                                 *)
(*    aperm x s == the image of x under the action of the permutation s.      *)
(*              := s x                                                        *)
(*   pcycle s x == the set of all elements that are in the same cycle of the  *)
(*                 permutation s as x, i.e., {x, s x, (s ^+ 2) x, ...}.       *)
(*    pcycles s == the set of all the cycles of the permutation s.            *)
(*   (s : bool) == s is an odd permutation (the coercion is called odd_perm). *)
(*      dpair u == u is a pair (x, y) of distinct objects (i.e., x != y).     *)
(* lift_perm i j s == the permutation obtained by lifting s : 'S_n.-1 over    *)
(*                 (i |-> j), that maps i to j and lift i k to lift j (s k).  *)
(* Canonical structures are defined allowing permutations to be an eqType,    *)
(* choiceType, countType, finType, subType, finGroupType; permutations with   *)
(* composition form a group, therefore inherit all generic group notations:   *)
(* 1 == identity permutation, * == composition, ^-1 == inverse permutation.   *)
(******************************************************************************)

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

Import GroupScope.

Section PermDefSection.

Variable T : finType.

Inductive perm_type : predArgType :=
  Perm (pval : {ffun T -> T}) & injectiveb pval.
Definition pval p := let: Perm f _ := p in f.
Definition perm_of of phant T := perm_type.
Identity Coercion type_of_perm : perm_of >-> perm_type.

Notation pT := (perm_of (Phant T)).

Canonical perm_subType := Eval hnf in [subType for pval].
Definition perm_eqMixin := Eval hnf in [eqMixin of perm_type by <:].
Canonical perm_eqType := Eval hnf in EqType perm_type perm_eqMixin.
Definition perm_choiceMixin := [choiceMixin of perm_type by <:].
Canonical perm_choiceType := Eval hnf in ChoiceType perm_type perm_choiceMixin.
Definition perm_countMixin := [countMixin of perm_type by <:].
Canonical perm_countType := Eval hnf in CountType perm_type perm_countMixin.
Canonical perm_subCountType := Eval hnf in [subCountType of perm_type].
Definition perm_finMixin := [finMixin of perm_type by <:].
Canonical perm_finType := Eval hnf in FinType perm_type perm_finMixin.
Canonical perm_subFinType := Eval hnf in [subFinType of perm_type].

Canonical perm_for_subType := Eval hnf in [subType of pT].
Canonical perm_for_eqType := Eval hnf in [eqType of pT].
Canonical perm_for_choiceType := Eval hnf in [choiceType of pT].
Canonical perm_for_countType := Eval hnf in [countType of pT].
Canonical perm_for_subCountType := Eval hnf in [subCountType of pT].
Canonical perm_for_finType := Eval hnf in [finType of pT].
Canonical perm_for_subFinType := Eval hnf in [subFinType of pT].

Lemma perm_proof (f : T -> T) : injective f -> injectiveb (finfun f).
Proof.
by move=> f_inj; apply/injectiveP; apply: eq_inj f_inj _ => x; rewrite ffunE.
Qed.

End PermDefSection.

Notation "{ 'perm' T }" := (perm_of (Phant T))
  (at level 0, format "{ 'perm'  T }") : type_scope.

Arguments pval _ _%g.

Bind Scope group_scope with perm_type.
Bind Scope group_scope with perm_of.

Notation "''S_' n" := {perm 'I_n}
  (at level 8, n at level 2, format "''S_' n").

Local Notation fun_of_perm_def := (fun T (u : perm_type T) => val u : T -> T).
Local Notation perm_def := (fun T f injf => Perm (@perm_proof T f injf)).

Module Type PermDefSig.
Parameter fun_of_perm : forall T, perm_type T -> T -> T.
Parameter perm : forall (T : finType) (f : T -> T), injective f -> {perm T}.
Axiom fun_of_permE : fun_of_perm = fun_of_perm_def.
Axiom permE : perm = perm_def.
End PermDefSig.

Module PermDef : PermDefSig.
Definition fun_of_perm := fun_of_perm_def.
Definition perm := perm_def.
Lemma fun_of_permE : fun_of_perm = fun_of_perm_def. Proof. by []. Qed.
Lemma permE : perm = perm_def. Proof. by []. Qed.
End PermDef.

Notation fun_of_perm := PermDef.fun_of_perm.
Notation "@ 'perm'" := (@PermDef.perm) (at level 10, format "@ 'perm'").
Notation perm := (@PermDef.perm _ _).
Canonical fun_of_perm_unlock := Unlockable PermDef.fun_of_permE.
Canonical perm_unlock := Unlockable PermDef.permE.
Coercion fun_of_perm : perm_type >-> Funclass.

Section Theory.

Variable T : finType.
Implicit Types (x y : T) (s t : {perm T}) (S : {set T}).

Lemma permP s t : s =1 t <-> s = t.
Proof. by split=> [| -> //]; rewrite unlock => eq_sv; apply/val_inj/ffunP. Qed.

Lemma pvalE s : pval s = s :> (T -> T).
Proof. by rewrite [@fun_of_perm]unlock. Qed.

Lemma permE f f_inj : @perm T f f_inj =1 f.
Proof. by move=> x; rewrite -pvalE [@perm]unlock ffunE. Qed.

Lemma perm_inj {s} : injective s.
Proof. by rewrite -!pvalE; apply: (injectiveP _ (valP s)). Qed.
Hint Resolve perm_inj : core.

Lemma perm_onto s : codom s =i predT.
Proof. by apply/subset_cardP; rewrite ?card_codom ?subset_predT. Qed.

Definition perm_one := perm (@inj_id T).

Lemma perm_invK s : cancel (fun x => iinv (perm_onto s x)) s.
Proof. by move=> x /=; rewrite f_iinv. Qed.

Definition perm_inv s := perm (can_inj (perm_invK s)).

Definition perm_mul s t := perm (inj_comp (@perm_inj t) (@perm_inj s)).

Lemma perm_oneP : left_id perm_one perm_mul.
Proof. by move=> s; apply/permP => x; rewrite permE /= permE. Qed.

Lemma perm_invP : left_inverse perm_one perm_inv perm_mul.
Proof. by move=> s; apply/permP=> x; rewrite !permE /= permE f_iinv. Qed.

Lemma perm_mulP : associative perm_mul.
Proof. by move=> s t u; apply/permP=> x; do !rewrite permE /=. Qed.

Definition perm_of_baseFinGroupMixin : FinGroup.mixin_of (perm_type T) :=
  FinGroup.Mixin perm_mulP perm_oneP perm_invP.
Canonical perm_baseFinGroupType :=
  Eval hnf in BaseFinGroupType (perm_type T) perm_of_baseFinGroupMixin.
Canonical perm_finGroupType := @FinGroupType perm_baseFinGroupType perm_invP.

Canonical perm_of_baseFinGroupType :=
  Eval hnf in [baseFinGroupType of {perm T}].
Canonical perm_of_finGroupType := Eval hnf in [finGroupType of {perm T} ].

Lemma perm1 x : (1 : {perm T}) x = x.
Proof. by rewrite permE. Qed.

Lemma permM s t x : (s * t) x = t (s x).
Proof. by rewrite permE. Qed.

Lemma permK s : cancel s s^-1.
Proof. by move=> x; rewrite -permM mulgV perm1. Qed.

Lemma permKV s : cancel s^-1 s.
Proof. by have:= permK s^-1; rewrite invgK. Qed.

Lemma permJ s t x : (s ^ t) (t x) = t (s x).
Proof. by rewrite !permM permK. Qed.

Lemma permX s x n : (s ^+ n) x = iter n s x.
Proof. by elim: n => [|n /= <-]; rewrite ?perm1 // -permM expgSr. Qed.

Lemma im_permV s S : s^-1 @: S = s @^-1: S.
Proof. exact: can2_imset_pre (permKV s) (permK s). Qed.

Lemma preim_permV s S : s^-1 @^-1: S = s @: S.
Proof. by rewrite -im_permV invgK. Qed.

Definition perm_on S : pred {perm T} := fun s => [pred x | s x != x] \subset S.

Lemma perm_closed S s x : perm_on S s -> (s x \in S) = (x \in S).
Proof.
move/subsetP=> s_on_S; have [-> // | nfix_s_x] := eqVneq (s x) x.
by rewrite !s_on_S // inE /= ?(inj_eq perm_inj).
Qed.

Lemma perm_on1 H : perm_on H 1.
Proof. by apply/subsetP=> x; rewrite inE /= perm1 eqxx. Qed.

Lemma perm_onM H s t : perm_on H s -> perm_on H t -> perm_on H (s * t).
Proof.
move/subsetP=> sH /subsetP tH; apply/subsetP => x; rewrite inE /= permM.
by have [-> /tH | /sH] := eqVneq (s x) x.
Qed.

Lemma out_perm S u x : perm_on S u -> x \notin S -> u x = x.
Proof. by move=> uS; apply: contraNeq (subsetP uS x). Qed.

Lemma im_perm_on u S : perm_on S u -> u @: S = S.
Proof.
move=> Su; rewrite -preim_permV; apply/setP=> x.
by rewrite !inE -(perm_closed _ Su) permKV.
Qed.

Lemma tperm_proof x y : involutive [fun z => z with x |-> y, y |-> x].
Proof.
move=> z /=; case: (z =P x) => [-> | ne_zx]; first by rewrite eqxx; case: eqP.
by case: (z =P y) => [->| ne_zy]; [rewrite eqxx | do 2?case: eqP].
Qed.

Definition tperm x y := perm (can_inj (tperm_proof x y)).

Variant tperm_spec x y z : T -> Type :=
  | TpermFirst of z = x          : tperm_spec x y z y
  | TpermSecond of z = y         : tperm_spec x y z x
  | TpermNone of z <> x & z <> y : tperm_spec x y z z.

Lemma tpermP x y z : tperm_spec x y z (tperm x y z).
Proof. by rewrite permE /=; do 2?[case: eqP => /=]; constructor; auto. Qed.

Lemma tpermL x y : tperm x y x = y.
Proof. by case: tpermP. Qed.

Lemma tpermR x y : tperm x y y = x.
Proof. by case: tpermP. Qed.

Lemma tpermD x y z : x != z -> y != z -> tperm x y z = z.
Proof. by case: tpermP => // ->; rewrite eqxx. Qed.

Lemma tpermC x y : tperm x y = tperm y x.
Proof. by apply/permP => z; do 2![case: tpermP => //] => ->. Qed.

Lemma tperm1 x : tperm x x = 1.
Proof. by apply/permP => z; rewrite perm1; case: tpermP. Qed.

Lemma tpermK x y : involutive (tperm x y).
Proof. by move=> z; rewrite !permE tperm_proof. Qed.

Lemma tpermKg x y : involutive (mulg (tperm x y)).
Proof. by move=> s; apply/permP=> z; rewrite !permM tpermK. Qed.

Lemma tpermV x y : (tperm x y)^-1 = tperm x y.
Proof. by set t := tperm x y; rewrite -{2}(mulgK t t) -mulgA tpermKg. Qed.

Lemma tperm2 x y : tperm x y * tperm x y = 1.
Proof. by rewrite -{1}tpermV mulVg. Qed.

Lemma card_perm A : #|perm_on A| = (#|A|)`!.
Proof.
pose ffA := {ffun {x | x \in A} -> T}.
rewrite -ffactnn -{2}(card_sig (mem A)) /= -card_inj_ffuns_on.
pose fT (f : ffA) := [ffun x => oapp f x (insub x)].
pose pfT f := insubd (1 : {perm T}) (fT f).
pose fA s : ffA := [ffun u => s (val u)].
rewrite -!sum1dep_card -sum1_card (reindex_onto fA pfT) => [|f].
  apply: eq_bigl => p; rewrite andbC; apply/idP/and3P=> [onA | []]; first split.
  - apply/eqP; suffices fTAp: fT (fA p) = pval p.
      by apply/permP=> x; rewrite -!pvalE insubdK fTAp //; apply: (valP p).
    apply/ffunP=> x; rewrite ffunE pvalE.
    by case: insubP => [u _ <- | /out_perm->] //=; rewrite ffunE.
  - by apply/forallP=> [[x Ax]]; rewrite ffunE /= perm_closed.
  - by apply/injectiveP=> u v; rewrite !ffunE => /perm_inj; apply: val_inj.
  move/eqP=> <- _ _; apply/subsetP=> x; rewrite !inE -pvalE val_insubd fun_if.
  by rewrite if_arg ffunE; case: insubP; rewrite // pvalE perm1 if_same eqxx.
case/andP=> /forallP-onA /injectiveP-f_inj.
apply/ffunP=> u; rewrite ffunE -pvalE insubdK; first by rewrite ffunE valK.
apply/injectiveP=> {u} x y; rewrite !ffunE.
case: insubP => [u _ <-|]; case: insubP => [v _ <-|] //=; first by move/f_inj->.
  by move=> Ay' def_y; rewrite -def_y [_ \in A]onA in Ay'.
by move=> Ax' def_x; rewrite def_x [_ \in A]onA in Ax'.
Qed.

End Theory.

Prenex Implicits tperm permK permKV tpermK.
Arguments perm_inj {T s} [x1 x2] eq_sx12.

(* Shorthand for using a permutation to reindex a bigop. *)
Notation reindex_perm s := (reindex_inj (@perm_inj _ s)).

Lemma inj_tperm (T T' : finType) (f : T -> T') x y z :
  injective f -> f (tperm x y z) = tperm (f x) (f y) (f z).
Proof. by move=> injf; rewrite !permE /= !(inj_eq injf) !(fun_if f). Qed.

Lemma tpermJ (T : finType) x y (s : {perm T}) :
  (tperm x y) ^ s = tperm (s x) (s y).
Proof.
by apply/permP => z; rewrite -(permKV s z) permJ; apply/inj_tperm/perm_inj.
Qed.

Lemma tuple_permP {T : eqType} {n} {s : seq T} {t : n.-tuple T} :
  reflect (exists p : 'S_n, s = [tuple tnth t (p i) | i < n]) (perm_eq s t).
Proof.
apply: (iffP idP) => [|[p ->]]; last first.
  rewrite /= (map_comp (tnth t)) -{1}(map_tnth_enum t) perm_map //.
  apply: uniq_perm => [||i]; rewrite ?enum_uniq //.
    by apply/injectiveP; apply: perm_inj.
  by rewrite mem_enum -[i](permKV p) image_f.
case: n => [|n] in t *; last have x0 := tnth t ord0.
  rewrite tuple0 => /perm_small_eq-> //.
  by exists 1; rewrite [mktuple _]tuple0.
case/(perm_iotaP x0); rewrite size_tuple => Is eqIst ->{s}.
have uniqIs: uniq Is by rewrite (perm_uniq eqIst) iota_uniq.
have szIs: size Is == n.+1 by rewrite (perm_size eqIst) !size_tuple.
have pP i : tnth (Tuple szIs) i < n.+1.
  by rewrite -[_ < _](mem_iota 0) -(perm_mem eqIst) mem_tnth.
have inj_p: injective (fun i => Ordinal (pP i)).
  by apply/injectiveP/(@map_uniq _ _ val); rewrite -map_comp map_tnth_enum.
exists (perm inj_p); rewrite -[Is]/(tval (Tuple szIs)); congr (tval _).
by apply: eq_from_tnth => i; rewrite tnth_map tnth_mktuple permE (tnth_nth x0).
Qed.

Section PermutationParity.

Variable T : finType.

Implicit Types (s t u v : {perm T}) (x y z a b : T).

(* Note that pcycle s x is the orbit of x by <[s]> under the action aperm. *)
(* Hence, the pcycle lemmas below are special cases of more general lemmas *)
(* on orbits that will be stated in action.v.                              *)
(*   Defining pcycle directly here avoids a dependency of matrix.v on      *)
(* action.v and hence morphism.v.                                          *)

Definition aperm x s := s x.
Definition pcycle s x := aperm x @: <[s]>.
Definition pcycles s := pcycle s @: T.
Definition odd_perm (s : perm_type T) := odd #|T| (+) odd #|pcycles s|.

Lemma apermE x s : aperm x s = s x. Proof. by []. Qed.

Lemma mem_pcycle s i x : (s ^+ i) x \in pcycle s x.
Proof. by rewrite (mem_imset (aperm x)) ?mem_cycle. Qed.

Lemma pcycle_id s x : x \in pcycle s x.
Proof. by rewrite -{1}[x]perm1 (mem_pcycle s 0). Qed.

Lemma uniq_traject_pcycle s x : uniq (traject s x #|pcycle s x|).
Proof.
case def_n: #|_| => // [n]; rewrite looping_uniq.
apply: contraL (card_size (traject s x n)) => /loopingP t_sx.
rewrite -ltnNge size_traject -def_n ?subset_leq_card //.
by apply/subsetP=> _ /imsetP[_ /cycleP[i ->] ->]; rewrite /aperm permX t_sx.
Qed.

Lemma pcycle_traject s x : pcycle s x =i traject s x #|pcycle s x|.
Proof.
apply: fsym; apply/subset_cardP.
  by rewrite (card_uniqP _) ?size_traject ?uniq_traject_pcycle.
by apply/subsetP=> _ /trajectP[i _ ->]; rewrite -permX mem_pcycle.
Qed.

Lemma iter_pcycle s x : iter #|pcycle s x| s x = x.
Proof.
case def_n: #|_| (uniq_traject_pcycle s x) => [//|n] Ut.
have: looping s x n.+1.
  by rewrite -def_n -[looping _ _ _]pcycle_traject -permX mem_pcycle.
rewrite /looping => /trajectP[[|i] //= lt_i_n /perm_inj eq_i_n_sx].
move: lt_i_n; rewrite ltnS ltn_neqAle andbC => /andP[le_i_n /negP[]].
by rewrite -(nth_uniq x _ _ Ut) ?size_traject ?nth_traject // eq_i_n_sx.
Qed.

Lemma eq_pcycle_mem s x y : (pcycle s x == pcycle s y) = (x \in pcycle s y).
Proof.
apply/eqP/idP=> [<- | /imsetP[si s_si ->]]; first exact: pcycle_id.
apply/setP => z; apply/imsetP/imsetP=> [] [sj s_sj ->].
  by exists (si * sj); rewrite ?groupM /aperm ?permM.
exists (si^-1 * sj); first by rewrite groupM ?groupV.
by rewrite /aperm permM permK.
Qed.

Lemma pcycle_sym s x y : (x \in pcycle s y) = (y \in pcycle s x).
Proof. by rewrite -!eq_pcycle_mem eq_sym. Qed.

Lemma pcycle_perm s i x : pcycle s ((s ^+ i) x) = pcycle s x.
Proof. by apply/eqP; rewrite eq_pcycle_mem mem_pcycle. Qed.

Lemma ncycles_mul_tperm s x y : let t := tperm x y in
  #|pcycles (t * s)| + (x \notin pcycle s y).*2 = #|pcycles s| + (x != y).
Proof.
pose xf a b u := find (pred2 a b) (traject u (u a) #|pcycle u a|).
have xf_size a b u: xf a b u <= #|pcycle u a|.
  by rewrite (leq_trans (find_size _ _)) ?size_traject.
have lt_xf a b u n : n < xf a b u -> ~~ pred2 a b ((u ^+ n.+1) a).
  move=> lt_n; apply: contraFN (before_find (u a) lt_n).
  by rewrite permX iterSr nth_traject // (leq_trans lt_n).
pose t a b u := tperm a b * u.
have tC a b u : t a b u = t b a u by rewrite /t tpermC.
have tK a b: involutive (t a b) by move=> u; apply: tpermKg.
have tXC a b u n: n <= xf a b u -> (t a b u ^+ n.+1) b = (u ^+ n.+1) a.
  elim: n => [|n IHn] lt_n_f; first by rewrite permM tpermR.
  rewrite !(expgSr _ n.+1) !permM {}IHn 1?ltnW //; congr (u _).
  by case/lt_xf/norP: lt_n_f => ne_a ne_b; rewrite tpermD // eq_sym.
have eq_xf a b u: pred2 a b ((u ^+ (xf a b u).+1) a).
  have ua_a: a \in pcycle u (u a) by rewrite pcycle_sym (mem_pcycle _ 1).
  have has_f: has (pred2 a b) (traject u (u a) #|pcycle u (u a)|).
    by apply/hasP; exists a; rewrite /= ?eqxx -?pcycle_traject.
  have:= nth_find (u a) has_f; rewrite has_find size_traject in has_f.
  rewrite -eq_pcycle_mem in ua_a.
  by rewrite nth_traject // -iterSr -permX -(eqP ua_a).
have xfC a b u: xf b a (t a b u) = xf a b u.
  without loss lt_a: a b u / xf b a (t a b u) < xf a b u.
    move=> IHab; set m := xf b a _; set n := xf a b u.
    by case: (ltngtP m n) => // ltx; [apply: IHab | rewrite -[m]IHab tC tK].
  by move/lt_xf: (lt_a); rewrite -(tXC a b) 1?ltnW //= orbC [_ || _]eq_xf.
pose ts := t x y s; rewrite /= -[_ * s]/ts.
pose dp u := #|pcycles u :\ pcycle u y :\ pcycle u x|.
rewrite !(addnC #|_|) (cardsD1 (pcycle ts y)) mem_imset ?inE //.
rewrite (cardsD1 (pcycle ts x)) inE mem_imset ?inE //= -/(dp ts) {}/ts.
rewrite (cardsD1 (pcycle s y)) (cardsD1 (pcycle s x)) !(mem_imset, inE) //.
rewrite -/(dp s) !addnA !eq_pcycle_mem andbT; congr (_ + _); last first.
  wlog suffices: s / dp s <= dp (t x y s).
    by move=> IHs; apply/eqP; rewrite eqn_leq -{2}(tK x y s) !IHs.
  apply/subset_leq_card/subsetP=> {dp} C.
  rewrite !inE andbA andbC !(eq_sym C) => /and3P[/imsetP[z _ ->{C}]].
  rewrite 2!eq_pcycle_mem => sxz syz.
  suffices ts_z: pcycle (t x y s) z = pcycle s z.
    by rewrite -ts_z !eq_pcycle_mem {1 2}ts_z sxz syz mem_imset ?inE.
  suffices exp_id n: ((t x y s) ^+ n) z = (s ^+ n) z.
    apply/setP=> u; apply/idP/idP=> /imsetP[_ /cycleP[i ->] ->].
      by rewrite /aperm exp_id mem_pcycle.
    by rewrite /aperm -exp_id mem_pcycle.
  elim: n => // n IHn; rewrite !expgSr !permM {}IHn tpermD //.
    by apply: contraNneq sxz => ->; apply: mem_pcycle.
  by apply: contraNneq syz => ->; apply: mem_pcycle.
case: eqP {dp} => [<- | ne_xy]; first by rewrite /t tperm1 mul1g pcycle_id.
suff ->: (x \in pcycle (t x y s) y) = (x \notin pcycle s y) by case: (x \in _).
without loss xf_x: s x y ne_xy / (s ^+ (xf x y s).+1) x = x.
  move=> IHs; have ne_yx := nesym ne_xy; have:= eq_xf x y s; set n := xf x y s.
  case/pred2P=> [|snx]; first exact: IHs.
  by rewrite -[x \in _]negbK ![x \in _]pcycle_sym -{}IHs ?xfC ?tXC // tC tK.
rewrite -{1}xf_x -(tXC _ _ _ _ (leqnn _)) mem_pcycle; symmetry.
rewrite -eq_pcycle_mem eq_sym eq_pcycle_mem pcycle_traject.
apply/trajectP=> [[n _ snx]].
have: looping s x (xf x y s).+1 by rewrite /looping -permX xf_x inE eqxx.
move/loopingP/(_ n); rewrite -{n}snx.
case/trajectP=> [[_|i]]; first exact: nesym; rewrite ltnS -permX => lt_i def_y.
by move/lt_xf: lt_i; rewrite def_y /= eqxx orbT.
Qed.

Lemma odd_perm1 : odd_perm 1 = false.
Proof.
rewrite /odd_perm card_imset ?addbb // => x y; move/eqP.
by rewrite eq_pcycle_mem /pcycle cycle1 imset_set1 /aperm perm1; move/set1P.
Qed.

Lemma odd_mul_tperm x y s : odd_perm (tperm x y * s) = (x != y) (+) odd_perm s.
Proof.
rewrite addbC -addbA -[~~ _]oddb -odd_add -ncycles_mul_tperm.
by rewrite odd_add odd_double addbF.
Qed.

Lemma odd_tperm x y : odd_perm (tperm x y) = (x != y).
Proof. by rewrite -[_ y]mulg1 odd_mul_tperm odd_perm1 addbF. Qed.

Definition dpair (eT : eqType) := [pred t | t.1 != t.2 :> eT].
Arguments dpair {eT}.

Lemma prod_tpermP s :
  {ts : seq (T * T) | s = \prod_(t <- ts) tperm t.1 t.2 & all dpair ts}.
Proof.
have [n] := ubnP #|[pred x | s x != x]|; elim: n s => // n IHn s /ltnSE-le_s_n.
case: (pickP (fun x => s x != x)) => [x s_x | s_id]; last first.
  exists nil; rewrite // big_nil; apply/permP=> x.
  by apply/eqP/idPn; rewrite perm1 s_id.
have [|ts def_s ne_ts] := IHn (tperm x (s^-1 x) * s); last first.
  exists ((x, s^-1 x) :: ts); last by rewrite /= -(canF_eq (permK _)) s_x.
  by rewrite big_cons -def_s mulgA tperm2 mul1g.
rewrite (cardD1 x) !inE s_x in le_s_n; apply: leq_ltn_trans le_s_n.
apply: subset_leq_card; apply/subsetP=> y.
rewrite !inE permM permE /= -(canF_eq (permK _)).
have [-> | ne_yx] := altP (y =P x); first by rewrite permKV eqxx.
by case: (s y =P x) => // -> _; rewrite eq_sym.
Qed.

Lemma odd_perm_prod ts :
  all dpair ts -> odd_perm (\prod_(t <- ts) tperm t.1 t.2) = odd (size ts).
Proof.
elim: ts => [_|t ts IHts] /=; first by rewrite big_nil odd_perm1.
by case/andP=> dt12 dts; rewrite big_cons odd_mul_tperm dt12 IHts.
Qed.

Lemma odd_permM : {morph odd_perm : s1 s2 / s1 * s2 >-> s1 (+) s2}.
Proof.
move=> s1 s2; case: (prod_tpermP s1) => ts1 ->{s1} dts1.
case: (prod_tpermP s2) => ts2 ->{s2} dts2.
by rewrite -big_cat !odd_perm_prod ?all_cat ?dts1 // size_cat odd_add.
Qed.

Lemma odd_permV s : odd_perm s^-1 = odd_perm s.
Proof. by rewrite -{2}(mulgK s s) !odd_permM -addbA addKb. Qed.

Lemma odd_permJ s1 s2 : odd_perm (s1 ^ s2) = odd_perm s1.
Proof. by rewrite !odd_permM odd_permV addbC addbK. Qed.

End PermutationParity.

Coercion odd_perm : perm_type >-> bool.
Arguments dpair {eT}.
Prenex Implicits pcycle dpair pcycles aperm.

Section LiftPerm.
(* Somewhat more specialised constructs for permutations on ordinals. *)

Variable n : nat.
Implicit Types i j : 'I_n.+1.
Implicit Types s t : 'S_n.

Definition lift_perm_fun i j s k :=
  if unlift i k is Some k' then lift j (s k') else j.

Lemma lift_permK i j s :
  cancel (lift_perm_fun i j s) (lift_perm_fun j i s^-1).
Proof.
rewrite /lift_perm_fun => k.
by case: (unliftP i k) => [j'|] ->; rewrite (liftK, unlift_none) ?permK.
Qed.

Definition lift_perm i j s := perm (can_inj (lift_permK i j s)).

Lemma lift_perm_id i j s : lift_perm i j s i = j.
Proof. by rewrite permE /lift_perm_fun unlift_none. Qed.

Lemma lift_perm_lift i j s k' :
  lift_perm i j s (lift i k') = lift j (s k') :> 'I_n.+1.
Proof. by rewrite permE /lift_perm_fun liftK. Qed.

Lemma lift_permM i j k s t :
  lift_perm i j s * lift_perm j k t = lift_perm i k (s * t).
Proof.
apply/permP=> i1; case: (unliftP i i1) => [i2|] ->{i1}.
  by rewrite !(permM, lift_perm_lift).
by rewrite permM !lift_perm_id.
Qed.

Lemma lift_perm1 i : lift_perm i i 1 = 1.
Proof. by apply: (mulgI (lift_perm i i 1)); rewrite lift_permM !mulg1. Qed.

Lemma lift_permV i j s : (lift_perm i j s)^-1 = lift_perm j i s^-1.
Proof. by apply/eqP; rewrite eq_invg_mul lift_permM mulgV lift_perm1. Qed.

Lemma odd_lift_perm i j s : lift_perm i j s = odd i (+) odd j (+) s :> bool.
Proof.
rewrite -{1}(mul1g s) -(lift_permM _ j) odd_permM.
congr (_ (+) _); last first.
  case: (prod_tpermP s) => ts ->{s} _.
  elim: ts => [|t ts IHts] /=; first by rewrite big_nil lift_perm1 !odd_perm1.
  rewrite big_cons odd_mul_tperm -(lift_permM _ j) odd_permM {}IHts //.
  congr (_ (+) _); transitivity (tperm (lift j t.1) (lift j t.2)); last first.
     by rewrite odd_tperm (inj_eq (pcan_inj (liftK j))).
  congr odd_perm; apply/permP=> k; case: (unliftP j k) => [k'|] ->.
    by rewrite lift_perm_lift inj_tperm //; apply: lift_inj.
  by rewrite lift_perm_id tpermD // eq_sym neq_lift.
suff{i j s} odd_lift0 (k : 'I_n.+1): lift_perm ord0 k 1 = odd k :> bool.
  rewrite -!odd_lift0 -{2}invg1 -lift_permV odd_permV -odd_permM.
  by rewrite lift_permM mulg1.
elim: {k}(k : nat) {1 3}k (erefl (k : nat)) => [|m IHm] k def_k.
  by rewrite (_ : k = ord0) ?lift_perm1 ?odd_perm1 //; apply: val_inj.
have le_mn: m < n.+1 by [rewrite -def_k ltnW]; pose j := Ordinal le_mn.
rewrite -(mulg1 1)%g -(lift_permM _ j) odd_permM {}IHm // addbC.
rewrite (_ : _ 1 = tperm j k); first by rewrite odd_tperm neq_ltn def_k leqnn.
apply/permP=> i; case: (unliftP j i) => [i'|] ->; last first.
  by rewrite lift_perm_id tpermL.
apply: ord_inj; rewrite lift_perm_lift !permE /= eq_sym -if_neg neq_lift.
rewrite fun_if -val_eqE /= def_k /bump ltn_neqAle andbC.
case: leqP => [_ | lt_i'm] /=; last by rewrite -if_neg neq_ltn leqW.
by rewrite add1n eqSS; case: eqVneq.
Qed.

End LiftPerm.

Prenex Implicits lift_perm lift_permK.

Notation tuple_perm_eqP :=
  (deprecate tuple_perm_eqP tuple_permP) (only parsing).


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.Properties.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Cartesians.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Trivial.

Local Open Scope cat.

(**
The trivial bicategory has a cleaving
 *)
Section ConstantCleaving.
  Variable (B₁ B₂ : bicat).

  (** Characterisation of cartesian 2-cells *)
  Definition trivial_invertible_is_cartesian_2cell
             {x₁ x₂ : B₁}
             {y₁ : trivial_displayed_bicat B₁ B₂ x₁}
             {y₂ : trivial_displayed_bicat B₁ B₂ x₂}
             {f₁ f₂ : x₁ --> x₂}
             {g₁ : y₁ -->[ f₁ ] y₂}
             {g₂ : y₁ -->[ f₂ ] y₂}
             (α : f₁ ==> f₂)
             (β : g₁ ==>[ α ] g₂)
             (Hβ : is_invertible_2cell β)
    : is_cartesian_2cell (trivial_displayed_bicat B₁ B₂) β.
  Proof.
    intros h h' γ ββ ; cbn in *.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros τ₁ τ₂ ;
         use subtypePath ; [ intro ; apply cellset_property | ] ;
         use (vcomp_rcancel _ Hβ) ;
         exact (pr2 τ₁ @ !(pr2 τ₂))).
    - refine (ββ • Hβ^-1 ,, _).
      abstract
        (rewrite !vassocl ;
         rewrite vcomp_linv ;
         apply id2_right).
  Defined.

  Definition trivial_cartesian_2cell_is_invertible
             {x₁ x₂ : B₁}
             {y₁ : trivial_displayed_bicat B₁ B₂ x₁}
             {y₂ : trivial_displayed_bicat B₁ B₂ x₂}
             {f₁ f₂ : x₁ --> x₂}
             {g₁ : y₁ -->[ f₁ ] y₂}
             {g₂ : y₁ -->[ f₂ ] y₂}
             (α : f₁ ==> f₂)
             (β : g₁ ==>[ α ] g₂)
             (Hβ : is_cartesian_2cell (trivial_displayed_bicat B₁ B₂) β)
    : is_invertible_2cell β.
  Proof.
    cbn in *.
    unfold is_cartesian_2cell in Hβ.
    pose (Hβ f₁ g₂ (id2 _) (id2 _)) as lift.
    pose (inv := iscontrpr1 lift).
    cbn in lift, inv.
    use make_is_invertible_2cell.
    - exact (pr1 inv).
    - abstract
        (pose (Hβ f₁ g₁ (id2 _) β) as m ;
         cbn in m ;
         pose (proofirrelevance _ (isapropifcontr m)) as i ;
         simple refine (maponpaths pr1 (i (β • pr1 inv ,, _) (id₂ g₁ ,, _))) ; cbn ;
         [ cbn ;
           rewrite vassocl ;
           rewrite (pr2 inv) ;
           apply id2_right
         | apply id2_left ]).
    - abstract
        (exact (pr2 inv)).
  Defined.

  (** Characterisation of cartesian 2-cells *)
  Definition trivial_invertible_is_opcartesian_2cell
             {x₁ x₂ : B₁}
             {y₁ : trivial_displayed_bicat B₁ B₂ x₁}
             {y₂ : trivial_displayed_bicat B₁ B₂ x₂}
             {f₁ f₂ : x₁ --> x₂}
             {g₁ : y₁ -->[ f₁ ] y₂}
             {g₂ : y₁ -->[ f₂ ] y₂}
             (α : f₁ ==> f₂)
             (β : g₁ ==>[ α ] g₂)
             (Hβ : is_invertible_2cell β)
    : is_opcartesian_2cell (trivial_displayed_bicat B₁ B₂) β.
  Proof.
    intros h h' γ ββ ; cbn in *.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros τ₁ τ₂ ;
         use subtypePath ; [ intro ; apply cellset_property | ] ;
         use (vcomp_lcancel _ Hβ) ;
         exact (pr2 τ₁ @ !(pr2 τ₂))).
    - refine (Hβ^-1 • ββ,, _).
      abstract
        (rewrite !vassocr ;
         rewrite vcomp_rinv ;
         apply id2_left).
  Defined.

  Definition trivial_opcartesian_2cell_is_invertible
             {x₁ x₂ : B₁}
             {y₁ : trivial_displayed_bicat B₁ B₂ x₁}
             {y₂ : trivial_displayed_bicat B₁ B₂ x₂}
             {f₁ f₂ : x₁ --> x₂}
             {g₁ : y₁ -->[ f₁ ] y₂}
             {g₂ : y₁ -->[ f₂ ] y₂}
             (α : f₁ ==> f₂)
             (β : g₁ ==>[ α ] g₂)
             (Hβ : is_opcartesian_2cell (trivial_displayed_bicat B₁ B₂) β)
    : is_invertible_2cell β.
  Proof.
    cbn in *.
    unfold is_cartesian_2cell in Hβ.
    pose (Hβ f₂ g₁ (id2 _) (id2 _)) as lift.
    pose (inv := iscontrpr1 lift).
    cbn in lift, inv.
    use make_is_invertible_2cell.
    - exact (pr1 inv).
    - abstract
        (exact (pr2 inv)).
    - abstract
        (pose (Hβ f₂ g₂ (id2 _) β) as m ;
         cbn in m ;
         pose (proofirrelevance _ (isapropifcontr m)) as i ;
         simple refine (maponpaths pr1 (i (pr1 inv • β,, _) (id₂ g₂ ,, _))) ; cbn ;
         [ cbn ;
           rewrite vassocr ;
           rewrite (pr2 inv) ;
           apply id2_left
         | apply id2_right ]).
  Defined.

  Definition trivial_local_cleaving
    : local_cleaving (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros x₁ x₂ y₁ y₂ f₁ f₂ f α.
    simple refine (f ,, id2 _ ,, _) ; cbn.
    apply trivial_invertible_is_cartesian_2cell.
    is_iso.
  Defined.

  Definition trivial_local_opcleaving
    : local_opcleaving (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros x₁ x₂ y₁ y₂ f₁ f₂ f α.
    simple refine (f ,, id2 _ ,, _) ; cbn.
    apply trivial_invertible_is_opcartesian_2cell.
    is_iso.
  Defined.

  Definition trivial_local_isocleaving
    : local_iso_cleaving (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros x₁ x₂ y₁ y₂ f₁ f₂ f α.
    refine (f ,, id2 _ ,, _).
    apply trivial_is_invertible_2cell_to_is_disp_invertible.
    is_iso.
  Defined.

  Section TrivialCartesianOneCell.
    Context {x₁ x₂ : B₁}
            {y₁ : trivial_displayed_bicat B₁ B₂ x₁}
            {y₂ : trivial_displayed_bicat B₁ B₂ x₂}
            (f : x₁ --> x₂)
            (g : y₁ -->[ f ] y₂)
            (Hg : left_adjoint_equivalence g).

    Definition trivial_lift_1cell
               {x₃ : B₁}
               {y₃ : trivial_displayed_bicat B₁ B₂ x₃}
               (h : x₃ --> x₁)
               (k : y₃ -->[ h · f] y₂)
      : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) g k.
    Proof.
      simple refine (_ ,, _) ; cbn in *.
      - exact (k · left_adjoint_right_adjoint Hg).
      - simple refine (_ ,, _) ; cbn.
        + refine (rassociator _ _ _ • (k ◃ _) • runitor _).
          exact (left_adjoint_counit Hg).
        + cbn.
          use trivial_is_invertible_2cell_to_is_disp_invertible.
          is_iso.
          apply (left_equivalence_counit_iso Hg).
    Defined.

    Definition trivial_lift_2cell
               {w : B₁}
               {z : B₂}
               {h h' : w --> x₁}
               {k k' : z --> y₂}
               (γ : h ==> h')
               (δ : k ==> k')
               (Lh : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) g k)
               (Lh' : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) g k')
      : lift_2cell_factor (trivial_displayed_bicat B₁ B₂) g (δ := γ) δ Lh Lh'.
    Proof.
      use iscontraprop1.
      - abstract
          (use invproofirrelevance ;
           intros φ₁ φ₂ ;
           induction φ₁ as [ φ₁ ψ₁ ] ;
           induction φ₂ as [ φ₂ ψ₂ ] ;
           use subtypePath ; [ intro ; apply cellset_property | ] ;
           cbn in * ;
           rewrite transportf_const in ψ₁, ψ₂ ;
           cbn in * ;
           apply (fully_faithful_1cell_faithful (adj_equiv_fully_faithful Hg)) ;
           pose (p₂ := trivial_disp_invertible_to_invertible_2cell (pr2 Lh')) ;
           use (vcomp_rcancel p₂) ; [ apply p₂ | ] ;
           exact (ψ₁ @ !ψ₂)).
      - simple refine (_ ,, _) ; cbn.
        + exact (fully_faithful_1cell_inv_map
                   (adj_equiv_fully_faithful Hg)
                   (pr12 Lh
                    • δ
                    • trivial_disp_invertible_to_invertible_2cell (pr2 Lh')^-1)).
        + abstract
            (rewrite transportf_const ; cbn ;
             etrans ;
             [ apply maponpaths_2 ;
               apply (fully_faithful_1cell_inv_map_eq (adj_equiv_fully_faithful Hg))
             | ] ;
             cbn in * ;
             rewrite !vassocl ;
             apply maponpaths ;
             refine (_ @ id2_right _) ;
             apply maponpaths ;
             apply (vcomp_linv
                      (trivial_disp_invertible_to_invertible_2cell (pr2 Lh')))).
    Defined.

    Definition trivial_cartesian_1cell
      : cartesian_1cell (trivial_displayed_bicat B₁ B₂) g.
    Proof.
      split.
      - exact @trivial_lift_1cell.
      - exact @trivial_lift_2cell.
    Defined.
  End TrivialCartesianOneCell.

  Section Cartesian1CellToAdjEquiv.
    Context {x₁ x₂ : B₁}
            {y₁ : trivial_displayed_bicat B₁ B₂ x₁}
            {y₂ : trivial_displayed_bicat B₁ B₂ x₂}
            (f : x₁ --> x₂)
            (g : y₁ -->[ f ] y₂)
            (Hg : cartesian_1cell (trivial_displayed_bicat B₁ B₂) g).

    Let inv : y₂ --> y₁ := pr1 (pr1 Hg x₁ y₂ (id₁ _) (id₁ _)).
    Let ε : inv · g ==> id₁ y₂ := pr12 (pr1 Hg x₁ y₂ (id₁ _) (id₁ _)).
    Let εinv
      : is_invertible_2cell ε
      := trivial_disp_invertible_to_invertible_2cell
           (pr2 (pr1 Hg x₁ y₂ (id₁ _) (id₁ _))).

    Local Definition unit_help_lift₁
      : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) (h := id₁ _) g g.
    Proof.
      simple refine (_ ,, _ ,, _) ; cbn.
      - apply id₁.
      - apply lunitor.
      - use trivial_is_invertible_2cell_to_is_disp_invertible.
        is_iso.
    Defined.

    Local Definition unit_help_lift₂
      : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) (h := id₁ _) g g.
    Proof.
      simple refine (_ ,, _ ,, _) ; cbn.
      - exact (g · inv).
      - exact (rassociator _ _ _ • (g ◃ ε) • runitor _).
      - use trivial_is_invertible_2cell_to_is_disp_invertible.
        is_iso.
    Defined.

    Local Definition unit
      : id₁ y₁ ==> g · inv
      := cartesian_1cell_lift_2cell
           _ _
           Hg
           (δ := id2 _) (id2 _)
           unit_help_lift₁ unit_help_lift₂.

    Definition trivial_cartesian_1cell_left_adj_data
      : left_adjoint_data g
      := (inv ,, unit ,, ε).

    Definition trivial_cartesian_1cell_left_equiv_axioms
      : left_equivalence_axioms trivial_cartesian_1cell_left_adj_data.
    Proof.
      split.
      - use (trivial_is_disp_invertible_to_is_invertible_2cell (α := id2 (id₁ _))).
        + is_iso.
        + refine (cartesian_1cell_lift_2cell_invertible
                   _ Hg _ _
                   unit_help_lift₁
                   unit_help_lift₂).
          use trivial_is_invertible_2cell_to_is_disp_invertible.
          is_iso.
      - exact εinv.
    Defined.

    Definition trivial_cartesian_1cell_is_adj_equiv
      : left_adjoint_equivalence g.
    Proof.
      use equiv_to_adjequiv.
      simple refine (_ ,, _).
      - exact trivial_cartesian_1cell_left_adj_data.
      - exact trivial_cartesian_1cell_left_equiv_axioms.
    Defined.
  End Cartesian1CellToAdjEquiv.

  Definition trivial_global_cleaving
    : global_cleaving (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros x₁ x₂ y₁ y₂.
    simple refine (y₁ ,, id₁ _ ,, _) ; cbn.
    apply trivial_cartesian_1cell.
    apply (internal_adjoint_equivalence_identity y₁).
  Defined.

  Definition trivial_lwhisker_cartesian
    : lwhisker_cartesian (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα.
    apply trivial_invertible_is_cartesian_2cell.
    cbn.
    is_iso.
    apply trivial_cartesian_2cell_is_invertible.
    apply Hαα.
  Qed.

  Definition trivial_rwhisker_cartesian
    : rwhisker_cartesian (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα.
    apply trivial_invertible_is_cartesian_2cell.
    cbn.
    is_iso.
    apply trivial_cartesian_2cell_is_invertible.
    apply Hαα.
  Qed.

  Definition trivial_lwhisker_opcartesian
    : lwhisker_opcartesian (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα.
    apply trivial_invertible_is_opcartesian_2cell.
    cbn.
    is_iso.
    apply trivial_opcartesian_2cell_is_invertible.
    apply Hαα.
  Qed.

  Definition trivial_rwhisker_opcartesian
    : rwhisker_opcartesian (trivial_displayed_bicat B₁ B₂).
  Proof.
    intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα.
    apply trivial_invertible_is_opcartesian_2cell.
    cbn.
    is_iso.
    apply trivial_opcartesian_2cell_is_invertible.
    apply Hαα.
  Qed.

  Definition trivial_cleaving_of_bicats
    : cleaving_of_bicats (trivial_displayed_bicat B₁ B₂).
  Proof.
    repeat split.
    - exact trivial_local_cleaving.
    - exact trivial_global_cleaving.
    - exact trivial_lwhisker_cartesian.
    - exact trivial_rwhisker_cartesian.
  Defined.
End ConstantCleaving.


Require Import Eqdep_dec.
From mathcomp Require Import all_ssreflect.
Require Import PArith core_defs.
Require list_defs.

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

Open Scope positive_scope.

Inductive t :=
  | T0
  | T1 of list t.

Section Ind.

  Context (Pl : list t -> Prop) (P : t -> Prop).
  Context (Hnil : Pl [::]) (Hcons: forall t l, P t -> Pl l -> Pl (t::l))
          (HT0 : P T0) (HT1 : forall l, Pl l -> P (T1 l)).

  Fixpoint t_Ind (x : t) : P x :=
    match x with
    | T0 => HT0
    | T1 l => @HT1 l (@list_defs.list_Ind t P Pl t_Ind Hnil Hcons l)
    end.

End Ind.

Module AUX.

Definition tag (x : t) :=
  match x with
  | T0     => 1
  | T1 _   => 2
  end.

Definition fields_t (p:positive) : Type :=
  match p with
  | 2 => list t
  | _ => unit
  end.

Definition fields (x:t) : fields_t (tag x) :=
  match x return fields_t (tag x) with
  | T0 => tt
  | T1 o => o
  end.

Definition construct (p:positive) : fields_t p -> option t :=
  match p with
  | 1 => fun _ => Some T0
  | 2 => fun o => Some (T1 o)
  | _ => fun _ => None
  end.

Lemma constructP x : construct (fields x) = Some x.
Proof. by case: x. Qed.

End AUX.

Local Instance t_obj : @obj t :=
  {| tag        := AUX.tag
   ; fields_t   := AUX.fields_t
   ; fields     := AUX.fields
   ; construct  := AUX.construct
   ; constructP := AUX.constructP |}.

Section Fields.

Context (eqb : t -> t -> bool).

Definition eqb_fields (p:positive) : fields_t p -> fields_t p -> bool :=
  match p return fields_t p -> fields_t p -> bool with
  | 1 => eq_op
  | 2 => @list_defs.eqb t eqb
  | _ => eq_op
  end.

End Fields.

Fixpoint eqb (x1 x2:t) :=
  match x1 with
  | T0   => eqb_body (eqb_fields eqb) (t1:=1) tt x2
  | T1 o => eqb_body (eqb_fields eqb) (t1:=2) o x2
  end.

Lemma eqb_correct_on_T0 : eqb_correct_on eqb T0.
Proof.
  rewrite /eqb_correct_on /=.
  by apply (@eqb_body_correct _ t_obj (eqb_fields eqb) T0).
Qed.

Lemma eqb_correct_on_T1 (o : list t) :
  eqb_correct_on (list_defs.eqb eqb) o -> eqb_correct_on eqb (T1 o).
Proof.
  rewrite /eqb_correct_on /=.
  move=> h; apply (@eqb_body_correct _ t_obj (eqb_fields eqb) (T1 o)).
  by rewrite /eqb_fields_correct_on /= => ? /h ->.
Qed.

Lemma eqb_correct (x1 x2: t) : eqb x1 x2 -> x1 = x2.
Proof.
  apply (@t_Ind (eqb_correct_on (list_defs.eqb eqb)) (eqb_correct_on eqb)) => {x1 x2}.
  + by apply list_defs.eqb_correct_on_nil.
  + by apply list_defs.eqb_correct_on_cons.
  + by apply eqb_correct_on_T0.
  by apply eqb_correct_on_T1.
Qed.

Lemma eqb_refl_on_T0 : eqb_refl_on eqb T0.
Proof. done. Qed.

Lemma eqb_refl_on_T1 (o : list t) :
  eqb_refl_on (list_defs.eqb eqb) o -> eqb_refl_on eqb (T1 o).
Proof. apply (@eqb_body_refl _ t_obj (eqb_fields eqb) (T1 o)). Qed.

Lemma eqb_refl (x:t) : eqb x x.
Proof.
  apply (@t_Ind (eqb_refl_on (list_defs.eqb eqb)) (eqb_refl_on eqb)) => {x}.
  + by apply list_defs.eqb_refl_on_nil.
  + by apply list_defs.eqb_refl_on_cons.
  + by apply eqb_refl_on_T0.
  apply eqb_refl_on_T1.
Qed.

Lemma eqbP x1 x2 : reflect (x1 = x2) (eqb x1 x2).
Proof. apply (iffP idP);[ apply eqb_correct | move=> ->; apply eqb_refl]. Qed.


From Usuba Require Import usuba_AST collect usuba_sem equiv_rel.
From Coq Require Import MSets MSets.MSetToFiniteSet MSets.MSetFacts.
Require Import Coq.Structures.OrdersEx.
From mathcomp Require Import all_ssreflect.
Require Import Coq.Sets.Ensembles.

Lemma iset_empty_soudness:
    forall elt : iset.elt,
    iset.In elt iset.empty <-> In ident (Empty_set ident) elt.
Proof.
    move=> elt.
        pose (Hempty := iset.empty_spec).
        unfold iset.Empty in Hempty.
        specialize Hempty with elt.
        split.
        + move=> H; exfalso; auto.
        + move=> [].
Qed.

Lemma collect_aexpr_soundness:
    forall ae elt,
        iset.In elt (collect_aexpr ae) <-> In ident (aexpr_freevars ae) elt.
Proof.
    move=> ae; induction ae as [| |op ae1 HRec1 ae2 HRec2]; simpl.
    {
        exact iset_empty_soudness.
    }
    {
        move=> elt; rewrite iset.singleton_spec; split.
        + move=> ->; constructor.
        + move=> []; reflexivity.
    }
    {
        move=> elt; rewrite iset.union_spec.
        rewrite HRec1; rewrite HRec2; split.
        + move=> []; constructor; assumption.
        + move=> []; auto.
    }
Qed.

Lemma collect_aexprl_soundness:
    forall ael elt,
        iset.In elt (collect_aexprl ael) <-> In ident (aexprl_freevars ael) elt.
Proof.
    move=> ael; induction ael as [|hd tl HRec]; simpl; move=> elt.
    {
        exact (iset_empty_soudness _).
    }
    {
        rewrite iset.union_spec.
        rewrite collect_aexpr_soundness; rewrite HRec.
        split; move=> []; auto; move=> HIn; constructor; assumption.
    }
Qed.

Lemma collect_var_soundness:
    forall var elt,
        iset.In elt (collect_var var) <-> In ident (var_freevars var) elt.
Proof.
    move=> var; induction var as [|v HRec ae|v HRec ae1 ae2|v HRec aeL].
    all: simpl; move=> elt.
    {
        rewrite iset.singleton_spec; split.
        + move=> ->; constructor.
        + move=> []; reflexivity.
    }
    {
        rewrite iset.union_spec; rewrite HRec; rewrite collect_aexpr_soundness; split.
        + move=> []; constructor; assumption.
        + move=> []; auto.
    }
    {
        do 2 rewrite iset.union_spec; rewrite HRec; do 2 rewrite collect_aexpr_soundness; split.
        + move => [|[]].
            - constructor; assumption.
            - do 2 constructor; assumption.
            - do 2 constructor; assumption.
        + move => [|x []]; auto.
    }
    {
        rewrite iset.union_spec; rewrite HRec; rewrite collect_aexprl_soundness; split.
        + move=> []; constructor; assumption.
        + move=> []; auto.
    }
Qed.

Lemma collect_varl_soundness:
    forall varl elt,
        iset.In elt (collect_varl varl) <-> In ident (varl_freevars varl) elt.
Proof.
    move=> varl; induction varl as [|hd tl HRec]; simpl; move=> elt.
    {
        pose (Hempty := iset.empty_spec).
        unfold iset.Empty in Hempty.
        specialize Hempty with elt.
        split.
        + move=> H; exfalso; auto.
        + move=> [].
    }
    {
        rewrite iset.union_spec; rewrite collect_var_soundness.
        rewrite HRec; split.
        + move=> []; constructor; assumption.
        + move=> []; auto.
    }
Qed.

Lemma collect_expr_soundness:
    forall e elt,
        iset.In elt (collect_expr e) <-> In ident (expr_freevars e) elt.
Proof.
    move=> e.
    refine (expr_find (fun e => _) (fun exprL => _) _ _ _ _ _ _ _ _ _ _ _ _ _ _ e); simpl; auto; clear e.
    {
        intros; exact (iset_empty_soudness _).
    }
    {
        intros; exact (collect_var_soundness _ _).
    }
    {
        move=> e0 HRec elt; exact (HRec elt).
    }
    {
        move=> _ e1 HRec1 e2 HRec2 elt.
        rewrite iset.union_spec; rewrite HRec1; rewrite HRec2.
        split; move=> []; auto; intro; constructor; assumption.
    }
    {
        move=> _ e1 HRec1 e2 HRec2 elt.
        rewrite iset.union_spec; rewrite HRec1; rewrite HRec2.
        split; move=> []; auto; intro; constructor; assumption.
    }
    {
        move=> _ e1 HRec1 ae elt.
        rewrite iset.union_spec; rewrite HRec1; rewrite collect_aexpr_soundness.
        split; move=> []; auto; intro; constructor; assumption.
    }
    {
        intros; exact (collect_var_soundness _ _).
    }
    {
        move=> e HRec ae elt; rewrite iset.union_spec.
        rewrite HRec; rewrite collect_aexpr_soundness.
        split; move=> []; auto; intro; constructor; assumption.
    }
    {
        move=> e1 HRec1 e2 HRec2 typ elt.
        rewrite iset.union_spec; rewrite HRec1; rewrite HRec2.
        split; move=> []; auto; intro; constructor; assumption.
    }
    {
        move=> i el HRec elt; rewrite iset.union_spec.
        rewrite iset.singleton_spec; rewrite HRec.
        split; move=> []; auto.
        + move=> ->; do 2 constructor.
        + intro; constructor; assumption.
        + move=> x []; left; reflexivity.
    }
    {
        move=> i ae el HRec elt; do 2 rewrite iset.union_spec.
        rewrite iset.singleton_spec; rewrite collect_aexpr_soundness; rewrite HRec.
        split.
        + move=> [->|[HIn|HIn]]; do 2 constructor; assumption.
        + move=> [x []| x []]; auto.
    }
    {
        simpl; exact iset_empty_soudness.
    }
    {
        move=> e HRec el HRecl elt; simpl.
        rewrite iset.union_spec; rewrite HRec; rewrite HRecl.
        split; move=> []; auto; intro; constructor; assumption.
    }
Qed.

Lemma collect_deqs_soundness_lemma:
    forall deqs elt,
        iset.In elt (collect_deqs (list_deq_of_deqL deqs)) <-> In ident (deqs_vars (list_deq_of_deqL deqs)) elt.
Proof.
    move=> deqs elt; induction deqs as [|v e b tl HRec|i ae1 ae2 body HRecBody opt tl HRecTL]; simpl.
    {
        exact (iset_empty_soudness _).
    }
    {
        do 2 rewrite iset.union_spec; rewrite HRec.
        rewrite collect_varl_soundness; rewrite collect_expr_soundness.
        split; move=> []; auto.
        + move=> []; do 2 constructor; assumption.
        + intro; constructor; assumption.
        + move=> x []; auto.
    }
    {
        rewrite iset.union_spec.
        rewrite iset.add_spec; do 2 rewrite iset.union_spec.
        rewrite HRecBody; rewrite HRecTL.
        do 2 rewrite collect_aexpr_soundness; split.
        + move=> [[|[[]|]]|].
            - by move=> ->; do 3 constructor.
            - intro; do 3 constructor; assumption.
            - intro; do 4 constructor; assumption.
            - intro; do 4 constructor; assumption.
            - intro; do 1 constructor; assumption.
        + move=> [x [x' []|x' [|x'2 []]]|]; auto.
    }
Qed.

Lemma collect_bounddeqs_soundness_lemma:
    forall deqs elt,
        iset.In elt (collect_bounddeqs (list_deq_of_deqL deqs)) <-> In ident (deqs_boundvars (list_deq_of_deqL deqs)) elt.
Proof.
    move=> deqs elt; induction deqs as [|v e b tl HRec|i ae1 ae2 body HRecBody opt tl HRecTL]; simpl.
    {
        exact (iset_empty_soudness _).
    }
    {
        rewrite iset.union_spec; rewrite HRec.
        rewrite collect_varl_soundness.
        split; move=> []; auto.
        all: intro; constructor; assumption.
    }
    {
        rewrite iset.union_spec.
        rewrite iset.add_spec.
        rewrite HRecBody; rewrite HRecTL; split.
        + move=> [[]|].
            - by move=> ->; do 2 constructor.
            - intro; do 2 constructor; assumption.
            - intro; do 1 constructor; assumption.
        + move=> [x [x' []|]|]; auto.
    }
Qed.

Lemma collect_deqs_soundness:
    forall deqs elt,
        iset.In elt (collect_deqs deqs) <-> In ident (deqs_vars deqs) elt.
Proof.
    move=> deqs elt.
    pose (HEq := collect_deqs_soundness_lemma (deqL_of_list_deq deqs) elt); move: HEq.
    rewrite deqL_is_list_deq; auto.
Qed.


(* Check that dependent rewrite applies on arbitrary terms *)

Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Axiom
  ax :
    forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)),
    existT _ (n + n') l = existT _ (n' + n) l'.

Lemma lem :
 forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)),
 n + n' = n' + n /\ existT _ (n + n') l = existT _ (n' + n) l'.
Proof.
intros n n' l l'.
 dependent rewrite (ax n n' l l').
split; reflexivity.
Qed.

(* Used to raise an anomaly instead of an error in 8.1 *)
(* Submitted by Y. Makarov *)

Parameter N : Set.
Parameter E : N -> N -> Prop.

Axiom e : forall (A : Set) (EA : A -> A -> Prop) (a : A), EA a a.

Theorem th : forall x : N, E x x.
intro x. try rewrite e.
Abort.

(* Behavior of rewrite wrt conversion *)

Require Import Arith.

Goal forall n, 0 + n = n -> True.
intros n H.
rewrite plus_0_l in H.
Abort.

(* Rewrite dependent proofs from left-to-right *)

Lemma l1 :
  forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H.
intros x y H P H0.
rewrite H.
rewrite H in H0.
assumption.
Qed.

(* Rewrite dependent proofs from right-to-left *)

Lemma l2 :
  forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H.
intros x y H P H0.
rewrite <- H.
rewrite <- H in H0.
assumption.
Qed.

(* Check rewriting dependent proofs with non-symmetric equalities *)

Lemma l3:forall x (H:eq_true x) (P:forall x, eq_true x -> Type), P x H -> P x H.
intros x H P H0.
rewrite H.
rewrite H in H0.
assumption.
Qed.

(* Dependent rewrite *)

Require Import JMeq.

Goal forall A B (a:A) (b:B), JMeq a b -> JMeq b a -> True.
inversion 1; (* Goal is now [JMeq a a -> True] *) dependent rewrite H3.
Undo.
intros; inversion H; dependent rewrite H4 in H0.
Undo.
intros; inversion H; dependent rewrite <- H4 in H0.
Abort.

(* Test conversion between terms with evars that both occur in K-redexes and
   are elsewhere solvable.

   This is quite an artificial example, but it used to work in 8.2.

   Since rewrite supports conversion on terms without metas, it
   was successively unifying (id 0 ?y) and 0 where ?y was not a
   meta but, because coming from a "_", an evar.

   After commit r12440 which unified the treatment of metas and
   evars, it stopped to work. Chung-Kil Hur's Heq package used
   this feature. Solved in r13...
*)

Parameter g : nat -> nat -> nat.
Definition K (x y:nat) := x.

Goal (forall y, g y (K 0 y) = 0) -> g 0 0 = 0.
intros.
rewrite (H _).
reflexivity.
Qed.

Goal (forall y, g (K 0 y) y = 0) -> g 0 0 = 0.
intros.
rewrite (H _).
reflexivity.
Qed.

(* Example of rewriting of a degenerated pattern using the right-most
   argument of the goal. This is sometimes used in contribs, even if
   ad hoc. Here, we have the extra requirement that checking types
   needs delta-conversion *)

Axiom s : forall (A B : Type) (p : A * B), p = (fst p, snd p).
Definition P := (nat * nat)%type.
Goal forall x:P, x = x.
intros. rewrite s.
Abort.

(* Test second-order unification and failure of pattern-unification *)

Goal forall (P: forall Y, Y -> Prop) Y a, Y = nat -> (True -> P Y a) -> False.
intros.
(* The next line used to succeed between June and November 2011 *)
(* causing ill-typed rewriting *)
Fail rewrite H in H0.
Abort.

(* Test subst in the presence of a dependent let-in *)
(* Was not working prior to May 2014 *)

Goal forall x y, x=y+0 -> let z := x+1 in x+1=y -> z=z -> z=x.
intros.
subst x. (* was failing *)
subst z.
rewrite H0.
auto with arith.
Qed.

(* Check that evars are instantiated when the term to rewrite is
   closed, like in the case it is open *)

Goal exists x, S 0 = 0 -> S x = 0.
eexists. intro H.
rewrite H.
reflexivity.
Abort.

(* Check that rewriting within evars still work (was broken in 8.5beta1) *)

Goal forall (a: unit) (H: a = tt), exists x y:nat, x = y.
intros; eexists; eexists.
rewrite H.
Undo.
subst.
Abort.

(* Check that iterated rewriting does not rewrite in the side conditions *)
(* Example from Sigurd Schneider, extracted from contrib containers *)

Lemma EQ
  : forall (e e' : nat), True -> e = e'.
Admitted.

Lemma test (v1 v2 v3: nat) (v' : v1 = v2) : v2 = v1.
Proof.
  rewrite <- (EQ v1 v2) in *.
  exact v'.
  (* There should be only two side conditions *)
  exact I.
  exact I.
Qed.


(* Action of List nat over a list of arbitary elements.
   Identity function and cfun functions (circular shifts). *)

From Coq Require Import Bool PeanoNat Lia.
From OLlibs Require Import List_more funtheory.
Require Import List_nat.

(* APP_NAT_FUN *)
Definition app_nat_fun_dflt {A} p (l : list A) a := map (fun x => nth x l a) p.

Lemma app_nat_fun_dflt_indep {A} :
 forall p l (d d' : A), all_lt p (length l) = true -> app_nat_fun_dflt p l d = app_nat_fun_dflt p l d'.
Proof.
induction p; intros l d d' Hlt; simpl; f_equal; simpl in Hlt; apply andb_true_iff in Hlt.
- apply nth_indep, Nat.ltb_lt, Hlt.
- apply IHp, Hlt.
Qed.

Lemma app_nat_fun_dflt_nil {A} : forall p (d : A),
  app_nat_fun_dflt p nil d = map (fun _ => d) p.
Proof.
  intros p d; induction p; [ reflexivity | ].
  simpl; rewrite IHp.
  f_equal; destruct a; reflexivity.
Qed.

Definition app_nat_fun {A} (p : list nat) (l : list A) :=
  match l with
  | nil => nil
  | a :: l => app_nat_fun_dflt p (a :: l) a
  end.

Infix "∘" := app_nat_fun (at level 40, left associativity).

Ltac app_nat_fun_dflt_unfold l1 l2 n a d :=
  change (app_nat_fun_dflt (n :: l1) (a :: l2) d)
  with (nth n (a :: l2) a :: app_nat_fun_dflt l1 (a :: l2) d) in *.
Ltac app_nat_fun_unfold l1 l2 n a :=
  change (app_nat_fun (n :: l1) (a :: l2)) with (nth n (a :: l2) a :: app_nat_fun l1 (a :: l2)) in *.

Lemma app_nat_fun_nil {A} : forall (l : list A), nil ∘ l = nil.
Proof. destruct l; reflexivity. Qed.

Lemma app_nat_fun_not_nil {A} : forall p (l : list A) a,
  l <> nil -> p ∘ l = app_nat_fun_dflt p l (hd a l).
Proof. intros p l a Hnil; destruct l; [ contradiction Hnil | ]; reflexivity. Qed.

Lemma app_nat_fun_cons {A} : forall n (a : A) p l,
  (n :: p) ∘ (a :: l) = nth n (a :: l) a :: (p ∘ (a :: l)).
Proof. intros n a p l; unfold app_nat_fun; app_nat_fun_dflt_unfold p l n a a; reflexivity. Qed.

Lemma app_nat_fun_app_nat_fun_dflt {A} : forall p (l : list A) d,
  all_lt p (length l) = true -> p ∘ l = app_nat_fun_dflt p l d.
Proof.
intros p l d Hlen.
destruct l.
- destruct p.
  + reflexivity.
  + exfalso.
    apply andb_true_iff in Hlen as [Hlen _].
    apply Nat.ltb_lt in Hlen; simpl in Hlen; lia.
- now apply app_nat_fun_dflt_indep.
Qed.

Lemma app_nat_fun_middle {A} : forall l1 l2 (a : A) p,
  (length l1 :: p) ∘ (l1 ++ a :: l2) = a :: (p ∘ (l1 ++ a :: l2)).
Proof.
  intros l1 l2 a0 p.
  destruct l1; [ reflexivity | ].
  change ((length (a :: l1) :: p) ∘ ((a :: l1) ++ a0 :: l2))
    with (nth (length (a :: l1)) ((a :: l1) ++ a0 :: l2) a :: (p ∘ ((a :: l1) ++ a0 :: l2))).
  replace a0 with (nth (length (a :: l1)) ((a :: l1) ++ a0 :: l2) a);
    f_equal; apply nth_middle.
Qed.

Lemma app_nat_fun_length_cons {A} : forall f (l : list A), l <> nil -> length (f ∘ l) = length f.
Proof. intros f l Hnnil; destruct l; [ exfalso; apply Hnnil; reflexivity | apply map_length ]. Qed.

Lemma app_nat_fun_length {A} : forall f (l : list A), length f = length l -> length (f ∘ l) = length f.
Proof.
intros f l Heq; destruct l.
- rewrite Heq; reflexivity.
- apply app_nat_fun_length_cons; intros Heq2; inversion Heq2.
Qed.

Lemma all_lt_app_nat_fun : forall p l n, all_lt p (length l) = true ->
  all_lt l n = true -> all_lt (p ∘ l) n = true.
Proof.
induction p; intros l n Hl Halt.
- rewrite app_nat_fun_nil; reflexivity.
- simpl in Hl; apply andb_true_iff in Hl as [Hl1 Hl2].
  destruct l; [ apply Nat.ltb_lt in Hl1; simpl in Hl1; lia | ].
  simpl in Halt; apply andb_true_iff in Halt as [Halt1 Halt2].
  simpl; apply andb_true_iff; split.
  + destruct a; [ assumption | ].
    apply Nat.ltb_lt.
    apply cond_all_lt_inv; [ | assumption ].
    apply Nat.ltb_lt in Hl1; simpl in Hl1; lia.
  + fold (p ∘ (n0 :: l)).
    apply IHp; [ | apply andb_true_iff; split ]; assumption.
Qed.

Lemma app_nat_fun_dflt_shift {A} : forall (la lb lc : list A) p d, length (la ++ lc) <> 0 ->
  app_nat_fun_dflt (shift p (length la) (length lb)) (la ++ lb ++ lc) d = app_nat_fun_dflt p (la ++ lc) d.
Proof.
  intros la lb lc p d Hlen.
  induction p; simpl; [ reflexivity | ].
  rewrite <- IHp.
  case_eq (a <? length la); intros Ha0; subst; list_simpl; f_equal.
  - now rewrite 2 app_nth1; try (apply Nat.ltb_lt; assumption).
  - apply Nat.ltb_ge in Ha0.
    rewrite app_nth2; try lia.
    replace (length lb + a - length la) with (length lb + (a - length la)) by lia.
    rewrite app_nth2_plus.
    now rewrite <- app_nth2; try lia.
Qed.

Lemma app_nat_fun_shift {A} : forall (la lb lc :list A) p,
  length (la ++ lc) <> 0 -> all_lt p (length (la ++ lc)) = true ->
    shift p (length la) (length lb) ∘ (la ++ lb ++ lc) = p ∘ (la ++ lc).
Proof.
  intros la lb lc p Hlen Hlt.
  destruct la; [ destruct lc | ].
  - exfalso.
    now apply Hlen.
  - rewrite 2 app_nat_fun_not_nil with _ _ a.
    + replace (app_nat_fun_dflt p (nil ++ a :: lc) (hd a (nil ++ a :: lc)))
        with (app_nat_fun_dflt p (nil ++ a :: lc) (hd a (nil ++ lb ++ a :: lc))).
      * apply app_nat_fun_dflt_shift; assumption.
      * apply app_nat_fun_dflt_indep; assumption.
    + intro Heq; inversion Heq.
    + intros Heq; destruct lb; inversion Heq.
  - simpl app_nat_fun.
    change (S (length la)) with (length (a :: la)).
    change (a :: la ++ lb ++ lc) with ((a :: la) ++ lb ++ lc).
    change (a :: la ++ lc) with ((a :: la) ++ lc).
    now apply app_nat_fun_dflt_shift.
Qed.

Lemma app_nat_fun_dflt_downshift {A} : forall la lb (a : A) p d, In_nat_bool (length la) p = false ->
  app_nat_fun_dflt p (la ++ a :: lb) d = app_nat_fun_dflt (downshift p (length la)) (la ++ lb) d.
Proof.
  intros la lb a p d Hlen.
  induction p; simpl; [ reflexivity | ].
  simpl in Hlen; apply orb_false_iff in Hlen as [Hl Hr].
  rewrite Nat.eqb_sym in Hl; rewrite Hl.
  rewrite IHp; [ | apply Hr ].
  case_eq (a0 <? length la); intros Ha0; subst; list_simpl; f_equal.
  - rewrite 2 app_nth1; try (apply Nat.ltb_lt; assumption).
    reflexivity.
  - apply Nat.ltb_ge in Ha0.
    rewrite app_nth2 by lia.
    apply Nat.eqb_neq in Hl.
    rewrite app_nth2 by lia.
    simpl; f_equal.
    replace (Init.Nat.pred a0 - length la) with (Init.Nat.pred (a0 - length la)) by lia.
    assert (a0 - length la > 0) as Hnz by lia.
    remember (a0 - length la) as n; clear - Hnz.
    destruct n; [ inversion Hnz | reflexivity ].
Qed.

Lemma app_nat_fun_downshift {A} : forall la lb (a : A) p,
  In_nat_bool (length la) p = false -> all_lt p (S (length (la ++ lb))) = true ->
    p ∘ (la ++ a :: lb) = downshift p (length la) ∘ (la ++ lb).
Proof.
intros la lb a p Hlen Hlt.
case_eq p.
- intros Hp; subst.
  rewrite 2 app_nat_fun_nil; reflexivity.
- intros x l Hl; rewrite <- Hl in *.
  rewrite 2 app_nat_fun_not_nil with _ _ a.
  + replace (app_nat_fun_dflt p (la ++ a :: lb) (hd a (la ++ a :: lb)))
       with (app_nat_fun_dflt p (la ++ a :: lb) (hd a (la ++ lb))).
    * apply app_nat_fun_dflt_downshift; assumption.
    * apply app_nat_fun_dflt_indep.
      rewrite app_length in *; simpl.
      rewrite <- Hlt; f_equal; lia.
  + intros Heq; subst.
    rewrite Heq in Hlt; simpl in Hlt.
    apply app_eq_nil in Heq.
    destruct Heq as [Heq _]; subst; simpl in Hlen.
    apply andb_true_iff in Hlt.
    apply orb_false_iff in Hlen.
    destruct Hlt as [Hlt _]; destruct Hlen as [Hlen _].
    destruct x; [ inversion Hlen | inversion Hlt].
  + intros Heq; destruct la; inversion Heq.
Qed.

Lemma app_nat_fun_dflt_downshift_commu : forall l f k d,
  all_lt f (length l) = true ->
  In_nat_bool k l = false ->
  app_nat_fun_dflt f (downshift l k) d = downshift (app_nat_fun_dflt f l d) k.
Proof.
intros l f; revert l.
induction f; intros l k d Hlt Hnin; [ reflexivity | ].
simpl in Hlt; apply andb_true_iff in Hlt; destruct Hlt as [Hlt Hlt'].
simpl app_nat_fun_dflt; simpl downshift.
replace (beq_nat (nth a l d) k) with false.
- case_eq (nth a l d <? k); intros Hlt2.
  + rewrite IHf; [ f_equal | assumption | assumption ].
    apply Nat.ltb_lt in Hlt2.
    apply nth_downshift_lt; assumption.
  + rewrite IHf; [ f_equal | assumption | assumption ].
    apply Nat.ltb_ge in Hlt2.
    rewrite nth_indep with _ _ _ _ (pred d) by (now apply Nat.ltb_lt in Hlt; rewrite downshift_length; try lia).
    now apply nth_downshift_ge.
- apply Nat.ltb_lt in Hlt.
  clear - Hlt Hnin; revert a Hlt; induction l; intros b Hlt.
  + exfalso; simpl in Hlt; inversion Hlt.
  + simpl in Hnin; apply orb_false_iff in Hnin; destruct Hnin as [Hnin1 Hnin2].
    destruct b; simpl.
    * symmetry; apply Nat.eqb_neq; intros H; subst; apply Nat.eqb_neq in Hnin1; auto.
    * simpl in Hlt; apply IHl; [assumption | lia].
Qed.

Lemma app_nat_fun_downshift_commu : forall a l f k,
  In_nat_bool k (a :: l) = false -> all_lt f (length (a :: l)) = true ->
  f ∘ downshift (a :: l) k = downshift (f ∘ (a :: l)) k.
Proof.
intros a l f k Hlen Hnin.
rewrite 2 app_nat_fun_not_nil with _ _ 0.
- rewrite app_nat_fun_dflt_downshift_commu; auto.
  f_equal; apply app_nat_fun_dflt_indep; assumption.
- intros H; inversion H.
- intros H; simpl in H.
  simpl in Hlen; apply orb_false_iff in Hlen; destruct Hlen as [Hlen _].
  rewrite Nat.eqb_sym in Hlen; rewrite Hlen in H.
  inversion H.
Qed.

Lemma asso_app_nat_fun_dflt {A} : forall l1 l2 (l3 : list A) n d,
   app_nat_fun_dflt (app_nat_fun_dflt l1 l2 n) l3 d
 = app_nat_fun_dflt l1 (app_nat_fun_dflt l2 l3 d) (nth n l3 d).
Proof.
intros l1 l2 l3 n d; unfold app_nat_fun_dflt.
rewrite map_map.
apply map_ext; intros x.
revert l2; induction x; intros l2; destruct l2; simpl; try reflexivity.
rewrite IHx; reflexivity.
Qed.

Lemma asso_app_nat_fun {A} : forall l1 l2 (l3 : list A), (l1 ∘ l2) ∘ l3 = l1 ∘ (l2 ∘ l3).
Proof.
intros l1 l2 l3.
destruct l3; [ reflexivity | ].
destruct l2; [ reflexivity | ].
unfold app_nat_fun.
remember (app_nat_fun_dflt (n :: l2) (a :: l3) a) as l.
destruct l.
- exfalso.
  destruct n; simpl in Heql; inversion Heql.
- rewrite Heql.
  replace a0 with (nth n (a :: l3) a) by (destruct n; simpl in Heql; simpl; now inversion Heql).
  apply asso_app_nat_fun_dflt.
Qed.

Lemma app_nat_fun_dflt_right {A} : forall (l1 l2 : list A) f d,
  app_nat_fun_dflt (incr_all f (length l1)) (l1 ++ l2) d = app_nat_fun_dflt f l2 d.
Proof.
intros l1 l2 f; revert l1 l2; induction f; intros l1 l2 d; [ reflexivity | ].
simpl; rewrite IHf.
f_equal.
rewrite app_nth2; f_equal; lia.
Qed.

Lemma app_nat_fun_right {A} : forall k (l1 l2 : list A) f, k = length l1 -> all_lt f (length l2) = true ->
  incr_all f k ∘ (l1 ++ l2) = f ∘ l2.
Proof.
intros k l1 l2 f Heq Hlen; subst.
induction l1; simpl.
- now rewrite shift_0.
- change (S (length l1)) with (length (a :: l1)).
  rewrite app_comm_cons.
  rewrite app_nat_fun_dflt_right.
  now symmetry; apply app_nat_fun_app_nat_fun_dflt.
Qed.

Lemma app_nat_fun_dflt_left {A} : forall (l1 l2 : list A) f d1 d2, all_lt f (length l1) = true ->
   app_nat_fun_dflt f (l1 ++ l2) d1 = app_nat_fun_dflt f l1 d2.
Proof.
intros l1 l2 f d1 d2 Hlen.
unfold app_nat_fun_dflt.
apply map_ext_in; intros x Hin.
assert (x < length l1) as Hx.
{ revert Hlen Hin; induction f; intros Hlen Hin; inversion Hin; subst.
  - apply andb_true_iff in Hlen as [Hlen _].
    now apply Nat.ltb_lt.
  - apply IHf; try assumption.
    now apply andb_true_iff in Hlen as [_ Hlen]. }
rewrite app_nth1; [ | apply Hx ].
apply nth_indep, Hx.
Qed.

Lemma app_nat_fun_left {A} : forall (l1 l2 : list A) f, all_lt f (length l1) = true ->
  f ∘ (l1 ++ l2) = f ∘ l1.
Proof.
intros l1 l2 f Hlen.
destruct l2; [ list_simpl; reflexivity | ].
rewrite 2 app_nat_fun_app_nat_fun_dflt with _ _ a.
- now apply app_nat_fun_dflt_left.
- assumption.
- apply all_lt_leq with (length l1); [ assumption | rewrite app_length; lia ].
Qed.

Lemma app_nat_fun_dflt_app {A} : forall (l : list A) f1 f2 d,
  app_nat_fun_dflt (f1 ++ f2) l d = app_nat_fun_dflt f1 l d ++ app_nat_fun_dflt f2 l d.
Proof. intros l f1 f2 d; apply map_app. Qed.

Lemma app_nat_fun_app {A} : forall (l : list A) f1 f2, (f1 ++ f2) ∘ l = (f1 ∘ l) ++ (f2 ∘ l).
Proof. intros l f1 f2; destruct l; [ reflexivity | apply app_nat_fun_dflt_app ]. Qed.

Lemma append_fun_eq {A} : forall (l1 l2 : list A) f1 f2,
  all_lt f1 (length l1) = true -> all_lt f2 (length l2) = true ->
  (f1 ++ incr_all f2 (length l1)) ∘ (l1 ++ l2) = (f1 ∘ l1) ++ (f2 ∘ l2).
Proof. intros; now rewrite app_nat_fun_app; f_equal; [ apply app_nat_fun_left | apply app_nat_fun_right ]. Qed.

Lemma pappend_fun_eq {A} : forall (l1 l2 : list A) f1 f2, length f1 = length l1 ->
  all_lt f1 (length f1) = true -> all_lt f2 (length l2) = true ->
  (f1 +++ f2) ∘ (l1 ++ l2) = (f1 ∘ l1) ++ (f2 ∘ l2).
Proof. intros l1 l2 f1 f2 Hlen Hlt1 Hlt2; now rewrite <- append_fun_eq; rewrite_all Hlen. Qed.

Lemma app_nat_fun_downshift_shift : forall l f n0 n,
  all_distinct l = true -> all_distinct f = true ->
  all_lt f (pred (length l)) = true -> n < length l ->
  f ∘ downshift l (nth n l n0) = downshift (shift f n 1 ∘ l) (nth n l n0).
Proof with try reflexivity; try assumption.
  intros l f n0 n Had Hadf Hal Hlen.
  destruct (@nth_split _ n l n0) as (la & (lb & (Heql & Hlenla)))...
  pattern l at 1 3.
  rewrite Heql.
  pattern n at 4.
  rewrite<- Hlenla.
  rewrite Heql in Hal.
  destruct la.
  - destruct lb.
    { destruct n; try now inversion Hlenla.
      change (length nil) with 0.
      rewrite? app_nil_l.
      clear.
      rewrite downshift_eq.
      induction f...
      change (shift (a :: f) 0 1) with (S a :: (shift f 0 1)).
      unfold app_nat_fun at 2.
      app_nat_fun_dflt_unfold (shift f 0 1) (@nil nat) (S a) (nth 0 l n0) (nth 0 l n0).
      replace (nth (S a) (nth 0 l n0 :: nil) (nth 0 l n0)) with (nth 0 l n0) by now destruct a.
      rewrite downshift_eq... }
    rewrite <- Hlenla.
    change (nil ++ nth (length nil) l n0 :: n1 :: lb) with
        (nil ++ (nth (@length nat nil) l n0 :: nil) ++ (n1 :: lb)).
    change 1 with (length (nth (@length nat nil) l n0 :: nil)).
    rewrite app_nat_fun_shift by now try (intros H; inversion H).
    rewrite 2 app_nil_l; simpl app.
    rewrite downshift_eq.
    apply app_nat_fun_downshift_commu...
    apply all_distinct_right with (@nil nat).
    rewrite Hlenla.
    rewrite <- Heql...
  - simpl in Hal.
    rewrite <- Hlenla.
    change 1 with (length (nth (length (n1 :: la)) l n0 :: nil)).
    change ((n1 :: la) ++ nth (length (n1 :: la)) l n0 :: lb)
      with ((n1 :: la) ++ (nth (length (n1 :: la)) l n0 :: nil) ++ lb).
    rewrite app_nat_fun_shift.
    + rewrite downshift_app.
      change ((nth (length (n1 :: la)) l n0 :: nil) ++ lb) with (nth (length (n1 :: la)) l n0 :: lb).
      rewrite downshift_eq.
      rewrite<- downshift_app.
      change ((n1 :: la) ++ lb) with (n1 :: la ++ lb).
      rewrite app_nat_fun_downshift_commu...
      * change (n1 :: la ++ lb) with ((n1 :: la) ++ lb).
        rewrite In_nat_bool_app.
        apply orb_false_iff.
        split.
        -- apply all_distinct_left with lb.
           rewrite Hlenla; rewrite<- Heql...
        -- apply all_distinct_right with (n1 :: la).
           rewrite Hlenla; rewrite<- Heql...
      * simpl.
        rewrite app_length in Hal |- *; simpl in Hal.
        rewrite Nat.add_succ_r in Hal...
    + intros H; inversion H.
    + simpl.
      rewrite app_length in Hal |- * ; simpl in Hal.
      rewrite Nat.add_succ_r in Hal...
Qed.

Lemma app_nat_fun_incr_all : forall n l p, p ∘ incr_all l n = incr_all (p ∘ l) n.
Proof with try reflexivity.
  intros n l p.
  destruct l...
  induction p...
  change (shift (n0 :: l) 0 n) with (n + n0 :: shift l 0 n).
  unfold app_nat_fun.
  app_nat_fun_dflt_unfold p (shift l 0 n) a (n + n0) (n + n0).
  app_nat_fun_dflt_unfold p l a n0 n0.
  simpl in IHp.
  rewrite IHp.
  change (n + n0 :: shift l 0 n) with (shift (n0 :: l) 0 n).
  rewrite nth_incr_all...
Qed.

Lemma In_nat_bool_shift_false : forall l f n0 n,
    all_lt f (pred (length l)) = true ->
    n < length l ->
    all_distinct l = true ->
    In_nat_bool (nth n l n0) (shift f n 1 ∘ l) = false.
Proof with try reflexivity; try assumption.
  intros l f n0 n Hal Hlen Had.
  destruct l; try now inversion Hlen.
  induction f...
  simpl shift.
  simpl in Hal.
  apply andb_prop in Hal as (Hlt & Hal).
  case_eq (a <? n); intros Hlt'.
  - apply orb_false_iff.
    split ; [ | apply IHf]...
    case_eq (nth n (n1 :: l) n0 =? nth a (n1 :: l) n1); intros Heq...
    exfalso.
    apply Nat.ltb_lt in Hlt'.
    apply (Nat.lt_neq a n)...
    symmetry.
    apply Nat.eqb_eq in Heq.
    replace (nth a (n1 :: l) n1) with (nth a (n1 :: l) n0) in Heq.
    2:{ apply nth_indep.
        simpl.
        apply Nat.ltb_lt in Hlt.
        lia. }
    apply cond_all_distinct_inv with (n1 :: l) n0...
    simpl.
    apply Nat.ltb_lt in Hlt.
    lia.
  - apply orb_false_iff.
    split ; [ | apply IHf]...
    assert (n <> S a).
    { apply Nat.ltb_nlt in Hlt'.
      lia. }
    replace (nth (S a) (n1 :: l) n1) with (nth (S a) (n1 :: l) n0).
    2:{ apply nth_indep.
        simpl.
        apply Nat.ltb_lt... }
    case_eq (nth n (n1 :: l) n0 =? nth (S a) (n1 :: l) n0); intros Heq...
    exfalso.
    apply H.
    apply Nat.eqb_eq in Heq.
    apply cond_all_distinct_inv with (n1 :: l) n0...
    simpl; apply Nat.ltb_lt...
Qed.

Lemma app_nat_fun_map {A B} : forall (f : A -> B) l p, p ∘ map f l = map f (p ∘ l).
Proof with try reflexivity.
  intros f l p.
  destruct l...
  induction p...
  rewrite map_cons.
  unfold app_nat_fun; app_nat_fun_dflt_unfold p (map f l) a0 (f a) (f a).
  rewrite<- ? map_cons.
  simpl in IHp.
  simpl map at 2.
  rewrite IHp.
  app_nat_fun_dflt_unfold p l a0 a a.
  rewrite map_nth...
Qed.

(* ID *)
Notation Id := (seq 0).

Lemma incr_all_seq : forall s l k, incr_all (seq s l) k = seq (s + k) l.
Proof.
intros s l k.
revert s; induction l; intros s; simpl; [ reflexivity | ].
f_equal; [ lia | apply IHl ].
Qed.

Lemma all_lt_seq : forall s l k, s + l <= k -> all_lt (seq s l) k = true.
Proof.
intros s l k Hle.
apply all_lt_Forall, Forall_forall.
intros x Hin.
apply in_seq in Hin; lia.
Qed.

Lemma all_distinct_seq : forall s l, all_distinct (seq s l) = true.
Proof. intros; apply all_distinct_NoDup, seq_NoDup. Qed.

Lemma app_nat_fun_seq_seq : forall i j k n, k + n <= j -> seq k n ∘ seq i j = seq (i + k) n.
Proof.
intros i j k n; revert i k; induction n; intros i k Hlt; simpl.
- apply app_nat_fun_nil.
- replace j with (S (j - 1)) by lia.
  simpl seq.
  rewrite app_nat_fun_cons; f_equal.
  + rewrite cons_seq, seq_nth; lia.
  + replace (S (i + k)) with (i + S k) by lia.
    rewrite <- IHn; [ | lia ].
    f_equal; rewrite cons_seq; f_equal; lia.
Qed.

Lemma app_Id {A} : forall (l : list A), Id (length l) ∘ l = l.
Proof.
  induction l; [ reflexivity | ].
  simpl; unfold app_nat_fun_dflt; f_equal.
  rewrite <- seq_shift.
  rewrite map_map.
  etransitivity; [ | apply IHl ].
  unfold app_nat_fun; destruct l; [ reflexivity | ].
  apply map_ext_in; intros x Hin.
  simpl; destruct x; [reflexivity | apply nth_indep].
  apply in_seq in Hin; simpl in Hin; lia.
Qed.

Lemma app_Id_ext {A} : forall k (l1 l2 : list A), length l1 = k -> Id k ∘ (l1 ++ l2) = l1.
Proof.
intros k l1 l2 Heq.
rewrite <- Heq.
rewrite app_nat_fun_left; [ apply app_Id | apply all_lt_seq; lia ].
Qed.

Lemma app_nat_fun_Id_r : forall f k, all_lt f k = true -> f ∘ Id k = f.
Proof.
induction f; intros k Hlen.
- apply app_nat_fun_nil.
- simpl in Hlen; apply andb_true_iff in Hlen as [Hlen1 Hlen2]; apply Nat.ltb_lt in Hlen1.
  destruct k; [ lia | ].
  apply IHf in Hlen2; simpl in Hlen2.
  simpl; destruct a; f_equal; try assumption.
  rewrite seq_nth; lia.
Qed.

(* CFUN *)
Definition cfun n m := seq n m ++ seq 0 n.

Lemma cfun_length : forall n m, length (cfun n m) = n + m.
Proof. intros; unfold cfun; rewrite app_length; rewrite 2 seq_length; lia. Qed.

Lemma all_lt_cfun : forall n m, all_lt (cfun n m) (n + m) = true.
Proof.
intros n m.
unfold cfun; rewrite all_lt_app.
apply andb_true_iff; split; apply all_lt_seq; lia.
Qed.

Lemma all_distinct_cfun : forall n m, all_distinct (cfun n m) = true.
Proof.
  intros n m.
  unfold cfun.
  rewrite all_distinct_app_commu.
  rewrite <- seq_app.
  apply all_distinct_seq.
Qed.

Lemma app_cfun_eq {A} : forall (l1 : list A) l2, cfun (length l1) (length l2) ∘ (l1 ++ l2) = l2 ++ l1.
Proof.
intros l1 l2.
unfold cfun.
rewrite app_nat_fun_app; f_equal.
- change (length l1) with (0 + length l1).
  rewrite <- incr_all_seq.
  rewrite app_nat_fun_right; try lia.
  + apply app_Id.
  + apply all_lt_seq; lia.
- rewrite app_nat_fun_left.
  + apply app_Id.
  + apply all_lt_seq; lia.
Qed.

Lemma cfun_c1n : forall i j,
    cfun 1 (i + j) ∘ cfun i (S j) = cfun (S i) j.
Proof.
  intros i j.
  unfold cfun at 2 3.
  rewrite <- cons_seq; simpl app; rewrite cons_is_app.
  replace (i + j) with (length (seq (S i) j ++ Id i)) by (rewrite app_length; rewrite ? seq_length; lia).
  change 1 with (length (i :: nil)).
  rewrite app_cfun_eq; rewrite<- app_assoc.
  unfold Id; now rewrite<- seq_S.
Qed.

Lemma cfun_generated_by_c1n : forall i j,
    cfun i j = Nat.iter i (app_nat_fun (cfun 1 (pred (i+j)))) (Id (i + j)).
Proof.
  induction i; intros j; [ unfold cfun; now rewrite app_nil_r | ].
  specialize (IHi (S j)); replace (i + S j) with (S i + j) in IHi by lia.
  simpl in *; rewrite<- IHi; now rewrite cfun_c1n.
Qed.

Lemma cfun_inv : forall n m, cfun n m ∘ cfun m n = Id (m + n).
Proof.
intros n m.
change (cfun m n) with (seq m n ++ Id m).
replace (cfun n m) with (cfun (length (seq m n)) (length (Id m))).
- rewrite app_cfun_eq.
  symmetry; apply seq_app.
- rewrite 2 seq_length; reflexivity.
Qed.

Lemma cfun_cfun_le : forall i j k l, i + j = k + l -> k <= j ->
  cfun k l ∘ cfun i j = cfun (i + k) (j - k).
Proof.
intros i j k l Hlen Hlt; unfold cfun.
rewrite app_nat_fun_app.
replace j with (k + (j - k)) at 2 by lia.
rewrite 2 seq_app; rewrite <- app_assoc.
rewrite app_Id_ext by apply seq_length.
rewrite app_assoc; f_equal.
replace l with (j - k + i) by lia; rewrite seq_app.
replace (k + (j - k)) with (j - k + k) by lia; rewrite app_nat_fun_app; f_equal.
- rewrite app_nat_fun_left by (apply all_lt_seq; rewrite seq_length; lia).
  apply app_nat_fun_seq_seq; lia.
- replace (j - k + k) with j by lia.
  change j with (0 + j) at 1; rewrite <- incr_all_seq.
  rewrite app_nat_fun_right; rewrite ? seq_length; try lia.
  + replace i with (length (Id i)) at 1 by apply seq_length.
    now rewrite app_Id.
  + apply all_lt_seq; lia.
Defined.

Lemma cfun_cfun_ge : forall i j k l, i + j = k + l -> k >= j ->
  cfun k l ∘ cfun i j = cfun (k - j) (j + l).
Proof.
intros i j k l Hlen Hgt.
rewrite <- (app_Id (cfun (k - j) (j + l))), cfun_length.
replace (k - j + (j + l)) with (l + k) by lia.
rewrite <- cfun_inv, asso_app_nat_fun; f_equal.
rewrite cfun_cfun_le; [ f_equal | | ]; lia.
Defined.

Lemma cfun_cfun : forall i j k l, i + j = k + l -> {'(n, m) : _ & cfun k l ∘ cfun i j = cfun n m}.
Proof.
intros i j k l Hlen.
destruct (Compare_dec.le_lt_dec j k) as [Hle | Hgt].
- exists (k - j, j + l); now apply cfun_cfun_ge.
- exists (i + k, j - k); now apply cfun_cfun_le; try lia.
Defined.

Lemma cfun_0_n : forall n, cfun 0 n = Id n.
Proof. intros n; now unfold cfun; rewrite app_nil_r. Qed.

Lemma cfun_n_0 : forall n, cfun n 0 = Id n.
Proof. intros n; now unfold cfun. Qed.

Lemma cfun_arg_inj_S : forall n1 n2 m1 m2, cfun (S n1) (S m1) = cfun (S n2) (S m2) -> n1 = n2 /\ m1 = m2.
Proof.
intros n1 n2 m1 m2 Heq.
enough (n1 = n2 /\ n1 + m1 = n2 + m2) as [Hn Hp] by (split; lia).
unfold cfun in Heq; simpl in Heq.
split.
- now inversion Heq.
- apply (f_equal (@length _)) in Heq.
  simpl in Heq; rewrite ? app_length in Heq; simpl in Heq; rewrite ? seq_length in Heq; lia.
Qed.

Lemma cfun_arg_inj : forall n1 n2 m1 m2, (m1 = 0 -> n1 = 0) -> (m2 = 0 -> n2 = 0) ->
  cfun n1 m1 = cfun n2 m2 -> n1 = n2 /\ m1 = m2.
Proof.
intros n1 n2 m1 m2 Hz1 Hz2 Heq.
assert (n1 + m1 = n2 + m2) as Hplus by now rewrite <- 2 cfun_length; rewrite Heq.
destruct m1; [ | destruct m2 ]; try lia.
destruct n1; destruct n2; try lia.
- exfalso; unfold cfun in Heq; inversion Heq.
- exfalso; unfold cfun in Heq; inversion Heq.
- apply cfun_arg_inj_S in Heq; lia.
Qed.

Lemma nat_cfun_arg : forall n i, 0 <= i < max 1 n <-> (n = i -> i = 0) /\ i <= n.
Proof. intros; lia. Qed.
Lemma nat_cfun_args : forall i j, 0 <= i < max 1 (i + j) <-> (j = 0 -> i = 0).
Proof. intros; lia. Qed.

(* Extensionality *)

Lemma app_nat_fun_ext : forall f1 f2,
  (forall {A} (l : list A), f1 ∘ l = f2 ∘ l) -> f1 = f2.
Proof.
  intros f1 f2 H.
  specialize (H nat (Id (max (S (list_max f1)) (S (list_max f2))))).
  rewrite 2 app_nat_fun_Id_r in H; [apply H | | ];
    try eapply all_lt_leq; try apply all_lt_max; try lia.
Qed.

(* Additional properties of app_nat_fun *)

Lemma app_antecedent_dflt {A} : forall (d a : A) f l l1 l2,
    app_nat_fun_dflt f l d = l1 ++ a :: l2 ->
    nth (nth (length l1) f 0) l d = a.
Proof.
  intros d a f l l1.
  revert d a f l.
  induction l1; intros d b f l l2 Heq.
  - simpl in *.
    destruct f; destruct l; try now inversion Heq.
  - destruct f; [ destruct l; inversion Heq | ].
    simpl.
    apply IHl1 with l2; try assumption.
    destruct l; try now inversion Heq.
Qed.

Lemma app_antecedent {A} : forall (a : A) f l l1 l2, f ∘ l = l1 ++ a :: l2 ->
  nth (nth (length l1) f 0) l (hd a l) = a.
Proof.
  intros a f l l1 l2 Heq.
  apply app_antecedent_dflt with l2; try assumption.
  destruct l; [ destruct l1; inversion Heq | ].
  apply Heq.
Qed.

Lemma app_nat_fun_vs_elt_inv {A} : forall (a : A) f l l1 l2,
  f ∘ l = l1 ++ a :: l2 -> {' (la, lb) : _ & l = la ++ a :: lb }.
Proof with try reflexivity; try assumption.
  intros a f l l1 l2 Heq.
  case_eq (nth (length l1) f 0 <? length l); intro H ;
    [apply Nat.ltb_lt in H | apply Nat.ltb_nlt in H].
  - destruct (nth_split_inf l (hd a l) H) as [[la lb] Heql Hlen].
    split with (la, lb).
    rewrite app_antecedent with _ _ _ _ l2 in Heql...
  - destruct l; [destruct l1; inversion Heq | ].
    split with (nil, l).
    rewrite<- app_antecedent with a f (a0 :: l) l1 l2...
    rewrite nth_overflow...
    lia.
Qed.

Lemma app_nat_fun_vs_cons_inv {A} : forall (a : A) f l l1,
  f ∘ l = a :: l1 ->  {' (la, lb) : _ & l = la ++ a :: lb }.
Proof.
intros a f l l1 Heq; rewrite<- (app_nil_l (a :: l1)) in Heq; now apply app_nat_fun_vs_elt_inv with f nil l1.
Qed.

Lemma app_nat_fun_map_inv_inj {A B} : forall (f : A -> B), injective f -> forall g l1 l2,
  g ∘ map f l1 = map f l2 -> g ∘ l1 = l2.
Proof with try reflexivity; try assumption.
  intros f Hinj g l1 l2 Heq.
  assert (forall A B (f : A -> B) g l, app_nat_fun g (map f l) = map f (app_nat_fun g l))
    as app_nat_fun_map.
  { clear.
    intros.
    destruct l...
    change (map f (a :: l)) with (f a :: map f l).
    unfold app_nat_fun.
    unfold app_nat_fun_dflt; rewrite map_map.
    change (f a :: map f l) with (map f (a :: l)).
    apply map_ext.
    intros x.
    rewrite map_nth... }
  rewrite app_nat_fun_map in Heq.
  apply (map_injective Hinj)...
Qed.

Lemma app_nat_fun_elt_map_inv {A B} : forall (f : A -> B) g a l1 l2 l3 l4,
  g ∘ (l3 ++ map f l4) = l1 ++ a :: l2 ->
  (forall b, a <> f b) -> { '(l5,l6) | l3 = l5 ++ a :: l6 }.
Proof.
intros f g a l1 l2 l3 l4 HP Hf.
apply app_nat_fun_vs_elt_inv in HP.
destruct HP as [(l',l'') Heq].
dichot_elt_app_inf_exec Heq.
- subst; exists (l', l) ; reflexivity.
- exfalso.
  symmetry in Heq1; decomp_map_inf Heq1; symmetry in Heq1.
  apply Hf in Heq1.
  inversion Heq1.
Qed.