(** * IndProp: Индуктивно Определенные Пропозиции *)

Require Export Logic.

(* ################################################################# *)
(** * Индуктивно Определенные Пропозиции *)

(** В главе [Логика] мы взглянули на несколько способов записывания
    пропозиций, включая конъюнкцию, дизнъюнкцию и кванторы.
    В данной главе, мы привнесем новый инстрмент: _индуктивные
    определения_.

    Вспомните что мы видели два способа утверждать что число [n]
    четно: мы говорим (1) [evenb n = true], или (2) [exists k, n =
    double k].  В то же время, другая возможность выразить то что
    [n] четно это способ установить его четность исходя из
    следующих правил:

       - Правило [ev_0]: Число [0] четно.
       - Правило [ev_SS]: Если [n] четно, тогдаn [S (S n)] также четно.

    Чтобы проиллюстрировать как данное новое определение четности
    работает, давайте воспользуемся его правилами, чтобы показать
    что [4] четно. По правилу [ev_SS], достаточно показать, что
    четно [2]. Это, в свою очередь, опять гарантировано правилом
    [ev_SS], если мы можем показать четность [0]. Но данный последний
    факт напрямую следует из правила [ev_0]. *)

(** Мы увидем много определений наподобие предыдущего в течении
    данного курса. Для целей неформального обсуждения, полезно
    иметь легковесную нотацию, которая делает легким их запись
    и чтение.  _Правила вывода_ одна такая нотация: *)
(**

                              ------------                        (ev_0)
                                 ev 0

                                  ev n
                             --------------                      (ev_SS)
                              ev (S (S n))
*)

(** Каждое текстовое правило сверху переформатировано здесь в
    правило вывода; предполагаемое прочтение, если _предпосылки_
    сверху линии справедливы, то _заключения_ под линией
    следуют. Например, правило [ev_SS] говорит что, если [n]
    удовлетворяет [ev], тогда [S (S n)] также. Если правило не
    имеет предпоссылок над линией, то утверждение справедливо
    без предусловий.

    Мы можем представить доказательство используя данные правила
    комбинируя применения правил в _дерево доказательств_. Вот как
    мы може записать доказательство того что [4] четно: *)
(**

                ------  (ev_0)
                 ev 0
                ------ (ev_SS)
                 ev 2
                ------ (ev_SS)
                 ev 4
*)

(** Почему мы называем это "деревом" (вместо "стека", например)?
    Потому что, в общем случае, оравила вывода могут иметь много предпосылок.
    Мы увидем примеры этого в дальнейшем. *)

(** Объединяя все это вместе, мы можем перевести определение четности
    в формальное определение Coq используя декларацию [Inductive],
    в которой каждый конструктор соответствует правилу вывода: *)

Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS : forall n : nat, ev n -> ev (S (S n)).

(** Данное определение отличается в одном важном смысле от предыдущих
    использований [Inductive]: его результат не есть [Type], но
    функция из [nat] в [Prop] -- т.е., свойство чисел. Заметьте,
    что мы уже видели другие индуктивные определения, такие как
    [list], чей тип есть [Type ->Type]. Что нового здесь, так это то, что
    так как  аргумент [nat] для [ev] появляется _неназваным_, в _правой_
    части от двоеточия ему позволительно принимать разные значения
    в типах разных конструкторов: [0] в типе [ev_0] и [S (S n)] в типе [ev_SS].

    В отличие, определение [list] называет параметр [X]
    _глобально_, с _левок_ части двоеточия, заставляя, как результат,
    [nil] и [cons] быть теми же ([list X]).  Если бы мы попробовали бы
    перенести [nat] на лево в определении [ev], мы бы увидели бы ошибку: *)

Fail Inductive wrong_ev (n : nat) : Prop :=
| wrong_ev_0 : wrong_ev 0
| wrong_ev_SS : forall n, wrong_ev n -> wrong_ev (S (S n)).
(* ===> Error: A parameter of an inductive type n is not
        allowed to be used as a bound variable in the type
        of its constructor. *)

(** ("Parameter" здесь есть жаргонизм Coq для аргумента слева от двоеточия
    в определнии [Inductive] ; "индекс" используется для отмечания аргументов
    из правой части двоеточия.) *)

(** Мы можем думать об определении [ev] как об определении свойства a Coq
    [ev : nat -> Prop], вместе с теоремами [ev_0 : ev 0] и
    [ev_SS : forall n, ev n -> ev (S (S n))].  Такие "теоремы конструкторы"
    имеют тот же статус, что и доказанные теоремы. В частности,
    мы можем использовать тактику Coq [apply] вместе именами правил для
    доказательства [ev] в случае заданных чисел... *)

Theorem ev_4 : ev 4.
Proof. apply ev_SS. apply ev_SS. apply ev_0. Qed.

(** ... или мы можем использовать синтакс применения функции: *)

Theorem ev_4' : ev 4.
Proof. apply (ev_SS 2 (ev_SS 0 ev_0)). Qed.

(** Мы также можем доказать теоремы что имеют гипотезы включающие [ev]. *)

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.

(** Более обще, мы можем показать что любое число умноженное на 2 четно: *)

(** **** Упражнение: 1 звездочка (ev_double)  *)
Theorem ev_double : forall n,
  ev (double n).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Используем Свидетельства в Доказательствах *)

(** Кроме _конструирования_ свидетельств того что числа четные, мы также
    можем _рассуждать о_ таких свидетельствах.

    Введение [ev] с декларацией [Inductive] говорит Coq не только
    что конструкторы [ev_0] и [ev_SS] есть валидные способы построить
    свидетельство что некоторое число четно, но также что эти два
    конструктора являются _единственными_ путями построить такое
    свидетельство (в смысле [ev]). *)

