(** * Combi.SymGroup.presentSn : The Coxeter Presentation of the Symmetric Group *)
(******************************************************************************)
(*      Copyright (C) 2016-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * The Coxeter Presentation of the Symmetric Group

The main goal is to show that elementary transpositions generate the symmetric
groups as a Coxeter group. We follow the proofs from Alain Lascoux "The
Symmetric Group", unfinished notes. It is not the shortest nor the simplest,
but it is fully explicit and algorithmic. In particular, it goes through two
algorithms to
- compute the size-lexicographically minimal reduced word of a permutation
- straighten a word to the previous reduced word.

Here are the notion defined is this file:

Notion of code

- [c \is a code] == c is a list such that [c_i <= i].
- [wordcd c] == for a code [c] the list [0, 1-c1..1, 2-c2..2, ..]

- [is_code_of_size c n] == the predicate [c] is a code of size [n]
- [enum_codesz n] == a list enumerating all the code of size [n]
- [codesz n] == sigma type for codes of size [n], canonically a [finType]

Elementary tranpositions

- ['s_i]     == the i-th elementary transposition. It is of type ['S_n.+1]
                where n is inferred from the context. [i] is an integer
                smaller than [n] (otherwise [eltr i] is the identity)

Inversion sets

- [invset s] == the set of inversion of [s]
- [Delta]    == the set of pair [(i, j)] such that [0 <= i < j < n.+1];
                 [n] is infered from the context
- [is_invset IS]     == [IS] is the inversion set of a permutation, that is
                 subdiagonal transitive and co-transitive
- [length s] == the number of inversion of [s] we show latter that this is the
                Coxeter length of [s]
- [rsymrel IS] == the reflexive and antisymmetric closure of the binary
                relation associated to the inversion set [IS]
- [perm_of_invset IS] == the permutation whose inversion set is [IS]

Inverse Lehmer code

- [cocode s] == the recursively defined Lehmer code of [s^-1]
- [canword s] == the canonical reduced word for [s] as a [seq 'I_n]
- [prods_codesz c] == the product [eltr i] associated to the code [c] that
                is for [i <- wordcd c]. Lemma [prods_codesz_bij] shows that it
                is a bijection from [codesz n.+1] to ['S_n.+1].

Reduced words

- [w \is reduced] == [w] is a word of size [length 's_[w]].

Braid relations

- [braid_aba]    == the braid rewriting rule [a a.+1 a == a.+1 a a.+1]
- [braidC]       == the braid rewriting rule [a b == b a] if |b - a| > 1
- [braidrule]    == the union of the two previous rules
- [braidcongr]   == the braid monoid congruence generated by [braidrule]
- [braidclass s] == the braid monoid class of [s]
- [a =Br b]      == [a] and [b] are equivalent under the braid congruence

- [reduce u v]   == [u] reduces to [v] using the rule [[:: i i] -> [::]]
- [braidred u v] == either [u =Br v] or [reduce u v]

The algorithms

- [inscode c i] == the insertion the letter [i] in the code [c]. If [c] is the
               code for the permutation [s] then it is the code for the
               permutation [s * 's_i]
- [path_catl p w] == append [w] to all the sequences of [p] that is
                     [[seq v ++ w | v <- p]]
- [straighten w] == the straigtened reduced word equivalent to [w]

The presentation

- [relat_Sn n g] == if [g : nat -> gT] for a [finGroupType] [gt]. A
               proposition which asserts that the relation of the symmetric
               group holds for the [g i] denoted ['g_i]. Namely

  - [forall i, i < n -> 'g_i^+2 = 1]
  - [forall i, i.+1 < n -> 'g_i * 'g_i.+1 * 'g_i = 'g_i.+1 * 'g_i * 'g_i.+1]
  - [forall i j, i.+1 < j < n -> 'g_i * 'g_j = 'g_j * 'g_i]

The main result is thus [Theorem presentation_Sn_eltr]:

  [
    relat_Sn ->
    exists f : {morphism 'SG_n.+1 >-> gT}, forall i, i < n -> f 's_i = 'g_i.
  ]
***************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import choice fintype tuple finfun fingraph finset binomial.
From mathcomp Require Import bigop fingroup perm morphism presentation.
From mathcomp Require Import ssralg poly ssrint.

Require Import permcomp tools permuted combclass congr.

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

Section SRel.

Variable T : finType.
Implicit Type (S A B : {set T * T}).
Definition srel S := [rel x y : T | (x, y) \in S].

Lemma srelE S1 S2 : srel S1 =2 srel S2 -> S1 = S2.
Proof. by move=> eqS; apply/setP => [[x y]]; apply: eqS x y. Qed.

Definition tclosure A : {set T * T} :=
  [set p | (p.1 != p.2) && (connect (srel A) p.1 p.2)].

Lemma tclosure_sub A B :
  A \subset B -> transitive (srel B) -> tclosure A \subset B.
Proof.
move=> /subsetP AB trB.
apply/subsetP => /= [[i j]]; rewrite /tclosure inE /= => /andP [Hneq].
move/connectP => /= [p]; elim: p => [| p0 p IHp] /= in i Hneq *.
  by move => _ Heq; rewrite Heq eqxx in Hneq.
case: (altP (p0 =P j)) => [<- /= /andP[/AB ->] // | {}/IHp IHp].
by move=> /andP [/AB {}/trB trB {}/IHp H{}/H]; apply: trB.
Qed.

End SRel.

Prenex Implicits srel.

Notation "''SG_' n" := [set: 'S_n]
  (at level 8, n at level 2, format "''SG_' n").

Reserved Notation "''s_' i"
      (at level 8, i at level 2, format "''s_' i").
Reserved Notation "''s_' [ w ] "
      (at level 8, w at level 100, format "''s_' [ w ]").

Local Reserved Notation "''II_' n" (at level 8, n at level 2).
Local Reserved Notation "a =Br b" (at level 70).
Local Reserved Notation "''I[' a '..' b ']'" (at level 0, a, b at level 2).

Lemma ieqi1F i : (i == i.+1) = false. Proof. by apply: negbTE; elim i. Qed.
Lemma ieqi2F i : (i == i.+2) = false. Proof. by apply: negbTE; elim i. Qed.
Lemma i1eqiF i : (i.+1 == i) = false. Proof. by apply: negbTE; elim i. Qed.
Lemma i2eqiF i : (i.+2 == i) = false. Proof. by apply: negbTE; elim i. Qed.

Lemma inordi n i : i < n -> (@inord n i = i :> nat).
Proof. move=> Hi; rewrite inordK // ltnS; exact: ltnW. Qed.

Lemma inordi1 n i : i < n -> (@inord n i.+1 = i.+1 :> nat).
Proof. move=> Hi; by rewrite inordK. Qed.

Lemma inord1i n i : i.+1 < n -> (@inord n i = i :> nat).
Proof. move=> Hi; rewrite inordK //; apply ltnW; exact: ltnW. Qed.

Lemma inordi_neq_i1 n i : i < n -> (@inord n i != @inord n i.+1).
Proof.
move=> Hi.
rewrite /eq_op /= inordK; last by apply (leq_trans Hi).
rewrite inordK; last exact: Hi.
by rewrite ieqi1F.
Qed.

Definition trivSimpl := (eq_refl, eqSS, ieqi1F, ieqi2F, i1eqiF, i2eqiF).

(** * Codes for permutations *)
Section Codes.

Definition code := [qualify a c : seq nat |
  all (fun i => nth 0 c i <= i) (iota 0 (size c)) ].

Definition wordcd (c : seq nat) : seq nat :=
  flatten [seq rev (iota (i - nth 0 c i) (nth 0 c i)) | i <- iota 0 (size c)].

Lemma size_wordcd c : size (wordcd c) = sumn c.
Proof.
rewrite /wordcd size_flatten; congr sumn.
rewrite /shape -map_comp.
apply (eq_from_nth (x0 := 0)); rewrite size_map size_iota //.
move=> i Hi; rewrite (nth_map 0); last by rewrite size_iota.
by rewrite /= size_rev size_iota (nth_iota _ _ Hi) add0n.
Qed.

Lemma is_codeP c :
  reflect (forall i, i < size c -> nth 0 c i <= i) (c \is a code).
Proof.
rewrite /unfold_in; apply (iffP idP) => [/allP Hcode // i Hi | Hcode].
- by apply Hcode; rewrite mem_iota /= add0n.
- by apply/allP => i; rewrite mem_iota add0n /=; exact: Hcode.
Qed.

Lemma is_code_rcons c i : i <= size c -> c \is a code -> rcons c i \is a code.
Proof.
move=> Hi /is_codeP Hcode; apply/is_codeP => j.
rewrite size_rcons ltnS leq_eqVlt => /orP [/eqP ->| Hj]; rewrite nth_rcons.
- by rewrite ltnn eq_refl.
- by rewrite Hj; apply Hcode.
Qed.

Lemma is_code_rconsK c i : rcons c i \is a code -> c \is a code.
Proof.
move/is_codeP; rewrite size_rcons => Hcode.
apply/is_codeP => j Hj; have:= Hj; rewrite -ltnS => /ltnW/Hcode.
by rewrite nth_rcons Hj.
Qed.

Lemma code_ltn_size c : c \is a code -> all (gtn (size c)) c.
Proof.
move=> /is_codeP Hcode.
apply/allP => v Hv; rewrite -(nth_index 0 Hv).
move: Hv; rewrite -index_mem => Hv.
by have:= Hv => /Hcode/leq_ltn_trans; apply.
Qed.

Lemma wordcd_ltn c :
  c \is a code -> all (gtn (size c).-1) (wordcd c).
Proof.
move=> /is_codeP Hcode.
apply/allP => i /flatten_mapP [ j]; rewrite mem_iota /= add0n => Hc.
rewrite mem_rev mem_iota subnK; last exact: Hcode.
move=> /andP [_ /leq_trans]; apply.
by case: (size c) Hc.
Qed.

Lemma insub_wordcdK n c :
  c \is a code -> size c <= n.+1 ->
  [seq (i : nat) | i : 'I_n <- pmap insub (wordcd c)] = wordcd c.
Proof.
move=> /wordcd_ltn/allP Hall Hsz.
rewrite pmap_filter; last by move=> j /=; rewrite insubK.
rewrite (eq_in_filter (a2 := xpredT)); first by rewrite filter_predT.
move=> j /= /Hall /= Hj.
have {}Hj : j < n by case: (size c) Hj Hsz => [| sz]//=; apply: leq_trans.
by rewrite insubT.
Qed.

Definition is_code_of_size n c := (c \is a code) && (size c == n).

Fixpoint enum_codesz n :=
  if n is n'.+1 then
    flatten [seq [seq rcons c i | c <- enum_codesz n'] | i <- iota 0 n]
  else [:: [::]].

Lemma enum_codeszP n : all (is_code_of_size n) (enum_codesz n).
Proof.
rewrite /is_code_of_size; elim: n => [| n IHn] //.
apply/allP => cn /flatten_mapP [i].
rewrite -/enum_codesz mem_iota /= add0n ltnS => Hi.
move=> /mapP [c /(allP IHn) {IHn}] /andP [Hcode /eqP Hsz ->] {cn}.
rewrite size_rcons Hsz eq_refl andbT.
by apply is_code_rcons; first by rewrite Hsz.
Qed.

Lemma enum_codesz_countE n c :
  is_code_of_size n c -> count_mem c (enum_codesz n) = 1.
Proof.
elim: n c => [//= | n IHn] c /andP [].
  by move=> _ /nilP ->; rewrite eq_refl addn0.
case/lastP: c => [// | c cn] Hcode.
rewrite size_rcons eqSS => /eqP Hsz.
have /IHn{IHn} Hcount : is_code_of_size n c.
  rewrite /is_code_of_size Hsz eq_refl andbT.
  exact: (is_code_rconsK Hcode).
rewrite count_flatten -map_comp -/enum_codesz.
rewrite (eq_map (f2 := fun i => i == cn : nat)); first last.
  move=> i /=; rewrite count_map /=.
  case (altP (i =P cn)) => [Heq | /negbTE Hneq].
  + subst i; rewrite (eq_count (a2 := xpred1 c)); first exact: Hcount.
    by move=> s /=; apply/idP/idP => [/eqP/rconsK ->| /eqP ->].
  + rewrite (eq_count (a2 := pred0)); first by rewrite count_pred0.
    move=> s /=; apply/negP=> /eqP/(congr1 rev).
    by rewrite !rev_rcons => [] [/eqP]; rewrite Hneq.
rewrite sumn_pred1_iota //= add0n.
move/is_codeP: Hcode; rewrite size_rcons ltnS => /(_ _ (ltnSn _)).
by rewrite nth_rcons ltnn eq_refl Hsz => ->.
Qed.

(** ** Fintype for codes for permutations of size n *)
Section FinType.

Variable n : nat.

Structure codesz : Set :=
  CodeSZ {cdval :> seq nat; _ : (cdval \is a code) && (size cdval == n)}.
Canonical codesz_subType := Eval hnf in [subType for cdval].
Definition codesz_eqMixin := Eval hnf in [eqMixin of codesz by <:].
Canonical codesz_eqType := Eval hnf in EqType codesz codesz_eqMixin.
Definition codesz_choiceMixin := Eval hnf in [choiceMixin of codesz by <:].
Canonical codesz_choiceType := Eval hnf in ChoiceType codesz codesz_choiceMixin.
Definition codesz_countMixin := Eval hnf in [countMixin of codesz by <:].
Canonical codesz_countType := Eval hnf in CountType codesz codesz_countMixin.
Canonical codesz_subCountType := Eval hnf in [subCountType of codesz].
Let type := sub_finType codesz_subCountType
                        (enum_codeszP n) (@enum_codesz_countE n).
Canonical codesz_finType := Eval hnf in [finType of codesz for type].
Canonical codesz_subFinType := Eval hnf in [subFinType of codesz].

Implicit Type (c : codesz).

Lemma codeszP c : val c \is a code.
Proof using. by case: c => c /= /andP []. Qed.

Lemma size_codesz c : size c = n.
Proof using. by case: c => c /= /andP [_ /eqP]. Qed.

Lemma enum_codeszE : map val (enum {:codesz}) = enum_codesz n.
Proof using. by rewrite /=; exact: enum_subE. Qed.

End FinType.

Lemma card_codesz n : #|{:codesz n}| = n`!.
Proof.
rewrite factE /= cardE -(size_map val) enum_codeszE.
elim: n => [//=| n IHn].
rewrite size_flatten -/enum_codesz /shape -map_comp.
rewrite (eq_map (f2 := fun => fact_rec n)); first last.
  by move=> i /=; rewrite size_map.
by rewrite sumnE big_map big_const_seq count_predT size_iota iter_addn_0 mulnC.
Qed.

End Codes.

#[export] Hint Resolve codeszP : core.

Import GroupScope.

(** * Elementary transpositions *)
Section Transp.

Variable T : finType.
Implicit Types (x y z t : T).

Lemma tperm_braid x y z :
  x != y -> y != z ->
  tperm x y * tperm y z * tperm x y = tperm y z * tperm x y * tperm y z.
Proof using.
move=> Hxy Hyz.
rewrite -{1}(tpermV x y) -mulgA -/(conjg _ _) tpermJ tpermR.
rewrite -{1}(tpermV y z) -mulgA -/(conjg _ _) tpermJ tpermL.
case: (altP (x =P z)) => [-> | Hxz].
- by rewrite tpermR tpermL tpermC.
- rewrite (tpermD Hxz Hyz).
  rewrite ![x == _]eq_sym in Hxy Hxz.
  by rewrite (tpermD Hxy Hxz).
Qed.

Lemma tpermC x y a b :
  x != a -> y != a -> x != b -> y != b ->
  tperm x y * tperm a b = tperm a b * tperm x y.
Proof using.
move=> Hxa Hya Hxb Hyb.
apply permP => i; rewrite !permM.
case: (tpermP a b i) => [-> | -> |].
- by rewrite (tpermD Hxa Hya) tpermL (tpermD Hxb Hyb).
- by rewrite (tpermD Hxa Hya) (tpermD Hxb Hyb) tpermR.
case: (tpermP x y i) => [ _ _ _ | _ _ _ | _ _ ].
- rewrite ![y == _]eq_sym in Hya Hyb.
  by rewrite tpermD.
- rewrite ![x == _]eq_sym in Hxa Hxb.
  by rewrite tpermD.
- move=> /eqP; rewrite eq_sym => Hai.
- move=> /eqP; rewrite eq_sym => Hbi.
  by rewrite tpermD.
Qed.

End Transp.

Section ElemTransp.

Variable n0 : nat.
Notation n := n0.+1.

Definition eltr i : 'S_n0.+1 := tperm (inord i) (inord i.+1).

Notation "''s_' i" := (eltr i).
Notation "''s_' [ w ]" := (\prod_(i <- w) 's_i).

Implicit Type s t : 'S_n.

Lemma eltrV i : 's_i^-1 = 's_i. Proof. by rewrite tpermV. Qed.
Lemma eltrK i : involutive 's_i. Proof. exact: tpermK. Qed.
Lemma eltr2 i : 's_i * 's_i = 1. Proof. exact: tperm2. Qed.

Lemma eltr_braid i :
  i.+1 < n0 -> 's_i * 's_i.+1 * 's_i = 's_i.+1 * 's_i * 's_i.+1.
Proof using.
move=> Hi.
apply: tperm_braid; rewrite /eq_op /=.
- by rewrite inord1i // inordi // !trivSimpl.
- by rewrite inordi // inordi1 // !trivSimpl.
Qed.

Lemma eltr_comm i j :
  i.+1 < j < n0 -> 's_i * 's_j = 's_j * 's_i.
Proof using.
move => /andP [Hij Hj].
have Hi := ltn_trans Hij Hj.
apply: tpermC; rewrite /eq_op /=.
- by rewrite inord1i // inordi // (ltn_eqF (ltnW Hij)).
- by rewrite !inordi // (ltn_eqF Hij).
- rewrite inord1i // inordi1 //.
  by rewrite (ltn_eqF (leq_trans (ltnW Hij) (leqnSn j))).
- rewrite inordi // inordi1 //.
  by rewrite eqSS (ltn_eqF (ltnW Hij)).
Qed.

Local Lemma eltrL_ord (i : 'I_n) : 's_i i = inord i.+1.
Proof. by rewrite /eltr -{3}(inord_val i) tpermL. Qed.
Local Lemma eltrR_ord (i : 'I_n) : 's_i (inord i.+1) = i.
Proof. by rewrite /eltr tpermR inord_val. Qed.
Local Lemma eltrD_ord (i j : 'I_n) : i != j -> inord i.+1 != j -> 's_i j = j.
Proof. by move=> Hi Hi1; rewrite tpermD // inord_val. Qed.

Definition eltrL := (eltrL_ord, tpermL).
Definition eltrR := (eltrR_ord, tpermR).
Definition eltrD := (eltrD_ord, tpermD).

Lemma prods_iota_mi (m : 'I_n) i :
  i <= m -> 's_[iota (m - i) i] (inord (m - i)) = m.
Proof using.
elim: i => [| i IHi] /= Hm.
  by rewrite subn0 inord_val big_nil perm1.
rewrite big_cons permM eltrL.
rewrite subnS prednK; last by rewrite subn_gt0.
by apply: IHi; exact: ltnW.
Qed.

Lemma prods_iota_ltmi i (m u : 'I_n) :
  u < m - i -> 's_[(iota (m - i) i)] u = u.
Proof using.
rewrite big_seq=> ltumi; elim/big_ind: _.
- by rewrite perm1.
- by move=> s t Hs Ht; rewrite permM Hs Ht.
move=> j; rewrite mem_iota.
case: (ltnP m i) => [/ltnW|].
  by rewrite -subn_eq0 => /eqP H; rewrite H in ltumi.
move=> /subnK -> /andP[/(leq_trans ltumi) ltuj].
move=> /leq_ltn_trans/(_ (ltn_ord _)) ltjn1.
have jo  := ltn_trans (ltnSn _) ltjn1.
rewrite eltrD // -val_eqE //= inordK // gtn_eqF //.
exact: (ltn_trans ltuj (ltnSn _)).
Qed.

Lemma cycleij_j (i j : 'I_n) :
  i <= j -> 's_[index_iota i j] i = j.
Proof using.
move=> leij; rewrite /index_iota -{3}(inord_val i) -{1 3}(subKn leij).
exact/prods_iota_mi/leq_subr.
Qed.

Lemma cycleij_lt (i j k : 'I_n) :
  i <= j -> k < i -> 's_[index_iota i j] k = k.
Proof using.
move=> leij ltki; rewrite /index_iota -{1}(subKn leij).
by apply: prods_iota_ltmi; rewrite subKn.
Qed.

Lemma cycleij_gt (i j : nat) (k : 'I_n) :
  j < k -> 's_[index_iota i j] k = k.
Proof using.
move=> ltij; rewrite big_seq; elim/big_ind: _.
- by rewrite perm1.
- by move=> s t Hs Ht; rewrite permM Hs Ht.
move=> u; rewrite mem_iota => /andP[leiu].
case: (ltnP j i) => [/ltnW|].
  rewrite -subn_eq0 => /eqP ->.
  by rewrite addn0 => /leq_trans/(_ leiu); rewrite ltnn.
move=> /subnKC -> /leq_ltn_trans/(_ ltij) ltu1k.
have u1o := ltn_trans ltu1k (ltn_ord k).
have uo  := ltn_trans (ltnSn _) u1o.
rewrite eltrD // -val_eqE //= inordK // ltn_eqF //.
exact: (ltn_trans (ltnSn _) ltu1k).
Qed.

Lemma cycleij_inS i (j k : 'I_n) :
  i <= k < j -> 's_[index_iota i j] (inord k.+1) = k.
Proof.
rewrite /index_iota => /andP[lejk ltkj].
have ltij := leq_ltn_trans lejk ltkj.
have lekj := ltnW ltkj.
have -> /= : iota i (j - i) = iota i (k - i) ++ iota k (j - k.+1).+1.
  rewrite subnS prednK ?subn_gt0 //.
  suff -> : (j - i) = (k - i) + (j - k) by rewrite iotaD subnKC.
  by rewrite addnC addnBA // subnK.
rewrite big_cat /= big_cons permM cycleij_gt //; first last.
  by rewrite inordK // ltnS (leq_trans ltkj) // -ltnS.
rewrite permM eltrR_ord.
have Hk1 := inordK (leq_ltn_trans ltkj (ltn_ord _)).
by rewrite -Hk1 cycleij_lt // Hk1.
Qed.

Lemma cycleij_in i (j k : 'I_n) :
  i < k <= j -> 's_[index_iota i j] k = (inord k.-1).
Proof.
move=> /andP[ltik lekj].
have eqk1 : val k = (inord k.-1 : 'I_n).+1.
  by rewrite inordK ?(ltn_predK ltik) // ltnW.
rewrite -{1}(inord_val k) {1}eqk1 cycleij_inS //.
by rewrite -ltnS -eqk1 ltik.
Qed.

Lemma prodsK w : 's_[w] * 's_[rev w] = 1.
Proof using.
elim/last_ind: w => [| w wn IHw] /=.
  by rewrite /rev /= !big_nil mulg1.
rewrite rev_rcons -cat1s -cats1 -big_cat /=.
rewrite -catA -[wn :: rev w]cat1s [X in w ++ X]catA cat1s !big_cat /=.
suff -> : 's_[[:: wn; wn]] = 1 by rewrite mul1g.
by rewrite big_cons big_seq1 eltr2.
Qed.

Lemma prodsV w : 's_[rev w] = 's_[w]^-1.
Proof using. by apply/eqP; rewrite eq_sym eq_invg_mul prodsK. Qed.

Lemma odd_eltr i : (i < n0)%N -> odd_perm 's_i.
Proof.
rewrite odd_tperm => Hi.
apply/negP=> /eqP/(congr1 val)/eqP/=.
rewrite !inordK // ?ltnS ?ieqi1F //.
exact: ltnW.
Qed.

End ElemTransp.

Local Notation "''II_' n" := ('I_n * 'I_n)%type.

(** * Inversion set of a permutation *)
Section InvSet.

Variable n0 : nat.
Notation n := n0.+1.

Implicit Type (p : 'II_n) (IS S : {set 'II_n}).
Implicit Type s t : 'S_n.

Definition Delta : {set 'II_n} := [set p : 'II_n | (p.1 < p.2)].
Definition invset (s : 'S_n) : {set 'II_n} :=
  [set p : 'II_n | (p.1 < p.2) && (s p.1 > s p.2) ].
Definition rsymrel IS :=
  [rel i j : 'I_n |
   [|| (i == j), (j, i) \in IS | (i < j) && ((i, j) \notin IS)]].

Variant is_invset IS : Prop :=
  IsInvset of IS \subset Delta
  & transitive (srel IS)
  & transitive (srel (Delta :\: IS)).

Lemma mem_Delta i j : (i, j) \in Delta = (i < j).
Proof. by rewrite inE. Qed.
Lemma DeltaP i j : (i, j) \in Delta -> (i < j).
Proof. by rewrite inE. Qed.
Lemma is_invset_Delta IS : is_invset IS -> IS \subset Delta.
Proof. by move=> []. Qed.

Lemma transitive_DeltaI1 IS :
  (transitive (srel (Delta :\: IS))) <->
  (forall i j k : 'I_n,
      i < j < k -> (i, k) \in IS -> ((i, j) \in IS \/ (j, k) \in IS)).
Proof.
split.
- rewrite /= => tr i j k /andP [iltj jltk] ik.
  case: (boolP ((i, j) \in IS)) => [_|ijN]/=; first by left.
  right; move: ik; apply/contraLR => jkN.
  have {}/tr tr : (i, j) \in Delta :\: IS by rewrite !inE ijN /= iltj.
  have {}/tr    : (j, k) \in Delta :\: IS by rewrite !inE jkN /= jltk.
  by rewrite /= inE => /andP [].
- move=> H j i k; rewrite /= !inE /= ![_ && (_ < _)]andbC.
  move=> /andP [iltj ijN] /andP [jltk jkN].
  rewrite (ltn_trans iltj jltk) /=.
  have ijk : i < j < k by rewrite iltj jltk.
  move: ijN; apply contra => /(H i j k ijk) [] //.
  by rewrite (negbTE jkN).
Qed.

Lemma invset_Delta s : invset s \subset Delta.
Proof.
rewrite /invset/Delta; apply/subsetP => [[/= i j]].
by rewrite !inE /= => /andP [].
Qed.

Lemma invset_permV s :
  invset s^-1 = [set (s (p.2), s (p.1)) | p in invset s].
Proof.
apply/setP => [[i j]]; rewrite !inE /=.
apply/andP/imsetP => /= [[Hij Hsij] | [] [u v]].
- by exists (s^-1 j, s^-1 i); rewrite ?inE ?Hsij ?permKV ?Hij.
- by rewrite inE /= => /andP[Huv Hsuv] [-> ->]; rewrite !permK.
Qed.

Lemma invsetP s : is_invset (invset s).
Proof.
split; first exact: invset_Delta.
- rewrite /=/invset => j i k /=; rewrite !inE /=.
  by move=> /andP[/ltn_trans iltj /(ltn_trans _) siltsj]
            /andP[/iltj-> /siltsj->].
- rewrite /=/invset => j i k /=; rewrite !inE /=.
  have bla A B : ((~~ (A && B)) && A) = (A && ~~ B) by case: A; case: B.
  rewrite !{}bla -!leqNgt.
  by move=> /andP[/ltn_trans iltj /leq_trans siltsj] /andP[/iltj-> /siltsj->].
Qed.

Lemma rsymrel_refl IS : reflexive (rsymrel IS).
Proof. by rewrite /rsymrel=> k /=; rewrite eqxx. Qed.
Lemma rsymrel_anti IS :
  IS \subset Delta -> antisymmetric (rsymrel IS).
Proof.
rewrite /rsymrel => /subsetP HD i j /=.
move=> /andP [/or3P [/eqP -> //|jiIS|/andP [iltj ijNIS]]].
- move=> /or3P [/eqP -> //|ijIS|/andP [jlti jiNIS]].
  + exfalso.
    by have:= ltn_trans (DeltaP (HD _ jiIS)) (DeltaP (HD _ ijIS)); rewrite ltnn.
  + by rewrite jiIS in jiNIS.
- move=> /or3P [/eqP -> //|ijIS|/andP [jlti jiNIS]].
  + by rewrite ijIS in ijNIS.
  + exfalso.
    by have:= ltn_trans iltj jlti; rewrite ltnn.
Qed.
Lemma rsymrel_trans IS : is_invset IS -> transitive (rsymrel IS).
Proof.
case; rewrite /rsymrel/= => /subsetP HD HIS HDIS j i k /=.
move/orP=> [/eqP->{i}| Hij]; first by [].
move/orP=> [/eqP<-{k}| Hjk]; first by rewrite Hij orbT.
apply/orP; right; move: Hij Hjk.
move=> /orP [jiIS|/andP [iltj ijNIS]] /orP [kjIS|/andP [jltk jkNIS]]; apply/orP.
- by left; apply: (HIS j).
- case: (ltngtP i k) => [iltk | klti | /val_inj ik].
  + right => /=.
    by move: jkNIS; apply contra => /(HIS _ _ _ jiIS); apply.
  + left; move: jiIS; apply contraLR => kiNIS.
    have jlti := ltn_trans jltk klti.
    have:= HDIS k j i; rewrite /= !inE /= klti jltk jlti !andbT.
    exact.
  + by exfalso; subst k; rewrite jiIS in jkNIS.
- case: (ltngtP i k) => [iltk | klti | /val_inj ik].
  + right => /=.
    by move: ijNIS; apply contra => /HIS; apply.
  + left; move: kjIS; apply contraLR => kiNIS.
    have kltj := ltn_trans klti iltj.
    have:= HDIS i k j; rewrite /= !inE /= iltj klti kltj !andbT.
    exact.
  + by exfalso; subst k; rewrite kjIS in ijNIS.
- right.
  have iltk := ltn_trans iltj jltk.
  have:= HDIS j i k; rewrite /= !inE /= jltk iltk iltj !andbT.
  exact.
Qed.
Lemma rsymrel_total (IS : {set 'II_n}) :
  IS \subset Delta -> total (rsymrel IS).
Proof.
rewrite /rsymrel => /subsetP HD /= i j /=.
case: eqP => //= /eqP Hneq.
rewrite eq_sym (negbTE Hneq) /=; apply/orP.
case: (boolP ((j, i) \in IS)) => /=[_|ijNIS]; first by left.
case: (boolP ((i, j) \in IS)) => /=[_|jiNIS]; first by right.
by rewrite !andbT; apply/orP; rewrite -neq_ltn.
Qed.

Lemma rsym_invset_refl s : reflexive (rsymrel (invset s)).
Proof. exact: rsymrel_refl. Qed.
Lemma rsym_invset_anti s : antisymmetric (rsymrel (invset s)).
Proof. exact: rsymrel_anti (invset_Delta s). Qed.
Lemma rsym_invset_trans s : transitive (rsymrel (invset s)).
Proof. exact: rsymrel_trans (invsetP s). Qed.
Lemma rsym_invset_total s : total (rsymrel (invset s)).
Proof. exact: rsymrel_total (invset_Delta s). Qed.

Lemma rsym_invsetP s :
  sorted (rsymrel (invset s)) [seq s^-1 i | i : 'I_n].
Proof.
apply/(sorted.sorted1P ord0) => i; rewrite size_map size_enum_ord => i1ltn1.
have iltn1 := ltnW i1ltn1.
rewrite !(nth_map ord0) -?enumT ?size_enum_ord //.
rewrite -[i]/(val (Ordinal iltn1)) nth_ord_enum.
rewrite -[succn i]/(val (Ordinal i1ltn1)) nth_ord_enum.
set io := (Ordinal iltn1); set io1 := (Ordinal i1ltn1).
rewrite /= !inE /= negb_and -!leqNgt.
rewrite !permKV /= ltnSn leqnSn /= orbT !andbT.
by rewrite -neq_ltn eq_sym orbN.
Qed.

Lemma perm_of_relP (r : rel 'I_n) :
  injective (fun i : 'I_n => nth ord0 (sort r (enum 'I_n)) i).
Proof.
move=> i j /= /eqP.
rewrite nth_uniq => [/eqP/val_inj -> //|||].
- by rewrite size_sort size_enum_ord.
- by rewrite size_sort size_enum_ord.
- by rewrite sort_uniq enum_uniq.
Qed.
Definition perm_of_invset IS := (perm (@perm_of_relP (rsymrel IS)))^-1.

Lemma invsetK : cancel invset perm_of_invset.
Proof.
rewrite /perm_of_invset=> s; apply invg_inj; rewrite invgK.
apply/permP => i /=; rewrite permE.
have -> : s^-1 i = nth ord0 [seq s^-1 i | i : 'I_n] i.
  by rewrite (nth_map ord0) ?size_enum_ord // nth_ord_enum.
congr nth => {i}.
apply: (sorted_eq (@rsym_invset_trans s) (@rsym_invset_anti s)).
- exact: (sort_sorted (@rsym_invset_total s)).
- exact: rsym_invsetP.
- rewrite perm_sort; apply uniq_perm.
  + exact: enum_uniq.
  + rewrite map_inj_uniq; first exact: enum_uniq.
    exact: perm_inj.
  + move=> /= i; apply esym.
    rewrite mem_enum inE; apply/mapP; exists (s i); first by rewrite mem_enum.
    by rewrite permK.
Qed.

Theorem invset_inj : injective invset.
Proof. by move=> s t Hinvset; rewrite -(invsetK s) Hinvset invsetK. Qed.

Theorem perm_of_invsetK IS :
  is_invset IS -> invset (perm_of_invset IS) = IS.
Proof.
move=> ISinv; have ID := is_invset_Delta ISinv.
rewrite /perm_of_invset; set s := perm _.
have compat (i j : 'I_n) : i < j -> rsymrel IS (s i) (s j).
  rewrite {}/s !permE => /ltnW ilej.
  apply: (sorted.sortedP _ (rsymrel_trans ISinv) (rsymrel_refl IS) _
                         (sort_sorted (rsymrel_total ID) (enum 'I_n))).
  by rewrite ilej size_sort size_enum_ord /=.
rewrite invset_permV /invset -setP => /=[[i j]] /=.
apply/imsetP/idP => /= [[[a b]] | ijIS].
- rewrite inE /= => /andP [altb sbltsa [->{i} ->{j}]].
  move: altb => {}/compat.
  rewrite !inE /= /eq_op/= eqn_leq (leqNgt (s a) (s b)) sbltsa /=.
  by rewrite (ltnNge (s a) (s b)) (ltnW sbltsa) /= orbF.
- exists (s^-1 j, s^-1 i); last by rewrite !permKV.
  have iltj := DeltaP ((subsetP ID) _ ijIS).
  rewrite inE /= !permKV iltj andbT.
  case: ltngtP => //[{}/compat |]; first last.
    by move=> /val_inj/perm_inj Hij; rewrite Hij ltnn in iltj.
  rewrite !permKV !inE /=.
  rewrite ijIS /eq_op/= eqn_leq (leqNgt j i) iltj /= !andbF /= orbF.
  move=> /(subsetP ID)/DeltaP/ltn_trans/(_ iltj).
  by rewrite ltnn.
Qed.

Notation "''s_' i" := (eltr _ i).
Notation "''s_' [ w ]" := (\prod_(i <- w) 's_i).

Lemma eltr_exchange i (a b : 'I_n) :
  i < n0 -> a < b -> 's_i a < 's_i b = (i != a) || (i.+1 != b).
Proof using.
move=> Hi; case: tpermP => [-> | -> | /eqP Ha1 /eqP Hai1];
  case: tpermP => [-> | -> | /eqP Hb1 /eqP Hbi1];
  rewrite ?(inordi Hi) ?(inordi1 Hi) /= ?ltnn ?trivSimpl //=.
- by move=> /ltnW; rewrite leqNgt => /negbTE ->.
- by rewrite (ltn_neqAle i.+1 b) => ->; rewrite andbT.
- by rewrite ltnS leqnn.
- by move/ltnW => ->.
- by rewrite ltnS (ltn_neqAle a i) eq_sym => /andP [-> ->].
- by rewrite ltnS ltn_neqAle => -> /=; rewrite eq_sym andbT orbF.
- move=> ->; apply esym; apply/orP; left.
  move: Ha1; apply contra => /eqP Hia.
  by apply/eqP/val_inj; rewrite /= -Hia inordi.
Qed.

Lemma invset_eltrL s (i : 'I_n) :
  i < n0 -> s i < s (inord (i.+1)) ->
  invset ('s_i * s) =
  (i, inord i.+1) |: [set ('s_i p.1, 's_i p.2) | p in invset s].
Proof.
move => Hi Hfwd.
have Hio : (inord i) = i by apply val_inj => /=; rewrite inordK.
apply/setP => [/= [u v]] /=; rewrite !inE /= !permM.
apply/idP/idP.
- move=> /andP [Huv].
  case: tpermP => /= [Hv | Hv | /eqP Hvi /eqP Hvi1].
  + rewrite Hio in Hv; subst v.
    have Htu : 's_i u = u.
      rewrite eltrD // eq_sym.
      * by move: Huv; apply contraL => /eqP ->; rewrite ltnn.
      * by move: Huv; apply contraL => /eqP ->; rewrite /= -leqNgt inordi1.
    rewrite Htu => Hs; apply/orP; right.
    apply/imsetP; exists (u, inord i.+1); first last.
      by rewrite /= eltrR Htu.
    by rewrite inE /= Hs andbT inordi1 //; apply/(ltn_trans Huv).
  + rewrite Hio; subst v; case: tpermP.
    * by move=> ->; rewrite Hio eq_refl.
    * by move=> Hu; move: Huv; rewrite Hu ltnn.
    rewrite Hio => /eqP Hiu /eqP Hi1u.
    have Htu : 's_i u = u by rewrite eltrD // eq_sym.
    move=> Hsiu; apply/orP; right.
    apply/imsetP; exists (u, i); last by rewrite Htu /= eltrL.
    by rewrite inE /= Hsiu andbT ltn_neqAle Hiu -ltnS -(inordi1 Hi) Huv.
  rewrite Hio in Hvi.
  case: tpermP => [Hu | Hu | /eqP Hui /eqP Hui1].
  + rewrite Hio in Hu; subst u => Hsvi1.
    have Htv : 's_i v = v by rewrite eltrD // eq_sym.
    apply/orP; right.
    apply/imsetP; exists ((inord i.+1), v); last by rewrite Htv /= eltrR.
    rewrite inE /= Hsvi1 ltn_neqAle inordi1 //.
    by rewrite Huv !andbT eq_sym -(inordi1 Hi) Hvi1.
  + rewrite Hio; subst u => Hsvi1.
    have Htv : 's_i v = v by rewrite eltrD // eq_sym // Hio.
    apply/orP; right.
    apply/imsetP; exists (i, v); last by rewrite Htv /= eltrL.
    rewrite inE /= Hsvi1 ltn_neqAle eq_sym Hvi !andbT /=.
    by move: Huv; rewrite inordi1 // => /ltnW/ltnW.
  + rewrite Hio in Hui; move=> Hsvu.
    apply/orP; right.
    apply/imsetP; exists (u, v); last by rewrite !eltrD // eq_sym.
    by rewrite inE /= Huv Hsvu.
- move/orP => [].
    move=> /eqP [-> ->].
    by rewrite eltrL eltrR Hfwd inordi1 // ltnS leqnn.
  move=> /imsetP [[a b]]; rewrite inE /= => /andP [Hab Hsba] [-> ->] {u v}.
  rewrite !eltrK Hsba andbT (eltr_exchange Hi Hab) -negb_and.
  move: Hsba; apply contraL; rewrite -leqNgt => /andP [/eqP Hia /eqP Hib].
  have -> : a = i by apply val_inj.
  have -> : b = (inord i.+1) by apply val_inj; rewrite /= -Hib inordi1.
  exact: ltnW.
Qed.

Lemma invset_eltrR s (i : 'I_n) :
  i < n0 -> s^-1 i < s^-1 (inord (i.+1)) ->
  invset (s * 's_i) = (s^-1 i, s^-1 (inord i.+1)) |: invset s.
Proof.
move=> Hi Hfwd.
have Hio : (inord i) = i by apply val_inj => /=; rewrite inordK.
rewrite -eltrV -{1}(invgK s) -invMg invset_permV.
rewrite invset_eltrL // imsetU1; congr (_ |: _).
- by rewrite /= !permM eltrL eltrR.
- rewrite invset_permV -!imset_comp -[RHS](imset_id) /=; apply eq_imset.
  by move=> [u v]; rewrite /= !permM !eltrK !permK.
Qed.

End InvSet.
Arguments Delta {n0}.

Section Length.

Variable n0 : nat.
Notation n := n0.+1.

Notation "''s_' i" := (eltr n0 i).
Notation "''s_' [ w ]" := (\prod_(i <- w) 's_i).

Implicit Type s t u : 'S_n.

(** * Length of a permutation *)
Definition length s := #|invset s|.

Lemma length1 : length 1 = 0.
Proof using.
rewrite /length /invset.
apply/eqP; rewrite cards_eq0; apply/eqP/setP => [[i j]]; rewrite !inE !perm1.
apply/negP=> /andP /= [/ltn_trans H{}/H].
by rewrite ltnn.
Qed.

Lemma lengthV s : length s^-1 = length s.
Proof using.
rewrite /length invset_permV card_imset //.
by move=> /= [i j] [k l] /= [/perm_inj-> /perm_inj->].
Qed.

Lemma length_add1L s (i : 'I_n) :
  i < n0 -> s i < s (inord (i.+1)) -> length ('s_i * s) = (length s).+1.
Proof using.
rewrite /length => Hi Hfwd.
have Hio : (inord i) = i by apply val_inj => /=; rewrite inordK.
rewrite (invset_eltrL Hi Hfwd).
rewrite cardsU1 (card_imset _ (@inv_inj _ _ _)); first last.
  by move=> [u v] /=; rewrite !eltrK.
rewrite (_ : (_, _) \in _ = false) //.
apply/negP => /imsetP [[u v]].
rewrite inE /= => /andP [Huv Hsvu] [].
move/(congr1 's_i); rewrite eltrK eltrL => Hu; subst u.
move/(congr1 's_i); rewrite eltrK eltrR => Hv; subst v.
by move: Huv => /ltnW; rewrite inordi1 // ltnn.
Qed.

Lemma length_sub1L s (i : 'I_n) :
  i < n0 -> s i > s (inord (i.+1)) -> length s = (length ('s_i * s)).+1.
Proof using.
move=> Hi Hs.
rewrite -{1}[s](mulKg 's_i) eltrV.
by apply (length_add1L Hi); rewrite !permM eltrL eltrR.
Qed.

Lemma length_descL s (i : 'I_n) :
  i < n0 -> (s i < s (inord (i.+1))) = (length ('s_i * s) > length s).
Proof using.
move=> Hi.
case: (ltngtP (s i) (s (inord (i.+1)))) => Hsi; apply esym.
- by rewrite (length_add1L  Hi Hsi) ltnS leqnn.
- by rewrite (length_sub1L Hi Hsi) ltnNge leqnSn.
- exfalso.
  have {Hsi} : s i = s (inord i.+1) by apply val_inj.
  move=> /perm_inj /(congr1 val) /= /eqP.
  by rewrite inordK ?ltnS // trivSimpl.
Qed.

Lemma length_add1R s (i : 'I_n) :
  i < n0 -> s^-1 i < s^-1 (inord (i.+1)) -> length (s * 's_i) = (length s).+1.
Proof using.
move=> Hi Hdesc.
rewrite -lengthV -[length s]lengthV invMg eltrV.
exact: length_add1L.
Qed.

Lemma length_sub1R s (i : 'I_n) :
  i < n0 -> s^-1 i > s^-1 (inord (i.+1)) -> length s = (length (s * 's_i)).+1.
Proof using.
move=> Hi Hdesc.
rewrite -lengthV -[length (s * _)]lengthV invMg eltrV.
exact: length_sub1L.
Qed.

Lemma length_descR s (i : 'I_n) :
  i < n0 -> (s^-1 i < s^-1 (inord (i.+1))) = (length (s * 's_i) > length s).
Proof using.
by move/length_descL ->; rewrite -{1}eltrV -invMg !lengthV.
Qed.

Lemma length_eltr (i : 'I_n0) : length 's_i = 1%N.
Proof using.
pose il := lift ord_max i.
have Hi : il < n0 by rewrite /il lift_max ltn_ord.
have:= length_add1L (s := 1) Hi; rewrite mulg1 length1 lift_max; apply.
by rewrite !perm1 /= /bump (leqNgt n0 i) ltn_ord /= add0n inordK // ltnS.
Qed.

Lemma length_prods (w : seq 'I_n0) : length 's_[w] <= size w.
Proof using.
elim: w => [/=| w0 w]; first by rewrite big_nil length1.
rewrite big_cons /=; move: ('s_[w]) => s Hlen.
pose w0' := inord (n' := n0) w0.
have Hw0' : w0' < n0 by rewrite /= inordK //; apply: ltnW; rewrite ltnS.
have -> : w0 = w0' :> nat by rewrite inordK //; apply ltnW; rewrite ltnS.
case (ltngtP (s w0') (s (inord w0'.+1))) => H.
- by rewrite (length_add1L Hw0' H); rewrite ltnS.
- move: Hlen; rewrite (length_sub1L Hw0' H) => /ltnW.
  by rewrite -ltnS => /ltnW.
- exfalso; move: H => /val_inj/perm_inj => H.
  have {H} /= /eqP := (congr1 nat_of_ord H).
  by rewrite inordK // ieqi1F.
Qed.

(** * The canonical reduced word of a permutation *)
Fixpoint cocode_rec m c (s : 'S_n) : seq nat :=
  if m is m'.+1 then
    let mo := inord m' in
    cocode_rec m' (mo - s mo :: c) (s * 's_[iota (s mo) (mo - s mo)])
  else c.
Definition cocode s := cocode_rec n [::] s.
Definition canword s : seq 'I_n0 := pmap insub (wordcd (cocode s)).

(*
Definition Lehmer (s : 'S_n.+1) (i : 'I_n.+1) :=
  #|[set j : 'I_n.+1 | (i < j) && (s i > s j)]|.
*)

(** ** Properties of the dual code *)
Lemma cocode_rec_cat m c s : cocode_rec m c s = (cocode_rec m [::] s ++ c).
Proof using.
elim: m => [//= | m IHm] in c s * => /=.
by rewrite IHm [X in _ = X ++ _]IHm -cat1s catA.
Qed.

Lemma wordcdE c :
  's_[wordcd c] =
  \prod_(i <- iota 0 (size c)) 's_[rev (iota (i - nth 0 c i) (nth 0 c i))].
Proof using. by rewrite big_flatten /= big_map. Qed.

Lemma size_cocode_rec m s c : size (cocode_rec m c s) = m + size c.
Proof using. by elim: m => [| m IHm] //= in s c *; rewrite IHm /= addSnnS. Qed.

Lemma size_cocode s : size (cocode s) = n.
Proof using. by rewrite size_cocode_rec addn0. Qed.

(** ** Partial codes *)
Section PartCode.

Let is_partcode m c :=
  forall i, i < size c -> nth 0 c i <= i + m.
Let word_of_partcocode m c : seq nat :=
  flatten [seq rev (iota (m + i - nth 0 c i) (nth 0 c i)) |
           i <- iota 0 (size c)].

Lemma perm_on_cocode_recP m c s0 s :
  m <= n ->
  is_partcode m c ->
  s0 = s * 's_[word_of_partcocode m c] ->
  perm_on [set k : 'I_n | k < m] s ->
  let cf := cocode_rec m c s in cf \is a code /\ s0 = 's_[wordcd cf].
Proof using.
move=> Hm Hcode -> {s0}.
elim: m => [| m IHm] in c s Hm Hcode * => Hon /=.
  split; first by apply/is_codeP => i; rewrite -{3}(addn0 i); apply Hcode.
  suff -> : s = 1 by rewrite mul1g.
  apply permP => i; rewrite perm1.
  by apply: (out_perm Hon); rewrite inE.
pose mo := Ordinal Hm.
have -> : inord m = mo by apply val_inj; rewrite /= inordK.
have : mo \in [set k : 'I_n | k < m.+1] by rewrite inE.
rewrite -(perm_closed _ Hon) inE ltnS => Hsm.
move/(_ _ _ (ltnW Hm)): IHm => Hrec.
have {Hcode}/Hrec Hrec: is_partcode m (mo - s mo :: c).
  rewrite /is_partcode {Hrec} => [[_ | i]] /=.
    by rewrite add0n; exact: leq_subr.
  by rewrite ltnS addSnnS => /Hcode.
set srec := s * _.
have /Hrec{Hrec} /= : perm_on [set k : 'I_n | k < m] srec.
  rewrite {Hrec} /srec /perm_on; apply/subsetP => k.
  rewrite !inE; apply contraR; rewrite -ltnNge permM ltnS => Hmk.
  apply/eqP; case (leqP k m) => Hkm.
  + have -> : k = mo by apply val_inj; apply/eqP; rewrite /= eqn_leq Hmk Hkm.
    exact: cycleij_j.
  + have -> : s k = k by apply (out_perm Hon); rewrite inE -ltnNge.
    rewrite cycleij_gt // -ltnNge.
move=> [Hcode <-]; split; first exact: Hcode.
rewrite {Hcode}/srec -mulgA; congr (s * _).
rewrite /word_of_partcocode /= addn0 (subKn Hsm) big_cat /=.
rewrite mulgA prodsK mul1g; apply congr_big => //; congr flatten.
rewrite -(addn0 1%N) iotaDl -map_comp.
apply eq_map => i /=.
by rewrite addnA addn1.
Qed.

End PartCode.

Lemma perm_on_prods c m :
  c \is a code -> m <= size c -> m <= n ->
  perm_on [set k : 'I_n | k < m]
          (\prod_(i <- iota 0 m) 's_[(rev (iota (i - nth 0 c i) (nth 0 c i)))]).
Proof using.
move=> /is_codeP Hc Hmsz Hm.
rewrite big_seq; apply big_rec => [| i s]; first exact: perm_on1.
rewrite mem_iota /= add0n => Him /(perm_onM _); apply => {s}.
rewrite big_seq; apply big_rec => [| j s]; first exact: perm_on1.
rewrite mem_rev mem_iota /= => /andP [_].
move/(_ _ (leq_trans Him Hmsz)): Hc => /subnK -> Hji /(perm_onM _); apply => {s}.
have Hj1m := leq_ltn_trans Hji Him.
have Hjm := ltn_trans Hji Him.
rewrite /perm_on; apply/subsetP => u; rewrite inE unfold_in.
apply contraR; rewrite -leqNgt => Hu; apply/eqP/tpermD.
- apply/negP => /eqP/(congr1 nat_of_ord).
  rewrite (inordK (leq_trans Hjm Hm)) => Hju.
  by have:= leq_trans Hjm Hu; rewrite Hju ltnn.
- apply/negP => /eqP/(congr1 nat_of_ord).
  rewrite (inordK (leq_trans Hj1m Hm)) => Hju.
  by have:= leq_trans Hj1m Hu; rewrite Hju ltnn.
Qed.

Lemma perm_on_prods_length_ord s i (m : 'I_n) :
  i <= m -> perm_on [set k : 'I_n | k < m] s ->
  length (s * 's_[rev (iota (m - i) i)]) = length s + i.
Proof using.
elim: i s => [/= | i IHi] /= s Hm Hon; first by rewrite /= big_nil mulg1 addn0.
rewrite rev_cons -cats1 big_cat /= {1}subnS prednK; last by rewrite subn_gt0.
rewrite big_seq1 mulgA.
have H : m - i.+1 < n0.
  rewrite -ltnS subnSK //; apply: (leq_trans _ (ltn_ord m)).
  by rewrite ltnS; exact: leq_subr.
have:= H; rewrite -ltnS => /ltnW Ho.
have -> : (m - i.+1) = Ordinal Ho by [].
rewrite length_add1R.
- by rewrite (IHi _ (ltnW Hm) Hon) addnS.
- by [].
- have -> : Ordinal Ho = inord (m - i.+1) by apply val_inj => /=; rewrite inordK.
  rewrite invMg !permM inordK // {IHi}.
  rewrite !subnS prednK; last by rewrite subn_gt0.
  rewrite {H Ho} prodsV invgK (prods_iota_mi (ltnW Hm)).
  have : m \notin [set k : 'I_n | k < m] by rewrite inE ltnn.
  move/(out_perm (perm_onV Hon)) ->.
  rewrite prods_iota_ltmi; first last.
    rewrite inordK; first by move: Hm; rewrite -subn_gt0; case: (m - i).
    apply: (leq_trans (leq_pred _)).
    by apply: (leq_trans (leq_subr _ _)); rewrite -ltnS.
  have:= perm_closed (inord (m - i).-1) (perm_onV Hon).
  rewrite !inE => -> /=; rewrite inordK.
  - rewrite prednK; last by rewrite subn_gt0.
    exact: leq_subr.
  - rewrite prednK; last by rewrite subn_gt0.
    by apply: (leq_trans (leq_subr _ _)); exact: ltnW.
Qed.

Lemma perm_on_prods_length s i m :
  m < n -> i <= m -> perm_on [set k : 'I_n | k < m] s ->
  length (s * 's_[(rev (iota (m - i) i))]) = length s + i.
Proof using.
move=> Hm; have -> : m = Ordinal Hm by [].
exact: perm_on_prods_length_ord.
Qed.

Lemma length_permcd c :
  c \is a code -> size c <= n -> length 's_[wordcd c] = sumn c.
Proof using.
rewrite wordcdE => Hcode.
have:= Hcode => /is_codeP Hcd Hsz.
rewrite (sumn_nth_le (n := size c)) // /index_iota subn0.
have [n] := ubnPgeq (size c); elim: n => [/= |m IHm] Hm.
  by rewrite !big_nil length1.
rewrite -(addn1 m) iotaD !big_cat /= add0n !big_seq1.
rewrite perm_on_prods_length /=; first by rewrite (IHm (ltnW Hm)).
- exact: leq_trans Hm Hsz.
- by apply Hcd.
- rewrite -/(index_iota _ _). apply: (perm_on_prods Hcode (ltnW Hm)).
  by apply ltnW; exact: leq_trans Hm Hsz.
Qed.

Lemma cocode2P s :
  let c := cocode s in c \is a code /\ s = 's_[wordcd c].
Proof using.
rewrite /cocode; apply perm_on_cocode_recP => //.
- by rewrite /= big_nil mulg1.
- by rewrite /perm_on; apply/subsetP => k _; rewrite !inE; exact: ltn_ord.
Qed.

Lemma cocodeP s : cocode s \is a code.
Proof using. by have:= cocode2P s => /= [] []. Qed.

Lemma cocodeE s : s = 's_[wordcd (cocode s)].
Proof using. by have:= cocode2P s => /= [] []. Qed.

(** ** Properties of [canword s]

We show that [canword s] meets it specification : The canonical reduced word
of [s] is indeed a word whose [length] is the size of [s], that is a reduced
word (defined later).
 *)

Lemma canwordE s :
  [seq (i : nat) | i : 'I_n0 <- canword s] = wordcd (cocode s).
Proof using. by apply (insub_wordcdK (cocodeP _)); rewrite size_cocode. Qed.

Theorem canwordP s : 's_[canword s] = s.
Proof using.
rewrite /= {2}(cocodeE s).
rewrite -(big_map nat_of_ord xpredT) /=; apply congr_big => //.
by rewrite canwordE.
Qed.

(** As a consequence ['SG_n] is generated by the elementary transpositions *)
Corollary eltr_genSn : 'SG_n = <<[set 's_(i : 'I_n0) | i in 'I_n0]>>%G.
Proof.
apply/setP => s; apply/idP/gen_prodgP => /=.
- move=> Hs; exists (size (canword s)).
  exists (fun i => 's_(tnth (in_tuple (canword s)) i)).
  + by move=> i; apply: imset_f.
  + rewrite -{1}(canwordP s).
    by rewrite -{1}[canword s]/(tval (in_tuple (canword s))) big_tuple.
- move=> [l [fi Hfi] ->{s}]; apply group_prod => i _.
  by rewrite inE.
Qed.

(** The corresponding induction theorem *)
Theorem eltr_ind (P : 'S_n -> Type) :
  P 1 -> (forall s i, i < n0 -> P s -> P ('s_i * s)) ->
  forall s, P s.
Proof using.
move=> H1 IH s; rewrite -(canwordP s).
elim: (canword s)  => [| t0 t IHt] /=; first by rewrite big_nil.
by rewrite big_cons; apply IH; first exact: ltn_ord.
Qed.

Corollary morph_eltr (gT : finGroupType)
          (f g : {morphism 'SG_n >-> gT}) :
  (forall i : 'I_n0, f 's_i = g 's_i) -> f =1 g.
Proof.
move=> Heq; elim/eltr_ind => [| s i lt_i_n0]; first by rewrite !morph1.
by rewrite !morphM ?inE // (Heq (Ordinal lt_i_n0)) => ->.
Qed.

(** A simple application *)
Lemma odd_size_permE ts :
  all (gtn n0) ts -> odd (size ts) = odd_perm 's_[ts].
Proof using.
elim: ts => [_ | t0 t IHt] /=; first by rewrite big_nil odd_perm1.
move=> /andP [Ht0 /IHt{IHt} ->].
by rewrite big_cons odd_mul_tperm (inordi_neq_i1 Ht0) addTb.
Qed.

(** ** Various properties of the length *)
Lemma sumn_cocode s : sumn (cocode s) = length s.
Proof.
have /= := cocode2P s => [] [Hcode {2}->].
by rewrite -length_permcd // size_cocode.
Qed.
Theorem size_canword s : size (canword s) = length s.
Proof using.
by rewrite -(size_map val) canwordE size_wordcd sumn_cocode.
Qed.

Corollary length_eq0 s : length s = 0 -> s = 1.
Proof.
rewrite -size_canword -{2}(canwordP s) => /eqP/nilP ->.
exact: big_nil.
Qed.

Corollary length_eq1 s : length s = 1%N -> exists i : 'I_n0, s = 's_i.
Proof.
rewrite -size_canword -{2}(canwordP s).
case: (canword s) => [|i[|j]] // _.
by exists i; rewrite big_seq1.
Qed.

Corollary lengthM s t : length (s * t) <= length s + length t.
Proof.
rewrite -(size_canword s) -(size_canword t) -size_cat.
have -> : s * t = 's_[canword s ++ canword t] by rewrite big_cat /= !canwordP.
exact: length_prods.
Qed.

Corollary lengthME s t :
  length s + length t <= length (s * t) -> length (s * t) = length s + length t.
Proof. by move=> H; apply anti_leq; rewrite H lengthM. Qed.

Corollary lengthKR s t u :
  length (s * t * u) = length s + length t + length u ->
  length (t * u) = length t + length u.
Proof.
move=> Hstu.
apply: lengthME; rewrite leqNgt; apply/negP => Habs.
have:= lengthM s (t * u).
rewrite mulgA Hstu -addnA leq_add2l => /(leq_trans Habs).
by rewrite ltnn.
Qed.

Corollary lengthKL s t u :
  length (s * t * u) = length s + length t + length u ->
  length (s * t) = length s + length t.
Proof.
move=> Hstu.
apply: lengthME; rewrite leqNgt; apply/negP => Habs.
have:= lengthM (s * t) u.
rewrite Hstu leq_add2r => /(leq_trans Habs).
by rewrite ltnn.
Qed.

Lemma card_Delta : #|@Delta n0| = 'C(n, 2).
Proof.
rewrite /Delta -card_ltn_sorted_tuples.
have /card_imset <- : injective (fun p : 'II_n => [tuple p.1; p.2]).
  by move=> [i1 i2] [j1 j2] [-> ->].
congr #|pred_of_set _|; apply/setP => [[[| s0 [| s1 [|s]]]]] // Hs.
rewrite inE /=; apply/imsetP/idP => /= [[[i j]] |]; rewrite andbT.
- by rewrite inE /= => Hij [-> ->].
- move=> Hsort; exists (s0, s1); first by rewrite inE.
  exact: val_inj.
Qed.

Lemma length_max s : length s <= 'C(n, 2).
Proof.
by rewrite /length -card_Delta; apply: subset_leq_card (invset_Delta s).
Qed.

Definition maxperm : 'S_n := perm (@rev_ord_inj n).

Lemma maxpermK : involutive maxperm.
Proof. by move=> i; rewrite !permE rev_ordK. Qed.
Lemma maxpermV : maxperm^-1 = maxperm.
Proof. exact/eqP/permKP/maxpermK. Qed.

Lemma invset_maxperm : invset maxperm = Delta.
Proof.
apply/setP => /= [[i j]]; rewrite /Delta !inE /= !permE.
case: ltnP => //= Hij; apply ltn_sub2l.
- by apply (leq_trans Hij); rewrite -ltnS.
- by rewrite ltnS.
Qed.

Lemma length_maxperm : length maxperm = 'C(n, 2).
Proof. by rewrite /length invset_maxperm card_Delta. Qed.
Lemma length_maxpermE s : length s = 'C(n, 2) -> s = maxperm.
Proof.
move=> Hlen; apply/invset_inj/eqP.
rewrite eqEcard -!/(length _) Hlen length_maxperm leqnn andbT.
by rewrite invset_maxperm invset_Delta.
Qed.

Lemma invset_maxpermMr s : invset (s * maxperm) = Delta :\: invset s.
Proof.
rewrite /invset -setP => /= [[i j]].
rewrite /Delta !inE /= !permM ![maxperm _]permE.
case: (ltnP i j) => //= iltj; rewrite andbT -leqNgt.
rewrite [RHS]leq_eqVlt (inj_eq val_inj) (inj_eq perm_inj).
rewrite -[i == j](inj_eq val_inj) (ltn_eqF iltj) /=.
apply/idP/idP => [| siltsj].
- apply contraLR; rewrite -!leqNgt => H.
  by apply leq_sub2l; rewrite ltnS.
- apply ltn_sub2l => //; rewrite ltnS.
  by apply (leq_trans siltsj); rewrite -ltnS.
Qed.
Lemma invset_maxpermMl s :
  invset (maxperm * s) =
  Delta :\: [set (maxperm p.2, maxperm p.1) | p in invset s].
Proof.
rewrite /invset -setP => /=[[i j]]; rewrite !inE /= [RHS]andbC.
case: ltnP => //= iltj; rewrite !permM.
apply/idP/idP => [Hsm|].
- apply/imsetP => /=[] [[k l]].
  rewrite inE /= => /andP [kltl slltsk] [Hi Hj]; subst i; subst j.
  move: Hsm; rewrite !maxpermK => /(ltn_trans slltsk).
  by rewrite ltnn.
- move/imsetP => /= H; rewrite ltnNge; apply/negP.
  rewrite leq_eqVlt (inj_eq val_inj) !(inj_eq perm_inj).
  rewrite -[i == j](inj_eq val_inj) (ltn_eqF iltj) /= => Hsm.
  apply: H; exists (maxperm j, maxperm i); rewrite ?inE /= ?maxpermK //.
  rewrite {}Hsm andbT !permE /=.
  apply ltn_sub2l => //; rewrite ltnS.
  by apply (leq_trans iltj); rewrite -ltnS.
Qed.

Lemma length_maxpermMr s : length (s * maxperm) = 'C(n, 2) - length s.
Proof.
rewrite /length invset_maxpermMr cardsD card_Delta.
by have /setIidPr -> := invset_Delta s.
Qed.
Lemma length_maxpermMl s : length (maxperm * s) = 'C(n, 2) - length s.
Proof. by rewrite -lengthV invMg maxpermV length_maxpermMr lengthV. Qed.

Definition prods_codesz (c : codesz n) : 'S_n := 's_[wordcd c].

Lemma prods_codesz_bij : bijective prods_codesz.
Proof using.
apply inj_card_bij; last by rewrite card_codesz card_Sn.
move=> c1 c2 Heq.
suff /image_injP Hinj :
  #|image prods_codesz {:codesz n}| == #|{:codesz n}| by exact: (Hinj c1 c2).
rewrite {c1 c2 Heq} card_codesz (eq_card (B := 'S_n)) ?card_Sn //.
move=> s; rewrite !inE; apply/mapP.
have Hcode : is_code_of_size n (cocode s).
  by rewrite /is_code_of_size cocodeP size_cocode /=.
exists (CodeSZ Hcode); first by rewrite enumT.
by rewrite /prods_codesz /= -cocodeE.
Qed.

Lemma prods_wordcd_inj c1 c2 :
  c1 \is a code -> c2 \is a code -> size c1 = n -> size c2 = n ->
  's_[wordcd c1] = 's_[wordcd c2] -> c1 = c2.
Proof using.
move=> Hc1 Hc2 Hsz1 Hsz2.
have HC1 : is_code_of_size n c1 by rewrite /is_code_of_size Hc1 Hsz1 /=.
have HC2 : is_code_of_size n c2 by rewrite /is_code_of_size Hc2 Hsz2 /=.
by move/((bij_inj prods_codesz_bij) (CodeSZ HC1) (CodeSZ HC2))/(congr1 val).
Qed.

End Length.
Arguments length  {n0}.
Arguments maxperm {n0}.

#[export] Hint Resolve cocodeP : core.
#[export] Hint Resolve codeszP : core.

(** * Let's do some real combinatorics !!!

The generating polynomial for permutation counted by their length.
 *)

Section Combi.

Import GRing.Theory.
Open Scope ring_scope.

Corollary genfun_length n :
  \sum_(s in 'S_n.+1) 'X^(length s) =
  \prod_(0 <= i < n.+1) \sum_(0 <= j < i.+1) 'X^j : {poly int}.
Proof.
rewrite (reindex _ (onW_bij _ (prods_codesz_bij n))) /=.
under eq_bigr => i _ do
  rewrite (length_permcd (codeszP _)) // ?size_codesz //.
rewrite /prods_codesz -big_enum /=.
rewrite -(big_map (@cdval _) xpredT (fun i : seq nat => 'X^(sumn i))).
elim: n => [/= | n].
  by rewrite enum_codeszE /index_iota !big_seq1 /= addn0.
move: (n.+1) => {}n. (* Workaround of shifting of n *)
rewrite /index_iota !enum_codeszE big_flatten big_map -/enum_codesz.
rewrite !subn0 -{2}addn1 iotaD add0n [iota 0 n.+1]lock /=.
rewrite big_cat /= big_seq1 {2}[(0 :: iota 1 n)%N]lock /= => <-.
rewrite big_distrr /=; apply eq_bigr => i _.
rewrite big_distrl /= big_map; apply eq_bigr => j _.
by rewrite -sumn_rev rev_rcons /= sumn_rev exprD mulrC.
Qed.

End Combi.

(** * Reduced words *)
Section Reduced.

Variable n : nat.
Implicit Type w : seq 'I_n.

Notation "''s_' i" := (eltr n i).
Notation "''s_' [ w ]" := (\prod_(i <- w) 's_i).

Definition reduced_word := [qualify w : seq 'I_n | length 's_[w] == size w ].
Notation reduced := reduced_word.

Lemma reducedP w : reflect (length 's_[w] = size w) (w \is reduced).
Proof. by rewrite unfold_in; apply/eqP. Qed.

Lemma reduced_nil : [::] \is reduced.
Proof using. by rewrite unfold_in big_nil length1. Qed.

Hint Resolve reduced_nil : core.

Lemma reduced_iiF i : [:: i; i] \is reduced = false.
Proof using. by rewrite unfold_in /= big_cons big_seq1 eltr2 length1. Qed.

Lemma reduced_rev w : w \is reduced -> rev w \is reduced.
Proof using.
rewrite !unfold_in size_rev => /eqP <-.
by rewrite -lengthV -!(big_map nat_of_ord xpredT) -prodsV map_rev revK.
Qed.

Lemma reduced_revE w : (w \is reduced) = (rev w \is reduced).
Proof using.
apply/idP/idP; first exact: reduced_rev.
by move/reduced_rev; rewrite revK.
Qed.

Lemma reduced_sprod_code c :
  c \is a code -> size c <= n.+1 -> pmap insub (wordcd c) \is reduced.
Proof using.
move=> Hcode Hsz; apply/reducedP.
have:= Hsz => /(length_permcd Hcode) Hlength.
rewrite -(big_map nat_of_ord xpredT) /=.
by rewrite -(size_map val) /= insub_wordcdK // Hlength size_wordcd.
Qed.

(** ** [canword s] is reduced *)
Theorem canword_reduced s : canword s \is reduced.
Proof using.
by apply: (reduced_sprod_code (cocodeP _)); rewrite size_cocode.
Qed.

Lemma reduced_catr u v : u ++ v \is reduced -> v \is reduced.
Proof using.
rewrite !unfold_in size_cat => /eqP H.
have {H} Huv : length 's_[u] + length 's_[v] = size u + size v.
  apply/eqP; rewrite eqn_leq (leq_add (length_prods u) (length_prods v)) /=.
  by have:= lengthM 's_[u] 's_[v]; rewrite -big_cat /= H => ->.
by have:= leq_addE (length_prods u) (length_prods v) Huv => [] [_ ->].
Qed.

Lemma reduced_catl u v : u ++ v \is reduced -> u \is reduced.
Proof using.
move/reduced_rev; rewrite rev_cat => /reduced_catr.
by rewrite -reduced_revE.
Qed.

Lemma reduced_consK i u : i :: u \is reduced -> u \is reduced.
Proof using. by rewrite -cat1s; exact: reduced_catr. Qed.

Lemma reduced_rconsK u i : rcons u i \is reduced -> u \is reduced.
Proof using. by rewrite -cats1; exact: reduced_catl. Qed.

Lemma reducedM (s t : 'S_(n.+1)) :
  length (s * t) = length s + length t -> canword s ++ canword t \is reduced.
Proof.
rewrite unfold_in big_cat /= size_cat -!size_canword => <-.
by rewrite !canwordP.
Qed.

Lemma canword1 : canword (1 : 'S_n.+1) = [::].
Proof using.
have:= canword_reduced 1.
by rewrite unfold_in canwordP length1 eq_sym => /nilP.
Qed.

(** * Braid monoid relations *)
Definition braid_aba :=
  fun s : seq 'I_n => match s with
             | [:: a; b; c] => if (a == c) && ((a.+1 == b) || (b.+1 == a))
                               then [:: [:: b; a; b]] else [::]
             | _ => [::]
           end.

Definition braidC :=
  fun s : seq 'I_n => match s with
             | [:: a; b] => if (a.+1 < b) || (b.+1 < a)
                            then [:: [:: b; a]] else [::]
             | _ => [::]
           end.

Definition braidrule := [fun s => braid_aba s ++ braidC s].

Lemma braid_abaP (u v : seq 'I_n) :
  reflect (exists a b : 'I_n,
              [/\ ((a.+1 == b) || (b.+1 == a)),
               u = [:: a; b; a] & v = [:: b; a; b] ] )
          (v \in braid_aba u).
Proof using.
rewrite /braid_aba /=; apply: (iffP idP).
- case: u => [//=|u0[//=|u1[//=|u2[]//=]]].
  case H : ((u0 == u2) && ((u0.+1 == u1) || (u1.+1 == u0))).
  + move: H => /andP [/eqP <- Heq].
    rewrite mem_seq1 => /eqP ->.
    by exists u0, u1.
  + by rewrite in_nil.
- by move=> [a] [b] [H -> ->]; rewrite H eq_refl /= inE.
Qed.

Lemma braidCP (u v : seq 'I_n) :
  reflect (exists a b : 'I_n,
             [/\ ((a.+1 < b) || (b.+1 < a)), u = [:: a; b] & v = [:: b; a] ] )
          (v \in braidC u).
Proof using.
rewrite /braidC /=; apply: (iffP idP).
- case: u => [//=|u0[//=|u1[]//=]].
  case H : ((u0.+1 < u1) || (u1.+1 < u0)).
  + rewrite mem_seq1 => /eqP ->.
    by exists u0, u1.
  + by rewrite in_nil.
- by move=> [a] [b] [H -> ->]; rewrite H inE.
Qed.

Lemma braidrule_sym (u v : seq 'I_n) :
  v \in (braidrule u) -> u \in (braidrule v).
Proof using.
rewrite !mem_cat => /orP [] /= Hbr; apply/orP.
- left; move: Hbr => /braid_abaP [a] [b] [Hab -> ->].
  by rewrite /braid_aba eq_refl orbC Hab inE.
- right; move: Hbr => /braidCP [a] [b] [Hab -> ->].
  by rewrite /braidC orbC Hab inE.
Qed.

Lemma braidrule_homog (u : seq 'I_n) :
  all [pred v | size v == size u] (braidrule u).
Proof using.
apply/allP => /= v.
by rewrite mem_cat => /orP [/braid_abaP | /braidCP] [a] [b] [_ -> ->].
Qed.

Definition braidcongr := gencongr_hom braidrule_homog.
Definition braidclass := genclass_hom braidrule_homog.

Local Notation "a =Br b" := (braidcongr a b).

Lemma braid_equiv : equivalence_rel braidcongr.
Proof using. by apply: gencongr_equiv; exact: braidrule_sym. Qed.

Lemma braid_refl : reflexive braidcongr.
Proof using.
by have:= braid_equiv; rewrite equivalence_relP => [] [Hrefl Hltr].
Qed.

Lemma braidww w : braidcongr w w.
Proof using. exact: braid_refl. Qed.

Lemma braid_sym : symmetric braidcongr.
Proof using.
have:= braid_equiv; rewrite equivalence_relP => [] [Hrefl Hltr].
by move=> i j; apply/idP/idP => /Hltr <-.
Qed.

Lemma braid_ltrans : left_transitive braidcongr.
Proof using.
by have:= braid_equiv; rewrite equivalence_relP => [] [Hrefl Hltr].
Qed.

Lemma braid_trans : transitive braidcongr.
Proof using.
have:= braid_equiv; rewrite equivalence_relP => [] [Hrefl Hltr].
by move=> i j k => /Hltr <-.
Qed.

Lemma braid_is_congr : congruence_rel braidcongr.
Proof using. by apply: gencongr_is_congr; exact: braidrule_sym. Qed.

Definition braid_cons := congr_cons braid_is_congr.
Definition braid_rcons := congr_rcons braid_is_congr.
Definition braid_catl := congr_catl braid_is_congr.
Definition braid_catr := congr_catr braid_is_congr.
Definition braid_cat := congr_cat braid_is_congr braid_equiv.

Lemma size_braid u v : u =Br v -> size u = size v.
Proof using. by move=> /gencongr_invar /= /eqP ->. Qed.

Lemma braid_rev u v : u =Br v -> rev u =Br rev v.
Proof using.
move: v; apply gencongr_ind; first exact: braid_refl.
move=> a b1 c b2 /braid_ltrans -> {u} Hrule.
rewrite !rev_cat -!catA; apply braid_is_congr; apply rule_gencongr.
move: Hrule; rewrite /braidrule /= !mem_cat => /orP [].
- move/braid_abaP => [x] [y] [Hxy -> ->].
  by rewrite /rev /= eq_refl Hxy /= inE eq_refl.
- move/braidCP => [x] [y] [Hxy -> ->].
  by rewrite /rev /= orbC Hxy mem_seq1 eq_refl.
Qed.

Lemma class_braid1 i s : s =Br [:: i] -> s = [:: i].
Proof.
rewrite braid_sym.
move: s; apply: gencongr_ind => //= a b1 c b2 /(congr1 size) /= Hsize.
by rewrite mem_cat => /orP [/braid_abaP | /braidCP] [x [y]] [_ Hb1 _];
  exfalso; move: Hsize; rewrite Hb1 !size_cat /= !addnS.
Qed.

Theorem braid_prods (v w : seq 'I_n) : v =Br w -> 's_[v] = 's_[w].
Proof using.
move=> H; apply/esym; move: w H; apply gencongr_ind => // a b1 c b2 <- Hrule.
rewrite !big_cat /=; congr (_ * (_ * _)).
move: Hrule; rewrite {a c} /braidrule /= mem_cat => /orP [].
- move/braid_abaP => [x] [y] [Hxy -> ->].
  do 2 (rewrite 2!big_cons big_seq1 mulgA).
  by move: Hxy => /orP [] /eqP Hxy; rewrite -Hxy eltr_braid // Hxy.
- move/braidCP => [x] [y] [Hxy -> ->].
  do 2 (rewrite big_cons big_seq1).
  move: Hxy => /orP [] Hxy.
  + by rewrite [RHS]eltr_comm // Hxy /=.
  + by rewrite [LHS]eltr_comm // Hxy /=.
Qed.

Corollary braid_reduced (v w : seq 'I_n) :
  v =Br w -> v \is reduced -> w \is reduced.
Proof using.
rewrite unfold_in => Hbr.
by rewrite (braid_prods Hbr) (size_braid Hbr).
Qed.

(** ** reducing words for permutation *)
Fixpoint reduces (u v : seq 'I_n) :=
  match u with
    | [::] | [:: _] => false
    | [:: a, b & l] =>
      ((a == b) && (l == v))
        || if v is v0 :: v' then (a == v0) && reduces (b :: l) v'
           else false
  end.

Lemma reducesP (u v : seq 'I_n) :
  reflect
    (exists x i y, u = x ++ [:: i; i] ++ y /\ v = x ++ y)
    (reduces u v).
Proof using.
elim: u v => [| a u IHu] v.
  apply (iffP idP) => /=; first by case v.
  by move=> [x] [i] [y] []; case x.
case: u IHu => [| b l] IHu.
  apply (iffP idP) => /=; first by case v.
  by move=> [x] [i] [y] []; case: x => [| x0 [|x1 x]].
case: v => [| v0 v] /=.
  rewrite orbF; apply (iffP idP).
  - move=> /andP [/eqP Ha /eqP Hl]; subst a l.
    by exists [::], b, [::].
  - move=> [x] [i] [y] []; case: x => [| x0 x] //.
    by case: y => //= [] [-> -> ->]; rewrite eq_refl.
apply (iffP idP).
- move=> /orP [] /andP [/eqP -> {a}].
  + move=> /eqP Hl; subst l.
    by exists [::], b, (v0 :: v).
  + move/IHu => {IHu} [x] [i] [y] [Hbl -> {v}].
    by exists (v0 :: x), i, y => /=; rewrite Hbl.
- move=> [x] [i] [y] []; case: x => [| x0 x] /=.
  + by move=> [-> -> ->] <-; rewrite !eq_refl.
  + move=> [Ha H1] [H0 H2]; subst a v0.
    apply/orP; right; rewrite eq_refl /=.
    by apply/IHu; exists x, i, y.
Qed.

Lemma reduces_catl u v w : reduces u v -> reduces (u ++ w) (v ++ w).
Proof using.
move/reducesP => [x] [i] [y] [-> ->].
by apply/reducesP; exists x, i, (y ++ w); rewrite -!catA.
Qed.

Lemma prods_reducesE u v : reduces u v -> 's_[u] = 's_[v].
Proof using.
move/reducesP => [x] [i] [y] [-> {u} -> {v}].
by rewrite !big_cat big_cons !big_seq1 /= eltr2 mul1g.
Qed.

Definition braid_reduces (u v : seq 'I_n) := (u =Br v) || (reduces u v).

Lemma braidred_catl (u v w : seq 'I_n) :
  braid_reduces u v -> braid_reduces (u ++ w) (v ++ w).
Proof using.
rewrite /braid_reduces => /orP [/braid_catl -> // |] /reduces_catl ->.
by rewrite orbT.
Qed.

Lemma braidredE u v : braid_reduces u v -> 's_[u] = 's_[v].
Proof using. by move=> /orP []; [apply braid_prods|apply prods_reducesE]. Qed.

End Reduced.
Arguments reducedP {n w}.

Notation reduced := (reduced_word _).
Notation braidred := (@braid_reduces _).

#[export] Hint Resolve braidww : core.

(** ** The cocode insertion algorithm *)
Section CanWord.

Variable (n0 : nat).
Local Notation n := n0.+1.
Local Notation "''s_' i" := (eltr n i) : group_scope.
Local Notation "''s_' [ w ]" := (\prod_(i <- w) 's_i).
Local Notation "a =Br b" := (braidcongr a b).

Fixpoint inscode (c : seq nat) (i : 'I_n) :=
  if c is c0 :: c' then
    let m := size c' in
    if i > m - c0 then c0 :: inscode c' (inord i.-1)
    else if i == m - c0 :> nat then c0.-1 :: c'
    else if i.+1 == m - c0 :> nat then c0.+1 :: c'
    else c0 :: inscode c' i
  else [::].

Lemma size_inscode c i : size (inscode c i) = size c.
Proof using.
elim: c i => [| c0 c IHc] //= i.
case: ltnP => _ /=; first by rewrite IHc.
case: eqP => _ //=.
by case: eqP => _ //=; rewrite IHc.
Qed.

Lemma head_revcode c0 c : rev (c0 :: c) \is a code -> c0 <= size c.
Proof using.
have H : size c < size (rev (c0 :: c)) by rewrite size_rev /= ltnS.
move=> /is_codeP/(_ _ H).
by rewrite rev_cons nth_rcons size_rev ltnn eq_refl.
Qed.

Lemma inord_predS (i : 'I_n) a b :
  a < i -> i < b -> (inord (n' := n0) i.-1).+1 < b.
Proof using.
move=> Ha Hb; rewrite inordK; last by apply (leq_ltn_trans (leq_pred _)).
by rewrite (ltn_predK Ha).
Qed.

Lemma inscodeP c (i : 'I_n) :
  rev c \is a code -> i.+1 < size c -> rev (inscode c i) \is a code.
Proof using.
elim: c i => [//= | c0 c IHc] i /= => Hcode.
have:= Hcode; rewrite rev_cons => /is_code_rconsK Hcd.
move/(_ _ Hcd): IHc => Hrec.
have /head_revcode := Hcode => Hc0.
move/is_codeP : Hcode; rewrite size_rev /= => Hcode.
rewrite !ltnS => Hisz.
case: ltnP => Hi.
  rewrite rev_cons.
  move/(_ _ (inord_predS Hi Hisz)) : Hrec => /= /is_code_rcons; apply.
  by rewrite size_rev size_inscode.
case: eqP => [Hi1 | /eqP Hi1].
  rewrite rev_cons; apply: (is_code_rcons _ Hcd).
  rewrite size_rev; apply (leq_trans (leq_pred _)).
  have := Hcode (size c) (ltnSn (size c)).
  by rewrite rev_cons nth_rcons size_rev ltnn eq_refl.
have {Hi1}Hi : i < size c - c0 by rewrite ltn_neqAle Hi Hi1.
case: eqP => [Hi1 | /eqP Hi1].
  rewrite rev_cons; apply: (is_code_rcons _ Hcd).
  by rewrite size_rev -subn_gt0 -Hi1.
have {Hi1}Hi : i.+1 < size c - c0 by rewrite ltn_neqAle Hi Hi1.
  rewrite rev_cons.
  have /Hrec : i.+1 < size c by apply (leq_trans Hi); exact: leq_subr.
  move/is_code_rcons; apply.
  by rewrite size_rev size_inscode.
Qed.

Let wcord c : seq 'I_n := map inord (wordcd (rev c)).

Lemma wcordE c :
  rev c \is a code -> size c <= n.+1 -> wcord c = pmap insub (wordcd (rev c)).
Proof using.
rewrite /wcord => Hcode; have:= Hcode => /wordcd_ltn/allP.
rewrite size_rev => Hall Hsz.
apply (inj_map (@val_inj _ _ _)) => /=.
rewrite insub_wordcdK //; last by rewrite size_rev.
rewrite -map_comp -[RHS]map_id -eq_in_map => j /Hall /= Hj.
rewrite inordK //.
by case: (size c) Hj Hsz => [//= | sz] /=; exact: leq_trans.
Qed.

Lemma reduced_wcord c :
  rev c \is a code -> size c <= n.+1 -> wcord c \is reduced.
Proof using.
move=> Hc Hsz; rewrite wcordE //.
by apply reduced_sprod_code; last by rewrite size_rev.
Qed.

Lemma wcord_cons c i :
  wcord (i :: c) = wcord c ++ map inord (rev (iota (size c - i) i)).
Proof using.
rewrite /wcord /wordcd -map_cat; congr (map _ _).
rewrite size_rev [size (_ :: _)]/= -(addn1 (size c)) iotaD.
rewrite !map_cat !flatten_cat /= cats0 !add0n !rev_cons.
rewrite nth_rcons size_rev ltnn eq_refl.
congr ((flatten _) ++ _); apply eq_in_map => j.
by rewrite mem_iota /= add0n nth_rcons size_rev => ->.
Qed.

Lemma ltn_braidC (s : seq 'I_n) (i : 'I_n) :
  (forall u, u \in s -> u.+1 < i) -> [:: i] ++ s =Br s ++ [:: i].
Proof using.
rewrite cat1s cats1.
move=> Hs; elim: s => [| s0 s IHs] //= in Hs *.
apply (braid_trans (y := [:: s0, i & s])).
- rewrite -[[:: i, s0 & s]]/([:: i; s0] ++ s) -[[:: s0, i & s]]/([:: s0; i] ++ s).
  apply braid_catl; apply rule_gencongr => /=.
  have /Hs -> : s0 \in s0 :: s by rewrite inE eq_refl.
  by rewrite orbT mem_seq1 eq_refl.
rewrite -[s0 :: _]cat1s -[s0 :: rcons _ _]cat1s.
by apply braid_catr; apply IHs => u Hu; apply Hs; rewrite inE Hu orbT.
Qed.

Lemma gtn_braidC (s : seq 'I_n) (i : 'I_n) :
  (forall u, u \in s -> i.+1 < u) -> [:: i] ++ s =Br s ++ [:: i].
Proof using.
rewrite cat1s cats1.
move=> Hs; elim: s => [| s0 s IHs] //= in Hs *.
apply (braid_trans (y := [:: s0, i & s])).
- rewrite -[[:: i, s0 & s]]/([:: i; s0] ++ s) -[[:: s0, i & s]]/([:: s0; i] ++ s).
  apply braid_catl; apply rule_gencongr => /=.
  have /Hs -> : s0 \in s0 :: s by rewrite inE eq_refl.
  by rewrite orTb mem_seq1 eq_refl.
- rewrite -[s0 :: _]cat1s -[s0 :: rcons _ _]cat1s.
  by apply braid_catr; apply IHs => u Hu; apply Hs; rewrite inE Hu orbT.
Qed.

Lemma iota_cut_i (l b : nat) (i : 'I_n) :
  l <= b -> b - l < i -> i < b -> iota (b - l) l =
  (iota (b - l) (i.-1 - (b - l))) ++ [:: i.-1; i : nat] ++ (iota i.+1 (b - i.+1)).
Proof using.
move=> Hbl Hi1 Hi2.
have Hbli : b - l <= i.-1 by rewrite -ltnS (ltn_predK Hi1).
have -> : [:: i.-1; i : nat] = iota i.-1 2 by rewrite /= (ltn_predK Hi1).
rewrite -{2}(subnKC Hbli) catA -iotaD.
rewrite -addSnnS addn1 -subSn // (ltn_predK Hi1) -subSn; last by apply ltnW.
have Hbli1 := leq_trans (ltnW Hi1) (leqnSn _).
rewrite -{2}(subnKC Hbli1) -iotaD addnC (addnBA _ Hbli1).
by rewrite (subnK Hi2) (subKn Hbl).
Qed.

Local Notation "''I[' a '..' b ']'" :=
  [seq inord i | i <- rev (iota (b - a) a)].

Lemma braid_pred_lineC (i : 'I_n) (sz c : nat) :
  sz <= n -> i < sz -> c <= sz -> sz - c < i ->
  ([:: inord i.-1] ++ 'I[c .. sz]) =Br ('I[c .. sz] ++ [:: i]).
Proof using.
rewrite /= cats1 => Hsz Hisz Hc0 Hi.
rewrite (iota_cut_i Hc0 Hi Hisz) !rev_cat !map_cat -cats1 -!catA.
set A := map _ _; rewrite {1 3}/rev [map _ _]/= inord_val; set B := map _ _.
apply (braid_trans (y := A ++ [:: i; inord i.-1] ++ (i :: B))); first last.
  do 2 apply braid_catr; rewrite -cat1s; apply ltn_braidC => u.
  rewrite {}/B {A} => /mapP [x].
  rewrite mem_rev mem_iota => /andP [_].
  case: i Hisz Hi (inord_predS Hi Hisz) => [[| i] Hi] //= Hisz.
  rewrite !ltnS => /subnKC -> Hszi Hx ->.
  by rewrite inordK //; apply (ltn_trans Hx); apply ltnW.
rewrite -[i :: B]cat1s -cat1s !catA; apply: braid_catl => {B}.
apply (braid_trans (y := A ++ [:: inord i.-1; i; inord i.-1])); first last.
  rewrite -catA /=; apply braid_catr; apply rule_gencongr => /=.
  rewrite eq_refl /=.
  suff -> : (inord (n' := n0) i.-1).+1 = i by rewrite eq_refl /= mem_seq1 eq_refl.
  rewrite inordK; last by apply (leq_ltn_trans (leq_pred _)).
  by rewrite (ltn_predK Hi).
rewrite -[inord i.-1 :: i :: _]cat1s catA; apply braid_catl.
rewrite /A; case: (ltnP i sz) => Hi'.
  apply gtn_braidC => u.
  rewrite {}/A => /mapP [x].
  rewrite mem_rev mem_iota => /andP [Hix Hx] -> {u} /=.
  rewrite subnKC // in Hx.
  rewrite inordK; last by apply (leq_ltn_trans (leq_pred _)).
  rewrite (ltn_predK Hi).
  by rewrite inordK; last apply: (leq_trans Hx).
move: Hi'; rewrite -ltnS => /ltnW.
by rewrite /leq => /eqP ->.
Qed.

Lemma braid_ltn_lineC (i : 'I_n) (sz c : nat) :
  sz <= n -> i.+1 < sz - c -> c <= sz ->
  [:: i] ++ 'I[c .. sz] =Br 'I[c .. sz] ++ [:: i].
Proof using.
move=> Hsz Hi Hc0; apply gtn_braidC => u /mapP [ x].
rewrite mem_rev mem_iota => /andP [Hix Hx] -> {u} /=.
rewrite subnK // in Hx.
rewrite inordK; last by apply (leq_trans Hx).
exact: (leq_trans Hi).
Qed.

Implicit Type (u v w : seq 'I_n).

Lemma path_braidred_catl p u w :
  path braidred u p -> path braidred (u ++ w) [seq v ++ w | v <- p].
Proof using.
elim: p u => [//= | p0 p IHp] u /= /andP [Hbr /IHp ->].
by rewrite braidred_catl.
Qed.

Lemma braidred_inscode_path c (i : 'I_n) :
  rev c \is a code -> size c <= n.+1 -> i.+1 < size c ->
  { p | path braidred ((wcord c) ++ [:: i]) p /\
        last ((wcord c) ++ [:: i]) p = wcord (inscode c i) }.
Proof using.
elim: c i => [//= | c0 c IHc] i /= Hcode.
have:= Hcode; rewrite rev_cons => /is_code_rconsK /IHc{IHc} Hrec.
move/head_revcode : Hcode => Hc0.
rewrite !ltnS wcord_cons -catA => Hsz Hisz.
case: ltnP => Hi.
  have:= Hsz; rewrite -ltnS => /ltnW/(Hrec _)/(_ (inord_predS Hi Hisz)){Hrec} /=.
  rewrite !wcord_cons -cat1s size_inscode cats0.
  move=> [pth] [Hpath <-].
  exists ((wcord c ++ [:: inord i.-1] ++ 'I[c0 .. (size c)]) ::
          [seq v ++ 'I[c0 .. (size c)] | v <- pth]); split => [| {Hpath}].
  - have /= := path_braidred_catl 'I[c0 .. (size c)] Hpath.
    rewrite -catA /= => ->; rewrite andbT.
    rewrite /braidred braid_catr // braid_sym.
    exact: braid_pred_lineC.
  - rewrite !catA; case: pth => [| p0 p] //=.
    exact: last_map.
case: eqP => [{Hrec}Hi | /eqP Hi1].
  case: c0 Hc0 Hi Hisz => [Hc0 | c0 Hc0 Hi Hisz /=].
    by rewrite subn0 => ->; rewrite ltnn.
  rewrite -{1 3}Hi /= subnS prednK ?subn_gt0 //.
  rewrite rev_cons map_rcons inord_val -!cats1 -catA.
  exists [:: wcord (c0 :: c)]; split; last by [].
  rewrite /= andbT; rewrite /braidred; apply/orP; right.
  apply/reducesP; exists (wcord c ++ 'I[c0 .. (size c)]), i, [::].
  rewrite !cats0 -catA; split; first by [].
  exact: wcord_cons.
have {Hi1}Hi : i < size c - c0 by rewrite ltn_neqAle Hi Hi1.
case: eqP => [Hi1 | /eqP Hi1].
  exists [::]; split; first by [].
  by rewrite /= wcord_cons rev_cons map_rcons subnS -Hi1 /= inord_val cats1.
have {Hi1}Hi : i.+1 < size c - c0 by rewrite ltn_neqAle Hi Hi1.
  have:= Hsz.
  rewrite -ltnS => /ltnW/(Hrec _)/(_ (leq_trans Hi (leq_subr _ _))) {Hrec} /=.
  rewrite wcord_cons size_inscode.
  move=> [pth] [Hpath <-].
  exists ((wcord c ++ [:: i] ++ 'I[c0 .. (size c)]) ::
          [seq v ++ 'I[c0 .. (size c)] | v <- pth]); split => [| {Hpath}].
  - have /= := path_braidred_catl 'I[c0 .. (size c)] Hpath.
    rewrite -catA /= => ->; rewrite andbT.
    rewrite /braidred braid_catr // braid_sym.
    exact: braid_ltn_lineC.
  - rewrite !catA; case: pth => [| p0 p] //=.
    exact: last_map.
Qed.

(** ** Straigthening a word *)
Fixpoint straighten_rev w :=
  if w is w0 :: w then inscode (straighten_rev w) w0 else (nseq n.+1 0).
Definition straighten w := straighten_rev (rev w).

Lemma size_straighten w : size (straighten w) = n.+1.
Proof using.
rewrite /straighten; elim/last_ind: w => [//= | w wn IHw] /=.
  by rewrite size_nseq.
by rewrite rev_rcons /= size_inscode.
Qed.

Lemma is_code_straighten w : rev (straighten w) \is a code.
Proof using.
rewrite /straighten; elim/last_ind: w => [| w wn IHw /=].
  rewrite {2}/rev /=.
  have -> : [:: 0, 0 & nseq n0 0] = nseq n.+1 0 by [].
  apply/is_codeP => i; rewrite size_rev size_nseq ltnS => Hi.
  rewrite nth_rev size_nseq ?ltnS //.
  by rewrite nth_nseq if_same.
rewrite rev_rcons => /=.
apply (inscodeP IHw).
by rewrite size_straighten ltnS.
Qed.

Lemma straighten_path_npos w :
  { p | path braidred w p /\ last w p = wcord (straighten w) }.
Proof using.
rewrite /straighten; elim/last_ind: w => [| w wn].
  exists [::]; split; first by [].
  rewrite [LHS]/=; apply esym; apply/nilP.
  by rewrite /wcord /nilp size_map size_wordcd sumn_rev /= !add0n; elim: n0.
rewrite rev_rcons /= -/(straighten w) -cats1 => [] [prec] [Hpath Hlast].
have : size (straighten w) <= n0.+2 by rewrite size_straighten.
move=> /(braidred_inscode_path (is_code_straighten w)) => Hins.
have : wn.+1 < size (straighten w) by rewrite size_straighten ltnS.
move=> /Hins{Hins} [pins] [Hpathins Hlastins].
exists ([seq v ++ [:: wn] | v <- prec] ++ pins); split => [| {Hpath Hpathins}].
- rewrite cat_path (last_map (fun v => v ++ [:: wn])) Hlast Hpathins andbT.
  exact: path_braidred_catl.
- by rewrite last_cat (last_map (fun v => v ++ [:: wn])) Hlast.
Qed.

Theorem prods_straighten w : 's_[wcord (straighten w)] = 's_[w].
Proof using.
move: (straighten_path_npos w) => [p] [Hpath <-].
elim: p w Hpath => [| p0 p IHp] //= w /andP [/braidredE -> {w}].
exact: IHp.
Qed.

Corollary cocode_straightenE w :
  rev (straighten w) = cocode 's_[w].
Proof using.
have:= (prods_straighten w); rewrite -{1}(canwordP 's_[w]).
rewrite -!(big_map nat_of_ord xpredT) /= canwordE /wcord -map_comp.
rewrite [map _ _](_ : _ = wordcd (rev (straighten w))); first last.
  rewrite -[RHS](map_id) -eq_in_map => i.
  rewrite /= /wordcd => /flatten_mapP [j].
  rewrite mem_rev !mem_iota /= add0n size_rev size_straighten ltnS => Hj.
  move=> /andP [_]; rewrite subnK => [Hij | ].
    by rewrite inordK // (leq_trans Hij Hj).
  have /is_codeP := is_code_straighten w.
  by rewrite size_rev size_straighten; apply; rewrite ltnS.
apply (prods_wordcd_inj (is_code_straighten _) (cocodeP _)).
- by rewrite size_rev size_straighten.
- exact: size_cocode.
Qed.

Corollary canword_straightenE w : wcord (straighten w) = canword 's_[w].
Proof using.
rewrite /canword -cocode_straightenE -(wcordE (is_code_straighten w)) //.
by rewrite size_straighten.
Qed.

Corollary canword_path_npos w :
  { p | path braidred w p /\ last w p = canword 's_[w] }.
Proof using. by rewrite -canword_straightenE; exact: straighten_path_npos. Qed.

End CanWord.

Notation "''s_' i" := (eltr _ i) : group_scope.
Notation "''s_[' w ']'" := (\prod_(i <- w) 's_i) : group_scope.

Local Notation "a =Br b" := (braidcongr a b) : bool_scope.

Theorem braidred_to_canword n (w : seq 'I_n) :
  { p | path braidred w p /\ last w p = canword 's_[w] }.
Proof.
case: (altP (n =P 0)) => Hn.
  subst n; case: w => [| [w0 Hw0] w] //=.
  by rewrite big_nil canword1; exists [::].
move: Hn; case H : {1}(n) => _ //=; subst n.
exact: canword_path_npos.
Qed.

Lemma braidred_size_decr n (w : seq 'I_n) p :
  path braidred w p -> size w >= size (last w p).
Proof.
elim: p w => [| p0 p IHp] //= w /andP [HBr /IHp/leq_trans]; apply.
move: HBr => /orP [ /size_braid -> // |].
move/reducesP => [x] [i] [y] [-> ->].
by rewrite !size_cat [size [:: i; i] + _]addnC addnA; exact: leq_addr.
Qed.

Theorem braid_to_canword n (w : seq 'I_n) :
  w \is reduced -> w =Br canword 's_[w].
Proof.
move/reducedP; rewrite -size_canword braid_sym.
case: (braidred_to_canword w) => p [Hpath <-].
elim: p w Hpath => [| p0 p IHp] //= w /andP [].
rewrite {1}/braidred => /orP [] HBr.
- move/IHp; rewrite (size_braid HBr) => H{}/H /braid_ltrans ->.
  by rewrite braid_sym.
- move=> {IHp} /braidred_size_decr Hsz Heq; exfalso.
  move: Hsz; rewrite {}Heq.
  move/reducesP: HBr => [x] [i] [y] [-> ->].
rewrite !size_cat [size [:: i; i] + _]addnC addnA /=.
by rewrite leqNgt addnS ltnS addn1 leqnSn.
Qed.

Theorem reduceP n (u : seq 'I_n) :
  u \isn't reduced -> exists v w, u =Br v /\ reduces v w.
Proof.
rewrite unfold_in => Hnred.
have {Hnred} : length ((\prod_(i <- u) 's_ i) : 'S_n.+1) < size u.
  by rewrite ltn_neqAle Hnred length_prods.
rewrite -size_canword.
case: (braidred_to_canword u) => p [Hpath <-].
elim: p u Hpath => [| p0 p IHp] u //=; first by rewrite ltnn.
rewrite {1}/braidred => /andP [/orP [] HBr].
- move/IHp; rewrite (size_braid HBr) => H{}/H.
  move=> [v] [w] [/(braid_trans HBr) {HBr} Hred].
  by exists v, w.
- by exists u, p0.
Qed.

Corollary reduced_braid n (v w : seq 'I_n) :
  v \is reduced -> w \is reduced -> ('s_[v] == 's_[w] :> 'S_n.+1) = (v =Br w).
Proof.
move=> Hv Hw; apply/idP/idP => [/eqP H|].
- apply (braid_trans (y := canword 's_[v])).
  + exact: braid_to_canword.
  + rewrite H braid_sym; exact: braid_to_canword.
- by move/braid_prods ->.
Qed.

Lemma canword_eltr n (i : 'I_n) : canword 's_i = [:: i].
Proof.
suff /braid_to_canword : [:: i] \is reduced.
  by rewrite big_seq1 braid_sym => /class_braid1.
apply contraT => /reduceP [/= v [w []]].
rewrite braid_sym => /class_braid1 ->{v}.
move=> /reducesP [v [a [b]]] [] /(congr1 size) /=.
by rewrite size_cat /= !addnS.
Qed.

(** * The presentation of the symmetric groups *)
Section PresentationSn.

Variable n : nat.
Variable gT : finGroupType.
Variable eltrG : nat -> gT.

Local Notation "''g_' i" :=
  (eltrG i) (at level 8, i at level 2, format "''g_' i").

Variant relat_Sn : Prop :=
  RelatSn of
    (forall i, i < n -> 'g_i^+2 = 1) &
    (forall i, i.+1 < n -> 'g_i * 'g_i.+1 * 'g_i = 'g_i.+1 * 'g_i * 'g_i.+1) &
    (forall i j, i.+1 < j < n -> 'g_i * 'g_j = 'g_j * 'g_i)
  : relat_Sn.

Theorem presentation_Sn_eltr :
  relat_Sn ->
  exists f : {morphism 'SG_n.+1 >-> gT}, forall i, i < n -> f 's_i = 'g_i.
Proof using.
move=> [Hsq Hbraid Hcom].
pose morph_eltr_fun (s : 'S_n.+1) := \prod_(i <- canword s) 'g_i.
have morph_eltrP : {morph morph_eltr_fun : x y / x * y}.
  move=> i j.
  have:= braidred_to_canword (canword i ++ canword j) => [[redpath [Hpath]]].
  rewrite big_cat /= !canwordP /morph_eltr_fun -big_cat /= => Hlast.
  elim: redpath (_ ++ _) Hpath Hlast =>
      [c _ <- //|] w0 wp IHwp /= c /andP [Hbr] {}/IHwp H{}/H ->.
  move: Hbr => /orP [].
  - rewrite braid_sym; move: c; apply: gencongr_ind => //.
    move=> a b1 c b2 ->{w0} Hbr; rewrite !big_cat /=; congr (_ * (_ * _)) => {a c}.
    move: Hbr; rewrite /= mem_cat => /orP [].
    + move=> /braid_abaP [a [b [Heq ->{b1} ->{b2}]]].
      rewrite !big_cons !big_nil !mulg1 !mulgA.
      move: Heq => /orP [] /eqP Heq.
      * by rewrite -Heq; apply Hbraid; rewrite Heq.
      * by rewrite -Heq; symmetry; apply Hbraid; rewrite Heq.
    + move=> /braidCP [a [b [Heq ->{b1} ->{b2}]]].
      rewrite !big_cons !big_nil !mulg1.
      move: Heq => /orP [] Heq.
      * by apply Hcom; rewrite Heq /=.
      * by symmetry; apply Hcom; rewrite Heq /=.
  - move=> /reducesP [a [l [b [->{c} ->{w0}]]]].
    rewrite !big_cat /= !big_cons !big_nil !mulg1.
    have:= Hsq l (ltn_ord l); rewrite expgS expg1 => ->.
    by rewrite mul1g.
exists (Morphism (in2W morph_eltrP)) => i Hi /=.
rewrite /morph_eltr_fun; have /= -> := (canword_eltr (Ordinal Hi)).
by rewrite big_seq1.
Qed.

End PresentationSn.

Lemma joingU1 (gt : finGroupType) (a : gt) (S : {set gt}) :
  <[a]> <*> <<S>>  = << a |: S >>.
Proof. by rewrite joing_idr joing_idl joingE. Qed.

Lemma presentation_S2 :
  'SG_2 \isog Grp ( s0 : s0^+2 ).
Proof.
apply intro_isoGrp.
- apply/existsP; exists ('s_0).
  rewrite /= !xpair_eqE; apply/andP; split; try by rewrite expgS expg1 eltr2.
  rewrite eqEsubset subsetT /=; apply/subsetP => /= s _.
  rewrite -(canwordP s).
  elim: (canword s) => [| t0 t IHt] /=; first by rewrite big_nil group1.
  rewrite big_cons; apply groupM => /=; last exact: IHt.
  apply (subsetP (subset_gen _)); rewrite !inE.
  by case: t0 => [] [| //=] /= _.
- move=> Gt H; case/existsP => /= s0 /eqP [<-{H} Hx0].
  apply/homgP.
  pose fs := fun i => match i with 0 => s0 | _ => 1 end.
  have /presentation_Sn_eltr [f Hf] : relat_Sn 1 fs.
    constructor; try by case=> [|i].
    by case=> [|i] j // /andP [/leq_ltn_trans H'/H'].
  exists f; rewrite {3}eltr_genSn morphim_gen; last exact: subsetT.
  congr <<_>>; apply/setP => x; rewrite !inE.
  apply/imsetP/eqP => [[/= x0]| ->{x}] /=; rewrite setTI.
  + move=> /imsetP [/= i _ -> ->].
    by case: i => [[|i] //= ] _; rewrite Hf.
  + exists 's_0; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 0); rewrite //= inordK.
Qed.

Lemma presentation_S3 :
  'SG_3 \isog Grp ( s0 : s1 : (s0^+2 = s1^+2 = 1, s0*s1*s0 = s1*s0*s1) ).
Proof.
apply intro_isoGrp.
- apply/existsP; exists ('s_0, 's_1).
  rewrite /= !xpair_eqE; apply/and4P; split; try by rewrite expgS expg1 eltr2.
  + rewrite joingU1 eqEsubset subsetT /=; apply/subsetP => /= s _.
    rewrite -(canwordP s).
    elim: (canword s) => [| t0 t IHt] /=; first by rewrite big_nil group1.
    rewrite big_cons; apply groupM; last exact: IHt.
    apply (subsetP (subset_gen _)); rewrite !inE.
    by case: t0 => [] [| [| //=]] /= _; rewrite eq_refl /= ?orbT.
  + by apply/eqP/eltr_braid.
- move=> Gt H; case/existsP => /= [] [s0 s1] /eqP [<-{H} Hx0 Hx1 H3].
  rewrite joingU1; apply/homgP.
  pose fs := fun i => match i with 0 => s0 | 1 => s1 | _ => 1 end.
  have /presentation_Sn_eltr [f Hf] : relat_Sn 2 fs.
    constructor; try by case=> [|[|i]].
    by case=> [|i] j // /andP [/leq_ltn_trans H'/H'].
  exists f; rewrite {3}eltr_genSn morphim_gen; last exact: subsetT.
  congr <<_>>; apply/setP => x; rewrite !inE.
  apply/imsetP/idP => [[/= x0] | /orP [] /eqP ->{x}] /=; rewrite setTI.
  + move=> /imsetP [/= i _ -> ->].
    by case: i => [[|[|i]] //= ] _; rewrite Hf // eq_refl ?orbT.
  + exists 's_0; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 0); rewrite //= inordK.
  + exists 's_1; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 1); rewrite //= inordK.
Qed.

Lemma presentation_S4 :
  'SG_4 \isog Grp (
          s0 : s1 : s2 :
            (s0^+2, s1^+2, s2^+2,
             s0*s1*s0 = s1*s0*s1, s1*s2*s1 = s2*s1*s2,
             s0*s2 = s2*s0
        ) ).
Proof.
have Gen3 (gt : finGroupType) (a b c : gt) :
    <[a]> <*> <[b]> <*> <[c]> = <<[set a; b; c]>>.
  by rewrite -!setUA -!joingU1 !joingA.
apply intro_isoGrp.
- apply/existsP; exists ('s_0, 's_1, 's_2).
  rewrite /= !xpair_eqE /=; apply/andP; split.
  + rewrite Gen3 eqEsubset subsetT /=; apply/subsetP => /= s _.
    rewrite -(canwordP s).
    elim: (canword s) => [| t0 t IHt] /=; first by rewrite big_nil group1.
    rewrite big_cons; apply groupM; last exact: IHt.
    apply (subsetP (subset_gen _)); rewrite !inE.
    by case: t0 => [] [| [| [| //=]]] /= _; rewrite eq_refl /= ?orbT.
  do 3 do [apply/andP; split; first by rewrite expgS expg1 eltr2].
  do 2 do [apply/andP; split; first by apply/eqP/eltr_braid].
  by apply/eqP/eltr_comm.
- move=> Gt H; case/existsP => /= [] [[s0 s1] s2]
                                  /eqP [<-{H} Hx0 Hx1 Hx2 H010 H121 H02].
  rewrite Gen3; apply/homgP.
  pose fs := fun i => match i with 0 => s0 | 1 => s1 | 2 => s2 | _ => 1 end.
  have /presentation_Sn_eltr [f Hf] : relat_Sn 3 fs.
    constructor; try by case=> [|[|[|i]]].
    by case=> [|[|i]] [|[|[|j]]] // /andP [/leq_ltn_trans H'/H'].
  exists f; rewrite {3}eltr_genSn morphim_gen; last exact: subsetT.
  congr <<_>>; apply/setP => x; rewrite !inE -orbA.
  apply/imsetP/idP => [[/= x0] | /or3P [] /eqP ->{x}] /=; rewrite setTI.
  + move=> /imsetP [/= i _ -> ->].
    by case: i => [[|[|[|i]]] //= ] _; rewrite Hf //= eq_refl ?orbT.
  + exists 's_0; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 0); rewrite //= inordK.
  + exists 's_1; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 1); rewrite //= inordK.
  + exists 's_2; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 2); rewrite //= inordK.
Qed.

Lemma presentation_S5 :
  'SG_5 \isog Grp (
          s0 : s1 : s2 : s3 :
            (s0^+2, s1^+2, s2^+2, s3^+2,
             s0*s1*s0 = s1*s0*s1, s1*s2*s1 = s2*s1*s2, s2*s3*s2 = s3*s2*s3,
             s0*s2 = s2*s0, s0*s3 = s3*s0, s1*s3 = s3*s1
        ) ).
Proof.
have Gen4 (gt : finGroupType) (a b c d : gt) :
    <[a]> <*> <[b]> <*> <[c]> <*> <[d]> = <<[set a; b; c; d]>>.
  by rewrite -!setUA -!joingU1 !joingA.
apply intro_isoGrp.
- apply/existsP; exists ('s_0, 's_1, 's_2, 's_3).
  rewrite /= !xpair_eqE /=; apply/andP; split.
  + rewrite Gen4 eqEsubset subsetT /=; apply/subsetP => /= s _.
    rewrite -(canwordP s).
    elim: (canword s) => [| t0 t IHt] /=; first by rewrite big_nil group1.
    rewrite big_cons; apply groupM; last exact: IHt.
    apply (subsetP (subset_gen _)); rewrite !inE.
    by case: t0 => [] [| [| [| [|//=]]]] /= _; rewrite eq_refl /= ?orbT.
  do 4 do [apply/andP; split; first by rewrite expgS expg1 eltr2].
  do 3 do [apply/andP; split; first by apply/eqP/eltr_braid].
  do 2 do [apply/andP; split; first by apply/eqP/eltr_comm].
  by apply/eqP/eltr_comm.
- move=> Gt H; case/existsP => /= [] [[[s0 s1] s2] s3]
     /eqP [<-{H} Hx0 Hx1 Hx2 Hx3 H010 H121 H232 H02 H03 H13].
  rewrite Gen4; apply/homgP.
  pose fs := fun i =>
               match i with 0 => s0 | 1 => s1 | 2 => s2 | 3 => s3 | _ => 1 end.
  have /presentation_Sn_eltr [f Hf] : relat_Sn 4 fs.
    constructor; try by case=> [|[|[|[|i]]]].
    by case=> [|[|[|i]]] [|[|[|[|j]]]] // /andP [/leq_ltn_trans H'/H'].
  exists f; rewrite {3}eltr_genSn morphim_gen; last exact: subsetT.
  congr <<_>>; apply/setP => x; rewrite !inE -!orbA.
  apply/imsetP/idP => [[/= x0] | /or4P [] /eqP ->{x}] /=; rewrite setTI.
  + move=> /imsetP [/= i _ -> ->].
    by case: i => [[|[|[|[|i]]]] //= ] _; rewrite Hf //= eq_refl ?orbT.
  + exists 's_0; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 0); rewrite //= inordK.
  + exists 's_1; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 1); rewrite //= inordK.
  + exists 's_2; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 2); rewrite //= inordK.
  + exists 's_3; rewrite ?setTI ?Hf //.
    by apply/imsetP => /=; exists (inord 3); rewrite //= inordK.
Qed.