(** * Combi.LRrule.shuffle : Shuffle and shifted shuffle *)
(******************************************************************************)
(*      Copyright (C) 2014-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/                              *)
(******************************************************************************)
(** * Shuffle, shifted shuffle and plactic classes

This file contains the core of Schützenberger proof of the Littlewood-Richardson
rule. Namely, the theorem saying that the shifted shuffle of two plactic classes
is a union of plactic classes. The set of those class is described by the
[pred_LRtriple] predicate.

However, to prove the rule, instead of taking the road of plactic Schur
function, we follow Duchamp-Hivert-Thibon using free Schur functions. We
nevertheless prove Schützenberger theorem [Schutzenberger_shuffle_plact] but
we don't use it.

Here are the new notions:

- [shuffle u v] == the sequence of shuffling of [u] and [v]
- [shiftn n u] == add n to all the entries of the sequence [u]
- [sfiltergtn n v] == filter all the entries smaller than [n] in [v]
- [sfilterleq n v] == filter and substract [n] to the entries of [v] larger
          than [n] in [v]

- [shsh u v] == the shifted shuffle of [u] and [v]

- [langQ t] == the set of words whose Q-symbol is [t]

The Littlewood-Richardson triple:

- [LRtriple t1 t2 t] == there exists three words [p1] [p2] [p] of respective
           P-symbol [t1] [t2] [t] such that [p] appears in the shifted shuffle
           of [p1] and [p2]. Otherwise said, the row reading of [t] appears
           in the shifted shuffle of the plactic classes of [t1] and [t2].
           This is an inductive proposition.
- [pred_LRtriple t1 t2 t] == a predicate deciding [LRtriple t1 t2 t]
- [pred_LRtriple_fast t1 t2 t] == a faster predicate deciding [LRtriple t1 t2 t]
           only computing the shifted shuffle of (the row reading of) [t1] with
           the plactic class of [t2]

The main statement is [LRtriple_cat_equiv] which stats the equivalence,
for two standard tableau [t1] and [t2] and two words [u1] [u2] of the right length,
between the two following statements:
- [ u1 \in langQ t1 /\ u2 \in langQ t2]
- [ exists t, LRtriple t1 t2 t /\ u1 ++ u2 \in langQ t ]

Then to get a first version of the LR rule, we will need to do the necessary
abgebraic translation of the rule and recode the triple by some standard
skew tableaux.
*************************)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrfun ssrnat eqtype finfun fintype choice.
From mathcomp Require Import order seq tuple finset perm binomial bigop.
Require Import tools vectNK subseq partition Yamanouchi ordtype std tableau stdtab.
Require Import Schensted plactic Greene_inv stdplact.

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

Open Scope bool.

Import Order.TTheory.

(** ** The shuffle of two sequences *)
Section Defs.

Variable Alph : eqType.
Let word := seq Alph.

Implicit Type a b c : Alph.
Implicit Type u v w : word.

(** A well founded recursive definition of shuffle (a :: u) v *)
Fixpoint shuffle_from_rec a u shuffu' v {struct v} :=
  if v is b :: v' then
    [seq a :: w | w <- shuffu' v] ++
    [seq b :: w | w <- shuffle_from_rec a u shuffu' v']
  else [:: (a :: u)].

Fixpoint shuffle u v {struct u} :=
  if u is a :: u' then
    shuffle_from_rec a u' (shuffle u') v
  else [:: v].

Lemma shuffle_nil u : shuffle u [::] = [:: u].
Proof using . by case u. Qed.

Lemma size_shuffle u v :
  size (shuffle u v) = binomial ((size u) + (size v)) (size u).
Proof using .
elim: u v => [| a u IHu] /= v; first by rewrite bin0.
elim: v => [| b v IHv] /=; first by rewrite addn0 binn.
rewrite size_cat !size_map IHu IHv /=.
by rewrite !addSn addnS addnC -binS.
Qed.

Lemma shuffleC u v : perm_eq (shuffle u v) (shuffle v u).
Proof using .
elim: u v => [| a u IHu] /= v; first by rewrite shuffle_nil perm_refl.
elim: v => [| b v IHv] /=; first by rewrite perm_refl.
set sa := (X in X ++ _); set sb := (X in _ ++ X).
apply: (@perm_trans _ (sb ++ sa)); first by apply/permPl; apply: perm_catC.
set sc := (X in perm_eq _ (X ++ _)).
apply: (@perm_trans _ (sc ++ sa)).
- rewrite perm_cat2r /sb /sc /= {sa sb sc}.
  by apply: perm_map; exact: IHv.
- rewrite perm_cat2l /sa /= {sa sb sc}.
  by apply: perm_map; exact: IHu.
Qed.

Lemma perm_shuffle u v : all (perm_eq (u ++ v)) (shuffle u v).
Proof using .
elim: u v => [| a u IHu] /= v; first by rewrite perm_refl.
elim: v => [| b v /allP IHv] /=; first by rewrite cats0 perm_refl.
rewrite all_cat; apply/andP; split; apply/allP => s /mapP [t Ht -> {s}] /=.
- rewrite perm_cons.
  by move/(_ (b :: v)): IHu => /allP; apply.
- apply: (@perm_trans _ (b :: v ++ a :: u)).
  + by apply/permPl; have /= := perm_catC (a :: u) (b :: v).
  + rewrite perm_cons perm_sym.
    move/(_ t Ht) : IHv; rewrite perm_sym => /perm_trans; apply.
    by apply/permPl; have /= := perm_catC (a :: u) v.
Qed.

Lemma all_size_shuffle u v :
  all (fun s => size s == size u + size v) (shuffle u v).
Proof using .
apply/allP => x Hx; rewrite -size_cat.
apply/eqP; apply: perm_size.
have:= perm_shuffle u v => /allP Hall.
by rewrite perm_sym; exact: Hall.
Qed.

(** *** Shuffling two disjoint sequences *)
Lemma all_in_shufflel u v :
  predI (mem u) (mem v) =i pred0 ->
  all (fun s => filter (mem u) s == u) (shuffle u v).
Proof using .
elim: u v => [| a u IHu] /= v HI.
  by rewrite !andbT (eq_filter (a2 := pred0)) // filter_pred0.
elim: v HI => [_ | b v IHv] /=.
- rewrite !andbT inE eq_refl /=; apply/eqP; congr (a :: _).
  rewrite (eq_in_filter (a2 := predT)); first by rewrite filter_predT.
  by move => i /=; rewrite inE => ->; rewrite orbT.
- move=> HI; rewrite all_cat.
  apply/andP; split; apply/allP=> x /mapP [s Hs -> {x}] /=.
  + rewrite !inE eq_refl /=; apply/eqP; congr (a :: _).
    have {}/IHu/allP Hu : [predI u & b :: v] =i pred0.
      move=> i; rewrite !inE; apply: negbTE.
      move/(_ i): HI; rewrite !inE => /negbT.
      by apply: contra => /andP [->]; rewrite orbT.
    case (boolP (a \in u)) => Ha.
    * rewrite (eq_filter (a2 := mem u)); first by apply/eqP; apply: (Hu _ Hs).
      move => i /=; rewrite inE.
      apply/idP/idP => [| ->]; last by rewrite orbT.
      by move/orP => [/eqP ->|].
    * rewrite (eq_in_filter (a2 := mem u)); first by apply/eqP; apply: (Hu _ Hs).
      move => i /=; rewrite inE => Hi.
      apply/idP/idP; last by move ->; rewrite orbT.
      have /allP := perm_shuffle u (b :: v) => /(_ _ Hs)/perm_mem/(_ i).
      rewrite {}Hi /= mem_cat inE => /or3P []; first by move ->.
      - move/eqP -> => /orP [] // /eqP Habs; exfalso.
        by move/(_ a): HI; rewrite !inE Habs !eq_refl.
      - move=> Hi /orP [] // /eqP Habs; move: Hi; rewrite Habs {i Habs} => Habs.
        by move/(_ a): HI; rewrite !inE Habs !eq_refl /= orbT.
  + have := HI b; rewrite !inE /= eq_refl /= andbT => ->.
    have /IHv/allP : [predI a :: u & v] =i pred0.
      move=> i /=; rewrite !inE; apply: negbTE.
      move/(_ i): HI; rewrite !inE => /negbT.
      by apply: contra => /andP [-> ->]; rewrite orbT.
    by apply.
Qed.

Lemma all_in_shuffler u v :
  predI (mem u) (mem v) =i pred0 ->
  all (fun s => filter (mem v) s == v) (shuffle u v).
Proof using .
move=> HI.
rewrite (perm_all _ (shuffleC _ _)) //.
apply: all_in_shufflel.
by move=> i; rewrite -(HI i) !inE andbC.
Qed.

Lemma mem_shuffle_predU u v s Pu Pv:
  predI Pu Pv =i pred0 ->
  filter Pu s = u -> filter Pv s = v -> size s = size u + size v ->
  filter (predU Pu Pv) s = s.
Proof using .
move=> HI Hu Hv Hsz.
have /eqP := count_predUI Pu Pv s.
rewrite -!size_filter Hu Hv (eq_filter HI) filter_pred0 /= addn0 -Hsz.
by rewrite size_filter -all_count => /all_filterP.
Qed.

Lemma mem_shuffle_pred u v s Pu Pv:
  predI Pu Pv =i pred0 ->
  filter Pu s = u -> filter Pv s = v -> size s = size u + size v ->
  s \in shuffle u v.
