Require Import Omega.
Require Import List.
Require Import Permutation.
Require Import NPeano.
Import ListNotations.

Definition injective {A B : Type} (L : list A) (f : A -> B) : Prop :=
  forall x1 x2, In x1 L -> In x2 L -> f x1 = f x2 -> x1 = x2.

Definition pairwise_disjoint {A B : Type} (L : list A) (f : A -> list B) : Prop :=
  forall x1 x2 y, In x1 L -> In x2 L -> In y (f x1) -> In y (f x2) -> x1 = x2.

Fixpoint nub'
  {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (L : list A) : list A :=
    match L with
    | [] => []
    | x :: M => (if in_dec eq_dec x M then [] else [x]) ++ nub' eq_dec M
    end.

Definition select {A : Type} (L : list bool) (M : list A) : list A :=
  map (@snd bool A) (filter (@fst bool A) (combine L M)).

Lemma empty_length :
  forall (A : Type) (L : list A), L = [] <-> length L = 0.
Proof.
  intros A [|x L].
  - tauto.
  - simpl.
    split; intro H; contradict H; auto with *.
Qed.

Lemma nonempty_length :
  forall (A : Type) (L : list A), L <> [] <-> length L > 0.
Proof.
  intros A [|x L].
  - simpl.
    intuition.
  - simpl.
    auto with *.
Qed.

Lemma removelast_correct :
  forall (A : Type) (x : A) (L : list A), removelast (L ++ [x]) = L.
Proof.
  intros A x L.
  rewrite removelast_app; simpl; auto with *.
Qed.

Lemma removelast_length :
  forall (A : Type) (L : list A), length (removelast L) = length L - 1.
Proof.
  intros A L.
  induction L as [|x [|y L] IH]; trivial.
  change (S (length (removelast (y :: L))) = S (length (y :: L)) - 1).
  rewrite IH.
  simpl.
  omega.
Qed.

Lemma tail_length :
  forall (A : Type) (L : list A), length (tail L) = length L - 1.
Proof.
  intros A L.
  induction L as [|x L IH]; trivial.
  simpl.
  omega.
Qed.

Lemma firstn_correct :
  forall (A : Type) (L M : list A), firstn (length L) (L ++ M) = L.
Proof.
  intros A L M.
  induction L as [|x L IH]; trivial.
  simpl.
  rewrite IH.
  trivial.
Qed.

Lemma firstn_map :
  forall (A B : Type) (k : nat) (f : A -> B) (L : list A),
    firstn k (map f L) = map f (firstn k L).
Proof.
  intros A B k f.
  induction k as [|k IH]; intros [|x L]; trivial.
  simpl.
  rewrite IH.
  trivial.
Qed.

Lemma firstn_incl :
  forall (A : Type) (k : nat) (L : list A),
    forall (x : A), In x (firstn k L) -> In x L.
Proof.
  intros A k.
  induction k as [|k IH]; intros [|x L] y H; trivial.
  - simpl in *.
    tauto.
  - simpl in *.
    destruct H as [H|H]; [tauto|].
    right.
    apply IH.
    trivial.
Qed.

Lemma skipn_correct :
  forall (A : Type) (L M : list A), skipn (length L) (L ++ M) = M.
Proof.
  intros A L M.
  induction L as [|x L IH]; trivial.
Qed.

Lemma skipn_length :
  forall (A : Type) (k : nat) (L : list A), length (skipn k L) = length L - k.
Proof.
  intros A k L.
  apply (plus_reg_l _ _ (min k (length L))).
  rewrite <- firstn_length at 1.
  rewrite <- app_length, firstn_skipn.
  destruct (le_dec k (length L)) as [H|H]; [rewrite min_l|rewrite min_r]; omega.
Qed.

Lemma skipn_map :
  forall (A B : Type) (k : nat) (f : A -> B) (L : list A),
    skipn k (map f L) = map f (skipn k L).
Proof.
  intros A B k f.
  induction k as [|k IH]; intros [|x L]; simpl; trivial.
Qed.

Lemma skipn_incl :
  forall (A : Type) (k : nat) (L : list A),
    forall (x : A), In x (skipn k L) -> In x L.
Proof.
  intros A k.
  induction k as [|k IH]; intros [|x L] y H; auto with *.
Qed.

Lemma nth_skipn :
  forall (A : Type) (n : nat) (L : list A) (d : A),
    nth n L d = hd d (skipn n L).
Proof.
  intros A n L d.
  revert L.
  induction n as [|n IH]; intros [|x L]; simpl; trivial.
Qed.

Lemma combine_nth2 :
  forall (A B : Type) (L : list A) (M : list B) (n : nat) (x : A) (y : B),
    n < length L -> n < length M -> nth n (combine L M) (x, y) = (nth n L x, nth n M y).
Proof.
  intros A B L M n x y.
  revert L M.
  induction n as [|n IH]; intros L M HL LM;
    (destruct L as [|v L]; [simpl in *; omega|]);
    (destruct M as [|w M]; [simpl in *; omega|]);
    trivial.
  apply IH; auto with *.
Qed.

Lemma in_seq :
  forall m n x, In x (seq m n) <-> m <= x < m + n.
Proof.
  intros m n x.
  revert m.
  induction n as [|n IH]; intro m.
  - simpl in *.
    omega.
  - simpl.
    specialize (IH (S m)).
    assert (m = x \/ m <> x) by omega.
    intuition.
Qed.

Lemma flat_map_length :
  forall (A B : Type) (f : A -> list B) (L : list A) (n : nat),
    (forall x, In x L -> length (f x) = n) ->
      length (flat_map f L) = n * length L.
Proof.
  intros A B f L n.
  rewrite mult_comm.
  induction L as [|x L IH]; trivial.
  intro Hf.
  simpl.
  rewrite app_length.
  rewrite Hf by auto with *.
  rewrite IH by auto with *.
  trivial.
Qed.

Lemma flat_map_app :
  forall (A B : Type) (f : A -> list B) (L M : list A),
    flat_map f (L ++ M) = flat_map f L ++ flat_map f M.
Proof.
  intros A B f L M.
  induction L as [|x L IH]; trivial.
  simpl.
  rewrite IH.
  auto with *.
Qed.

Lemma filter_length :
  forall (A : Type) (f : A -> bool) (L : list A),
    length (filter f L) <= length L.
Proof.
  intros A f L.
  induction L as [|x L IH]; trivial.
  simpl.
  destruct (f x); simpl.
  - omega.
  - auto.
Qed.

Lemma NoDup_singleton :
  forall (A : Type) (x : A), NoDup [x].
Proof.
  intros A x.
  apply NoDup_cons; [tauto|].
  apply NoDup_nil.
Qed.

Lemma NoDup_app :
  forall (A : Type) (L M : list A),
    NoDup L -> NoDup M -> (forall x, ~ (In x L /\ In x M)) -> NoDup (L ++ M).
Proof.
  intros A L M HL HM.
  induction HL as [|x L Hx HL IH]; trivial.
  intro HD.
  simpl.
  apply NoDup_cons.
  - rewrite in_app_iff.
    specialize (HD x).
    intuition.
  - apply IH.
    intro y.
    specialize (HD y).
    intuition.
Qed.

Lemma NoDup_map :
  forall (A B : Type) (f : A -> B) (L : list A),
    injective L f -> NoDup L -> NoDup (map f L).
Proof.
  intros A B f L Hf HL.
  induction HL as [|x L Hx HL IH]; [apply NoDup_nil|].
  simpl.
  apply NoDup_cons.
  - rewrite in_map_iff.
    intros [x2 [Ef Hx2]].
    specialize (Hf x2 x).
    rewrite <- Hf in Hx; auto with *.
  - compute in *.
    auto.
Qed.

Lemma NoDup_flat_map :
  forall (A B : Type) (f : A -> list B) (L : list A),
    (forall x, In x L -> NoDup (f x)) ->
    pairwise_disjoint L f ->
    NoDup L ->
      NoDup (flat_map f L).
Proof.
  intros A B f L Hf1 Hf2 HL.
  induction HL as [|x L Hx HL IH]; [apply NoDup_nil|].
  simpl.
  apply NoDup_app.
  - apply Hf1.
    auto with *.
  - apply IH.
    + auto with *.
    + intros x1 x2 y.
      specialize (Hf2 x1 x2 y).
      auto with *.
  - intros y [H1 H2].
    rewrite in_flat_map in H2.
    destruct H2 as [x2 [H2 H3]].
    specialize (Hf2 x x2 y).
    rewrite Hf2 in Hx; auto with *.
Qed.

Lemma NoDup_seq :
  forall m n, NoDup (seq m n).
Proof.
  intros m n.
  revert m.
  induction n as [|n IH]; intro m.
  - apply NoDup_nil.
  - specialize (IH (S m)).
    simpl.
    apply NoDup_cons.
    + rewrite in_seq.
      omega.
    + trivial.
Qed.

Lemma Permutation_NoDup :
  forall (A : Type) (L M : list A), Permutation L M -> NoDup L -> NoDup M.
Proof.
  intros A L M HP.
  induction HP as [ |x L M HP IH| | ].
  - trivial.
  - intro H.
    apply NoDup_cons.
    + intro H2.
      symmetry in HP.
      apply (Permutation_in x) in HP; trivial.
      contradict HP.
      revert H.
      apply (NoDup_remove_2 nil).
    + apply IH.
      revert H.
      apply (NoDup_remove_1 nil).
  - intro H.
    pose (NoDup_remove_1 nil _ _ H) as H2.
    pose (NoDup_remove_2 nil _ _ H) as H3.
    pose (NoDup_remove_1 nil _ _ H2) as H4.
    pose (NoDup_remove_2 nil _ _ H2) as H5.
    repeat apply NoDup_cons; firstorder.
  - tauto.
Qed.

Lemma NoDup_incl_Permutation :
  forall (A : Type) (L M : list A),
    NoDup L -> incl L M -> length L = length M -> Permutation L M.
Proof.
  intros A L M HN.
  revert M.
  induction L as [|x L IH]; intros M HI HL.
  - symmetry in HL.
    apply empty_length in HL.
    subst M.
    trivial.
  - assert (In x M) as H by auto with *.
    destruct (in_split x M H) as [M1 [M2 E]].
    subst M.
    rewrite <- Permutation_middle.
    apply perm_skip.
    apply IH.
    + inversion HN.
      trivial.
    + intros y K.
      assert (In y (x :: L)) as K2 by auto with *.
      specialize (HI y K2).
      rewrite in_app_iff in *.
      simpl in HI.
      destruct HI as [H1|[H2|H3]]; try tauto.
      subst y.
      inversion HN.
      tauto.
    + revert HL.
      repeat rewrite app_length.
      simpl.
      auto with *.
Qed.

Lemma Permutation_incl_left :
  forall (A : Type) (L M N : list A),
    Permutation L M -> (incl L N <-> incl M N).
Proof.
  intros A L M N HP.
  split; intros H x Hx; apply H; revert Hx; apply Permutation_in; auto with *.
Qed.

Lemma Permutation_incl_right :
  forall (A : Type) (L M N : list A),
    Permutation L M -> (incl N L <-> incl N M).
Proof.
  intros A L M N HP.
  split; intros H x Hx; [|symmetry in HP]; apply (Permutation_in _ HP); auto.
Qed.

Lemma incl_drop :
  forall (A : Type) (L M : list A) (x : A), incl L (x :: M) -> ~ In x L -> incl L M.
Proof.
  intros A L M x H1 H2 y Hy.
  specialize (H1 y Hy).
  destruct H1 as [H1|H1].
  - subst y.
    tauto.
  - trivial.
Qed.

Lemma incl_cons_iff :
  forall (A : Type) (x : A) (L M : list A),
    incl (x :: L) M <-> In x M /\ incl L M.
Proof.
  unfold incl.
  simpl.
  intuition.
  subst.
  trivial.
Qed.

Lemma NoDup_incl_lel :
  forall (A : Type) (L M : list A), NoDup L -> incl L M -> length L <= length M.
Proof.
  intros A L M HI.
  revert M.
  induction L as [|x L IH]; [auto with *|].
  intros M HM.
  rewrite incl_cons_iff in HM.
  destruct HM as [Hx HL].
  apply in_split in Hx.
  destruct Hx as [P [Q HM]].
  subst M.
  rewrite app_length.
  simpl.
  rewrite <- plus_n_Sm, <- app_length.
  apply le_n_S.
  apply IH.
  - inversion HI.
    trivial.
  - intros y Hy.
    specialize (HL y Hy).
    revert HL.
    repeat rewrite in_app_iff.
    intros [H|[H|H]]; try tauto.
    subst y.
    inversion HI.
    tauto.
Qed.

Lemma seq_app :
  forall k m n : nat, seq k m ++ seq (k + m) n = seq k (m + n).
Proof.
  intros k m n.
  revert k.
  induction m as [|m IH]; intro k.
  - replace (k + 0) with k; trivial.
  - simpl.
    replace (k + S m) with (S k + m) by omega.
    rewrite IH.
    trivial.
Qed.

Lemma in_nub' :
  forall (A : Type) eq_dec (L : list A) (x : A), In x (nub' eq_dec L) <-> In x L.
Proof.
  intros A eq_dec L x.
  induction L as [|y L IH]; [tauto|].
  simpl.
  rewrite <- IH.
  destruct (in_dec eq_dec y L) as [H|H].
  - intuition.
    subst.
    tauto.
  - auto with *.
Qed.

Lemma NoDup_nub' :
  forall (A : Type) eq_dec (L : list A), NoDup (nub' eq_dec L).
Proof.
  intros A eq_dec L.
  induction L as [|x L IH]; [apply NoDup_nil|].
  unfold nub'.
  destruct (in_dec eq_dec x L) as [H|H]; fold (@nub' A).
  - trivial.
  - apply NoDup_cons; trivial.
    rewrite in_nub'.
    trivial.
Qed.

Lemma NoDup_nub'_eq :
  forall (A : Type) eq_dec (L : list A), NoDup L -> L = nub' eq_dec L.
Proof.
  intros A eq_dec L H.
  induction L as [|x L IH]; trivial.
  simpl.
  inversion H as [|y M H1 H2 [E1 E2]].
  subst y M.
  destruct (in_dec eq_dec x L) as [N|]; [tauto|].
  rewrite <- IH; trivial.
Qed.

Lemma nub'_length :
  forall (A : Type) eq_dec (L : list A), length (nub' eq_dec L) <= length L.
Proof.
  intros A eq_dec L.
  induction L as [|x L IH]; trivial.
  simpl.
  destruct (in_dec eq_dec x L) as [H|H].
  - auto.
  - simpl.
    omega.
Qed.

Lemma nub'_filter :
  forall (A : Type) eq_dec (f : A -> bool) (L : list A),
    nub' eq_dec (filter f L) = filter f (nub' eq_dec L).
Proof.
  intros A eq_dec f L.
  induction L as [|x L IH]; trivial.
  simpl.
  destruct (f x) eqn:E;
    simpl;
    rewrite IH;
    destruct (in_dec eq_dec x L) as [H1|H1];
    destruct (in_dec eq_dec x (filter f L)) as [H2|H2];
    rewrite filter_In in H2;
    try tauto;
    simpl;
    destruct (f x);
    trivial;
    discriminate.
Qed.

Lemma select_length :
  forall (A : Type) (L : list bool) (M : list A),
    length (select L M) <= length M.
Proof.
  intros A L M.
  unfold select.
  rewrite map_length, filter_length, combine_length.
  auto with *.
Qed.

Lemma select_cons :
  forall (A : Type) (x : bool) (L : list bool) (y : A) (M : list A),
    select (x :: L) (y :: M) = (if x then [y] else []) ++ select L M.
Proof.
  intros A x L y M.
  destruct x; trivial.
Qed.

Lemma select_length_equal :
  forall (A : Type) (L : list bool) (M N : list A),
    length M = length N -> length (select L M) = length (select L N).
Proof.
  intros A L M; revert L.
  induction M as [|x M IH]; intros [|v L] [|y N]; trivial; simpl; try omega.
  repeat rewrite select_cons, app_length.
  intro H.
  rewrite (IH L N) by auto.
  destruct v; trivial.
Qed.

Lemma select_incl :
  forall (A : Type) (L : list bool) (M : list A),
    incl (select L M) M.
Proof.
  intros A L M x.
  unfold select.
  rewrite in_map_iff.
  intros [[y z] [E H]].
  rewrite filter_In in H.
  simpl in E.
  subst z.
  destruct H as [H _].
  revert H.
  apply in_combine_r.
Qed.

Lemma in_select :
  forall (A : Type) (x d : A) (L : list bool) (M : list A),
    In x (select L M) <-> (exists n : nat, nth n L false = true /\ nth n M d = x /\ n < length M).
Proof.
  intros A x d L M.
  unfold select.
  rewrite in_map_iff.
  split.
  - intros [[b y] [E H]].
    simpl in E.
    subst y.
    apply filter_In in H.
    destruct H as [H E].
    simpl in E.
    subst b.
    apply in_split in H.
    destruct H as [N [P E]].
    pose (f_equal (fun Q => nth (length N) Q (false, d)) E) as H.
    simpl in H.
    pose (f_equal (@length (bool * A)) E) as HL.
    rewrite combine_length, app_length in HL.
    simpl in HL.
    assert (min (length L) (length M) <= length L) as HM1 by auto with *.
    assert (min (length L) (length M) <= length M) as HM2 by auto with *.
    rewrite combine_nth2 in H by omega.
    rewrite app_nth2 in H by auto.
    replace (length N - length N) with 0 in H by omega.
    injection H as E1 E2.
    exists (length N).
    auto with *.
  - intros [n [E1 [E2 H2]]].
    exists (true, x).
    split; trivial.
    apply filter_In.
    split; trivial.
    rewrite <- E1, <- E2.
    destruct (le_lt_dec (length L) n) as [H1|H1].
    + apply (nth_overflow _ false) in H1.
      rewrite H1 in E1.
      discriminate.
    + rewrite <- combine_nth2; trivial.
      apply nth_In.
      rewrite combine_length.
      apply NPeano.Nat.min_glb_lt; trivial.
Qed.

Definition search_first
  {A : Type}
  (eq_dec : forall x y : A, {x = y} + {x <> y})
  (x : A) (L : list A) :
    {M : list A & {N | L = M ++ x :: N /\ ~ In x M}} + {~ In x L}.
Proof.
  induction L as [|y L IH].
  - right.
    tauto.
  - destruct (eq_dec x y) as [E|NE].
    + left.
      exists nil, L.
      subst y.
      tauto.
    + destruct IH as [[M [N [H1 H2]]]|NI].
      * left.
        exists (y :: M), N.
        subst L.
        simpl.
        intuition.
      * right.
        firstorder.
Defined.

Definition search_last
  {A : Type}
  (eq_dec : forall x y : A, {x = y} + {x <> y})
  (x : A) (L : list A) :
    {M : list A & {N | L = M ++ x :: N /\ ~ In x N}} + {~ In x L}.
Proof.
  destruct (search_first eq_dec x (rev L)) as [[M [N [H1 H2]]]|H].
  - left.
    exists (rev N), (rev M).
    rewrite <- (rev_involutive L), <- rev_unit, <- rev_app_distr, <- app_assoc, H1, <- in_rev.
    tauto.
  - right.
    rewrite <- in_rev in H.
    trivial.
Defined.

Definition remove1 {A : Type} eq_dec (x : A) (L : list A) : list A :=
  match search_first eq_dec x L with
  | inleft (existT _ M (exist _ N _)) => M ++ N
  | inright _ => L
  end.

Fixpoint list_diff {A : Type} eq_dec (L M : list A) : list A :=
  match M with
  | [] => L
  | x :: N => remove1 eq_dec x (list_diff eq_dec L N)
  end.

Lemma Permutation_remove1 :
  forall (A : Type) eq_dec (x : A) (L M : list A),
    Permutation (x :: L) M -> Permutation L (remove1 eq_dec x M).
Proof.
  intros A eq_dec x L M H.
  unfold remove1.
  destruct (search_first eq_dec x M) as [[M1 [M2 [HM _]]]|NI].
  - subst M.
    apply Permutation_cons_app_inv in H.
    trivial.
  - apply (Permutation_in x) in H.
    + tauto.
    + auto with *.
Qed.

Lemma Permutation_list_diff :
  forall (A : Type) eq_dec (L M N : list A),
    Permutation (L ++ M) N -> Permutation M (list_diff eq_dec N L).
Proof.
  intros A eq_dec L M N.
  revert M.
  induction L as [|x L IH]; trivial.
  intros M H.
  simpl.
  apply Permutation_remove1, IH.
  rewrite <- Permutation_middle.
  trivial.
Qed.

Lemma list_diff_undisturbed :
  forall (A : Type) eq_dec (x : A) (L M : list A),
    In x L -> ~ In x M -> In x (list_diff eq_dec L M).
Proof.
  intros A eq_dec x L M HL HM.
  induction M as [|y M IH]; trivial.
  simpl.
  unfold remove1.
  destruct (search_first eq_dec y (list_diff eq_dec L M)) as [[N1 [N2 [E H]]]|H].
  - assert (~ In x M) as HM2 by auto with *.
    specialize (IH HM2).
    rewrite E, in_app_iff in IH.
    destruct IH as [IH|[IH|IH]]; auto with *.
    subst y.
    contradict HM.
    auto with *.
  - auto with *.
Qed.

Lemma list_diff_NoDup_length :
  forall (A : Type) eq_dec (L M : list A),
    NoDup M -> incl M L -> length (list_diff eq_dec L M) = length L - length M.
Proof.
  intros A eq_dec L M HN HI.
  induction M as [|x M IH]; auto with *.
  simpl.
  unfold remove1.
  destruct (search_first eq_dec x (list_diff eq_dec L M)) as [[N1 [N2 [E H]]]|H].
  - assert (NoDup M) as HN2 by (inversion HN; trivial).
    assert (incl M L) as HI2 by (unfold incl; auto with *).
    specialize (IH HN2 HI2).
    rewrite E, app_length in IH.
    simpl in IH.
    rewrite app_length.
    omega.
  - contradict H.
    apply list_diff_undisturbed; auto with *.
    inversion HN.
    trivial.
Qed.

Definition empty_dec {A : Type} (L : list A) :
  {L = []} + {L <> []}.
Proof.
  destruct L.
  - tauto.
  - auto with *.
Defined.

Definition NoDup_dec
  {A : Type}
  (eq_dec : forall x y : A, {x = y} + {x <> y})
  (L : list A) :
    {NoDup L} + {~ NoDup L}.
Proof.
  destruct (list_eq_dec eq_dec L (nub' eq_dec L)) as [Y|N].
  - left.
    rewrite Y.
    apply NoDup_nub'.
  - right.
    contradict N.
    apply NoDup_nub'_eq, N.
Defined.

Definition Permutation_dec
  {A : Type}
  (eq_dec : forall x y : A, {x = y} + {x <> y})
  (L M : list A) :
    {Permutation L M} + {~ Permutation L M}.
Proof.
  revert M.
  induction L as [|x L IH]; intro M.
  - destruct M as [|x M].
    + left.
      apply perm_nil.
    + right.
      intro H.
      apply Permutation_nil in H.
      discriminate.
  - destruct (search_first eq_dec x M) as [[M1 [M2 [HM _]]]|NI].
    subst M.
    + specialize (IH (M1 ++ M2)).
      destruct IH as [YP|NP].
      * left.
        apply Permutation_cons_app.
        trivial.
      * right.
        contradict NP.
        exact (Permutation_cons_app_inv M1 M2 NP).
    + right.
      contradict NI.
      apply (Permutation_in x NI).
      auto with *.
Defined.

Definition incl_dec
  {A : Type}
  (eq_dec : forall x y : A, {x = y} + {x <> y})
  (L M : list A) :
    {incl L M} + {~ incl L M}.
Proof.
  induction L as [|x L IH].
  - left.
    intros x H.
    contradict H.
  - destruct (in_dec eq_dec x M) as [Y|N].
    + destruct IH as [Y2|N2].
      * left.
        auto with *.
      * right.
        contradict N2.
        intro y.
        auto with *.
    + right.
      auto with *.
Defined.


(******************************************************************************)
(** * Minimal elements of relations *)
(******************************************************************************)

Require Import HahnBase HahnList HahnSets HahnRelationsBasic.
Require Import HahnEquational HahnRewrite HahnMaxElt.
Require Import Arith Setoid.

Set Implicit Arguments.

Definition min_elt A (r: relation A) (a : A) :=
  forall b (REL: r b a), False.

Definition wmin_elt A (r: relation A) (a : A) :=
  forall b (REL: r b a), a = b.

Section BasicProperties.

Variable A : Type.
Variables r r' r'' : relation A.
Variable a : A.

Lemma min_transp : min_elt r⁻¹ ≡₁ max_elt r.
Proof.
  split; unfold min_elt, max_elt, transp, set_subset; ins; desf.
Qed.

Lemma max_transp : max_elt r⁻¹ ≡₁ min_elt r.
Proof.
  split; unfold min_elt, max_elt, transp, set_subset; ins; desf.
Qed.

Lemma set_subset_min_elt (S: r' ⊆ r) : min_elt r ⊆₁ min_elt r'.
Proof. unfold min_elt, inclusion, set_subset in *; intuition; eauto. Qed.

Lemma set_subset_wmin_elt (S: r' ⊆ r) : wmin_elt r ⊆₁ wmin_elt r'.
Proof. unfold wmin_elt, inclusion, set_subset in *; intuition; eauto. Qed.

Lemma set_equiv_min_elt (S: r ≡ r') : min_elt r ≡₁ min_elt r'.
Proof. unfold min_elt, same_relation, set_equiv, set_subset in *; intuition; eauto. Qed.

Lemma set_equiv_wmin_elt (S: r ≡ r') : wmin_elt r ≡₁ wmin_elt r'.
Proof. unfold wmin_elt, same_relation, set_equiv in *; intuition; eauto. Qed.

Lemma min_elt_weaken : min_elt r a -> wmin_elt r a.
Proof.
  red; ins; exfalso; eauto.
Qed.

Lemma min_elt_union : min_elt r a -> min_elt r' a -> min_elt (r +++ r') a.
Proof.
  unfold union; red; ins; desf; eauto.
Qed.

Lemma wmin_elt_union : wmin_elt r a -> wmin_elt r' a -> wmin_elt (r +++ r') a.
Proof.
  unfold union; red; ins; desf; eauto.
Qed.

Lemma min_elt_t : min_elt r a -> min_elt (r⁺) a.
Proof.
  red; ins; apply clos_trans_t1n in REL; induction REL; eauto.
Qed.

Lemma wmin_elt_rt : wmin_elt r a -> wmin_elt (r＊) a.
Proof.
  red; ins; apply clos_rt_rt1n in REL; induction REL; intuition; desf; eauto.
Qed.

Lemma wmin_elt_t : wmin_elt r a -> wmin_elt (r⁺) a.
Proof.
  by red; ins; eapply wmin_elt_rt, inclusion_t_rt.
Qed.

Lemma wmin_elt_eqv (f: A -> Prop) : wmin_elt (eqv_rel f) a.
Proof.
  unfold eqv_rel; red; ins; desf.
Qed.

Lemma wmin_elt_restr_eq B (f: A -> B) :
  wmin_elt r a -> wmin_elt (restr_eq_rel f r) a.
Proof.
  unfold restr_eq_rel in *; red; ins; desf; eauto.
Qed.

Lemma min_elt_restr_eq B (f: A -> B) :
  min_elt r a -> min_elt (restr_eq_rel f r) a.
Proof.
  unfold restr_eq_rel in *; red; ins; desf; eauto.
Qed.

Lemma wmin_elt_r :
  wmin_elt r a -> wmin_elt (r^?) a.
Proof.
  unfold clos_refl; red; ins; desf; eauto.
Qed.

Lemma min_elt_seq1 : min_elt r' a -> min_elt (r ⨾ r') a.
Proof.
  unfold seq; red; ins; desf; apply H in REL0; desf; eauto.
Qed.

Lemma wmin_elt_seq2 : wmin_elt r a -> wmin_elt r' a -> wmin_elt (r ⨾ r') a.
Proof.
  unfold seq; red; ins; desf; apply H0 in REL0; desf; eauto.
Qed.

Lemma wmin_elt_seq1 : min_elt r' a -> wmin_elt (r ⨾ r') a.
Proof.
  unfold seq; red; ins; desf; apply H in REL0; desf; eauto.
Qed.

Lemma min_elt_seq2 : min_elt r a -> wmin_elt r' a -> min_elt (r ⨾ r') a.
Proof.
  unfold seq; red; ins; desf; apply H0 in REL0; desf; eauto.
Qed.

End BasicProperties.

Global Hint Immediate min_elt_weaken : hahn.
Global Hint Resolve wmin_elt_union min_elt_union : hahn.
Global Hint Resolve wmin_elt_t wmin_elt_r wmin_elt_rt min_elt_t : hahn.
Global Hint Resolve min_elt_restr_eq wmin_elt_restr_eq : hahn.
Global Hint Resolve min_elt_seq1 min_elt_seq2 wmin_elt_seq1 wmin_elt_seq2 : hahn.

Section MoreProperties.

Variable A : Type.
Implicit Type r : relation A.

Lemma seq_min r r' b
      (MAX: min_elt r b) (DOM: forall x y, r' x y -> x = b) :
  r ⨾ r' ≡ ∅₂.
Proof.
  unfold seq; split; red; ins; desf.
  apply DOM in H0; desf; eauto.
Qed.

Lemma seq_min_t r r' b
      (MAX: min_elt r b) (DOM: forall x y, r' x y -> x = b) :
  r ⁺ ⨾ r'  ≡ ∅₂.
Proof.
  eauto using seq_min with hahn.
Qed.

Lemma seq_min_rt r r' b
      (MAX: min_elt r b) (COD: forall x y, r' x y -> x = b) :
  r ＊ ⨾ r' ≡ r'.
Proof.
  rewrite rtE; relsf; rewrite seq_min_t; relsf.
Qed.

Lemma seq_min_r r r' b
      (MAX: min_elt r b) (COD: forall x y, r' x y -> x = b) :
  r ^? ⨾ r' ≡ r'.
Proof.
  rewrite crE; relsf; rewrite seq_min; relsf.
Qed.

Lemma seq_min_eq r b (MAX: min_elt r b) :
  r ⨾⦗eq b⦘ ≡ ∅₂.
Proof.
  eapply seq_min; unfold eqv_rel; ins; desf; eauto.
Qed.

Lemma seq_min_t_eq r b (MAX: min_elt r b) :
  r⁺ ⨾⦗eq b⦘ ≡ ∅₂.
Proof.
  eauto using seq_min_eq with hahn.
Qed.

Lemma seq_min_rt_eq r b (MAX: min_elt r b) :
  r＊ ⨾⦗eq b⦘ ≡ ⦗eq b⦘.
Proof.
  rewrite rtE; relsf; rewrite seq_min_t_eq; relsf.
Qed.

Lemma seq_min_r_eq r b (MAX: min_elt r b) :
  r^? ⨾⦗eq b⦘ ≡ ⦗eq b⦘.
Proof.
  rewrite crE; relsf; rewrite seq_min_eq; relsf.
Qed.

Lemma seq_min_singl r a b (MAX: min_elt r a) :
  r ⨾ singl_rel a b ≡ ∅₂.
Proof.
  unfold singl_rel, seq; split; red; ins; desf; eauto.
Qed.

Lemma seq_min_t_singl r a b (MAX: min_elt r a) :
  r⁺ ⨾ singl_rel a b ≡ ∅₂.
Proof.
  eauto using seq_min_singl with hahn.
Qed.

Lemma seq_min_rt_singl r a b (MAX: min_elt r a) :
  r＊ ⨾ singl_rel a b ≡ singl_rel a b.
Proof.
  rewrite rtE; relsf; rewrite seq_min_t_singl; relsf.
Qed.

Lemma seq_min_r_singl r a b (MAX: min_elt r a) :
  r^? ⨾ singl_rel a b ≡ singl_rel a b.
Proof.
  rewrite crE; relsf; rewrite seq_min_singl; relsf.
Qed.

Lemma seq_eqv_min r :
  r ⨾ ⦗min_elt r⦘ ≡ ∅₂.
Proof.
  basic_solver.
Qed.

Lemma seq_t_eqv_min r :
  r⁺ ⨾ ⦗min_elt r⦘ ≡ ∅₂.
Proof.
  rewrite ct_end, seqA; seq_rewrite seq_eqv_min; basic_solver.
Qed.

Lemma seq_rt_eqv_min r :
  r＊ ⨾ ⦗min_elt r⦘ ≡ ⦗min_elt r⦘.
Proof.
  rewrite rtE; relsf; rewrite seq_t_eqv_min; relsf.
Qed.

Lemma seq_r_eqv_min r :
  r^? ⨾ ⦗min_elt r⦘ ≡ ⦗min_elt r⦘.
Proof.
  rewrite crE; relsf; rewrite seq_eqv_min; relsf.
Qed.

Lemma seq_eqv_min_transp r :
  ⦗min_elt r⦘ ⨾ r⁻¹  ≡ ∅₂.
Proof.
  basic_solver.
Qed.

Lemma seq_eqv_min_transp_t r :
  ⦗min_elt r⦘ ⨾ (r⁻¹)⁺ ≡ ∅₂.
Proof.
  rewrite ct_begin; seq_rewrite seq_eqv_min_transp; basic_solver.
Qed.

Lemma seq_eqv_min_transp_rt r :
  ⦗min_elt r⦘ ⨾ (r⁻¹)＊  ≡ ⦗min_elt r⦘.
Proof.
  rewrite rtE; relsf; rewrite seq_eqv_min_transp_t; relsf.
Qed.

Lemma seq_eqv_min_transp_r r :
  ⦗min_elt r⦘ ⨾ (r⁻¹)^?  ≡ ⦗min_elt r⦘.
Proof.
  rewrite crE; relsf; rewrite seq_eqv_min_transp; relsf.
Qed.

Lemma seq_wmin r r' b
      (MAX: wmin_elt r b) (D: forall x y, r' x y -> x = b) :
    r⨾ r' ⊆ r'.
Proof.
  unfold seq; red; ins; desf; eauto.
  specialize (D _ _ H0); desf; apply MAX in H; desf.
Qed.

Lemma seq_wmin_t r r' b
      (MAX: wmin_elt r b) (D: forall x y, r' x y -> x = b) :
  r ⁺⨾ r' ⊆ r'.
Proof.
  eauto using seq_wmin with hahn.
Qed.

Lemma seq_wmin_rt r r' b
      (MAX: wmin_elt r b) (COD: forall x y, r' x y -> x = b) :
  r ＊⨾ r' ≡ r'.
Proof.
  rewrite rtE; split; relsf; rewrite seq_wmin_t; relsf.
Qed.

Lemma seq_wmin_r r r' b
      (MAX: wmin_elt r b) (COD: forall x y, r' x y -> x = b) :
  r ^?⨾ r' ≡ r'.
Proof.
  rewrite crE; split; relsf; rewrite seq_wmin; relsf.
Qed.

Lemma seq_wmin_eq r b (MAX: wmin_elt r b) :
  r ⨾ ⦗eq b⦘ ⊆ ⦗eq b⦘.
Proof.
  eapply seq_wmin; unfold eqv_rel; ins; desf.
Qed.

Lemma seq_wmin_t_eq r b (MAX: wmin_elt r b) :
  r ⁺ ⨾ ⦗eq b⦘ ⊆ ⦗eq b⦘.
Proof.
  eauto using seq_wmin_eq with hahn.
Qed.

Lemma seq_wmin_rt_eq r b (MAX: wmin_elt r b) :
  r ＊ ⨾ ⦗eq b⦘ ≡ ⦗eq b⦘.
Proof.
  rewrite rtE; split; relsf; rewrite seq_wmin_t_eq; relsf.
Qed.

Lemma seq_wmin_r_eq r b (MAX: wmin_elt r b) :
  r ^? ⨾ ⦗eq b⦘ ≡ ⦗eq b⦘.
Proof.
  rewrite crE; split; relsf; rewrite seq_wmin_eq; relsf.
Qed.

Lemma seq_wmin_singl r a b (MAX: wmin_elt r a) :
  r ⨾ singl_rel a b ⊆ singl_rel a b.
Proof.
  unfold singl_rel, seq; red; ins; desf; eauto.
  apply MAX in H; desf.
Qed.

Lemma seq_wmin_t_singl r a b (MAX: wmin_elt r a) :
  r ⁺ ⨾ singl_rel a b ⊆ singl_rel a b.
Proof.
  eauto using seq_wmin_singl with hahn.
Qed.

Lemma seq_wmin_rt_singl r a b (MAX: wmin_elt r a) :
  r ＊ ⨾ singl_rel a b ≡ singl_rel a b.
Proof.
  rewrite rtE; split; relsf; rewrite seq_wmin_t_singl; relsf.
Qed.

Lemma seq_wmin_r_singl r a b (MAX: wmin_elt r a) :
  r ^? ⨾ singl_rel a b ≡ singl_rel a b.
Proof.
  rewrite crE; split; relsf; rewrite seq_wmin_singl; relsf.
Qed.

End MoreProperties.

Global Hint Unfold min_elt wmin_elt : unfolderDb.

Require Import Morphisms.

Instance min_elt_Proper A : Proper (inclusion --> set_subset) _ := set_subset_min_elt (A:=A).
Instance wmin_elt_Proper A : Proper (inclusion --> set_subset) _ := set_subset_wmin_elt (A:=A).
Instance min_elt_Propere A : Proper (same_relation ==> set_equiv) _ := set_equiv_min_elt (A:=A).
Instance wmin_elt_Propere A : Proper (same_relation ==> set_equiv) _ := set_equiv_wmin_elt (A:=A).

Add Parametric Morphism A : (@min_elt A) with signature
  inclusion --> eq ==> Basics.impl as min_elt_mori.
Proof.
  unfold inclusion, min_elt, Basics.impl; eauto.
Qed.

Add Parametric Morphism A : (@wmin_elt A) with signature
  inclusion --> eq ==> Basics.impl as wmin_elt_mori.
Proof.
  unfold inclusion, wmin_elt, Basics.impl; eauto.
Qed.

Add Parametric Morphism A : (@min_elt A) with signature
  same_relation --> eq ==> iff as min_elt_more.
Proof.
  unfold same_relation, inclusion, min_elt; firstorder.
Qed.

Add Parametric Morphism A : (@wmin_elt A) with signature
  same_relation --> eq ==> iff as wmin_elt_more.
Proof.
  unfold same_relation, inclusion, wmin_elt; firstorder.
Qed.


Lemma L2 : forall (A:Type) (P : A->Prop) (Q : Prop),
  (forall x:A, P x -> Q) <-> ((exists y:A, P y) -> Q).
  Proof.
  intros A P Q.
(*
1 subgoal
A : Type
P : A -> Prop
Q : Prop
______________________________________(1/1)
(forall x : A, P x -> Q) <-> (exists y : A, P y) -> Q
*)

  split.

(*
2 subgoals
A : Type
P : A -> Prop
Q : Prop
______________________________________(1/2)
(forall x : A, P x -> Q) -> (exists y : A, P y) -> Q

______________________________________(2/2)
((exists y : A, P y) -> Q) -> forall x : A, P x -> Q
*)

  intro H.
(*
2 subgoals
A : Type
P : A -> Prop
Q : Prop
H : forall x : A, P x -> Q
______________________________________(1/2)
(exists y : A, P y) -> Q
*)
  intros [y Hy].

(*
2 subgoals
A : Type
P : A -> Prop
Q : Prop
H : forall x : A, P x -> Q
y : A
Hy : P y
______________________________________(1/2)
Q
*)
  apply (H y).

(*
2 subgoals
A : Type
P : A -> Prop
Q : Prop
H : forall x : A, P x -> Q
y : A
Hy : P y
______________________________________(1/2)
P y

*)
 assumption.

(*
1 subgoal
A : Type
P : A -> Prop
Q : Prop
______________________________________(1/1)
((exists y : A, P y) -> Q) -> forall x : A, P x -> Q
*)

  intro H.

(*
1 subgoal
A : Type
P : A -> Prop
Q : Prop
H : (exists y : A, P y) -> Q
______________________________________(1/1)
forall x : A, P x -> Q
*)

  intros x Hx.

(*
1 subgoal
A : Type
P : A -> Prop
Q : Prop
H : (exists y : A, P y) -> Q
x : A
Hx : P x
______________________________________(1/1)
Q
*)
  apply H.
(*
1 subgoal
A : Type
P : A -> Prop
Q : Prop
H : (exists y : A, P y) -> Q
x : A
Hx : P x
______________________________________(1/1)
exists y : A, P y
*)
  exists x.

(*
1 subgoal
A : Type
P : A -> Prop
Q : Prop
H : (exists y : A, P y) -> Q
x : A
Hx : P x
______________________________________(1/1)
P x
*)
 assumption.

Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
   f_equal. }
   { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro. simpl. rewrite append_nil. reflexivity. }
Qed.

Theorem rev_involutive : forall (x : lst), eq (rev (rev x)) x.
Proof.
   induction x.
   { simpl. rewrite rev_append. simpl. f_equal.
   assumption. }
   { simpl. reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (append (rev x) Nil)) x.
Proof.
   intro.
lfind.
Admitted.


Require Import Arith.

(******************************************************************************)
(* FONCTIONS RECURSIVES ET INDUCTION SUR LES LISTES                           *)
(******************************************************************************)

(* On définit les listes de nat *)
Inductive nlist : Set :=
| nnil : nlist
| ncons : nat -> nlist -> nlist.

(* ... avec des notations confortables *)
Infix "::" := ncons.
Notation "[]" := nnil.

(* Exercice *)
(* Définir "concat" la fonction de concaténation de deux listes l1 et l2 (par récursion sur l1) *)
Fixpoint concat (l1 l2 : nlist) : nlist :=
  match l1 with
  | []     => l2
  | x :: l => x::(concat l l2)
  end.

(* On note ++ en notation infix pour la concatenation *)
Infix "++" := concat.

(* On reprend la fonction appartient du TP de LIFLF *)

Fixpoint appartient (x : nat) (l : nlist) : bool :=
  match l with
  | [] => false
  | h::rl => (Nat.eqb x h) || (appartient x rl)
  end.
(* END CUT *)

(* Exprimer (cf. TD de LIFLC) et montrer que cette fonction retourne
true sur la donnée de paramètres x de type nat et l de type nlist
seulement si on peut écrire l comme une nlist l1 concaténée à une
nlist l2 commençant par x *)

(* on aura besoin du théorème
   - Bool.orb_prop
*)
Check Bool.orb_prop.

(* on aura besoin du théorème
   - beq_nat_true (déjà vu)
*)

Check beq_nat_true.

(* En hypothèse l'existentiel est éliminé avec destruct de l'hypothèse *)
(* Rappel : la règle d'introduction de l'existentiel dans le but est exists objet_specialisé *)

Theorem appartient_seulement : forall(x:nat), forall(l:nlist), appartient x l = true -> exists(l1:nlist), exists(l2:nlist), l = concat l1 (x::l2).
Proof.
intro x.
intro l.
induction l.
-
intro h0.
exists [].
exists [].
discriminate.
-intro h1.
exists [].
exists l.
simpl.
destruct IHl.
+rewrite <- h1.
simpl.
rewrite <- h1.
Qed.

(**********************************************************************)
(* Exprimer et montrer que la fonction plus est commutative                       *)
(* On commencera par montrer un petit lemme technique                 *)
(**********************************************************************)

Lemma plus_Succ_r : forall a b, S (plus a b) = plus a (S b).
Proof.
Admitted. (* remplacer ici *)

Lemma plus_commute :
Proof.
Admitted. (* remplacer ici *)

(******************************************************************************)
(* Les arbres binaires de nat *)
(******************************************************************************)

(* le type inductif *)
Inductive BinTree : Set :=
  | leaf : BinTree
  | node : BinTree -> nat -> BinTree -> BinTree.

(**********************************************************************)
(* Montrer par induction sur Bin E qu'un arbre binaire comportant
   n occurrences de l’arbre vide contient n - 1 éléments              *)
(**********************************************************************)
(* on aura sans doute besoin du théorème plus_n_Sm *)
Check plus_n_Sm.

(* les deux fonctions qui comptent *)
Fixpoint count_leaves (t:BinTree) : nat :=
end.

Fixpoint count_nodes (t:BinTree) : nat :=
end.

(* la propriété *)
Lemma count_leaves_nodes : forall (t:BinTree), 1 + (count_nodes t) =  (count_leaves  t).
Proof.
Admitted. (* remplacer ici *)

(**********************************************************************)
(* ÉTUDE DE CAS.

On se propose de regarder le cas de l'automate qui reconnaît les mots finissant par "aab".
On commence par définir cet automate en utilisant le TP de LIFLF.
 *)
(**********************************************************************)

(* inclure ici le TP de LF *)

(* Automate qui reconnaît les mots qui finissent par "aab" *)
Definition gaab := [ ]. (* remplacer ici *)

Definition Aaab := false. (* remplacer ici *)

(* Écrire en commentaire la grammaire régulière produisant le langage de l'automate *)
(* Source : X1
 *)

(* On peut définir le prédicat "être généré par cette grammaire" *)

(* En effet : une règle "N -> c M" signifie qu'un mot généré depuis N
   peut être constitué d'un c suivi par un mot généré depuis M donc
   pour tout mot w, le mot cw est généré par N si w est généré par M.
   Dit autrement : "pour tout mot w, si w est généré depuis M alors cw
   est généré depuis N".  C'est exactement ce qu'on se propose
   d'écrire. *)

(* On va donc définir un prédicat *inductif*, paramétré par un mot et
un état (vu comme un non terminal de la grammaire ), dont chaque
règle de construction caractérise chaque règle de grammaire *)

(* Définir ce prédicat inductif Paab, de type liste Alphabet -> nat -> Prop *)
Inductive Paab : list Alphabet -> nat -> Prop := False (* remplacer ici *)
.

(* Pour montrer qu'un mot est bien généré depuis un état, il suffit
d'appliquer (apply) les règles de construction jusqu'à tomber sur un
cas de base. *)
(* Montrer que le mot abaaab est bien généré depuis le non terminal 1 *)

Lemma exemple :  Paab [a;b;a;a;a;b] 1.
Proof.
Admitted. (* remplacer ici *)

(* CE PRÉDICAT (DÉRIVÉ DE LA GRAMMAIRE) CARACTÉRISE-T-IL BIEN LES MOTS
RECONNUS PAR L'AUTOMATE ? *)

(* Pour le montrer on va poser un lemme intermédiaire *)

(* Ce lemme, appelons-le PmimeA, énonce que pour tout mot généré à
partir d'un état/non terminal, disons q, de la grammaire, la lecture
de ce mot depuis q dans l'automate aboutit à un état, disons e, et cet
état e est acceptant. *)

(* Définir le lemme PmimeA *)
Lemma PmimeA : False. (* remplacer ici *)
Proof.
Admitted. (* remplacer ici *)

(* Pour le montrer une nouvelle tactique va être bien utile :
inversion.
  - La tactique "inversion" appliquée à un nom d'inductif énumère les
  cas *possibles* de règles qui ont pu le produire.
  - Les cas absurdes sont éliminés, en particulier si une hypothèse n'a
  pu apparaître qu'à l'aide de cas absurdes, le but est prouvé.
  - On va se servir de cette tactique pour se placer dans les différents
  cas du prédicat. *)

(* Énoncer et montrer le théorème principal : tout mot généré depuis le non terminal 1 est reconnu par l'automate. *)
Theorem PA : False. (* remplacer ici *)
Proof.
Admitted. (* remplacer ici *)


(*|
####################################################
Problems with dependent types in Coq proof assistant
####################################################

:Link: https://stackoverflow.com/q/43453365
|*)

(*|
Question
********

Consider the following simple expression language:
|*)

Require Import Arith_base List. (* .none *)
Inductive Exp : Set :=
| EConst : nat -> Exp
| EVar   : nat -> Exp
| EFun   : nat -> list Exp -> Exp.

(*| and its wellformedness predicate: |*)

Definition Env := list nat.

Inductive WF (env : Env) : Exp -> Prop :=
| WFConst : forall n, WF env (EConst n)
| WFVar   : forall n, In n env -> WF env (EVar n)
| WFFun   : forall n es, In n env ->
                         Forall (WF env) es ->
                         WF env (EFun n es).

(*|
which basically states that every variable and function symbols must
be defined in the environment. Now, I want to define a function that
states the decidability of ``WF`` predicate:
|*)

Definition WFDec (env : Env) : forall e, {WF env e} + {~ WF env e}.
  refine (fix wfdec e : {WF env e} + {~ WF env e} :=
            match e as e' return e = e' -> {WF env e'} + {~ WF env e'} with
            | EConst n => fun _ => left _ _
            | EVar n => fun _ =>
                          match in_dec eq_nat_dec n env with
                          | left _ _ => left _ _
                          | right _ _ => right _ _
                          end
            | EFun n es => fun _ =>
                             match in_dec eq_nat_dec n env with
                             | left _ _ => _
                             | right _ _ => right _ _
                             end
            end (eq_refl e)); clear wfdec; subst; eauto.
Abort. (* .none *)

(*|
The trouble is how to state that ``WF`` predicate holds or not for a
list of expressions in the ``EFun`` case. My obvious guess was:

.. code-block:: coq

    ...
    match Forall_dec (WF env) wfdec es with
    ...

But Coq refuses it, arguing that the recursive call ``wfdec`` is
ill-formed. My question is: Is it possible to define decidability of
such wellformedness predicate without changing the expression
representation?

The complete working code is at the following `gist
<https://gist.github.com/rodrigogribeiro/132e4feca910f40198242d3da3eca040>`__.
|*)

(*|
Answer (ejgallego)
******************

As a temporal workaround you can define ``wf`` as:
|*)
From mathcomp Require Import all_ssreflect. (* .none *)
Definition wf (env : Env) := fix wf (e : Exp) : bool :=
    match e with
    | EConst _ => true
    | EVar v   => v \in env
    | EFun v l => [&& v \in env & all wf l]
    end.

(*|
which is usually way more convenient to use. However, this definition
will be pretty useless due to Coq generating the wrong induction
principle for ``exp``, as it doesn't detect the list. What I usually
do is to fix the induction principle manually, but this is costly.
Example:
|*)

Reset Initial. (* .none *)
From Coq Require Import List.
From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.
Import Prenex Implicits.

Section ReflectMorph.

  Lemma and_MR P Q b c : reflect P b -> reflect Q c -> reflect (P /\ Q) (b && c).
  Proof. by move=> h1 h2; apply: (iffP andP) => -[/h1 ? /h2 ?]. Qed.

  Lemma or_MR P Q b c : reflect P b -> reflect Q c -> reflect (P \/ Q) (b || c).
  Proof. by move=> h1 h2; apply: (iffP orP) => -[/h1 | /h2]; auto. Qed.

End ReflectMorph.

Section IN.
  Variables (X : eqType).

  Lemma InP (x : X) l : reflect (In x l) (x \in l).
  Proof.
    elim: l => [|y l ihl]; first by constructor 2.
    by apply: or_MR; rewrite // eq_sym; exact: eqP.
  Qed.

End IN.

Section FORALL.

  Variables (X : Type) (P : X -> Prop).
  Variables (p : X -> bool).

  Lemma Forall_inv x l : Forall P (x :: l) -> P x /\ Forall P l.
  Proof. by move=> U; inversion U. Qed.

  Lemma ForallP l : (forall x, In x l -> reflect (P x) (p x)) ->
                    reflect (Forall P l) (all p l).
  Proof.
    elim: l => [|x l hp ihl /=]; first by constructor.
    have/hp {hp}hp : forall x : X, In x l -> reflect (P x) (p x).
    by move=> y y_in; apply: ihl; right.
    have {ihl} ihl := ihl _ (or_introl erefl).
    by apply: (iffP andP) => [|/Forall_inv] [] /ihl hx /hp hall; constructor.
  Qed.

End FORALL.

Inductive Exp : Type :=
| EConst : nat -> Exp
| EVar   : nat -> Exp
| EFun   : nat -> list Exp -> Exp.

Lemma Exp_rect_list (P : Exp -> Type) :
  (forall n : nat, P (EConst n)) ->
  (forall n : nat, P (EVar n)) ->
  (forall (n : nat) (l : seq Exp),
      (forall x, In x l -> P x) -> P (EFun n l)) -> forall e : Exp, P e.
Admitted.

Definition Env := list nat.

Definition wf (env : Env) := fix wf (e : Exp) : bool :=
    match e with
    | EConst _ => true
    | EVar v   => v \in env
    | EFun v l => [&& v \in env & all wf l]
    end.

Inductive WF (env : Env) : Exp -> Prop :=
| WFConst : forall n, WF env (EConst n)
| WFVar   : forall n, In n env -> WF env (EVar n)
| WFFun   : forall n es, In n env ->
                         Forall (WF env) es ->
                         WF env (EFun n es).

Lemma WF_inv env e (wf : WF env e) :
  match e with
  | EConst n  => True
  | EVar n    => In n env
  | EFun n es => In n env /\ Forall (WF env) es
  end.
Proof. by case: e wf => // [n | n l] H; inversion H. Qed.

Lemma wfP env e : reflect (WF env e) (wf env e).
Proof.
  elim/Exp_rect_list: e => [n | n | n l ihe] /=; try repeat constructor.
  by apply: (iffP idP) => [/InP | /WF_inv/InP //]; constructor.
  apply: (iffP andP) => [[/InP ? /ForallP H] | /WF_inv[/InP ? /ForallP]].
  by constructor => //; exact: H.
  by auto.
Qed.

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

The problem is that ``Forall_dec`` is defined as opaque in the
standard library (that is, with ``Qed`` instead of ``Defined``).
Because of that, Coq does not know that the use of ``wfdec`` is valid.

The immediate solution to your problem is to redefine ``Forall_dec``
so that it is transparent. You can do this by printing the proof term
that Coq generates and pasting it in your source file. I've added a
`gist
<https://gist.github.com/anonymous/5b3fdc11871e42b3e9cfe006f6d8cc76>`__
here with a complete solution.

Needless to say, this approach lends itself to bloated, hard to read,
and hard to maintain code. As ejgallego was pointing out in his
answer, your best bet in this case is probably to define a Boolean
function that decides ``WF``, and use that instead of ``WFDec``. The
only problem with his approach, as he said, is that you will need to
write your own induction principle to ``Exp`` in order to prove that
the Boolean version indeed decides the inductive definition. Adam
Chlipala's CPDT has a `chapter
<http://adam.chlipala.net/cpdt/html/InductiveTypes.html>`__ on
inductive types that gives an example of such an induction principle;
just look for "nested inductive types".
|*)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__parallelflip.
Require Export lemma__parallelsymmetric.
Require Export logic.
Definition lemma__PGsymmetric : forall A B C D, (euclidean__defs.PG A B C D) -> (euclidean__defs.PG C D A B).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (* Cut *) ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H0.
- assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H0 by exact H.
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as __TmpHyp by exact H0.
destruct __TmpHyp as [H1 H2].
split.
-- exact H1.
-- exact H2.
- assert (* Cut *) (euclidean__defs.Par C D A B) as H1.
-- destruct H0 as [H1 H2].
apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A B C D H1).
-- assert (* Cut *) (euclidean__defs.Par B C A D) as H2.
--- destruct H0 as [H2 H3].
apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A D B C H3).
--- assert (* Cut *) (euclidean__defs.Par C B D A) as H3.
---- destruct H0 as [H3 H4].
assert (* Cut *) ((euclidean__defs.Par C B A D) /\ ((euclidean__defs.Par B C D A) /\ (euclidean__defs.Par C B D A))) as H5.
----- apply (@lemma__parallelflip.lemma__parallelflip B C A D H2).
----- destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
exact H9.
---- assert (* Cut *) (euclidean__defs.PG C D A B) as H4.
----- split.
------ exact H1.
------ exact H3.
----- exact H4.
Qed.


From mathcomp Require Import all_ssreflect.

Section Nagoya2013.

  Definition Sk k n := \sum_(1 <= i < n.+1) i ^ k.
  Variable m : nat.
  Hypothesis Hm : m > 1.
  Definition Tm n := \sum_(1 <= k < m) 'C(m, k) * Sk k n. (* binomial.v 参照*)

  Check big_nat1
        : forall (R : Type) (idx : R) (op : Monoid.law idx) (n : nat) (F : nat -> R),
            \big[op/idx]_(n <= i < n.+1) F i = F n.

  Lemma Sk1 k :
    Sk k 1 = 1.
  Proof.
    by rewrite /Sk big_nat1 exp1n.
    (*
      Sk k 1 = 1.
      ↓
      ↓rewrite /Sk.
      ↓
      \sum_(1 <= i < 2) i ^ k = 1
      ↓
      ↓rewrite big_nat1.
      ↓
      1 ^ k = 1
      ↓
      ↓rewrite exp1n.
      ↓
      1 = 1
    *)
  Qed.

  Lemma Tm1 :
    Tm 1 = 2 ^ m - 2.
  Proof.
    rewrite /Tm.
    rewrite [in 2 ^ m](_ : 2 = 1 + 1) //.
    rewrite Pascal. (* 二項公式*)
    transitivity ((\sum_(0 <= k < m.+1) 'C(m, k)) - 2).
      symmetry.
      rewrite (@big_cat_nat _ _ _ m) //=.
      rewrite (@big_cat_nat _ _ _ 1) //=; last by apply ltnW.
      rewrite addnAC !big_nat1 bin0 binn addKn.
      apply eq_bigr => i H.
      by rewrite Sk1 muln1.
    rewrite big_mkord.
    congr (_ - _).
    apply eq_bigr => i _.
    by rewrite !exp1n !muln1.
  Qed.

  Search (_ ^ _) "exp". (* 自然数の指数関数expn に関する様々な補題*)

  Lemma Tm2 :
    Tm 2 = 3 ^ m - 3.
  Proof.
    rewrite /Tm.
    have ->: 3 ^ m - 3 = 2 ^ m - 2 + (3 ^ m - 1 - 2 ^ m).
      (* 追加ここから *)
      rewrite addnC addnBA.
      - rewrite subnK.
        + by rewrite -subnDA.
        + (*
            2 ^ m <= 3 ^ m - 1
            2 ^ m <= (2 + 1) ^ m - 1
            2 ^ m <= \sum_(i < m.+1) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) - 1
            2 ^ m <= 'C(m, 0) * (2 ^ (m - 0) * 1 ^ 0) +
                     \sum_(1 <= i < m.+1) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) - 1
            2 ^ m <= 1 * (2 ^ m * 1) +
                     \sum_(1 <= i < m.+1) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) - 1
            2 ^ m <= 2 ^ m +
                     \sum_(1 <= i < m.+1) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) - 1
                0 <= \sum_(1 <= i < m.+1) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) - 1
                0 <= \sum_(1 <= i < m) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) +
                    'C(m, m) * (2 ^ (m - m) * 1 ^ m) - 1
                0 <= \sum_(1 <= i < m) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) +
                     1 * (2 ^ 0 * 1) - 1
                0 <= \sum_(1 <= i < m) 'C(m, i) * (2 ^ (m - i) * 1 ^ i) + 1 - 1
                0 <= \sum_(1 <= i < m) 'C(m, i) * (2 ^ (m - i) * 1 ^ i)
          *)
          rewrite [in 3 ^ m](_ : 3 = 2 + 1); last done.
          rewrite Pascal.
          rewrite -(@big_mkord _ 0 addn m.+1 (fun n => true) (fun i => 'C(m, i) * (2 ^ (m - i) * 1 ^ i))).
          rewrite big_nat_recl.
          rewrite bin0 subn0 expn0 mul1n muln1.
          rewrite -{1}[2 ^ m]addn0.
          rewrite -{3}[m]prednK; last by apply: (@ltn_trans 1 0 m).
          rewrite big_nat_recr /=.
          + rewrite prednK; last by apply: (@ltn_trans 1 0 m).
            rewrite binn exp1n subnn expn0 !mul1n addnA addn1 subn1 PeanoNat.Nat.pred_succ.
            by rewrite leq_add2l.
          + rewrite leq_eqVlt; apply/orP; right.
            by rewrite -(@ltn_add2r 1) add0n addn1 prednK; last by apply: (@ltn_trans 1 0 m).
          rewrite leq_eqVlt; apply/orP; right.
          by apply: (@ltn_trans 1 0 m).
      - rewrite -{1}(exp1n m) ltn_exp2r; first done.
        by apply: (@ltn_trans 1 0 m).
      (* 追加ここまで *)
    rewrite -Tm1.
    rewrite [in 3 ^ m](_ : 3 = 1 + 2) //.
    rewrite Pascal.
    transitivity (Tm 1 + (\sum_(1 <= k < m) 'C(m, k) * 2 ^ k)).
      rewrite -big_split /=.
      apply eq_bigr => i _.
      rewrite /Sk !big_cons !big_nil.
      by rewrite !addn0 -mulnDr.
    congr (_ + _).
    transitivity ((\sum_(0 <= k < m.+1) 'C(m, k) * 2 ^ k) - 1 - 2 ^ m).
    (* 追加ここから *)
      rewrite [in RHS]big_nat_recr /=.
      - rewrite binn mul1n.
        rewrite [in RHS]big_ltn; last by apply: (@ltn_trans 1 0 m).
        rewrite bin0 expn0 muln1.
        rewrite -addnA addnC -subnDA [1 + 2 ^ m]addnC -addnA -addnBA; last done.
        by rewrite subnn addn0.
      - apply: ltnW.
        by apply: (@ltn_trans 1 0 m).
    rewrite big_mkord.
    have -> : \sum_(i < m.+1) 'C(m, i) * 2 ^ i =
              \sum_(i < m.+1) 'C(m, i) * (1 ^ (m - i) * 2 ^ i).
      rewrite -(@big_mkord _ 0 addn m.+1 (fun n => true) (fun i => 'C(m, i) * 2 ^ i)).
      rewrite -(@big_mkord _ 0 addn m.+1 (fun n => true) (fun i => 'C(m, i) * (1 ^ (m - i) * 2 ^ i))).
      apply: (@eq_big_nat _ 0 addn 0 m.+1 (fun i => 'C(m, i) * 2 ^ i) (fun i => 'C(m, i) * (1 ^ (m - i) * 2 ^ i))) => i.
      by rewrite exp1n mul1n.
    by [].
    (* 追加ここまで *)
  Qed.

  Theorem Tmn n :
    Tm n.+1 = n.+2 ^ m - n.+2.
  Proof.
    elim: n => [|n IHn] /=.
      by apply Tm1.
    have Hm': m > 0 by apply ltnW.
    have ->: n.+3 ^ m - n.+3 = n.+2 ^ m - n.+2 + (n.+3 ^ m - 1 - n.+2 ^ m).
    (* 追加ここから *)
      rewrite addnC addnBA.
      - rewrite subnK.
        + by rewrite -subnDA addnC addn1.
        + rewrite -[n.+3]addn1 Pascal.
          rewrite -(@big_mkord _ 0 addn m.+1 (fun n => true) (fun i => 'C(m, i) * (n.+2 ^ (m - i) * 1 ^ i))).
          rewrite big_nat_recl; last by apply: ltnW.
          rewrite bin0 subn0 expn0 mul1n muln1 -{1}[n.+2 ^ m]addn0.
          rewrite -{3}[m]prednK; last by apply: (@ltn_trans 1 0 m).
          rewrite big_nat_recr /=.
          * rewrite prednK; last by apply: (@ltn_trans 1 0 m).
            rewrite binn exp1n subnn expn0 !mul1n addnA addn1 subn1 PeanoNat.Nat.pred_succ.
            by rewrite leq_add2l.
          * rewrite leq_eqVlt; apply/orP; right.
            by rewrite -(@ltn_add2r 1) add0n addn1 prednK; last by apply: (@ltn_trans 1 0 m).
      - rewrite -[n.+2]addn1 Pascal.
        rewrite -(@big_mkord _ 0 addn m.+1 (fun n => true) (fun i => 'C(m, i) * (n.+1 ^ (m - i) * 1 ^ i))).
        rewrite big_nat_recr /=.
        + rewrite binn exp1n subnn expn0 !mul1n.
          rewrite -{1}[m]prednK; last by apply: (@ltn_trans 1 0 m).
          rewrite big_nat_recr /=.
          * rewrite -{4}[m]prednK; last done.
            rewrite binSn prednK; last done.
            rewrite -subn1 subKn; last done.
            rewrite expn1 exp1n muln1.
            rewrite -{4}[m]prednK; last done.
            rewrite -[m.-1.+1]addn1 mulnDl mul1n -addnA -[_ + n.+1 + 1]addnA addnA.
            rewrite -{1}[n.+1 + 1]add0n (@leq_add2r (n.+1 + 1)).
            by [].
          * rewrite leq_eqVlt; apply/orP; right.
            by rewrite -(@ltn_add2r 1) add0n addn1 prednK; last by apply: (@ltn_trans 1 0 m).
        + by apply: ltnW.
    (*
      この時点でゴールは次の形になっている。
      m : nat
      Hm : 1 < m
      n : nat
      IHn : Tm n.+1 = n.+2 ^ m - n.+2
      Hm' : 0 < m
      ______________________________________(1/1)
      Tm n.+2 = n.+2 ^ m - n.+2 + (n.+3 ^ m - 1 - n.+2 ^ m)
    *)
    rewrite -IHn /Tm /Sk.
    (*
        \sum_(1 <= k < m) 'C(m, k) * (\sum_(1 <= i < n.+3) i ^ k)
      = \sum_(1 <= k < m) 'C(m, k) * (\sum_(1 <= i < n.+2) i ^ k + n.+2 ^ k)
      = \sum_(1 <= k < m) 'C(m, k) * \sum_(1 <= i < n.+2) i ^ k +
        \sum_(1 <= k < m) 'C(m, k) * n.+2 ^ k

        \sum_(1 <= k < m) 'C(m, k) * n.+2 ^ k
      = 'C(m, 1)    * n.+2 ^ 1 +
        ... +
        'C(m, m.-1) * n.+2 ^ m.-1

        n.+3 ^ m - 1 - n.+2 ^ m
      = n.+3 ^ m - 1 - n.+2 ^ m
      = (n.+2 + 1) ^ m - 1 - n.+2 ^ m
    *)
    have -> : n.+3 ^ m - 1 - n.+2 ^ m = \sum_(1 <= k < m) 'C(m, k) * n.+2 ^ k.
      rewrite -[n.+3]addn1 addnC.
      rewrite Pascal.
      rewrite -(@big_mkord _ 0 addn m.+1 (fun n => true) (fun i => 'C(m, i) * (1 ^ (m - i) * n.+2 ^ i))).
      rewrite big_nat_recr /=; last done.
      rewrite binn exp1n !mul1n.
      rewrite big_ltn; last done.
      rewrite bin0 exp1n !mul1n expn0 [1 + _]addnC -addnA -subnDA -subnBA; last done.
      rewrite subnn subn0.
      apply: eq_big_nat => i H.
      by rewrite exp1n mul1n.
    rewrite -big_split /=.
    apply: congr_big; first done; first done.
    by move=> i _; rewrite -mulnDr -big_nat_recr.
    (* 追加ここまで *)
  Qed.

  Lemma lm_bin p k :
    2 < p ->
    1 <= k < p.-1 ->
    prime p ->
    ~~(p %| 'C(p.-1, k)).
    (*
      pが3以上の素数であり、
      kが1以上p-1未満であるなら、
      'C(p-1, k)はpで割り切れない。
    *)
  Proof.
    move=> Hpgt2 /andP [Hkgt0 Hkltpredp] Hprmp.
    rewrite bin_factd.
    - rewrite -prime_coprime; last done.
      apply/coprimeP; first by apply: (@ltn_trans 2).
      exists (((p.-1)`!.+1) %/ p, k`! * (p.-1 - k)`!) => /=.
      rewrite divnK.
      + rewrite mulnC divnK.
        * rewrite -addn1 addnC -addnBA; last done.
          by rewrite subnn.
        * rewrite -(@bin_fact p.-1 k).
          -- by apply: dvdn_mull.
          -- by rewrite leq_eqVlt; apply/orP; right.
      + by move: (Hprmp); rewrite Wilson; last by apply: (@ltn_trans 2).
    - by apply: (@ltn_trans k).
  Qed.

  Lemma lm_evn_p p :
    p > 2 ->
    prime p ->
    odd p.-1 = false.
    (*
      pが3以上の素数なら、
      p-1は奇数ではない。
    *)
  Proof.
    move=> Hpgt2 => /even_prime [Hpeq2 | Hoddp].
    - by rewrite Hpeq2 in Hpgt2.
    - apply: negbTE.
      rewrite -oddS.
      rewrite prednK; first done.
      by apply: (@ltn_trans 2 0 p).
  Qed.

  Lemma lm_div_p_tmpp_pp p :
    p > 2 ->
    \sum_(1 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1 = p ^ p.-1 - p ->
    p %| \sum_(1 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1.
    (*
      pが3以上で、
      \sum_(1 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1 = p ^ p.-1 - pなら、
      \sum_(1 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1はpで割り切れる。(当たり前)
    *)
  Proof.
    move=> Hpgt2 ->.
    apply: dvdn_sub; last done.
    apply: dvdn_exp; last done.
    rewrite ltn_predRL.
    by apply: (@ltn_trans 2 1 p).
  Qed.

  Lemma lm_div_3_tm2_2 :
    3 %| \sum_(1 <= k < 2) 'C(2, k) * Sk k 2.
    (*
      \sum_(1 <= k < 2) 'C(2, k) * Sk k 2は3で割り切れる。
    *)
  Proof.
    rewrite big_nat1 bin1 /Sk.
    have -> : (2 * \sum_(1 <= i < 3) i ^ 1) = 2 * 3.
      rewrite big_ltn; last done.
      rewrite big_ltn; last done.
      by rewrite big_nil !expn1 addn0.
    by apply: dvdn_mull.
  Qed.

  Lemma lm_div_3_tm2_2' :
    3 %| Sk 1 2.
    (*
      Sk 1 2は3で割り切れる。(定理Skpでp=3の場合)
    *)
  Proof.
    move: lm_div_3_tm2_2.
    rewrite big_ltn; last done.
    rewrite big_nil addn0.
    have H : ~~ (3 %| 'C(2, 1)) by apply: (lm_bin 3 1).
    rewrite Euclid_dvdM; last done.
    by move/orP; case.
  Qed.

  Lemma lm_sum_0_to_n n :
    2 * (\sum_(0 <= i < n.+1) i ^ 1) = n * n.+1.
    (*
      1からnまでの和は、n*(n+1)/2に等しい。
    *)
  Proof.
    elim: n => [| n IHn].
    - rewrite big_ltn; last done.
      rewrite expn1 add0n.
      by rewrite big_geq; last done.
    - rewrite big_nat_recr /=; last done.
      by rewrite mulnDr expn1 IHn -mulnDl addn2 mulnC.
  Qed.

  Lemma lm_div_p_tmpp_pp' p :
    p > 2 ->
    prime p ->
    p %| \sum_(1 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1 ->
    (p %| \sum_(1 <= k < 2) 'C(p.-1, k) * Sk k p.-1)
    /\ (p %| \sum_(2 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1).
    (*
      pが3以上の素数で、
      \sum_(1 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1がpで割り切れるなら、
      \sum_(1 <= k < 2) 'C(p.-1, k) * Sk k p.-1と
      \sum_(2 <= k < p.-1) 'C(p.-1, k) * Sk k p.-1は
      ともにpで割り切れる。
    *)
  Proof.
    move=> Hpgt2 Hprmp.
    rewrite big_ltn; last by rewrite ltn_predRL.
    rewrite bin1.
    rewrite -{1}(@odd_double_half p.-1) lm_evn_p; last done; last done.
    rewrite -muln2 -mulnA /Sk prednK; last  by apply: (@ltn_trans 2 0 p).
    have H : 2 * (\sum_(1 <= i < p) i ^ 1) = p.-1 * p.
      move: (lm_sum_0_to_n p.-1).
      rewrite prednK; last by apply: (@ltn_trans 2 0 p).
      rewrite big_ltn; last by apply: (@ltn_trans 2 0 p).
      by rewrite expn1 add0n.
    rewrite H mulnA.
    move/dvdn_add_eq.
    rewrite dvdn_mull; last done.
    move=> <-.
    rewrite big_ltn; last done.
    rewrite bin1 -{1}(@odd_double_half p.-1) lm_evn_p; last done; last done.
    by rewrite -muln2 -mulnA /Sk H mulnA big_nil addn0 dvdn_mull.
  Qed.

  Lemma lm_div_p_tmpp_pp'' p :
    p > 2 ->
    prime p ->
    m = p.-1 ->
    p %| \sum_(1 <= k < m) 'C(m, k) * Sk k p.-1.
    (*
      pが3以上の素数であり、
      m=p-1なら、
      \sum_(1 <= k < m) 'C(m, k) * Sk k p.-1はpで割り切れる。
    *)
  Proof.
    move=> Hpgt2 Hprmp Hmeqprdp.
    move: (Tmn p.-2).
    rewrite prednK /Tm.
    - move=> ->.
      rewrite prednK; last by apply: (@ltn_trans 2 0 p).
      apply: dvdn_sub; last done.
      rewrite dvdn_exp; first done; last done.
      by apply: (@ltn_trans 1 0 m).
    - rewrite -Hmeqprdp.
      by apply: (@ltn_trans 1 0 m).
  Qed.

  Theorem Skp p k :
    p > 2 ->
    prime p ->
    1 <= k < p.-1 ->
    p %| Sk k p.-1.
    (*
      pが3以上の素数のとき、
      Sk(p-1) (1 <= k <= p-2)はpの倍数である。
    *)
  Proof.
    (* 追加ここから *)
    (* 追加ここまで *)
  Admitted.

End Nagoya2013.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.

(** A cardinality restriction for types is a property that holds for a type
    if and only if it holds for all types isomorphic to it. *)
Record Card_Restriction : Type :=
{
  Card_Rest : Type → Prop;

  Card_Rest_Respect : ∀ (A B : Type),
      (A ≃≃ B ::> Type_Cat)%isomorphism → Card_Rest A → Card_Rest B
}.

Coercion Card_Rest : Card_Restriction >-> Funclass.

(** A type is finite if it is isomorphic to a subset of natural numbers
    less than n for soem natural number n. *)
Program Definition Finite : Card_Restriction :=
  {|
    Card_Rest :=
      fun A => inhabited {n : nat & (A ≃≃ {x : nat | x < n} ::> Type_Cat)%isomorphism}
  |}.

Next Obligation.
Proof.
  destruct H as [[n I]].
  eexists.
  refine (existT _ n (I ∘ (X⁻¹)%isomorphism)%isomorphism).
Qed.


Require Export ImpList_J.

Definition Assertion := state -> Prop.

Definition hoare_triple (P: Assertion) (c: com) (Q: Assertion): Prop :=
  forall st st',
    c / st || st' ->
    P st ->
    Q st'.

Notation "{{ P }} c" := (hoare_triple P c (fun st => True)) (at level 90): hoare_spec_scope.
Notation "{{ P }} c {{ Q }}" := (hoare_triple P c Q) (at level 90, c at next level): hoare_spec_scope.

Open Scope hoare_spec_scope.

Theorem hoare_post_true: forall (P Q: Assertion) c,
                           (forall st, Q st) ->
                           {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval Hp.
  apply H.
Qed.

Theorem hoare_pre_false: forall (P Q: Assertion) c,
                           (forall st, ~(P st)) ->
                           {{P}} c {{Q}}.
Proof.
  intros P Q c H.
  unfold hoare_triple.
  intros st st' Heval Hpre.
  apply H in Hpre.
  inversion Hpre.
Qed.

Definition assn_sub V a Q: Assertion :=
  fun (st: state) =>
    Q (update st V (aeval st a)).

Theorem hoare_asgn: forall Q V a,
                      {{assn_sub V a Q}} (V ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q V a st st' HE HQ.
  unfold assn_sub in HQ.
  inversion HE.
  subst.
  assumption.
Qed.

Example assn_sub_example :
  {{fun st => 3 = 3}}
    (X ::= (ANum 3))
    {{fun st => asnat (st X) = 3}}.
Proof.
  assert ((fun st => 3 = 3) = (assn_sub X (ANum 3) (fun st => asnat (st X) = 3))).
  unfold assn_sub. reflexivity.
  rewrite -> H.
  apply hoare_asgn.
Qed.

Theorem hoare_asgn_eq: forall Q Q' V a,
                         Q' = assn_sub V a Q ->
                         {{Q'}} (V ::= a) {{Q}}.
Proof.
  intros Q Q' V a H.
  rewrite H. apply hoare_asgn.
Qed.

Example assn_sub_example':
  {{fun st => 3 = 3}}
    (X ::= (ANum 3))
    {{fun st => asnat (st X) = 3}}.
Proof.
  apply hoare_asgn_eq. reflexivity.
Qed.

Theorem hoare_asgn_weakest: forall P V a Q,
                              {{P}} (V ::= a) {{Q}} ->
                              forall st, P st -> assn_sub V a Q st.
Proof.
  intros P V a Q Has st HE.
  unfold hoare_triple in Has.
  unfold assn_sub.
  apply Has with (st := st).
  apply E_Asgn.
  reflexivity.
  assumption.
Qed.

Theorem hoare_consequence: forall (P P' Q Q': Assertion) c,
                             {{P'}} c {{Q'}} ->
                             (forall st, P st -> P' st) ->
                             (forall st, Q' st -> Q st) ->
                             {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c H HPP' HQ'Q.
  intros st st' Hc HP.
  apply HQ'Q. apply (H st st'). assumption.
  apply HPP'. assumption.
Qed.

Theorem hoare_consequence_pre: forall (P P' Q: Assertion) c,
                                 {{P'}} c {{Q}} ->
                                 (forall st, P st -> P' st) ->
                                 {{P}} c {{Q}}.
Proof.
  intros P P' Q c H HPP'.
  apply hoare_consequence with (P' := P') (Q' := Q); try assumption.
  intros st H'. apply H'.
Qed.

Theorem hoare_consequence_post: forall (P Q' Q: Assertion) c,
                                  {{P}} c {{Q'}} ->
                                  (forall st, Q' st -> Q st) ->
                                  {{P}} c {{Q}}.
Proof.
  intros P Q' Q c H HQQ'.
  apply hoare_consequence with (P' := P) (Q' := Q'); try assumption.
  + intros st H'. apply H'.
Qed.

Example hoare_asgn_example1:
  {{fun st => True}} (X ::= (ANum 1)) {{fun st => asnat (st X) = 1}}.
Proof.
  apply hoare_consequence_pre with (P' := (fun st => 1 = 1)).
  apply hoare_asgn_eq. reflexivity.
  intros st H. reflexivity.
Qed.

Example hoare_asgn_example1' :
  {{fun st => True}}
    (X ::= (ANum 1))
    {{fun st => asnat (st X) = 1}}.
Proof.
  eapply hoare_consequence_pre.
  apply hoare_asgn_eq. reflexivity.
  intros st H. reflexivity.
Qed.

Theorem hoare_skip: forall P,
                      {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP.
  inversion H.
  subst. assumption.
Qed.

Theorem hoare_seq: forall P Q R c1 c2,
                     {{Q}} c2 {{R}} ->
                     {{P}} c1 {{Q}} ->
                     {{P}} c1;c2 {{R}}.
Proof.
  intros P Q R c1 c2 HQR HPQ.
  intros st st' H Hp.
  inversion H. subst. clear H.
  apply (HQR st'0 st'); try assumption.
  apply (HPQ st st'0); try assumption.
Qed.

Example hoare_asgn_example3: forall a n,
                               {{fun st => aeval st a = n}}
                                 (X ::= a; SKIP)
                                 {{fun st => st X = n}}.
Proof.
  intros a n. eapply hoare_seq.
  + apply hoare_skip.
  + eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. subst. reflexivity.
Qed.

Example hoare_asgn_example4:
  {{fun st => True}} (X ::= (ANum 1); Y ::= (ANum 2))
               {{fun st => asnat (st X) = 1 /\ asnat (st Y) = 2}}.
Proof.
  eapply hoare_seq.
  apply hoare_asgn.
  unfold assn_sub.
  unfold update.
  simpl.
  intros st st' H H'.
  inversion H. subst. simpl.
  omega.
Qed.

Definition bassn b: Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true: forall b st,
                        beval st b = true -> (bassn b) st.
Proof.
  intros b st H.
  unfold bassn. assumption.
Qed.

Lemma bexp_eval_false: forall b st,
                         beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st H contra.
  unfold bassn in contra.
  rewrite contra in H. inversion H.
Qed.

Theorem hoare_if: forall P Q b c1 c2,
                    {{fun st => P st /\ bassn b st}} c1 {{Q}}  ->
                    {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
                    {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  + apply (HTrue st st'). assumption.
    split. assumption. apply bexp_eval_true. assumption.
  + apply (HFalse st st'). assumption.
    split. assumption. apply bexp_eval_false. assumption.
Qed.

Example if_example:
  {{fun st => True}}
    IFB (BEq (AId X) (ANum 0))
    THEN (Y ::= (ANum 2))
    ELSE (Y ::= (APlus (AId X) (ANum 1)))
    FI
    {{fun st => asnat (st X) <= asnat (st Y)}}.
Proof.
  apply hoare_if.
  + eapply hoare_consequence_pre. apply hoare_asgn.
    unfold bassn, assn_sub, update.  simpl. intros.
    inversion H. symmetry in H1; apply beq_nat_eq in H1.
    rewrite H1. omega.
  +
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold assn_sub, update; simpl; intros. omega.
Qed.

Lemma hoare_while: forall P b c,
                     {{fun st => P st /\ bassn b st}} c {{P}} ->
                     {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  remember (WHILE b DO c END) as wocm.
  ceval_cases (induction He) Case; try (inversion Heqwocm); subst.
  Case "E_WhileEnd".
  split. assumption. apply bexp_eval_false. assumption.
  Case "E_WhileLoop".
  apply IHHe2. reflexivity.
  apply (Hhoare st st'); try assumption.
  split. assumption. apply bexp_eval_true. assumption.
Qed.

Example while_example:
  {{fun st => asnat (st X) <= 3}}
    WHILE (BLe (AId X) (ANum 2))
    DO X ::= APlus (AId X) (ANum 1) END
    {{fun st => asnat (st X) = 3}}.
Proof.
  eapply hoare_consequence_post.
  apply hoare_while.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  unfold bassn, assn_sub. intros. rewrite update_eq. simpl.
  inversion H as [_ H0].simpl in H0. apply ble_nat_true in H0.
  omega.
  unfold bassn. intros. inversion H as [Hle Hb]. simpl in Hb.
  remember (ble_nat (asnat (st X)) 2) as le. destruct le.
  apply ex_falso_quodlibet. apply Hb. reflexivity.
  symmetry in Heqle. apply ble_nat_false in Heqle. omega.
Qed.

Theorem always_loop_hoare: forall P Q,
                             {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  intros P Q.
  apply hoare_consequence_pre with (P' := fun st : state => True).
  eapply hoare_consequence_post.
  apply hoare_while.
  Case "Loop body preserves invariant".
  apply hoare_post_true. intros st. apply I.
  Case "Loop invariant and negated guard imply postcondition".
  simpl. intros st [Hinv Hguard].
  apply ex_falso_quodlibet. apply Hguard. reflexivity.
  Case "Precondition implies invariant".
  intros st H. constructor.
Qed.

Theorem always_loop_hoare': forall P Q,
                              {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  unfold hoare_triple. intros P Q st st' contra.
  apply loop_never_stops in contra. inversion contra.
Qed.


From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype seq.

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

Section SnocList.
Context (A : Type).

Inductive sseq : Type :=
	snil : sseq | snoc : sseq -> A -> sseq.

Fixpoint scat s1 s2 := if s2 is snoc s2' x then snoc (scat s1 s2') x else s1.

End SnocList.

Section Fun.

Fixpoint smap {A B} (f : A -> B) (s : sseq A) : sseq B :=
  if s is snoc xs x then snoc (smap f xs) (f x) else @snil B.

Fixpoint to_seq {A} (s : sseq A) : seq A :=
  if s is snoc xs x then rcons (to_seq xs) x else [::].

Fixpoint from_seq {A} (s : seq A) : sseq A :=
  if s is x::xs then scat (snoc (@snil A) x) (from_seq xs) else @snil A.

End Fun.

Section Eqtype.
Context {T : eqType}.

Fixpoint eq_sseq (t1 t2 : sseq T) :=
  match t1, t2 with
  | snil, snil => true
  | snoc s x, snoc t y => eq_sseq s t && (x == y)
  | _, _ => false
  end.

Lemma eq_sseqP : Equality.axiom eq_sseq.
Proof.
move; elim=> [|s IH x][|t y] /=; try by constructor.
have [<-/=|neqx] := x =P y; last by rewrite andbF; apply: ReflectF; case.
rewrite andbT; apply: (iffP idP).
- by move/IH=>->.
by case=><-; apply/IH.
Qed.

Canonical sseq_eqMixin := EqMixin eq_sseqP.
Canonical sseq_eqType := Eval hnf in EqType (sseq T) sseq_eqMixin.

End Eqtype.

Section SnocPred.
Context (A : Type).
Variable a : pred A.

Fixpoint sall s := if s is snoc s' x then a x && sall s' else true.

Fixpoint shas s := if s is snoc s' x then a x || shas s' else false.

End SnocPred.


Theorem lt_le: forall n p: nat, n < p -> n <= p.
Proof.
intros n p H.

Show.
(*
  intros  n p H. unfold lt in H. apply le_S_n. apply le_S. exact H.
Qed.
*)


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

Require Import List Arith Omega.
Require Import list_utils wf_utils bt bft_forest bft_std bft_inj.

Set Implicit Arguments.

Section bfn_NC. (* necessary conditions *)

  (** We derive equations from the functional spec of BFN:

      the expected output of (bfn_f i l) is
      a list ln such that l ~lt ln
                      and is_bfn_from i ln *)

  Variable (X : Type) (bfn_f : nat -> list (bt X) -> list (bt nat))
           (H0 : forall i l, l ~lt rev (bfn_f i l))
           (H1 : forall i l, is_bfn_from i (rev (bfn_f i l))).

  Let H0' i l : rev l ~lt bfn_f i l.
  Proof.
    apply Forall2_rev_eq.
    rewrite rev_involutive.
    apply H0.
  Qed.

  Fact rev_inj K (l m : list K) : rev l = rev m -> l = m.
  Proof.
    intro.
    rewrite <- (rev_involutive l), <- (rev_involutive m).
    f_equal; trivial.
  Qed.

  Theorem bfn_f_eq_0 i : bfn_f i nil = nil.
  Proof.
    apply rev_inj.
    symmetry; apply lbt_is_bfn_from_eq with i; simpl; auto.
    + apply lbt_eq_trans with (2 := H0 _ _); constructor.
    + red; rewrite bft_f_fix_0; simpl; constructor.
  Qed.

  Theorem bfn_f_eq_1 i x l : bfn_f i (leaf x::l) = bfn_f (S i) l ++ leaf i :: nil.
  Proof.
    apply rev_inj.
    rewrite rev_app_distr; simpl.
    apply lbt_is_bfn_from_eq with i; auto.
    + apply lbt_eq_sym, lbt_eq_trans with (2 := H0 _ _); repeat constructor.
      apply lbt_eq_sym, H0.
    + red; rewrite bft_f_fix_oka_1; simpl.
      split; auto; apply H1.
  Qed.

  Theorem bfn_f_eq_2 i a x b l : exists an bn ln,
               bfn_f (S i) (l++a::b::nil) = bn::an::ln
            /\ bfn_f i (node a x b::l) = ln ++ node an i bn :: nil.
  Proof.
    generalize (H0 (S i) (l++a::b::nil)); intros H.
    apply Forall2_rev in H.
    rewrite rev_involutive, rev_app_distr in H.
    simpl in H; revert H.
    case_eq (bfn_f (S i) (l ++ a :: b :: nil)).
    { inversion 2. }
    intros bn ln E H.
    apply Forall2_cons_inv in H.
    destruct H as (H2 & H).
    destruct ln as [ | an ln ].
    { inversion H. }
    apply Forall2_cons_inv in H.
    destruct H as (H3 & H4).
    exists an, bn, ln; split; auto.
    apply rev_inj.
    apply lbt_is_bfn_from_eq with i; auto.
    + apply lbt_eq_sym, lbt_eq_trans with (2 := H0 _ _), lbt_eq_sym.
      rewrite rev_app_distr.
      simpl; repeat constructor; auto.
      apply Forall2_rev_eq.
      rewrite rev_involutive; auto.
    + red; rewrite rev_app_distr; simpl.
      rewrite bft_f_fix_oka_2; simpl.
      split; auto.
      generalize (H1 (S i) (l++a::b::nil)).
      rewrite E; simpl.
      rewrite app_ass; simpl; auto.
  Qed.

End bfn_NC.

Section bfn_SC. (* sufficient conditions, synthesis *)

  (* Assuming [bfn_f] satisfies the previous equations,
     then [bfn_f] satisfies the functional spec of BFN *)

  Variable (X : Type) (bfn_f : nat -> list (bt X) -> list (bt nat))
           (H0 : forall i, bfn_f i nil = nil)
           (H1 : forall i x l, bfn_f i (leaf x::l) = bfn_f (S i) l ++ leaf i :: nil)
           (H2 : forall i a x b l, exists an bn ln,
                bfn_f (S i) (l++a::b::nil) = bn::an::ln
             /\ bfn_f i (node a x b::l) = ln ++ node an i bn :: nil).

  Theorem bfn_f_lt i l : l ~lt rev (bfn_f i l).
  Proof.
    induction on i l as IH with measure (lsum l).
    destruct l as [ | [ x | a x b ] l ].
    + rewrite H0; constructor.
    + rewrite H1, rev_app_distr; simpl.
      repeat constructor.
      apply IH; simpl; omega.
    + destruct (H2 i a x b l) as (an & bn & ln & H3 & H4).
      rewrite H4, rev_app_distr; simpl.
      assert (lsum (l++a::b::nil) < lsum (node a x b :: l)) as D.
      { rewrite lsum_app; simpl; omega. }
      generalize (IH (S i) _ D); rewrite H3.
      simpl; rewrite app_ass; simpl; intros H5.
      apply Forall2_2snoc_inv in H5; destruct H5 as (? & ? & ?).
      repeat constructor; assumption.
  Qed.

  Theorem bfn_f_bfn i l : is_bfn_from i (rev (bfn_f i l)).
  Proof.
    induction on i l as IH with measure (lsum l).
    destruct l as [ | [ x | a x b ] l ].
    + rewrite H0; red; rewrite bft_f_fix_0; simpl; constructor.
    + rewrite H1, rev_app_distr; simpl; red.
      rewrite bft_f_fix_oka_1; split; auto.
      apply IH; simpl; omega.
    + destruct (H2 i a x b l) as (an & bn & ln & H3 & H4).
      rewrite H4, rev_app_distr; simpl; red.
      rewrite bft_f_fix_oka_2; split; auto.
      replace (rev ln++an::bn::nil) with (rev (bn::an::ln)).
      * rewrite <- H3; apply IH.
        rewrite lsum_app; simpl; omega.
      * simpl; rewrite app_ass; auto.
  Qed.

End bfn_SC.


Require Export XR_Rplus_0_r.
Require Export XR_Rle_lt_trans.
Require Export XR_Rplus_le_compat_l.

Local Open Scope R_scope.

Lemma Rplus_lt_reg_pos_r : forall r1 r2 r3,
  R0 <= r2 ->
  r1 + r2 < r3 ->
  r1 < r3.
Proof.
  intros x y z.
  intros hy h.
  apply Rle_lt_trans with (x+y).
  {
    pattern x at 1;rewrite <- Rplus_0_r.
    apply Rplus_le_compat_l.
    exact hy.
  }
  { exact h. }
Qed.