Require Coq.Structures.Equalities.
Import Coq.Structures.Equalities.
Module Terms_mod (SetVars FuncSymb: UsualDecidableTypeFull).
End Terms_mod.

Module m1 : Typ.
Definition t:=nat.
End m1.

Require Import Arith.PeanoNat.
Module m2 : UsualDecidableTypeFull.
Definition t:=nat.
Definition eq := @eq nat.
Definition eq_refl:=@eq_refl nat.
Definition eq_sym:=@eq_sym nat.
Definition eq_trans:=@eq_trans nat.
(*
Theorem eq_equiv:Equivalence eq.
Proof.
apply Build_Equivalence.
+ unfold Reflexive. (*intro x.*) exact eq_refl.
+ unfold Symmetric. exact eq_sym.
(*intros x y p. destruct p. reflexivity.*)
+ unfold Transitive. exact eq_trans.
(*intros x y z p1 p2. transitivity y.
exact p1. exact p2.*)
Defined.

Check Nat.eq_dec.
*)
Definition eq_equiv:Equivalence eq := Nat.eq_equiv.
(*
Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  induction n; destruct m.
  - now left.
  - now right.
  - now right.
  - destruct (IHn m); [left|right]; auto.
Defined.
*)
Definition eq_dec := Nat.eq_dec.
Definition eqb:=Nat.eqb.
Definition eqb_eq:=Nat.eqb_eq.
(*
Lemma eqb_eq n m : eqb n m = true <-> n = m.
Proof.
 revert m.
 induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
 - now intros ->.
 - now injection 1.
Qed.
*)
End m2.

(*Definition eqb_eq:=Nat.eqb_eq.*)
(*Definition eq_dec:=@eq_dec nat.*)
(*Import Typ.

Module XFo := Terms_mod nat nat.
SetVars FuncSymb.
Export cn.
Export XFo.

Import Terms_mod nat.
*)


(** DepMap: Maps with explicit domain contained in their type *)
Require Import Utf8.
Require Import Orders.
Require Import Coqlib.
Require Import DepMapInterface.

Set Implicit Arguments.

(************************************************************)
(** **  Derived properties on DepMap from their interface  **)
(************************************************************)

Module Type DepMapFacts (X : OrderedType).

Include DepMap(X).

(** ***  Comparisons of dependent maps  **)

Definition eq {A : Type} {dom₁ dom₂} (m₁ : t A dom₁) (m₂ : t A dom₂) := forall x, find x m₁ = find x m₂.
Definition incl {A : Type} {dom₁ dom₂} (m₁ : t A dom₁) (m₂ : t A dom₂) :=
  forall x v, find x m₁ = Some v -> find x m₂ = Some v.

Declare Instance eq_refl : forall A dom, Reflexive (@eq A dom dom).
Parameter eq_sym : forall A dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t A dom₂), eq m₁ m₂ -> eq m₂ m₁.
Parameter eq_trans : forall A dom₁ dom₂ dom3 (m₁ : t A dom₁) (m₂ : t A dom₂) (m3 : t A dom3),
  eq m₁ m₂ -> eq m₂ m3 -> eq m₁ m3.
Declare Instance eq_equiv : forall A dom, Equivalence (@eq A dom dom).

Declare Instance incl_refl : forall A dom (m : t A dom), Reflexive (@incl A dom dom).
Parameter incl_trans : forall A dom₁ dom₂ dom3 (m₁ : t A dom₁) (m₂ : t A dom₂) (m3 : t A dom3),
  incl m₁ m₂ -> incl m₂ m3 -> incl m₁ m3.
Declare Instance incl_preorder : forall A dom, PreOrder (@incl A dom dom).
Declare Instance eq_incl_compat : forall A dom, PartialOrder (@eq A dom dom) (@incl A dom dom).

(** ***  Compatibility Instances  **)

Declare Instance mem_compat (A : Type) dom : Proper (X.eq ==> @eq A dom dom ==> Logic.eq) (@mem A dom).
Parameter find_compat : forall A x y dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t A dom₂),
  X.eq x y -> eq m₁ m₂ -> find x m₁ = find y m₂.
Declare Instance find_compat2 (A : Type) dom : Proper (X.eq ==> @eq A dom dom ==> Logic.eq) (@find A dom).

Arguments set {A} {dom} x v m _.
Parameter set_compat :
  forall A x y v dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t A dom₂) (Hin₁ : Dom.In x dom₁) (Hin₂ : Dom.In y dom₂),
  X.eq x y -> eq m₁ m₂ -> eq (set x v m₁ Hin₁) (set y v m₂ Hin₂).
Declare Instance set_compat2 (A : Type) x dom :
  Proper (Logic.eq ==> @eq A dom dom ==> full_relation ==> @eq A dom dom) (@set A dom x).

Parameter add_compat : forall A x y v dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t A dom₂),
  X.eq x y -> eq m₁ m₂ -> eq (add x v m₁) (add y v m₂).
Declare Instance add_compat2 (A : Type) x dom :
  Proper (Logic.eq ==> @eq A dom dom ==> @eq A (Dom.add x dom) (Dom.add x dom)) (@add A dom x).

Parameter remove_compat : forall A x y dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t A dom₂),
  X.eq x y -> eq m₁ m₂ -> eq (remove x m₁) (remove y m₂).
Declare Instance remove_compat2 (A : Type) x dom :
  Proper (@eq A dom dom ==> @eq A (Dom.remove x dom) (Dom.remove x dom)) (@remove A dom x).

(** ***  Simplification theorems  **)

Parameter find_None : forall A dom x (m : t A dom), find x m = None <-> ¬Dom.In x dom.
Parameter find_dom : forall A x v dom (m : t A dom), find x m = Some v -> Dom.In x dom.

Parameter set_Some : forall A x y v u dom (m : t A dom) (Hin : Dom.In x dom),
  find y (set x v m Hin) = Some u <-> X.eq y x ∧ u = v ∨ ¬X.eq y x ∧ find y m = Some u.
Parameter set_None : forall A x y v dom (m : t A dom) (Hin : Dom.In x dom),
  find y (set x v m Hin) = None <-> ¬X.eq y x ∧ find y m = None.

Parameter add_Some : forall A x y v u dom (m : t A dom),
  find y (add x v m) = Some u <-> X.eq y x ∧ u = v ∨ ¬X.eq y x ∧ find y m = Some u.
Parameter add_None : forall A x y v dom (m : t A dom),
  find y (add x v m) = None <-> ¬X.eq y x ∧ find y m = None.

Parameter remove_Some : forall A x y u dom (m : t A dom),
  find y (remove x m) = Some u <-> ¬X.eq y x ∧ find y m = Some u.
Parameter remove_None : forall A x y dom (m : t A dom),
  find y (remove x m) = None <-> X.eq y x ∨ find y m = None.

Parameter add_cancel : forall A x v dom (m : t A dom), find x m = Some v -> eq (add x v m) m.
Parameter remove_cancel : forall A x dom (m : t A dom), find x m = None -> eq (remove x m) m.

Parameter add_merge : forall A x v₁ v₂ dom (m : t A dom), eq (add x v₂ (add x v₁ m)) (add x v₂ m).
Parameter add_comm : forall A x y v₁ v₂ dom (m : t A dom),
  ¬X.eq x y -> eq (add y v₂ (add x v₁ m)) (add x v₁ (add y v₂ m)).

Parameter remove_add_cancel : forall A s v dom (m : t A dom), eq (remove s (add s v m)) (remove s m).

Parameter map_None : forall A B (f : A -> B) dom (m : t A dom) x, find x (map f m) = None <-> ¬Dom.In x dom.

Parameter combine_None : forall A B C (f : A -> B -> C) g₁ g₂ dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t B dom₂) x,
  find x (combine f g₁ g₂ m₁ m₂) = None <-> find x m₁ = None ∧ find x m₂ = None.

Parameter add_incl : forall A x v dom (m : t A dom), ¬Dom.In x dom -> incl m (add x v m).
Parameter remove_incl : forall A x dom (m : t A dom), incl (remove x m) m.

Parameter cast_spec : forall A dom₁ dom₂ (Heq : Dom.eq dom₁ dom₂) (m : t A dom₁), eq (cast Heq m) m.

Parameter eq_dom : forall A dom₁ dom₂ (m₁ : t A dom₁) (m₂ : t A dom₂), eq m₁ m₂ -> Dom.eq dom₁ dom₂.

(** *** Additional operations and their specification **)

Parameter for_all : forall {A}, (key -> A -> bool) -> forall {dom}, t A dom -> bool.
(** [for_all f m] returns [true] iff all bindings (x, v) in [m] satisfy [f x v]. **)

Parameter for_all_spec : forall A f, Proper (X.eq ==> Logic.eq ==> Logic.eq) f -> forall dom (m : t A dom),
  for_all f m = true <-> forall x v, find x m = Some v -> f x v = true.

Parameter exists_ : forall {A}, (key -> A -> bool) -> forall {dom}, t A dom -> bool.
(** [exists_ f m] returns [true] iff at least one bindings (x, v) in [m] satisfy [f x v]. **)

Parameter exists_spec : forall A f, Proper (X.eq ==> Logic.eq ==> Logic.eq) f -> forall dom (m : t A dom),
  exists_ f m = true <-> exists x v, find x m = Some v ∧ f x v = true.
(*
Parameter filter : forall {A} (f : key -> A -> bool) {dom} (m : t A dom),
  t A (fold (fun x v acc => if f x v then Dom.add x acc else acc) m Dom.empty).

Parameter filter_spec : forall A f dom (m : t A dom) x v,
  find x (filter f m) = Some v <-> find x m = Some v ∧ f x v = true.
*)
End DepMapFacts.


Require Import Utf8 List.
Local Set Implicit Arguments.
Local Open Scope list_scope.

Notation "'foreach' x 'in' l 'then' P" := (fold_right (λ x Q, P ∧ Q) True l)
(at level 0, x at level 0, l at level 0, P at level 0).

Lemma foreach_inv X (l : list X) (P : X → Prop) :
  foreach x in l then (P x) →
  ∀ y, In y l → P y.
Proof.
  intros H_fold x H_x.
  induction l as [ | x' l IHl] ; simpl in * ; [ contradict H_x | ].
  destruct H_fold.
  destruct H_x.
  + subst x' ; assumption.
  + apply IHl ; assumption.
Qed.

Lemma foreach_arrow X (l : list X) (P Q : X → Prop) :
  (∀ x, P x → Q x) →
  foreach x in l then (P x) →
  foreach x in l then (Q x).
Proof.
  intros H_arrow HP.
  induction l ; simpl in *.
  + trivial.
  + destruct HP.
    split ; auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal30.

Set Printing Depth 1000.
Definition lfind_eval  n l1:=
append (rev l1) (Cons n Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ Zero))))) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Zero) (Nil).