Proof using .
move=> HI Hu Hv Hsz; have /all_filterP Hall := mem_shuffle_predU HI Hu Hv Hsz.
elim: u v s Hu Hv {Hsz} Hall => [| a u' IHu] /= v s Hu Hv Hall.
  move: Hall => /all_filterP; rewrite (eq_in_filter (a2 := Pv)).
    by move <-; rewrite Hv mem_seq1.
  move=> i Hi /=.
  rewrite (_ : Pu i = false) //; apply/negP => HPu.
  have : i \in [seq x <- s | Pu x] by rewrite mem_filter HPu Hi.
  by rewrite Hu /= in_nil.
elim: v s Hv Hu Hall => [//= | b v IHv] /= s Hv Hu Hall.
  move: Hall => /all_filterP; rewrite (eq_in_filter (a2 := Pu)).
    by move <-; rewrite Hu mem_seq1.
  move=> i Hi /=.
  rewrite (_ : Pv i = false) ?orbF //; apply/negP => HPv.
  have : i \in [seq x <- s | Pv x] by rewrite mem_filter HPv Hi.
  by rewrite Hv /= in_nil.
case: s Hu Hv Hall => [//= | s0 s] /=.
case: (boolP (Pu s0)) => Hs0 /=.
- have -> : Pv s0 = false by move/(_ s0): HI; rewrite !inE Hs0.
  move=> [Ha]; subst s0 => Hu Hv Hall.
  rewrite mem_cat; apply/orP; left.
  apply/mapP; exists s; last by [].
  exact: IHu.
- move=> Hu Hv {Hs0} /andP [Hs0 Hall].
  move: Hv; rewrite Hs0 => [] [Htmp]; subst s0 => Hv.
  rewrite mem_cat; apply/orP; right.
  apply/mapP; exists s; last by [].
  exact: IHv.
Qed.

Lemma mem_shuffle u v s :
  predI (mem u) (mem v) =i pred0 ->
  [&& filter (mem u) s == u,
      filter (mem v) s == v &
      (size s == size u + size v)] = (s \in shuffle u v).
Proof using .
move=> HI; apply/idP/idP.
- move=> /and3P [/eqP Hu /eqP Hv /eqP Hsz].
  exact: (mem_shuffle_pred HI).
- move=> Hs.
  have:= all_in_shufflel HI => /allP/(_ _ Hs) -> /=.
  have:= all_in_shuffler HI => /allP/(_ _ Hs) -> /=.
  by have:= all_size_shuffle u v => /allP/(_ _ Hs).
Qed.

End Defs.

(** ** The shifted shuffle of two standard words *)
Section ShiftedShuffle.

Implicit Type u v w : seq nat.

Definition shiftn n := map (addn n).
Definition sfiltergtn n := [fun v => filter (gtn n) v].
Definition sfilterleq n := [fun v => map (subn^~ n) (filter (leq n) v)].

Lemma shiftuK n : cancel (shiftn n) (map (subn^~ n)).
Proof.
move=> s; rewrite /shiftn -map_comp.
rewrite (eq_map (f2 := id)); first by rewrite map_id.
by move=> i /=; rewrite /= addKn.
Qed.

Lemma sfilterleqK n v : shiftn n (sfilterleq n v) = [seq x <- v | n <= x].
Proof.
rewrite /=; elim: v => [//= | v0 v IHv] /=.
case: leqP => H /=; rewrite IHv; last by [].
by rewrite subnKC.
Qed.

Lemma sfilterleqE n u v : u = sfilterleq n v <-> shiftn n u = filter (leq n) v.
Proof. by split => [-> {u} /= | /= <- {v}]; rewrite ?sfilterleqK ?shiftuK. Qed.

Lemma mem_sfilterleqK n v i : i \in (sfilterleq n v) = (i + n \in v).
Proof.
rewrite /=; elim: v => [//= | v0 v IHv] /=.
case: leqP => H /=; rewrite !inE IHv.
- by congr (_ || _); rewrite -{2}(subnK H) eqn_add2r.
- suff -> : (i + n == v0) = false by [].
  by apply: gtn_eqF; exact: ltn_addl.
Qed.

Lemma perm_shiftn_std n s :
  is_std s -> perm_eq (shiftn n s) (iota n (size s)).
Proof.
rewrite /is_std /shiftn -{2}(addn0 n) iotaDl.
exact: perm_map.
Qed.

Definition shsh u v := shuffle u (shiftn (size u) v).

Lemma std_shsh u v : is_std u -> is_std v -> all is_std (shsh u v).
Proof.
rewrite /is_std /shsh /shiftn => Hu Hv.
apply/allP => s Hs.
have /allP/(_ s Hs) := perm_shuffle u (shiftn (size u) v).
rewrite perm_sym => /perm_trans; apply.
have /allP/(_ s Hs)/eqP := all_size_shuffle u (shiftn (size u) v).
rewrite size_map => -> {s Hs}.
rewrite iotaD.
apply: (@perm_trans _ (u ++ iota (size u) (size v))); last by rewrite perm_cat2r.
rewrite perm_cat2l -{2}[size u]addn0 iotaDl.
exact: perm_map.
Qed.

Lemma pred0_std u v : is_std u -> [predI u & shiftn (size u) v] =i pred0.
Proof.
rewrite /is_std /shsh /shiftn => /perm_mem Hu i /=.
rewrite !inE Hu mem_iota add0n /=.
apply/negP => /andP [Hlt /mapP [j _ Hi]].
by move: Hlt; rewrite Hi -{2}[size u]addn0 ltn_add2l.
Qed.

Lemma shsh_sfiltergtn p u v :
  is_std u -> p \in shsh u v -> u = sfiltergtn (size u) p.
Proof.
move=> Hstdu; rewrite /shsh.
rewrite -(mem_shuffle _ (pred0_std v Hstdu)) => /and3P [/eqP Hu _ _].
rewrite -{1}Hu; apply: eq_filter => i /=.
by rewrite (perm_mem Hstdu) mem_iota /= add0n.
Qed.

Lemma shsh_sfilterleq p u v :
  is_std u -> p \in shsh u v -> v = sfilterleq (size u) p.
Proof.
move=> Hstdu; rewrite /shsh => Hsh.
rewrite sfilterleqE; have:= Hsh.
rewrite -(mem_shuffle _ (pred0_std v Hstdu)) /= => /and3P [_ /eqP <- _].
apply: eq_in_filter => i /= Hi.
have /allP/(_ p Hsh) Hp := perm_shuffle u (shiftn (size u) v).
move: Hi; rewrite -(perm_mem Hp) mem_cat => /orP [].
- rewrite (perm_mem Hstdu) mem_iota /= add0n /shiftn => Hi.
  rewrite leqNgt Hi /=; apply/negP => /mapP [j Hj Heq].
  by move: Hi; rewrite Heq -{2}[size u]addn0 ltn_add2l.
- move=> Hi; rewrite Hi; apply: esym.
  move: Hi; rewrite /shiftn => /mapP [j _ ->].
  by rewrite -{1}[size u]addn0 leq_add2l.
Qed.

Lemma mem_shsh p u v :
  is_std u ->
  (p \in shsh u v) =
  ((sfiltergtn (size u) p == u) && (sfilterleq (size u) p == v)).
Proof.
move=> Hstdu; apply/idP/idP.
- move=> H.
  by rewrite {2}(shsh_sfiltergtn Hstdu H) (shsh_sfilterleq Hstdu H) !eq_refl.
- rewrite /shsh -(mem_shuffle _ (pred0_std v Hstdu)).
  move=> /andP [/eqP /= Hu /eqP /= Hv].
  apply/and3P; split.
  + apply/eqP; rewrite -{2}Hu /=; apply: eq_filter => i.
    by rewrite /= (perm_mem Hstdu) mem_iota /= add0n.
  + apply/eqP; rewrite -{2}Hv sfilterleqK /=; apply: eq_in_filter => i /= Hi.
    by rewrite -Hv sfilterleqK mem_filter Hi andbT.
  + rewrite -(count_predC (gtn (size u)) p) -!size_filter.
    have /eq_filter -> : (predC (gtn (size u))) =1 leq (size u).
      by move=> i /=; rewrite -leqNgt.
    by rewrite Hu -Hv !size_map.
Qed.

Lemma shift_plactcongr n u v : (u =Pl v) = (shiftn n u =Pl shiftn n v).
Proof.
apply/idP/idP.
- apply: plact_map_in_incr => x y _ _.
  by rewrite !ltEnat /= ltn_add2l.
- rewrite -{2}[u](shiftuK n) -{2}[v](shiftuK n) /shiftn.
  apply: plact_map_in_incr => x y /mapP [x0 Hx0 -> {x}] /mapP [y0 Hy0 -> {y}].
  by rewrite !ltEnat /= ltn_add2l !addKn.
Qed.

(** ** Schützenberger theorem *)
Theorem Schutzenberger_shuffle_plact u1 v1 w1 w2 :
  is_std u1 -> is_std v1 -> w1 \in shsh u1 v1 ->
  (w1 =Pl w2) ->
  exists u2 v2, [/\ u1 =Pl u2, v1 =Pl v2 & w2 \in shsh u2 v2].
Proof.
move=> Hstdu1 Hstdv1 Hsh Hpl.
have Hstdw1 : is_std w1 by exact: (allP (std_shsh Hstdu1 Hstdv1)).
have:= Hsh; rewrite (mem_shsh _ _ Hstdu1) => /andP [/eqP Hu1 /eqP Hv1].
have HgtnE : (fun x => (x < size u1)%O) =1 gtn (size u1).
  by move=> x /=; rewrite ltEnat.
have HleqE : (fun x => (x >= size u1)%O) =1 leq (size u1).
  by move=> x /=; rewrite leEnat.
pose u2 := (sfiltergtn (size u1) w2); pose v2 := (sfilterleq (size u1) w2).
have {Hu1} Hplu : u1 =Pl u2.
  rewrite -Hu1 /u2 /sfiltergtn /= -!(eq_filter HgtnE).
  exact: plactic_filter_gt.
have {Hv1} Hplv : v1 =Pl v2.
  rewrite -Hv1 /v2 /sfilterleq /= -!(eq_filter HleqE).
  apply: plact_map_in_incr; last exact: plactic_filter_le.
  move=> /= x y.
  rewrite !mem_filter !leEnat !ltEnat /= => /andP [Hx _]  /andP [Hy _] Hxy.
  by rewrite -(ltn_add2r (size u1)) ?subnK.
exists u2, v2; split => //.
rewrite mem_shsh; first last.
  by apply (perm_std Hstdu1); rewrite perm_sym; exact: plact_homog.
by rewrite -(perm_size (plact_homog Hplu)) !eq_refl.
Qed.

End ShiftedShuffle.

(** * Shifted shuffle and inverse standardized *)
Section LRTriple.

Context {disp : unit} {Alph : inhOrderType disp}.
Let word := seq Alph.

Implicit Type a b c : Alph.
Implicit Type u v w : word.
Implicit Type t : seq (seq nat).

Lemma perm_sfiltergtn p n :
  is_std p -> perm_eq (sfiltergtn n p) (iota 0 (minn n (size p))).
Proof using .
move=> Hstd; apply: uniq_perm.
- by apply: filter_uniq; exact: std_uniq.
- exact: iota_uniq.
- move=> i; rewrite mem_filter mem_iota /= add0n leq_min.
  congr (_ && _).
  rewrite (perm_mem Hstd).
  by rewrite mem_iota /= add0n.
Qed.

Lemma perm_sfilterleq p n :
  is_std p -> perm_eq (sfilterleq n p) (iota 0 ((size p) - n)).
Proof using .
move=> Hstd; apply: uniq_perm.
- rewrite map_inj_in_uniq.
  + by apply: filter_uniq; exact: std_uniq.
  + move=> i j; rewrite !mem_filter => /andP [Hi _] /andP [Hj _] H.
    by rewrite -(subnK Hi) H (subnK Hj).
- exact: iota_uniq.
- move=> i; rewrite mem_sfilterleqK.
  rewrite (perm_mem Hstd).
  rewrite !mem_iota /= !add0n.
  by rewrite ltn_subRL addnC.
Qed.

Lemma size_sfiltergtn p n :
  is_std p -> size (sfiltergtn n p) = minn n (size p).
Proof using.
by move/(perm_sfiltergtn n)/perm_size ->; rewrite size_iota.
Qed.
Lemma size_sfilterleq p n :
  is_std p -> size (sfilterleq n p) = (size p) - n.
Proof using.
by move/(perm_sfilterleq n)/perm_size ->; rewrite size_iota.
Qed.

Lemma sfiltergtn_is_std p n : is_std p -> is_std (sfiltergtn n p).
Proof using .
move=> Hstd; rewrite /is_std (size_sfiltergtn _ Hstd).
exact: perm_sfiltergtn.
Qed.
Lemma sfilterleq_is_std p n : is_std p -> is_std (sfilterleq n p).
Proof using .
move=> Hstd; rewrite /is_std (size_sfilterleq _ Hstd).
exact: perm_sfilterleq.
Qed.

Lemma size_sfiltergtn_cat u v :
  size (sfiltergtn (size u) (invstd (std (u ++ v)))) = size u.
Proof using .
rewrite (size_sfiltergtn _ (invstd_is_std _)); last exact: std_is_std.
rewrite size_invstd size_std size_cat.
by have /minn_idPl -> : size u <= size u + size v by apply: leq_addr.
Qed.
Lemma size_sfilterleq_cat u v :
  size (sfilterleq (size u) (invstd (std (u ++ v)))) = size v.
Proof using .
rewrite (size_sfilterleq _ (invstd_is_std _)); last exact: std_is_std.
by rewrite size_invstd size_std size_cat addKn.
Qed.

Lemma index_leq_filter l (P : pred nat) i j :
  P i -> P j ->
  (index i (filter P l)) <= (index j (filter P l)) = (index i l <= index j l).
Proof using .
move=> Hi Hj.
elim: l => [//= | l0 l IHl] /=.
case (boolP (P l0)) => [Hl0|] /=.
- by case (altP (l0 =P i)) => Hil0; case (altP (l0 =P j)).
- case (altP (l0 =P i)) => [->|Hil0]; first by rewrite Hi.
  case (altP (l0 =P j)) => [->|Hjl0]; first by rewrite Hj.
  by rewrite ltnS IHl.
Qed.

Lemma index_sfilterleq n s i :
  index i (sfilterleq n s) = index (i + n) (filter (leq n) s).
Proof using .
elim: s => [//= | s0 s IHs] /=.
case: (leqP n s0) => Hv0 /=.
- by rewrite -{2}(subnK Hv0) eqn_add2r IHs.
- by rewrite IHs.
Qed.

Lemma index_invstd l i :
  is_std l -> i < size l -> index i (invstd l) = nth inh l i.
Proof using .
move=> Hstd Hi.
by rewrite -{2}(invstdK Hstd) /invstd nth_mkseq //= size_mkseq.
Qed.

Lemma invstd_catgtn u v :
  invstd (std u) = sfiltergtn (size u) (invstd (std (u ++ v))).
Proof using .
have Hsftstd : is_std (sfiltergtn (size u) (invstd (std (u ++ v)))).
  apply: (@sfiltergtn_is_std (invstd (std (u ++ v))) (size u)).
  by apply: invstd_is_std; exact: std_is_std.
suff Heqinv : std u = invstd (sfiltergtn (size u) (invstd (std (u ++ v)))).
  by rewrite Heqinv invstdK.
apply/eqP/stdP; apply: StdSpec; first exact: invstd_is_std.
move=> {Hsftstd}.
apply/eq_invP; split; first by rewrite size_invstd size_sfiltergtn_cat.
move=> i j /andP [Hij Hj].
have Hi := leq_ltn_trans Hij Hj.
rewrite leEnat /=.
do 2 (rewrite nth_mkseq; last by rewrite size_sfiltergtn_cat).
rewrite index_leq_filter //= -/(invstd (std (u++v))).
have Hucat : size u <= size (std (u ++ v)).
  by rewrite size_std size_cat; apply: leq_addr.
do 2 (rewrite (index_invstd (std_is_std (u ++ v)));
      last by apply: (@leq_trans (size u)); last exact Hucat).
have /eq_invP := eq_inv_std (u ++ v) => [] [_ Hinv].
have Hijsz : i <= j < size (u ++ v).
  rewrite Hij /=; apply: (leq_trans Hj); rewrite size_cat; exact: leq_addr.
rewrite -leEnat -(Hinv i j Hijsz).
by rewrite !nth_cat Hi Hj.
Qed.

Lemma invstd_catleq u v :
  invstd (std v) = sfilterleq (size u) (invstd (std (u ++ v))).
Proof using .
have Hsftstd : is_std (sfilterleq (size u) (invstd (std (u ++ v)))).
  apply: (@sfilterleq_is_std (invstd (std (u ++ v))) (size u)).
  by apply: invstd_is_std; exact: std_is_std.
suff Heqinv : std v = invstd (sfilterleq (size u) (invstd (std (u ++ v)))).
  by rewrite Heqinv invstdK.
apply/eqP/stdP; apply: StdSpec; first exact: invstd_is_std.
move=> {Hsftstd}.
apply/eq_invP; split; first by rewrite size_invstd size_sfilterleq_cat.
move=> i j /andP [Hij Hj].
have Hi := leq_ltn_trans Hij Hj.
rewrite leEnat /=.
do 2 (rewrite nth_mkseq; last by rewrite size_sfilterleq_cat).
rewrite !index_sfilterleq index_leq_filter; try apply: leq_addl.
do 2 (rewrite (index_invstd (std_is_std (u ++ v)));
  last by rewrite size_std size_cat addnC ltn_add2l).
have /eq_invP := eq_inv_std (u ++ v) => [] [_ Hinv].
have Hijsz : i + size u <= j + size u < size (u ++ v).
  rewrite size_cat [size u + _]addnC.
  rewrite leq_add2r ltn_add2r.
  by rewrite Hij Hj.
rewrite -leEnat -(Hinv _ _ Hijsz) {Hijsz}.
rewrite !nth_cat.
have H x : (x + size u < size u) = false.
  by apply: negbTE; rewrite -leqNgt; apply: leq_addl.
by rewrite !H !addnK.
Qed.

(** This is essentially the product rule of FQSym *)
Theorem invstd_cat_in_shsh u v :
  invstd (std (u ++ v)) \in shsh (invstd (std u)) (invstd (std v)).
Proof using .
rewrite mem_shsh; last by apply: invstd_is_std; apply: std_is_std.
rewrite {2}(invstd_catgtn u v) size_invstd size_std (invstd_catleq u v).
by rewrite !eq_refl.
Qed.

(** Free Schur functions as predicates *)
Definition langQ t := [pred w : word | (RStabmap w).2 == t].

Lemma langQE u t : (u \in langQ t) = (RS (invstd (std u)) == t).
Proof. by rewrite /langQ inE RSinvstdE. Qed.

Lemma size_langQ t u : u \in langQ t -> size u = size_tab t.
Proof using .
rewrite langQE => /eqP <-.
by rewrite -size_RS -RStabmapE RSinvstdE /size_tab shape_RStabmapE.
Qed.

(** * Littlewood-Richardson-Schützenberger triple *)
Inductive LRtriple t1 t2 t : Prop :=
  LRTriple :
    forall p1 p2 p, RS p1 = t1 -> RS p2 = t2 -> RS p = t ->
                    p \in shsh p1 p2 -> LRtriple t1 t2 t.
Definition pred_LRtriple (t1 t2 : seq (seq nat)) :=
  [pred t : (seq (seq nat)) |
   has (fun p => RS p == t)
       (flatten [seq shsh p1 p2 | p1 <- RSclass _ t1, p2 <- RSclass _ t2])].
Definition pred_LRtriple_fast (t1 t2 : seq (seq nat)) :=
  [pred t : (seq (seq nat)) |
   has (fun p2 => to_word t \in shsh (to_word t1) p2) (RSclass _ t2)].

Lemma LRtripleP t1 t2 t :
  is_stdtab t1 -> is_stdtab t2 ->
  reflect (LRtriple t1 t2 t) (pred_LRtriple t1 t2 t).
Proof using .
rewrite /is_stdtab => /andP [Htab1 _] /andP [Htab2 _].
apply: (iffP idP) => /=.
- move=> /hasP [p /flattenP [shuf /allpairsP [] [p1 p2]]] /= [].
  move=> /mapP [yam1
          /(allP (enum_yamevalP (is_part_sht Htab1))) /= /andP [Hyam1 Hsh1] Hp1].
  move=> /mapP [yam2
          /(allP (enum_yamevalP (is_part_sht Htab2))) /= /andP [Hyam2 Hsh2] Hp2].
  move=> -> {shuf} Hshuf /eqP <- {t}.
  apply: (@LRTriple t1 t2 (RS p) p1 p2 p) => //=.
  + by rewrite Hp1 -RSmapE RSmapinv2K //= Htab1 Hyam1 eq_sym Hsh1.
  + by rewrite Hp2 -RSmapE RSmapinv2K //= Htab2 Hyam2 eq_sym Hsh2.
- move=> [p1 p2 p]; rewrite -2!RSmapE => Hp1 Hp2 Hp Hsh.
  apply/hasP; exists p; last by rewrite Hp.
  apply/flattenP; exists (shsh p1 p2); last exact: Hsh.
  apply/allpairsP; exists (p1, p2); split; last by [].
  + rewrite /= -Hp1 RSmapE; exact: mem_RSclass.
  + rewrite /= -Hp2 RSmapE; exact: mem_RSclass.
Qed.

Lemma filter_gt_RS (d : unit) (T : inhOrderType d) (w : seq T) n :
  RS (filter (>%O n) w) = filter_gt_tab n (RS w).
Proof using .
apply/eqP.
rewrite -(RS_tabE (is_tableau_filter_gt _ (is_tableau_RS w))) -plactic_RS /=.
rewrite to_word_filter_nnil -filter_to_word.
apply: plactic_filter_gt; exact: congr_RS.
Qed.

Lemma pred_LRtriple_fast_filter_gt t1 t2 t :
  is_stdtab t1 -> is_stdtab t ->
  pred_LRtriple_fast t1 t2 t -> t1 = filter_gt_tab (size_tab t1) t.
Proof using .
move=> Ht1 Ht /= /hasP [p2 Hp2 Hshsh].
move: Ht1; rewrite /is_stdtab => /andP [Htab1 Hstd1].
rewrite -{1}(RS_tabE Htab1) (shsh_sfiltergtn Hstd1 Hshsh) /=.
rewrite -size_to_word.
move: Ht; rewrite /is_stdtab => /andP [Htab _].
by rewrite filter_gt_RS /= (RS_tabE Htab).
Qed.

Lemma LRtriple_fastE t1 t2 t :
  is_stdtab t1 -> is_stdtab t2 -> is_stdtab t ->
  pred_LRtriple t1 t2 t = pred_LRtriple_fast t1 t2 t.
Proof using .
move=> Ht1 Ht2 Ht.
apply/idP/idP.
- move/(LRtripleP t Ht1 Ht2) => [p1 p2 p Hp1 Hp2 Hp Hshsh] /=.
  rewrite -Hp -Hp1 -Hp2.
  pose p' := (sfilterleq (size p1) (to_word (RS p))).
  have Hp' : RS p2 = RS p'.
    apply/eqP; rewrite -plactic_RS.
    move: Hshsh; have:= Ht1; rewrite -Hp1 RSstdE => /mem_shsh -> /andP [_ /eqP <-].
    rewrite (shift_plactcongr (size p1)) /p' !sfilterleqK.
    apply: plactic_filter_le; apply congr_RS.
  apply/hasP; exists p'.
  + apply /mapP; exists (RSmap p').2.
    * apply/count_memPn; rewrite Hp'.
      have: is_yam_of_eval (shape (RS p')) (RSmap p').2.
        by rewrite /is_yam_of_eval is_yam_RSmap2 /= -RSmapE shape_RSmap_eq.
      by move/(enum_yameval_countE (is_part_sht (is_tableau_RS p'))) => ->.
    * rewrite Hp' -[RS p']RSmapE /=.
      have -> : ((RSmap p').1, (RSmap p').2) = RSmap p' by case RSmap.
      by rewrite RSmapK.
  + have: is_std (to_word (RS p1)) by move: Ht1; rewrite Hp1 /is_stdtab => /andP [].
    move/mem_shsh ->; apply/andP.
    rewrite size_to_word size_RS; split; last by [].
    move: Hshsh; have:= Ht1.
    rewrite -Hp1 RSstdE => /mem_shsh -> /andP [/eqP {3}<- _].
    rewrite /= filter_gt_RS.
    by rewrite filter_to_word to_word_filter_nnil.
- move=> Hfast; apply/(LRtripleP t Ht1 Ht2).
  move: Hfast => /= /hasP [p2 /mapP [y2 Hy2]].
  have:= Ht2; rewrite /is_stdtab => /andP [Htab2 _].
  have:= (is_part_sht Htab2) => /enum_yamevalP/allP/(_ _ Hy2) {Hy2}.
  rewrite /is_yam_of_eval => /andP [Hyam2 /eqP Hsh2] Hp2 Htshsh.
  have:= Ht1; rewrite /is_stdtab => /andP [/RS_tabE H1 _].
  have H2 : RS p2 = t2 by rewrite Hp2 -RSmapE RSmapinv2K //= Htab2 Hyam2 Hsh2 /=.
  have:= Ht; rewrite /is_stdtab => /andP [/RS_tabE Hres _].
  exact: (LRTriple H1 H2 Hres).
Qed.

Lemma is_stdtab_of_n_LRtriple t1 t2 t :
  is_stdtab t1 -> is_stdtab t2 -> LRtriple t1 t2 t ->
  is_stdtab_of_n ((size_tab t1) + (size_tab t2)) t.
Proof using .
move=> H1 H2 [p1 p2 p Hp1 Hp2 <- {t} Hp] /=.
apply/andP; split.
- rewrite RSstdE.
  have Hsp1 : is_std p1 by rewrite -(RSstdE) Hp1.
  have Hsp2 : is_std p2 by rewrite -(RSstdE) Hp2.
  exact: (allP (std_shsh Hsp1 Hsp2)).
- rewrite size_RS; move: Hp; rewrite /shsh => Hp.
  have /allP/(_ _ Hp)/eqP -> := all_size_shuffle p1 (shiftn (size p1) p2).
  by rewrite size_map -Hp1 -Hp2 !size_RS.
Qed.

Theorem LRtriple_cat_langQ t1 t2 u1 u2:
  is_stdtab t1 -> is_stdtab t2 -> u1 \in langQ t1 -> u2 \in langQ t2 ->
  LRtriple t1 t2 (RStabmap (u1 ++ u2)).2.
Proof using .
move=> Hstd1 Hstd2 Hu1 Hu2.
have Hsz1 := size_langQ Hu1; have Hsz2 := size_langQ Hu2.
move: Hu1 Hu2; rewrite !inE => /eqP Hu1 /eqP Hu2.
apply: (LRTriple (p1 := invstd (std u1))
                      (p2 := invstd (std u2))
                      (p  := invstd (std (u1 ++ u2))) ).
- by rewrite -Hu1 RSinvstdE.
- by rewrite -Hu2 RSinvstdE.
- by rewrite RSinvstdE.
- exact: invstd_cat_in_shsh.
Qed.

(** This is essentially the free LR rule:

The concatenation of [langQ t1] and [langQ t2] is the union of [langQ t] for
[t] such that [LRtriple t1 t2 t].
******************************)
Theorem LRtriple_cat_equiv t1 t2 :
  is_stdtab t1 -> is_stdtab t2 ->
  forall u1 u2 : word,
  ( (u1 \in langQ t1 /\ u2 \in langQ t2) <->
    [/\ size u1 = size_tab t1, size u2 = size_tab t2 &
     exists t, LRtriple t1 t2 t /\ u1 ++ u2 \in langQ t] ).
Proof using .
move=> Hstd1 Hstd2 u1 u2.
split.
- move=> [Hu1 Hu2]; split; try exact: size_langQ.
  exists (RStabmap (u1 ++ u2)).2; split.
  + exact: LRtriple_cat_langQ.
  + by rewrite inE.
- move=> [Hsz1 Hsz2 [t] [] [p1 p2 p Hp1 Hp2 Htmp]]; subst t.
  rewrite !inE -!RSinvstdE -Hp1 -Hp2 -!plactic_RS => Hsh Hcat.
  have Hstdp1 : is_std p1 by rewrite -RSstdE Hp1.
  have Hszp : size p1 = size u1 by rewrite Hsz1 -size_RS Hp1.
  split.
  + rewrite (invstd_catgtn u1 u2) (shsh_sfiltergtn Hstdp1 Hsh) Hszp.
    exact: plactic_filter_gt.
  + rewrite (invstd_catleq u1 u2) (shsh_sfilterleq Hstdp1 Hsh) Hszp.
    rewrite (shift_plactcongr (size u1)) !sfilterleqK.
    exact: plactic_filter_le.
Qed.

(** ** A longer alternative road *)
(** In the following we goes along the proof of Schützenberger theorem
    but we end up duplicating the whole proof: compare the statement and proofs
    of
    - [sfiltergtn_invstd] below with [invstd_catgtn]
    - [sfilterleq_invstd] below with [invstd_catleq]
 *)

Lemma sfiltergtn_invstd w n :
  n <= size w -> sfiltergtn n (invstd (std w)) = invstd (std (take n w)).
Proof.
move=> Hn.
have Hsftstd : is_std (sfiltergtn n (invstd (std w))).
  apply: (@sfiltergtn_is_std (invstd (std w)) n).
  by apply: invstd_is_std; exact: std_is_std.
suff Heqinv : invstd (sfiltergtn n (invstd (std w))) = std (take n w).
  by rewrite -Heqinv invstdK.
apply/esym/eqP/stdP; apply: StdSpec; first exact: invstd_is_std.
have Hstdiw : is_std (invstd (std w)).
  by apply: invstd_is_std; exact: std_is_std.
apply/eq_invP; split.
  rewrite size_takel // size_invstd size_sfiltergtn //.
  by rewrite size_invstd size_std (minn_idPl Hn).
move=> i j /andP [Hij]; rewrite size_takel // => Hj.
have Hi := leq_ltn_trans Hij Hj.
rewrite leEnat /=.
do 2 (rewrite nth_mkseq; last rewrite size_sfiltergtn //;
        last by rewrite size_invstd size_std (minn_idPl Hn)).
rewrite index_leq_filter // !nth_take //.
rewrite (index_invstd (std_is_std w)); first last.
  by apply (leq_trans Hi); rewrite size_std.
rewrite (index_invstd (std_is_std w)); first last.
  by apply (leq_trans Hj); rewrite size_std.
have /eq_invP := (eq_inv_std w) => [] [_]; apply.
by rewrite Hij (leq_trans Hj Hn).
Qed.

Lemma sfilterleq_invstd w n :
  n <= size w -> sfilterleq n (invstd (std w)) = invstd (std (drop n w)).
Proof.
move=> Hn.
have Hsftstd : is_std (sfilterleq n (invstd (std w))).
  apply: (@sfilterleq_is_std (invstd (std w)) n).
  by apply: invstd_is_std; exact: std_is_std.
suff Heqinv : invstd (sfilterleq n (invstd (std w))) = std (drop n w).
  by rewrite -Heqinv invstdK.
apply/esym/eqP/stdP; apply: StdSpec; first exact: invstd_is_std.
have Hstdiw : is_std (invstd (std w)).
  by apply: invstd_is_std; exact: std_is_std.
apply/eq_invP; split.
  rewrite size_drop size_invstd size_sfilterleq //.
  by rewrite size_invstd size_std.
move=> i j /andP [Hij]; rewrite size_drop => Hj.
rewrite leEnat /=.
have Hi := leq_ltn_trans Hij Hj.
do 2 (rewrite nth_mkseq; last by rewrite size_sfilterleq // size_invstd size_std).
rewrite !index_sfilterleq !nth_drop.
rewrite index_leq_filter ?leq_addl //.
do 2 (rewrite (index_invstd (std_is_std w));
      last by rewrite size_std addnC -ltn_subRL).
have /eq_invP := (eq_inv_std w) => [] [_].
rewrite ![_ + n]addnC; apply.
by rewrite leq_add2l Hij /= -ltn_subRL.
Qed.

(** Yet another form of Schützenberger theorem *)
Theorem LRrule_langQ t1 t2 w :
  is_stdtab t1 ->
  (exists u v, [/\ w = u ++ v, u \in langQ t1 & v \in langQ t2]) <->
  (exists t, LRtriple t1 t2 t /\ w \in langQ t).
Proof.
move=> Hstd1.
split => [[u] [v] [Hcat]| [t] []]; rewrite !langQE.
- move=> /eqP Ht1 /eqP Ht2.
  exists (RS (invstd (std (u ++ v)))); split.
  + apply: (LRTriple Ht1 Ht2 erefl).
    exact: invstd_cat_in_shsh.
  + by rewrite Hcat langQE.
- move=> [/= p1 p2 p Ht1 <-{t2} <-{t} Hsh].
  move: Hstd1; rewrite -Ht1 RSstdE => Hstd1 {Ht1 t1}.
  rewrite -plactic_RS => Hpl.
  have := Hsh; rewrite mem_shsh // => /andP [/eqP Hp1 /eqP Hp2].
  have Hszp1: size p1 <= size w.
    move/size_plact: Hpl; rewrite size_invstd size_std => ->.
    by rewrite -Hp1 size_filter count_size.
  have HgtnE : (fun x => (x < size p1)%O) =1 gtn (size p1).
    by move=> x /=; rewrite ltEnat.
  have HleqE : (fun x => (x >= size p1)%O) =1 leq (size p1).
    by move=> x /=; rewrite leEnat.
  exists (take (size p1) w), (drop (size p1) w); split.
  + by rewrite cat_take_drop.
  + rewrite langQE -plactic_RS -sfiltergtn_invstd // -{2}Hp1.
    rewrite /sfiltergtn /= -!(eq_filter HgtnE).
    exact: plactic_filter_gt.
  + rewrite langQE -plactic_RS -sfilterleq_invstd // -{1}Hp2.
    rewrite /sfilterleq /= -!(eq_filter HleqE).
    apply: plact_map_in_incr; last exact: plactic_filter_le.
    move=> /= x y.
    rewrite !mem_filter !leEnat !ltEnat /= => /andP [Hx _]  /andP [Hy _] Hxy.
    by rewrite -(ltn_add2r (size p1)) ?subnK.
Qed.

(** Alternative proof from [LRtriple_cat_equiv] *)
Theorem LRrule_langQ_alternate t1 t2 w :
  is_stdtab t1 -> is_stdtab t2 ->
  (exists u v, [/\ w = u ++ v, u \in langQ t1 & v \in langQ t2]) <->
  (exists t, LRtriple t1 t2 t /\ w \in langQ t).
Proof.
move=> H1 H2; have H := LRtriple_cat_equiv H1 H2.
split=> [[u] [v] [Hcat Hu Hv]| [t] [Htriple Hw]].
- have {}/H [_ _] : u \in langQ t1 /\ v \in langQ t2 by split.
  by rewrite Hcat.
- have:= cat_take_drop (size_tab t1) w.
  set u1 := take (size_tab t1) w; set u2 := drop (size_tab t1) w => Hcat.
  have /= /andP [_ /eqP Hsz] := is_stdtab_of_n_LRtriple H1 H2 Htriple.
  have Hszw : size w = size_tab t.
    move: Hw; rewrite langQE => /eqP <-.
    by rewrite size_RS size_invstd size_std.
  have : [/\ size u1 = size_tab t1, size u2 = size_tab t2
        & exists t : seq (seq nat), LRtriple t1 t2 t /\ u1 ++ u2 \in langQ t].
    split.
    - by rewrite size_takel // Hszw Hsz leq_addr.
    - by rewrite size_drop Hszw Hsz addnC addnK.
    - by exists t; rewrite Hcat.
  rewrite -H => [] [Hu1 Hu2].
  by exists u1, u2; rewrite Hcat.
Qed.

(** ** Conjugating [LRtriple] *)
Theorem LRtriple_conj t1 t2 t :
  is_stdtab t1 -> is_stdtab t2 -> is_stdtab t ->
  LRtriple t1 t2 t -> LRtriple (conj_tab t1) (conj_tab t2) (conj_tab t).
Proof using .
move=> Ht1 Ht2 Ht [p1 p2 p Hp1 Hp2 Hp].
rewrite mem_shsh; last by rewrite -RSstdE Hp1.
move=> /= /andP [/eqP Hsh1 /eqP Hsh2].
apply: (@LRTriple _ _ _ (rev p1) (rev p2) (rev p)).
- rewrite RS_rev_uniq; last by apply std_uniq; rewrite -RSstdE Hp1.
  by rewrite Hp1.
- rewrite RS_rev_uniq; last by apply std_uniq; rewrite -RSstdE Hp2.
  by rewrite Hp2.
- rewrite RS_rev_uniq; last by apply std_uniq; rewrite -RSstdE Hp.
  by rewrite Hp.
- rewrite mem_shsh; first last.
    rewrite /is_std size_rev perm_rev.
    by rewrite -/(is_std _)  -RSstdE Hp1.
  by rewrite /= size_rev !filter_rev map_rev Hsh1 Hsh2 !eq_refl.
Qed.

Theorem pred_LRtriple_conj t1 t2 t :
  is_stdtab t1 -> is_stdtab t2 -> is_stdtab t ->
  pred_LRtriple t1 t2 t = pred_LRtriple (conj_tab t1) (conj_tab t2) (conj_tab t).
Proof using .
move=> Ht1 Ht2 Ht.
have Hc1 := is_stdtab_conj Ht1.
have Hc2 := is_stdtab_conj Ht2.
have Hc := is_stdtab_conj Ht.
apply/idP/idP => /LRtripleP H; apply/LRtripleP => //=.
- apply: LRtriple_conj => //; exact: H.
- rewrite -[t1]conj_tabK; last by move: Ht1 => /andP [].
  rewrite -[t2]conj_tabK; last by move: Ht2 => /andP [].
  rewrite -[t]conj_tabK;  last by move: Ht  => /andP [].
  apply: LRtriple_conj => //; exact: H.
Qed.

End LRTriple.

Arguments langQ {disp} [Alph].

(*
(* First non trivial example of LR rule *)
Eval compute in map (@shape nat_ordType)
                    (filter
                       (pred_LRtriple [:: [:: 0; 1]; [:: 2]] [:: [:: 0; 1]; [:: 2]])
                       (enum_stdtabn 6)).

Eval compute in count
                  (pred_LRtriple [:: [:: 0; 1]; [:: 2]] [:: [:: 0; 1]; [:: 2]])
                  (enum_stdtabsh [:: 3; 2; 1]).

Eval compute in count
                  (pred_LRtriple_fast [:: [:: 0; 1]; [:: 2]] [:: [:: 0; 1]; [:: 2]])
                  (enum_stdtabsh [:: 3; 2; 1]).

Eval compute in count
                  (pred_LRtriple_fast [:: [:: 0; 1]; [:: 2; 3]] [:: [:: 0; 1]; [:: 2; 3]])
                  (enum_stdtabsh [:: 4; 4]).
*)


From Hammer Require Import Hammer.

Require ClassicalFacts.
Require FunctionalExtensionality.

Lemma functional_extensionality_dep:
forall {A: Type} {B : A -> Type} (f g : forall x : A, B x),
(forall x, f x = g x) -> f = g.
Proof. hammer_hook "Axioms" "Axioms.functional_extensionality_dep". exact (@FunctionalExtensionality.functional_extensionality_dep). Qed.

Lemma functional_extensionality:
forall {A B: Type} (f g : A -> B), (forall x, f x = g x) -> f = g.
Proof. hammer_hook "Axioms" "Axioms.functional_extensionality". exact (@FunctionalExtensionality.functional_extensionality). Qed.

Lemma extensionality:
forall {A B: Type} (f g : A -> B),  (forall x, f x = g x) -> f = g.
Proof. hammer_hook "Axioms" "Axioms.extensionality". exact (@functional_extensionality). Qed.

Axiom proof_irr: ClassicalFacts.proof_irrelevance.

Arguments proof_irr [A].


From stdpp Require Import prelude.
From Coq Require Import FunctionalExtensionality.
From sets Require Import Ensemble.
From ARL Require Import TransitionSystem RuleBasedTransitionSystem.

Definition substitution `{TransitionSystem} (Name : Type) : Type := Name -> quantified_term (Name := Name).

Section sec_matching.

Context
  `{TransitionSystem}
  (NameSet : Type)
  `{FinSet Name NameSet}.

Definition substitution_dependent_vars
  (s : substitution Name) (interesting_vars dependent_vars : NameSet) : Prop :=
  set_Forall (fun x => pattern_dependent_vars NameSet (s x) dependent_vars) interesting_vars.

Definition substitute_term (s : substitution Name) (t : quantified_term) : quantified_term :=
  fun v => t (fun x => s x v).

Definition substitute_pattern (s : substitution Name) (p : quantified_pattern) : quantified_pattern :=
  fun v => p (fun x => s x v).

Lemma substitute_term_dependent_vars s (t : quantified_term) t_vars s_vars :
  pattern_dependent_vars NameSet t t_vars ->
  substitution_dependent_vars s t_vars s_vars ->
  pattern_dependent_vars NameSet (substitute_term s t) s_vars.
Proof.
  intros Ht_deps Hs_deps v1 v2 Heqvars.
  apply Ht_deps.
  constructor; intros x Hx.
  by apply (Hs_deps x Hx _ _ Heqvars).
Qed.

Lemma substitute_pattern_dependent_vars s (t : quantified_pattern) t_vars s_vars :
  pattern_dependent_vars NameSet t t_vars ->
  substitution_dependent_vars s t_vars s_vars ->
  pattern_dependent_vars NameSet (substitute_pattern s t) s_vars.
Proof.
  intros Ht_deps Hs_deps v1 v2 Heqvars.
  apply Ht_deps.
  constructor; intros x Hx.
  by apply (Hs_deps x Hx _ _ Heqvars).
Qed.

Record Substitution :=
{
  sub :> substitution Name;
  sub_from : NameSet;
  sub_to : NameSet;
  sub_dep_vars : substitution_dependent_vars sub sub_from sub_to;
  sub_free_vars : forall x, x ∉ sub_from -> sub x = quantified_variable x;
}.

Lemma Substitute_term_dependent_vars s (t : quantified_term):
  pattern_dependent_vars NameSet t (sub_from s) ->
  pattern_dependent_vars NameSet (substitute_term s t) (sub_to s).
Proof.
  intros.
  by eapply substitute_term_dependent_vars, s.
Qed.

Lemma Substitute_pattern_dependent_vars s (t : quantified_pattern):
  pattern_dependent_vars NameSet t (sub_from s) ->
  pattern_dependent_vars NameSet (substitute_pattern s t) (sub_to s).
Proof.
  intros.
  by eapply substitute_pattern_dependent_vars, s.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing Feq %\ensuremath{\approx}% #≈# *)

Require Export CoRN.reals.Intervals.
Require Export CoRN.tactics.DiffTactics1.

Section Definitions.

(**
* Equality of Partial Functions

** Definitions

In some contexts (namely when quantifying over partial functions) we
need to refer explicitly to the subsetoid of elements satisfying a
given predicate rather than to the predicate itself.  The following
definition makes this possible.
*)

Definition subset (P : IR -> CProp) : CSetoid := Build_SubCSetoid IR P.

(**
The core of our work will revolve around the following fundamental
notion: two functions are equal in a given domain (predicate) iff they
coincide on every point of that domain#. #%\footnote{%Notice that,
according to our definition of partial function, it is equivalent to
prove the equality for every proof or for a specific proof.  Typically
it is easier to consider a generic case%.}%.  This file is concerned
with proving the main properties of this equality relation.
*)

Definition Feq P (F G : PartIR) := included P (Dom F) and included P (Dom G) and
 (forall x, P x -> forall Hx Hx', F x Hx [=] G x Hx').

(**
Notice that, because the quantification over the proofs is universal,
we must require explicitly that the predicate be included in the
domain of each function; otherwise the basic properties of equality
(like, for example, transitivity) would fail to hold#. #%\footnote{%To
see this it is enough to realize that the empty function would be
equal to every other function in every domain.%}.% The way to
circumvent this would be to quantify existentially over the proofs;
this, however, would have two major disadvantages: first, proofs of
equality would become very cumbersome and clumsy; secondly (and most
important), we often need to prove the inclusions from an equality
hypothesis, and this definition allows us to do it in a very easy way.
Also, the pointwise equality is much nicer to use from this definition
than in an existentially quantified one.
*)

End Definitions.

Section Equality_Results.

(**
** Properties of Inclusion

We will now prove the main properties of the equality relation.

%\begin{convention}% Let [I,R:IR->CProp] and [F,G:PartIR], and denote
by [P] and [Q], respectively, the domains of [F] and [G].
%\end{convention}%
*)

Variable I : IR -> CProp.
Variables F G : PartIR.

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
(* end hide *)

Variable R : IR -> CProp.

(**
We start with two lemmas which make it much easier to prove and use
this definition:
*)

Lemma eq_imp_Feq : included I P -> included I Q ->
 (forall x, I x -> forall Hx Hx', F x Hx [=] G x Hx') -> Feq I F G.
Proof.
 intros.
 split.
  assumption.
 split; assumption.
Qed.

Lemma Feq_imp_eq : Feq I F G -> forall x, I x -> forall Hx Hx', F x Hx [=] G x Hx'.
Proof.
 intros H x Hx1 Hx Hx'.
 elim H; intros H0 H1.
 elim H1; auto.
Qed.

Lemma included_IR : included I (fun x : IR => True).
Proof.
 split.
Qed.

End Equality_Results.

#[global]
Hint Resolve included_IR : included.

Section Some_More.

(**
If two function coincide on a given subset then they coincide in any smaller subset.
*)

Lemma included_Feq : forall P Q F G, included P Q -> Feq Q F G -> Feq P F G.
Proof.
 intros P Q F G H H0.
 elim H0; clear H0; intros H0 H1.
 elim H1; clear H1; intros H1 H2.
 apply eq_imp_Feq.
   eapply included_trans.
    apply H.
   assumption.
  eapply included_trans.
   apply H.
  assumption.
 intros; apply H2.
 apply H; assumption.
Qed.

End Some_More.

Section Away_from_Zero.

Section Definitions.

(**
** Away from [0]

Before we prove our main results about the equality we have to do some
work on division.  A function is said to be bounded away from zero in
a set if there exists a positive lower bound for the set of absolute
values of its image of that set.

%\begin{convention}% Let [I : IR->CProp], [F : PartIR] and denote by [P]
the domain of [F].
%\end{convention}%
*)

Variable I : IR -> CProp.
Variable F : PartIR.
(* begin hide *)
Let P := Dom F.
(* end hide *)

Definition bnd_away_zero := included I P and {c : IR | [0] [<] c |
  forall y Hy, (I y) -> c [<=] AbsIR (F y Hy)}.

(**
If [F] is bounded away from zero in [I] then [F] is necessarily apart from zero in [I]; also this means that [I] is included in the domain of [{1/}F].
*)

(* begin show *)
Hypothesis Hf : bnd_away_zero.
(* end show *)

Lemma bnd_imp_ap_zero : forall x Hx, (I x) -> F x Hx [#] [0].
Proof.
 intros.
 apply AbsIR_cancel_ap_zero.
 apply Greater_imp_ap.
 elim Hf; intros.
 inversion_clear b.
 eapply less_leEq_trans; auto.
 auto.
Qed.

Lemma bnd_imp_inc_recip : included I (Dom {1/}F).
Proof.
 intros x Hx.
 elim Hf; intros H H0.
 split.
  apply (H x Hx).
 intro.
 apply bnd_imp_ap_zero; auto.
Qed.

Lemma bnd_imp_inc_div : forall G, included I (Dom G) -> included I (Dom (G{/}F)).
Proof.
 intros G HG x Hx.
 split; auto.
 elim Hf; intros H0 H1.
 split.
  apply (H0 x Hx).
 intro.
 apply bnd_imp_ap_zero; auto.
Qed.

End Definitions.

(**
Boundedness away from zero is preserved through restriction of the set.

%\begin{convention}% Let [F] be a partial function and [P, Q] be predicates.
%\end{convention}%
*)

Variable F : PartIR.
Variables P Q : IR -> CProp.

Lemma included_imp_bnd : included Q P -> bnd_away_zero P F -> bnd_away_zero Q F.
Proof.
 intros H H0.
 elim H0; clear H0; intros H1 H2; split.
  apply included_trans with P; auto.
 elim H2; intros c Hc Hc'.
 exists c; auto.
Qed.

Lemma FRestr_bnd : forall (HP : pred_wd _ P) (H : included P (Dom F)),
 included Q P -> bnd_away_zero Q F -> bnd_away_zero Q (Frestr HP H).
Proof.
 intros HP H H0 H1.
 elim H1; clear H1; intros H2 H3; split.
  auto.
 elim H3; intro c; intros.
 exists c; simpl in |- *; auto.
Qed.

(**
A function is said to be bounded away from zero everywhere if it is bounded away from zero in every compact subinterval of its domain; a similar definition is made for arbitrary sets, which will be necessary for future work.
*)

Definition bnd_away_zero_everywhere G := forall a b Hab,
  included (compact a b Hab) (Dom G) -> bnd_away_zero (compact a b Hab) G.

Definition bnd_away_zero_in_P := forall a b Hab,
  included (compact a b Hab) P -> bnd_away_zero (compact a b Hab) F.

(**
An immediate consequence:
*)

Lemma bnd_in_P_imp_ap_zero : pred_wd _ P -> bnd_away_zero_in_P ->
 forall x, P x -> forall Hx, F x Hx [#] [0].
Proof.
 intros H H0 x H1 Hx.
 apply bnd_imp_ap_zero with (Compact (leEq_reflexive _ x)).
  apply H0.
  red in |- *; intros x0 H2.
  cut (x [=] x0); intros.
   apply H with x; auto.
  inversion_clear H2; apply leEq_imp_eq; auto.
 split; apply leEq_reflexive.
Qed.

Lemma FRestr_bnd' : forall (HP : pred_wd _ P) (H : included P (Dom F)),
 bnd_away_zero_everywhere F -> bnd_away_zero_everywhere (Frestr HP H).
Proof.
 intros HP H H0 a b Hab H1.
 elim (H0 a b Hab); intros.
  split.
   auto.
  elim b0; intro c; intros.
  exists c; simpl in |- *; auto.
 apply included_trans with P; simpl in H1; auto.
Qed.

End Away_from_Zero.

#[global]
Hint Resolve bnd_imp_inc_recip bnd_imp_inc_div: included.
#[global]
Hint Immediate bnd_in_P_imp_ap_zero: included.

(**
** The [FEQ] tactic
This tactic splits a goal of the form [Feq I F G] into the three subgoals
[included I (Dom F)], [included I (Dom G)] and [forall x, F x [=] G x]
and applies [Included] to the first two and [rational] to the third.
*)

(* begin hide *)
Ltac FEQ := apply eq_imp_Feq;
   [ Included | Included | intros; try (simpl in |- *; rational) ].
(* end hide *)

Section More_on_Equality.

(**
** Properties of Equality

We are now finally able to prove the main properties of the equality relation.  We begin by showing it to be an equivalence relation.

%\begin{convention}% Let [I] be a predicate and [F, F', G, G', H] be
partial functions.
%\end{convention}%
*)

Variable I : IR -> CProp.

Section Feq_Equivalence.

Variables F G H : PartIR.

Lemma Feq_reflexive : included I (Dom F) -> Feq I F F.
Proof.
 intro; FEQ.
Qed.

Lemma Feq_symmetric : Feq I F G -> Feq I G F.
Proof.
 intro H0.
 elim H0; intros H' H1.
 elim H1; intros incF incG.
 FEQ; algebra.
Qed.

Lemma Feq_transitive : Feq I F G -> Feq I G H -> Feq I F H.
Proof.
 intro H0.
 elim H0; intros incF H'.
 elim H'; intros incG H1.
 clear H0 H'.
 intro H0.
 elim H0; intros incG' H'.
 elim H'; intros incH H2.
 clear H0 H'.
 FEQ.
 Step_final (G x (incG x X)).
Qed.

End Feq_Equivalence.

Section Operations.

(**
Also it is preserved through application of functional constructors and restriction.
*)

Variables F F' G G' : PartIR.

Lemma Feq_plus : Feq I F F' -> Feq I G G' -> Feq I (F{+}G) (F'{+}G').
Proof.
 intros H0 H1.
 elim H0; intros incF H0'.
 elim H0'; clear H0 H0'; intros incG H2.
 elim H1; intros incF' H1'.
 elim H1'; clear H1 H1'; intros incG' H1.
 FEQ; simpl in |- *; algebra.
Qed.

Lemma Feq_inv : Feq I F F' -> Feq I {--}F {--}F'.
Proof.
 intro H0.
 elim H0; intros incF H0'.
 elim H0'; clear H0 H0'; intros incF' H1.
 FEQ; simpl in |- *; algebra.
Qed.

Lemma Feq_minus : Feq I F F' -> Feq I G G' -> Feq I (F{-}G) (F'{-}G').
Proof.
 intros H0 H1.
 elim H0; intros incF H0'.
 elim H0'; clear H0 H0'; intros incG H2.
 elim H1; intros incF' H1'.
 elim H1'; clear H1 H1'; intros incG' H0.
 FEQ; simpl in |- *; algebra.
Qed.

Lemma Feq_mult : Feq I F F' -> Feq I G G' -> Feq I (F{*}G) (F'{*}G').
Proof.
 intros H0 H1.
 elim H0; intros incF H0'.
 elim H0'; clear H0 H0'; intros incG H2.
 elim H1; intros incF' H1'.
 elim H1'; clear H1 H1'; intros incG' H0.
 FEQ; simpl in |- *; algebra.
Qed.

Lemma Feq_nth : forall n : nat, Feq I F F' -> Feq I (F{^}n) (F'{^}n).
Proof.
 intros n H0.
 elim H0; intros incF H0'.
 elim H0'; clear H0 H0'; intros incF' H1.
 FEQ.
 astepl (F x Hx[^]n); Step_final (Part F' x Hx'[^]n).
Qed.

Lemma Feq_recip : bnd_away_zero I F -> Feq I F F' -> Feq I {1/}F {1/}F'.
Proof.
 intros Hbnd H0.
 elim H0; intros incF H0'.
 elim H0'; clear H0 H0'; intros incF' H1.
 FEQ.
  apply included_FRecip.
   auto.
  intros x H Hx; apply ap_wdl_unfolded with (F x (incF x H)).
   apply bnd_imp_ap_zero with I; assumption.
  auto.
 simpl in |- *; algebra.
Qed.

Lemma Feq_recip' : bnd_away_zero I F -> Feq I F' F -> Feq I {1/}F' {1/}F.
Proof.
 intros.
 apply Feq_symmetric; apply Feq_recip.
  assumption.
 apply Feq_symmetric; assumption.
Qed.

Lemma Feq_div : bnd_away_zero I G ->
 Feq I F F' -> Feq I G G' -> Feq I (F{/}G) (F'{/}G').
Proof.
 intros Hbnd H0 H1.
 elim H0; intros incF H0'.
 elim H0'; clear H0 H0'; intros incF' H2.
 elim H1; intros incG H1'.
 elim H1'; clear H1 H1'; intros incG' H0.
 FEQ.
  apply included_FDiv; auto.
  intros x H Hx; apply ap_wdl_unfolded with (G x (incG x H)).
   apply bnd_imp_ap_zero with I; assumption.
  auto.
 simpl in |- *; algebra.
Qed.

Lemma Feq_div' : bnd_away_zero I G ->
 Feq I F' F -> Feq I G' G -> Feq I (F'{/}G') (F{/}G).
Proof.
 intros.
 apply Feq_symmetric; apply Feq_div.
   assumption.
  apply Feq_symmetric; assumption.
 apply Feq_symmetric; assumption.
Qed.

Lemma Feq_comp : forall (J : IR -> CProp),
(forall x Hx, I x -> J (F x Hx)) -> (forall x Hx, I x -> J (F' x Hx)) ->
Feq I F F' -> Feq J G G' -> Feq I (G[o]F) (G'[o]F').
Proof.
 intros J Hmap Hmap' [HF0 [HF1 HF2]] [HG0 [HG1 HG2]].
 repeat split; try (apply included_FComp; Included).
 intros x Habx [Hx0 Hx1] [Hx'0 Hx'1].
 simpl.
 assert (F x Hx0[=]F' x Hx'0).
  apply HF2.
  Included.
 assert (X:Dom G' (F x Hx0)).
  eapply dom_wd.
   apply Hx'1.
  apply eq_symmetric; assumption.
 apply eq_transitive with (G' (F x Hx0) X).
  apply HG2.
  Included.
 apply pfwdef.
 assumption.
Qed.

(**
Notice that in the case of division we only need to require boundedness away from zero for one of the functions (as they are equal); thus the two last lemmas are stated in two different ways, as according to the context one or the other condition may be easier to prove.

The restriction of a function is well defined.
*)

Lemma FRestr_wd : forall Iwd Hinc, Feq I F (Frestr (F:=F) (P:=I) Iwd Hinc).
Proof.
 intros.
 FEQ.
Qed.

(**
The image of a set is extensional.
*)

Lemma fun_image_wd : Feq I F G -> forall x, fun_image F I x -> fun_image G I x.
Proof.
 intros H x H0.
 elim H; clear H; intros H H1.
 elim H1; clear H1; intros H2 H3.
 elim H0; intros y Hy.
 exists y.
 elim Hy; intros H4 H1.
 elim H1; clear Hy H1; intros H5 H6.
 split; auto.
 split; auto.
 intro; Step_final (F y H5).
Qed.

End Operations.

End More_on_Equality.

Section Nth_Power.

(**
** Nth Power

We finish this group of lemmas with characterization results for the
power function (similar to those already proved for arbitrary rings).
The characterization is done at first pointwise and later using the
equality relation.

%\begin{convention}% Let [F] be a partial function with domain [P] and
[Q] be a predicate on the real numbers assumed to be included in [P].
%\end{convention}%
*)

Variable F : PartIR.
(* begin hide *)
Let P := Dom F.
(* end hide *)

Variable Q : IR -> CProp.
Hypothesis H : included Q (fun x : IR => True).
Hypothesis Hf : included Q (Dom F).

Lemma FNth_zero : forall x, Q x -> forall Hx Hx', [-C-][1] x Hx [=] (F{^}0) x Hx'.
Proof.
 intros.
 algebra.
Qed.

Variable n : nat.
Hypothesis H' : included Q (Dom (F{*}F{^}n)).

Lemma FNth_mult : forall x, Q x -> forall Hx Hx', (F{*}F{^}n) x Hx [=] (F{^}S n) x Hx'.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply mult_commutes.
 apply mult_wd.
  rational.
 change (F x (ProjIR2 Hx) [^]n [=] F x Hx'[^]n) in |- *.
 apply nexp_wd; rational.
Qed.

End Nth_Power.

Section Strong_Nth_Power.

(**
%\begin{convention}% Let [a,b] be real numbers such that [I := [a,b]]
is included in the domain of [F].
%\end{convention}%
*)

Variables a b : IR.
Hypothesis Hab : a [<=] b.
(* begin hide *)
Let I := compact a b Hab.
(* end hide *)

Variable F : PartIR.
Hypothesis incF : included I (Dom F).

Lemma FNth_zero' : Feq I [-C-][1] (F{^}0).
Proof.
 FEQ.
Qed.

Lemma FNth_mult' : forall n, Feq I (F{*}F{^}n) (F{^}S n).
Proof.
 intro; FEQ.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply mult_commutes.
 apply bin_op_wd_unfolded.
  rational.
 change (F x (ProjIR2 Hx) [^]n [=] F x Hx'[^]n) in |- *.
 apply nexp_wd; rational.
Qed.

End Strong_Nth_Power.


(************************************************************************)
(* Copyright 2008-2010 Milad Niqui                                      *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 3                          *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl-3.0.html>         *)
(************************************************************************)

Require Export Bisimulation.

(** Module type for weakly final coalgebras. *)

Module Type Weakly_Final_Coalgebra.

Include Bisimulation_For_Coalgebra.

Definition is_weakly_final (w:F_coalgebra) := forall (S0:F_coalgebra),
   { F_unfold_ : S0.(states) -> w.(states) |
     forall s0, w.(transition) (F_unfold_ s0) = lift_F_ _ _ F_unfold_ (S0.(transition) s0)}.

Parameter w:F_coalgebra.

Axiom w_is_weakly_final:is_weakly_final w.

Definition F_unfold (S0:F_coalgebra) := proj1_sig (w_is_weakly_final S0).

Definition commutativity_F_unfold (S0:F_coalgebra) :forall (x:S0.(states)), w.(transition) (F_unfold S0 x) = (lift_F_ _ _ (F_unfold S0)) (S0.(transition) x) := proj2_sig (w_is_weakly_final S0).

Definition bisimilar := maximal_bisimulation w w.

Notation " A (=) B " := (bisimilar A B) (at level 70).

Axiom F_unique:forall (S0:F_coalgebra) f g,
   (forall (s0: S0.(states)), w.(transition) (f s0) = (lift_F_ _ _ f) (S0.(transition) s0) ) ->
   (forall (s0: S0.(states)), w.(transition) (g s0) = (lift_F_ _ _ g) (S0.(transition) s0) ) ->
   forall s, f s(=) g s.

Axiom lift_F_extensionality_bisim: forall (X:Set) (f0 f1:X->w.(states)) fx, (forall x, f0 x (=) f1 x) -> rel_image_lift_F_ _ _ bisimilar (lift_F_  _ _ f0 fx) (lift_F_ _ _ f1 fx).

End Weakly_Final_Coalgebra.

Module Weakly_Final_Coalgebra_theory (MB:Weakly_Final_Coalgebra).

Import MB.
Export MB.

Include (Bisimulation_theory MB).

Lemma ordinary_coinduction:forall (R: w.(states)-> w.(states)->Prop) x y,
    R x y-> is_F_bisimulation _ _ R -> x (=) y.
Proof.
 intros R x y hyp_R hyp_bisim; apply bisimulation_maximal_bisimulation with R; trivial.
Qed.

Lemma strong_ordinary_coinduction:forall  (R: w.(states)-> w.(states)->Set) x y,
    R x y-> is_F_bisimulation_strong _ _ R -> x (=) y.
Proof.
 intros R x y hyp_R hyp_bisim; apply bisimulation_strong_maximal_bisimulation with R; trivial.
Qed.

Lemma F_unfold_injectve (S0 : F_coalgebra) x y : x = y -> (F_unfold S0) x = (F_unfold S0) y.
Proof.
 intros hyp1; subst x; reflexivity.
Qed.

Lemma F_unfold_bisim_congruence (S0:F_coalgebra) R x y : (is_F_bisimulation S0 S0 R) -> R x y -> (F_unfold S0) x (=) (F_unfold S0) y.
Proof.
 intros [gamma hyp_gamma] hyp1.
 change (  (fun s1s2 => F_unfold S0 (fst (proj1_sig s1s2))) (exist (fun s1s2=> R (fst s1s2) (snd s1s2)) (x,y) hyp1) (=)
           (fun s1s2 => F_unfold S0 (snd (proj1_sig s1s2))) (exist (fun s1s2=> R (fst s1s2) (snd s1s2)) (x,y) hyp1)   ).
 apply (F_unique (Build_F_coalgebra {s1s2 : states S0 * states S0 | R (fst s1s2) (snd s1s2)} gamma));
 intros s1s2hyp; destruct (hyp_gamma s1s2hyp) as [H1 H2];
 [ rewrite (commutativity_F_unfold S0 (fst (proj1_sig s1s2hyp))); rewrite <- H1
 | rewrite (commutativity_F_unfold S0 (snd (proj1_sig s1s2hyp))); rewrite <- H2]
 ; rewrite lift_F_compose; apply lift_F_extensionality; trivial.
Qed.

Lemma F_unfold_morphism (S0:F_coalgebra) x y : (maximal_bisimulation S0 S0) x y -> (F_unfold S0) x (=) (F_unfold S0) y.
Proof.
 intros hyp1;
 apply (F_unfold_bisim_congruence _ (maximal_bisimulation S0 S0)); trivial;
 apply maximal_bisimulation_is_bisimulation.
Qed.

Lemma F_unfold_morphism_inversion (S0:F_coalgebra) x y : (F_unfold S0) x (=) (F_unfold S0) y -> (maximal_bisimulation S0 S0) x y.
Proof.
 intros hyp1.
 set (f:=F_unfold S0).
 set (f_inv_delta:=fun x y=> f x (=) f y).
 apply bisimulation_maximal_bisimulation with f_inv_delta.
  assumption.
  apply inverse_image_F_bisimulation_is_F_bisimulation with (S2 := w).
   subst f; intros s0; symmetry; apply (commutativity_F_unfold S0 s0).
   apply maximal_bisimulation_is_bisimulation.
Qed.

Add Parametric Morphism (S0:F_coalgebra) : (F_unfold S0)
 with signature  (maximal_bisimulation S0 S0) ==> (maximal_bisimulation w w) as F_unfold_Morphism.
Proof.
 apply F_unfold_morphism.
Qed.

Definition coconstructor : F_ w.(states) -> w.(states) := F_unfold (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition))).

Lemma coconstructor_destructor: forall x, coconstructor (w.(transition) x) (=) x.
Proof.
 intros x.
 generalize (commutativity_F_unfold (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition)))).
 simpl in *; fold coconstructor.
 intros hyp_cocon.
 apply (F_unique w (fun x=>coconstructor (w.(transition) x)) (fun x=>x)); intros x0.
  rewrite (hyp_cocon (w.(transition) x0)); rewrite lift_F_compose; trivial.
  apply lift_F_id.
Qed.

Lemma destructor_equal_inversion: forall x1 x2, w.(transition) x1 = w.(transition) x2 -> x1 (=) x2.
Proof.
 intros x1 x2 hyp1.
 rewrite <- (coconstructor_destructor x1).
 rewrite <- (coconstructor_destructor x2).
 apply F_unfold_morphism.
 rewrite hyp1.
 apply refl_bisimilar.
Qed.

Lemma destructor_maximum_bisimulation_inversion: forall x1 x2,
   maximal_bisimulation (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition)))
                        (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition))) (w.(transition) x1) (w.(transition) x2) ->
     x1 (=) x2.
Proof.
 intros x1 x2 hyp1.
 rewrite <- (coconstructor_destructor x1).
 rewrite <- (coconstructor_destructor x2).
 apply F_unfold_morphism; assumption.
Qed.

Lemma destructor_morphism : forall x y, x(=)y ->
   maximal_bisimulation (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition)))
                        (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition)))
                        (w.(transition) x) (w.(transition) y).
Proof.
 intros x y hyp.
 apply F_unfold_morphism_inversion.
 fold coconstructor.
 do 2 rewrite coconstructor_destructor; trivial.
Qed.

Lemma rel_image_maximal_bisimulation_inversion: forall fw1 fw2,
                        rel_image_lift_F_ _ _ bisimilar fw1 fw2 ->
   maximal_bisimulation (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition)))
                        (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition))) fw1 fw2.
Proof.
 intros fw1 fw2 (x & y & hyp1 & hyp2 & hyp3).
 subst fw1 fw2; trivial; apply destructor_morphism; trivial.
Qed.

Add Morphism w.(transition)
 with signature  (maximal_bisimulation w w) ==>
                 (maximal_bisimulation (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition)))
                                       (Build_F_coalgebra (F_ w.(states)) (lift_F_ _ _ w.(transition))))
   as destructor_Morphism.
Proof.
 apply destructor_morphism.
Qed.

Lemma rel_image_bisimilar_transitive: forall fw1 fw2 fw3,
                        rel_image_lift_F_ _ _ bisimilar fw1 fw2 ->
                        rel_image_lift_F_ _ _ bisimilar fw2 fw3 ->
                        rel_image_lift_F_ _ _ bisimilar fw1 fw3.
Proof.
 intros fs1 fs2 fs3 (x1 & y1 & hyp11 & hyp12 & hyp13) (x2 & y2 & hyp21 & hyp22 & hyp23).
 red.
 exists x1; exists y2.
 repeat split; trivial.
 rewrite hyp11.
 rewrite <- hyp21.
 symmetry.
 apply destructor_equal_inversion.
 rewrite <- hyp13.
 rewrite <- hyp22; trivial.
Qed.

End Weakly_Final_Coalgebra_theory.


Require Import Equations.Prop.Loader.
From Coq Require Import FunctionalExtensionality.
Require Import Equations.Prop.DepElim.
Require Import Equations.Prop.Tactics.
Require Import Equations.Prop.FunctionalInduction.
(** Telescopes: allows treating variable arity fixpoints *)
Set Universe Polymorphism.
Import Sigma_Notations.
Local Open Scope equations_scope.

Set Equations Transparent.

Cumulative Inductive tele@{i} : Type :=
| tip (A : Type@{i})
| ext (A : Type@{i}) (B : A -> tele) : tele.

Register tele as equations.tele.type.
Register tip as equations.tele.tip.
Register ext as equations.tele.ext.

Section TeleSigma.
  Universe i.

  Equations tele_sigma (t : tele@{i}) : Type@{i} :=
  tele_sigma (tip A) := A ;
  tele_sigma (ext A B) := @sigma A (fun x => tele_sigma (B x)).

  Coercion tele_sigma : tele >-> Sortclass.

  Inductive tele_val : tele@{i} -> Type@{i+1} :=
  | tip_val {A} (a : A) : tele_val (tip A)
  | ext_val {A B} (a : A) (b : tele_val (B a)) : tele_val (ext A B).

  Equations tele_pred : tele -> Type :=
  | tip A := A -> Prop;
  | ext A B := forall x : A, tele_pred (B x).

  Equations tele_rel : tele -> tele -> Type :=
  | tip A | tip B := A -> B -> Prop;
  | ext A B | ext A' B' := forall (x : A) (y : A'), tele_rel (B x) (B' y);
  | _ | _ := False.

  Equations tele_rel_app (T U : tele) (P : tele_rel T U) (x : tele_sigma T) (y : tele_sigma U) : Type :=
  tele_rel_app (tip A) (tip A') P a a' := P a a';
  tele_rel_app (ext A B) (ext A' B') P (a, b) (a', b') := tele_rel_app (B a) (B' a') (P a a') b b'.

  Universes j k.

  Equations tele_fn : tele@{i} -> Type@{j} -> Type@{k} :=
  | tip A | concl := A -> concl;
  | ext A B | concl := forall x : A, tele_fn (B x) concl.

  Equations tele_MR (T : tele@{i}) (A : Type@{j}) (f : tele_fn T A) : T -> A :=
  tele_MR (tip A)   C f := f;
  tele_MR (ext A B) C f := fun x => tele_MR (B x.1) C (f x.1) x.2.

  Equations tele_measure (T : tele@{i}) (A : Type@{i}) (f : tele_fn T A) (R : A -> A -> Prop) : T -> T -> Prop :=
  tele_measure T C f R := fun x y => R (tele_MR T C f x) (tele_MR T C f y).

  Equations tele_type : tele@{i} -> Type@{k} :=
  | tip A := A -> Type@{j};
  | ext A B := forall x : A, tele_type (B x).

  Equations tele_type_app (T : tele@{i}) (P : tele_type T) (x : tele_sigma T) : Type@{k} :=
  tele_type_app (tip A) P a := P a;
  tele_type_app (ext A B) P (a, b) := tele_type_app (B a) (P a) b.

  Equations tele_forall (T : tele@{i}) (P : tele_type T) : Type@{k} :=
  | tip A | P := forall x : A, P x;
  | ext A B | P := forall x : A, tele_forall (B x) (P x).

  Equations tele_forall_impl (T : tele@{i}) (P : tele_type T) (Q : tele_type T) : Type :=
  | tip A | P | Q := forall x : A, P x -> Q x;
  | ext A B | P | Q := forall x : A, tele_forall_impl (B x) (P x) (Q x).

  Equations tele_forall_app (T : tele@{i}) (P : tele_type T) (f : tele_forall T P) (x : T) : tele_type_app T P x :=
  tele_forall_app (tip A)   P f x := f x;
  tele_forall_app (ext A B) P f x := tele_forall_app (B x.1) (P x.1) (f x.1) x.2.

  Equations tele_forall_type_app (T : tele@{i}) (P : tele_type T)
            (fn : forall t, tele_type_app T P t) : tele_forall T P :=
  | (tip A) | P | fn := fn;
  | ext A B | P | fn := fun a : A => tele_forall_type_app (B a) (P a) (fun b => fn (a, b)).

  Lemma tele_forall_app_type (T : tele@{i}) (P : tele_type T) (f : forall t, tele_type_app T P t) :
    forall x, tele_forall_app T P (tele_forall_type_app T P f) x = f x.
  Proof.
    induction T; simpl. reflexivity. cbn. intros [a b]. simpl. rewrite H. reflexivity.
  Defined.

  Equations tele_forall_uncurry (T : tele@{i}) (P : T -> Type@{j}) : Type@{k} :=
  | tip A   | P := forall x : A, P x;
  | ext A B | P := forall x : A, tele_forall_uncurry (B x) (fun y : tele_sigma (B x) => P (x, y)).

  Equations tele_rel_pack (T U : tele) (x : tele_rel T U) : tele_sigma T -> tele_sigma U -> Prop by struct T :=
  tele_rel_pack (tip A) (tip A') P := P;
  tele_rel_pack (ext A B) (ext A' B') P := fun x y => tele_rel_pack (B x.1) (B' y.1) (P _ _) x.2 y.2.

  Equations tele_pred_pack (T : tele) (P : tele_pred T) : tele_sigma T -> Prop :=
  tele_pred_pack (tip A) P := P;
  tele_pred_pack (ext A B) P := fun x => tele_pred_pack (B x.1) (P x.1) x.2.

  Equations tele_type_unpack (T : tele) (P : tele_sigma T -> Type) : tele_type T :=
  tele_type_unpack (tip A) P := P;
  tele_type_unpack (ext A B) P := fun x => tele_type_unpack (B x) (fun y => P (x, y)).

  Equations tele_pred_fn_pack (T U : tele) (P : tele_fn T (tele_pred U)) : tele_sigma T -> tele_sigma U -> Prop :=
  tele_pred_fn_pack (tip A) U P := fun x => tele_pred_pack U (P x);
  tele_pred_fn_pack (ext A B) U P := fun x => tele_pred_fn_pack (B x.1) U (P x.1) x.2.

  Definition tele_rel_curried T := tele_fn T (tele_pred T).

  Equations tele_forall_pack (T : tele) (P : T -> Type) (f : tele_forall_uncurry T P) (t : T) : P t :=
  | (tip A) | P | f | t := f t;
  | ext A B | P | f | (a, b) := tele_forall_pack (B a) (fun b => P (a, b)) (f a) b.

  Equations tele_forall_unpack (T : tele@{i}) (P : T -> Type@{j}) (f : forall (t : T), P t) : tele_forall_uncurry T P :=
  | (tip A) | P | f := f;
  | ext A B | P | f := fun a : A => tele_forall_unpack (B a) (fun b => P (a, b)) (fun b => f (a, b)).

  Lemma tele_forall_pack_unpack (T : tele) (P : T -> Type) (f : forall t, P t) :
    forall x, tele_forall_pack T P (tele_forall_unpack T P f) x = f x.
  Proof.
    induction T; simpl. reflexivity. intros [a b]. simpl.
    rewrite H. reflexivity.
  Defined.

End TeleSigma.

Register tele_sigma as equations.tele.interp.
Register tele_measure as equations.tele.measure.

#[export]
Instance wf_tele_measure@{i j k}
         {T : tele@{i}} (A : Type@{j}) (f : tele_fn@{i j k} T A) (R : A -> A -> Prop) :
  WellFounded R -> WellFounded (tele_measure@{i j k} T A f R).
Proof.
  intros. apply Program.Wf.measure_wf. apply H.
Defined.

Section Fix.
  Universe i j k.
  Context {T : tele@{i}} (R : T -> T -> Prop).
  Context (wf : WellFounded R).
  Context (P : tele_type@{i j k} T).

  (* (forall x : A, (forall y : A, R y x -> P y) -> P x) -> forall x : A, P x *)
  Definition tele_fix_functional_type :=
    tele_forall_uncurry T (fun x =>
      ((tele_forall_uncurry T (fun y =>
         R y x -> tele_type_app T P y))) ->
      tele_type_app T P x).

  Context (fn : tele_fix_functional_type).

  Lemma tele_fix : tele_forall T P.
  Proof.
    refine (tele_forall_type_app _ _
     (@Subterm.FixWf (tele_sigma T) _ wf (tele_type_app T P)
           (fun x H => tele_forall_pack T _ fn x (tele_forall_unpack T _ H)))).
  Defined.
End Fix.

Register tele_fix as equations.tele.fix.
Register tele_MR as equations.tele.MR.
Register tele_fix_functional_type as equations.tele.fix_functional_type.

Register tele_type_app as equations.tele.type_app.
Register tele_forall_type_app as equations.tele.forall_type_app.
Register tele_forall_uncurry as equations.tele.forall_uncurry.
Register tele_forall as equations.tele.forall.
Register tele_forall_pack as equations.tele.forall_pack.
Register tele_forall_unpack as equations.tele.forall_unpack.

Extraction Inline tele_forall_pack tele_forall_unpack tele_forall_type_app tele_fix.

Lemma poly_f_equal@{i j} : forall (A : Type@{i}) (B : Type@{j}) (f : A -> B) (x y : A), x = y -> f x = f y.
Proof. intros. destruct H. reflexivity. Defined.

Section FixUnfold.
  Universes i j k.

  Context {T : tele@{i}} (x : T) (R : T -> T -> Prop).
  Context (wf : well_founded R).
  Context (P : tele_type@{i j k} T).

  (* (forall x : A, (forall y : A, R y x -> P y) -> P x) -> forall x : A, P x *)
  Context (fn : tele_fix_functional_type@{i j k} R P).

  Lemma tele_fix_unfold :
    tele_forall_app T P (tele_fix R wf P fn) x =
    tele_forall_pack T _ fn x
                     (tele_forall_unpack T _ (fun y _ => tele_forall_app T P (tele_fix R wf P fn) y)).
  Proof.
    intros. unfold tele_fix, Subterm.FixWf, Fix.
    rewrite tele_forall_app_type@{i j k}. destruct (wellfounded x). simpl.
    apply poly_f_equal@{k k}. apply poly_f_equal@{k k}. extensionality y. extensionality h.
    rewrite tele_forall_app_type@{i j k}. apply poly_f_equal@{k k}. apply Subterm.Acc_pi.
  Defined.

End FixUnfold.

Register tele_fix_unfold as equations.tele.fix_unfold.


(*Fixpoint map {A B} (f : A -> B) xs := match xs with
    | nil => nil
    | cons x xs => cons (f x) (map f xs)
    end.*)
Load "ListBackedSet.v".
Import ListBackedSet.
Import ListBackedSet'.

Lemma le_trans : forall x y z, x <= y -> y <= z -> x <= z.
    induction x, y, z; try easy; intros Hxy Hyz.
    - apply le_0_n.
    - exact (le_n_S _ _ (IHx y z (le_pred _ _ Hxy) (le_pred _ _ Hyz))).
    Qed.

Inductive RoseTree (A : Type) := MkRoseTree : A -> list (RoseTree A) -> RoseTree A.
Arguments MkRoseTree [A] x xs.

(* A simple fixpoint fails because it's not structurally recursive *)
Fail Fixpoint mapRoseTree {A B} (f : A -> B) (tree : RoseTree A) {struct tree} := match tree with
    MkRoseTree x xs => MkRoseTree (f x) (map (mapRoseTree f) xs)
    end.

Definition numchildren {A} (tree : RoseTree A) := match tree with MkRoseTree _ xs => length xs end.
Definition numchildren_rel {A} (t1 t2 : RoseTree A) := numchildren t1 < numchildren t2.

Lemma numchildren_rel_wf' : forall A n (t : RoseTree A), numchildren t <= n -> Acc numchildren_rel t.
Proof.
    induction n; intros [x xs] H; apply Acc_intro; intros [y ys] H'.
    - unfold numchildren_rel in *. simpl in *. inversion H. rewrite H1 in H'. inversion H'.
    - apply IHn.
    unfold numchildren_rel in H'. simpl in *. unfold lt in *.
    inversion H.
        + rewrite H1 in H'. exact (le_pred _ _ H').
        + subst. inversion H1.
            * exact (le_S_n _ _ (le_S _ _ H')).
            * exact (le_S _ _ (le_S_n _ _ (le_S _ _ (le_trans _ _ _ H' H0)))).
Defined.

Theorem numchildren_rel_wf : forall A, well_founded (@ numchildren_rel A).
Proof. intros A [x xs]. eapply numchildren_rel_wf'. apply le_n. Defined.

Definition mapRoseTree {A B} (f : A -> B) : RoseTree A -> RoseTree B.
    (*destruct tree as [x xs].*)
    (*Check (Fix (numchildren_rel_wf A) (fun _ => RoseTree B)) (fun t rec => _).*)
    apply (Fix (numchildren_rel_wf A)). intros [x xs] H. apply MkRoseTree.
    - exact (f x).
    - eapply map. 2:exact xs.
    Abort.

Definition children {A} (tree : RoseTree A) := match tree with MkRoseTree _ xs => xs end.
Inductive Child {A} : RoseTree A -> RoseTree A -> Prop := Direct : forall t1 t2, Elem t1 (children t2) -> Child t1 t2 | Indirect : forall t1 t2 t3, Elem t1 (children t2) -> Child t2 t3 -> Child t1 t3.
Fixpoint Child' {A} (t1 t2 : RoseTree A) := match t2 with
    | MkRoseTree _ nil => False
    | MkRoseTree _ (x :: xs) => t1 = x \/ Child' t1 x \/ Elem t1 xs
    end.
Inductive Child'' {A} : nat -> RoseTree A -> RoseTree A -> Prop :=
    | Direct' : forall t1 t2, Elem t1 (children t2) -> Child'' 0 t1 t2
    | Indirect' : forall t1 t2 t3 n, Elem t1 (children t2) -> Child'' n t2 t3 -> Child'' (S n) t1 t3.

Goal forall A a (x : RoseTree A), ~Child' x (MkRoseTree a nil).
    intros A a x H. inversion H. Qed.
(*Goal forall A a (x : RoseTree A), ~Child x (MkRoseTree a nil).
    intros A a [x xs] H. induction xs.
    - inversion H; subst.
        + inversion H0.*)
Lemma not_Child''_nil : forall A a n (x : RoseTree A), ~Child'' n x (MkRoseTree a nil).
    intros A a n.
    induction n; intros x H.
    - inversion H. inversion H0.
    - inversion H. exact (IHn _ H2).
    Qed.

(*Goal forall A (t1 t2 : RoseTree A), Child t1 t2 <-> Child' t1 t2.
    intros A [x xs] [y ys]. split.
    - (induction ys).  (simpl).  intro H.*)

(*Lemma Child_wf' : forall A (t1 t2 : RoseTree A), Child t1 t2 -> Acc Child t2.
    intros A [x xs] [y ys] H.
    inversion H; subst; apply Acc_intro; intros [z zs] H'; simpl in *.
    - induction ys.
        + inversion H0.
        + apply IHys.
            *
*)
(*Theorem Child_wf : forall A, well_founded (@ Child A).
    intros A [x xs]. apply Acc_intro. intros [y ys] H. inversion H; subst; simpl in *.
    - (* Direct *) induction xs; inversion H0; subst; apply IHxs.
        +
*)
(*Theorem Child'_wf : forall A, well_founded (@ Child' A).
    intros A [x xs]. constructor; induction xs; intros [y ys] H.
    - inversion H.
    - apply IHxs.*)

Definition depth {A} (t1 : RoseTree A) : nat := (fix depth_aux tree acc : nat := match tree with
    MkRoseTree _ children => (fix reclist xs acc' : nat := match xs with
        | nil => acc'
        | cons y ys => reclist ys (max (depth_aux y (S acc)) acc')
        end) children acc
    end) t1 0.

Fixpoint testDepth n : RoseTree True := match n with 0 => MkRoseTree I nil | S n' => MkRoseTree I (cons (testDepth n') nil) end.

Example foo1 : depth (testDepth 0) = 0. reflexivity. Qed.
Example foo2 : depth (testDepth 1) = 1. reflexivity. Qed.
Example foo3 : depth (testDepth 5) = 5. reflexivity. Qed.

Definition shallower {A} (t1 t2 : RoseTree A) := depth t1 < depth t2.

Theorem shallower_wf : forall A, well_founded (@ shallower A).
    intros A [x xs]. constructor. intros [y ys] H.
    Abort.

Theorem Child''_wf : forall A n, well_founded (@ Child'' A n).
    intros A n t. constructor. revert t.
    induction n; intros [x xs] [y ys] H; swap 1 2.
    - inversion H; subst. destruct (IHn _ _ H2).
    (*- (* (induction xs).
        + (contradict H). (apply not_Child''_nil).
        + *)
    revert H; revert xs; revert x; induction ys; intros x xs H.
    + constructor.  (intros [z zs] H').  (contradict H').  (apply not_Child''_nil).
    +
    *)
    Abort.

Definition RoseTree_rect' (A : Type) (P : RoseTree A -> Type) (Q : list (RoseTree A) -> Type)
    (H : forall x xs, Q xs -> P (MkRoseTree x xs))
    (H' : Q nil) (H'' : forall x xs, Q xs -> Q (cons x xs)) : forall t, P t.
Proof.
    intros [x xs]. apply H. induction xs.
    - exact H'.
    - apply H''. exact IHxs.
Defined.

Fixpoint RoseTree_rect'' (A : Type) (P : RoseTree A -> Type) (Q : list (RoseTree A) -> Type)
    (H : forall x xs, Q xs -> P (MkRoseTree x xs))
    (H' : Q nil) (H'' : forall x xs, P x -> Q xs -> Q (cons x xs)) (t : RoseTree A) : P t.
Proof.
    destruct t as [x xs].
    apply H. induction xs.
    - exact H'.
    - apply H''.
        + exact (RoseTree_rect'' A P Q H H' H'' a).
        + exact IHxs.
Defined.

Definition mapRoseTree {A B} (f : A -> B) (tree : RoseTree A) : RoseTree B.
    refine (RoseTree_rect'' A (fun _ => RoseTree B) (fun _ => list (RoseTree B)) _ _ _ tree).
    - intros x xs ys. exact (MkRoseTree (f x) ys).
    - exact nil.
    - intros a xs b ys. exact (cons b ys).
Defined.

(* Compute mapRoseTree (fun x => 5) (testDepth 3). *)