Require Coq.Strings.Ascii.
Require Coq.Lists.List.
Require Coq.Setoids.Setoid.
Require Coq.Relations.Relations.
Require Coq.Classes.Morphisms.
Require Turing.Util.
Require Import Coq.Lists.List.
Import Coq.Lists.List.ListNotations.

Open Scope char_scope. (* Ensure by default we are representing characters. *)

Section Defs.
  Import List.
  Import ListNotations.
  Import Ascii.

  Definition word := list ascii.

  (** A language is a predicate on words. We say that [w] is in language [L] if,
      and only if, [L w]. *)

  Definition language := word -> Prop.

  (** A word is in a language is defined as function application *)
  Definition In w (L:language) := L w.

  Lemma in_def:
    forall (L:language) w,
    L w = In w L.
  Proof.
    intros.
    unfold In.
    reflexivity.
  Qed.

  (** The language that accepts all strings. *)

  Definition All : language := fun w => True.

  (** Every word is in [All]. *)

  Lemma all_in:
    forall w,
    In w All.
  Proof.
    intros.
    unfold All.
    apply I.
  Qed.

  (** The language that rejects all strings. *)

  Definition Void : language := fun w => False.

  (** Conversely, no word is in [Void]. *)

  Lemma void_not_in:
    forall w,
    ~ In w Void.
  Proof.
    intros.
    unfold Void; intros N.
    contradiction.
  Qed.

  (** [Nil] only accepts empty strings. *)

  Definition Nil : language := fun w => w = [].

  Lemma nil_in:
    In [] Nil.
  Proof.
    reflexivity.
  Qed.

  Lemma nil_in_inv:
    forall w,
    In w Nil ->
    w = [].
  Proof.
    unfold Nil. intros.
    assumption.
  Qed.

  (** [Char] accepts a single character. *)

  Definition Char c : language :=
    fun w => w = [c].

  Lemma char_in:
    forall (c:ascii),
    In [c] (Char c).
  Proof.
    unfold Char.
    intros.
    reflexivity.
  Qed.

  Lemma char_in_inv:
    forall c w,
    In w (Char c) ->
    w = [c].
  Proof.
    unfold Char.
    intros.
    assumption.
  Qed.

  (** [Any] accepts any single character. *)

  Definition Any: language := fun w => exists c, w = [c].

  Lemma any_in:
    forall c,
    In [c] Any.
  Proof.
    unfold Any.
    intros.
    exists c.
    reflexivity.
  Qed.

  Lemma any_in_inv:
    forall w,
    In w Any -> exists c, w = [c].
  Proof.
    unfold Any; auto.
  Qed.

  (** Concatenation of strings *)

  Definition App (L1 L2:language) : language :=
    fun w => exists w1 w2, w = w1 ++ w2 /\ L1 w1 /\ L2 w2.

  (** Show that if [w1] is in [L1] and [w2] is in [L2], then [w1 ++ w2] is in
      [App L1 L2]. *)

  Lemma app_in_eq:
    forall (L1 L2:language) w1 w2,
    In w1 L1 ->
    In w2 L2 ->
    In (w1 ++ w2) (App L1 L2).
  Proof.
    unfold In, App; intros.
    eauto.
  Qed.

  (** Auxiliary lemma that lets us use app when the string is not directly in
      the form of [w1 ++ w2]. *)
  Lemma app_in:
    forall (L1 L2:language) w1 w2 w3,
    In w1 L1 ->
    In w2 L2 ->
    w3 = w1 ++ w2 ->
    In w3 (App L1 L2).
  Proof.
    unfold In; intros.
    subst.
    apply app_in_eq; auto.
  Qed.

  Lemma app_in_inv:
    forall (L1 L2:language) w,
    In w (App L1 L2) ->
    exists w1 w2, w = w1 ++ w2 /\ In w1 L1 /\ In w2 L2.
  Proof.
    unfold App; intros.
    assumption.
  Qed.

  Lemma app_l_char_in:
    forall c (L:language) w,
    In w L ->
    In (c :: w) (App (Char c) L).
  Proof.
    intros.
    apply app_in with (w1:=[c]) (w2:=w).
    + apply char_in.
    + assumption.
    + reflexivity.
  Qed.

  Lemma app_l_all_in:
    forall (L:language) w1 w2,
    In w2 L ->
    In (w1 ++ w2) (App All L).
  Proof.
    intros.
    apply app_in with (w1:=w1) (w2:=w2).
    + apply all_in.
    + assumption.
    + reflexivity.
  Qed.

  Lemma app_l_all_in_skip:
    forall (L:language) w,
    In w L ->
    In w (App All L).
  Proof.
    intros.
    apply app_in with (w1:=[]) (w2:=w).
    + apply all_in.
    + assumption.
    + reflexivity.
  Qed.

  Lemma app_r_all_in_skip:
    forall (L:language) w,
    In w L ->
    In w (App L All).
  Proof.
    intros.
    apply app_in with (w1:=w) (w2:=[]).
    + assumption.
    + apply all_in.
    + rewrite app_nil_r.
      reflexivity.
  Qed.

  Lemma app_r_all_in:
    forall (L:language) w1 w2,
    In w1 L ->
    In (w1 ++ w2) (App L All).
  Proof.
    intros.
    apply app_in with (w1:=w1) (w2:=w2).
    + assumption.
    + apply all_in.
    + reflexivity.
  Qed.

  Lemma app_l_any_in:
    forall c w L,
    In w L ->
    In (c::w) (App Any L).
  Proof.
    intros.
    apply app_in with (w1:=[c]) (w2:=w); auto using any_in.
  Qed.

  Lemma app_l_char_in_inv:
    forall c L w,
    In w (App (Char c) L) ->
    exists w', w = c:: w' /\ In w' L.
  Proof.
    intros.
    apply app_in_inv in H.
    destruct H as (w1, (w2, (?, (Ha, Hb)))).
    apply char_in_inv in Ha.
    subst.
    exists w2.
    auto.
  Qed.

  Lemma app_r_char_in_inv:
    forall c L w,
    In w (App L (Char c)) ->
    exists w', w = w' ++ [c] /\ In w' L.
  Proof.
    intros.
    apply app_in_inv in H.
    destruct H as (w1, (w2, (?, (Ha, Hb)))).
    apply char_in_inv in Hb.
    subst.
    exists w1.
    auto.
  Qed.

  Lemma app_l_any_in_inv:
    forall w L,
    In w (App Any L) ->
    exists w' c, w = c :: w' /\ In w' L.
  Proof.
    intros.
    apply app_in_inv in H.
    destruct H as (w1, (w2, (?, (Ha, Hb)))).
    subst.
    apply any_in_inv in Ha.
    destruct Ha as (c, ?).
    subst.
    exists w2.
    exists c.
    auto.
  Qed.

  (** Union on languages *)

  Definition Union (L1 L2:language) : language :=
    fun w => L1 w \/ L2 w.

  Lemma union_in_l:
    forall (L1 L2:language) w,
    In w L1 ->
    In w (Union L1 L2).
  Proof.
    unfold In, Union.
    eauto.
  Qed.

  Lemma union_in_r:
    forall (L1 L2:language) w,
    In w L2 ->
    In w (Union L1 L2).
  Proof.
    unfold In, Union; eauto.
  Qed.

  Lemma union_in_inv:
    forall (L1 L2:language) w,
    In w (Union L1 L2) ->
    In w L1 \/ In w L2.
  Proof.
    unfold Union; auto.
  Qed.

  (** Pow definition based on: https://en.wikipedia.org/wiki/Kleene_star *)

  Inductive Pow (L:language) : nat -> word -> Prop :=
  | pow_nil:
    Pow L 0 nil
  | pow_cons:
    forall n w1 w2 w3,
    Pow L n w2 ->
    L w1 ->
    w3 = w1 ++ w2 ->
    Pow L (S n) w3.

  Lemma pow_in_eq:
    forall (L:language) w,
    In w L ->
    In w (Pow L 1).
  Proof.
    intros.
    apply pow_cons with (w1:=w) (w2:=nil).
    + apply pow_nil.
    + assumption.
    + rewrite app_nil_r.
      reflexivity.
  Qed.

  (** Star definition based on https://en.wikipedia.org/wiki/Kleene_star *)

  Definition Star L : language := fun w => exists n, Pow L n w.

  Lemma star_in_nil:
    forall L,
    In [] (Star L).
  Proof.
    intros.
    exists 0.
    apply pow_nil.
  Qed.

  Lemma star_in_eq:
    forall (L:language) w,
    In w L ->
    In w (Star L).
  Proof.
    intros.
    exists 1.
    apply pow_in_eq; auto.
  Qed.

  Lemma pow_to_star:
    forall (L:language) n w,
    In w (Pow L n) ->
    In w (Star L).
  Proof.
    intros.
    exists n.
    assumption.
  Qed.

  Lemma star_to_pow:
    forall (L:language) w,
    In w (Star L) ->
    exists n, In w (Pow L n).
  Proof.
    unfold Star, In; intros.
    assumption.
  Qed.

  (** Equivalence of languages *)

  Definition Equiv (L1 L2:language) : Prop := forall w, In w L1 <-> In w L2.

  (** Equivalence is symmetric. *)

  Lemma equiv_sym:
    forall L1 L2,
    Equiv L1 L2 ->
    Equiv L2 L1.
  Proof.
    unfold Equiv; split; intros; apply H; assumption.
  Qed.

  (** Equivalence is transitive. *)

  Lemma equiv_trans:
    forall L1 L2 L3,
    Equiv L1 L2 ->
    Equiv L2 L3 ->
    Equiv L1 L3.
  Proof.
    unfold Equiv; intros.
    rewrite H.
    rewrite H0.
    intuition.
  Qed.

  Lemma equiv_refl:
    forall L,
    Equiv L L.
  Proof.
    split; intros; tauto.
  Qed.

  (** Register [Equiv] in Coq's tactics. *)
  Global Add Parametric Relation : language Equiv
    reflexivity proved by equiv_refl
    symmetry proved by equiv_sym
    transitivity proved by equiv_trans
    as l_equiv_setoid.

  Goal forall (L1 L2:language), Equiv L1 L2 -> Equiv L2 L1.
  Proof.
    intros.
    symmetry. (** We can apply symmetry in the goal. *)
    rewrite H. (** We can rewrite H in the goal. *)
    reflexivity. (** We can use reflexivity to conclude Equiv goals. *)
  Qed.

  Lemma pow_equiv_in:
    forall L1 L2 n w,
    Equiv L1 L2 ->
    In w (Pow L1 n) ->
    In w (Pow L2 n).
  Proof.
    intros.
    induction H0; intros.
    - apply pow_nil.
    - subst.
      apply pow_cons with (w1:=w1) (w2:=w2); auto.
      apply H.
      assumption.
  Qed.

  Lemma pow_equiv:
    forall (L1 L2:language),
    Equiv L1 L2 ->
    forall n,
    Equiv (Pow L1 n) (Pow L2 n).
  Proof.
    split; intros.
    + eauto using pow_equiv_in.
    + apply equiv_sym in H.
      eauto using pow_equiv_in.
  Qed.

  Lemma star_equiv:
    forall (L1 L2:language),
    Equiv L1 L2 ->
    Equiv (Star L1) (Star L2).
  Proof.
    split; intros.
    + apply star_to_pow in H0.
      destruct H0 as (n, Hi).
      apply pow_to_star with (n:=n).
      eauto using pow_equiv_in.
    + apply star_to_pow in H0.
      destruct H0 as (n, Hi).
      apply pow_to_star with (n:=n).
      apply equiv_sym in H.
      eauto using pow_equiv_in.
  Qed.

  Lemma star_equiv_in:
    forall L1 L2 w,
    Equiv L1 L2 ->
    In w (Star L1) ->
    In w (Star L2).
  Proof.
    intros.
    apply star_equiv in H.
    apply H.
    assumption.
  Qed.

  Lemma app_in_equiv:
    forall L1 L2 L3 L4 w,
    Equiv L1 L3 ->
    Equiv L2 L4 ->
    In w (App L1 L2) ->
    In w (App L3 L4).
  Proof.
    intros.
    apply app_in_inv in H1.
    destruct H1 as (w1, (w2, (?, (Ha, Hb)))).
    subst.
    apply app_in_eq.
    + apply H; assumption.
    + apply H0. assumption.
  Qed.

  Lemma equiv_app:
    forall L1 L2 L3 L4,
    Equiv L1 L3 ->
    Equiv L2 L4 ->
    Equiv (App L1 L2) (App L3 L4).
  Proof.
    split; intros.
    - eapply app_in_equiv; eauto.
    - eapply app_in_equiv; eauto.
      + apply equiv_sym. assumption.
      + apply equiv_sym. assumption.
  Qed.

  Lemma union_in_equiv:
    forall L1 L2 L3 L4 w,
    Equiv L1 L3 ->
    Equiv L2 L4 ->
    In w (Union L1 L2) ->
    In w (Union L3 L4).
  Proof.
    intros.
    destruct H1.
    - apply H in H1.
      apply union_in_l.
      assumption.
    - apply H0 in H1.
      apply union_in_r.
      assumption.
  Qed.

  Lemma equiv_union:
    forall L1 L2 L3 L4,
    Equiv L1 L3 ->
    Equiv L2 L4 ->
    Equiv (Union L1 L2) (Union L3 L4).
  Proof.
    split; intros.
    - eapply union_in_equiv; eauto.
    - eapply union_in_equiv; eauto.
      + apply equiv_sym. assumption.
      + apply equiv_sym. assumption.
  Qed.

  Section equiv_proper.
  Import Morphisms.

  Global Instance in_equiv_proper: Proper (eq ==> Equiv ==> iff) In.
  Proof.
    unfold Proper, respectful, Equiv.
    intros.
    subst.
    split; intros; apply H0 in H; auto.
  Qed.

  (* Allow rewriting under App *)
  Global Instance app_equiv_proper: Proper (Equiv ==> Equiv ==> Equiv) App.
  Proof.
    unfold Proper.
    unfold respectful.
    intros.
    apply equiv_app; auto.
  Qed.
  (* Allow rewriting under Union *)
  Global Instance union_equiv_proper: Proper (Equiv ==> Equiv ==> Equiv) Union.
  Proof.
    unfold Proper.
    unfold respectful.
    intros.
    apply equiv_union; auto.
  Qed.

  Global Instance star_equiv_proper: Proper (Equiv ==> Equiv) Star.
  Proof.
    unfold Proper.
    unfold respectful.
    apply star_equiv.
  Qed.

  Global Instance pow_equiv_proper (n:nat): Proper (Equiv ==> Equiv) (fun x => Pow x n).
  Proof.
    unfold Proper.
    unfold respectful.
    intros.
    apply pow_equiv.
    assumption.
  Qed.

  End equiv_proper.
  (** Relate [All] with [Star Any]. *)

  Lemma app_assoc_in_1:
    forall L1 L2 L3 w,
    In w (App L1 (App L2 L3)) ->
    In w (App (App L1 L2) L3).
  Proof.
    intros.
    apply app_in_inv in H.
    destruct H as (w1, (w2, (?, (Ha, Hb)))).
    subst.
    apply app_in_inv in Hb.
    destruct Hb as (w3, (w4, (?, (Hc, Hd)))).
    subst.
    rewrite app_assoc.
    auto using app_in_eq.
  Qed.

  Lemma app_assoc_in_2:
    forall L1 L2 L3 w,
    In w (App (App L1 L2) L3) ->
    In w (App L1 (App L2 L3)).
  Proof.
    intros.
    apply app_in_inv in H.
    destruct H as (w1, (w2, (?, (Ha, Hb)))).
    subst.
    apply app_in_inv in Ha.
    destruct Ha as (w3, (w4, (?, (Ha, Hc)))).
    subst.
    rewrite <- app_assoc.
    auto using app_in_eq.
  Qed.

  Lemma app_assoc_rw:
    forall L1 L2 L3,
    Equiv (App L1 (App L2 L3)) (App (App L1 L2) L3).
  Proof.
    intros.
    split; intros.
    - apply app_assoc_in_1.
      assumption.
    - apply app_assoc_in_2.
      assumption.
  Qed.

  Lemma union_assoc_in_1:
    forall w L1 L2 L3,
    In w (Union L1 (Union L2 L3)) ->
    In w (Union (Union L1 L2) L3).
  Proof.
    intros.
    destruct H as [H1|[H2|H3]].
    - left.
      left.
      assumption.
    - left.
      right.
      assumption.
    - right.
      assumption.
  Qed.

  Lemma union_assoc_in_2:
    forall L1 L2 L3 w,
    In w (Union (Union L1 L2) L3) ->
    In w (Union L1 (Union L2 L3)).
  Proof.
    intros.
    destruct H as [[H|H]|H].
    - left; assumption.
    - right. left. assumption.
    - right.
      right.
      assumption.
  Qed.

  Lemma pow_char_in_inv:
    forall c n w,
    In w (Pow (Char c) n) ->
    w = Util.pow1 c n.
  Proof.
    induction n; intros.
    - inversion H; subst; clear H.
      reflexivity.
    - inversion H; subst; clear H.
      inversion H2; subst; clear H2.
      apply IHn in H1.
      subst.
      reflexivity.
  Qed.

  Lemma pow_char_cons:
    forall c n w,
    In w (Pow (Char c) n) ->
    In (c::w) (Pow (Char c) (S n)).
  Proof.
    intros.
    apply pow_cons with (w1:=[c]) (w2:=w).
    - assumption.
    - apply char_in.
    - reflexivity.
  Qed.

  Lemma pow_char_in:
    forall c n,
    In (Util.pow1 c n) (Pow (Char c) n).
  Proof.
    induction n; intros.
    - apply pow_nil.
    - simpl.
      apply pow_cons with (w1:=[c]) (w2:=Util.pow1 c n).
      + assumption.
      + apply char_in.
      + reflexivity.
  Qed.

  Lemma pow_char_cons_inv:
    forall c n w,
    In w (Pow (Char c) (S n)) ->
    exists w', w = c::w' /\ In w' (Pow (Char c) n).
  Proof.
    intros.
    inversion H; subst; clear H.
    inversion H2; subst; clear H2.
    exists w2.
    auto.
  Qed.

  Lemma pow_pow_in_inv:
    forall c1 c2 n1 n2 w,
    In w (App (Pow (Char c1) n1) (Pow (Char c2) n2)) ->
    w = Util.pow1 c1 n1 ++ Util.pow1 c2 n2.
  Proof.
    intros.
    apply app_in_inv in H.
    destruct H as (w1, (w2, (?, (Ha, Hb)))).
    subst.
    apply pow_char_in_inv in Ha.
    apply pow_char_in_inv in Hb.
    subst.
    reflexivity.
  Qed.

  Lemma pow_pow_in_inv_eq:
    forall c1 c2 n1 n2 m1 m2,
    c1 <> c2 ->
    App (Pow (Char c1) n1) (Pow (Char c2) n2) (Util.pow1 c1 m1 ++ Util.pow1 c2 m2) ->
    n1 = m1 /\ n2 = m2.
  Proof.
    intros.
    apply pow_pow_in_inv in H0.
    assert (n1 = m1) by eauto using Util.pow1_app_inv_eq_1.
    subst.
    assert (n2 = m2) by eauto using Util.pow1_app_inv_eq_2.
    subst.
    intuition.
  Qed.

  Lemma pow_add:
    forall L n1 n2 (w1 w2:word),
    In w1 (Pow L n1) ->
    In w2 (Pow L n2) ->
    In (w1 ++ w2) (Pow L (n1 + n2)).
  Proof.
    induction n1; intros.
    - inversion H; subst; clear H; simpl.
      assumption.
    - inversion H; subst; clear H.
      simpl.
      assert (Hx := IHn1 _ _ _ H2 H0).
      rewrite <- app_assoc.
      eapply pow_cons; eauto.
  Qed.

  Lemma pow_add_inv:
    forall L n1 n2 (w:word),
    In w (Pow L (n1 + n2)) ->
    exists w1 w2, w = w1 ++ w2 /\ In w1 (Pow L n1) /\ In w2 (Pow L n2).
  Proof.
    induction n1; simpl; intros. {
      exists nil, w.
      intuition.
      apply pow_nil.
    }
    inversion H; subst; clear H.
    assert (Hx := H1).
    apply IHn1 in H1.
    destruct H1 as (w3, (w4, (?, (Ha, Hb)))).
    subst.
    exists (w1 ++ w3) % list, w4.
    rewrite app_assoc.
    intuition.
    unfold In.
    eauto using pow_cons.
  Qed.

  Lemma nil_pow_in_inv:
    forall n w,
    In w (Pow Nil n) ->
    w = [].
  Proof.
    induction n; intros.
    - inversion H; subst; clear H.
      reflexivity.
    - inversion H; subst; clear H.
      apply nil_in_inv in H2.
      subst.
      apply IHn in H1.
      subst.
      reflexivity.
  Qed.

  Lemma void_pow_in_inv:
    forall n w,
    In w (Pow Void n) ->
    w = [].
  Proof.
    intros.
    induction H.
    - reflexivity.
    - subst.
      apply void_not_in in H0.
      contradiction.
  Qed.

  Lemma pow_cons_eq:
    forall (L:language) w1 w2 n,
    In w1 L ->
    In w2 (Pow L n) ->
    In (w1 ++ w2) (Pow L (S n)).
  Proof.
    intros.
    apply pow_cons with (w1:=w1) (w2:=w2); auto.
  Qed.

  Lemma star_cons:
    forall (L:language) w1 w2 w3,
    In w1 L ->
    In w2 (Star L) ->
    w3 = w1 ++ w2 ->
    In w3 (Star L).
  Proof.
    intros.
    destruct H0 as (n, Hp).
    exists (S n).
    subst.
    apply pow_cons_eq; auto.
  Qed.

  Lemma star_cons_eq:
    forall (L:language) w1 w2,
    In w1 L ->
    In w2 (Star L) ->
    In (w1 ++ w2) (Star L).
  Proof.
    intros.
    apply star_cons with (w1:=w1) (w2:=w2); auto.
  Qed.

End Defs.

Declare Scope lang_scope.

Module LangNotations.
  Import Ascii.
  Notation "{}" := Void : lang_scope.
  Infix ">>" := App (at level 40, left associativity) : lang_scope.
  Notation "a 'U' b" := (Union a b) (at level 50, left associativity)  : lang_scope.
  Notation "x '*'" := (Star x) (at level 20) : lang_scope.
  Infix "^^" := Pow (right associativity, at level 35) : lang_scope.
  Infix "==" := Equiv (at level 95, no associativity) : lang_scope.
  Coercion Char: ascii >-> language.
End LangNotations.

Section Rewrites.
  Import LangNotations.
  Import List.
  Import ListNotations.
  Open Scope lang_scope.

  Lemma union_assoc_rw:
    forall L1 L2 L3,
    L1 U (L2 U L3) == (L1 U L2) U L3.
  Proof.
    intros.
    split; intros.
    - apply union_assoc_in_1.
      assumption.
    - apply union_assoc_in_2.
      assumption.
  Qed.

  Lemma union_sym_rw:
    forall L1 L2,
    L1 U L2 == L2 U L1.
  Proof.
    split; intros; destruct H; try (left; assumption); try (right; assumption).
  Qed.

  Lemma union_dup_rw:
    forall L,
    L U L == L.
  Proof.
    intros; split; intros.
    - destruct H; assumption.
    - left. assumption.
  Qed.

  Lemma star_any_rw:
    Any * == All.
  Proof.
    split; intros.
    - apply all_in.
    - unfold Star.
      generalize dependent H.
      induction w; intros. {
        exists 0.
        apply pow_nil.
      }
      assert (All w) by auto using all_in.
      destruct IHw as (n, Hp); auto.
      exists (S n).
      rewrite in_def in *.
      apply pow_cons with (w1:=[a]) (w2:=w); auto.
      rewrite in_def.
      auto using any_in.
  Qed.

  Lemma app_r_void_rw:
    forall (L:language),
    L >> {} == {}.
  Proof.
    split; intros.
    - apply app_in_inv in H.
      destruct H as (w1, (w2, (?, (Ha, Hb)))).
      apply void_not_in in Hb.
      contradiction.
    - apply void_not_in in H.
      contradiction.
  Qed.

  Lemma app_l_void_rw:
    forall (L:language),
    {} >> L == {}.
  Proof.
    split; intros.
    - apply app_in_inv in H.
      destruct H as (w1, (w2, (?, (Ha,Hb)))).
      apply void_not_in in Ha.
      contradiction.
    - apply void_not_in in H.
      contradiction.
  Qed.

  Lemma app_l_nil_rw:
    forall (L:language),
    Nil >> L == L.
  Proof.
    intros.
    split; intros.
    - apply app_in_inv in H.
      destruct H as (w1, (w2, (?, (Ha, Hb)))).
      subst.
      apply nil_in_inv in Ha.
      subst.
      assumption.
    - apply app_in_eq with (w1:=[]) (w2:=w).
      + apply nil_in.
      + assumption.
  Qed.

  Lemma app_r_nil_rw:
    forall (L:language),
    L >> Nil == L.
  Proof.
    split; intros.
    - apply app_in_inv in H.
      destruct H as (w1, (w2, (?, (Ha, Hb)))).
      subst.
      apply nil_in_inv in Hb.
      subst.
      rewrite app_nil_r.
      assumption.
    - apply app_in with (w1:=w) (w2:=[]).
      + assumption.
      + apply nil_in.
      + rewrite app_nil_r.
        reflexivity.
  Qed.

  Lemma union_r_void_rw:
    forall (L:language),
    L U {} == L.
  Proof.
    split; intros.
    + apply union_in_inv in H.
      destruct H; auto.
      apply void_not_in in H.
      contradiction.
    + left.
      assumption.
  Qed.

  Lemma union_l_void_rw:
    forall (L:language),
    {} U L == L.
  Proof.
    split; intros.
    - destruct H. {
        apply void_not_in in H.
        contradiction.
      }
      assumption.
    - right.
      assumption.
  Qed.

  Lemma union_r_all_rw:
    forall (L:language),
    L U All == All.
  Proof.
    split; intros.
    + apply all_in.
    + right.
      assumption.
  Qed.

  Lemma union_l_all_rw:
    forall (L:language),
    All U L == All.
  Proof.
    split; intros.
    - apply all_in.
    - left.
      assumption.
  Qed.

  Lemma app_star_rw:
    forall (L:language),
    L * >> L * == L  * .
  Proof.
    split; intros.
    - apply app_in_inv in H.
      destruct H as (w1, (w2, (?, (Ha, Hb)))).
      subst.
      destruct Ha as (n1, Ha).
      destruct Hb as (n2, Hb).
      exists (n1 + n2).
      apply pow_add; auto.
    - apply app_in_eq with (w1:=[]) (w2:=w).
      + apply star_in_nil.
      + assumption.
  Qed.

  Lemma star_star_rw:
    forall (L:language),
    L * * == L *.
  Proof.
    intros.
    split; intros.
    - apply star_to_pow in H.
      destruct H as (n, Hn).
      generalize dependent w.
      induction n; intros. {
        inversion Hn; subst; clear Hn.
        apply star_in_nil.
      }
      inversion Hn; subst; clear Hn.
      apply IHn in H0.
      apply app_star_rw.
      auto using app_in_eq.
    - destruct H as (n, H).
      exists 1.
      apply pow_cons with (w1:=w) (w2:=nil).
      + apply pow_nil.
      + exists n.
        assumption.
      + auto with *.
  Qed.

  Lemma star_nil_rw:
    Nil * == Nil.
  Proof.
    split; intros.
    - apply star_to_pow in H.
      destruct H as (n, H).
      apply nil_pow_in_inv in H.
      subst.
      apply nil_in.
    - apply nil_in_inv in H.
      subst.
      apply star_in_nil.
  Qed.

  Lemma star_void_rw:
    {} * == Nil.
  Proof.
    split; intros.
    - destruct H as (n, H).
      apply void_pow_in_inv in H.
      subst.
      apply nil_in.
    - apply nil_in_inv in H.
      subst.
      exists 0.
      apply pow_nil.
  Qed.

  Lemma app_union_distr_l:
    forall L1 L2 L3,
    L1 >> L3 U L2 >> L3 == (L1 U L2) >> L3.
  Proof.
    split; intros.
    - destruct H as [H|H]; apply app_in_inv in H; destruct H as (w1, (w2, (?, (Ha, Hb)))); subst;
      apply app_in_eq; auto.
      + left.
        assumption.
      + right.
        assumption.
    - apply app_in_inv in H.
      destruct H as (w1, (w2, (?, (Ha, Hb)))); subst.
      apply union_in_inv in Ha.
      destruct Ha.
      + apply union_in_l.
        auto using app_in_eq.
      + apply union_in_r.
        auto using app_in_eq.
  Qed.

  Lemma pow_zero_rw:
    forall L,
    L ^^ 0 == Nil.
  Proof.
    split; intros.
    - inversion H; subst; clear H.
      apply nil_in.
    - apply nil_in_inv in H.
      subst.
      apply pow_nil.
  Qed.

  Lemma pow_succ_equiv:
    forall n L1 L2,
    L1 == L2 ->
    L1 ^^ n == L2 ^^ n ->
    L1 ^^ S n == L2 ^^ S n.
  Proof.
    split; intros.
    - inversion H1; subst; clear H1.
      apply H0 in H3.
      apply pow_cons with (w1:=w1) (w2:=w2); auto.
      apply H in H4.
      assumption.
    - inversion H1; subst; clear H1.
      apply H0 in H3.
      apply pow_cons with (w1:=w1) (w2:=w2); auto.
      apply H in H4.
      assumption.
  Qed.

  (** A nil inside a star can be elided. *)

  Lemma star_union_nil_rw:
    forall L1,
    (Nil U L1) * == L1 *.
  Proof.
    intros.
    split; intros.
    - destruct H as (n, H).
      induction H.
      + apply star_in_nil.
      + subst.
        destruct H0.
        * inversion H0; subst; clear H0.
          simpl.
          assumption.
        * apply star_cons_eq; auto.
    - destruct H as (n, H).
      induction H.
      + apply star_in_nil.
      + subst.
        apply star_cons_eq; auto.
        right.
        assumption.
  Qed.

End Rewrites.

Module Examples.
  Import Ascii.
  Import Util.
  Import LangNotations.
  Open Scope lang_scope.
  Open Scope char_scope. (* Ensure by default we are representing characters. *)

  (** Any string that ends with "a" *)
  Definition L1 : language := All >> "a".

  (** Show that the notation above is equivalent to writing a more direct, yet
     more verbose notation: *)
  Lemma l1_spec:
    L1 == fun w => exists w', w = w' ++ ["a"].
  Proof.
    unfold L1.
    (* When to unfold Equiv?
       - If the language only uses operators, then use rewrite rules.
       - If the language has a general specification (ie, without language
         operators, then you must unfold Equiv.
    *)
    unfold Equiv.
    (* A proof of equivalence consists of using destructor-lemmas on the
       assumption and constructor-lemmas to conclude.
       *)
    split; intros.
    - Search (In _ (_ >> _)).
      (*
       To note:
        - Lemmas that end with _inv destruct the assumption
        - Lemmas that end with _in_inv destruct assumptions In _ _

       Thus, app_in_inv destructructs an assumption that holds an App

       Not to be confused with lemmas that start with app_in_,
       they are *constructors*, which is necessary in the next goal.
      *)
      apply app_in_inv in H.
      destruct H as (wa, (wb, (?, (Ha, Hb)))).
      subst.
      unfold In.
      Search (In _ (Char _ )).
      apply char_in_inv in Hb.
      subst.
      exists wa.
      reflexivity.
    - (* This is an arbitrary In relation, so we must open it. *)
      unfold In in H.
      (* Destruct its contents as much as possible. *)
      destruct H as (wa, H).
      (* Take care of equations *)
      subst.
      (* Search for constructors of App: *)
      Search (In (_ ++ _) ( _ >> _)).
      apply app_in_eq.
      + Search (In _ All).
        apply all_in.
      + Search (In _ (Char _)).
        apply char_in.
  Qed.

  (** Show that string "a" is in L1. *)
  Lemma a_in_l1: In ["a"] L1.
  Proof.
    unfold L1.
    (*
      When using LangNotations, [] now becomes language Nil. If you use []
      to represent the empty list, you will get the following error:

         The term "[]" has type "word -> Prop" while it is expected to have type "list ascii".

      To work around the issue use nil to represent the empty string.
     *)
    apply app_in with (w1:=[]) (w2:=["a"]). (* When using lists use nil to represent  *)
    + apply all_in.
    + apply char_in.
    + auto.
    (* Alternative proof:
    apply app_l_all_in_skip.
    apply char_in.
    *)
  Qed.

  (** Show that we can rewrite under In *)
  Lemma a_in_l1_void: In ["a"] (L1 U {}).
  Proof.
    (* We recall that we can simplify the language by descarding {} *)
    Search (_ U {}).
    (* union_r_void_rw: forall L : language, L U {} == L *)
    rewrite union_r_void_rw.
    apply a_in_l1.
  Qed.

  (** Show that the empty string is not in L1. *)
  Lemma nil_not_in_l1: ~ In [] L1.
  Proof.
    unfold L1; intros N.
    Search (In _ (_ >> _)).
    apply app_in_inv in N.
    destruct N as (w1, (w2, (H1, (H2, H3)))).
    (* We gather that (H1) w1 ++ w2 is the empty string *)
    (* However, from (H3) we get that w2 is ["a"] *)
    apply char_in_inv in H3.
    subst.
    (* We are not done, because we do not know what w1 is. Let us do a case
       analysis on w1. *)
    destruct w1.
    + inversion H1. (* use the explosion principle, from w2 *)
    + inversion H1. (* use the explosion principle, from w1 *)
  Qed.

  (** Show that string "bbba" is L1 *)

  Lemma bbba_in_l1: In ["b"; "b"; "b"; "a"] L1.
  Proof.
    unfold L1.
    apply app_in with (w1:=["b"; "b"; "b"]) (w2:=["a"]).
    - apply all_in.
    - apply char_in.
    - reflexivity.
  Qed.

  (* An example that uses rewrites. *)
  Goal
    (("a" >> {}) * U "a") * == "a" *.
  Proof.
    (* Nil and Void are always great candidates to start your search. *)
    Search (_ >> {}).
    (* We can simplify the App: *)
    rewrite app_r_void_rw.
    (* We note that we have another candidate, so we search *)
    Search ({} *).
    (* We simplify the void star. *)
    rewrite star_void_rw.
    (* Another candidate: *)
    Search (Nil U _).
    rewrite star_union_nil_rw.
    (* Done. *)
    reflexivity.
  Qed.

  Definition L2 : language := fun w => length w = 2.

  (** Show that L2 can be described as concatenating two Any-characters. *)
  Lemma l2_spec:
    L2 == Any >> Any.
  Proof.
    unfold Examples.L2; split; intros.
    - unfold In in H.
      (* We know that w has length 2, but we must do a case analysis to look
         at its structure. *)
      destruct w. {
        (* Impossible because w = [] *)
        inversion H.
      }
      (* w <> [] *)
      (* Let us try to get the remaining character. *)
      destruct w. {
        (* Impossible because w = [a] *)
        inversion H.
      }
      destruct w. {
        (* The only possible case where the list has exactly 2 elements. *)
        Search (App Any _).
        apply app_l_any_in.
        apply any_in.
      }
      (* This case is impossible because the list has at least 3 elements. *)
      inversion H.
    - Search (Any >> _).
      apply app_l_any_in_inv in H.
      destruct H as (w', (c1, (?, Hi))).
      subst.
      apply any_in_inv in Hi.
      destruct Hi as (c2, ?).
      subst.
      reflexivity.
  Qed.

  (** Show that string "01" is in L2. *)
  Lemma _01_in_l2: In ["0"; "1"] L2.
  Proof.
    unfold L2.
    reflexivity.
  Qed.

  Definition L3 : language := "a" >> All >> "b".

  Lemma l3_spec:
    L3 == fun w => exists w', ["a"] ++ w' ++ ["b"] = w.
  Proof.
    unfold L3; split; intros.
    - apply app_r_char_in_inv in H.
      destruct H as (w1, (?, Hw)).
      apply app_l_char_in_inv in Hw.
      destruct Hw as (w2, (?, _)).
      subst.
      simpl.
      exists w2.
      reflexivity.
    - unfold In in H.
      destruct H as (w', ?).
      subst.
      simpl.
      apply app_assoc_in_1.
      apply app_l_char_in.
      apply app_l_all_in.
      apply char_in.
  Qed.

  (** We define the language in terms of the Pow and App combinators. *)

  Definition L4 := fun w => exists n, In w ("a" ^^ n >> "b" ^^ n).

  (** We then show that this correspond to our expectation of when not using
      combinators: *)
  Lemma l4_spec:
    L4 == fun x => exists n, pow1 "a" n ++ pow1 "b" n = x.
  Proof.
    unfold L4; split; intros.
    - destruct H as (n, Hw).
      exists n.
      apply app_in_inv in Hw.
      destruct Hw as (w1, (w2, (?, (Ha, Hb)))).
      subst.
      apply pow_char_in_inv in Ha.
      apply pow_char_in_inv in Hb.
      subst.
      reflexivity.
    - destruct H as (n, H).
      subst.
      exists n.
      apply app_in_eq.
      + apply pow_char_in.
      + apply pow_char_in.
  Qed.

  (** L4 accepts the empty string. *)
  Lemma nil_in_l4: In [] L4.
  Proof.
    unfold L4.
    exists 0.
    apply app_in with (w1:=[]) (w2:=[]).
    + apply pow_nil.
    + apply pow_nil.
    + reflexivity.
  Qed.

  (** L4 accepts a single a and a single b. *)
  Lemma aabb_in_l4: In ["a"; "a"; "b"; "b"] L4.
  Proof.
    exists 2.
    apply app_in with (w1:=["a"; "a"]) (w2:=["b"; "b"]).
    + apply pow_char_cons, pow_char_cons.
      apply pow_nil.
    + apply pow_char_cons, pow_char_cons.
      apply pow_nil.
    + reflexivity.
  Qed.

  Lemma abb_not_in_l4: ~ In ["a"; "b"; "b"] L4.
  Proof.
    unfold L4;
    intros N.
    destruct N as (n, N).
    (* Let us rearrange the string to be in terms of Util.pow1. *)
    assert (R: ["a"; "b"; "b"] = (pow1 "a" 1 ++ pow1 "b" 2) % list) by reflexivity.
    rewrite R in *; clear R.
    (* Our language is: a^n b^n = a^1 b^2, thus n = 1 and n = 2
       and we reach a contradiction. *)
    apply pow_pow_in_inv_eq in N.
    - (* n = 1 and n = 2, contradiction *)
      destruct N.
      subst.
      inversion H0.
    - (* show that a = b *)
      intros M.
      inversion M.
  Qed.

  (** Show that this random string is not in L4 *)

  Lemma car_not_in_l4: ~ In ["c"; "a"; "r"] L4.
  Proof.
    unfold L4.
    intros N.
    destruct N as (n, H).
    (* Since the left-hand side has a power, we can enforce that the first
       character has to be a 'a' if n > 0. Let us do a case analysis on n. *)
    destruct n. {
      apply app_in_inv in H.
      destruct H as (w1, (w2, (Hs, (Ha, Hb)))).
      (* Any power of 0 yields an empty string, so w1 = [] and w2 = [] *)
      inversion Ha; subst.
      inversion Hb; subst.
      (* Thus "car" = "" which is a contradiction. *)
      inversion Hs.
    }
    apply app_in_inv in H.
    destruct H as (w1, (w2, (Hs, (Ha, Hb)))).
    (* Ha is: a ^ (S n) = w, so we know that w = a :: w' *)
    apply pow_char_cons_inv in Ha.
    destruct Ha as (w', (?, ?)).
    subst.
    (* Hs now says that on the lhs starts with c and rhs starts with a,
       contradiction. *)
    inversion Hs.
  Qed.

End Examples.


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.
Require Import Program.Wf.

Unset Printing Records.

From Ordinal Require Import Defs.
From Ordinal Require Import Operators.
From Ordinal Require Import Arith.
From Ordinal Require Import Fixpoints.
From Ordinal Require Import VeblenDefs.

Require Import List.
Import ListNotations.
Open Scope list.

Section VeblenSymbol.
  Variable Idx : Type.
  Variable idx_lt : Idx -> Idx -> Prop.
  Variable idx_zero : Idx.
  Variable idx_succ : Idx -> Idx.

  Hypothesis idx_lt_trans: forall x y z, idx_lt x y -> idx_lt y z -> idx_lt x z.
  Hypothesis idx_lt_wf : well_founded idx_lt.
  Hypothesis idx_succ_lt : forall x, idx_lt x (idx_succ x).

  Definition idx_le i j := forall x, idx_lt x i -> idx_lt x j.

  Fixpoint well_formed_tail i (ls:list (Idx * Ord)) : Prop :=
    match ls with
    | [] => True
    | ((j,x) :: ls') => idx_lt i j /\ well_formed_tail j ls'
    end.

  Definition well_formed_symbol (ls:list (Idx * Ord)) : Prop :=
    match ls with
    | [] => True
    | ((i,x) :: ls') => well_formed_tail i ls'
    end.

  Lemma well_formed_tail_symbol i ls : well_formed_tail i ls -> well_formed_symbol ls.
  Proof.
    destruct ls; simpl in *; intuition.
    destruct p. intuition.
  Qed.

  Fixpoint indices_bounded (ls:list (Idx * Ord)) (i:Idx) : Prop :=
    match ls with
    | [] => True
    | ((j,x) :: ls') => idx_lt j i /\ indices_bounded ls' i
    end.

  Lemma well_formed_symbols_bounded : forall ls, well_formed_symbol ls -> exists i, indices_bounded ls i.
  Proof.
    intros ls. destruct ls.
    - exists idx_zero. simpl. auto.
    - destruct p as [j x].
      simpl.
      clear x.
      revert j.
      induction ls.
      + simpl; intros.
        exists (idx_succ j). split; auto.
      + intros.
        destruct a as [k y].
        simpl in *.
        destruct H as [Hk H].
        destruct (IHls k H) as [i [??]].
        exists i; intuition.
        apply idx_lt_trans with k; auto.
  Qed.

  Lemma is_well_formed_tail a xs : well_formed_symbol (a::xs) -> well_formed_symbol xs.
  Proof.
    destruct a. simpl. destruct xs; intuition.
    apply well_formed_tail_symbol with i; auto.
  Qed.

  Lemma is_well_formed_cons j y i x x' ls :
    idx_lt j i ->
    well_formed_symbol ((i,x)::ls) ->
    well_formed_symbol ((j,y)::(i,x')::ls).
  Proof.
    simpl; intros. split; auto.
  Qed.

  Lemma is_well_formed_prefix : forall xs ys, well_formed_symbol (xs ++ ys) -> well_formed_symbol xs.
  Proof.
    destruct xs; simpl; auto.
    destruct p as [i _].
    revert i; induction xs; simpl; intuition; eauto.
  Qed.

  Lemma well_formed_tail_bounded : forall xs i j o ys,
      well_formed_tail i (xs ++ (j,o) :: ys) -> idx_lt i j /\ indices_bounded xs j.
  Proof.
    induction xs; simpl.
    - intuition.
    - destruct a as [k _]. simpl; intros i j o ys [H1 H2].
      apply IHxs in H2.
      intuition.
      apply idx_lt_trans with k; auto.
  Qed.

  Lemma well_formed_bounded : forall xs j o ys,
      well_formed_symbol (xs ++ (j,o) :: ys) -> indices_bounded xs j.
  Proof.
    destruct xs; simpl.
    - intuition.
    - destruct p as [k _].
      apply well_formed_tail_bounded.
  Qed.

  Definition VeblenSymbol := { ls:list (Idx*Ord) | well_formed_symbol ls }.

  Inductive symbol_lt : list (Idx*Ord) -> list (Idx*Ord) -> Prop :=
  | symbol_lt_drop : forall i x ls, symbol_lt ls ((i,x)::ls)
  | symbol_lt_ord  : forall i x x' ls ys,
      x' < x ->
      indices_bounded ys i ->
      symbol_lt (ys ++ ((i,x')::ls)) ((i,x)::ls).

  Definition VeblenSymbol_lt (xs ys : VeblenSymbol) : Prop :=
    symbol_lt (proj1_sig xs) (proj1_sig ys).

  Lemma symbol_lt_append_Acc : forall a,
    Acc symbol_lt a ->
    forall b, Acc symbol_lt b ->
    Acc symbol_lt (a ++ b).
  Proof.
    intros a Ha. induction Ha.
    intros b Hb.
    destruct x as [|[j o] x].
    - simpl; auto.
    - simpl.
      constructor. simpl; intros.
      inversion H1; subst.
      + apply H0; auto.
        apply symbol_lt_drop.
      + cut (Acc symbol_lt ((ys ++ ((j,x') :: x)) ++ b)).
        { rewrite <- app_assoc. auto. }
        apply H0; auto.
        apply symbol_lt_ord; auto.
  Qed.

  Theorem symbol_lt_bounded_Acc : forall i xs, indices_bounded xs i -> Acc symbol_lt xs.
  Proof.
    induction i as [i Hind_i] using (well_founded_induction idx_lt_wf).
    induction xs; intros.
    - constructor. intros ys Hys.
      inversion Hys.
    - destruct a as [j x]. simpl in *. destruct H.
      induction x as [x Hind_x] using ordinal_induction.
      constructor. intros ys. intro Hys.
      inversion Hys; subst.
      + apply IHxs; auto.
      + apply symbol_lt_append_Acc.
        * apply (Hind_i j); auto.
        * apply Hind_x; auto.
  Qed.

  Theorem symbol_lt_well_formed_Acc : forall xs, well_formed_symbol xs -> Acc symbol_lt xs.
  Proof.
    intros.
    destruct (well_formed_symbols_bounded xs H) as [i Hi].
    apply (symbol_lt_bounded_Acc i xs Hi).
  Qed.

  Section MultiVeblen.
    Variable f : Ord -> Ord.

    Lemma step_down i (j:{ j:Idx | idx_lt j i}) A g ai y ls :
      symbol_lt ((proj1_sig j,y)::(i,g ai)::ls) ((i,ord A g)::ls).
    Proof.
      apply (symbol_lt_ord i (ord A g) (g ai) ls [(proj1_sig j,y)]).
      - apply (index_lt (ord A g) ai).
      - simpl; split; auto. apply (proj2_sig j).
    Qed.

    Fixpoint MultiVeblen (xs : list (Idx*Ord)) (HAcc : Acc symbol_lt xs) {struct HAcc} : Ord -> Ord :=
      fix inner (x:Ord) : Ord :=
        match xs as xs' return Acc symbol_lt xs' -> Ord with
        | [] => fun _ => f x
        | ((i,ord A g)::ls) => fun HAcc' =>
            match HAcc' with
            | Acc_intro _ Hsub =>
              MultiVeblen ls (Hsub ls (symbol_lt_drop i (ord A g) ls)) x ⊔
              match x with
              | ord X h =>
                @supOrd A (fun ai =>
                   fixOrd (MultiVeblen ((i,g ai)::ls) (Hsub _ (symbol_lt_ord i (ord A g) (g ai) ls nil (index_lt (ord A g) ai) I)))
                              (ord X (fun xi => inner (h xi)))
                   ⊔
                @supOrd { j:Idx | idx_lt j i} (fun j =>
                   fixOrd (fun y => MultiVeblen ((proj1_sig j,y)::(i,g ai)::ls) (Hsub _ (step_down i j A g ai y ls)) zeroOrd)
                       (ord X (fun xi => inner (h xi)))
                   ))
              end
        end
      end HAcc.

   End MultiVeblen.
End VeblenSymbol.

Definition nat_symbol := list (nat*Ord).

Require Import Lia.

Lemma nat_symbol_bounded : forall (x:nat_symbol), exists i, indices_bounded nat lt x i.
Proof.
  induction x; simpl.
  - exists O. auto.
  - destruct IHx as [i Hi].
    destruct a as [j _]; simpl.
    exists (Peano.max i (S j)).
    split; [ lia | ].
    induction x; simpl.
    + auto.
    + destruct a as [k y]; simpl in *.
      split; [ lia | intuition ].
Qed.

Require Import Wf_nat.

Lemma nat_symbol_lt_wf : well_founded (symbol_lt nat lt).
Proof.
  intro x.
  destruct (nat_symbol_bounded x) as [i Hi].
  apply symbol_lt_bounded_Acc with i; auto.
  apply lt_wf.
Qed.

Definition nth_veblen (n:nat) : Ord -> Ord :=
  MultiVeblen nat lt powOmega [(n,1)] (nat_symbol_lt_wf [(n,1)]).

Definition SmallVeblenOrdinal : Ord := ord nat (fun n => nth_veblen n 0).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** ** Luca's theorem *)

Require Import Arith Nat Omega Lia List.
Require Import utils_tac gcd prime binomial sums Zp rel_iter.

Set Implicit Arguments.

Local Notation power := (mscal mult 1).
Local Notation expo := (mscal mult 1).

Section fact.

  Let factorial_cancel n a b : fact n * a = fact n * b -> a = b.
  Proof.
    apply Nat.mul_cancel_l.
    generalize (fact_gt_0 n); intro; lia.
  Qed.

  Notation Π := (msum mult 1).

  Notation mprod_an := (fun a n => Π n (fun i => i+a)).

  Fact mprod_factorial n : fact n = mprod_an 1 n.
  Proof.
    induction n as [ | n IHn ].
    + rewrite msum_0; auto.
    + rewrite msum_plus1; auto.
      rewrite mult_comm, <- IHn, fact_S.
      f_equal; lia.
  Qed.

  Variable (p : nat) (Hp : p <> 0).

  Notation "〚 x 〛" := (nat2Zp Hp x).

  Let expo_p_cancel n a b : expo n p * a = expo n p * b -> a = b.
  Proof.
    apply Nat.mul_cancel_l.
    generalize (power_ge_1 n Hp); intros; lia.
  Qed.

  Fact mprod_factorial_Zp i n :〚mprod_an (i*p+1) n〛=〚fact n〛.
  Proof.
    rewrite mprod_factorial.
    induction n as [ | n IHn ].
    + do 2 rewrite msum_0; auto.
    + do 2 (rewrite msum_plus1; auto).
      do 2 rewrite nat2Zp_mult; f_equal; auto.
      apply nat2Zp_inj.
      rewrite (plus_comm n), <- plus_assoc, plus_comm.
      rewrite <- rem_plus_div; auto.
      * f_equal; lia.
      * apply divides_mult, divides_refl.
  Qed.

  Notation φ := (fun n r => mprod_an (n*p+1) r).
  Notation Ψ := (fun n => Π n (fun i => mprod_an (i*p+1) (p-1))).

  Let phi_Zp_eq n r :〚φ n r〛=〚fact r〛.
  Proof. apply mprod_factorial_Zp. Qed.

  Fact mprod_factorial_mult n : fact (n*p) = expo n p * fact n * Ψ n.
  Proof.
    induction n as [ | n IHn ].
    + rewrite Nat.mul_0_l, msum_0, mscal_0, fact_0; auto.
    + replace (S n*p) with (n*p+p) by ring.
      rewrite mprod_factorial, msum_plus, <- mprod_factorial; auto.
      replace p with (S (p-1)) at 2 by omega.
      rewrite msum_plus1; auto.
      rewrite <- plus_assoc.
      replace (p-1+1) with p by omega.
      replace (n*p+p) with ((S n)*p) by ring.
      rewrite mscal_S, fact_S, msum_S.
      rewrite IHn.
      repeat rewrite mult_assoc.
      rewrite (mult_comm _ p).
      repeat rewrite <- mult_assoc.
      do 2 f_equal.
      rewrite (mult_comm (S n)).
      repeat rewrite <- mult_assoc; f_equal.
      repeat rewrite mult_assoc; f_equal.
      rewrite msum_ext with (f := fun i => n*p+i+1)
                            (g := fun i => i+(n*p+1)).
      2: intros; ring.
      rewrite <- msum_plus1; auto.
  Qed.

  Lemma mprod_factorial_euclid n r : fact (n*p+r) = expo n p * fact n * φ n r * Ψ n.
  Proof.
    rewrite mprod_factorial, msum_plus; auto.
    rewrite <- mprod_factorial.
    rewrite msum_ext with (f := fun i => n*p+i+1)
                          (g := fun i => i+(n*p+1)).
    2: intros; ring.
    rewrite mprod_factorial_mult; auto; ring.
  Qed.

  Notation Zp := (Zp_zero Hp).
  Notation Op := (Zp_one Hp).
  Notation "∸" := (Zp_opp Hp).
  Infix "⊗" := (Zp_mult Hp) (at level 40, left associativity).
  Notation expoZp := (mscal (Zp_mult Hp) (Zp_one Hp)).

  Hint Resolve Nat_mult_monoid.

  Let Psi_Zp_eq n :〚Ψ n〛= expoZp n〚fact (p-1)〛.
  Proof.
    induction n as [ | n IHn ].
    + rewrite msum_0, mscal_0; auto.
    + rewrite msum_plus1, nat2Zp_mult.
      rewrite mscal_plus1; auto.
      2: apply Zp_mult_monoid.
      2: apply Nat_mult_monoid.
      f_equal; auto.
  Qed.

  Hypothesis (Hprime : prime p).

  Let phi_Zp_invertible n r : r < p -> Zp_invertible Hp 〚φ n r〛.
  Proof.
    intros H; simpl; rewrite phi_Zp_eq.
    apply Zp_invertible_factorial; auto.
  Qed.

  Let Psi_Zp_invertible n : Zp_invertible Hp 〚Ψ n〛.
  Proof.
    simpl; rewrite (Psi_Zp_eq n).
    apply Zp_expo_invertible, Zp_invertible_factorial; auto; omega.
  Qed.

  (** rewrite the binomial theorem

               fact k * fact (n-k) * binomial n k = fact n

      when

         k = K*p + k0
         n = N*p + n0

      with

      1)  K <= N & k0 <= n0

      we get n-k = (N-K)*p + (n0-k0) and

        expo K     p * fact K     * φ K      k0     * Ψ K
      .* expo (N-K) p * fact (N-K) * φ (N-K) (n0-k0) * Ψ (N-K)
      .* binomial n k
      = expo N p     * fact N     * φ N      n0     * Ψ N.

      hence, simplifying by expo N p  we get

        fact K * fact (N-K) * φ K k0 * Ψ K * φ (N-K) (n0-k0) * Ψ (N-K) * binomial n k = fact N * φ N n0 * Ψ N.

      then in Z/Zp we derive (modulo Wilson's theorem, unnecessary here〚fact (p-1)〛=〚-1〛)

       〚fact K〛⊗〚fact (N-K)〛⊗〚fact k0〛⊗〚-1〛^K⊗〚fact (n0-k0)〛⊗〚-1〛^(N-K)⊗〚binomial n k〛
      =〚fact N〛⊗〚fact n0〛⊗〚-1〛^N

        that we combine with 〚fact K〛⊗〚fact (N-K)〛⊗〚binomial N K〛=〚fact N〛
                        and  〚fact k0〛⊗〚fact (n0-k0)〛⊗〚binomial n0 k0〛=〚fact n0〛

        to derive the result:〚binomial n k 〛=〚binomial N K〛⊗〚binomial n0 k0〛

      with

      2) K < N & n0 < k0

      we have n-k = (N-(K+1))*p + (p-(k0-n0)) and

        expo K         p * fact K         * φ K          k0         * Ψ K
      .* expo (N-(K+1)) p * fact (N-(K+1)) * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1))
      .* binomial n k
      = expo N p     * fact N     * φ N      n0     * Ψ N.

      hence

         fact K * φ K k0 * Ψ K * fact (N-(K+1)) * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
       = p * ....

      then in Z/Zp all the left factor are invertible except binomial n k which must thus be〚0〛 *)

  Section binomial_without_p_not_zero.

    Variable (n N n0 k K k0 : nat) (Hn : n = N*p+n0) (Hk : k = K*p+k0) (H1 : K <= N) (H2 : k0 <= n0).

    Let Hkn : k <= n.
    Proof.
      rewrite Hn, Hk.
      replace N with (K+(N-K)) by omega.
      rewrite Nat.mul_add_distr_r.
      generalize ((N-K)*p); intros; omega.
    Qed.

    Let Hnk : n - k = (N-K)*p+(n0-k0).
    Proof.
      rewrite Hn, Hk, Nat.mul_sub_distr_r.
      cut (K*p <= N*p).
      + generalize (K*p) (N*p); intros; omega.
      + apply mult_le_compat; auto.
    Qed.

    Fact binomial_wo_p : φ K k0 * Ψ K * φ (N-K) (n0-k0) * Ψ (N-K) * binomial n k
                       = binomial N K * φ N n0 * Ψ N.
    Proof.
      apply (factorial_cancel (N-K)); repeat rewrite mult_assoc.
      rewrite (mult_comm (fact _) (binomial _ _)).
      apply (factorial_cancel K); repeat rewrite mult_assoc.
      rewrite (mult_comm (fact _) (binomial _ _)).
      rewrite <- binomial_thm; auto.
      apply expo_p_cancel with N.
      repeat rewrite mult_assoc.
      rewrite <- mprod_factorial_euclid, <- Hn.
      rewrite binomial_thm with (1 := Hkn).
      rewrite Hnk.
      rewrite Hk at 3.
      replace N with (K+(N-K)) at 1 by omega.
      rewrite power_plus.
      do 2 rewrite mprod_factorial_euclid.
      ring.
    Qed.

    Hypothesis (Hn0 : n0 < p).

    Hint Resolve Zp_mult_monoid.

    Fact binomial_Zp_prod :〚binomial n k〛=〚binomial N K〛⊗〚binomial n0 k0〛.
    Proof.
      generalize binomial_wo_p; intros G.
      apply f_equal with (f := nat2Zp Hp) in G.
      repeat rewrite nat2Zp_mult in G.
      repeat rewrite Psi_Zp_eq in G.
      repeat rewrite phi_Zp_eq in G.
      rewrite binomial_thm with (1 := H2) in G.
      repeat rewrite nat2Zp_mult in G.
      rewrite (Zp_mult_comm _ _〚 fact k0 〛) in G.
      repeat rewrite Zp_mult_assoc in G.
      rewrite (Zp_mult_comm _ _〚 fact k0 〛) in G.
      repeat rewrite <- Zp_mult_assoc in G.
      apply Zp_invertible_cancel_l in G.
      2: apply Zp_invertible_factorial; auto; omega.
      repeat rewrite Zp_mult_assoc in G.
      do 2 rewrite (Zp_mult_comm _ _〚 fact _ 〛) in G.
      repeat rewrite <- Zp_mult_assoc in G.
      apply Zp_invertible_cancel_l in G.
      2: apply Zp_invertible_factorial; auto; omega.
      repeat rewrite Zp_mult_assoc in G.
      rewrite <- mscal_plus in G; auto.
      replace (K+(N-K)) with N in G by omega.
      rewrite (Zp_mult_comm _ _ (expoZp _ _)) in G.
      apply Zp_invertible_cancel_l in G; trivial.
      apply Zp_expo_invertible, Zp_invertible_factorial; auto; omega.
    Qed.

  End binomial_without_p_not_zero.

  Section binomial_without_p_zero.

    Variable (n N n0 k K k0 : nat) (Hn : n = N*p+n0) (Hk : k = K*p+k0)
             (H1 : K < N) (H2 : n0 < k0) (Hk0 : k0 < p).

    Let H3 : p - (k0-n0) < p.    Proof. omega. Qed.
    Let H4 : S (N-1) = N.        Proof. omega. Qed.
    Let H5 : N-1 = K+(N-(K+1)).  Proof. omega. Qed.
    Let H6 : N = K+1+(N-(K+1)).  Proof. omega. Qed.
    Let HNK : N-K = S (N-(K+1)). Proof. omega. Qed.

    Let Hkn : k <= n.
    Proof.
      rewrite Hn, Hk, H6.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((N-(K+1))*p); clear H3 H4 H5 H6 HNK; intros; omega.
    Qed.

    Let Hnk : n - k = (N-(K+1))*p+(p-(k0-n0)).
    Proof.
      rewrite Hn, Hk, Nat.mul_sub_distr_r.
      cut ((K+1)*p <= N*p).
      + rewrite Nat.mul_add_distr_r.
        generalize (K*p) (N*p); clear H3 H4 H5 H6 HNK Hkn; intros; omega.
      + apply mult_le_compat; auto; clear H3 H4 H5 H6 HNK Hkn; omega.
    Qed.

    Fact binomial_with_p : fact K * fact (N-(K+1)) * φ K k0 * Ψ K * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
                         = p * fact N * φ N n0 * Ψ N.
    Proof.
      apply expo_p_cancel with (N-1).
      repeat rewrite mult_assoc.
      rewrite (mult_comm (expo _ _) p).
      rewrite <- mscal_S.
      rewrite H4, <- mprod_factorial_euclid, <- Hn.
      rewrite binomial_thm with (1 := Hkn).
      rewrite Hnk.
      rewrite Hk at 3.
      do 2 rewrite mprod_factorial_euclid.
      rewrite H5 at 1.
      rewrite power_plus.
      ring.
    Qed.

    Fact binomial_with_p' : φ K k0 * Ψ K * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
                          = p * binomial N K * (N-K) * φ N n0 * Ψ N.
    Proof.
      apply (factorial_cancel (N-(K+1))); repeat rewrite mult_assoc.
      apply (factorial_cancel K); repeat rewrite mult_assoc.
      rewrite binomial_with_p.
      rewrite binomial_thm with (n := N) (p := K).
      2: { apply lt_le_weak; auto. }
      rewrite HNK at 1.
      rewrite fact_S.
      rewrite <- HNK.
      ring.
    Qed.

    Fact binomial_Zp_zero :〚binomial n k〛= Zp.
    Proof.
      generalize binomial_with_p'; intros G.
      apply f_equal with (f := nat2Zp Hp) in G.
      repeat rewrite nat2Zp_mult in G.
      rewrite nat2Zp_p in G.
      repeat rewrite Zp_mult_zero in G.
      apply Zp_invertible_eq_zero in G; auto.
      repeat (apply Zp_mult_invertible; auto).
    Qed.

  End binomial_without_p_zero.

End fact.

Section lucas_lemma.

  (* https://math.stackexchange.com/questions/1463758/proof-of-lucas-theorem-without-the-polynomial-hint *)

  Variables (p : nat) (Hprime : prime p).

  Let Hp : p <> 0.
  Proof.
    generalize (prime_ge_2 Hprime); intro; omega.
  Qed.

  Variables (n N n0 k K k0 : nat)
            (G1 : n = N*p+n0)  (G2 : n0 < p)
            (G3 : k = K*p+k0)  (G4 : k0 < p).

  Let choice : (K <= N  /\ k0 <= n0)
            \/ (n0 < k0 /\ K < N)
            \/ ((n0 < k0 \/ N < K) /\ n < k).
  Proof.
    destruct (le_lt_dec k n) as [ H0 | H0 ];
    destruct (le_lt_dec k0 n0) as [ H1 | H1 ];
    destruct (le_lt_dec K N) as [ H2 | H2 ]; try omega.
    + do 2 right; split; auto.
      rewrite G1, G3.
      replace K with (N+1+(K-N-1)) by omega.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((K-N-1)*p); intros; omega.
    + destruct (eq_nat_dec N K); try omega.
      do 2 right; split; auto.
      rewrite G1, G3; subst N; omega.
    + do 2 right; split; auto.
      rewrite G1, G3.
      replace K with (N+1+(K-N-1)) by omega.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((K-N-1)*p); intros; omega.
  Qed.

  Theorem lucas_lemma : rem (binomial n k) p = rem (binomial N K * binomial n0 k0) p.
  Proof.
    destruct choice as [ (H1 & H2)
                     | [ (H1 & H2)
                       | (H1 & H2) ] ]; clear choice.
    3: { rewrite binomial_gt with (1 := H2).
         f_equal.
         destruct H1 as [ H1 | H1 ];
           rewrite binomial_gt with (1 := H1); ring. }
    + apply nat2Zp_inj with (Hp := Hp).
      rewrite nat2Zp_mult.
      apply binomial_Zp_prod; auto.
    + rewrite binomial_gt with (1 := H1).
      rewrite Nat.mul_0_r.
      apply nat2Zp_inj with (Hp := Hp).
      rewrite nat2Zp_zero.
      apply binomial_Zp_zero with (2 := G1) (3 := G3); auto.
  Qed.

End lucas_lemma.

Check lucas_lemma.
Print Assumptions lucas_lemma.


Require Import Coq.Lists.List.
Import ListNotations.

Set Implicit Arguments.

Section Prefix.

  Variable A : Type.

  Inductive prefix : list A -> list A -> Prop :=
  | prefix_empty : forall l, prefix [] l
  | prefix_cons : forall x l l', prefix l l' -> prefix (x::l) (x::l').

  Lemma prefix_refl :
    forall l, prefix l l.
  Proof.
    induction l; constructor; assumption.
  Qed.

  Lemma prefix_app :
    forall l1 l2 l3, prefix l1 l2 -> prefix l1 (l2 ++ l3).
  Proof.
    intros l1 l2 l3 Hpre.
    induction Hpre; simpl; constructor; assumption.
  Qed.

  Lemma prefix_app_exists :
    forall l1 l3, prefix l1 l3 -> exists l2, l3 = l1 ++ l2.
  Proof.
    intros l1 l2 Hpre.
    induction Hpre.
    exists l; reflexivity.
    inversion IHHpre as [l2 Hl2].
    rewrite Hl2.
    exists l2.
    reflexivity.
  Qed.

End Prefix.

Section Postfix.

  Variable A : Type.

  Inductive postfix (l : list A) : list A -> Prop :=
  | postfix_refl : postfix l l
  | postfix_cons : forall x l', postfix l l' -> postfix l (x::l').

  Lemma postfix_empty :
    forall l, postfix [] l.
  Proof.
    induction l; constructor; assumption.
  Qed.

  Lemma postfix_app :
    forall l1 l2 l3, postfix l1 l2 -> postfix (l1 ++ l3) (l2 ++ l3).
  Proof.
    intros l1 l2 l3 Hpost.
    induction Hpost; simpl; constructor; assumption.
  Qed.

  Lemma postfix_app_exists :
    forall l1 l3, postfix l1 l3 -> exists l2, l3 = l2 ++ l1.
  Proof.
    intros l1 l3 Hpost.
    induction Hpost.
    exists []; reflexivity.
    rename l' into l3.
    inversion IHHpost as [l2 Hl2].
    exists (x::l2); simpl.
    rewrite Hl2; reflexivity.
  Qed.

  Theorem prefix_postfix_rev :
    forall l1 l2, prefix l1 l2 -> postfix (rev l1) (rev l2).
  Proof.
    intros l1 l2 Hpre.
    induction Hpre.
    apply postfix_empty.
    apply postfix_app.
    assumption.
  Qed.

  Theorem postfix_prefix_rev :
    forall l1 l2, postfix l1 l2 -> prefix (rev l1) (rev l2).
  Proof.
    intros l1 l2 Hpost.
    induction Hpost.
    apply prefix_refl.
    apply prefix_app.
    assumption.
  Qed.

End Postfix.

Section Assoc.

  Variable A : Type.
  Hypothesis eq_dec : forall x y : A, {x = y} + {x <> y}.
  Variable B : Type.

  Fixpoint assoc (l : list (A*B)) (x : A) : option B :=
    match l with
    | [] => None
    | ab::l' => let '(a,b) := ab in if eq_dec x a then Some b else assoc l' x
    end.

End Assoc.

Section FunctionDef.

  Variable A B : Type.
  Variable R : A -> B -> Prop.

  Definition function := forall a, exists! b, R a b.

  Theorem function_eq :
    function ->
    forall a b b', R a b -> R a b' -> b' = b.
  Proof.
    unfold function.
    intros H a b b' Hb Hb'.
    specialize (H a).
    inversion H as [b'' Huniq].
    replace b with b'' by (apply Huniq; assumption).
    replace b' with b'' by (apply Huniq; assumption).
    reflexivity.
  Qed.

End FunctionDef.

Section ListRel.

  Variable A B : Type.
  Variable R : A -> B -> Prop.

  Inductive list_rel : list A -> list B -> Prop :=
  | list_rel_nil : list_rel [] []
  | list_rel_cons : forall x xs y ys,
      list_rel xs ys -> R x y -> list_rel (x::xs) (y::ys).

  Theorem function_rel__function_list_rel :
    function R -> function list_rel.
  Proof.
    unfold function.
    intros Hf xs.
    induction xs as [|x xs].

    (* Nil *)
    exists [].
    split.
    constructor.
    intros ys Hlr.
    inversion Hlr.
    reflexivity.

    (* Cons *)
    inversion IHxs as [ys Hys]; subst; clear IHxs.
    specialize (Hf x).
    inversion Hf as [y Hy]; subst; clear Hf.
    exists (y::ys).
    destruct Hys as [Hlrs Hys_uniq].
    destruct Hy as [HRxy Hy_uniq].
    split.
    constructor; assumption.
    intros ys'.
    destruct ys' as [|y' ys']; intros H; inversion H; subst; clear H.
    replace y' with y by (apply Hy_uniq; assumption).
    replace ys' with ys by (apply Hys_uniq; assumption).
    reflexivity.
  Qed.

  Theorem function_list_rel__function_rel :
    function list_rel -> function R.
  Proof.
    unfold function.
    intros H a.
    specialize (H [a]).
    inversion H as [bs (Hb,Huniq)].
    destruct bs; inversion Hb; subst; clear Hb.
    exists b.
    split.
    assumption.
    intros b' Hb'.
    inversion H3; subst; clear H3.
    assert (list_rel [a] [b']) as Hlb'.
    constructor.
    constructor.
    assumption.
    specialize (Huniq [b'] Hlb').
    inversion Huniq.
    reflexivity.
  Qed.

End ListRel.

Section ListRelEq.

  Variable A : Type.

  Theorem list_rel_eq__list_eq :
    forall (l1 l2 : list A), list_rel eq l1 l2 -> l1 = l2.
  Proof.
    induction l1; intros l2 Hlr;
      inversion Hlr as [ | x xs y ys]; subst.
    reflexivity.
    replace ys with l1 by (apply IHl1; assumption); reflexivity.
  Qed.

End ListRelEq.

Section FunctionComposition.

  Variable A B C : Type.

  Definition comp (R1 : A -> B -> Prop) (R2 : B -> C -> Prop) : A -> C -> Prop :=
    fun a c => forall b, R1 a b -> R2 b c.

  Theorem comp_function :
    forall R1 R2,
      function R1 -> function R2 -> function (comp R1 R2).
  Proof.
    unfold function, comp.
    intros R1 R2 HR1 HR2 a.
    specialize (HR1 a).
    inversion HR1 as [b (Hb,Hb1)]; clear HR1.
    specialize (HR2 b).
    inversion HR2 as [c (Hc,Hc1)]; clear HR2.
    exists c.
    split.
    intros b' Hb'.
    replace b'  with b by (apply Hb1; assumption).
    assumption.
    intros c' Hc'.
    apply Hc1.
    apply Hc'.
    assumption.
  Qed.

  Theorem comp_correct :
    forall (f : B -> C) (g : A -> B) x y,
      f (g x) = y <-> comp (fun a b => g a = b) (fun b c => f b = c) x y.
  Proof.
    unfold comp.
    intros f g x y.
    split; intros H.
    intros b Hg; subst; reflexivity.
    apply H.
    reflexivity.
  Qed.

End FunctionComposition.

Section Relations.

  Section Converse.
    Variable A B : Type.
    Variable R : A -> B -> Prop.

    Definition transp (b : B) (a : A) : Prop := R a b.
  End Converse.

End Relations.


Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect.

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

Lemma iter_id (T : Type) n : @iter T n id =1 id.
Proof. by elim: n. Qed.

Lemma iterK n (T : Type) (f g : T -> T) :
  cancel f g -> cancel (iter n f) (iter n g).
Proof.
by move => can_fg; elim: n => // n IHn x; rewrite iterS iterSr IHn can_fg.
Qed.

Lemma leq_subl n m o : n <= m -> n - o <= m.
Proof. move => A. rewrite -[m]subn0. exact: leq_sub. Qed.

(** *** Lemmas on [index] and [subseq] *)
(** could go to seq.v *)

Lemma mem2_index (T : eqType) (x y : T) (s : seq T) :
  uniq s -> y \in s -> mem2 s x y = (index x s <= index y s).
Proof.
have [|xNs _ y_s] := boolP (x \in s); last first.
  by rewrite mem2lf // (memNindex xNs) leqNgt index_mem y_s.
elim: s => //= z s IHs x_s /andP[zNs uniq_s] y_s; rewrite mem2_cons.
rewrite y_s; have [-> //|zDx] := eqVneq z x.
have [<-|zDy] := eqVneq z y;first by rewrite mem2rf.
rewrite !inE ?[_ == z]eq_sym ?(negbTE zDy) ?(negbTE zDx) /= in x_s y_s.
exact: IHs.
Qed.

Lemma index_subseq (T : eqType) x y (s1 s2 : seq T) :
  y \in s1 -> subseq s1 s2 -> uniq s2 ->
  index x s1 <= index y s1 -> index x s2 <= index y s2.
Proof.
move=> y_s1 sub_s1_s2 uniq_s2; have uniq_s1 := subseq_uniq sub_s1_s2 uniq_s2.
rewrite -!mem2_index ?mem2E // => [?|]; last exact: (mem_subseq sub_s1_s2).
exact: subseq_trans sub_s1_s2.
Qed.

Section Path.

Lemma eq_traject (T : Type) (f g : T -> T) : f =1 g -> traject f =2 traject g.
Proof. move=> fg x n; elim: n x => //= n IHn x. by rewrite IHn fg. Qed.

Variable (T : eqType).
Implicit Types (s p : seq T) (x y : T).

Lemma head_rot s x0 n : n < size s -> head x0 (rot n s) = nth x0 s n.
Proof.
move=> n_lt_s; rewrite /rot -nth0 nth_cat size_drop subn_gt0 n_lt_s.
by rewrite -{2}[s](cat_take_drop n) nth_cat size_take n_lt_s ltnn subnn.
Qed.

Lemma next_cons x0 x s : next (x::s) x = head x0 (rcons s x).
Proof. by case: s => [|y s] /=; rewrite eqxx. Qed.

Lemma next_neq x p : x \in p -> uniq p -> 1 < size p -> x != next p x.
Proof.
move => x_p; have [i p' rot_p uniq_p] := rot_to x_p.
move: (uniq_p); rewrite -(next_rot i) // -(size_rot i) -(rot_uniq i) {}rot_p.
case: p' => //= y p'. rewrite inE eqxx. by case: (x == y).
Qed.

Lemma prev_neq x p : x \in p -> uniq p -> 1 < size p -> x != prev p x.
Proof.
move => x_p uniq_p lt1p. have := @next_neq (prev p x) _ _ uniq_p lt1p.
by rewrite mem_prev next_prev // eq_sym; apply.
Qed.

Lemma iter_next_rot x0 s n :
  n < size s -> uniq s -> iter n (next s) (head x0 s) = head x0 (rot n s).
Proof.
elim: n s => [|n IHn] s; first by move => *; rewrite rot0.
case: s => [_ /= |x s]; first by rewrite (@eq_iter _ _ id) ?iter_id.
move => n_lt_s uniq_s. rewrite iterSr rotS 1?ltnW // rot_rot rot1_cons.
rewrite (next_cons x0).
under eq_iter => z do rewrite -(next_rot 1) ?rot1_cons //.
by rewrite IHn // ?size_rcons ?rcons_uniq // ltnW.
Qed.

Lemma iter_next_nth x0 s n :
  uniq s -> n < size s -> iter n (next s) (head x0 s) = nth x0 s n.
Proof. by move => *; rewrite iter_next_rot // head_rot. Qed.

Lemma traject_next x0 s :
  uniq s -> traject (next s) (head x0 s) (size s) = s.
Proof.
move=> uniq_s; apply: (@eq_from_nth _ x0); rewrite size_traject // => i i_lt_s.
rewrite (set_nth_default (head x0 s)) ?size_traject //.
by rewrite nth_traject // iter_next_nth.
Qed.

Lemma mem_arc (p : seq T) (x y : T) : {subset arc p x y <= p}.
Proof. by move => z /mem_take; rewrite mem_rot. Qed.

End Path.

Lemma map_arc (aT rT : eqType) (f : aT -> rT) (s : seq aT) (x y : aT) :
  injective f -> [seq f z | z <- arc s x y] = arc (map f s) (f x) (f y).
Proof.
by move=> inj_f; rewrite /arc -map_rot !index_map // map_take.
Qed.

Lemma next_map (aT rT : eqType) (f : aT -> rT) (s : seq aT) (x : aT) :
  injective f -> next (map f s) (f x) = f (next s x).
Proof.
move=> inj_f; case: s => //= a s.
by elim: s a {2 4}a => /= [|y s IHs] a b; rewrite inj_eq // ?IHs -fun_if.
Qed.

(** *** Lemmas on [index] *)
(** could go to [fingraph.v] *)

Lemma eq_findex (T : finType) (f g : T -> T) :
  f =1 g -> findex f =2 findex g.
Proof.
move=> fg x y; rewrite /findex /index /orbit /order (eq_traject fg).
congr (_ _ (traject _ _ _)); exact/eq_card/eq_fconnect.
Qed.

Lemma findex_head (T : finType) (x y : T) (s : seq T) (uniq_xs : uniq (x::s)) :
  findex (next (x :: s)) x y = index y (x :: s).
Proof.
rewrite /findex (_ : orbit (next (x::s)) x = x::s) // /orbit.
rewrite (@order_cycle _ _ (x::s)) ?mem_head ?cycle_next //.
exact: (@traject_next _ x).
Qed.

From GraphTheory Require Import preliminaries.
Local Notation splitPr := path.splitPr.

(* Only the lemmas below are actually used:
(* already on mathcomp master *)
Axiom card_gt1P :
   forall {T : finType} {A : pred T}, reflect (exists x y : T, [/\ x \in A, y \in A & x != y]) (1 < #|A|).
Axiom disjointFr :
  forall (T : finType) (A B : pred T), reflect (forall x : T, x \in A -> x \in B -> False) [disjoint A & B].
*)

Lemma head_arc (T: eqType) (s : seq T) (x y : T) (xDy : x != y) :
  uniq s -> x \in s -> y \in s -> x \in arc s x y.
Proof.
move=>  uniq_s x_s y_s. case: (rot_to_arc uniq_s x_s y_s xDy) => i s1 s2 <- _ _.
exact: mem_head.
Qed.

Lemma next_mem_arc (T : eqType) (s : seq T) (x y : T) :
  uniq s -> x \in s -> y \in s -> x != y -> next s x \in rcons (arc s x y) y.
Proof.
move=> uniq_s x_s y_s xDy.
have [i s1 s2 arc1 arc2 rot_r] := rot_to_arc uniq_s x_s y_s xDy.
rewrite -arc1 -(next_rot i) // rot_r (next_cons x).
by case: s1 {arc1 rot_r} => [|z s1']; rewrite /= !inE eqxx orbT.
Qed.

(* Not used *)
Lemma arc_next (T : eqType) (s : seq T) (x : T) :
  1 < size s -> uniq s -> x \in s -> arc s x (next s x) = [:: x].
Proof.
move=> le2s uniq_s x_s.
have xDnx : x != next s x by apply: next_neq.
have nx_s : next s x \in s by rewrite mem_next.
have [i s1 s2 A1 A2 rot_i] := rot_to_arc uniq_s x_s nx_s xDnx.
suff s1nil : s1 = [::] by rewrite -A1 s1nil.
move: (uniq_s); rewrite -(rot_uniq i) rot_i -(next_rot i) // rot_i (next_cons x).
by case: s1 {A1 A2 rot_i} => //= y s1'; rewrite !(inE,mem_cat) eqxx orbT andbF.
Qed.

Definition path0 (T : Type) (e : rel T) (s : seq T) :=
  if s is x::s then path e x s else true.

Lemma path_path0 (T : Type) (e : rel T) x (s : seq T) :
  path e x s -> path0 e s.
Proof. by case: s => //= y s /andP [_]. Qed.

Section UcycleArc.
Variables (T : finType) (e : rel T) (s : seq T).

Lemma arc_path x y (xDy : x != y) :
  ucycle e s -> x \in s -> y \in s -> path0 e (arc s x y).
Proof.
move=> /andP[cycle_s uniq_s] x_s y_s.
have [i s1 s2 <- _ E /=] := rot_to_arc uniq_s x_s y_s xDy.
move: cycle_s. rewrite -(rot_cycle i) E /= rcons_path cat_path.
by case: (path e x s1).
Qed.

Lemma arc_edge x y :
  ucycle e s -> x \in s -> y \in s -> x != y -> e (last x (arc s x y)) y.
Proof.
move => /andP [cycle_s uniq_s] x_s y_s xDy.
have [n s1 s2 <- _ rot_s] := rot_to_arc uniq_s x_s y_s xDy.
move: cycle_s; rewrite -(rot_cycle n) {}rot_s /=.
by rewrite rcons_path cat_path /=; case: (e (last _ _) _); rewrite // andbF.
Qed.

Lemma arc_findex x y z (xDy : x != y) :
  uniq s -> x \in s -> y \in s ->
  (z \in arc s x y) = (findex (next s) x z < findex (next s) x y).
Proof.
move=> uniq_s x_s y_s; have [i s1 s2 A1 A2 R] := rot_to_arc uniq_s x_s y_s xDy.
under eq_findex => u do rewrite -(next_rot i) //.
under (@eq_findex _ (next s)) => u do rewrite -(next_rot i) //.
have uniq_xy : uniq (x :: s1 ++ y :: s2) by rewrite -R rot_uniq.
rewrite R !findex_head // -cat_cons !index_cat index_head.
rewrite -A1 [X in _ < X]ifN.
  by case: ifP => [Hz|_]; rewrite ?ltn_add2l // addn0 index_mem Hz.
by apply: contraTN uniq_xy => C; rewrite -cat_cons cat_uniq /= C /= andbF.
Qed.

Lemma arc_disjoint2 x y :
  uniq s -> x \in s -> y \in s -> x != y -> [disjoint arc s x y & arc s y x].
Proof.
move => uniq_s x_s y_s xDy.
have [n s1 s2 <- <- rot_s] := rot_to_arc uniq_s x_s y_s xDy.
move: uniq_s; rewrite -(rot_uniq n) rot_s -cat_cons cat_uniq.
by rewrite disjoint_sym disjoint_has => /and3P [_ -> _].
Qed.

Lemma arc_disjoint x1 x2 y1 y2 :
  uniq s -> x1 \in s -> x2 \in s -> y1 \in s -> y2 \in s -> x1 != x2 -> y1 != y2 ->
  findex (next s) x1 x2 <= findex (next s) x1 y1 ->
  findex (next s) y1 y2 <= findex (next s) y1 x1 ->
  [disjoint arc s x1 x2 & arc s y1 y2].
Proof.
move=> uniq_s x1_s x2_s y1_s y2_s x1Dx2 y1Dy2 index_x index_y.
have x1Dy1 : x1 != y1.
{ apply: contraNneq x1Dx2 => ?; subst y1.
  by move: index_x; rewrite findex0 leqn0 findex_eq0. }
apply/pred0Pn => -[x] /=; rewrite !arc_findex // => /andP [A1 A2].
have {A1 index_x} := leq_trans A1 index_x.
have {A2 index_y} := leq_trans A2 index_y.
rewrite -!arc_findex //= 1?eq_sym // => x_arc.
by apply/negP; rewrite (disjointFl (@arc_disjoint2 x1 y1  _ _ _ _)).
Qed.

Variable p : seq T.
Hypothesis uniq_s : uniq s.
Hypothesis p_sub_s : subseq p s.
Let p_in_s := mem_subseq p_sub_s.
Let uniq_p := subseq_uniq p_sub_s uniq_s.

Lemma findex_next_other (x y : T) :
  x \in p -> y \in p -> x != y -> findex (next s) x (next p x) <= findex (next s) x y.
Proof.
move=> x_p y_p xDy; have x_s : x \in s by apply: p_in_s.
have [n s' rot_n] := rot_to x_s.
under eq_findex => z do rewrite -(next_rot n) //.
under [X in _ <= X]eq_findex => z do rewrite -(next_rot n) //.
have uniq_xs : uniq (x :: s') by rewrite -rot_n rot_uniq.
have [m _ sub] := subseq_rot n p_sub_s.
rewrite rot_n !findex_head // -(next_rot m) //; rewrite rot_n in sub.
have [p' P] : exists p', rot m p = x :: p'.
{ rewrite -(mem_rot m) in x_p; rewrite -(rot_uniq m) in (uniq_p).
  case: (splitPr x_p) sub => p1 p2. rewrite -[x::s']cat0s.
  rewrite uniq_subseq_pivot // => /andP.
  by rewrite subseq0 => -[/eqP -> _]; exists p2. }
rewrite P next_nth mem_head index_head.
case: p' P => [|y' p' P]; first by rewrite /= eqxx leq0n.
rewrite [nth _ _ _]/= P in sub *; apply: index_subseq sub _ _ => //.
  by rewrite -P mem_rot.
by rewrite /= eqxx (negbTE xDy); case: (x == y').
Qed.

Lemma arc_next_disjoint x y :
  x \in p -> y \in p -> x != y ->
  [disjoint arc s x (next p x) & arc s y (next p y)].
Proof.
move=> x_p y_p xDy.
have x_s : x \in s by apply p_in_s.
have ? : 1 < size p.
{ apply: leq_trans (card_size _). by apply/card_gt1P; exists x,y. }
apply: arc_disjoint; try apply: p_in_s; rewrite ?mem_next //.
1-2: exact: next_neq.
all: by apply: findex_next_other; rewrite // eq_sym.
Qed.

Lemma arc_cover x y : x \in s -> y \in s -> x != y -> s =i [predU arc s x y & arc s y x].
Proof.
move=> x_s y_s xDy z; have [i s1 s2 A1 A2 def_s] := rot_to_arc uniq_s x_s y_s xDy.
by rewrite -(mem_rot i) def_s -cat_cons A1 A2 mem_cat.
Qed.

Lemma mem_arc_other x y z : x \in s -> y \in s -> z \in s -> x != y ->
  (z \in arc s x y) = (z \notin arc s y x).
Proof.
move=> x_s y_s z_s xDy; have/esym := arc_cover x_s y_s xDy z; rewrite z_s inE /=.
have D := arc_disjoint2 uniq_s x_s y_s xDy.
by case/orP => z_arc; rewrite z_arc ?(disjointFr D) // ?(disjointFl D).
Qed.

Lemma arc_remainder x : 1 < size p -> x \in p -> {subset p <= rcons (arc s (next p x) x) x}.
Proof.
move=> gt1p x_p y y_p; rewrite mem_rcons inE; have [//|xDy/=] := eqVneq x y.
rewrite mem_arc_other ?p_in_s ?mem_next // 1?eq_sym ?next_neq //.
have D := arc_next_disjoint x_p y_p xDy.
by rewrite (disjointFl D) // head_arc ?p_in_s ?next_neq ?mem_next.
Qed.

End UcycleArc.

Section SubCycle.
Variables (T : eqType).
Implicit Types (p s : seq T).

Definition subcycle p s := [exists n : 'I_(size p).+1, subseq (rot n p) s].

Lemma subcycleP p s : reflect (exists n, subseq (rot n p) s) (subcycle p s).
Proof.
apply: (iffP existsP) => [[n On]|[n rot_n]]; first by exists n.
have [lt_p|ge_p] := ltnP n (size p).+1; first by exists (Ordinal lt_p).
by exists (Ordinal (ltn0Sn _)); rewrite /= rot0 -[p](@rot_oversize _ n) // ltnW.
Qed.

Lemma subcycle_rot_l n p s : subcycle (rot n p) s = subcycle p s.
Proof.
apply/subcycleP/subcycleP => [[m]|[m sub]].
  rewrite rot_rot_add => sub; eexists; exact: sub.
exists (rot_add (rot n p) ((size (rot n p)) - n) m).
by rewrite -rot_rot_add -/(rotr _ _) rotK.
Qed.

Lemma subcycle_rot_r n p s : subcycle p (rot n s) = subcycle p s.
Proof.
apply/subcycleP/subcycleP => -[m sub].
  have [k _ sub'] := subseq_rot (size (rot n s) - n) sub.
  rewrite -/(rotr _ _) rotK rot_rot_add in sub'; eexists; exact sub'.
have [k _ sub'] := subseq_rot n sub.
by exists (rot_add p m k); rewrite -rot_rot_add.
Qed.

Lemma subcycle_rot n m s p : subcycle (rot n p) (rot m s) = subcycle p s.
Proof. by rewrite subcycle_rot_l subcycle_rot_r. Qed.

Lemma subseq_subcyle p s : subseq p s -> subcycle p s.
Proof. by move => sub; apply/subcycleP; exists 0; rewrite rot0. Qed.

Lemma subcycle_trans : transitive subcycle.
Proof.
move=> r p q sub_p_r /subcycleP [m sub_r_q].
move: sub_p_r; rewrite -(subcycle_rot_r m) => /subcycleP [n] sub_p_r.
by apply/subcycleP; exists n; apply: subseq_trans sub_r_q.
Qed.

Lemma subcycle_uniq p s : subcycle p s -> uniq s -> uniq p.
Proof.
move=> /subcycleP [n sub_p_s]; rewrite -(rot_uniq n p).
exact: subseq_uniq.
Qed.

Lemma mem_subcycle p s : subcycle p s -> {subset p <= s}.
Proof.
move=> /subcycleP[n /mem_subseq sub_p_s] z z_p.
by apply: sub_p_s; rewrite mem_rot.
Qed.

Lemma subcycle_get_arc x p s :
  x \in s -> uniq s -> subcycle p s -> 1 < size p ->
  exists2 z, z \in p & x \in arc s z (next p z).
Proof.
wlog [s' -> _ {s}] : s / exists s', s = x::s'.
{ move=> W x_s uniq_s sub_p_s size_p; have [i s' rot_i] := rot_to x_s.
  case: (W (rot i s)); rewrite ?mem_rot ?rot_uniq ?subcycle_rot_r //; first by exists s'.
  move=> z z_p; rewrite arc_rot ?(mem_subcycle sub_p_s) //; by exists z. }
move=> uniq_s sub_p_s size_p.
have uniq_p : uniq p by apply: subcycle_uniq uniq_s.
have [x_p|xNp] := boolP (x \in p).
- exists x; rewrite ?head_arc ?mem_head //; first exact: next_neq.
  apply: mem_subcycle sub_p_s _ _. by rewrite mem_next.
- have has_p : has (mem p) s'.
  {  case: p => [//|z p] in size_p sub_p_s uniq_p xNp *.
     apply/hasP; exists z; rewrite /= ?mem_head //.
     move:(mem_subcycle sub_p_s) => /(_ z (mem_head _ _)) /predU1P [zx|//].
     by rewrite zx inE eqxx in xNp. }
  case def_s : _ _ _ _ / (split_find_nth x has_p) => [/= nz s1 s2 nz_p Ns2].
  pose z := path.prev p nz.
  have z_s2 : z \in s2.
  { have z_p : z \in p by rewrite path.mem_prev.
    move:(mem_subcycle sub_p_s z_p); rewrite inE => /predU1P[zx|].
      by subst; contrab.
    rewrite def_s. rewrite mem_cat mem_rcons inE eq_sym (negbTE (prev_neq _ _ _)) //=.
    by case/orP => [z_s1|//]; apply: contraNT Ns2 => _; apply/hasP; exists z. }
  exists z; rewrite ?path.mem_prev // next_prev // -cats1 -catA /=.
  case def_s2 : _ / (path.splitPr z_s2) => [p1 p2].
  have U1 : uniq (x :: s1 ++ nz :: p1 ++ z :: p2).
  { by rewrite -def_s2 -[nz :: _]cat1s catA cats1 -def_s. }
  move: (U1). rewrite -cat_cons -(rot_uniq (size (x :: s1))) rot_size_cat => U2.
  rewrite -cat_cons -(arc_rot (size (x :: s1))) // ?rot_size_cat ?(inE,mem_cat,eqxx,orbT)//.
  have E : ((nz :: p1) ++ z :: p2) ++ x :: s1 = nz :: p1 ++ z :: (p2 ++ x :: s1).
  { by rewrite /= -!cat_cons -!catA. }
  by rewrite E right_arc -?E// !(inE,mem_cat) eqxx /= !orbT.
Qed.

End SubCycle.

Lemma arc_iterP (T : eqType) (x y z : T) (s : seq T) (xDy : x != y) :
  uniq s -> x \in s -> y \in s ->
  reflect (exists2 n, iter n (next s) x = z
                    & forall m, m <= n -> iter m (next s) x != y)
          (z \in arc s x y).
Proof.
move=> uniq_s x_s y_s.
have [i s1 s2 arc1 arc2 rot_i] := rot_to_arc uniq_s x_s y_s xDy.
have I k (lt_k_s : k < size (rot i s)) : iter k (next s) x = nth x (rot i s) k.
{ have -> : x = head z (rot i s) by rewrite rot_i.
  under eq_iter => u do rewrite -(next_rot i) //.
  by rewrite iter_next_nth // ?rot_uniq // (set_nth_default z). }
have yNarc1 : y \notin arc s x y.
{ apply: contraTN uniq_s; rewrite -(rot_uniq i) rot_i -cat_cons arc1 cat_uniq.
  move=> y_arc1; rewrite [has _ _](_ : _ = true) ?andbF //.
  by apply/hasP; exists y => //=; apply: mem_head. }
apply: (iffP idP) => [z_arc1|[n iter_n min_n]].
- have z_s := mem_arc z_arc1; exists (index z (rot i s)) => [|m lt_m_z].
    rewrite I ?nth_index // ?mem_rot // index_mem.
    by rewrite rot_i -cat_cons arc1 mem_cat z_arc1.
   have lt_m_a1 : m < size (arc s x y).
   { apply: leq_ltn_trans lt_m_z _.
     by rewrite rot_i -cat_cons arc1 index_cat z_arc1 index_mem. }
   have m_lt_s : m < size (rot i s).
     by apply: leq_trans lt_m_a1 _; rewrite rot_i -cat_cons arc1 size_cat leq_addr.
   apply: contraNneq yNarc1; rewrite I // => {1}<-.
   by rewrite rot_i -cat_cons arc1 nth_cat lt_m_a1 mem_nth.
- pose k := index y (rot i s); have lt_k_s : k < size (rot i s).
    by rewrite index_mem rot_i !(inE,mem_cat) eqxx !orbT.
  have lt_n_k : n < k.
    rewrite ltnNge; apply/negP=> /min_n.
    by rewrite I // nth_index ?eqxx // rot_i !(inE,mem_cat) eqxx !orbT.
  rewrite -iter_n I ?(ltn_trans lt_n_k lt_k_s) // rot_i -cat_cons arc1 nth_cat.
  suff eq_k : k = size (arc s x y) by   rewrite -eq_k lt_n_k mem_nth // -eq_k.
  by rewrite /k rot_i -cat_cons arc1 index_cat (negbTE yNarc1) /= ?eqxx ?addn0.
Qed.

Lemma next_iter (T : eqType) (x y : T) (s : seq T) :
  uniq s -> x \in s -> y \in s -> exists n, iter n (next s) x == y.
Proof.
move=> uniq_s x_s y_s; have [i s' rot_i] := rot_to x_s.
exists (index y (rot i s)); under eq_iter => z do rewrite -(next_rot i) //.
have -> : x = head y (rot i s) by rewrite rot_i.
by rewrite iter_next_nth ?nth_index ?index_mem ?mem_rot ?rot_uniq.
Qed.

Lemma prev_iter (T : eqType) (x y : T) (s : seq T) :
  uniq s -> x \in s -> y \in s -> exists n, iter n (prev s) x == y.
Proof.
move=> uniq_s x_s y_s; have [n /eqP eq_x] := next_iter uniq_s y_s x_s.
by exists n; rewrite -eq_x iterK //; apply: prev_next.
Qed.

Lemma subcycle_get_arc' (T : eqType) x (p s : seq T) :
  x \in s -> uniq s -> subcycle p s -> 1 < size p ->
  exists2 z, z \in p & x \in arc s z (next p z).
Proof.
move=> x_s uniq_s sub_p_s le2p.
have mem_s := mem_subcycle sub_p_s.
have uniq_p : uniq p by apply: subcycle_uniq uniq_s.
have /ex_minnP [n iter_n min_n] : exists n, iter n (prev s) x \in p.
  move/leqW : le2p; rewrite ltnS -has_predT => /hasP [z z_p _].
  have [n /eqP it_n] := next_iter uniq_s (mem_s _ z_p) x_s.
  by exists n; rewrite -it_n iterK //; exact: prev_next.
set z := iter n _ _ in iter_n *; exists z => //.
have [z_s nz_s] : z \in s /\ next p z \in s by rewrite ?mem_s // ?mem_next.
apply/arc_iterP; rewrite ?next_neq //.
have /ex_minnP [m /eqP iter_m min_m] := next_iter uniq_s z_s nz_s.
exists n => [|n'] ; first exact/iterK/next_prev.
apply: contraTN => /min_m => le_m_n'. rewrite -ltnNge.
apply: leq_trans le_m_n' => {n'}. apply: wlog_neg; rewrite -ltnNge => gt_m_n.
have gt0m : 0 < m.
{ by rewrite lt0n; apply: contra_eq_neq iter_m => -> /=; apply: next_neq. }
have gt0n : 0 < n by apply: leq_trans gt0m _.
have/min_n : iter (n - m) (prev s) x \in p.
{ have En : n = m + (n - m) by rewrite subnKC.
  move: iter_n. rewrite -mem_next -iter_m /z {1}En iterD iterK //.
  exact: next_prev. }
by rewrite leqNgt ltn_subrL gt0m gt0n.
Qed.

Lemma arc_subcycle_disjoint (T : finType) (p s : seq T) (x y : T) :
  uniq s -> subcycle p s -> x \in p -> y \in p -> x != y ->
  [disjoint arc s x (next p x) & arc s y (next p y)].
Proof.
move=> uniq_s /subcycleP [m sub_p_s].
wlog: p {sub_p_s} / subseq p s => [W|?]; last exact: arc_next_disjoint.
move: (W _ sub_p_s); rewrite !mem_rot !next_rot // -(rot_uniq m).
all: exact: subseq_uniq uniq_s.
Qed.

Lemma arc_subcycle_disjoints (T : finType) (p s : seq T) (x y nx ny : T) :
  uniq s -> subcycle p s -> x \in p -> y \in p -> x != y -> nx = next p x -> ny = next p y ->
  [disjoint [set z in arc s x nx] & [set z in arc s y ny]].
Proof.
move=> uniq_s subcycle_p x_p y_p xDy next_x next_y.
under eq_disjoint => z do by rewrite !inE.
under eq_disjoint_r => z do by rewrite !inE.
by rewrite next_x next_y; apply: (arc_subcycle_disjoint uniq_s).
Qed.


From LF Require Export Basics.
From LF Require Export Logic.
Require Import PeanoNat.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.
Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.
Notation "~ x" := (not x) : type_scope.

Lemma lma (P:Prop) : ~(P /\ ~P).
Proof.
  unfold not.
  intros H.
  destruct H as [p].
  apply H.
  apply p.
Qed.

Lemma lma' (P Q:Prop) : ~(P \/ Q) -> ~P /\ ~Q.
Proof.
  unfold not.
  intros H.
  constructor.
  - intro p.
    apply H.
    left.
    apply p.
  - intro q.
    apply H.
    right.
    apply q.
Qed.

(*1 - 1 балл*)
Theorem excluded_middle_irrefutableKR: forall (P : Prop), ~~(P \/ ~ P).
Proof.
intros P H.
  apply lma' in H.
  apply lma in H.
  apply H.
Qed.

(*2 - 0.5 баллов*)
Theorem all_imp_ist A (P Q: A -> Prop):
  (forall x: A, P x -> Q x) -> (forall y, P y) -> forall z, Q z.
Proof.
Admitted.

(*3 - 1 балл*)
Theorem or_distributes_over_and_2 P Q R :
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
    intros. inversion H as [[HP|HQ] [HP2|HR]].
    apply or_introl. apply HP.
    apply or_introl. apply HP.
    apply or_introl. apply HP2.
    apply or_intror. split. apply HQ. apply HR.
Qed.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(*4 - 0.5 баллов*)
(*В примерах (Example) заменить "A" на функцию, которая позволит из данного (короткого)
списка получить итоговый (длинный) список)*)
Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.
Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y):=
  match l with
  | []     => []
  | h :: t =>  (f h) ++  (flat_map f t)
  end.

Example test_flat_map':
  flat_map (fun n => [n;n;n;n]) [1;5;4]
  = [1; 1; 1; 1; 5; 5; 5; 5; 4; 4; 4; 4].
Proof. reflexivity. Qed.

Example test_flat_map'':
  flat_map (fun n => [n;n]) [8;10;15;2]
  = [8; 8; 10; 10; 15; 15; 2; 2].
Proof. reflexivity. Qed.

Require Import Classical_Prop.

Definition peirce_law := forall P Q: Prop, ((P -> Q) -> P) -> P.
Definition classic := forall P:Prop,   ~~P  ->  P.
Definition peirce := peirce_law.
Definition double_neg := forall P: Prop, ~ ~ P -> P.
Definition excluded_middle := forall P: Prop, P \/ ~P.
Definition de_morgan_not_and_not := forall P Q: Prop, ~ ( ~P /\ ~Q) -> P \/ Q.
Definition implies_to_or := forall P Q: Prop, (P -> Q) -> (~P \/ Q).

(*5 - 2 балла*)
(*Используя приведенные выше определения доказать теорему*)
Theorem classic_implies_demorgan : classic -> de_morgan_not_and_not.
Proof.
unfold classic, de_morgan_not_and_not.
intro Classic. intros P Q. unfold not.
intro nan. apply Classic. unfold not.
intro double_neg. apply nan.
split.
 intro. apply double_neg. left. assumption.
 intro. apply double_neg. right. assumption.
Qed.

(*6 - 2 балла*)
(*Используя приведенные выше определения доказать теорему*)
Theorem demorgan_implies_exclude : de_morgan_not_and_not -> excluded_middle.
Proof.
unfold de_morgan_not_and_not, excluded_middle.
intros Demogran P. apply Demogran. unfold not. intro.
inversion H. contradiction.
Qed.


Require Export P06.

(** **** Exercise: 3 stars, optional (add_slowly_decoration)  *)
(** The following program adds the variable X into the variable Z
    by repeatedly decrementing X and incrementing Z.
  WHILE X <> 0 DO
     Z ::= Z + 1;;
     X ::= X - 1
  END

    Following the pattern of the [subtract_slowly] example above, pick
    a precondition and postcondition that give an appropriate
    specification of [add_slowly]; then (informally) decorate the
    program accordingly. *)

Theorem slow_addition_dec_correct : forall n m,
  {{fun st => st X = n /\ st Y = m }}
  WHILE BNot (BEq (AId X) (ANum 0)) DO
     Y ::= APlus (AId Y) (ANum 1);;
     X ::= AMinus (AId X) (ANum 1)
  END
  {{fun st => st Y = n + m}}.
Proof. intros n m.
  apply hoare_consequence_pre with (P':= (fun st => st X + st Y = n + m )).
  Case "{{P'}} while {{Q}}".
    eapply hoare_consequence_post.
    SCase "{{P'} while {{P'/\~b}}".
      apply hoare_while.  (* now P'/\b c1;;c2 P' *)
      eapply hoare_seq.
      SSCase "{{P''}} c2 {{P'}}". apply hoare_asgn.
      SSCase "{{P'/\b}} c1 {{P''}}".
        eapply hoare_consequence_pre. apply hoare_asgn.
        unfold assert_implies, assn_sub. intros.
        unfold update; simpl. destruct H. simpl in H0.
        apply negb_true_iff in H0. apply beq_nat_false_iff in H0.
        omega.
    SCase "P'/\~b ->> Q".
      unfold assert_implies. intros.
      destruct H. simpl in H0. apply negb_false_iff in H0. apply beq_nat_true_iff in H0. omega.
  Case "P' ->> P".
    unfold assert_implies. intros. omega.
Qed.