(** Другими словами, если кто то предоставляет вам свидетельство
    [E] для утверждения [ev n], тогда мы знаем что [E] должно иметь одну
    из двух форм:

      - [E] есть [ev_0] (и [n] есть [O]), или
      - [E] есть [ev_SS n' E'] (и [n] есть [S (S n')], где [E'] есть
        свидетельство для [ev n']). *)

(** Это предполагает что существует возможность для анализа
    гипотезы в формеэ [ev n] примерно также как мы делали в
    слуаче индуктивно определенных структур данных; в частности,
    должно быть возможным аргументировать по _индукции_ и
    _разбором случаев_ на данном свидетельстве. Давайте рассмотрим
    несколько примеров, чтобы увидеть что это значит на практике. *)

(* ================================================================= *)
(** ** Инверсия на Свидетельстве *)

(** Вычитание двойки из четного числа производит четное число.
    Мы можем легко этп доказать с помощью техник, что мы уже видели,
    если конечно сформулируем данный факт в нужной форме. Если
    мы сформулируем его в терминах [evenb], например, мы сможем
    использовать простой анализ случаев на [n]: *)

Theorem evenb_minus2: forall n,
  evenb n = true -> evenb (pred (pred n)) = true.
Proof.
  intros [ | [ | n' ] ].
  - (* n = 0 *) reflexivity.
  - (* n = 1; contradiction *) intros H. inversion H.
  - (* n = n' + 2 *) simpl. intros H. apply H.
Qed.

(** Мы може сформулировать данное заявление в терминах [ev], но мы быстро
    застреваем: Так как [ev] определено индуктивно -- ане как функция
    -- Coq не знает как упрощать цель включающую [ev n] после разбора случаев
    на [n]. Как следствие, эта стратегия доказательства не срабатывает: *)

Theorem ev_minus2: forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros [ | [ | n' ] ].
  - (* n = 0 *) simpl. intros _. apply ev_0.
  - (* n = 1; и тут мы застреваем! *) simpl.
Abort.

(** Решением будет применить разбор случаев на свидетельстве того что [ev
    n] _напрямую_. По определению [ev], есь два случая на рассмотрение:

    - Если свидетельство есть в форме [ev_0], мы знаем что [n = 0].
      Таким образом, достаточно показать что [ev (pred (pred 0))] справедливо.
      По определению [pred], это эквивалентно тому что
      [ev 0] справедливо, что следует напрямую из [ev_0].

    - Иначе, свидетельство должно иметь форму [ev_SS n' E'], где
      [n = S (S n')] и [E'] есть свидетельство для [ev n']. Тогда мы
      должны показать что [ev (pred (pred (S (S n'))))] справедливо,
      что, после некоторого упрощения, следуе напрямую из [E']. *)

(** Мы можем вызвать такой вид аргумента из Coq используя тактику [inversion].
    Кроме того что она позволяет нам рассуждать о равенствах включающих
    конструкторы, [inversion] предоставляет принцип разбора случаев для
    индуктивно определенных пропозиций. Когда использована таким образом,
    ее синтаксис похож на [destruct]: мы передаем список идентификаторов
    разделеных символами [|] для называния их аргументов в случае каждого
    возожного конструктора. Например: *)

Theorem ev_minus2 : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  inversion E as [| n' E'].
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'.  Qed.

(** Заметьте чт0, в данном конкретном случае, также возможно заменить
    [inversion] на [destruct]: *)

Theorem ev_minus2' : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'].
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'.  Qed.

(** Разнца в этих двух формах заключается в том, том [inversion] более
    удобна когда применена на гипотезе состоящией из индуктивного
    свойства примененного к сложному выраженип (в отличии от одной
    переменной). Бот конкретный пример. Предположим, что мы хотим
    доказать следующую вариацию [ev_minus2]: *)

Theorem evSS_ev : forall n,
  ev (S (S n)) -> ev n.

(** Интуитивно, мы знаем что свидетельство для гипотезы не может
    состоять из одного лишь конструктора [ev_0], так как [O] и [S]
    разные конструкторы типа [nat]; таким образом, [ev_SS] единственый
    случай что применим. К несчастью, [destruct] неодстаточно умен чтобы
    это понять, и всеравно генерирует две подцели. Даже хуже,
    делая это, она оставляет финальную цель неизменной, не предоставляя
    никакой полезной информации для завершения доказательства.  *)

Proof.
  intros n E.
  destruct E as [| n' E'].
  - (* E = ev_0. *)
    (* Мы должны доказать что [n] четное без каких либо предположений! *)
Abort.

(** Что же случилось конкретно?  Вызов [destruct] имеет эффект замены
    всех появлений аргумента свойства значениями которые соответствуют
    своему конструктору. Этого недостаточно для случая
    [ev_minus2'] так как аргумент [n], нарямую указан в
    финальной цели. Тем не менее, это не помогает в случае
    [evSS_ev] так как терм который заменяется на ([S (S n)])
    нигде не упомянут. *)

(** Тактика [inversion], с другой стороны, может задетектировать (1)
    что первый случай не применим, и (2) что [n'] который появляется
    в случае [ev_SS] должен быть тем же что и [n]. Это позволяет нам
    завершить доказательство: *)

Theorem evSS_ev : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E.
  inversion E as [| n' E'].
  (* Мы теперь в случае [E = ev_SS n' E'] теперь. *)
  apply E'.
Qed.

(** Используя [inversion], мы можем применить принцип взрыва
    к "очевидно противоречивым" гипотезам включающим индуктивные
    свойства. Например: *)

Theorem one_not_even : ~ ev 1.
Proof.
  intros H. inversion H. Qed.

(** **** Упражнение: 1 звездочка (inversion_practice)  *)
(** Докажите следующие теоремы изпользуя [inversion]. *)

Theorem SSSSev__even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** Способ которым мы использовали [inversion] здесь может казаться
    слегка мистическим поначалу. До сих пор, мы использовали [inversion]
    только на пропозициях равенства, для утилизации инъективности конструкторов
    или дискриминации между конструкторами. Но мы видим здесь что
    [inversion] может быть также применена к анализу свидетельств для
    индуктивно определенных пропозиций.

    Вот как [inversion] работает в целом.  Предположим имя [I]
    относится к предположению [P] в данном контексте, где [P] определена
    с помощью декларации [Inductive].  Тогда, для каждого из конструкторов
    [P], [inversion I] генерирует подцель, в которо [I] будет заменена
    на точные, специальные условия при которых данный конструктор мог бы
    использован для доказательства [P]. Некоторые из этих подцелей
    будут противоречивыми; [inversion] выкидывает такие из рассмотрения.
    Те что остаются представляют случаи которые должны быть доказаны
    для установления оригинальной цели.  Для них, [inversion]
    добавляет все уравнения в контекст доказательства, которые должны
    иметь место для арументов заданных  [P] (т.е., [S (S n') = n]
    в доказательстве [evSS_ev]). *)

(* ================================================================= *)
(** ** Индукция на Свидетельствах *)

(** Упражнение [ev_double] сверху показывает что наше новое понятие
    четности следует из двух предыдущих (так как, из
    [even_bool_prop], мы уже знаем что те эквивалентны друг другу).
    Чтобы показать что все три совпадают, нам нужна только следующая
    лемма: *)

Lemma ev_even : forall n,
  ev n -> exists k, n = double k.
Proof.

(** Мы могли бы использовать разбор случаев или индукцию на [n].
    Но так как [ev] упомянуто в предпосылке, данная стратегия вероятно
    приведет к тупику, как и в предыдущей секции. Таким образом, кажется
    что стоит попробовать инверсию на свидетельстве для [ev].  Действительно,
    первый случая может быть решен тривиально. *)

  intros n E. inversion E as [| n' E'].
  - (* E = ev_0 *)
    exists 0. reflexivity.
  - (* E = ev_SS n' E' *) simpl.

(** К несчастью, второй случай сложнее. Нам надо показать, что [exists
    k, S (S n') = double k], но единственное имеющее предположение это
    [E'], которое утверждает что [ev n'] имеет место. Так как это
    не помогает напрямую, кажется что мы застряли и разбор случаев
    на [E] это потеря времени.

    Если мы посмотрим повнимательнее на нашу вторую цель, тем не менее,
    мы увидем нечто интересное: производим разбор случаев на [E],
    тот что включает _различные_ части свидетельства для: [E'].
    Более формально, мы можем закончить наше доказательство показав

        exists k', n' = double k',

    что тоже самое, что и оригинальное утверждение, но с [n'] вместо
    [n].  Десйтвительно, не трудно убедить Coq что этого
    промежуточного результата достаточно. *)

    assert (I : (exists k', n' = double k') ->
                (exists k, S (S n') = double k)).
    { intros [k' Hk']. rewrite Hk'. exists (S k').
      reflexivity. }
    apply I. (* редуцируем изначальную цель к новой *)

(** Если вам это кажется знакомым, то это не совпадение: Мы уже встречали
    похожие проблемы в главе [Индукция], когда пытались использовать анализ
    слуачев для доказательства результатов требующих индукции. И снова
    решение здесь... индукция!

    Поведение [induction] на свидетельстве такое же как ее поведение
    на данных: Она заставляет Coq генерировать одну подцель для каждого
    конструктора что может быть использован для построения свидетельства,
    в тоже время предоставляя индукционные гипотезы для рекурсивных
    случаев.

    Давайте попробуем снова с нашей текущей леммой: *)

Abort.

Lemma ev_even : forall n,
  ev n -> exists k, n = double k.
Proof.
  intros n E.
  induction E as [|n' E' IH].
  - (* E = ev_0 *)
    exists 0. reflexivity.
  - (* E = ev_SS n' E'
       с IH : exists k', n' = double k' *)
    destruct IH as [k' Hk'].
    rewrite Hk'. exists (S k'). reflexivity.
Qed.

(** Здесь мы видим, что Coq произвел [IH] соответствующее
    [E'], единственному реккурентному случаю [ev] в своем определении.
    Так как [E'] упоминает [n'], индукционная гипотеза говорит о [n'],
    а не о [n] или любом другом числе. *)

(** Эквивалентность между вторым и третьем определениями теперь следует. *)

Theorem ev_even_iff : forall n,
  ev n <-> exists k, n = double k.
Proof.
  intros n. split.
  - (* -> *) apply ev_even.
  - (* <- *) intros [k Hk]. rewrite Hk. apply ev_double.
Qed.

(** Как мы увидем в будущих главах, индукция на свидетельствах
    частая техника при изучении семантики языков програмирования,
    в которых многие интересные свойства определены индуктивно.
    Следующее упражнение предоставлет простые примеры данной
    техники, для практики. *)

(** **** Упражнение: 2 звездочки (ev_sum)  *)
Theorem ev_sum : forall n m, ev n -> ev m -> ev (n + m).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 4 звездочки, продвинутое (ev_alternate)  *)
(** В целомl, могут существовать многочисленные способы определения
    свойства индуктивно. Например, вот (слегка замороченное)
    альтернативное определение для [ev]: *)

Inductive ev' : nat -> Prop :=
| ev'_0 : ev' 0
| ev'_2 : ev' 2
| ev'_sum : forall n m, ev' n -> ev' m -> ev' (n + m).

(** Докажите что оно логически эквивалентно старому. *)

Theorem ev'_ev : forall n, ev' n <-> ev n.
Proof.
 (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 3 звездочки, продвинутое, рекомендованное (ev_ev__ev)  *)
(** Нахождение правильного объекта для индукции слегка
    непреосто здесь: *)

Theorem ev_ev__ev : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 3 звездочки, дополнительное (ev_plus_plus)  *)
(** Данное упражнение просто требует применения существующих лемм.
    Никакой индукции или разбора случаев не требуется, хотя часть
    переписывания будет скучным. *)

Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Индуктивные Отношения *)

(** Пропозиция параметризованная числом (как [ev])
    может быть рассмотрена как _свойство_ -- т.е., она определяет
    подмножество [nat], а именно тех чисел для которых пропозиция
    доказуема. Таким же путем, двух аргументная пропозиция может быть
    рассмотрена как _отношение_ -- т.е., она определяет множество пат
    для которых пропозиция доказуема. *)

Module LeModule.

(** Один полезный пример это отношение "меньше либо равно чем"
    на числах. *)

(** Следующее определение должно быть интуитивно понятно. Оно говорит,
    что есть два способа предоставить свидетельство того, чтп одно
    число меньше либо равно другому: или убедиться что числа одинаковы,
    или предоставить свидетельство того, что первое меньше либо равно
    предшественника второго. *)

Inductive le : nat -> nat -> Prop :=
  | le_n : forall n, le n n
  | le_S : forall n m, (le n m) -> (le n (S m)).

Notation "m <= n" := (le m n).

(** Доказательства фактов о [<=] использующих конструкторы [le_n] и
    [le_S] следуют тем же шаблонам, что и доказательства о
    свойствах, вроде [ev]. Мы можем применить [apply] конструкторы
    для доказательства целей [<=] (т.е., показать [3<=3] или [3<=6]),
    и можем использовать тактики вроде [inversion] для извлечения информации
    [<=] гипотез в контексте (т.е., доказать что [(2 <= 1) ->
    2+2=5].) *)

(** Вот несколько проверок на здравый смысл для нашего определения.
    (Обратите внимание на то что, хотя они являются просто версией
    простый "юнит тестов" наподобие тех что мы использовали для
    тестирования функций в первых лекциях, мы должны строить
    их доказательство явно -- [simpl] и [reflexivity] не делают за нас
    работу, так как доказательства не являются просто материалом
    с упрощающими вычислениями.) *)

Theorem test_le1 :
  3 <= 3.
Proof.
  (* ПРОРАБОТАНО В КЛАССЕ *)
  apply le_n.  Qed.

Theorem test_le2 :
  3 <= 6.
Proof.
  (* ПРОРАБОТАНО В КЛАССЕ *)
  apply le_S. apply le_S. apply le_S. apply le_n.  Qed.

Theorem test_le3 :
  (2 <= 1) -> 2 + 2 = 5.
Proof.
  (* ПРОРАБОТАНО В КЛАССЕ *)
  intros H. inversion H. inversion H2.  Qed.

(** Отношение "строго меньше чем" [n < m] может теперь быть определено
    в терминах [le]. *)

End LeModule.

Definition lt (n m:nat) := le (S n) m.

Notation "m < n" := (lt m n).

(** Вот несколко других простых отношений на числах: *)

Inductive square_of : nat -> nat -> Prop :=
  sq : forall n:nat, square_of n (n * n).

Inductive next_nat : nat -> nat -> Prop :=
  | nn : forall n:nat, next_nat n (S n).

Inductive next_even : nat -> nat -> Prop :=
  | ne_1 : forall n, ev (S n) -> next_even n (S n)
  | ne_2 : forall n, ev (S (S n)) -> next_even n (S (S n)).

(** **** Упражнение: 2 звездочки, рекомендованное (total_relation)  *)
(** Определите индуктивное бинарное отношение [total_relation] которое
    справедливо между любыми парами натуральных чисел. *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 2 звездочки (empty_relation)  *)
(** Определите индуктивное бинарное отношение [empty_relation] (на числах)
    которое никогда не справедливо. *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 3 звездочки, дополнительное (le_exercises)  *)
(** Вот набор фактов об отношениях [<=] и [<] которые нам понадобятся
    в дальнейшем в этом курсе. Доказательства послужат хорошими
    упражнениями для практики. *)

Lemma le_trans : forall m n o, m <= n -> n <= o -> m <= o.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
 unfold lt.
 (* ЗАПОЛНИТЕ ЗДЕСЬ *)
Admitted.

Theorem lt_S : forall n m,
  n < m ->
  n < S m.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem leb_complete : forall n m,
  leb n m = true -> n <= m.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

(** Подсказка: Следующее проще всего будет доказать индукцией по [m]. *)

Theorem leb_correct : forall n m,
  n <= m ->
  leb n m = true.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

(** Подсказка: Данная теорема может быть легко доказана без использования [induction]. *)

Theorem leb_true_trans : forall n m o,
  leb n m = true -> leb m o = true -> leb n o = true.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

(** **** Упражнение: 2 звездочки, дополнительное (leb_iff)  *)
Theorem leb_iff : forall n m,
  leb n m = true <-> n <= m.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

Module R.

(** **** Упражнение: 3 звездочки, рекомендованное (R_provability2)  *)
(** Мы можем определить отношения с тремя аргументами, с четырьмя и т.д.,
    точно также как мы это сделали для бинарных отношений. Например,
    рассмотрим следующуее трех аргументное отношение на числах: *)

Inductive R : nat -> nat -> nat -> Prop :=
   | c1 : R 0 0 0
   | c2 : forall m n o, R m n o -> R (S m) n (S o)
   | c3 : forall m n o, R m n o -> R m (S n) (S o)
   | c4 : forall m n o, R (S m) (S n) (S (S o)) -> R m n o
   | c5 : forall m n o, R m n o -> R n m o.

(** - Каке из следующих пропозиций доказуемы?
      - [R 1 1 2]
      - [R 2 2 6]

    - Если мы опустим конструктор [c5] из определения [R],
      изменится ли множество доказуемых пропозиций? Коротко (1
      предложение) объясните ответ.

    - Если мы отбросим конструктор [c4] из определения [R],
      изменится ли множество доказуемых пропозиций? Коротко (1
      предложение) объясните ответ.

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
[]
*)

(** **** Упражнение: 3 звездочки, дополнительное (R_fact)  *)
(** Отношение [R] сверху на самом деле кодирует знакомую функцию.
    Выясните что это за функциял затем сформулируйте и докажите
    эквивалентность в Coq? *)

Definition fR : nat -> nat -> nat
  (* ЗАМЕНИТЕ ЭТУ СТРОКУ ЭТИМ   := _ваше определение_ . *) . Admitted.

Theorem R_equiv_fR : forall m n o, R m n o <-> fR m n = o.
Proof.
(* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

End R.

(** **** Упражнение: 4 звездочки, продвинутое (subsequence)  *)
(** Список есть _подпоследовательность_ другого списка если все
    элементы из первого появляются в том же порядке во втором,
    возможно с некоторыми дополнительными элементами между.
    Например,

      [1;2;3]

    есть подпоследовательность каждого из следующих списков

      [1;2;3]
      [1;1;1;2;2;3]
      [1;2;7;3]
      [5;6;1;9;9;2;7;3;8]

    но _не_ является подпоследовательностью ни одного из этих списков

      [1;2]
      [1;3]
      [5;6;2;1;7;3;8].

    - Определите индуктивную пропозицию [subseq] на [list nat] так
      чтобы она отражала то что мы понимаем под подпоследовательностью.
      (Подсказка: Вам понадобятся три случая.)

    - Докажите [subseq_refl] о том что подпоследовательность рефлексивна, т.е.,
      любой список есть подпоследовательность для себя.

    - Докажите [subseq_app] для любых списков [l1], [l2], и [l3],
      если [l1] есть подпоследовательность [l2], тогда [l1] также подпоследовательность
      для [l2 ++ l3].

    - (Дополнительно, сложнее) Докажите [subseq_trans] о том что подпоследовательность
      транзитивна -- т.е., если [l1] есть подпоследовательность для [l2] и [l2]
      подпоследовательность для [l3], то [l1] подпоследовательность для [l3].
      Подсказка: выберайте свою индукцию осторожно! *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 2 звездочки, дополнительное (R_provability)  *)
(** Предположим мы зададим Coq следующее определение:

    Inductive R : nat -> list nat -> Prop :=
      | c1 : R 0 []
      | c2 : forall n l, R n l -> R (S n) (n :: l)
      | c3 : forall n l, R (S n) l -> R n l.

    Какая из следующих пропозиций доказуема?

    - [R 2 [1;0]]
    - [R 1 [1;2;1;0]]
    - [R 6 [3;2;1;0]]  *)

(** [] *)

(* ################################################################# *)
(** * Пример: Регулярные Выражения *)

(** Свойство [ev] предоставляет простой пример иллюстрирующий индуктивные
    определения и базовые техники для рассуждения о них, но он не
    сильно вдохновляющий -- в конце концов, он эквивалентен
    двум неиндуктивным примерам четности которые мы уже видели
    и будто не предоставляет какое либо конкретное преимущество
    по сравнениями с предыдущими определениями.Чтобы лучше представить
    мощь индуктивных определений, мы теперь покажем как использовать
    их для моделирования классической концепции в компьютерной
    науке: _регулярных выражений_.

    Регулярные выражения представляют из себя простой язык для описания
    строк, определнных как элементы следующего индуктивного типа.  (Имена
    конструкторов станут понятнее как только мы объясним их смысл внизу.)  *)

Inductive reg_exp (T : Type) : Type :=
| EmptySet : reg_exp T
| EmptyStr : reg_exp T
| Char : T -> reg_exp T
| App : reg_exp T -> reg_exp T -> reg_exp T
| Union : reg_exp T -> reg_exp T -> reg_exp T
| Star : reg_exp T -> reg_exp T.

Arguments EmptySet {T}.
Arguments EmptyStr {T}.
Arguments Char {T} _.
Arguments App {T} _ _.
Arguments Union {T} _ _.
Arguments Star {T} _.

(** Обратите внимание на то что это определение _полиморфно_:
    Регулярные выражения в [reg_exp T] описывают строки с символами
    взятыми и [T] -- т.е., списки элементов [T].  (Мы отходим слегка
    от стандартной практики в том, что мы не требуем от типа [T] быть
    конечным. Это приводит слегка другой теории регулярных выражений,
    но разница не важна для наших целей.)

    Мы связываем регулярные выражения и строки через следующие правила,
    которые определяют когда регулярное выражение _соответствует_
    некоторой строке:

    - Выражение [EmptySet] не соответствует никакой строке.

    - Выражение [EmptyStr] соотвествует пустой строке [[]].

    - Выражение [Char x] соответствует односимвольной строке [[x]].

    - Если [re1] соответствует [s1], и [re2] соответствует [s2], тогда [App re1
      re2] соответствует [s1 ++ s2].

    - Если хотя бы один из [re1] и  [re2] соответствует [s], тогда [Union re1
      re2] соответствует [s].

    - Наконец, если мы можем записать какую либо строку как
      конкатенацию последовательности строк [s = s_1 ++ ... ++ s_k],
      и выражение [re] соответствует каждой из строк [s_i], тогда
      [Star re] соответствует [s].  (Как специальный случай, последовательность
      строк может быть пустой, так что [Star re] всегда соответствует
      пустой строке [[]] не важно какой [re].) *)

(** Мы можем перевести данное неформальное определение в
    [Inductive] следующим образом: *)

Inductive exp_match {T} : list T -> reg_exp T -> Prop :=
| MEmpty : exp_match [] EmptyStr
| MChar : forall x, exp_match [x] (Char x)
| MApp : forall s1 re1 s2 re2,
           exp_match s1 re1 ->
           exp_match s2 re2 ->
           exp_match (s1 ++ s2) (App re1 re2)
| MUnionL : forall s1 re1 re2,
              exp_match s1 re1 ->
              exp_match s1 (Union re1 re2)
| MUnionR : forall re1 s2 re2,
              exp_match s2 re2 ->
              exp_match s2 (Union re1 re2)
| MStar0 : forall re, exp_match [] (Star re)
| MStarApp : forall s1 s2 re,
               exp_match s1 re ->
               exp_match s2 (Star re) ->
               exp_match (s1 ++ s2) (Star re).

(** И снова, для читаемости, мы также покажем данное определение используя
    нотацию правил вывода. В тоже время, давайте введем более читаемую
    инфикс нотацию. *)

Notation "s =~ re" := (exp_match s re) (at level 80).

(**

                          ----------------                    (MEmpty)
                           [] =~ EmptyStr

                          ---------------                      (MChar)
                           [x] =~ Char x

                       s1 =~ re1    s2 =~ re2
                      -------------------------                 (MApp)
                       s1 ++ s2 =~ App re1 re2

                              s1 =~ re1
                        ---------------------                (MUnionL)
                         s1 =~ Union re1 re2

                              s2 =~ re2
                        ---------------------                (MUnionR)
                         s2 =~ Union re1 re2

                          ---------------                     (MStar0)
                           [] =~ Star re

                      s1 =~ re    s2 =~ Star re
                     ---------------------------            (MStarApp)
                        s1 ++ s2 =~ Star re
*)

(** Заметьте что эти правила не _совсем_ теже что и в неформальном
    определении, что мы предоставили в начале секции. Во превых,
    нам нет нужны явно включать правило утверждающее, что ни одна
    строка не соответствует [EmptySet]; мы просто не добавляем правила
    эффектом которого было бы соответствие какой либо строки
    [EmptySet].  (Действительно, синтаксис индуктивных определений
    не позволяет даже _позволить_ нам такого "отрицательного правила.")

    Более того, неформальные правила для [Union] и [Star] выражены
    двумя конструкторами каждое: [MUnionL] / [MUnionR], и [MStar0] /
    [MStarApp].  Результат логически эквивалентен оригинальным
    правилам, но более удобен для использования в Coq, так как
    рекурсивные случаи [exp_match] заданы как прямые аргументы конструкторам,
    делая легче индукцию на свидетельствах.
    (Упражнения [exp_match_ex1] и [exp_match_ex2] внизу просят доказать
    что конструкторы данные в индуктивном определении и те которые
    бы появились при прямой трансляции неформальных правил действительно
    эквивалентны.) *)

(** Давайте проиллюстрируем эти правила на нескольких примерах. *)

Example reg_exp_ex1 : [1] =~ Char 1.
Proof.
  apply MChar.
Qed.

Example reg_exp_ex2 : [1; 2] =~ App (Char 1) (Char 2).
Proof.
  apply (MApp [1] _ [2]).
  - apply MChar.
  - apply MChar.
Qed.

(** (Заметьте как последний пример применяет [MApp] к строкам [[1]]
    и [[2]] напрямую. Так как цель упоминает [[1; 2]] вместо
    [[1] ++ [2]], Coq не смог бы определить сам как разбить строку
    сам по себе.)

    Используя [inversion], мы можем также показать что определенные строки
    _не_ соответствуют регулярным выражениям: *)

Example reg_exp_ex3 : ~ ([1; 2] =~ Char 1).
Proof.
  intros H. inversion H.
Qed.

(** Мы можем записать вспомогательные функции для записи регулярных
    выражений. Функция [reg_exp_of_list] конструирует регулярное выражение
    которое точно соответствует списку которое она принимает в качестве
    аргумента: *)

Fixpoint reg_exp_of_list {T} (l : list T) :=
  match l with
  | [] => EmptyStr
  | x :: l' => App (Char x) (reg_exp_of_list l')
  end.

Example reg_exp_ex4 : [1; 2; 3] =~ reg_exp_of_list [1; 2; 3].
Proof.
  simpl. apply (MApp [1]).
  { apply MChar. }
  apply (MApp [2]).
  { apply MChar. }
  apply (MApp [3]).
  { apply MChar. }
  apply MEmpty.
Qed.

(** Мы также можем доказать общие факты о [exp_match]. Например,
    следующая лемма показывает что каждая строка [s] которая
    соответствуер [re] также соответствует [Star re]. *)

Lemma MStar1 :
  forall T s (re : reg_exp T) ,
    s =~ re ->
    s =~ Star re.
Proof.
  intros T s re H.
  rewrite <- (app_nil_r _ s).
  apply (MStarApp s [] re).
  - apply H.
  - apply MStar0.
Qed.

(** (Заметьте использование [app_nil_r] для смены цели теоремы на
    точно ту форму, что ожидает [MStarApp].) *)

(** **** Упражнение: 3 звездочки (exp_match_ex1)  *)
(** Следующие леммы показывают что неформальные правила соответствия
    данные вначале главы могут быть получены из формального
    индуктивного определения. *)

Lemma empty_is_empty : forall T (s : list T),
  ~ (s =~ EmptySet).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Lemma MUnion' : forall T (s : list T) (re1 re2 : reg_exp T),
  s =~ re1 \/ s =~ re2 ->
  s =~ Union re1 re2.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

(** Следующая лемма сформулирована в терминах функции [fold] из главы
    [Poly]: Если [ss : list (list T)] представлает последовательность строк
    [s1, ..., sn], тогда [fold app ss []] результат их конкатенации. *)

Lemma MStar' : forall T (ss : list (list T)) (re : reg_exp T),
  (forall s, In s ss -> s =~ re) ->
  fold app ss [] =~ Star re.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

(** [] *)

(** **** Упражнение: 4 звездочки (reg_exp_of_list)  *)
(** Докажите что [reg_exp_of_list] удовлетворяет
    следующей спецификации: *)

Lemma reg_exp_of_list_spec : forall T (s1 s2 : list T),
  s1 =~ reg_exp_of_list s2 <-> s1 = s2.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** Так как определение [exp_match] имеет реккурсивную структуру,
    мы можем ожидать что доказательства включающие
    регулярные выражения будут часто требовать индукцию на
    свидетельствах. Например, предположим мы захотели доказать
    следующий интуитивный результат: Если регулярное выражение [re]
    соответствуер некоторой строке [s], то все элементы [s] должны
    появится где то в [re]. Чтобы сформулировать данную теорему
    мы вначале определим функцию [re_chars] которая перечисляет
    все символы, что появляются в регулярном выражении: *)

Fixpoint re_chars {T} (re : reg_exp T) : list T :=
  match re with
  | EmptySet => []
  | EmptyStr => []
  | Char x => [x]
  | App re1 re2 => re_chars re1 ++ re_chars re2
  | Union re1 re2 => re_chars re1 ++ re_chars re2
  | Star re => re_chars re
  end.

(** Мы можем выразить нашу теорему следующим образом: *)

Theorem in_re_match : forall T (s : list T) (re : reg_exp T) (x : T),
  s =~ re ->
  In x s ->
  In x (re_chars re).
Proof.
  intros T s re x Hmatch Hin.
  induction Hmatch
    as [
        |x'
        |s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        |s1 re1 re2 Hmatch IH|re1 s2 re2 Hmatch IH
        |re|s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
  (* ПРОРАБОТАНО В КЛАССЕ *)
  - (* MEmpty *)
    apply Hin.
  - (* MChar *)
    apply Hin.
  - simpl. rewrite in_app_iff in *.
    destruct Hin as [Hin | Hin].
    + (* In x s1 *)
      left. apply (IH1 Hin).
    + (* In x s2 *)
      right. apply (IH2 Hin).
  - (* MUnionL *)
    simpl. rewrite in_app_iff.
    left. apply (IH Hin).
  - (* MUnionR *)
    simpl. rewrite in_app_iff.
    right. apply (IH Hin).
  - (* MStar0 *)
    destruct Hin.

(** Нечто интересное происходит в случае [MStarApp].  Мы получаем
    _две_ индуктивные гипотезы: Одна которая применяется если [x]
    появляется в [s1] (соответствующее [re]), и вторая применяемая когда [x]
    появляется в [s2] (соответствующее [Star re]). Это хорошее иллюстрация
    того, почему нам нужна индукция на свидетельстве для [exp_match],
    вместо [re]: последнее предоставит лишь индукционную гипотезу
    для строк, которые соответствуют [re], что не позволит нам рассуждать
    о случае [In x s2]. *)

  - (* MStarApp *)
    simpl. rewrite in_app_iff in Hin.
    destruct Hin as [Hin | Hin].
    + (* In x s1 *)
      apply (IH1 Hin).
    + (* In x s2 *)
      apply (IH2 Hin).
Qed.

(** **** Упражнение: 4 звездочки (re_not_empty)  *)
(** Запишите реккурсивную функцию [re_not_empty] которая тестирует
    соответствует ли регулярному выражению какая либо строка.
    Докажите что ваша функция корректна. *)

Fixpoint re_not_empty {T} (re : reg_exp T) : bool
  (* ЗАМЕНИТЕ ДАННУЮ СТРОКУ НА   := _ваше определение_ . *) . Admitted.

Lemma re_not_empty_correct : forall T (re : reg_exp T),
  (exists s, s =~ re) <-> re_not_empty re = true.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Тактика [remember] (помнить) *)

(** Одно потенциально путающее свойство тактики [induction] состоит
    в том, что она радостно позволяет вам попробовать индукцию над
    термом, который не является достаточно общим. Суммарный эффект
    будет в потере информации (также как и в случае [destruct]),
    и состоянии в котором вы будете не способны завершить
    доказательство. Вот пример: *)

Lemma star_app: forall T (s1 s2 : list T) (re : reg_exp T),
  s1 =~ Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.
Proof.
  intros T s1 s2 re H1.

(** Просто делая [inversion] на [H1] не заведет нас далеко в реккурсивных
    случаях. (Попробуйте это!). Нам нужна индукция. Вот наивная первая
    попытка: *)

  induction H1
    as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2
        |s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH
        |re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2].

(** Но теперь, несмотря на то что мы получили семь случаев (как мы и ожидали
    из определение [exp_match]), мы потеряли важный кусок информации из
    [H1]: факт того что [s1] соответствует чему то из [Star re]. Это
    означает что мы должны предоставить доказательства для _всех_
    семи конструкторов определения, несмотря на то что все, кроме
    двух из них ([MStar0] и [MStarApp]), противоречивы. Мы всеравно можем
    получить доказательство для нескольких конструкторов, как
    [MEmpty]... *)

  - (* MEmpty *)
    simpl. intros H. apply H.

(** ... но большинство из них застревает.  Для [MChar], например,
   мы должны показать что

    s2 =~ Char x' -> x' :: s2 =~ Char x',

    что безусловно невозможно. *)

  - (* MChar. Застряли... *)

Abort.

(** Проблема в том, что [induction] над гипотезой Prop работает
    хорошо только с гипотезами которые полностью общие, т.е., те
    в которых все аргументы являются переменными, в отличие от
    более общих выражений, таких как [Star re]. В этом случае она
    работает более как [destruct] чем [inversion].

    Мы можем решить данную проблему обобщая над проблемными
    выражениями с явным равнеством: *)

Lemma star_app: forall T (s1 s2 : list T) (re re' : reg_exp T),
  s1 =~ re' ->
  re' = Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.

(** Мы теперь можем работать с помощью индукции над свидетельством напрямую,
    так как аргумент первой гипотезы достаточно общий, что означает
    мы можем разобраться с большинством случаев инвертируя равенство
    [re' = Star re] в контексте.

    Данная идиома настолько обычна, что Coq предоставляет тактику
    для автоматической генеразии таких уравнений для нас, избегая
    необходимости изменения утверждений наших теорем. Вызывая
    [remember e as x] заставляет Coq (1) заменить все случаи выражения
    [e] на переменную [x], и (2) добавить равенство [x =
    e] в контекст. Вот как мы можем использовать ее для того чтобы
    показать предыдущий результат: *)

Abort.

Lemma star_app: forall T (s1 s2 : list T) (re : reg_exp T),
  s1 =~ Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.
Proof.
  intros T s1 s2 re H1.
  remember (Star re) as re'.

(** У нас теперь есть [Heqre' : re' = Star re]. *)

  generalize dependent s2.
  induction H1
    as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2
        |s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH
        |re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2].

(** [Heqre'] противоречива в большинстве случаев, что позволяет
    завершить их сразу. *)

  - (* MEmpty *)  inversion Heqre'.
  - (* MChar *)   inversion Heqre'.
  - (* MApp *)    inversion Heqre'.
  - (* MUnionL *) inversion Heqre'.
  - (* MUnionR *) inversion Heqre'.

(** В интересных случаях (те что соответствуют [Star]), мы можем
    идти как раньше. Заметьте что индукционная гипотеза [IH2] на случай
    [MStarApp] упоминает дополнительную предпосылку [Star re'' = Star
    re'], что является результатом равенства сгенерированного [remember]. *)

  - (* MStar0 *)
    inversion Heqre'. intros s H. apply H.
  - (* MStarApp *)
    inversion Heqre'. rewrite H0 in IH2, Hmatch1.
    intros s2 H1. rewrite <- app_assoc.
    apply MStarApp.
    + apply Hmatch1.
    + apply IH2.
      * reflexivity.
      * apply H1.
Qed.

(** **** Упражнение: 4 звездочки (exp_match_ex2)  *)

(** Лемма [MStar''] снизу (объединенная со своей обратной, упражнение
    [MStar'] сверху), показывает, что наше определение [exp_match]
    для [Star] эквивалентно неформальному которое мы предоставили раньше. *)

Lemma MStar'' : forall T (s : list T) (re : reg_exp T),
  s =~ Star re ->
  exists ss : list (list T),
    s = fold app ss []
    /\ forall s', In s' ss -> s' =~ re.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 5 звездочек, продвинутое (накачка)  *)
(** Одна из первых интересных теорем в теории регулярных
    выражений это так называемая _лемма о накачке_, которая
    утверждает, неформально, что любая достаточно длинная строка [s]
    соответствующая регулярному выраженип [re] может быть "накачана"
    повторением некоторой серединной секции [s] произольное число раз
    для получения новой строки также соответствующей [re].

    Для начала, мы должны определить "достаточно длинное." Так как
    мы работаем в конструктивной логике, мы на самом деле должны иметь
    возможность вычислить для любого регулярного выражения [re] минимальную
    длину строк [s] для которой гарантируется "накачка." *)

Module Pumping.

Fixpoint pumping_constant {T} (re : reg_exp T) : nat :=
  match re with
  | EmptySet => 0
  | EmptyStr => 1
  | Char _ => 2
  | App re1 re2 =>
      pumping_constant re1 + pumping_constant re2
  | Union re1 re2 =>
      pumping_constant re1 + pumping_constant re2
  | Star _ => 1
  end.

(** Далее, полезно определить вспомогательную функцию которая повторяет строку
   (присоединяет ее к самомй себе) некоторое число раз. *)

Fixpoint napp {T} (n : nat) (l : list T) : list T :=
  match n with
  | 0 => []
  | S n' => l ++ napp n' l
  end.

Lemma napp_plus: forall T (n m : nat) (l : list T),
  napp (n + m) l = napp n l ++ napp m l.
Proof.
  intros T n m l.
  induction n as [|n IHn].
  - reflexivity.
  - simpl. rewrite IHn, app_assoc. reflexivity.
Qed.

(** Теперь, лемма о накачке сама по себе утверждает что, если [s =~ re]
    и если длина [s] хотябы равна константе накачки [re], тогда [s]
    может быть разбита на три подстроки [s1 ++ s2 ++ s3] таким образом
    что [s2] может быть повторенно любое число раз и результат, когда
    объединен с [s1] и [s3] все еще будет соответствовать [re]. Так как [s2]
    гарантирована не быть пустой строкой, это предоставляет на
    (конструктивный!) способ сгенерировать строки соответствующие [re]
    и при этом настолько длинные насколько мы захотим. *)

Lemma pumping : forall T (re : reg_exp T) s,
  s =~ re ->
  pumping_constant re <= length s ->
  exists s1 s2 s3,
    s = s1 ++ s2 ++ s3 /\
    s2 <> [] /\
    forall m, s1 ++ napp m s2 ++ s3 =~ re.

(** Чтобы ускорить доказательство (которое вы должны заполнить), тактика [omega],
    которая вступает в силу со следующим [Require], очень полезна в нескольких
    местах для автоматического завершения длинных низкоуровневых аргументов,
    включающих равенства или неравеснтва на натуральных числах. Мы возвратимся
    к [omega] в следующих главах, но чувствуйте себя свободно в жкспериментированийй
    с ней и сейчас. Первый случай индукции демонстрируер как она используется. *)

Require Import Coq.omega.Omega.

Proof.
  intros T re s Hmatch.
  induction Hmatch
    as [ | x | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
       | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
       | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2 ].
  - (* MEmpty *)
    simpl. omega.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

End Pumping.
(** [] *)

(* ################################################################# *)
(** * Улучшаем Рефлексию *)

(** Мы уже видели в главе [Logic] что нам часто нужно связывать
    булевы вычисления с утверждениями в [Prop]. К несчастью,
    произведение такой конвертации руками часто приводит к
    усложненным скриптам доказательств. Рассмотрим доказательство
    следующей теоремы: *)

Theorem filter_not_empty_In : forall n l,
  filter (beq_nat n) l <> [] ->
  In n l.
Proof.
  intros n l. induction l as [|m l' IHl'].
  - (* l = [] *)
    simpl. intros H. apply H. reflexivity.
  - (* l = m :: l' *)
    simpl. destruct (beq_nat n m) eqn:H.
    + (* beq_nat n m = true *)
      intros _. rewrite beq_nat_true_iff in H. rewrite H.
      left. reflexivity.
    + (* beq_nat n m = false *)
      intros H'. right. apply IHl'. apply H'.
Qed.

(** В первой ветке после [destruct], мы напрямую применяем
    лемму [beq_nat_true_iff] к уравнениям сгенерированным
    разбором [beq_nat n m], для того чтобы сконвертировать предположение [beq_nat n m
    = true] в предположение [n = m], которое нам и нужно для завершения
    цели.

    Мы можем упростить данное доказательство определением индуктивной
    пропозиции которая производит более лучший принцип разбора случаев
    для [beq_nat n m]. Вместо генерации уравнения вроде [beq_nat n m =
    true], которое напрямую бесполезно, этот принцио дает нам
    сразу предположение нужное нам: [n = m]. Мы на самом деле
    определим нечто более обшее, что можно будет использовать с
    любыми свойствами (и не только равенствами): *)

Inductive reflect (P : Prop) : bool -> Prop :=
| ReflectT : P -> reflect P true
| ReflectF : ~ P -> reflect P false.

(** Свойство [reflect] принимает два аргумента: пропозицию
    [P] и булево значение [b].  Интуитивно, оно утверждает что свойство
    [P] _отражено_ в (т.е., эквивалентно) булеву [b]: [P]
    справедливо тогда и только тогда когда [b = true].  Чтобы увидеть это,
    заметьте что, по определению, единственный способ которым мы можем
    предоставить свидетельство того что [reflect P true] имеет место, это
    показать что [P] справедливо и использовать конструктор
    [ReflectT].  Если мы инвертируем данное утверждений, то это значит,
    что должно быть возможно выделить свидетельство для [P] из
    доказательства [reflect P true]. Обратно, единственный способ
    показать [reflect P false] это объединить свидетельство для [~ P]
    с конструктором [ReflectF].

    Легко формализовать данную интуицию и показать, что два
    утверждения действительно эквивалентны: *)

Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof.
  intros P [] H.
  - apply ReflectT. rewrite H. reflexivity.
  - apply ReflectF. rewrite H. intros H'. inversion H'.
Qed.

(** **** Упражнение: 2 звездочки, рекомендаванное (reflect_iff)  *)
Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** Преимущество [reflect] над нормальным связкой "тогда и только тогда"
    состоит в том, что разбивая гипотезы или леммы в форме
    [reflect P b], мы можем делать разбор случаев на [b] в тоже
    время генерируя соответствующие гипотезы в двух ветках
    ([P] в первой подцели и [~ P] во второй).

    Для использования [reflect] чтобы сгенерировать более лучшее
    доказательство [filter_not_empty_In], мы начнем с перевода леммы
    [beq_nat_iff_true] в более удобную форму в терминах
    [reflect]: *)

Lemma beq_natP : forall n m, reflect (n = m) (beq_nat n m).
Proof.
  intros n m.
  apply iff_reflect. rewrite beq_nat_true_iff. reflexivity.
Qed.

(** Новое доказательство [filter_not_empty_In] теперь происходит
    следующим образом. Заметьте как мы вызываем [destruct] и [apply]
    объединенные в один вызов к [destruct].  (Чтобы увидеть это яснее,
    посмотрите на два доказательства [filter_not_empty_In] в вашем окне Coq
    и рассмотрите различия в состоянии доказательства вначале первого
    случая [destruct].) *)

Theorem filter_not_empty_In' : forall n l,
  filter (beq_nat n) l <> [] ->
  In n l.
Proof.
  intros n l. induction l as [|m l' IHl'].
  - (* l = [] *)
    simpl. intros H. apply H. reflexivity.
  - (* l = m :: l' *)
    simpl. destruct (beq_natP n m) as [H | H].
    + (* n = m *)
      intros _. rewrite H. left. reflexivity.
    + (* n <> m *)
      intros H'. right. apply IHl'. apply H'.
Qed.

(** Несмотря на то что данная техника возможно дает нам лишь небольшое
    преимущество в удобстве для данного конкретного доказательства,
    используя [reflect] последовательно часто приводит к более коротким
    и ясным доказательствам. Мы увидем гораздо больше примеров, где
    [reflect] становится удобным в дальнейших главах.

    Использование свойства [reflect] было популяризовано Coq библиотекой
    _SSReflect_, которая была использована для формализазии важных результатов
    в математике, включая теорему о четырех красок и теорему Фейт Томпсона.
    Имя SSReflect также означает _small-scale reflection_ (рефлексия малого
    маштаба), т.е., всепроникающее использование рефлексии для упрощения
    малых доказательств используя булевы вычисления. *)

(* ################################################################# *)
(** * Дополнительные Упражнения *)

(** **** Упражнения: 4 звездочки, рекомендовано (палиндромы)  *)
(** Палиндроме есть последовательность которая читается также задом
    наперед как и в обычную сторону.

    - Определите индуктивную пропозицию [pal] на [list X] которая
      описывает что означает быть палиндромом. (Подсказка: Вам понадобится
      три случая. Ваше определение должно базироваться на структуре
      списка; просто иметь один конструктор

        c : forall l, l = rev l -> pal l

      может показаться очевидным, но не будет работать хорошо.)

    - Докажите ([pal_app_rev]) о том что

       forall l, pal (l ++ rev l).

    - Докажите ([pal_rev] that)

       forall l, pal l -> l = rev l.
*)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 5 звездочек, дополнительное (palindrome_converse)  *)
(** Опять, обратное направление значительно более трудное, из за отсутствия
    свидетельства. Используя ваше определение [pal] из предыдущего
    упражнения, докажите что

     forall l, l = rev l -> pal l.
*)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 4 звездочки, продвинутое (filter_challenge)  *)
(** Давайте докажем, что наше определение [filter] из главы [Poly]
    соответствует абстрактной спецификации. Вот спецификация,
    записанная неформально:

    Список [l] является "объединенным с сохранением порядка" [l1] и [l2] если он
    содержит все теже элементы что [l1] и [l2], в том же порядке что [l1]
    и [l2], но возможно чередующиеся. Например,

    [1;4;6;2;3]

    есть объединенные с сохранением порядка для

    [1;6;2]

    и

    [4;3].

    Теперь, предположим, что у нас есть множество [X], функция [test: X->bool],
    и список [l] типа [list X].  Предположим далее, что [l] есть
    объединение с сохранением порядка двух списков, [l1] и [l2], таких что
    для любого терма в [l1] удовлетворяющего [test] и ни один элемент из [l2]
    не удовлетворяет тесту, Тогда
    [filter test l = l1].

    Переведите данную спецификацию в теорему Coq и докажите ее.
    (Вам надо будет начать определять что означает для одного списка
    быть объединением двух других. Сделайте это с помощью индуктивного
    отношения, а не [Fixpoint].)  *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 5 звездочек, продвинутое, дополнительное (filter_challenge_2)  *)
(** Другой способ охарактеризовать поведение [filter] работает следующим
    образом: Среди все подпоследовательностей [l] со свойством того что [test]
    вычисляется в  [true] на всех ее членах, [filter test l] наиболее длинна.
    Формализуйте данное заявление и докажите его. *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 4 звездочки, дополнительное (NoDup)  *)
(** Вспомните определение свойства [In] из главы [Logic],
    которое утверждает что значение [x] появляется хотя бы раз
    в списке [l]: *)

(* Fixpoint In (A : Type) (x : A) (l : list A) : Prop :=
   match l with
   | [] => False
   | x' :: l' => x' = x \/ In A x l'
   end *)

(** Ваша первая задача заключается в использовании [In] для определения
    пропозиции [disjoint X l1 l2], которая должна быть доказуема точно тогда,
    когда [l1] и [l2] списки (с элементами типа X) которые не имеют
    общих элементов. *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)

(** Далее, используйте [In] для определения индуктивного определения
    [NoDup X l], которая должна быть доказуема точно тогда когда [l]
    список (с элементами типа [X]) где каждый член не отличается от
    любого другого. Например, [NoDup nat [1;2;3;4]] и [NoDup
    bool []] должны быть доказуемы, в то время как [NoDup nat [1;2;1]] и
    [NoDup bool [true;true]] нет.  *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)

(** Наконец, сформулируйте и докажите одну или более интересных теорем связанных с
    [disjoint], [NoDup] и [++] (конкатенация списков).  *)

(* ЗАПОЛНИТЕ ЗДЕСЬ *)
(** [] *)

(** **** Упражнение: 3 звездочки, рекомендованное (nostutter)  *)
(** Умение формулировать индуктивные определение свойств это важный
    навык который будет нужен в данном курсе. Попробуйте решить
    данное упражнение без какой либо помощи.

    Мы говорим что We say that a list "заикается" если он повторяет
    один и тот же элемент последовательно. Свойство "[nostutter mylist]"
    означает, что [mylist] не заикается. Сформулируйте индуктивное
    определение для [nostutter].  (Это свойство отличо от [NoDup]
    из предыдущего упражнения; последовательность [1;4;1]
    повторяется, но не заикается.) *)

Inductive nostutter {X:Type} : list X -> Prop :=
 (* ЗАПОЛНИТЕ ЗДЕСЬ *)
.
(** Убедитесь, что следующие тесты проходят, но можете менять
    предложенное доказательство (в комментарияз) если предоставленное не
    работает для вас. Ваше определение может быть отличным от нашего
    и всеравно правильным. В этом случае примеры потребуют другого
    доказательства.  (Вы заметите, что предложеные доказательства
    используют некоторые тактики о которых мы еще не говорили. Это
    сделано для того чтобы доказательства были более устойчивы
    по отношению к разным способам определения [nostutter]. Вы можете
    вероятно расскоментировать их и использовать как есть, но также
    вы можете доказать каждый пример с использованием лишь
    более базовых тактик.)  *)

Example test_nostutter_1: nostutter [3;1;4;1;5;6].
(* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false_iff; auto.
  Qed.
*)

Example test_nostutter_2:  nostutter (@nil nat).
(* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false_iff; auto.
  Qed.
*)

Example test_nostutter_3:  nostutter [5].
(* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.
*)

Example test_nostutter_4:      not (nostutter [3;1;1;4]).
(* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(*
  Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction H1; auto. Qed.
*)
(** [] *)

(** **** Упражнение: 4 звездочки, продвинутое (принцип Дирихле)  *)
(**_Принцип Дирихле_ утверждает базовый факт о счете: если мы распределим более
   чем [n] элементов в [n] ячеек, то некоторые из ячеек будут
   содержать хотябы два элемента. Как часто бывает, этот очевидно
   тривиальный факт о числах требует нетривиальной машинерии
   для своего доказательства, но теперь у нас ее достаточно... *)

(** Во первых докажите легкую полезную лемму. *)

Lemma in_split : forall (X:Type) (x:X) (l:list X),
  In x l ->
  exists l1 l2, l = l1 ++ x :: l2.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

(** Теперь определите свойство [repeats] такое что [repeats X l] утверждает
    что [l] содержит хотя бы один повторяющийся элемент (of type [X]).  *)

Inductive repeats {X:Type} : list X -> Prop :=
  (* ЗАПОЛНИТЕ ЗДЕСЬ *)
.

(** Теперь, вот способ формализовать принцип Дирихле. Предположим
    список [l2] представляет из себя список идентификаторов ячеек, и
    список [l1] представляет идентификаторы присвоенные списку
    элементов. Если у нас больше элементов чем идентификаторов,
    то хотя бы двое элементов должны уметь тот же идентификатор
    -- т.е., список [l1] содержит повторения.

    Это доказательство гораздо легче, если вы используете принцип
    исключенного третьего [excluded_middle] для доказательства того
    что [In] разрешима, т.е., [forall x l, (In x
    l) \/ ~ (In x l)].  Тем не меннее, также возможно доказать
    _не_ предполагая что [In] разрешимо; если вы сможете сделать
    это, вам не понадобится гипотеза [excluded_middle]. *)

Theorem pigeonhole_principle: forall (X:Type) (l1  l2:list X),
   excluded_middle ->
   (forall x, In x l1 -> In x l2) ->
   length l2 < length l1 ->
   repeats l1.
Proof.
   intros X l1. induction l1 as [|x l1' IHl1'].
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** $Date: 2015-08-11 12:03:04 -0400 (Tue, 11 Aug 2015) $ *)


(*|
#########################
Prove properties of lists
#########################

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

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

My aim is to prove that certain properties of generated lists hold.
For instance, a generator function produces a list of ``1``\ s, the
length of the list is given as an argument; I'd like to prove that the
length of the list is what the argument specifies. This is what I have
so far:
|*)

Require Import List.

Fixpoint list_gen lng acc :=
  match lng with
  | 0 => acc
  | S lng_1 => list_gen lng_1 (1 :: acc)
  end.

Lemma lm0 : length (list_gen 0 nil) = 0.
  intuition.
Qed.

Lemma lm1 : forall lng : nat, length (list_gen lng nil) = lng.
  induction lng.
  - apply lm0.
  - (* .unfold *)
Abort. (* .none *)

(*|
Now after applying ``lm0`` the induction step is left. I was hoping
that the proof of this step would be deduced from the code of
``list_gen`` but it's most likely a mistaken concept. How can this
subgoal be proved?

----

**A (Daniel Schepler):** I would guess probably you need to generalize
what you're proving to handle cases where the ``acc`` argument is not
``nil``:

.. code-block:: coq

    forall (lng : nat) (acc : list nat),
      length (list_gen lng acc) = lng + length acc.

(And then simpl should be very helpful in proving the inductive
step...)
|*)

(*|
Answer
******

I would go with Daniel's approach, however a bit more general one is
to write out a spec of ``list_gen``, e.g. using *non-tail-recursive*
``repeat`` function:
|*)

Require Import List Arith.
Import ListNotations.

Lemma list_gen_spec : forall lng acc,
    list_gen lng acc = repeat 1 lng ++ acc.
Abort. (* .none *)

(*|
where I had to add a bunch of lemmas about ``repeat``'s interaction
with some standard list functions.
|*)

Lemma repeat_singleton {A} (x : A) :
  [x] = repeat x 1.
Admitted.

Lemma repeat_app {A} (x : A) n m :
  repeat x n ++ repeat x m = repeat x (n + m).
Admitted.

Lemma app_cons {A} (x : A) xs :
  x :: xs = [x] ++ xs.
Admitted.           (* this is a convenience lemma for the next one *)

Lemma app_cons_middle {A} (y : A) xs ys :
  xs ++ y :: ys = (xs ++ [y]) ++ ys.
Admitted.

(*|
I'll leave the proofs of these lemmas as an exercise.

After proving the spec, your lemma could be proved with a few
rewrites.
|*)

Lemma list_gen_spec : forall lng acc,
    list_gen lng acc = repeat 1 lng ++ acc.
Proof.
  induction lng as [| lng IH]; intros xs; simpl; trivial.
  rewrite IH.
  now rewrite app_cons_middle, repeat_singleton, repeat_app, Nat.add_comm.
Qed.

Lemma lm1 lng : length (list_gen lng nil) = lng.
Proof.
  now rewrite list_gen_spec, app_nil_r, repeat_length.
Qed.


Require Import ZF.Axioms.
Require Import ZF.Constructions.
Require Import ZF.Tactics.
Require Import ZF.Omega.

Theorem not_in_self x : ~(x in x).
Proof.
  intros ?.
  destruct (set_reg {x,}) as [? []]. { apply singleton_not_empty. }
  unsettle. subst. firstorder.
Qed.

Theorem not_in_eachother x y: ~(x in y /\ y in x).
Proof.
  intros ?.
  destruct (set_reg {x, y}) as [? []]. { apply pair_not_empty. }
  unsettle. intuition; subst; firstorder.
Qed.

Theorem not_in_triple x y z : ~(x in y /\ y in z /\ z in x).
Proof.
  intros ?.
  destruct (set_reg (cup {x, y} {y, z})) as [w [i d]]. { exists x. unsettle. auto. }
  unsettle. intuition; subst; firstorder.
Qed.

Theorem in_well_founded s : nonempty s -> exists m, m in s /\ forall w, w in s -> ~(w in m).
Proof.
  intros e.
  destruct (set_reg _ e) as [x [? H]].
  exists x. intuition.
  destruct H. exists w. auto.
Qed.

Definition transitive_closure a := union (c_repl omega (recurse a union)).

Theorem transitive_closure_transitive a b c: b in c -> c in transitive_closure a -> b in transitive_closure a.
Proof.
  intros ? i.
  unfold transitive_closure in *.
  unsettle.
  destruct i as [l [? [n]]].
  exists (union l).
  unsettle. split.
  + exists c. auto.
  + exists (succ n).
    intuition. subst.
    rewrite recurse_s; auto.
Qed.

Theorem set_ind (P : set -> Prop) : (forall x, (forall y, y in x -> P y) -> P x) -> forall z, P z.
Proof.
  intros I a.
  destruct (classic (P a)) as [ | na]; auto.
  destruct (in_well_founded (c_specif (transitive_closure {a,}) (fun z => ~P z))) as [m [i min]]. {
    exists a. unfold transitive_closure. unsettle. intuition.
    exists {a,}. unsettle. intuition.
    exists nothing.
    intuition.
    auto using recurse_z.
  }
  unsettle.
  destruct i as [? u].
  destruct u.
  apply I.
  intros y ?.
  destruct (classic (P y)); auto.
  destruct (min y); intuition.
  eauto using transitive_closure_transitive.
Qed.

Print set_ind.

Theorem in_accessible x : Acc elem x.
Proof. induction x using set_ind. constructor. auto. Qed.

(*
Section wf_recursion.
Variable S : forall x, (forall y, y in x -> set) -> set.

Local Record is_wf_recursive i F : Prop := {
  is_wf_rec_pairs : forall p, p in F -> exists s x, s in i /\ p = (k, x);
  is_wf_rec_functional : forall s, s in i -> exists! x, (k, x) in F;
  is_wf_rec_s : forall s, s in i -> (forall (k, x) in F -> (succ k, S x) in F;
}.

*)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (y : natural) (lf2 : natural) : natural :=
  plus y (plus lf3 lf2).


Variable Term : Type.
Variable r : Term -> Term -> Prop.
Variable A : Term. (* type is not empty                                          *)

Notation "M ~> N" := (r M N) (at level 50).

Axiom WeakDec : forall (M N:Term), (M ~> N) \/ ~(M ~> N).

Definition confluence1 : Prop := forall (L M N:Term),
    L ~> M -> L ~> N -> exists (P:Term), (M ~> P) /\ (N ~> P).

(* Seemingly as Stronger statement                                              *)
Definition confluence2 : Prop := forall (L M N:Term),
    exists (P:Term), L ~> M -> L ~> N -> (M ~> P) /\ (N ~> P).

Lemma L1 : confluence2 -> confluence1.
Proof.
    unfold confluence1, confluence2. intros H L M N H1 H2.
    destruct (H L M N) as [P H3]. exists P. apply H3; assumption.
Qed.

(* Term is not an empty type and relation is weakly decidable.                  *)
Lemma L2 : confluence1 -> confluence2.
Proof.
    unfold confluence1, confluence2. intros H L M N.
    destruct (WeakDec L M) as [H1|H1];
    destruct (WeakDec L N) as [H2|H2].
    - destruct (H L M N H1 H2) as [P [H3 H4]]. exists P.
      intros. split; assumption.
    - exists A. intros H3 H4. apply H2 in H4. contradiction.
    - exists A. intros H3 H4. apply H1 in H3. contradiction.
    - exists A. intros H3 H4. apply H1 in H3. contradiction.
Qed.


(* Exercise 17 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_017 : ~(exists x : D, forall y : D, (R y x -> ~ R x y) /\ (~ R x y -> R y x)).
Proof.
neg_i (1=1) a1.
exi_e (exists x : D, forall y : D, (R y x -> ~ R x y) /\ (~ R x y -> R y x)) a a2.
hyp a1.
dis_e (R a a \/ ~R a a) a3 a3.
LEM.
neg_e (R a a).
imp_e (R a a).
con_e1 (~R a a -> R a a).
all_e (forall y:D, (R y a -> ~ R a y) /\ (~ R a y -> R y a)) a.
hyp a2.
hyp a3.
hyp a3.
neg_e (R a a).
hyp a3.
imp_e (~R a a).
con_e2 (R a a -> ~R a a).
all_e (forall y : D, (R y a -> ~ R a y) /\ (~ R a y -> R y a)) a.
hyp a2.
hyp a3.
lin_solve.
Qed.


Require Import init.

Require Export topology_order_base.
Require Import topology_subspace.
Require Import topology_connected.
Require Export relation.
Require Import order_minmax.

Unset Keyed Unification.

(* begin hide *)
Section OrderTopology.

Context {U} `{
    Order U,
    Reflexive U le,
    Connex U le,
    Antisymmetric U le,
    Transitive U le,
    NotTrivial U
}.
(* end hide *)
Definition top_convex (S : U → Prop) :=
    ∀ a b, S a → S b → closed_interval a b ⊆ S.

Theorem open_interval_convex : ∀ a b, top_convex (open_interval a b).
Proof.
    intros a b c d [ac cb] [ad db] x [cx dx].
    split.
    -   exact (lt_le_trans ac cx).
    -   exact (le_lt_trans dx db).
Qed.
Theorem open_closed_interval_convex:∀ a b,top_convex (open_closed_interval a b).
Proof.
    intros a b c d [ac cb] [ad db] x [cx dx].
    split.
    -   exact (lt_le_trans ac cx).
    -   exact (trans dx db).
Qed.
Theorem closed_open_interval_convex:∀ a b,top_convex (closed_open_interval a b).
Proof.
    intros a b c d [ac cb] [ad db] x [cx dx].
    split.
    -   exact (trans ac cx).
    -   exact (le_lt_trans dx db).
Qed.
Theorem closed_interval_convex : ∀ a b, top_convex (closed_interval a b).
Proof.
    intros a b c d [ac cb] [ad db] x [cx dx].
    split.
    -   exact (trans ac cx).
    -   exact (trans dx db).
Qed.
Theorem open_inf_interval_convex : ∀ a, top_convex (open_inf_interval a).
Proof.
    intros a b c ab ac x [bx xc].
    exact (lt_le_trans ab bx).
Qed.
Theorem closed_inf_interval_convex : ∀ a, top_convex (closed_inf_interval a).
Proof.
    intros a b c ab ac x [bx xc].
    exact (trans ab bx).
Qed.
Theorem inf_open_interval_convex : ∀ a, top_convex (inf_open_interval a).
Proof.
    intros a b c ab ac x [bx xc].
    exact (le_lt_trans xc ac).
Qed.
Theorem inf_closed_interval_convex : ∀ a, top_convex (inf_closed_interval a).
Proof.
    intros a b c ab ac x [bx xc].
    exact (trans xc ac).
Qed.

(* begin hide *)
Context `{SupremumComplete U le, Dense U (strict le)}.

Let order_top := order_topology.
Existing Instance order_top.
Existing Instance subspace_topology.

Lemma convex_connected_wlog : ∀ S, top_convex S →
    ∀ (A B : set_type S → Prop) a b, A a → B b → a < b → ¬(separation A B).
Proof.
    intros S S_convex A B a b Aa Bb ab.
    intros [A_empty [B_empty [A_open [B_open [AB_dis AB_all]]]]].
    pose (A' x := A x ∧ x < b).
    pose (A'' := from_set_type A').
    assert (∃ x, A'' x) as A'_ex.
    {
        exists [a|].
        split with [|a].
        rewrite set_type_simpl.
        split; assumption.
    }
    assert (has_upper_bound le A'') as A'_upper.
    {
        exists [b|].
        intros x' [Sx' [Ax' x_lt]].
        apply x_lt.
    }
    pose proof (sup_complete A'' A'_ex A'_upper) as [α [α_upper α_least]].
    assert (A = 𝐂 B) as A_compl.
    {
        apply antisym.
        -   intros x Ax Bx.
            assert ((A ∩ B) x) as x_in by (split; assumption).
            unfold disjoint in AB_dis.
            rewrite AB_dis in x_in.
            exact x_in.
        -   intros x nBx.
            assert (all x) as x_in by exact true.
            rewrite <- AB_all in x_in.
            destruct x_in as [Ax|Bx].
            +   exact Ax.
            +   contradiction.
    }
    assert (B = 𝐂 A) as B_compl.
    {
        rewrite A_compl.
        rewrite compl_compl.
        reflexivity.
    }
    assert (closed A) as A_closed.
    {
        unfold closed.
        rewrite <- B_compl.
        exact B_open.
    }
    assert (closed B) as B_closed.
    {
        unfold closed.
        rewrite <- A_compl.
        exact A_open.
    }
    assert (S α) as Sα.
    {
        apply (S_convex [a|] [b|] [|a] [|b]).
        split.
        -   apply α_upper.
            split with [|a].
            rewrite set_type_simpl.
            split; assumption.
        -   apply α_least.
            intros x [x' [x_eq Ax]].
            apply Ax.
    }
    assert (A [α|Sα]) as Aα.
    {
        classic_case (A [α|Sα]) as [A_in|A_nin]; try exact A_in.
        classic_case (a = [α|Sα]) as [a_eq|a_neq].
        {
            rewrite <- a_eq.
            exact Aa.
        }
        assert ([a|] < α) as a_lt.
        {
            split.
            -   apply α_upper.
                split with [|a].
                rewrite set_type_simpl.
                split; assumption.
            -   intro; subst.
                apply a_neq.
                apply set_type_eq; cbn.
                reflexivity.
        }
        rewrite closed_limit_points in A_closed.
        apply A_closed.
        intros SC SC_open SCα.
        apply empty_neq.
        destruct SC_open as [UC [UC_open C_eq]].
        rewrite C_eq in SCα.
        specialize (UC_open _ SCα) as [BC [BC_basis [BCα BC_sub]]].
        assert (∀ c d, open_closed_interval c d α → open_interval c d ⊆ UC →
            ∃ x, ((A - ❴[α | Sα]❵)%set ∩ SC) x) as wlog.
        {
            clear BCα BC_sub.
            intros c d BCα BC_sub.
            pose (m := max c [a|]).
            assert (S m) as Sm.
            {
                apply (S_convex [a|] α [|a] Sα).
                split.
                -   apply rmax.
                -   unfold m, max; case_if.
                    +   apply a_lt.
                    +   apply BCα.
            }
            classic_case (∃ n, m < [n|] ∧ [n|] < α ∧ A n) as [n_ex|m_max'].
            +   destruct n_ex as [n [mn [nα An]]].
                exists n.
                repeat split.
                *   exact An.
                *   rewrite singleton_eq; intro; subst n.
                    destruct nα; contradiction.
                *   rewrite C_eq.
                    unfold to_set_type.
                    apply BC_sub.
                    split.
                    --  apply (le_lt_trans (lmax c [a|])).
                        exact mn.
                    --  apply (lt_le_trans nα).
                        apply BCα.
            +   rewrite not_ex in m_max'.
                assert (is_upper_bound le A'' m) as m_max.
                {
                    intros x A''x.
                    pose proof (α_upper x A''x) as x_le.
                    destruct A''x as [Sx [Ax x_lt]].
                    specialize (m_max' [x|Sx]).
                    do 2 rewrite not_and in m_max'.
                    destruct m_max' as [leq|[leq|nAx]].
                    -   rewrite nlt_le in leq.
                        exact leq.
                    -   rewrite nlt_le in leq.
                        pose proof (antisym leq x_le).
                        subst α.
                        cbn in *.
                        rewrite (proof_irrelevance Sx Sα) in Ax.
                        contradiction.
                    -   contradiction.
                }
                specialize (α_least _ m_max).
                assert (m < α) as ltq.
                {
                    unfold m, max; case_if.
                    -   exact a_lt.
                    -   apply BCα.
                }
                rewrite <- nle_lt in ltq.
                contradiction.
        }
        destruct BC_basis as [BC_basis|[BC_basis|BC_basis]].
        -   destruct BC_basis as [c [d BC_eq]].
            subst BC.
            assert (open_closed_interval c d α) as BCα2.
            {
                split; apply BCα.
            }
            exact (wlog c d BCα2 BC_sub).
        -   destruct BC_basis as [c [d [BC_eq d_max]]].
            subst BC.
            assert (open_interval c d ⊆ UC) as BC_sub2.
            {
                apply (trans2 BC_sub).
                intros x x_in.
                split; apply x_in.
            }
            exact (wlog c d BCα BC_sub2).
        -   destruct BC_basis as [c [d [BC_eq c_min]]].
            subst BC.
            assert (open_closed_interval c d α) as BCα2.
            {
                split.
                -   split.
                    +   apply BCα.
                    +   intro; subst c.
                        specialize (c_min [a|]).
                        destruct (le_lt_trans c_min a_lt); contradiction.
                -   apply BCα.
            }
            assert (open_interval c d ⊆ UC) as BC_sub2.
            {
                apply (trans2 BC_sub).
                intros x x_in.
                split; apply x_in.
            }
            exact (wlog c d BCα2 BC_sub2).
    }
    assert (B [α|Sα]) as Bα.
    {
        classic_case (B [α|Sα]) as [B_in|B_nin]; try exact B_in.
        classic_case (b = [α|Sα]) as [b_eq|b_neq].
        {
            rewrite <- b_eq.
            exact Bb.
        }
        assert (α < [b|]) as a_lt.
        {
            split.
            -   apply α_least.
                intros x [Sx [Ax x_lt]].
                apply x_lt.
            -   intro; subst.
                apply b_neq.
                apply set_type_eq; cbn.
                reflexivity.
        }
        assert (∀ x, α < x → x < [b|] → S x) as in_S.
        {
            intros x x_lt1 x_lt2.
            apply (S_convex α [b|] Sα [|b]).
            split.
            -   apply x_lt1.
            -   apply x_lt2.
        }
        assert (∀ x (x_lt1 : α < x) (x_lt2 : x < [b|]),
            B [x|in_S x x_lt1 x_lt2]) as in_B.
        {
            intros x x_lt1 x_lt2.
            pose proof (in_S x x_lt1 x_lt2) as Sx.
            rewrite (proof_irrelevance _ Sx).
            classic_contradiction contr.
            assert (all [x|Sx]) as x_in by exact true.
            rewrite <- AB_all in x_in.
            destruct x_in as [Ax|Bx]; try contradiction.
            assert (A'' x) as Ax'.
            {
                split with Sx.
                split.
                -   exact Ax.
                -   split.
                    +   apply x_lt2.
                    +   intros contr2.
                        pose proof x_lt2 as x_lt2'.
                        rewrite <- contr2 in x_lt2'.
                        cbn in x_lt2'.
                        destruct x_lt2'; contradiction.
            }
            specialize (α_upper _ Ax').
            destruct (lt_le_trans x_lt1 α_upper); contradiction.
        }
        rewrite closed_limit_points in B_closed.
        apply B_closed.
        intros SC SC_open SCα.
        apply empty_neq.
        destruct SC_open as [UC [UC_open C_eq]].
        rewrite C_eq in SCα.
        specialize (UC_open _ SCα) as [BC [BC_basis [BCα BC_sub]]].
        assert (∀ c d, closed_open_interval c d α → open_interval c d ⊆ UC →
            ∃ x, ((B - ❴[α | Sα]❵)%set ∩ SC) x) as wlog.
        {
            clear BCα BC_sub.
            intros c d BCα BC_sub.
            pose (m := min [b|] d).
            assert (α < m) as m_gt.
            {
                unfold m, min; case_if.
                -   exact a_lt.
                -   apply BCα.
            }
            pose proof (dense _ _ m_gt) as [n [αn nm]].
            pose proof (lt_le_trans nm (lmin _ _)) as nb.
            exists [n|in_S n αn nb].
            repeat split.
            +   apply in_B.
            +   rewrite singleton_eq; intro contr.
                inversion contr.
                subst.
                destruct αn; contradiction.
            +   rewrite C_eq.
                apply BC_sub; cbn.
                split.
                *   apply (le_lt_trans (land BCα)).
                    exact αn.
                *   apply (lt_le_trans nm).
                    apply rmin.
        }
        destruct BC_basis as [BC_basis|[BC_basis|BC_basis]].
        -   destruct BC_basis as [c [d BC_eq]].
            subst BC.
            assert (closed_open_interval c d α) as BCα2.
            {
                split; apply BCα.
            }
            exact (wlog c d BCα2 BC_sub).
        -   destruct BC_basis as [c [d [BC_eq d_max]]].
            subst BC.
            assert (closed_open_interval c d α) as BCα2.
            {
                split.
                -   apply BCα.
                -   split.
                    +   apply BCα.
                    +   intro contr; subst d.
                        specialize (d_max [b|]).
                        destruct (lt_le_trans a_lt d_max); contradiction.
            }
            assert (open_interval c d ⊆ UC) as BC_sub2.
            {
                apply (trans2 BC_sub).
                intros x x_in.
                split; apply x_in.
            }
            exact (wlog c d BCα2 BC_sub2).
        -   destruct BC_basis as [c [d [BC_eq c_min]]].
            subst BC.
            assert (open_interval c d ⊆ UC) as BC_sub2.
            {
                apply (trans2 BC_sub).
                intros x x_in.
                split; apply x_in.
            }
            exact (wlog c d BCα BC_sub2).
    }
    unfold disjoint in AB_dis.
    assert ((A ∩ B) [α | Sα]) as AB by (split; assumption).
    rewrite AB_dis in AB.
    exact AB.
Qed.
(* end hide *)
Theorem convex_connected : ∀ S, top_convex S → connected (set_type S).
Proof.
    intros S S_convex A B AB_sep.
    pose proof (land AB_sep) as A_ex.
    pose proof (land (rand AB_sep)) as B_ex.
    apply empty_neq in A_ex, B_ex.
    destruct A_ex as [a Aa].
    destruct B_ex as [b Bb].
    destruct (trichotomy a b) as [[ab|ab]|ab].
    -   exact (convex_connected_wlog S S_convex A B a b Aa Bb ab AB_sep).
    -   subst.
        assert ((A ∩ B) b) as b_in by (split; assumption).
        rewrite (land (rand (rand (rand (rand AB_sep))))) in b_in.
        exact b_in.
    -   rewrite separation_comm in AB_sep.
        exact (convex_connected_wlog S S_convex B A b a Bb Aa ab AB_sep).
Qed.

Theorem open_interval_connected :
    ∀ a b, connected (set_type (open_interval a b)).
Proof.
    intros a b.
    apply convex_connected.
    apply open_interval_convex.
Qed.
Theorem open_closed_interval_connected :
    ∀ a b, connected (set_type (open_closed_interval a b)).
Proof.
    intros a b.
    apply convex_connected.
    apply open_closed_interval_convex.
Qed.
Theorem closed_open_interval_connected :
    ∀ a b, connected (set_type (closed_open_interval a b)).
Proof.
    intros a b.
    apply convex_connected.
    apply closed_open_interval_convex.
Qed.
Theorem closed_interval_connected :
    ∀ a b, connected (set_type (closed_interval a b)).
Proof.
    intros a b.
    apply convex_connected.
    apply closed_interval_convex.
Qed.
Theorem open_inf_interval_connected :
    ∀ a, connected (set_type (open_inf_interval a)).
Proof.
    intros a.
    apply convex_connected.
    apply open_inf_interval_convex.
Qed.
Theorem closed_inf_interval_connected :
    ∀ a, connected (set_type (closed_inf_interval a)).
Proof.
    intros a.
    apply convex_connected.
    apply closed_inf_interval_convex.
Qed.
Theorem inf_open_interval_connected :
    ∀ a, connected (set_type (inf_open_interval a)).
Proof.
    intros a.
    apply convex_connected.
    apply inf_open_interval_convex.
Qed.
Theorem inf_closed_interval_connected :
    ∀ a, connected (set_type (inf_closed_interval a)).
Proof.
    intros a.
    apply convex_connected.
    apply inf_closed_interval_convex.
Qed.
(* begin hide *)
End OrderTopology.
(* end hide *)


Record WithHyps : Type :=
  WrapHyps { hyps : list Prop ; p: Prop }.

Require Import Coq.Lists.List.

Import ListNotations.

Fixpoint interp_hyps (hs : list Prop) : Prop :=
  match hs with
  | [] =>
    True
  | h :: hs =>
    h -> interp_hyps hs
  end.

Definition interp_wh (x: WithHyps) : Prop :=
  interp_hyps x.(hyps) -> x.(p).

Lemma interp_hyps_sound :
  forall P,
    P <-> interp_wh (WrapHyps [] P).
Proof.
  intros;
  compute;
  intuition eauto.
Qed.

Lemma add_hyp :
  forall (hs : list Prop) (H P : Prop),
    H ->
    (interp_wh (WrapHyps hs P) <-> interp_wh (WrapHyps (H :: hs) P)).
Proof.
  unfold interp_wh.
  induction hs.
  - compute.
    intuition eauto.
  - intros.
    simpl in *.
    intuition eauto.
Qed.

Lemma weaken_hyps :
  forall (P: Prop) hs,
    P -> interp_wh (WrapHyps hs P).
Proof.
  intros;
  compute;
  intuition eauto.
Qed.

Register WrapHyps as ms.hyps.wrap_hyps.
Register interp_hyps as ms.hyps.interp_hyps.
Register interp_wh as ms.hyps.interp_wh.


(** * Correctness of Binary Search Trees (BSTs) *)

(* This week we'll continue proving the correctness of a binary search tree implementation.
 * BSTs are a famous data structure for finite sets, allowing fast (log-time)
 * lookup, insertion, and deletion of items. (We omit the rebalancing heuristics
 * needed to achieve worst-case log-time operations, but you will prove the
 * correctness of rotation operations these heuristics use to modify the tree.)
 * In this problem set, we show that insertion and deletion functions are
 * correctly defined by relating them to operations on functional sets. *)

Require Import Frap Datatypes Pset4Sig.
Require Import Compare_dec.

(* We will study binary trees of natural numbers only for convenience.
   Almost everything here would also work with an arbitrary type
   [t], but with [nat] you can use [linear_arithmetic] to prove
   goals about ordering of multiple elements (e.g., transitivity). *)
Local Notation t := nat.

Module Impl.
  (* Trees are an inductive structure, where [Leaf] doesn't have any items,
   * whereas [Node] has an item and two subtrees. Note that a [tree] can
   * contain nodes in arbitrary order, so not all [tree]s are valid binary
   * search trees. *)

  (* (* Imported from Sig file: *)
  Inductive tree :=
  | Leaf (* an empty tree *)
  | Node (d : t) (l r : tree).
  *)
  (* Then a singleton is just a node without subtrees. *)
  Definition Singleton (v: t) := Node v Leaf Leaf.

  (* [bst] relates a well-formed binary search tree to the set of elements it
     contains. Note that invalid trees with misordered elements are not valid
     representations of any set. All operations on a binary tree are specified
     in terms of how they affect the set that the tree represents. That
     set is encoded as function that takes a [t] and returns the proposition "[t]
     is in this set". *)
  Fixpoint bst (tr : tree) (s : t -> Prop) :=
    match tr with
    | Leaf => forall x, not (s x) (* s is empty set *)
    | Node d l r =>
        s d /\
        bst l (fun x => s x /\ x < d) /\
        bst r (fun x => s x /\ d < x)
    end.

  (* [member] computes whether [a] is in [tr], but to do so it *relies* on the
     [bst] property -- if [tr] is not a valid binary search tree, [member]
     will (and should, for performance) give arbitrarily incorrect answers. *)
  Fixpoint member (a: t) (tr: tree) : bool :=
    match tr with
    | Leaf => false
    | Node v lt rt =>
      match compare a v with
      | Lt => member a lt
      | Eq => true
      | Gt => member a rt
      end
    end.

  (* Here is a typical insertion routine for BSTs.
   * From a given value, we recursively compare the value with items in
   * the tree from the root, until we find a leaf whose place the new value can take. *)
  Fixpoint insert (a: t) (tr: tree) : tree :=
    match tr with
    | Leaf => Singleton a
    | Node v lt rt =>
      match compare a v with
      | Lt => Node v (insert a lt) rt
      | Eq => tr
      | Gt => Node v lt (insert a rt)
      end
    end.

  (* Helper functions for [delete] below. The *main task* in this pset
     is to understand, specify, and prove these helpers. *)
  Fixpoint rightmost (tr: tree) : option t :=
    match tr with
    | Leaf => None
    | Node v _ rt =>
      match rightmost rt with
      | None => Some v
      | r => r
      end
    end.
  Definition is_leaf (tr : tree) : bool :=
    match tr with Leaf => true | _ => false end.
  Fixpoint delete_rightmost (tr: tree) : tree :=
    match tr with
    | Leaf => Leaf
    | Node v lt rt =>
      if is_leaf rt
      then lt
      else Node v lt (delete_rightmost rt)
    end.
  Definition merge_ordered lt rt :=
    match rightmost lt with
    | Some rv => Node rv (delete_rightmost lt) rt
    | None => rt
    end.

  (* [delete] searches for an element by its value and removes it if it is found.
     Removing an element from a leaf is degenerate (nothing to do), and
     removing the value from a node with no other children (both Leaf) can be done
     by replacing the node itself with a Leaf. Deleting a non-leaf node is
     substantially trickier because the type of [tree] does not allow for a Node
     with two subtrees but no value -- merging two trees is nontrivial. The
     implementation here removes the value anyway and then moves the rightmost
     node of the left subtree up to replace the removed value. This is equivalent
     to using rotations to move the value to be removed into leaf position and
     removing it there. *)
  Fixpoint delete (a: t) (tr: tree) : tree :=
    match tr with
    | Leaf => Leaf
    | Node v lt rt =>
      match compare a v with
      | Lt => Node v (delete a lt) rt
      | Eq => merge_ordered lt rt
      | Gt => Node v lt (delete a rt)
      end
    end.

  (* Here is a lemma that you will almost definitely want to use. *)
  Example bst_iff : forall tr P Q, bst tr P -> (forall x, P x <-> Q x) -> bst tr Q.
  Proof.
    induct tr; simplify.
    { rewrite <- H0. apply H with (x:=x). }
    rewrite H0 in H.
    propositional.
    { apply IHtr1 with (P:=(fun x : t => (fun d => P x /\ x < d) d));
        propositional; cycle 1.
      { rewrite H0; trivial. }
      { rewrite <-H0; trivial. } }
    { apply IHtr2 with (P:=(fun x : t => (fun d => P x /\ d < x) d));
      propositional; cycle 2.
      { rewrite <-H0; trivial. }
      { rewrite H0; trivial. } }
  Qed.

  (* You may want to call these tactics to use the previous lemma. *)
  (* They are just a means to save some typing of [apply ... with]. *)
  Ltac use_bst_iff known_bst :=
    lazymatch type of known_bst with
    | bst ?tree2 ?set2 =>
        lazymatch goal with
        | |- bst ?tree1 ?set1 =>
            apply bst_iff with (P:=set2) (Q := set1);
            lazymatch goal with
            |- bst tree2 set2 => apply known_bst
            | _ => idtac
            end
        end
    end.

  Ltac use_bst_iff_assumption :=
    match goal with
    | H : bst ?t _ |- bst ?t _ =>
      use_bst_iff H
    end.

  (* If you are comfortable with it, [eapply bst_iff] followed by careful
   * application of other [bst] facts (e.g., inductive hypotheses) can
   * save typing in some places where this tactic does not apply, though
   * keep in mind that forcing an incorrect choice for a ?unification
   * variable can make the goal false. *)

  (* It may also be useful to know that you can switch to proving [False] by
   * calling [exfalso]. This, for example, enables you to apply lemmas that end in
   * [-> False]. Of course, only do this if the hypotheses are contradictory. *)

  (* Other tactics used in our solution: apply, apply with, apply with in
   * (including multiple "with" clauses like in [use_bst_iff]), cases, propositional,
     linear_arithmetic, simplify, trivial, try, induct, equality, rewrite, assert. *)

  (* Warm-up exercise: rebalancing rotations *)

  (* Transcribe and prove one of the two rotations shown in [rotation1.svg] and [rotation2.svg].
     The AA-tree rebalancing algorithm applies these only if the annotations of relevant
     subtrees are in violation of a performance-critical invariant, but the rotations
     themselves are correct regardless. (These are straight from
     https://en.wikipedia.org/wiki/AA_tree#Balancing_rotations.) *)
  (* Each one can be written as a simple non-recursive definition
     containing two "match" expressions that returns the original
     tree in cases where the expected structure is not present. *)

  Definition rotate (T : tree) : tree.
  Admitted.

  Lemma bst_rotate T s (H : bst T s) : bst (rotate T) s.
  Admitted.

  (* There is a hint on the class website that completely gives away the proofs
   * of these rotations. We recommend you study that code after completing this
   * exercise to see how we did it, maybe picking up a trick or two to use below. *)

  Lemma bst_insert : forall tr s a, bst tr s ->
    bst (insert a tr) (fun x => s x \/ x = a).
  Proof.
  Admitted.

  (* To prove [bst_delete], you will need to write specifications for its helper
     functions, find suitable statements for proving correctness by induction, and use
     proofs of some helper functions in proofs of other helper functions. The hints
     on the course website provide examples and guidance but no longer ready-to-prove
     lemma statements. For time-planning purposes: you are not halfway done yet.
     (The Sig file also has a rough point allocation between problems.)

     It is up to you whether to use one lemma per function, multiple lemmas per
     function, or (when applicable) one lemma per multiple functions. However,
     the lemmas you prove about one function need to specify everything a caller
     would need to know about this function. *)

  Lemma bst_delete : forall tr s a, bst tr s ->
    bst (delete a tr) (fun x => s x /\ x <> a).
  Admitted.

  (* Great job! Now you have proven all tree-structure-manipulating operations
     necessary to implement a balanced binary search tree. Rebalancing heuristics
     that achieve worst-case-logarithmic running time maintain annotations on
     nodes of the tree (and decide to rebalance based on these). The implementation
     here omits them, but as the rotation operations are correct regardless of
     the annotations, any way of calling them from heuristic code would result in a
     functionally correct binary tree. *)
End Impl.

Module ImplCorrect : Pset4Sig.S := Impl.

(* Authors:
 * Joonwon Choi
 * Adam Chlipala
 * Benjamin Sherman
 * Andres Erbsen
 *)