Require Import CoqChess.Game.Game.
Require Import CoqChess.Game.Player.
Require Import CoqChess.Game.Strategy.
Require Import CoqChess.Game.Win.

CoInductive draw {G : Game} : GameState G -> Type :=
  | atom_draw : forall s,
      atomic_res s = Some Draw ->
      draw s
  | play_draw : forall s p,
      to_play s = p ->
      atomic_res s = None ->
      (forall m, draw (exec_move s m) + win (opp p) (exec_move s m)) ->
      forall m, draw (exec_move s m) ->
      draw s.

Lemma win_not_draw {G : Game} : forall (p : Player) (s : GameState G),
  win p s -> draw s -> False.
Proof.
  intros p s w.
  induction w; intro d.
  - destruct d; congruence.
  - destruct d; try congruence.
    destruct (s0 m).
    + auto.
    + apply (opp_no_fp p).
      assert (p0 = p) as Hp by congruence; rewrite Hp in *; clear Hp.
      eapply unique_winner; eauto.
  - destruct d; try congruence.
    exact (H m d).
Qed.

CoFixpoint strategy_of_draw {G : Game} {p : Player} {s : GameState G}
  (d : draw s) : strategy p s.
Proof.
  destruct d.
  - exact (atom_strategy e).
  - destruct (player_id_or_opp_r_t (to_play s) p).
    + eapply eloise_strategy.
      * exact e1.
      * eapply strategy_of_draw.
        exact d.
    + eapply (abelard_strategy).
      * exact e1.
      * intro m'.
        destruct (s0 m').
        ** eapply strategy_of_draw; auto.
        ** apply strategy_of_win.
           rewrite e in e1.
           rewrite e1 in w.
           rewrite opp_invol in w.
           exact w.
Defined.

CoFixpoint strategy_of_draw_correct {G : Game} {p : Player} (s : GameState G)
  (d : draw s) : drawing_strategy p (strategy_of_draw d).
Proof.
  rewrite (strat_id_eq _).
  unfold strat_id.
  destruct d.
  - unfold strategy_of_draw.
    constructor.
  - unfold strategy_of_draw.
    destruct (player_id_or_opp_r_t (to_play s) p).
    + constructor.
      apply strategy_of_draw_correct.
    + constructor.
      intro.
      destruct (s0 m0).
      * left.
        apply strategy_of_draw_correct.
      * right.
        simpl.
        apply strategy_of_win_correct.
Qed.


(*  bourbalki aux
$Id: ssete8.v,v 1.2 2018/07/13 12:58:25 grimm Exp $
*)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype.
From mathcomp Require Import ssrnat seq choice fintype binomial.
From mathcomp Require Import bigop ssralg poly ssrint.
From gaia Require Import ssete7.

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

(* The next lemma uses F38, which follows from F36.
However F37 is an easy consequence of F36, and we have the trivial
Lemma F37bis p p q:
  \sum_(k<q.+1) 'C(p+q,k) * 'C(p+q,p+k) = 'C((p+q).*2,q).
Proof. by move: (F37 (leq_addr q p)); rewrite addKn mul2n. Qed.
*)

Lemma F37bis p q:
  \sum_(k<q.+1) 'C(p+q,k) * 'C(p+q,p+k) = 'C((p+q).*2,q).
Proof.
pose f p q := \sum_(k<q.+1) 'C(p+q,k) * 'C(p+q,p+k).
pose g p q := 'C((p + q).*2, q).
rewrite -/(f p q) - /(g p q); move: p q.
have fp0: forall p, f p 0 = 1.
  by move => p; rewrite /f big_ord_recl big_ord0 binn bin0.
have gp0: forall p, f p 0 = g p 0.
  by move => p; rewrite /g bin0 fp0.
have fp1: forall p, f p 1 = (p.+1).*2.
  move => m; rewrite /f big_ord_recl big_ord_recl big_ord0 binn bin0.
  rewrite mul1n muln1 addn0 /=  /bump /= addn0 addn0.
  have r1: m = (m + 1) - 1 by rewrite addn1 subn1 -pred_Sn.
  rewrite {2} r1 -addnn addn1 bin_sub // bin1 //.
have gp1: forall p, f p 1 = g p 1.
  by move => p; rewrite /g bin1 fp1 addn1.
have f0q: forall q, f 0 q = 'C(q.*2,q).
  move=> q; rewrite /f add0n -F38; apply: congr_big => // [[i isn]].
have g0a: forall q, f 0 q = g 0 q.
  by move => q; rewrite /g f0q.
have gp2: forall p q, g p.+1 q.+2 = g p q.+2  + ( g p.+1 q.+1).*2 +  g p.+2 q.
  move => p q; rewrite /g.
  have ->: (p.+1 + q.+2).*2 = (p.+1 + q.+1).*2.+2.
  by rewrite -doubleS; congr (double _); rewrite addnS.
  rewrite binS binS -addnA -addnA addSnnS; congr (_ + _).
  rewrite -[in X in _ = X + _] addnn -addnA; congr (_ + _).
  by rewrite binS addSnnS addSnnS.
suff fp2: forall p q, f p.+1 q.+2= f p q.+2 + (f p.+1 q.+1).*2 + f p.+2 q.
  pose aux q:= forall p, f p q = g p q.
  have aux2: forall q, aux q /\ aux q.+1.
    elim => [// | n [hr1 hr2]]; split => //.
    by elim => // => p hrec; rewrite gp2 fp2 hr1 hr2 hrec.
  move => p q; move: p. move: (aux2 q) => [] //.
move=> p q.
rewrite /f.
rewrite 4! addSn  2! addnS; set n:= (p+q).+2.
set t0 := \sum_ (k < q.+3) _; set t1 := \sum_ (k < q.+3) _.
set t2 := \sum_ (k < q.+2) _; set t3 := \sum_ (k < q.+1) _.
rewrite /t0 big_ord_recl bin0 mul1n /ord0 addn0 binS.
set t4 := \sum_(i < q.+2) _.
have : t4 = \sum_(i < q.+2) (
    ('C(n, i.+1) * 'C(n.+1, (p+i).+2)) + ('C(n,i)) * 'C(n.+1, (p+i).+2)).
  rewrite /t4; apply: congr_big => // [[i lin]] _ /=.
  by rewrite /bump /= add1n addSn addnS binS mulnDl.
rewrite big_split /=.
set t5:=  \sum_(i < q.+2) _; set t6 :=  \sum_(i < q.+2) _; move => r1.
have: t5 = \sum_(i < q.+2) (('C(n, i.+1) *
  'C(n, (p + i).+2)) + ( 'C(n, i.+1) *  'C(n, (p + i).+1))).
  rewrite /t5;apply: congr_big => // [[i lin]] _ /=.
  by rewrite binS mulnDr.
have : t6 = \sum_(i < q.+2) (('C(n, i) *
  'C(n, (p + i).+2)) + ( 'C(n, i) *  'C(n, (p + i).+1))).
  rewrite /t5;apply: congr_big => // [[i lin]] _ /=.
  by rewrite binS mulnDr.
rewrite big_split /= big_split /=.
set t7:=  \sum_(i < q.+2) _; set t8:=  \sum_(i < q.+2) _.
set t9:=  \sum_(i < q.+2) _; set t10:=  \sum_(i < q.+2) _.
have -> : t8 = t2.
  rewrite /t2 /t8; apply: congr_big => // [[i lin]] _ /=.
have ->: t7 = t3.
  rewrite /t3 /t7; rewrite big_ord_recr /=.
  rewrite addnS -/n (bin_small (ltnSn n)) muln0 addn0.
  apply: congr_big => // [[i lin]] _ /=.
rewrite r1 => -> ->.
rewrite - [in X in _ = X] addnA (addnC t9) -(addnA t10).
rewrite addnCA (addnC ('C(n, p.+1))) -(addnA 'C(n, p)) addnA; congr ( _ + _).
  rewrite addnC /t1 big_ord_recl bin0 mul1n addn0; congr (_ + _).
  rewrite /t10; apply: congr_big => // [[i lin]] _ /=.
  by rewrite /bump /= add1n addnS.
rewrite addnA - addnn - (addnA t2) (addnC t3); congr ( _ + _).
rewrite /t9 / t2 big_ord_recr /=.
rewrite addnS -/n (bin_small (ltnSn n)) muln0 addn0.
symmetry; rewrite big_ord_recl bin0 mul1n addn0; congr (_ + _).
apply: congr_big => // [[i lin]] _ /=.
by rewrite /bump /= add1n addnS.
Qed.

Module Zformulas.

Import GRing.Theory.

Local Open Scope ring_scope.

Notation with_sign k x := ( (-1%:Z) ^+ k  *+  x ).
Notation with_sgn k x := ( (-1) ^+ k  *  x ).

Lemma F26a (k n: nat):
  \sum_(i<k.+1) ( with_sign i 'C(n.+1, i)) = with_sign k 'C(n, k).
Proof.
move: k; elim; first by rewrite big_ord_recl /= big_ord0 ! bin0  addr0.
move => k Hrec; rewrite big_ord_recr /= Hrec exprS - mulrnAr ! mulN1r.
by rewrite (binS n k) -opprB - mulrnBr ? addnK ? mulNrn // leq_addl.
Qed.

Lemma F26b (n: nat):
  \sum_(i<n.+2) ( with_sign i 'C(n.+1, i)) = 0.
Proof. by rewrite - (exprD1n (-1%:Z) (n.+1)) subrr exprS mul0r. Qed.

Lemma bin_inva (j q: nat):
  \sum_(k<q.+1) with_sign k ('C(j+q, j+k) * 'C(j+k, j)) =  (q==0%N).
Proof.
case q; first by rewrite big_ord_recl /= big_ord0 !addn0 binn muln1 expr0 addr0.
move => n.
set A := \sum_(k < _) _.
have ->: A = \sum_(k < n.+2) (-1) ^+ k *+ 'C(n.+1,  k) *+ 'C(j + n.+1, j).
  by apply: eq_bigr => //; move => i _ /=; rewrite - mulrnA binom_exchange1.
by rewrite sumrMnl F26a bin_small // mulr0n mul0rn.
Qed.

Lemma bin_invb (j q: nat): j <= q ->
  \sum_(k<q.+1) with_sign k ('C(q, k) * 'C(k, j)) =
    with_sgn j (Posz(q - j == 0)%N).
Proof.
move => h.
rewrite -  [in X in (X = _)] (subnKC h)  - addnS big_split_ord /=.
rewrite big1 ? add0r; last by move => [i lin] _; rewrite (bin_small lin) muln0.
rewrite - (bin_inva j (q-j)) big_distrr /=; apply: eq_bigr.
by move => [i len] _ /=; rewrite mulrnAr  exprD.
Qed.

Lemma double_pow_m1 (i: nat) (a : int): with_sgn i (with_sgn i a) = a.
Proof. by rewrite mulrA -exprD -signr_odd addnn odd_double expr0 mul1r. Qed.

Definition bin_conv_dir (g: nat -> int) n :=
  \sum_(i<n.+1) (g i) *+ 'C(n,i).
Definition bin_conv_inv (f: nat -> int) n :=
 with_sgn n (\sum_(i<n.+1)  with_sgn i  (f i) *+ 'C(n,i)).

Lemma bin_conv_inv1 (f: nat -> int) n:
  bin_conv_inv f n = \sum_(i<n.+1) with_sgn i (f (n- i)%N) *+ 'C(n,i).
Proof.
rewrite /bin_conv_inv big_distrr /=.
rewrite - (big_mkord xpredT (fun i => with_sgn i (f (n- i)%N) *+ 'C(n,i))).
rewrite big_nat_rev /= big_mkord; apply: eq_bigr; move => [i] /=.
rewrite ltnS => lin _.
rewrite add0n  subnS subSKn bin_sub // subKn // mulrnAr mulrA.
congr (_ * _  *+ _).
by rewrite -(signr_odd _ (n-i)) -exprD (oddB lin) - oddD signr_odd.
Qed.

Lemma bin_conv_inv2 (f g: nat -> int) n:
  (forall i, i<=n -> f i = bin_conv_dir g i) ->
  (forall i, i<=n -> g i = bin_conv_inv f i).
Proof.
move => h.
have h1:forall i m, m <=n -> i <= m ->  f i = \sum_(j<m.+1) (g j) *+ 'C(i,j).
  move => i m lemn leim; rewrite (h _ (leq_trans leim lemn)).
  rewrite - ltnS in leim; rewrite -  (subnKC leim) big_split_ord /=.
  rewrite - (addr0 (bin_conv_dir g i)); congr (_ + _); rewrite big1 //.
  by move => [k kn] _ /=; rewrite  bin_small // leq_addr.
move => i lein; rewrite /bin_conv_inv.
have ->: \sum_(i0 < i.+1) with_sgn i0 (f i0) *+ 'C(i, i0) =
  \sum_(k < i.+1) (\sum_(j<i.+1) (g j) * ((-1) ^+ k *+ ('C(i,k) * 'C(k, j)))).
  apply: eq_bigr ; move => [k lk] _ /=.
  transitivity  (\sum_(j<i.+1) (g j) * (-1) ^+ k *+ 'C(k, j) *+ 'C(i,k)).
    rewrite sumrMnl; congr (_ *+ _).
    rewrite (h1 k i lein) // big_distrr /=; apply:  eq_bigr => j _.
    by rewrite mulrnAr mulrC.
  by apply:  eq_bigr => j _; rewrite - ! mulrnAr - !mulrnA mulnC.
rewrite exchange_big /= big_ord_recr /= big1.
  rewrite add0r - big_distrr /= (bin_invb (leqnn i)) subnn mulr1.
  by rewrite (mulrC (g i)) double_pow_m1.
move => [j ji] _ /=; rewrite - big_distrr /=  (bin_invb (ltnW ji)).
by rewrite - (subnSK ji) ! mulr0.
Qed.

Lemma bin_conv_inv3 (f g: nat -> int) n:
  (forall i, i<=n -> f i = bin_conv_inv g i) ->
  (forall i, i<=n -> g i = bin_conv_dir f i).
Proof.
move => H.
pose g' i := with_sgn i (g i); pose f' i := with_sgn i (f i).
have H': forall i, i <= n -> f' i = bin_conv_dir g' i.
  by move => i lin; rewrite /f' (H _ lin)  /g' double_pow_m1.
move =>  i lin; move: (bin_conv_inv2 H' lin);rewrite /g' /bin_conv_inv => h.
move: (f_equal (fun z =>  (-1) ^+ i *z) h);rewrite !double_pow_m1.
by move => ->; apply : eq_bigr => j _; rewrite /f' double_pow_m1.
Qed.

Lemma bin_conv_inv_rec (f g: nat -> int) n:
  (forall i, i<=n.+1 -> g i = bin_conv_inv f i) ->
  (g n) + (g n.+1) =  bin_conv_inv (fun i => (f i.+1)) n.
Proof.
move => h.
rewrite addrC  (h _ (ltnSn n))  (h _ (leqnSn n)) !bin_conv_inv1 {h}.
rewrite  big_ord_recl [X in _ = X]  big_ord_recl /= - addrA !subn0 ! bin0.
rewrite [X in _ + (X + _) = _]
  (_:_ = \sum_(i < n.+1) with_sgn i.+1 (f (n.+1 -  i.+1)%N) *+ 'C(n, i.+1)
    - \sum_(i < n.+1) with_sgn i (f (n - i)%N) *+ 'C(n, i)).
 rewrite addrAC addrK; congr (_ + _).
  rewrite  big_ord_recr /= (bin_small (ltnSn n)) mulr0n addr0.
  apply: eq_bigr; move=> [i  lin] _ /=; rewrite subSn //.
rewrite -sumrB /=;  apply: eq_bigr; move=> [i  lin] _ /=.
rewrite -mulNrn - mulNr exprS mulN1r - mulrnDr //.
Qed.

Definition nb_surj n p := bin_conv_inv  (fun i => (i ^n)%N) p.

Lemma nb_surj_00 : nb_surj 0 0 = 1.
Proof.
rewrite /nb_surj /bin_conv_inv big_ord_recr /= big_ord0.
rewrite add0r double_pow_m1 //.
Qed.

Lemma nb_surj_n0  n: nb_surj n.+1 0 = 0.
Proof.
rewrite /nb_surj /bin_conv_inv big_ord_recr /= big_ord0.
rewrite add0r double_pow_m1 exp0n //.
Qed.

Lemma nb_surj_0p p: nb_surj 0 p.+1 = 0.
Proof.
rewrite /nb_surj /bin_conv_inv; set s := \sum_(i< _) _.
suff: s = 0 by move => ->; apply: mulr0.
transitivity (\sum_(i < p.+2) (-1%:Z) ^+ i *+ 'C(p.+1, i)).
  by apply :eq_bigr => i _; rewrite expn0 mulr1.
rewrite F26a bin_small //.
Qed.

Lemma nb_surj_n1  n: nb_surj n.+1 1 = 1.
Proof.
rewrite /nb_surj /bin_conv_inv big_ord_recr /= big_ord_recr /= big_ord0.
rewrite bin0 binn exp1n exp0n //.
Qed.

Lemma nb_surj_n2 n: nb_surj n.+1 2 = (2 ^n.+1 - 2)%N.
Proof.
rewrite /nb_surj /bin_conv_inv  ! big_ord_recr /= big_ord0.
rewrite exp0n // mulr0 mul0rn !add0r exp1n binn bin1 - signr_odd /= expr0 expr1.
rewrite ! mul1r mulr1n mulr1 addrC.
have s2: 2 <= (2 ^ n.+1) by  rewrite - {1} (expn1 2); apply: leq_pexp2l.
by rewrite -{1} (subnK s2) PoszD - addrA addrN addr0.
Qed.

Lemma nb_surj_1p p: nb_surj 1 p.+2 = 0.
Proof.
set g : ( nat -> int) := fun i =>  (if i ==1 then 1 else 0)%N.
pose f := bin_conv_dir g.
have aux: forall i, f i = i.
  move => i; rewrite /f /g /bin_conv_dir.
  rewrite big_ord_recl /= mul0rn add0r.
  case: i; first by  rewrite big_ord0.
  move => i; rewrite big_ord_recl /= bin1  big1 ? addr0.
    by rewrite - (intz i.+1) pmulrn.
  by move => [j lji] _  /=; rewrite mul0rn.
transitivity (bin_conv_inv f p.+2).
  congr (_ * _); apply: eq_bigr => i _; rewrite aux //.
have H: (forall i, i<=p.+2 -> f i = bin_conv_dir g i) by move => i ip.
rewrite - (bin_conv_inv2 H) ?(leqnn p.+2) /g //=.
Qed.

Lemma nb_surj_rec n p:
   nb_surj n.+1 p.+1 = (nb_surj n p + nb_surj n p.+1) *+ (p.+1).
Proof.
set f: (nat -> int ):= (fun i : nat => (i ^ n)%N).
rewrite (bin_conv_inv_rec (f:=f)) // /bin_conv_inv -mulrnAr - sumrMnl.
rewrite /nb_surj /bin_conv_inv /=.
have ->: (\sum_(i < p.+1) (-1) ^+ i * f i.+1 *+ 'C(p, i) *+ p.+1)
   = (\sum_(i < p.+1)  (-1) ^+ i * ((i.+1) ^(n.+1))%N%:Z *+ 'C(p.+1, i.+1)).
  apply:eq_bigr => i /= _; rewrite /f expnS mulnC PoszM  mulrA - mulrnA.
  rewrite mulnC mul_bin_diag  mulrnA; congr ( _ *+ _).
  by rewrite pmulrn - mulrzr intz.
rewrite exprSr - mulrA big_distrr /= big_ord_recl /= exp0n //(_: Posz 0 = 0) //.
rewrite mulr0 add0r; congr ( _ * _); apply: eq_bigr => i _ /=.
by rewrite mulrnAr mulrA  exprS mulN1r  mulN1r opprK.
Qed.

Lemma nbsurj_stirling n p: nb_surj n p = nbsurj n p.
Proof.
move: n p; elim.
  case => //; first by rewrite  nb_surj_00 nbsurj00.
  by move => p; rewrite nb_surj_0p nbsurj0n.
move => n H [|p]; first by rewrite nb_surj_n0 nbsurjn0.
by rewrite nb_surj_rec nbsurjS addnC H H - PoszD mulnC pmulrn mulrzz.
Qed.

Lemma nb_surj_small n p: nb_surj n (n+p.+1) = 0.
Proof.
move: p; elim: n; first by move => p; rewrite add0n nb_surj_0p.
by move => n Hrec p; rewrite addSn nb_surj_rec Hrec -addnS Hrec // addr0 mul0rn.
Qed.

Lemma nb_surj_nn n: nb_surj n n = n`!.
Proof.
elim:n; first by rewrite  nb_surj_00.
move => n Hrec; rewrite  nb_surj_rec - {1} addn1 nb_surj_small addr0 Hrec //.
rewrite factS mulnC PoszM pmulrn - mulrzr intz //.
Qed.

Lemma nb_surj_Snn n: nb_surj n.+1 n = ('C(n.+1,2) * n`!) %N.
Proof.
elim:n; first by rewrite  nb_surj_n0 bin_small //.
move => n Hrec; rewrite nb_surj_rec Hrec nb_surj_nn.
rewrite pmulrn - mulrzr intz - PoszD - PoszM (binS (n.+1)) bin1 mulnDl.
by rewrite - mulnA 2! (mulnC _ n.+1) - factS - mulnDl.
Qed.

Lemma nb_surj_SSnn n: nb_surj n.+2 n = (('C(n.+3,4) + 2 * 'C(n.+2,4)) * n`!) %N.
Proof.
elim:n; first by  rewrite  nb_surj_n0  bin_small //.
move => n Hrec; rewrite nb_surj_rec Hrec nb_surj_Snn.
rewrite pmulrn - mulrzr intz - PoszD - PoszM  mulnDl - mulnA.
rewrite 2! (mulnC _ n.+1)  - factS  mulnA - mulnDl -addnA.
rewrite (binS (n.+3)) - addnA;congr( Posz ((_ + _) * _)).
rewrite (binS (n.+2) 3) mulnDr addnA (addnC 'C(n.+3, 3)) (binS (n.+2)).
rewrite - addnA (addnC _ 'C(n.+2, 2)) -addnA (mulSn n);congr(addn _ (addn _ _)).
by rewrite - (addn2 n) (mul_Sm_binm_1 n 2) - {1}(addn2 1)  mulnDl mul1n.
Qed.

End Zformulas.

Import GRing.Theory.
Open Scope ring_scope.

Section RingFormulas.

Variable R : ringType.
Implicit Types (x y : R) (n: nat).

Lemma shorten_sum (f: nat -> R) (n m : nat):
    (n <= m)%N -> (forall i, (n <= i < m)%N -> f i = 0) ->
  \sum_(i < m) f i = \sum_(i < n) f i.
Proof.
move => nm fz.
rewrite - (big_mkord xpredT) (big_cat_nat _ _ _ (leq0n n) nm) /= big_mkord.
rewrite  [X in ( _ + X)]big1_seq ? Monoid.mulm1 // => i; case /andP => _.
by rewrite mem_index_iota; apply: fz.
Qed.

(* f1  *)
Lemma F1 x y n: (\sum_(i<n.+1) (x+y*+ i))*+2  = (x*+2+y*+n)*+n.+1.
Proof.
elim: n; first by rewrite big_ord_recl big_ord0 mulr1n mulr0n !addr0.
move => n Hrec.
rewrite  big_ord_recr /= mulrnDl Hrec mulrnDl - !mulrnA mulrnDl - !mulrnA.
rewrite addrAC addrA - mulrnDr - addrA -mulrnDr mulrnDl - !mulrnA -(addn1 n.+1).
congr ((x  *+ _)  + (y *+ _)).
  rewrite  mulnDr //.
rewrite mulnC - mulnDl add2n addn1 mulnC//.
Qed.

End RingFormulas.

Section  RingPoly.
Variable R : ringType.

Local Open Scope ring_scope.

Lemma power_monom (c:R) n :
  ('X + c%:P) ^+ n = \poly_(i< n.+1) (c^+(n - i)%N *+ 'C(n, i)).
Proof.
rewrite addrC exprDn_comm ?poly_def; last by apply: commr_polyX.
apply: eq_big=> // [[i lin]] _ /=.
by rewrite - mul_polyC - polyC_exp polyCMn  mulrnAl.
Qed.

(* is size_XaddC
Lemma size_factorp (a: R) : size ('X + a%:P) = 2%N.
Proof. by rewrite -['X]mul1r  -cons_poly_def polyseq_cons polyseq1. Qed.
*)

Lemma sum_powers_of_x (n: nat) (x:R):
  (x-1) * (\sum_(i < n) x^+ i) = x ^+ n -1.
Proof.
elim: n => [| n Ihn].
  by rewrite big_ord0 expr0 mulr0 subrr.
rewrite  (big_ord_recr n) /= mulrDr Ihn  mulrBl mul1r -exprS.
by rewrite addrAC addrCA subrr addr0.
Qed.

End RingPoly.

Section PolyFormulas.

Lemma intmul_inj: injective(fun z:nat => (@intmul int_Ring 1%Z z)).
Proof. by move=> a b /=; rewrite !intz =>  sf; injection sf. Qed.

Lemma bin_vandermonde (k l i:nat):
  (\sum_(j < i.+1) ('C(k, j)  *'C(l, (i - j))))%N = 'C(k+l , i)%N.
Proof.
apply: intmul_inj; set z1 := ('X + 1%:P) :{poly int}.
have aux: forall t j, (z1 ^+ t)`_j = 'C (t, j) %Z.
  move=> t j; rewrite /z1 (power_monom _ t) coef_poly expr1n.
  by case (ltnP j t.+1) => h //; rewrite ?pmulrn ?intz // bin_small.
move:(f_equal (fun z:{poly int} => z`_ i)  (exprD z1 k l)).
rewrite coefM aux;move  => ->;rewrite sumMz intz.
by apply: eq_bigr => j _;rewrite !aux intz PoszM.
Qed.

Lemma G6_a (n p:nat) (a b: int):
  (\sum_(i < p.+1) a^+ (p-i) * b ^+ i *+ ('C(n, i) * 'C(n-i, p-i)) =
     (a+b) ^+ p *+  'C(n , p)  )%Z.
Proof.
have: (n < p) || (p <= n) by rewrite ltnNge orNb.
case /orP => lenp.
  rewrite bin_small // mulr0n big1 //; move => [i lip] _ /=.
  move: lip; rewrite ltnS leq_eqVlt; case /orP => lipp.
    by move /eqP:lipp => ->; rewrite bin_small.
  move: (ltn_sub2r lipp lenp) => h;rewrite (bin_small h) muln0 //.
have leq1: n - p < n.+1 by rewrite ltnS leq_subr.
move: (power_monom (a+b) n) => eq1.
move: (f_equal (coefp (n - p)%N) eq1) => /=; rewrite coef_poly leq1/=.
rewrite (subKn lenp) (bin_sub lenp) => <-.
rewrite polyCD addrA exprDn coef_sum /=.
move: (lenp); rewrite - ltnS => lenp'.
have aux: forall i : nat, p < i < n.+1 ->
  (('X + a%:P) ^+ (n - i) * b%:P ^+ i *+ 'C(n, i))`_(n - p) = 0.
  move => i /andP [i1 i2]; rewrite  coefMn - polyC_exp coefMC power_monom.
  rewrite ltnS in i2; move: (ltn_sub2l (leq_trans i1 i2) i1).
  rewrite coef_poly ltnS ltnNge ;case ((n - p <= n - i)) => // _.
  by rewrite mul0r mul0rn.
rewrite  (shorten_sum lenp' aux); apply eq_bigr; move => [i lin] _ /=.
rewrite  coefMn - polyC_exp coefMC mulnC mulrnA  power_monom; congr (_  *+ _).
rewrite ltnS in lin; move: (leq_sub2l n lin) => le3.
rewrite coef_poly ltnS le3 - (bin_sub le3).
have ->: ((n - i - (n - p)) = p - i) %N.
  by rewrite - {1} (subnK lenp) -{2}  (subnK lin) addnA addnK addnC addnK.
by rewrite mulrC - mulrnAr mulrC.
Qed.

Lemma G6_b (n p:nat): p <> 0%N ->
  \sum_(i < p.+1)  (-1%:Z) ^+ i *+ ('C(n, i) * 'C(n-i, p-i)) =  0.
Proof.
move => pnz; move: (G6_a n p 1%:Z (-1%:Z)).
rewrite addrN (_ : 0 ^+ p = 0) ? mul0rn; last first.
  by  move: pnz; case:p => // p;rewrite exprS mul0r.
by move => eq; rewrite - {2} eq; apply: eq_bigr => i _; rewrite expr1n mul1r.
Qed.

Lemma G6_c (n p:nat):
  (\sum_(i < p.+1) 'C(n, i) * 'C(n-i, p-i) =  2 ^ p *'C(n , p)  )%N.
Proof.
apply: intmul_inj.
move: (G6_a n p 1 1); rewrite - mulr2n - natrX - mulrnA sumMz.
rewrite (_:  (2 ^ p * 'C(n, p))%:R  = (2 ^ p * 'C(n, p))%N%:~R) //.
by move => <-; apply: eq_bigr => i _; rewrite 2! expr1n mul1r //.
Qed.

Lemma F27_b n: (\sum_(i < n.+1)  i* 'C(n, i) = n * 2 ^ (n.-1) ) %N.
Proof.
apply: intmul_inj.
move: (refl_equal((deriv (('X + 1%:P) ^+ n):{poly int}).[1%Z])).
rewrite {1} addrC exprDn_comm; last by apply:  commr_polyX.
rewrite deriv_exp derivD derivX derivC addr0 mul1r hornerMn horner_exp.
rewrite! hornerE - mulr2n - natrX - mulrnA mulnC pmulrn /=.
rewrite raddf_sum /= horner_sum sumMz;  move => <-; apply: eq_bigr => i _.
by rewrite expr1n mul1r !derivE !hornerMn hornerXn expr1n - mulrnA.
Qed.

Notation with_sign k x := ( (-1%:Z) ^+ k  *+  x ).

Lemma F28 n: \sum_(i < n.+1)  with_sign i (i* 'C(n, i))
    =  if n is 1 then -1%:Z else 0.
Proof.
case:n; first by rewrite big_ord_recl big_ord0 //.
case; first by rewrite  2!big_ord_recl big_ord0 //.
move => n;move: (refl_equal((deriv (('X + 1%:P) ^+ n.+2):{poly int}).[-1%Z])).
rewrite {1} addrC exprDn_comm; last by apply:  commr_polyX.
rewrite deriv_exp derivD derivX derivC addr0 mul1r hornerMn horner_exp.
rewrite! hornerE_comm addNr /= exprS mul0r mul0rn raddf_sum /= horner_sum.
rewrite -{4}(oppr0) ; set g := \sum_(i<_) _;  set f := \sum_(i<_) _.
move => <- /=; rewrite - sumrN; apply eq_bigr => i _.
rewrite expr1n mul1r !derivE !hornerMn hornerXn - 2!mulNrn - mulrnA.
case:i =>i _ /=; case: i => // i /=; rewrite exprS mulN1r //.
Qed.

End PolyFormulas.

Section BigOps.
Variables (R : comRingType) (idx : R) (op : Monoid.com_law idx).

Lemma big_ord_rev (n : nat) (P : nat -> bool) (F : nat -> R):
  \big[op/idx]_(i < n | P i) F i =
  \big[op/idx]_(i < n | P (n - i.+1)%N) F ( n - i.+1)%N.
Proof. by rewrite - big_mkord big_nat_rev add0n big_mkord. Qed.

Lemma bigop_simpl1  (n m : nat) (F : nat -> R):
   (forall j, (m <= j)%N -> F j = idx) ->
   \big[op/idx]_(j < n) F j = \big[op/idx]_(j < m | (j < n)%N) F j.
Proof.
set s :=  (n + m)%N => h.
rewrite (big_ord_widen s F (leq_addr m n)).
rewrite (big_ord_widen_cond s (fun j => (j < n)%N) F (leq_addl n m)).
rewrite (bigID (fun i0:ordinal s => (i0 < m)%N) _ F) /=.
rewrite [X in op _ X] big1 ? Monoid.mulm1 //.
by move => j; rewrite  -leqNgt; case/andP => _; by apply: h.
Qed.

Lemma big_ord1 (F: 'I_1 -> R):
   \big[op/idx]_(i < 1) (F i) = F ord0.
Proof. by rewrite big_ord_recl big_ord0  Monoid.mulm1. Qed.

End BigOps.

(* *)


Require Import Naturelle.
Section Session1_2021_Logique_Exercice_2.

Variable A B C : Prop.

Theorem Exercice_2_Naturelle : ((A /\ B) -> C) -> ((A -> C) \/ (B -> C)).
Proof.
I_imp H.
E_ou A (~A).
TE.
I_imp H1.
I_ou_d.
I_imp H2.
E_imp (A /\ B).
Hyp H.
I_et.
Hyp H1.
Hyp H2.
I_imp H1.
I_ou_g.
I_imp H2.
E_antiT.
I_antiT A.
Hyp H2.
Hyp H1.
Qed.

Theorem Exercice_2_Coq : ((A /\ B) -> C) -> ((A -> C) \/ (B -> C)).
Proof.
intro H.
elim H.
Qed.

End Session1_2021_Logique_Exercice_2.


Require Import List.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype bigop fingraph finfun finset.

Require Import fl.cfg.Base fl.cfg.Definitions fl.cfg.Binarize fl.cfg.Chomsky.
Require Import fl.int.Base2 fl.int.DFA fl.int.ChomskyInduction.

Module Union.

  Import ListNotations Definitions Derivation Base Base2 ChomskyInduction.

  (** * Definitions *)
  (** In this section we define a function that creates a union-grammar out of a list of grammars. *)
  Section Definitions.

    Variables Tt Vt: Type.

    (* TODO: move? *)
    Definition grammar_to_language {Tt Vl : Type} (g : @var Vl * (@grammar Tt Vl)) : language :=
      let '(st, gr) := g in fun word => der gr st (to_phrase word).

    Inductive labeled_Vt : Type :=
    |  start : labeled_Vt
    |  lV : nat -> @var Vt -> labeled_Vt.

    Definition label_var (label: nat) (v: @var Vt): @var labeled_Vt :=
      V (lV label v).

    Definition label_symbol (label: nat) (s: @symbol Tt Vt): @symbol Tt labeled_Vt :=
      match s with
        | Ts t => Ts t
        | Vs v => Vs (V (lV label v))
      end.

    Definition label_phrase (label: nat) (p: @phrase Tt Vt): @phrase Tt labeled_Vt :=
      map (label_symbol label) p.

    Definition label_rule (label: nat) (r : @rule Tt Vt): @rule Tt labeled_Vt :=
      let '(R v p) := r in R (V (lV label v)) (label_phrase label p).

    Definition label_grammar (label: nat) (g: @grammar Tt Vt): @grammar Tt labeled_Vt:=
      map (label_rule label) g.

    Definition label_grammar_and_add_start_rule (label: nat) (g : @var Vt * (@grammar Tt Vt)):
      @grammar Tt labeled_Vt :=
      let '(st, gr) := g in (R (V start) [Vs (V (lV label st))]) :: label_grammar label gr.

    Fixpoint label_list_of_grammars (grammars : seq (@var Vt * (@grammar Tt Vt))):
      @grammar Tt labeled_Vt :=
      match grammars with
        |  [] => []
        |  ((_,gr)::t) => label_grammar (length t) gr ++ (label_list_of_grammars t)
      end.

    Fixpoint grammar_union (grammars : seq (@var Vt * (@grammar Tt Vt))): @grammar Tt labeled_Vt :=
      match grammars with
        |  [] => []
        |  (g::t) => label_grammar_and_add_start_rule (length t) g ++ (grammar_union t)
      end.

  End Definitions.

  Section Lemmas.

    (** * Util *)
    (** In this section we prove a few useful facts about the union-related functions. *)
    Section Util.

      Context {Tt Vt: Type}.

      Lemma word_remains_terminal:
        forall word,
          @terminal Tt Vt (to_phrase word).
      Proof.
        intros w.
        induction w.
        - intros s IN; inversion IN.
        - intros s IN.
          inversion IN; auto.
          subst s; exists a; auto.
      Qed.

      Lemma inner:
        forall (A: Type) (a: A) u v w,
          In a v \/ In a (u ++ w) <->
          In a (u ++ v ++ w).
      Proof.
        intros A a u v w; split; intros IN.
        { destruct IN as [IN|IN].
          { apply in_or_app; right.
              by apply in_or_app; left. }
          { apply in_app_or in IN.
              by destruct IN as [IN|IN]; auto. }
        }
        { apply in_app_or in IN.
          destruct IN as [IN|IN].
          { by right; apply in_or_app; auto. }
          { apply in_app_or in IN.
            destruct IN as [IN|IN].
            { by left. }
            { by right; apply in_or_app; auto. }
          }
        }
      Qed.

      Lemma app_label_phrase:
        forall (lphrase1 lphrase2: @phrase Tt (labeled_Vt Vt)) (label: nat) (phrase: @phrase Tt Vt),
          lphrase1 ++ lphrase2 = label_phrase label phrase ->
          exists phrase1 phrase2,
            phrase1 ++ phrase2 = phrase /\
            lphrase1 = label_phrase label phrase1 /\
            lphrase2 = label_phrase label phrase2.
      Proof.
        intros u v n p EQ.
        revert p EQ.
        induction u; intros p EQ.
        { by exists [], p; repeat split. }
        { destruct p; first by done.
          destruct a.
          { destruct s; last by done.
            injection EQ as EQ.
            destruct (IHu p H) as [u0 [v0 [H10 [H1 H2]]]]; clear IHu H.
            exists (Ts t :: u0), v0; repeat split; simpl.
            - by rewrite H10 EQ.
            - by rewrite H1.
            - by done.
          }
          { destruct s; first by done.
            destruct v0, v1.
            injection EQ as EQ.
            destruct (IHu p H) as [u1 [v1 [H10 [H1 H2]]]]; clear IHu H.
            exists ((Vs (V v0)) :: u1), v1; repeat split; simpl.
            - by rewrite H10.
            - by rewrite EQ H1.
            - by done.
          }
        }
      Qed.

      Lemma label_phrase_for_word:
        forall (label: nat) (word: word),
          @to_phrase Tt (labeled_Vt Vt) word = label_phrase label (to_phrase word).
      Proof.
        intros.
        induction word0; first by done.
          by simpl; rewrite IHword0.
      Qed.

      Lemma label_symbol_is_injective:
        forall (label: nat) (s1 s2: @symbol Tt Vt),
          label_symbol label s1 = label_symbol label s2 ->
          s1 = s2.
      Proof.
        intros n s1 s2 EQ.
        destruct s1, s2; simpl in *; try done.
        - by injection EQ as EQ; rewrite EQ.
          destruct v; destruct v0.
            by injection EQ as EQ; rewrite EQ.
      Qed.

      Lemma label_app:
        forall (label: nat) (p1 p2: @phrase Tt Vt),
          label_phrase label (p1 ++ p2) = label_phrase label p1 ++ label_phrase label p2.
      Proof.
        intros.
        induction p1; first by done.
        simpl; rewrite IHp1; reflexivity.
      Qed.

    End Util.

    (** * Forward *)
    (** In this section we prove that derivability in one grammar from the
        list implies derivability in the union-grammar. *)

    (* Let Tt Vt be types of terminals and nonterminals correspondingly. *)
    Variable Tt Vt: Type.

    (* For simplicity, let's define some local names. *)
    Let der := @der Tt.
    Let var := @var Vt.
    Let grammar := @grammar Tt Vt.

    Section Forward.

      Lemma grammar_extention:
        forall {V: Type} grammar1 grammar2 var (phrase: @phrase Tt V),
          der grammar2 var phrase ->
          der (grammar1 ++ grammar2) var phrase.
      Proof.
        intros V ? ? ? ? DER.
        induction DER.
        { by apply vDer. }
        { by apply rDer, in_or_app; right. }
        { by apply (replN (B := B)); [apply IHDER1 | apply IHDER2]. }
      Qed.

      Lemma der_in_grammar_implies_der_in_union_grammar_1:
        forall st grammar var grammars phrase,
          der grammar var phrase ->
          der (grammar_union ((st, grammar) :: grammars))
              (label_var (length grammars) var)
              (@label_phrase Tt Vt (length grammars) phrase).
      Proof.
        intros ? G ? ? ? DER.
        induction DER.
        { by destruct A; apply vDer. }
        { apply rDer; right.
          apply in_or_app; left.
          induction G; first by  done.
          move: H => [H|H].
          { by left; rewrite H; destruct A. }
          { by right; eapply IHG. }
        }
        { rewrite label_app label_app.
          eapply replN; last first.
          { by apply IHDER2. }
          { have EQ: [Vs (label_var (length grammars) B)] = (@label_phrase Tt Vt (length grammars) [Vs B]); first by done.
            rewrite EQ.
            rewrite <- label_app.
            rewrite <- label_app.
              by apply IHDER1.
          }
        }
      Qed.

      Lemma der_in_grammar_implies_der_in_union_grammar_2:
        forall var grammar grammars word,
          grammar_to_language (var, grammar) word ->
          grammar_to_language (V (start Vt), grammar_union (Tt:=Tt) ((var, grammar) :: grammars)) word.
      Proof.
        intros st g gs word DER.
        unfold grammar_to_language; unfold grammar_to_language in DER.
        rewrite (label_phrase_for_word (length gs)).
        rewrite -[label_phrase (Tt:=Tt) (Vt:=Vt) _ _]cats0 -[_ ++ []]cat0s.
        apply (replN (B := (V (lV (length gs) st)))).
        { by apply rDer; left. }
        { by apply der_in_grammar_implies_der_in_union_grammar_1. }
      Qed.

      (* TODO: check *)
      (* Now we can use two lemmas above to get the proof.
         (1) We use induction by (list of) grammars.
         (2) "Base" case is trivial.
         (3) "Step" case splits into two subcases:
           a) Case where we can use der_in_grammar_implies_der_in_union_grammar_2 lemma
           b) Case where we can just use inductive hypothesis. *)
      Lemma same_union_forward:
        forall (grammars: seq (var * grammar)) word,
          (exists s_l,
            Derivation.language (snd s_l) (fst s_l) (to_phrase word) /\ In s_l grammars) ->
          grammar_to_language (V (start Vt), grammar_union grammars) word.
      Proof.
        move => grammars word [[st gr] [[DER TER] IN]]; simpl in DER.
        unfold grammar_to_language in *.
        About in_split.
        have Fact: forall A l x, In x l -> exists l1 l2 : seq A, l = (l1 ++ (x :: l2)).
        { clear; intros ? ? ? IN.
          induction l; first by done.
          simpl in IN; move: IN => [EQ|IN]; [clear IHl; subst| ].
          { by exists [], l. }
          { apply IHl in IN; clear IHl.
            move: IN => [l1 [l2 EQ]].
              by exists (a::l1), l2; simpl; rewrite -EQ. }
        }
        move: (Fact _ _ _ IN) => [l1 [l2 EQ]]; clear Fact.
        rewrite EQ; clear EQ.
        have Fact:
          Derivation.der
            (grammar_union (Tt:=Tt) ((st, gr) :: l2)) (V (start Vt)) (to_phrase word) ->
          Derivation.der
            (grammar_union (Tt:=Tt) (l1 ++ (st, gr) :: l2)) (V (start Vt)) (to_phrase word).
        { induction l1; intros.
          { by rewrite cat0s. }
          { apply IHl1 in H; clear IHl1.
              by apply grammar_extention. }
        }
          by apply Fact, der_in_grammar_implies_der_in_union_grammar_2.
      Qed.

    End Forward.

    (** * Backward *)
    (** In this section we prove that derivability in the union-grammar implies
        derivability in one of the grammar from the list. *)
    Section Backward.

      (* In this section we prove several obvious properties of the updated grammar. *)
      Section GeneralFacts.

        Variable grammars: seq (var * grammar).

        Lemma der_in_union_simpl_grammar_implies_der_in_union_grammar:
          forall var phrase,
            der (label_list_of_grammars grammars) var phrase ->
            der (grammar_union grammars) var phrase.
        Proof.
          intros v p DER.
          unfold label_list_of_grammars in *.
          induction DER.
          { by intros; apply vDer. }
          { apply rDer.
            induction grammars; first by done.
            destruct a.
            apply in_app_or in H.
            destruct H as [H|H].
            { apply in_or_app; left.
                by right. }
            { apply in_or_app; right.
                by apply IHl0. } }
          { by intros; apply (replN (B := B)); [apply IHDER1 | apply IHDER2]. }
        Qed.

        Lemma updated_derivation_doesnot_contain_start_symbol:
          forall label var phrase,
            der (grammar_union grammars) (V (lV label var)) phrase ->
            ~ In (Vs (V (start Vt))) phrase.
        Proof.
          intros n v ? H.
          remember (V (lV n v)) as st.
          revert n v Heqst.
          induction H.
          { intros ? ? EQ IN.
            rewrite EQ in IN.
              by destruct IN. }
          { intros ? ? Heqst IN.
            induction grammars; first by done.
            apply in_app_or in H.
            destruct H; last by done.
            destruct a as [v0 g].
            destruct H as [H|H]; first by rewrite Heqst in H.
            induction g; first by done.
            destruct H; last by apply (IHg H).
            destruct a as [[v1] p].
            injection H as H.
            rewrite -H0 in IN; clear H0.
            induction p; first by done.
            destruct IN; last by done.
              by destruct a.
          }
          { intros n v0 ? ?.
            apply inner in H1.
            destruct H1.
            - destruct B as [[]].
              + by eapply IHder1, inner; eauto.
              + by eapply IHder2.
            - by eapply IHder1, inner; eauto.
          }
        Qed.

        Lemma derivability_without_start_rules:
          forall var phrase,
            var <> V (start Vt) ->
            der (grammar_union grammars) var phrase ->
            der (label_list_of_grammars grammars) var phrase.
        Proof.
          intros ? p NEQ DER.
          destruct var0 as [[ |n a]]; first by done.
          remember (V (lV n a)) as st.
          revert n a NEQ Heqst.
          induction DER.
          { by intros; apply vDer. }
          { intros.
            apply rDer.
            induction grammars; first by done.
            apply in_app_or in H.
            destruct H.
            { destruct a0; clear IHl0.
              apply in_or_app; left.
                by destruct H; [rewrite Heqst in H | ]. }
            { by destruct a0; apply in_or_app; right; apply IHl0. } }
          { intros.
            apply (replN (B := B)).
            { by apply (IHDER1 n a NEQ Heqst). }
            { destruct B.
              destruct l; last by apply (IHDER2 n0 v0).
              exfalso.
              rewrite Heqst in DER1.
              eapply updated_derivation_doesnot_contain_start_symbol; eauto 2.
                by apply inner; eauto 2.
            }
          }
        Qed.

        Lemma simpl_updated_derivation_doesnot_contain_start_symbol:
          forall label var phrase,
            der (label_list_of_grammars grammars) (V (lV label var)) phrase ->
            ~ In (Vs (V (start Vt))) phrase.
        Proof.
          intros ? ? ? DER IN.
          apply der_in_union_simpl_grammar_implies_der_in_union_grammar in DER.
            by eapply updated_derivation_doesnot_contain_start_symbol; eauto 2.
        Qed.

      End GeneralFacts.

      (* In this section we prove that the derivability of a word in some _labeled_ grammar
         implies that the word belongs to the union-language *)
      Section DerivabilityInUnionGrammar.

        Lemma start_nonterminal_is_not_derivable_in_labeled_grammar:
          forall grammar label1 label2 var word1 word2,
            ~ der (label_grammar label1 grammar)
              (V (lV label2 var)) (word1 ++ [Vs (V (start Vt))] ++ word2).
        Proof.
          have no_start_in_der_abdtract:
            forall G n0 v0 p,
              (forall lhs rhs, In (R lhs rhs) G -> ~ In (Vs (V (start Vt))) rhs) ->
              der G (V (lV n0 v0)) p ->
              ~ In (Vs (V (start Vt))) p.
          { intros ? ? ? ? no_start_rule ? ?.
            remember (V (lV n0 v0)) as st.
            revert n0 v0 Heqst.
            induction H.
            - intros.
              rewrite Heqst in H0.
              destruct H0.
              discriminate.
              contradiction.
            - intros.
              apply (no_start_rule A l H).
              exact H0.
            - intros.
              apply inner in H0.
              destruct H0.
              destruct B.
              destruct l.
              apply IHder1 with (n0:=n0) (v0:=v0).
              apply inner.
              auto.
              exact Heqst.
              apply IHder2 with (n0:=n) (v0:=v1).
              exact H0.
              reflexivity.
              apply IHder1 with (n0:=n0) (v0:=v0).
              apply inner.
              right.
              exact H0.
              exact Heqst.
          }
          intros G ? ? ? word1 word2 DER.
          eapply no_start_in_der_abdtract with (p := (word1 ++ [Vs (V (start Vt))] ++ word2)); eauto; last first.
          intros ? l IN1 IN2; clear DER.
          induction G; first by done.
          destruct IN1; last by eapply IHG; eauto 2.
          destruct a as [[v0] p].
          injection H as H1 H2.
          rewrite <- H2 in IN2.
          clear IHG H1 H2.
          induction p; first by done.
          destruct IN2; last by eapply IHp; eauto 2.
            by destruct a.
        Qed.

        Lemma labels_in_derivation_are_consistent:
          forall (grammar: grammar) label var phrase,
            der (label_grammar label grammar) (V (lV label var)) phrase ->
            forall label' var', In (Vs (V (lV label' var'))) phrase -> label = label'.
        Proof.
          intros GS label v0.
          have der_n_is_n_abstract :
            forall (g0: Definitions.grammar)
              (p: phrase),
              der g0 (V (lV label v0)) p ->
              (forall n0 v0 n v l, In (R (V (lV n0 v0)) l) g0 -> In (Vs (V (lV n v))) l -> n = n0) ->
              (forall n0 v0 u w, ~ der g0 (V (lV n0 v0)) (u ++ [Vs (V (start Vt))] ++ w)) ->
              forall v n, In (Vs (V (lV n v))) p -> n = label.
          {
            intros g0 p H H_g0 H_st v n.
            remember (V (lV label v0)) as st.
            revert label v0 n v Heqst.
            induction H.
            { intros n0 v0 n v EQ IN.
              rewrite EQ in IN.
                by destruct IN as [IN | IN]; [inversion IN |  done].
            }
            { intros n0 v0 n v EQ IN.
              rewrite EQ in H; clear EQ.
                by eapply H_g0; eauto 2.
            }
            { intros n0 v0 n v1 EQ IN.
              apply inner in IN.
              destruct IN.
              { destruct B.
                destruct l.
                { exfalso.
                  apply H_st with (n0 := n0) (v0 := v0) (u := u) (w := w).
                  rewrite -EQ.
                  exact H.
                }
                {
                  assert (n = n1).
                  apply (IHder2 n1 v2 n v1).
                  reflexivity.
                  exact H1.
                  assert (n1 = n0).
                  apply (IHder1 n0 v0 n1 v2).
                  exact EQ.
                  apply inner.
                  auto.
                  rewrite <- H3.
                  exact H2.
                }
              }
              { apply (IHder1 n0 v0 n v1); first by done.
                  by apply inner; eauto. }
            }
          }
          intros p ? n v ?.
          apply Logic.eq_sym, der_n_is_n_abstract with (g0 := (label_grammar label GS)) (p := p) (v := v); try done.
          { intros.
            clear v H0 p H.
            induction GS.
            contradiction.
            destruct H1.
            destruct a.
            destruct v0.
            injection H as H.
            rewrite <- H1 in H2.
            rewrite H in H2.
            clear H H1 IHGS.
            induction p.
            contradiction.
            destruct H2.
            destruct a.
            discriminate.
            destruct v3.
            injection H as H.
            auto.
            exact (IHp H).
            exact (IHGS H). }
          { intros ? ? ? ? ?.
            remember (V (lV n0 v1)) as A.
            rewrite HeqA in H1.
              by eapply start_nonterminal_is_not_derivable_in_labeled_grammar; eauto 2.
          }
        Qed.

        Lemma update_grammar_simpl_is_injective:
          forall (grammar: grammar) var label phrase,
            der (label_grammar label grammar) (V (lV label var)) (label_phrase label phrase) ->
            der grammar var phrase.
        Proof.
          intros grammar0 a n p ?.
          remember (label_phrase n p) as p0.
          remember (V (lV n a)) as A.
          revert a HeqA p Heqp0.
          induction H.
          { intros.
            rewrite HeqA in Heqp0.
            destruct p.
            discriminate.
            destruct p.
            simpl in Heqp0.
            destruct s.
            discriminate.
            destruct v.
            simpl in Heqp0.
            injection Heqp0 as H.
            rewrite H.
            apply vDer.
            discriminate. }
          { intros.
            apply rDer.
            rewrite Heqp0 in H. simpl in *.
            induction grammar0; first by done.
            destruct H.
            { left.
              destruct a0.
              rewrite HeqA in H.
              destruct v.
              simpl in H.
              injection H as H.
              rewrite H.
              clear A IHgrammar0 HeqA H.
              clear Heqp0.
              assert (p0 = p).
              revert p H0.
              induction p0.
              + intros.
                destruct p.
                reflexivity.
                discriminate.
              + intros.
                destruct p.
                discriminate.
                injection H0 as H.
                apply label_symbol_is_injective in H.
                rewrite H.
                assert (p0 = p).
                apply IHp0.
                apply H0.
                rewrite H1.
                reflexivity.
              + rewrite H.
                reflexivity.
            }
            + right.
              apply IHgrammar0.
              exact H. }
          { intros.
            destruct B.
            destruct l.
            exfalso.
            eapply start_nonterminal_is_not_derivable_in_labeled_grammar. rewrite HeqA in H. eauto 2.
            apply app_label_phrase in Heqp0.
            destruct Heqp0 as [u1 H1].
            destruct H1 as [t0 H1].
            destruct H1.
            destruct H2.
            apply app_label_phrase in H3.
            destruct H3 as [v1 H3].
            destruct H3 as [w1 H3].
            destruct H3.
            destruct H4.
            rewrite <- H3 in H1.
            clear H3.
            rewrite <- H1.
            assert (n0 = n).
            { rewrite HeqA in H.
              apply Logic.eq_sym, (labels_in_derivation_are_consistent H) with (var' := v0).
              apply inner.
              auto.
            }
            apply (replN (B := v0)).
            apply IHder1.
            exact HeqA.
            unfold label_phrase.
            rewrite map_cat.
            unfold label_phrase in H2.
            rewrite <- H2.
            simpl.
            unfold label_phrase in H5.
            rewrite <- H5.
            rewrite H3.
            reflexivity.
            apply IHder2.
            rewrite H3; reflexivity.
            exact H4. }
        Qed.

        Lemma derivability_in_grammar_implies_derivability_in_union_grammar:
          forall (grammars: seq (var * grammar)) grammar start label word,
            In (start, grammar) grammars ->
            der (label_grammar label grammar) (V (lV label start)) (to_phrase word) ->
            language_list_union (map grammar_to_language grammars) word.
        Proof.
          intros.
          induction grammars; first by done.
          destruct H; [left | right].
          { rewrite H; simpl.
            eapply update_grammar_simpl_is_injective with (var := start0) (label := label).
              by rewrite -label_phrase_for_word. }
          { by auto 2. }
        Qed.

      End DerivabilityInUnionGrammar.

      (* Suppose we have a phrase that we derived in a union-grammar.
         In this section we prove that there are only two options (1) either it is the
         starting nonterminal, or (2) we can choose a grammar from the union-list in
         which it is possible to derive this phrase. *)
      Section ChooseGrammarWithCorrectLabel.

        Lemma choose_labeled_grammar:
          forall (grammars: seq (var * grammar)) phrase,
            der (grammar_union grammars) (V (start Vt)) phrase ->
            phrase = [Vs (V (start Vt))] \/
            exists grammar var grammars1 grammars2,
              (grammars1 ++ (var, grammar) :: grammars2) = grammars /\
              der (grammar_union grammars) (V (lV (length grammars2) var)) phrase.
        Proof.
          intros ? p ?.
          remember (V (start Vt)) as st in H.
          induction H.
          { by left; rewrite Heqst. }
          { right.
            induction grammars; first by done.
            apply in_app_or in H.
            destruct H; [clear IHgrammars | ].
            { destruct a as [v G].
              exists G, v, [], grammars; split; first by done.
              rewrite Heqst in H.
              destruct H.
              { injection H as H.
                rewrite <- H.
                  by apply vDer.
              }
              { exfalso.
                induction G; first by done.
                  by destruct H; first destruct a.
              }
            }
            {
              intros. have H1 := IHgrammars H.
              clear H IHgrammars.
              destruct H1 as [G [a1 [u1 [v1 H1]]]].
              exists G, a1, (a::u1), v1.
              destruct H1.
              split.
              rewrite <- app_comm_cons.
              apply f_equal with (f := fun l => a::l).
              auto.
              apply grammar_extention.
              auto.
            }
          }
          {
            assert (H1 := IHder1 Heqst).
            clear IHder1.
            destruct H1.
            assert (B = V (start Vt) /\ u = [] /\ w = []).
            {
              destruct u.
              simpl in H1.
              destruct w.
              injection H1 as H1.
              auto.
              discriminate.
              destruct u.
              discriminate.
              discriminate.
            }
            clear H1.
            destruct H2.
            destruct H2.
            rewrite H2.
            rewrite H3.
            simpl.
            assert ((v ++ [])%list = v).
            apply app_nil_r.
            rewrite H4.
            apply IHder2.
            exact H1.
            destruct H1 as [g H1].
            destruct H1 as [a H1].
            destruct H1 as [u0 H1].
            destruct H1 as [v0 H1].
            right.
            exists g, a, u0, v0.
            destruct H1.
            split.
            exact H1.
            apply (replN H2 H0).
          }
        Qed.

      End ChooseGrammarWithCorrectLabel.

      (* In this section we prove that we can remove all grammars with "wrong" label. In other words,
         if we have a labeled nonterminal, it is not possible to derive something with different
         label. So, we can simply remove grammars with different labels. *)
      Section CutGrammars.

        Lemma labels_in_derivation_are_consistent_2:
          forall (grammars: seq (var * grammar)) label var phrase,
            der (label_list_of_grammars grammars) (V (lV label var)) phrase ->
            forall label' var', In (Vs (V (lV label' var'))) phrase -> label = label'.
        Proof.
          intros l n0 v0 p ? v n.
          unfold label_list_of_grammars in *.
          remember (V (lV n0 v0)) as st.
          revert n0 v0 n v Heqst.
          induction H.
          { intros; rewrite Heqst in H.
              by destruct H; [ injection H as H | ]. }
          { intros; rewrite Heqst in H; clear Heqst.
            induction l; first by done.
            destruct a as [v1 G].
            apply in_app_or in H.
            destruct H; last by auto.
            induction G; first by done.
            destruct H; last by auto.
            destruct a.
            destruct v2.
            simpl in H.
            injection H as H.
            rewrite H in H2.
            rewrite <- H2 in H0.
            clear H IHG IHl H1 H2.
            induction p.
            contradiction.
            destruct H0.
            destruct a.
            discriminate.
            destruct v3.
            injection H as H.
            auto.
            auto. }
          { intros n0 v0 v1 n ? ?.
            apply inner in H1.
            destruct H1.
            destruct B.
            destruct l0.
            rewrite Heqst in H.
            eapply simpl_updated_derivation_doesnot_contain_start_symbol in H.
            exfalso.
            apply H.
            eapply inner; eauto 2.
            assert (n = n1).
            apply Logic.eq_sym, (IHder2 n1 v2 v1).
            reflexivity.
            exact H1.
            assert (n1 = n0).
            apply Logic.eq_sym, (IHder1 n0 v0 v2).
            exact Heqst.
            apply inner.
            auto.
            rewrite <- H3.
              by apply Logic.eq_sym.
              apply (IHder1 n0 v0 v1).
              exact Heqst.
              apply inner.
              auto. }
        Qed.

        Lemma cut_head:
          forall grammar grammars label (var: var) phrase,
            length grammars <> label ->
            der (label_list_of_grammars (grammar::grammars)) (V (lV label var)) phrase ->
            der (label_list_of_grammars           grammars)  (V (lV label var)) phrase.
        Proof.
          intros a l n0 v0 p NEQ DER.
          remember (V (lV n0 v0)) as st.
          revert n0 v0 NEQ Heqst.
          induction DER.
          { intros.
            apply vDer.
          }
          { intros.
            destruct a.
            apply in_app_or in H.
            destruct H.
            exfalso.
            rewrite Heqst in H.
            clear Heqst.
            induction g.
            contradiction.
            destruct H.
            destruct a.
            destruct v1.
            injection H as H.
            auto.
            auto.
            apply rDer.
            exact H.
          }
          { intros.
            destruct B.
            destruct l0.
            + exfalso.
              rewrite Heqst in DER1.
              apply (simpl_updated_derivation_doesnot_contain_start_symbol DER1).
              apply inner.
              auto.
            + apply (replN (B := (V (lV n v1)))).
              apply (IHDER1 n0 v0).
              exact NEQ.
              apply Heqst.
              apply (IHDER2 n v1).
              clear IHDER1 IHDER2.
              assert (n = n0).
              rewrite Heqst in DER1.
              apply Logic.eq_sym, (labels_in_derivation_are_consistent_2 DER1) with (var' := v1) .
              apply inner.
              left.
              auto.
              rewrite H.
              exact NEQ.
              reflexivity.
          }
        Qed.

        Lemma label_is_bounded_by_grammar_union_length:
          forall (grammars: seq (var * grammar)) label var phrase,
            length grammars <= label ->
            ~ In (R (V (lV label var)) phrase) (label_list_of_grammars grammars).
        Proof.
          intros ? n v l ? ?.
          unfold label_list_of_grammars in *.
          induction grammars; first by done.
          destruct a as [v1 G].
          apply in_app_or in H0.
          destruct H0.
          - assert (length grammars < n).
            auto.
            clear H.
            destruct v1.
            induction G.
            contradiction.
            simpl in H0.
            destruct H0.
            + destruct a.
              destruct v1.
              simpl in H.
              injection H as H.
              rewrite H in H1.
                by rewrite ltnn in H1.
            + apply (IHG H).
          - apply IHgrammars.
            simpl in H. by apply ltnW.
            exact H0.
        Qed.

        Lemma cut_tail:
          forall (grammar: grammar) grammars label var v p,
            length grammars = label ->
            der (label_list_of_grammars ((var, grammar)::grammars)) (V (lV label v)) p ->
            der (label_grammar label grammar) (V (lV label v)) p.
        Proof.
          intros g r; intros.
          remember (V (lV label v)) as st.
          revert label v H Heqst.
          induction H0.
          { by intros; apply vDer. }
          { intros.
            apply in_app_or in H.
            destruct H.
            rewrite <- H0.
            apply rDer.
            exact H.
            exfalso.
            have H1 : length r <= label; first by rewrite H0.
            rewrite Heqst in H.
            apply (label_is_bounded_by_grammar_union_length H1 H).
          }
          { intros.
            destruct B.
            destruct l.
            exfalso.
            rewrite Heqst in H0_.
            apply (simpl_updated_derivation_doesnot_contain_start_symbol H0_).
            apply inner.
            auto.
            apply (replN (B := (V (lV n v1)))).
            apply (IHder1 label v0).
            exact H.
            exact Heqst.
            apply (IHder2 label v1).
            apply H.
            assert (n = label).
            rewrite Heqst in H0_.
            apply Logic.eq_sym, (labels_in_derivation_are_consistent_2 H0_ (var' :=v1)).
            apply inner.
            auto.
            rewrite H0.
            auto.
          }
        Qed.

        Lemma cut_grammar:
          forall (grammar: grammar) grammars1 grammars2 label var phrase,
            length grammars2 = label ->
            der (label_list_of_grammars (grammars1 ++ [(var,grammar)] ++ grammars2)) (V (lV label var)) phrase ->
            der (label_grammar label grammar) (V (lV label var)) phrase.
        Proof.
          intros grammar0 ? ? ? ? ? ? ?.
          induction grammars1.
          { by rewrite cat0s cat1s in H0; apply cut_tail in H0. }
          { rewrite -cat1s in H0.
            rewrite -!catA in H0.
            rewrite cat1s in H0.
            apply cut_head in H0.
            apply IHgrammars1 in H0; first by done.
            rewrite -H !app_length; simpl.
            apply/eqP; rewrite neq_ltn; apply/orP; right.
              by rewrite -addn1 [X in _ <= X]addnC -addnA leq_add2l.
          }
        Qed.

      End CutGrammars.

      (* TODO: check *)
      (* Now we can use all the lemmas above to get the proof.
         (1) We use choose_labeled_grammar lemma to make step into the correct grammar of the union-grammar
         (2) Next, lemma derivability_without_start_rules which states that we can make drop all the
              rules that lead from the starting nonterminal to the other grammars
         (3) Next, we can use the cut_grammar lemma to get rid of grammars with the wrong label
         (4) And finally, we apply derivability_in_grammar_implies_derivability_in_union_grammar lemma
              to "unlabel" the resulting grammar. *)
      Lemma same_union_backward:
        forall (grammars: seq (var * grammar)) word,
          grammar_to_language (V (start Vt), grammar_union grammars) word ->
          exists s_l,
            Derivation.language (snd s_l) (fst s_l) (to_phrase word) /\ In s_l grammars.
      Proof.
        intros ? word DER.
        have H1 := choose_labeled_grammar DER.
        destruct H1; first by exfalso; destruct word.
        clear DER; move: H => [g [a [u [v [H H0]]]]].
        apply derivability_without_start_rules in H0; last by done.
        rewrite -H in H0; apply cut_grammar in H0; last by done.
        rewrite -H.
        exists (a,g).
        unfold Derivation.language. simpl; split; [split | ].
        { apply update_grammar_simpl_is_injective with (label := length v).
            by rewrite -label_phrase_for_word. }
        { by apply word_remains_terminal. }
        { by rewrite -cat1s; apply in_or_app; right; apply in_or_app; left. }
      Qed.

    End Backward.

    Section MainTheorem2.

      Variable grammars: seq (var * grammar).

      Theorem correct_union:
        forall word,
          Derivation.language (grammar_union grammars) (V (start Vt)) (to_phrase word) <->
          exists s_l,
            Derivation.language (snd s_l) (fst s_l) (to_phrase word) /\ In s_l grammars.
      Proof.
        intros; split; intros.
        { apply same_union_backward.
            by move: H => [DER TER]. }
        { apply same_union_forward in H.
            by split; last apply word_remains_terminal. }
      Qed.

    End MainTheorem2.

  End Lemmas.

End Union.


From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Export tactics.
From iris.program_logic Require Import ectx_lifting.
From iris_examples.logrel.stlc Require Export lang.
From stdpp Require Import fin_maps.

Section stlc_rules.
  Context `{irisG stlc_lang Σ}.
  Implicit Types e : expr.

  Ltac inv_head_step :=
    repeat match goal with
    | H : to_val _ = Some _ |- _ => apply of_to_val in H
    | H : head_step ?e _ _ _ _ _ |- _ =>
       try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
       and can thus better be avoided. *)
       inversion H; subst; clear H
    end.

  Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _, _; simpl.

  Local Hint Constructors head_step.
  Local Hint Resolve to_of_val.

  Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
  Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
  Local Ltac solve_pure_exec :=
    unfold IntoVal in *;
    repeat match goal with H : AsVal _ |- _ => destruct H as [??] end; subst;
    intros ?; apply nsteps_once, pure_head_step_pure_step;
      constructor; [solve_exec_safe | solve_exec_puredet].

  (** Helper Lemmas for weakestpre. *)

  Global Instance pure_lam e1 e2 `{!AsVal e2}:
    PureExec True 1 (App (Lam e1) e2) (e1.[e2 /]).
  Proof. solve_pure_exec. Qed.

  Global Instance pure_fst e1 e2 `{!AsVal e1, !AsVal e2}:
    PureExec True 1 (Fst (Pair e1 e2)) e1.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_snd e1 e2 `{!AsVal e1, !AsVal e2}:
    PureExec True 1 (Snd (Pair e1 e2)) e2.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_case_inl e0 e1 e2 `{!AsVal e0}:
    PureExec True 1 (Case (InjL e0) e1 e2) e1.[e0/].
  Proof. solve_pure_exec. Qed.

  Global Instance pure_case_inr e0 e1 e2 `{!AsVal e0}:
    PureExec True 1 (Case (InjR e0) e1 e2) e2.[e0/].
  Proof. solve_pure_exec. Qed.

End stlc_rules.


Require Import Coq.Strings.String Coq.Sets.Ensembles.
Require Import Fiat.Common.
Require Export Fiat.Computation.Notations.

Definition Comp := @Ensemble.

Definition Return (A : Type) : A -> Comp A :=
  Singleton A.

Definition Bind (A B : Type)
           (ca : Comp A)
           (k : A -> Comp B)
: Comp B :=
  fun b =>
    exists a : A,
      In A ca a /\ In B (k a) b.

Definition Pick (A : Type)
           (P : Ensemble A)
: Comp A := P.

Bind Scope comp_scope with Comp.
Arguments Bind [A%type B%type] ca%comp k _.
Arguments Return [_] _ _.
Arguments Pick [_] _ _.

Notation ret := Return.

Notation "x >>= y" := (Bind x%comp y%comp) : comp_scope.
Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
                           (at level 81, right associativity,
                            format "'[v' x  <-  y ; '/' z ']'") : comp_scope.
Notation "x >> z" := (Bind x%comp (fun _ => z%comp))
                       (at level 81, right associativity,
                        format "'[v' x >> '/' z ']'") : comp_scope.
Notation "{ x  |  P }" := (@Pick _ (fun x => P)) : comp_scope.
Notation "{ x : A  |  P }" := (@Pick A%type (fun x => P)) : comp_scope.

Definition computes_to {A : Type} (ca : Comp A) (a : A) : Prop := ca a.

Notation "c ↝ v" := (computes_to c v).

Lemma ReturnComputes
      {A : Type}
: forall (a : A),
    ret a ↝ a.
Proof.
  constructor.
Qed.

Lemma BindComputes
      {A B: Type}
: forall (ca : Comp A)
         (f : A -> Comp B)
         (a : A)
         (b : B),
    ca ↝ a ->
    f a ↝ b ->
    (ca >>= f) ↝ b.
Proof.
  econstructor; eauto.
Qed.

Lemma PickComputes {A : Type}
: forall (P : Ensemble A)
         (a : A),
    P a ->
    {a' | P a'} ↝ a.
Proof.
  intros; eauto.
Qed.

Lemma Return_inv {A : Type}
: forall (a v : A),
    ret a ↝ v -> a = v.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma Bind_inv {A B: Type}
: forall (ca : Comp A)
         (f : A -> Comp B)
         (v : B),
    ca >>= f ↝ v ->
  exists a',
    ca ↝ a' /\ f a' ↝ v.
Proof.
  destruct 1; eauto.
Qed.

Lemma Pick_inv {A : Type}
: forall (P : Ensemble A)
         (v : A),
    {a | P a} ↝ v -> P v.
Proof.
  eauto.
Qed.

(** The old program might be non-deterministic, and the new program
      less so.  This means we want to say that if [new] can compute to
      [v], then [old] should be able to compute to [v], too. *)
Definition refine {A}
           (old : Comp A)
           (new : Comp A)
  := forall v, new ↝ v -> old ↝ v.

(* A definition and notation for pretty printing the goals used to
   interactively deriving refinements. *)

Definition Refinement_Of {A} (c : Comp A) :=
  {c' | refine c c'}.

Notation "'Refinement' 'of' c" :=
  {c' | refine c c'}
    (at level 0, no associativity,
     format "'Refinement'  'of' '/' '[v'    c ']' " )
  : comp_scope.

(** Define a symmetrized version of [refine] for ease of rewriting *)
Definition refineEquiv {A}
           (old : Comp A)
           (new : Comp A)
  := refine old new /\ refine new old.

Local Ltac t := repeat first [ solve [ unfold computes_to in *; eauto ]
                                        | progress hnf in *
                                        | intro
                                        | split
                                        | progress split_and ].

Global Instance refine_PreOrder A : PreOrder (@refine A).
t.
Qed.

Global Instance refineEquiv_Equivalence A : Equivalence (@refineEquiv A).
t.
Qed.

Global Opaque Return.
Global Opaque Bind.
Global Opaque Pick.
Global Opaque computes_to.

Global Hint Resolve ReturnComputes.
Global Hint Resolve BindComputes.
Global Hint Resolve PickComputes.

Ltac computes_to_inv :=
  repeat match goal with
           | H : {a' | @?P a'} ↝ _ |- _ => apply Pick_inv in H
           | H : Return ?a ↝ _ |- _ => apply Return_inv in H
           | H : Bind (A := ?A) ?ca ?k ↝ _ |- _ =>
             apply Bind_inv in H;
               let a' := fresh "v" in
               let H' := fresh H "'" in
               destruct H as [a' [H H']]
         end.

Ltac computes_to_econstructor :=
  first
    [ unfold refine; intros; eapply @ReturnComputes
    | unfold refine; intros; eapply @BindComputes
    | unfold refine; intros; eapply @PickComputes ].

Ltac computes_to_constructor :=
  first
    [ unfold refine; intros; apply @ReturnComputes
    | unfold refine; intros; apply @BindComputes
    | unfold refine; intros; apply @PickComputes ].


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj1eqsynthconj1 : forall  (lv0 : natural), (@eq natural (lv0) (lv0)).
Admitted.
QuickChick conj1eqsynthconj1.


From Coq Require Import Ascii String.
From Coq Require Import ZArith.Zdiv.
From Coq Require Import ZArith.Int.
From Coq Require Import ZArith.Znat.

Require Import Coq.Strings.String.

Open Scope Z_scope.

Definition int_to_ascii (n : Z) : ascii :=
  match n with
  | 0 => "0"
  | 1 => "1"
  | 2 => "2"
  | 3 => "3"
  | 4 => "4"
  | 5 => "5"
  | 6 => "6"
  | 7 => "7"
  | 8 => "8"
  | _ => "9"
  end.

Fixpoint int_to_string' (time: nat) (n : Z) (acc : string) : string :=
  let acc' := String (int_to_ascii (Zmod n 10)) acc in
  match time with
  | 0%nat => acc'
  | S time' =>
    match n / 10 with
    | 0 => acc'
    | n' => int_to_string' time' n' acc'
    end
  end.

Definition int_to_string (n : Z) : string :=
  match n with
  | Zneg _ => "-" ++(int_to_string' (Z.to_nat (- n)) (-n) "")
  | _ => int_to_string' (Z.to_nat n) n ""
  end.

Close Scope Z_scope.