Load FiniteSets.
Require Import Bool.
Require Import Arith.
Require Import List.
Require Import Notations.

(*A finite set is described using an inductive definition, using 2 constructors.*)

Definition El:=Fin.

(*A word is a list of elements *)(*Variable Sigma : Alphabet. *)
(*A word is a list of elements *)
Variable a:Alphabet.
Definition Word := list (Fin a).

Definition Language := Word  -> Prop.
(**empty word/string *)
Definition eps :Word :=nil.

(**empty word/string *)
Definition lang_conc(l1:Language  )(l2:Language ):Language  :=
    fun w:Word => exists w1:Word , exists w2:Word ,  w1 ++ w2=w /\ l1 w1 /\ l2 w2.

Definition lang_union (l1:Language )(l2:Language ):Language :=
    fun w:Word =>  l1 w \/ l2 w.

(* empty language imply [False] *)
Definition empty_lang :Language := fun w:Word =>False.
Check empty_lang.

(** A language included into another language *)
Definition Included (l1:Language )(l2:Language) :Prop := forall (w:Word ), l1 w -> l2 w.
Check Included.

Definition eps_lang1 :Language := fun w:Word => w=nil.

Definition eps_lang :Language := fun w:Word => match w with
   |nil => True
  | _  => False
   end.

(* L1 conc empty = empty *)
Lemma empty_lr : forall (l1:Language )(w:Word ) ,  (lang_conc l1 (empty_lang ))w <->  empty_lang w.

unfold iff.
intros.
split.
simpl.
intro.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
simpl.
simpl in H1.
unfold empty_lang.
unfold empty_lang in H1.
destruct H1.
intro.

unfold empty_lang in H.
destruct H.
Qed.

Lemma empty_rl: forall (l1:Language )(w:Word ) ,(lang_conc (empty_lang ) l1 )w <->  empty_lang w.
intros.
unfold iff.
split.
intros.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
unfold empty_lang in H0.
destruct H0.
intros.
unfold empty_lang in H.
destruct H.
Qed.

Theorem app_l_nil :  forall (A : Set)(l : list A),
  l ++ nil = l.
intros A l.
induction l.
reflexivity.
simpl.
rewrite IHl.
reflexivity.
Qed.
Lemma eps_lr :forall (l1:Language)(w:Word), (lang_conc l1 eps_lang1) w <-> l1 w.
intros.
unfold iff.
split.
intros.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
unfold eps_lang1 in H1.
rewrite H1 in H.
simpl in H.
rewrite app_l_nil in H.
rewrite <-H.
exact H0.
intro.
unfold lang_conc.
exists w.
exists nil.
split.
apply app_l_nil.
split.
exact H.
unfold eps_lang1.
reflexivity.
Qed.
Definition In_lang(w:Word)(l:Language) := l w.
(* use the properties of existence quantifier to attribute the right values
to the words *)

(** distributivity property *)
Lemma distrib : forall (l1 l2 l3 :Language) (w:Word), In_lang w (lang_conc l1 (lang_union l2 l3)) <-> In_lang w (lang_union (lang_conc l1 l2) (lang_conc l1 l3)).
(** -> *)

intros.
unfold iff.
split.
intro.
unfold In_lang.
unfold In_lang in H.
unfold lang_conc.
unfold lang_union.
unfold lang_conc in H.
unfold lang_union in H.
destruct H.
destruct H.
destruct H.

(* use the properties of existence quantifier to attribute the right values
to the words *)
destruct H0.
destruct H1.
left.
exists x.
exists x0.
split.
assumption.
split.
assumption.
assumption.
right.
exists x.
exists x0.
split.
exact H.
split.
assumption.
assumption.

(**  <- *)
intro.
unfold In_lang in H.
unfold lang_union in H.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H.
destruct H0.
unfold In_lang.
unfold lang_conc.
unfold lang_union.
exists x.
exists x0.
split.
exact H.
split.
exact H0.
left.
exact H1.

destruct H.
destruct H.
destruct H.
destruct H0.
unfold In_lang.
unfold lang_conc.
exists x.
exists x0.
split.
exact H.
split.
exact H0.
unfold lang_union.
right.
exact H1.
Qed.

Variable x:Word.

Lemma eps_implies_nil : forall (w:Word) , eps_lang w -> w=nil.
intros.
induction w.
reflexivity.
unfold eps_lang in H.
destruct H.
Qed.
(** Found in the List library *)

(* L conc epsilon = L *)

Theorem lang_conc_neutral_left : forall (l:Language)(w:Word), In_lang w (lang_conc l eps_lang) <-> In_lang w l.
intros.
unfold iff.
split.
intro.
unfold In_lang.
unfold In_lang in H.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
rewrite <-H.
assert (x1 = nil).
apply eps_implies_nil.
exact H1.
rewrite H2.
simpl.
rewrite app_l_nil.
exact H0.

intro.
unfold In_lang.
unfold In_lang in H.
unfold lang_conc.
exists w.
exists nil.
split.
rewrite app_l_nil.
reflexivity.
split.
exact H.
split.
Qed.

(** epsilon language belongs to L*, if L belongs to the powerset of the word , L* bleongs to the
powerset of the word (using concatenation) *)

Inductive Star(x:Language) : Language :=
  | nil0: (Star x) nil
  | cons0 : forall (a: Word)(b:Word),Star x a /\ x b -> Star x (app a b).

(** the power of a language L : L^n = LLLL...L n times *)
Fixpoint lang_power (l:Language)(n:nat) : Language :=
     match n with
     | 0 => eps_lang
     | S n => lang_conc l (lang_power l n)
     end.

(** L1 conc(L2 conc L3) =(L1 conc L2) conc L3
assume w= v0++ v1, v0 in L1
v1 in L2 conc L3
v1 = v2++v3,
v2 in L2 /\ v3 in L3,
w = v0++(v2++v3) = (v0++ v2)++v3 (associativity of lists) in L1 L2 L4
*)
Axiom app_ao : forall (A:Set)(l1 l2 l3 : list A) , l1 ++ app l2 l3 = (l1 ++ l2) ++ l3.
Lemma ab : forall (A:Set) (l1 l2 : list A) ,  app l1 l2 = l1 ++ l2.
intros.
reflexivity.
Qed.
Lemma abc : forall (A:Set) (l1 l2 l3: list A), app l1 l2 ++ l3 = l1 ++ (l2 ++l3).
intros.
simpl.
admit.
Qed.
Lemma lang_assoc : forall (l1 l2 l3:Language)(w:Word), In_lang w (lang_conc l1 (lang_conc l2 l3)) <-> In_lang w (lang_conc (lang_conc l1 l2) l3).

intros.
unfold iff.
split.
intro.
unfold In in H.

unfold In_lang.
unfold lang_conc.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
destruct H1.
destruct H1.
destruct H1.
destruct H2.
assert( In_lang x1 (lang_conc l2 l3)).
unfold In_lang.
unfold lang_conc.
exists x2.
exists x3.
split.
exact H1.
split.
assumption.
assumption.
rewrite <-H1 in H.

rewrite app_ao in H.
exists (x0 ++ x2).
exists x3.
split.

rewrite <-H.
simpl.
admit.
(* Coq does not recognise app x0 x2 ++ x3 as (x0 ++ x2) ++ x3 ??*)
split.
exists x0.
exists x2.
split.
reflexivity.
split.
assumption.
assumption.
exact H3.

intro.
unfold In.
unfold In in H.
unfold lang_conc.
unfold lang_conc in H.
destruct H.
destruct H.
destruct H.
destruct H0.
destruct H0.
destruct H0.
destruct H0.
destruct H2.

rewrite <-H0 in H.
rewrite abc in H.
exists x2.
exists (x3++ x1).
split. (* x2 ++ app x3 x1 *)
admit.
split.
exact H2.

exists x3.
exists x1.
split.
reflexivity.
split.
assumption.
assumption.
Qed.

(** Star (Star L) = Star l.  we will prove this by using *)
 Lemma kleene1 : forall (l:Language) (w:Word), In_lang w (Star l) ->In_lang w (Star (Star l)).

unfold In_lang.
intros.
rewrite <- app_nil_l.
assert (Star (Star l) nil).
apply (nil0 ).
assert ((Star (Star l) nil) /\ ((Star l) w)).
split.
assumption.
assumption.
apply (cons0) in H1.
exact H1.
Qed.

Axiom nil_O_r : forall (A:Set)(l:list A), l++nil = l.
(*Lemma star_help: forall (l:Language)(a: Word) , In_lang a (Star l) -> In_lang a l.
intros.
unfold In_lang in *.
induction a0.
simpl. *)
Lemma kleene2: forall (l:Language)(w:Word), In_lang w (Star(Star l)) -> In_lang w (Star l).
unfold In_lang.

Print Star.
intros.
induction H.
apply nil0.

Print Star.
assert (Star (Star l) (a0 ++ b)).
apply cons0.
exact H.

destruct H.
destruct H.
trivial.
destruct H.
apply cons0.
intuition.

induction w.
unfold In_lang in *.
intro.
apply nil0.

intro.

unfold In_lang in *.

set(xs := a0:: nil).
assert (xs ++ w = a0::w).
simpl in *.
reflexivity.
rewrite <-H0.

apply cons0.
rewrite <-H0 in H.
assumption.

intros.
unfold In_lang in *.
induction H.
apply nil0.
destruct H.
apply cons0.
split.

induction w.
apply nil0.
assumption.
Qed.
destruct H.
(** Not required
Lemma star_if: forall ( l:Language) (a b : Word) , In_lang a (Star l) /\ In_lang b (Star l) -> In_lang (a ++ b) (Star l).

intros.
unfold In_lang.
unfold In_lang in H.
destruct H.
induction H0.
simpl.
rewrite nil_O_r.
assumption.
Print Star.
assert(Star l (a0 ++b )).
apply cons0.
destruct H0.
split.
assumption.
assumption.
destruct H0.

intros.

destruct H.
admit.
admit.
Qed. *)

Lemma kleene2: forall (l:Language)(w:Word), In_lang w (Star(Star l)) -> In_lang w (Star l).
intros.
unfold In_lang.
unfold In_lang in H.

induction H.
apply nil0.
destruct H.
apply cons0.
split.
induction H.
apply nil0.
apply cons0.
split.
induction w.
apply nil0.

Print Star.
set(xs := a0:: nil).
assert (xs ++ w = a0::w).
simpl in *.
reflexivity.
rewrite <-H0.
apply star_if.
split.
unfold In_lang.
Print Star.
apply cons0.
split.
Print Star.
induction xs.
apply nil0.

induction H.
apply nil0.
destruct H.
Print Star.
induction H0.
apply cons0.
intuition.

induction w.
apply nil0.

induction H.
apply nil0.

apply cons0.
split.
destruct H.

induction w.
apply nil0.
destruct H.
apply nil0.
apply cons0.

Print Star.
induction w.
apply nil0.

assert (l(a0::w) -> Star l (a0::w)).
intros.
Print Star.

admit.

apply H0.

apply nil0.
destruct H.
apply cons0.
induction H.
apply nil0.
destruct H.
Print Star.
apply cons0.
split.
induction w.
simpl.
apply nil0.

destruct H.
apply nil0.
destruct H.

apply cons0.
split.

induction H.

apply nil0.
destruct H.

assert(Star (Star l) (a++b)).
apply cons0.
split.
assumption.
assumption.
assert(Star(Star l) b).
apply kleene1.
unfold In_lang.
exact H0.
induction H.
simpl.
assumption.
destruct H.
assert (Star l (b0 ++ b)).
apply lem.
unfold In_lang.
split.
assumption.
assumption.

induction a.
simpl.
exact H4.

Print Star.

destruct H.
simpl.
assumption.
destruct H.

induction H0.
simpl.
assert(a++nil = a).
admit.
rewrite H0.

induction H.

induction H.
exact (nil0 l).
assert(Star (Star l ) (a++b)).
apply cons0.
assumption.

Print Star.

destruct H.
induction H.
simpl.
assumption.
destruct H.
assert(Star l (b0++b)).
apply lem.
unfold In_lang.
split.
assumption.
assumption.
admit.
(*
induction H0.
assert (a++ nil = a).
admit.
rewrite H0.
induction H.
apply nil0.
apply cons0.
split. *)

induction H.
simpl.
exact H0.
Print Star.

assert(Star l (a++b0)).
destruct H.

assert (Star (Star l) (a ++ b0)).
apply cons0.
exact H.
Print Star.

assert (Star (Star l) b).
apply kleene1.
unfold In_lang.
exact H0.
Print Star.

induction H.
simpl.
exact H0.

apply cons0.


(** * Индукция: Доказательство по Индукции *)

(** Во первых, импортируем все наши определения из предыдущей главы. *)

Require Export Basics.

(** Для того чтобы [Require Export] заработало, нам сначало необходимо
    использовать [coqc] для компиляции [Basics.v] в [Basics.vo]. Это
    похоже на то как делается .class файл из .java файла, или .o файл из .c
    файла. Есть два способа это сделать:

     - В CoqIDE:

         Открыть [Basics.v].  В меню "Compile", кликнуть на "Compile
         Buffer".

     - Из командной строки:

         Запустить [coqc Basics.v]

    *)

(* ###################################################################### *)
(** * Доказательство по индукции *)

(** В прошлой главе мы доказали что [0] есть нейтральный элемент
    слева для [+], используя простой аргумент основанный на упрощении.
    Факт того, что он также является нейтральным элементом _справа_... *)

Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.

(** ... не может быть доказан таким же простым способом. Простое
  применение [reflexivity] не срабатывает, так как [n] в [n + 0] есть
  произвольное неизвестное число, поэтому [match] в определении [+] не может
  быть упрощен.  *)

Proof.
  intros n.
  simpl. (* Ничего не происходит! *)
Abort.

(** Рассужение с перебором случаев и использованием [destruct n] также не
   продвигает нас далеко: ветвь анализа случаев, где мы предполагаем [n = 0]
   доказывается хорошо, но ветвь [n = S n'] для некоторого [n'] останавливает
   нас аналогично предыдущей попытке.  Мы можем использовать [destruct n']
   для продвижения на еще один шаг, но, так как [n] произвольно большое, то
   делая таким образом никогда не закончим. *)

Theorem plus_n_O_secondtry : forall n:nat,
  n = n + 0.
Proof.
  intros n. destruct n as [| n'].
  - (* n = 0 *)
    reflexivity. (* пока хорошо... *)
  - (* n = S n' *)
    simpl.       (* ...но здесь мы застряли опять *)
Abort.

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

    Вспомните (из школы или курса дискретной математики) принцип
    индукции на натуральных числах: Если [P(n)] есть некоторое
    утверждение (пропозиция) включающая натуральное число [n] и
    мы хотим показать, что [P] справедливо для _всех_ чисел [n],
    мы можем рассуждать следующим образом:
         - показать справедливость [P(O)];
         - показать что, для любого [n'], если [P(n')] справесливо,
           то также справедливо [P(S n')];
         - заключить что [P(n)] справедливо для всех [n].

    В Coq, шаги остаются теми же, но в противоположном порядке:
    мы начинаем с цели [P(n)] для всех [n] и разбиваем
    (используя тактику [induction]) на две подцели:
    во первых показываем [P(O)] а затем показываем [P(n') -> P(S
    n')].  Вот как это работает для нашей теоремы: *)

Theorem plus_n_O : forall n:nat, n = n + 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite <- IHn'. reflexivity.  Qed.

(** Как и [destruct], тактика [induction] принимает условие [as...]
    для определения имен переменных, которые надо ввести в подцели.
    В первой ветке, [n] заменяется на [0] и целью становится
    [0 + 0 = 0], что доказывается упрощением. Во второй, [n] заменяется
    [S n'] и утверждение [n' + 0 = n'] добавляется в контекст (под именем [IHn'],
    т.е., Индуктивная Гипотеза для [n'] -- заметьте, что это имя
    явным образом выбрано [as...] условием вызова [induction]
    вместо предоставления выбора Coq). Целью в данном случае становится
    [(S n') + 0 = S n'], что упрощается до [S (n' + 0)
    = S n'], которая в свою очередь следует из [IHn']. *)

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* СДЕЛАНО В КЛАССЕS *)
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** (Использование тактики [intros] в данных доказательствах на самом
     излишне. Когда применено к цели содежащей квантор всеобщности,
     тактика [induction] автоматически переместит эти переменные
     в контекст по мере необходимости.) *)

(** **** Упражнение: 2 звездочки, рекомендовано (basic_induction)  *)
(** Докажите следующее используя индукцию. Вам могут понадобиться
    предыдуще доказанные результаты. *)

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

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

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

(** **** Упражнение: 2 звездочки (double_plus)  *)
(** Рассмотрите следующую функцию, которая удваивает свой аргумент: *)

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(** Используя индукцию докажите следующий простой факт о [double]: *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 2 звездочки, дополнительное (evenb_S)  *)
(** Один неудобный аспект нашего определения [evenb n] состоит в том, что
    оно требует реккурсивного вызова на [n - 2]. Это делает доказательства
    связанные с [evenb n] труднее, когда используется индукция по [n], так как
    нам может понадобиться индуктивная гипотеза о [n - 2]. Следующая лемма
    предоставляет более удобную характеристику [evenb (S n)]: *)

Theorem evenb_S : forall n : nat,
  evenb (S n) = negb (evenb n).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 1 звездочка (destruct_induction)  *)
(** Коротко изложите разницу между тактиками [destruct]
    и [induction].

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

(* ###################################################################### *)
(** * Доказательства в Доказательствах *)

(** В Coq, как и в обычной математике, большие доказательства часто
    разбиваются на последовательность теорем, с последующими теоремами
    ссылающимися на предыдущие теоремы. Но иногда доказательства требует
    некоторый факт который слишком тривиалем и мал, чтобы представлять
    интерес в виде формулировки в виде отдельной теоремы. В таких случая
    было бы удобно иметь возможность просто сформулировать и доказать
    необходимую "подтеорему" прямо на месте ее использования. Тактика
    [assert] позволяет это сделать. Например, наше ранее доказательство
    теоремы [mult_0_plus] обращалось к предыдущей теореме [plus_O_n].
    Вместо этого мы могли бы использовать [assert] для формулировки
    и доказательства [plus_O_n] внутри: *)

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n). { reflexivity. }
  rewrite -> H.
  reflexivity.  Qed.

(** Тактика [assert] вводит две подцели. Первая подцель это само нужное
    нам утверждение, используя [H:] мы задаем ему имя [H].  (Мы также
    можем задать имя утверждения с помощью [as] как мы это делали
    раньше в случае [destruct] и [induction], т.е., [assert (0 + n
    = n) as H].)  Заметьте, как мы выделяем доказательство утверждения
    фигурными скобками [{ ... }], как для читаемости, так и для того,
    чтобы в интерактивной сессии Coq легче видеть когда мы закончили
    под докозательство. Вторая цель такая же как и предыдущая в момент
    до использования [assert] за исключением того, что теперь у нас
    в контексте утверждение [H] о том что [0 + n = n].  Таким образомо,
    [assert] генерирует одну подцель, в которой мы должны  доказать
    нужный нам факт и вторую подцель где мы можем использовать
    данный факт для дальнейшего прогресса в том что мы с самого
    начала пытались доказать. *)

(** Тактика [assert] пригождается во многих ситуациях. Например, предположим
    что мы хотим доказать что [(n + m) + (p + q) = (m +
    n) + (p + q)]. Единственная разница между обоими частями [=] состоит
    в том, что аргументы [m] и [n] в первом внутреннем [+] переставлены
    местами, и кажется что нам может помочь коммутативность сложения ([plus_comm])
    для переписывания одной части в другую. Тем не менне, тактика [rewrite]
    немного глупа в том _где_ она применяет переписывание. У нас есть
    три использование [+], и оказывается, что [rewrite -> plus_comm] воздействует
    только на _внешнее_ сложение... *)

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* Нам просто нужно переставить (n + m) на (m + n)...
     кажется plus_comm должно это сделать! *)
  rewrite -> plus_comm.
  (* Не работает...Coq переписал неправильный плюс! *)
		     Abort.

(** Чтобы [plus_comm] был применен в точке, которая нам нужна, мы можем ввести локальную
    лемму, утверждающую [n + m = m + n] (для конкретного [m] и [n] с которыми мы работаем),
    доказать данную лемму используя [plus_comm], а затем применить ее для требуемого
    переписывания. *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity.  Qed.

(* ###################################################################### *)
(** * Больше Упражнений *)

(** **** Упражнение: 3 звездочки, рекомендованное (mult_comm)  *)
(** Используйте [assert] как помощь в доказательстве теоремы. Нет необходимости
   использовать индукцию в [plus_swap]. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

(** Теперь докажите коммутативность умножения.  (Вам наверное понадобится
    определить и доказать отдельную вспомогательную лемму для использования
    в основном доказательства. Вы можете найти [plus_swap] полезной.) *)

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 3 звездочки, дополнительное (больше упражнений)  *)
(** Возьмите лист бумаги. Для каждой из следующих теорем, во первых
    _подумайте_ о (a) может ли она быть доказана с использованием лишь
    упрощением и переписыванием, (b) требует ли она также анализа случаев
    ([destruct]), или (c) также потребуется индукция. Запишите ваше предсказание.
    Затем заполните доказательство. (Нет необходимости приносить или показывать
    ваш лист с предсказаниями. Это исключительно для тренировки мысли!) *)

Theorem leb_refl : forall n:nat,
  true = leb n n.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

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

Theorem S_nbeq_0 : forall n:nat,
  beq_nat (S n) 0 = false.
Proof.
  (* ЗАПОЛОЛНИТЕ ЗДЕСЬ *) Admitted.

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

Theorem all3_spec : forall b c : bool,
    orb
      (andb b c)
      (orb (negb b)
               (negb c))
  = true.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

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

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 2 звездочки, дополнительное (plus_swap')  *)
(** Тактика [replace] позволяет указать конкретный подтерм для переписывания
   и на что именно он должен быть переписан: [replace (t) with (u)]
   заменяет (все копии) выражения [t] в цели на выражения
   [u], и генерирует [t = u] в качестве дополнительной подцели. Это часто полезно
   когда просто [rewrite] воздействует на неправильную часть цели.

   Используйте тактику [replace] чтобы доказать [plus_swap'], аналогичную
   [plus_swap] но без использования [assert (n + m = m + n)]. *)

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.
(** [] *)

(** **** Упражнение: 3 звездочки, рекомендовано (binary_commute)  *)
(** Вспомните функции [incr] и [bin_to_nat], которые вы написали для
    упражнения [binary] главы [Basics]. Докажите, что следующая
    диаграмма коммутирует:

               bin --------- incr -------> bin
                |                           |
            bin_to_nat                  bin_to_nat
                |                           |
                v                           v
               nat ---------- S ---------> nat

    А именно, инкрементируя бинарное число и конвертируя его в унарное
    производит тот же результат, что и конвертация в натуральное число с
    последующим инкрементированием. Назовите свою теорему [bin_to_nat_pres_incr]
    ("pres" от "preserves").

    Прежде чем начать работать над упражнением, скопируйте определения
    из вашего решение упражнения [binary] так чтобы данный файл оценивался
    самостоятельно. Если вы находите более удобным поменять оригинальные
    определения для упрощения доказательства, то можете это сделать! *)

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

(** **** Упражнение: 5 звездочек, продвинутое (binary_inverse)  *)
(** Данное упражнение является продолжением предыдущего упражнения о
    бинарных числах. Вам понадобятся ваши определения и теоремы оттуда
    для завершения этого упражнения.

    (a) Во первых, напишите функцию конвертирующую натуральные числа
        в бинарные числа. Затем докажите что начиная с произвольного
        натурального числа, конвертирую его в бинарное, а затем обратно
        получается то же натуральное число, с которого мы начали.

    (b) Вы можете естественно подумать, что можно доказать аналогичный
        факт в обратном направлении: начав с бинарного числа, сконвертиров
        его в натуральное, а затем обратно в бинарное, мы получим
        то же число с которого начали. Там не менее, это не так!
        Объясните в чем здесь состоит проблема.

    (c) Определите функцию "прямой" нормализации -- т.е., функцию
        [normalize] из бинарных чисел в бинарные числа, так чтобы для
        любого бинарного числа b, конвертируя его в натуральное, а затем обратно
        получилось бы [(normalize b)].  Докажите это.  (Предупреждение: данная
        часть сложна!)

    Опять же, совободно меняйте свои предыдущие определения, если это вам
    здесь поможет. *)

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

(* ###################################################################### *)
(** * Формальные и Неформальные Доказательства (Дополнительный Материал) *)

(** "_Неформальные доказательства есть алгоритмы; формальные доказательства есть код_." *)

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

    Акты коммуникации могут включать в себя разные типы "читателей".
    С одной стороны, "читателем" могут быть программы вроде Coq, и в этом
    случае "вера" основывается на том что [P] может быть механистически
    выведено из некоторог множества формальных логических правил, и
    доказательство эт рецепт, который помогает программе проверить
    заданный факт. Такие рецепты и есть _формальные доказательства_.

    Альтернативно, читателем может быть человек, и в этом случае
    доказательство будет записано на некотором естественном языке,
    и таким образом будет _неформальным_. Здесь, критерии успеха
    определены менее ясно. "Валидное" доказательством является то,
    которое позволяет убедить читателя поверить в [P]. Однако, тоже
    самое доказательство может быть прочитано разными читателями,
    некоторые из которых могут быть убеждены данным конкретным
    способом выразить агумент, в то время как другие могут и не быть.
    Отдельные читатели могут быть педантичны, неопытны или просто
    тугодумы. Единственный способ убедить таких это предоставить
    все мучительно детально. Другие читатели, более знакомые с
    конкретной областью могут найти такой обилие деталей неприемлемым,
    так как теряется общая суть.  Все что они хотят, это услышать
    главные идеи, так как для них легче заполнить детали самим, чем
    пробираться через из запись. Итого, не существует универсального
    стандарта, так как нет одного простого пути, которым неформальное
    доказательство гарантировало бы убедить любого возможного читателя.

    На практике, тем не менее, математики разработали богатый набор
    конвенций и идиом для описания сложных математических объектов,
    которые -- по крайней мере в рамках конкретных сообществ -- делают
    коммуникацию вполне надежной. Конвенции данные конвенции такой
    стилизованой формы коммуникации предоставляют вполне ясный
    стандарт для разделения хороших и плохих доказательств.

    Так как мы используем Coq в данном курсе, мы будем много работать
    с формальными доказательствами. Но это не означает, что мы можем
    полностью забыть о неформальных!  Формальные доказательства полезны
    многими способами, но они _не_ очень эффективны для коммуникации идей
    между людьми. *)

(** Например, приведем доказательство того, что суммирование аддитивно: *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof. intros n m p. induction n as [| n' IHn']. reflexivity.
  simpl. rewrite -> IHn'. reflexivity.  Qed.

(** Coq вполне доволен этим. Для человека, тем не менее, достаточно
    трудно его понять. Мы можем использовать комментарии и маркеры
    чтобы показать структуру более ясно... *)

Theorem plus_assoc'' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  - (* n = 0 *)
    reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.   Qed.

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

    Математик (педантичный) мог бы записать ээто доказательство примерно так: *)

(** - _Theorem_: For any [n], [m] and [p],

      n + (m + p) = (n + m) + p.

    _Proof_: Индукцией по [n].

    - Во первых, предположим [n = 0].  Мы должны показать

        0 + (m + p) = (0 + m) + p.

      Это следует напрямую из определения [+].

    - Далее, предположив [n = S n'], где

        n' + (m + p) = (n' + m) + p.

      Покажем

        (S n') + (m + p) = ((S n') + m) + p.

      По определению [+], это следует из

        S (n' + (m + p)) = S ((n' + m) + p),

      которое напрямую следует из гипотезы индукции.  _Qed_. *)

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

(** **** Упражнение: 2 звездочки, продвинутое, рекомендованное (plus_comm_informal)  *)
(** Переведите ваше доказательство для [plus_comm] в неформальное доказательство:

    Теорема: Суммирование коммутативно.

    Доказательство: (* ЗАПОЛНИТЕ ЗДЕСЬ *)
*)
(** [] *)

(** **** Упражнение: 2 звездочки, дополнительное (beq_nat_refl_informal)  *)
(** Запишите неформальное доказательство следующей теоремы, используя неформально
    доказательство [plus_assoc] в качестве модели. Не надо просто перефразировать
    названия тактик Coq на русском!

    Теорема: [true = beq_nat n n] для любого [n].

    Доказательство: (* ЗАПОЛНИТЕ ЗДЕСЬ *)
[] *)

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


Require Import ssreflect.
Theorem frobenius (A : Set) (P : A -> Prop) (Q : Prop) :
  (exists x : A, Q /\ P x) <-> (Q /\ exists x : A, P x).
Proof.
  split=> [[x [q px]]|[q [x px]]].
  - split => //. by exists x.
  - by exists x.
Qed.


Require Import List PeanoNat FunInd Arith.Wf_nat Recdef.
Import ListNotations.
From mathcomp Require Import ssreflect.

Module Sort.

Fixpoint sorted (xs: list nat): Prop :=
  match xs with
  | [] => True
  | x1 :: xs1 => (forall x, In x xs1 -> x1 <= x) /\ sorted xs1
  end.

Example sorted_example1:
  sorted ([1; 2; 3]).
Proof.
rewrite /=.
split.
  move=> x.
  case.
    move=> H; rewrite -H.
    auto.
  case=> //.
    move=> H; rewrite -H.
    auto.
split.
  move=> x.
  case=> //.
  move=> H; rewrite -H.
  auto.
split=> //.
Qed.

(* 上のsortedの定義は少しややこしいので、もっとシンプルな定義と同値なことを証明しておきます *)
Fixpoint sorted_simple (xs: list nat): Prop :=
  match xs with
  | [] => True
  | x1 :: [] => True
  | x1 :: (x2 :: _) as xs' => x1 <= x2 /\ sorted_simple xs'
  end.

Definition length_sorted_simple(l: nat) :=
  forall xs, l = length xs -> sorted_simple xs -> sorted xs.

Theorem sorted_simple_iff: forall xs,
  sorted xs <-> sorted_simple xs.
Proof.
move=> xs.
split.
- induction xs => //.
  rename a into x1.
  rewrite /=.
  case.
  move=> Hx1_le_xs Hxs_sorted.
  case_eq xs => //.
  move=> x2 xs2 Hxs.
  rewrite -Hxs.
  split.
  + apply Hx1_le_xs.
    rewrite Hxs /=.
    by left.
  + by apply IHxs.
- apply: (lt_wf_ind (length xs) length_sorted_simple) => //.
  clear xs.
  move=> l.
  rewrite /length_sorted_simple.
  move=> Hlength_lt_sorted xs H Hsorted_simple.
  subst.
  case_eq xs => //=.
  move=> x1 xs1 Hxs.
  split.
  + move: Hsorted_simple.
    rewrite Hxs /=.
    case_eq xs1 => //.
    move=> x2 xs2 Hxs1.
    case.
    move=> Hx1_le_x2 Hsorted_simple_xs1 x.
    rewrite /=.
    case.
      by move=> H; rewrite -H.
    move=> Hx_in_xs2.
    apply (Nat.le_trans x1 x2 x) => //.
    suff: sorted xs1.
      rewrite Hxs1 /=.
      case.
      move=> H _.
      by apply H.
    apply (Hlength_lt_sorted (length xs1)) => //.
    * by rewrite Hxs /=.
    * by rewrite Hxs1.
  + apply (Hlength_lt_sorted (length xs1)) => //.
    * by rewrite Hxs /=.
    * move: Hsorted_simple.
      rewrite Hxs /=.
      case_eq xs1 => //.
      move=> x2 xs2 Hxs1.
      case.
      by move=> _ H.
Qed.

Lemma filter_length {A: Type} : forall (xs: list A) f,
  length (filter f xs) <= length xs.
Proof.
move=> xs f.
induction xs => //.
rewrite /=.
case (f a).
- suff: S (length (filter f xs)) <= S (length xs).
    by rewrite /=.
  by rewrite -Nat.succ_le_mono.
- by apply Nat.le_le_succ_r.
Qed.

Function quick_sort (xs: list nat) {measure length}: list nat :=
  match xs with
  | [] => []
  | pivot :: xs1 =>
    let right := filter (fun x => x <? pivot) xs1 in
    let left := filter (fun x => pivot <=? x) xs1 in
      (quick_sort right) ++ pivot :: (quick_sort left)
  end.
Proof.
(* xs = pivot :: xs1 *)
move=> xs pivot xs1 Hxs.
rewrite /=.
apply Nat.lt_succ_r.
by apply filter_length.

move=> xs pivot xs1 Hxs.
rewrite /=.
apply Nat.lt_succ_r.
by apply filter_length.
Qed.

Example quick_sort_example:
  quick_sort [3; 4; 1; 4; 2] = [1; 2; 3; 4; 4].
Proof.
rewrite quick_sort_equation /=.
rewrite 2!quick_sort_equation /=.
rewrite 2!quick_sort_equation /=.
rewrite quick_sort_equation /=.
rewrite 2!quick_sort_equation /=.
by rewrite quick_sort_equation.
Qed.

Lemma quick_sort_nil:
  quick_sort [] = [].
Proof.
by rewrite quick_sort_equation.
Qed.

Lemma quick_sort_single: forall x1: nat,
  quick_sort [x1] = [x1].
Proof.
move=> x1.
rewrite quick_sort_equation /=.
by rewrite quick_sort_equation.
Qed.

Lemma sorted_app: forall l r,
  sorted l -> sorted r -> (forall lx rx, In lx l -> In rx r -> lx <= rx) ->
  sorted (l ++ r).
Proof.
move=> l r Hsorted_l Hsorted_r Hlx_le_rx.
induction l.
  by [].
rename a into l1.
suff: sorted (l1 :: l ++ r).
  by [].
rewrite /=.
split.
- move=> x Hin_x.
  have: In x l \/ In x r.
    by rewrite -in_app_iff.
  case.
  + move=> Hx_in.
    move: Hsorted_l.
    rewrite /=.
    case.
    move=> H _.
    by apply H.
  + apply Hlx_le_rx.
    apply in_eq.
- apply IHl.
  + by apply Hsorted_l.
  + move=> lx rx Hlx_in Hrx_in.
    apply Hlx_le_rx.
    * rewrite /=.
      by right.
    * by [].
Qed.

Lemma filter_negb_In {A: Type}: forall xs (x: A) f g,
  In x xs ->
  (forall x', g x' = negb (f x')) ->
  In x (filter f xs) \/ In x (filter g xs).
Proof.
move=> xs x f g Hxin.
case_eq (f x) => /=.
- move=> Hfx.
  left.
  rewrite filter_In.
  by split => //=.
- move=> Hfx.
  right.
  rewrite filter_In.
  split => //=.
  rewrite (H x).
  by rewrite Bool.negb_true_iff.
Qed.

Lemma quick_sort_In_ind: forall xs x,
  (forall xs', length xs' < length xs -> (In x xs' <-> In x (quick_sort xs'))) ->
  (In x xs <-> In x (quick_sort xs)).
Proof.
move=> xs x Hquick_sort_In_length.
split.
- move=> Hinx.
  case_eq xs.
    move=> H.
    subst.
    by rewrite quick_sort_nil.
  move=> x1 xs1 Hxs.
  rewrite quick_sort_equation.
  remember (quick_sort (filter (fun x0 : nat => x0 <? x1) xs1)) as left.
  remember (quick_sort (filter (fun x0 : nat => x1 <=? x0) xs1)) as right.
  rewrite in_app_iff.
  suff: x1 = x \/ In x (left ++ right).
    rewrite /=.
    case.
      by right; left.
    rewrite in_app_iff.
    case.
      by left.
    by right; right.
  suff: In x xs -> x1 = x \/ In x xs1.
    case.
    + by [].
    + by left.
    + right.
      rewrite in_app_iff Heqleft Heqright.
      rewrite -Hquick_sort_In_length.
      * rewrite -Hquick_sort_In_length.
        - apply (filter_negb_In xs1 x).
          + by [].
          + move=> x'.
            by apply Nat.leb_antisym.
        - rewrite Hxs /=.
          by apply /Lt.le_lt_n_Sm /filter_length.
      * rewrite Hxs /=.
        by apply /Lt.le_lt_n_Sm /filter_length.
  rewrite Hxs /=.
  case.
  + by left.
  + by right.
- case_eq xs.
    by rewrite quick_sort_nil.
  move=> x1 xs1 Hxs.
  rewrite quick_sort_equation.
  rewrite in_app_iff.
  case.
  + rewrite -Hquick_sort_In_length.
    * rewrite filter_In /=.
      case.
      move=> H _.
      by right.
    * rewrite Hxs /=.
      by apply /Lt.le_lt_n_Sm /filter_length.
  + rewrite /=.
    case.
    * by left.
    * rewrite -Hquick_sort_In_length.
      - rewrite filter_In.
        case.
        move=> H _.
        by right.
      - rewrite Hxs /=.
        by apply /Lt.le_lt_n_Sm /filter_length.
Qed.

Definition length_quick_sort_In(l: nat) :=
  forall xs x, l = length xs -> In x xs <-> In x (quick_sort xs).

Lemma quick_sort_In: forall xs x,
  In x xs <-> In x (quick_sort xs).
Proof.
move=> xs x.
apply (lt_wf_ind (length xs) length_quick_sort_In) => //.
move=> l.
rewrite /length_quick_sort_In.
move=> Hlength_lt_In xs1 x1 Hxs1_length.
subst.
apply quick_sort_In_ind.
move=> xs2 Hxs2.
apply (Hlength_lt_In (length xs2)) => //.
Qed.

Lemma quick_sort_sorted_length_ind: forall xs,
  (forall xs', length xs' < length xs -> sorted (quick_sort xs')) ->
  sorted (quick_sort xs).
Proof.
move=> xs Hsorted_quick_sort.
case_eq xs.
  by rewrite quick_sort_nil.
move=> x1 xs1 Hxs.
rewrite quick_sort_equation.
have: length xs = S (length xs1).
  by rewrite Hxs /=.
move=> Hxs_length.
remember (quick_sort (filter (fun x : nat => x1 <=? x) xs1)) as right.
case_eq (quick_sort (filter (fun x : nat => x <? x1) xs1)).
- rewrite /=.
  split.
  + rewrite Heqright.
    move=> x.
    rewrite -quick_sort_In.
    rewrite filter_In.
    case.
    move=> _.
    by rewrite Nat.leb_le.
  + rewrite Heqright.
    apply Hsorted_quick_sort.
    rewrite Hxs_length.
    by apply /Lt.le_lt_n_Sm /filter_length.
(* (head :: left) ++ x1 :: right *)
- move=> head left Heqleft.
  rewrite /=.
  split.
  + move=> x.
    rewrite in_app_iff.
    case.
    * move=> Hinx_left.
      suff: sorted (head :: left).
        rewrite /=.
        case.
        move=> H _.
        by apply (H x).
      rewrite -Heqleft.
      apply Hsorted_quick_sort.
      rewrite Hxs_length.
      by apply /Nat.lt_succ_r /filter_length.
    * move=> Hin_right.
      have: x1 = x \/ In x right.
        move: Hin_right.
        by rewrite /=.
      clear Hin_right.
      have: In head (head :: left) -> head <= x1.
        rewrite -Heqleft.
        rewrite -quick_sort_In.
        rewrite filter_In.
        case => _.
        rewrite Nat.ltb_lt.
        by apply Nat.lt_le_incl.
      move=> Hhead_le_x1.
      case.
      - move=> H; rewrite -H; clear H.
        apply Hhead_le_x1.
        apply in_eq.
      - rewrite Heqright.
        rewrite -quick_sort_In.
        rewrite filter_In.
        case => _.
        rewrite Nat.leb_le.
        apply Nat.le_trans.
        apply Hhead_le_x1.
        by apply in_eq.
  + apply sorted_app.
    * suff: sorted (head :: left).
        rewrite /=.
        by case.
      rewrite -Heqleft.
      apply: Hsorted_quick_sort.
      rewrite Hxs_length.
      by apply /Nat.lt_succ_r /filter_length.
    * rewrite Heqright.
      rewrite /sorted -/sorted.
      split.
      - move=> x.
        rewrite -quick_sort_In.
        rewrite filter_In.
        case.
        by rewrite Nat.leb_le.
      - apply: Hsorted_quick_sort.
        rewrite Hxs_length.
        by apply /Nat.lt_succ_r /filter_length.
    * move=> lx rx Hlx Hrx.
      move: Nat.le_trans => H.
      apply (H _ x1 _); clear H.
      - suff: In lx (head :: left) -> lx <= x1.
          apply.
          rewrite /=.
          by right.
        rewrite -Heqleft.
        rewrite -quick_sort_In.
        rewrite filter_In.
        case.
        move=> _.
        rewrite Nat.ltb_lt.
        by apply Nat.lt_le_incl.
      - move: Hrx.
        rewrite /=.
        case.
          move=> H; by rewrite H.
        rewrite Heqright.
        rewrite -quick_sort_In.
        rewrite filter_In.
        case.
        move=> _.
        by rewrite Nat.leb_le.
Qed.

Definition length_quick_sort_sorted(l: nat) :=
  forall xs, l = length xs -> sorted (quick_sort xs).

Theorem quick_sort_sorted: forall xs,
  sorted (quick_sort xs).
Proof.
move=> xs.
apply (lt_wf_ind (length xs) length_quick_sort_sorted) => //.
move=> len.
rewrite /length_quick_sort_sorted.
move=> Hlength_lt_sorted xs1 Hxs1_length.
subst.
apply quick_sort_sorted_length_ind.
move=> xs2 Hxs2_length.
apply (Hlength_lt_sorted (length xs2)) => //.
Qed.

Definition count_nat := count_occ Nat.eq_dec.

(* count_occを気にせず使いたいので、置き換えるための補題 *)
Lemma count_nat_app: forall (l1 l2: list nat) (n: nat),
  count_nat (l1 ++ l2) n = count_nat l1 n + count_nat l2 n.
Proof.
move=> l1 l2 n.
by rewrite !/count_nat count_occ_app.
Qed.
Lemma count_nat_cons_eq: forall (l: list nat) (x n: nat),
  x = n -> count_nat (x :: l) n = S (count_nat l n).
Proof.
move=> l x n Hx_eq_n.
by rewrite !/count_nat count_occ_cons_eq.
Qed.
Lemma count_nat_cons_neq: forall (l: list nat) (x n: nat),
  x <> n -> count_nat (x :: l) n = count_nat l n.
Proof.
move=> l x n Hx_neq_n.
by rewrite !/count_nat count_occ_cons_neq.
Qed.

Lemma filter_negb_count_nat: forall xs f g,
  (forall x, g x = negb (f x)) ->
  (forall x, count_nat xs x = count_nat (filter f xs) x + count_nat (filter g xs) x).
Proof.
move=> xs f g Hgf n.
induction xs => //.
case_eq (f a).
- move=> Hfa_true.
  rewrite /= Hgf Hfa_true /=.
  case (Nat.eq_dec a n) => _ //.
  rewrite Nat.add_succ_l.
  by apply eq_S.
- move=> Hfa_false.
  rewrite /= Hgf Hfa_false /=.
  case (Nat.eq_dec a n) => _ //.
  rewrite Nat.add_succ_r.
  by apply eq_S.
Qed.

Lemma quick_sort_count_ind: forall xs,
  (forall xs', length xs' < length xs ->
    forall n, count_nat (quick_sort xs') n = count_nat xs' n) ->
  forall n, count_nat (quick_sort xs) n = count_nat xs n.
Proof.
move=> xs Hsorted_count n.
case_eq xs.
  by rewrite quick_sort_nil.
move=> x1 xs1 Hxs.
rewrite quick_sort_equation.
rewrite count_nat_app.
case_eq (x1 =? n).
- rewrite Nat.eqb_eq => Hx1_eq_n.
  rewrite count_nat_cons_eq => //.
  rewrite count_nat_cons_eq => //.
  rewrite Nat.add_succ_r.
  apply eq_S.
  have: forall fg, length (filter fg xs1) < length xs.
    move=> fg.
    rewrite Hxs /=.
    rewrite Nat.lt_succ_r.
    apply filter_length.
  move=> Hfilter_length.
  rewrite Hsorted_count => //.
  rewrite Hsorted_count => //.
  rewrite -filter_negb_count_nat => //.
  move=> x.
  by apply Nat.leb_antisym.
- rewrite Nat.eqb_neq => Hx1_neq_n.
  rewrite count_nat_cons_neq => //.
  rewrite count_nat_cons_neq => //.
  have: forall fg, length (filter fg xs1) < length xs.
    move=> fg.
    rewrite Hxs /=.
    rewrite Nat.lt_succ_r.
    apply filter_length.
  move=> Hfilter_length.
  rewrite Hsorted_count => //.
  rewrite Hsorted_count => //.
  rewrite -filter_negb_count_nat => //.
  move=> x.
  by apply Nat.leb_antisym.
Qed.

Definition length_quick_sort_count(l: nat) :=
  forall xs, l = length xs -> forall n, count_nat (quick_sort xs) n = count_nat xs n.

Lemma quick_sort_count: forall xs,
  forall n, count_nat (quick_sort xs) n = count_nat xs n.
Proof.
move=> xs n.
apply (lt_wf_ind (length xs) length_quick_sort_count) => // len.
rewrite /length_quick_sort_count => Hlength_lt_sort_count xs1 Hxs1_length.
subst.
apply quick_sort_count_ind => xs2 Hxs2_length.
apply (Hlength_lt_sort_count (length xs2)) => //.
Qed.

Definition sort_algorithm (alg: list nat -> list nat) :=
  forall xs, sorted (alg xs) /\ forall n, count_nat (alg xs) n = count_nat xs n.

(*
  ということできちんとクイックソートがソートアルゴリズムであることが証明できました。
  これで安心してクイックソートを使えます！
*)
Theorem quick_sort_is_sort_algorithm: sort_algorithm quick_sort.
Proof.
rewrite /sort_algorithm => xs.
split.
- by apply quick_sort_sorted.
- by apply quick_sort_count.
Qed.

End Sort.


(* The Word module should use the same definitions as CompCert.
   There is a functor that can be instantiated for the targeted word size.
   https://github.com/artart78/coq-bits/blob/master/test/integers.v
   See, e.g., the module Int64 defined in that file.
   If more flexibility on the word size is needed, e.g., to make all
   definitions parameteric in the word size, then let's discuss.
   For the moment, I won't touch your current Word module. *)

Require Import Arith.PeanoNat.
Require Import Lia.
Require Import ProofIrrelevance.

Inductive word (size : nat) : Type :=
| Word : forall n : nat, n < 2 ^ size -> word size.

Definition word_equality (s : nat) (w x : word s) : bool :=
  match w, x with
      | Word _ m _, Word _ n _ => EqNat.beq_nat m n
  end.

Lemma word_eq_succ : forall (n0 n1 size : nat) (H0 : n0 < 2 ^ size) (H1 : n1 < 2 ^ size) (P0 : (S n0) < 2 ^ size) (P1 : (S n1) < 2 ^ size),
    Word size n0 H0 = Word size n1 H1 -> Word size (S n0) P0 = Word size (S n1) P1.
Proof.
  intros; generalize dependent P0; generalize dependent P1.
  inversion H.
  induction n0; destruct n1; try(inversion H3);intros;
    assert (P0 = P1) as P by apply proof_irrelevance; rewrite P; reflexivity.  Qed.

Lemma word_neq_nat_neq : forall m n s P Q, Word s m P <> Word s n Q -> m <> n.
Proof.
  induction m; destruct n; intros; try(discriminate).
  - assert (P = Q) by (apply proof_irrelevance; assumption).
    contradiction H. rewrite H0. reflexivity.
  - intro Cont; destruct Cont.
    assert (P = Q) by (apply proof_irrelevance; assumption). rewrite H0 in H. contradiction. Qed.

Lemma word_neq_succ : forall (n0 n1 size : nat) (H0 : n0 < 2 ^ size) (H1 : n1 < 2 ^ size) (P0 : (S n0) < 2 ^ size) (P1 : (S n1) < 2 ^ size),
    Word size n0 H0 <> Word size n1 H1 -> Word size (S n0) P0 <> Word size (S n1) P1.
Proof.
  induction n0; destruct n1; intros; try(discriminate).
  assert (H': H0 = H1) by apply proof_irrelevance; rewrite H' in H. contradiction.
  intros Con. inversion Con. apply word_neq_nat_neq in H.
  apply H. apply f_equal. assumption.  Qed.

Theorem word_eq_dec : forall (n : nat) (w1 w2 : word n), {w1 = w2} + {w1 <> w2}.
  intros size [n0 P0].
  induction n0; intros [n1 P1]; destruct n1; try(right; discriminate).
    + left. assert (P0 = P1) by apply proof_irrelevance. rewrite H. reflexivity.
    + assert (n0 < 2 ^ size) by (apply Nat.lt_succ_l;assumption).
      assert (n1 < 2 ^ size) by (apply Nat.lt_succ_l;assumption).
      assert ({Word size n0 H = Word size n1 H0} + {Word size n0 H <> Word size n1 H0}) by apply IHn0.
      inversion H1.
      * left. apply word_eq_succ with H H0. assumption.
      * right. apply word_neq_succ with H H0. assumption.  Qed.

Lemma lem0 : forall (m n p: nat), m < 2^p -> n < 2^p -> (m + n) mod (2 ^ p) < (2 ^ p) .
Proof.
  intros.
  apply Nat.mod_upper_bound.
  apply Nat.pow_nonzero.
  discriminate.
Qed.

Definition word_add (size : nat) (w1 w2 : word size) : word size :=
  match w1, w2 with
  | Word _ n1 P1, Word _ n2 P2 => Word size ((n1 + n2) mod 2 ^ size)
                                      (lem0 n1 n2 size P1 P2)
  end.

Fixpoint nat_sub_underflow (under : nat) (n m : nat) :=
  match n, m with
  | _, 0 => n
  | 0, S m' => nat_sub_underflow under under m'
  | S n', S m' => nat_sub_underflow under n' m'
  end.

Lemma lem4 : forall (m n p : nat), m < 2^p -> n < 2 ^ p ->
    nat_sub_underflow (2^p - 1) m n < (2^p).
Proof.
  intros m n p P Q.
  generalize dependent m.
  induction n; destruct m; auto; intros; simpl.
  - apply IHn.
    + apply (Nat.lt_trans n (S n) (2^p)) in Q.
      * assumption.
      * apply Nat.lt_succ_diag_r.
    + rewrite Nat.sub_succ_r.
      rewrite Nat.sub_0_r.
      apply Lt.lt_pred_n_n.
      assumption.
  - intros.
    apply IHn.
    + apply (Nat.lt_trans n (S n) (2^p)) in Q.
      * assumption.
      * apply Nat.lt_succ_diag_r.
    + apply (Nat.lt_trans m (S m) (2^p)) in P.
      * assumption.
      * apply Nat.lt_succ_diag_r.  Qed.

Definition word_sub (size : nat) (w1 w2 : word size) : word size :=
  match w1, w2 with
  | Word _ n1 P1, Word _ n2 P2 => Word size (nat_sub_underflow (2^size - 1) n1 n2)
                                     (lem4 n1 n2 size P1 P2)
  end.

Lemma bitwise_max_lem : forall (m n p : nat) (op : bool -> bool -> bool), m <= 2^p - 1 -> n <= 2^p - 1 ->
    (Nat.bitwise op p m n) <= 2^p - 1.
Proof.
  intros m n p. generalize dependent n.
  generalize dependent m. induction p; intros; auto.
  intros. simpl.
    assert (forall x y, x <= 2 ^ S y - 1 -> Nat.div2 x <= 2 ^ y - 1). {
      intros.
      destruct (Nat.Even_or_Odd x).
      * inversion H2. rewrite H3.
        rewrite Nat.div2_double.
        rewrite H3 in H1.
        assert (0 < 2) by lia.
        apply (Nat.mul_le_mono_pos_l _ _ 2 H4).
        rewrite  Nat.mul_sub_distr_l.
        rewrite <- H3.
        simpl (2 * 1).
        inversion H1.
        lia.
        lia.

      * inversion H2. rewrite H3.
        rewrite (Nat.add_comm).
        rewrite Nat.div2_succ_double.
        rewrite H3 in H1.
        inversion H1.
        lia.
        lia.
    }
    apply H1 in H.
    apply H1 in H0.
    apply (IHp _ _ op H) in H0.
    apply (Nat.mul_le_mono_pos_l _ _ 2) in H0.
    rewrite  Nat.mul_sub_distr_l in H0.
    simpl in *.
    destruct (op (Nat.odd m) (Nat.odd n)).
    simpl.
    apply le_n_S in H0.
    repeat rewrite (Nat.add_comm _ 0) in *.
    simpl in *.
    assert (forall x, S (2 ^ x + 2 ^ x - 2) = (2 ^ x + 2 ^ x - 1)). {
      intros.
      assert (2 <= 2 ^ x + 2 ^ x) by
          (induction x; simpl; lia).
      rewrite <- (Nat.sub_succ_l _ _ H2).
      reflexivity.
    }
    rewrite H2 in H0.
    apply H0.
    simpl.
    apply le_S in H0.
    repeat rewrite (Nat.add_comm _ 0) in *.
    simpl in *.
    assert (forall x, S (2 ^ x + 2 ^ x - 2) = (2 ^ x + 2 ^ x - 1)). {
      intros.
      assert (2 <= 2 ^ x + 2 ^ x) by
          (induction x; simpl; lia).
      rewrite <- (Nat.sub_succ_l _ _ H2).
      reflexivity.
    }
    rewrite H2 in H0.
    apply H0. lia.
Qed.

Theorem bitwise_max : forall (m n p : nat) (op : bool -> bool -> bool), m < 2^p -> n < 2^p ->
    (Nat.bitwise op p m n) < 2^p.
  intros.
  assert (2 ^ p = S ( 2 ^ p - 1)) by lia.
  rewrite H1 in *.
  apply Lt.le_lt_n_Sm.
  apply Lt.lt_n_Sm_le in H.
  apply Lt.lt_n_Sm_le in H0.
  apply bitwise_max_lem; assumption. Qed.

Definition word_and (size : nat) (w1 w2 : word size) : word size :=
  match w1, w2 with
  | Word _ n1 P1, Word _ n2 P2 => Word size (Nat.bitwise andb size n1 n2)
                                      (bitwise_max n1 n2 size andb P1 P2)
  end.

Definition word_or (size : nat) (w1 w2 : word size) : word size :=
  match w1, w2 with
  | Word _ n1 P1, Word _ n2 P2 => Word _ (Nat.bitwise orb size n1 n2)
                                      (bitwise_max n1 n2 size orb P1 P2)
  end.

Definition word_xor (size : nat) (w1 w2 : word size) : word size :=
  match w1, w2 with
  | Word _ n1 P1, Word _ n2 P2 => Word _ (Nat.bitwise xorb size n1 n2)
                                      (bitwise_max n1 n2 size xorb P1 P2)
  end.

Lemma Oneq : forall s n, n mod 2 ^ s < 2 ^ s.
Proof. intros. apply Nat.mod_upper_bound. apply Nat.pow_nonzero. discriminate.  Qed.

Definition word_to_nat (s : nat) (w : word s) : nat :=
  match w with | Word _ n _ => n end.

Definition nat_to_word (s n : nat) : word s :=
  Word s (n mod 2 ^ s) (Oneq s n).


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> 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.

Lemma lem: forall l n, cons n (rev l) = rev (append l (cons n nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (append (rev (rev x)) y) (rev (rev (append x y))).
Proof.
  intros. rewrite lem2. rewrite lem2. reflexivity.
Qed.


Require Import Coq.Reals.Reals.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.omega.Omega.
Require Export LibTactics.

Inductive point : Type := Point (x y : R).

Definition region : Type := point -> Prop.

Definition map : Type := point -> region.

Inductive interval : Type := Interval (x y : R).

Inductive rectangle : Type := Rectangle (hspan vspan : interval).

Definition in_interval (s : interval) : R -> Prop :=
  fun t => let ' Interval x y := s in (x < t)%R /\ (t < y)%R.

Definition in_rectangle rr : region :=
  fun z => let ' Rectangle hspan vspan := rr in let ' Point x y := z in
  in_interval hspan x /\ in_interval vspan y.

(* Elementary set theory for the plane. *)

Definition union (r1 r2 : region) : region := fun z => r1 z \/ r2 z.

Definition intersect (r1 r2 : region) : region := fun z => r1 z /\ r2 z.

Definition nonempty (r : region) : Prop := exists z : point, r z.

Definition subregion (r1 r2 : region) : Prop := forall z : point, r1 z -> r2 z.

Lemma intersect_symm (r1 r2 : region) (z : point) :
  intersect r1 r2 z <-> intersect r2 r1 z.
Proof. split; intros [? ?]; split; auto. Qed.

Lemma subregion_refl (r : region) :
  subregion r r.
Proof. red. auto. Qed.

Lemma subregion_trans (r1 r2 r3 : region) :
  subregion r1 r2 -> subregion r2 r3 -> subregion r1 r3.
Proof.
  unfold subregion. intros. auto. Qed.

Definition meet (r1 r2 : region) : Prop := nonempty (intersect r1 r2).

Lemma meet_symm (r1 r2 : region) :
  meet r1 r2 -> meet r2 r1.
Proof. intros [? [? ?]]. exists x; split; auto. Qed.

Lemma meet_subregion (u1 u2 r : region) :
  meet u1 r -> subregion u1 u2 -> meet u2 r.
Proof.
  unfold meet, nonempty, intersect. intros [? [? ?]] ?.
  exists x. split; auto.
Qed.

Hint Resolve subregion_refl subregion_trans meet_subregion.

(* Maps are represented as relations; proper map are partial equivalence  *)
(* relations (PERs).                                                      *)

Record plain_map (m : map) : Prop := PlainMap {
  map_symm z1 z2 : m z1 z2 -> m z2 z1;
  map_trans z1 z2 z3 : m z1 z2 -> m z2 z3 -> m z1 z3
}.

(*
Axiom plain_map_unique_point :
  forall (m : map) (z1 z2 : point), plain_map m -> m z1 z2 -> z1 = z2.
*)

Lemma map_symm_trans_ll (m : map) (z1 z2 z3 : point) :
  plain_map m -> m z1 z2 -> m z1 z3 -> m z2 z3.
Proof. intros. apply map_trans with z1; auto. apply map_symm; auto. Qed.

Lemma map_symm_trans_rr (m : map) (z1 z2 z3 : point) :
  plain_map m -> m z1 z2 -> m z3 z2 -> m z1 z3.
Proof. intros. apply map_trans with z2; auto. apply map_symm; auto. Qed.

Lemma map_covered_left (m : map) (z1 z2 : point) :
  plain_map m -> m z1 z2 -> m z1 z1.
Proof.
  intros. assert (m z2 z1) by (apply map_symm; auto).
  apply map_trans with z2; auto. Qed.

Lemma map_covered_right (m : map) (z1 z2 : point) :
  plain_map m -> m z1 z2 -> m z2 z2.
Proof.
  intros. assert (m z2 z1) by (apply map_symm; auto).
  apply map_trans with z1; auto. Qed.

(* sum of all the regions in map (set of all the points defined on map) *)
Definition cover (m : map) : region := fun z => m z z.

Definition submap (m1 m2 : map) : Prop := forall z, subregion (m1 z) (m2 z).

Lemma submap_refl (m : map) :
  submap m m.
Proof. unfold submap. auto. Qed.

Lemma submap_trans (m1 m2 m3 : map) :
  submap m1 m2 -> submap m2 m3 -> submap m1 m3.
Proof.
  unfold submap. intros.
  eapply subregion_trans; auto.
Qed.

(* There are at most n regions in m. *)
Definition at_most_regions (n : nat) (m : map) :=
  exists f, forall z, cover m z -> exists2 i : nat, Peano.lt i n & m (f i) z.

(* Elementary topology. *)

Definition open (r : region) : Prop :=
  forall z, r z -> exists2 u, in_rectangle u z & subregion (in_rectangle u) r.

Definition closure (r : region) : region :=
  fun z => forall u, open u -> u z -> meet r u.

Lemma closure_supregion (m : map) (z : point) :
  m z z -> closure (m z) z.
Proof with auto.
  red. intros. exists z... split...
Qed.

Lemma closure_preserves_subregion (r1 r2 : region) :
  subregion r1 r2 -> subregion (closure r1) (closure r2).
Proof with auto.
  unfold subregion, closure. intros. destruct (H0 u) as [x [? ?]]...
  exists x. split...
Qed.

Definition connected (r : region) : Prop :=
  forall u v, open u -> open v -> subregion r (union u v) ->
  meet u r -> meet v r -> meet u v.

Record simple_map (m : map) : Prop := SimpleMap {
  simple_map_plain : plain_map m;
  simple_map_open z : open (m z);
  simple_map_connected z : connected (m z)
}.

Record finite_simple_map (m : map) : Prop := FiniteSimpleMap {
  finite_simple_map_simple : simple_map m;
  finite_simple_map_finite : exists n, at_most_regions n m
}.

Hint Resolve simple_map_plain.

Lemma closure_map (m : map) (z z' : point) :
  simple_map m -> closure (m z) z' -> m z z' \/ ~ m z' z'.
Proof.
  intros. repeat red in H0. destruct H.
  assert (m z' z' -> exists z0 : point, intersect (m z) (m z') z0) by auto.
  apply imply_to_or in H.
  destruct H; auto.
  left. inversion H; inversion H1.
  apply map_trans with x; auto.
  apply map_symm; auto.
Qed.

Lemma closure_map_trans (m : map) (z1 z2 z : point) :
  plain_map m -> m z1 z2 -> closure (m z1) z -> closure (m z2) z.
Proof with auto.
  unfold closure, meet. intros.
  assert (nonempty (intersect (m z1) u)) by auto.
  destruct H4. destruct H4. exists x. split; auto.
  apply map_trans with z1... apply map_symm...
Qed.

(* Borders, corners, adjacency and coloring. *)

Definition border (m : map) (z1 z2 : point) : region :=
  intersect (closure (m z1)) (closure (m z2)).

Definition corner_map (m : map) (z : point) : map :=
  fun z1 z2 => open (m z1) /\ m z1 z2 /\ closure (m z1) z.

(* a point is not a corner of a map iff it doesn't belong to the closure of
*  more than 2 regions. *)
Definition not_corner (m : map) : region :=
  fun z => at_most_regions 2 (corner_map m z).

Lemma not_corner_correct (m : map) (z1 z2 z3 z : point) :
  simple_map m -> not_corner m z ->
  m z1 z1 /\ closure (m z1) z ->
  m z2 z2 /\ closure (m z2) z ->
  m z3 z3 /\ closure (m z3) z ->
  m z1 z2 \/ m z2 z3 \/ m z3 z1.
Proof with auto.
  intros. repeat red in H0. destruct H0 as [f ?].
  assert (open (m z1) /\ m z1 z1 /\ closure (m z1) z) by (split; auto; apply simple_map_open; auto).
  assert (open (m z2) /\ m z2 z2 /\ closure (m z2) z) by (split; auto; apply simple_map_open; auto).
  assert (open (m z3) /\ m z3 z3 /\ closure (m z3) z) by (split; auto; apply simple_map_open; auto).
  clear H1 H2 H3; rename H4 into H1; rename H5 into H2; rename H6 into H3.
  apply (H0 z1) in H1. destruct H1 as [i ?]. destruct H4 as [? [? ?]].
  apply (H0 z2) in H2. destruct H2 as [j ?]. destruct H7 as [? [? ?]].
  apply (H0 z3) in H3. destruct H3 as [k ?]. destruct H10 as [? [? ?]].
  assert (i = 0 \/ i = 1) by omega.
  assert (j = 0 \/ j = 1) by omega.
  assert (k = 0 \/ k = 1) by omega.
  clear H1 H2 H3.
  destruct H13; subst.
  - destruct H14; subst.
    + left. apply map_trans with (f 0)... apply map_symm...
    + right. destruct H15; subst.
      { right. apply map_symm_trans_ll with (f 0)... }
      { left. apply map_symm_trans_ll with (f 1)... }
  - destruct H14; subst.
    + right. destruct H15; subst.
      { left. apply map_symm_trans_ll with (f 0)... }
      { right. apply map_symm_trans_ll with (f 1)... }
    + left. apply map_symm_trans_ll with (f 1)...
Qed.

Record adjacent (m : map) (z1 z2 : point) : Prop := Adjacent {
  adjacent_cover_left : m z1 z1;
  adjacent_cover_right : m z2 z2;
  adjacent_not_same_face : ~ m z1 z2;
  adjacent_meet : meet (not_corner m) (border m z1 z2)
}.

Definition inter_region (m : map) (z1 z2 : point) : region :=
  fun z => ~ m z1 z2 /\ intersect (not_corner m) (border m z1 z2) z.

Lemma border_symm (m : map) (z1 z2 z : point) :
  border m z1 z2 z <-> border m z2 z1 z.
Proof. split; unfold border; apply intersect_symm. Qed.

Lemma inter_region_symm (m : map) (z1 z2 z : point) :
  simple_map m ->
  inter_region m z1 z2 z <-> inter_region m z2 z1 z.
Proof with auto.
  split; unfold inter_region; intros [? [? ?]]; split.
  - intros F; apply H0; apply map_symm...
  - split... apply border_symm...
  - intros F; apply H0; apply map_symm...
  - split... apply border_symm...
Qed.

Hint Resolve border_symm inter_region_symm.

Lemma border_not_covered (m : map) (z1 z2 z : point) :
  simple_map m -> ~ m z1 z2 -> border m z1 z2 z -> ~ m z z.
Proof with auto.
  intros ? ? [? ?] ?.
  apply H0. apply map_trans with z.
  - inversion H...
  - destruct (closure_map _ _ _ H H1)...
    apply H4 in H3. inversion H3.
  - destruct (closure_map _ _ _ H H2).
    + apply map_symm...
    + apply H4 in H3. inversion H3.
Qed.

Lemma inter_region_deterministic (m : map) (z z1 z2 z3 z4 : point) :
  simple_map m ->
  m z1 z1 -> m z2 z2 -> m z3 z3 -> m z4 z4 ->
  inter_region m z1 z2 z -> inter_region m z3 z4 z ->
  (m z1 z3 /\ m z2 z4) \/ (m z1 z4 /\ m z2 z3).
Proof with auto.
  unfold inter_region. intros ? ? ? ? ? [? [? [? ?]]] [? [_ [? ?]]].
  assert (m z1 z2 \/ m z2 z3 \/ m z3 z1) by (apply not_corner_correct with z; auto).
  destruct H11.
  - contradiction.
  - destruct H11.
    + right; split...
      assert (m z1 z3 \/ m z3 z4 \/ m z4 z1) by (apply not_corner_correct with z; auto).
      destruct H12.
      { exfalso. apply H4; apply map_symm_trans_rr with z3... }
      { destruct H12. contradiction. apply map_symm... }
    + left. split; apply map_symm...
      assert (m z2 z3 \/ m z3 z4 \/ m z4 z2) by (apply not_corner_correct with z; auto).
      destruct H12.
      { exfalso. apply H4; apply map_trans with z3; auto; apply map_symm... }
      { destruct H12. contradiction. auto. }
Qed.

Record coloring (m k : map) : Prop := Coloring {
  coloring_plain : plain_map k;
  coloring_cover : subregion (cover m) (cover k);
  coloring_consistent : submap m k;
  coloring_adjacent z1 z2 : adjacent m z1 z2 -> ~ k z1 z2
}.

Definition colorable_with (n : nat) (m : map) : Prop :=
  exists2 k, coloring m k & at_most_regions n k.

(* TODO: add a restriction so that each region of m should be convex *)
Definition totalize (m : map) : map :=
  fun z z' =>
    (* もともとm上の点である *)
    m z z' \/
    (* z1, z2を含むregionの間にある点 *)
    (exists z1 z2 : point,
      m z1 z1 /\ m z2 z2 /\ ~ m z1 z2 /\
      intersect (border m z1 z2) (not_corner m) z /\
      intersect (border m z1 z2) (not_corner m) z').

Lemma totalize_symm (m : map) (z1 z2 : point) :
  simple_map m -> totalize m z1 z2 -> totalize m z2 z1.
Proof.
  unfold totalize. intros. destruct H0.
  - left. apply map_symm; auto.
  - destruct H0 as [z3 [z4 [? [? [? [[? ?] [? ?]]]]]]].
    right. exists z3, z4.
    repeat (split; auto).
Qed.

Lemma totalize_trans (m : map) (z1 z2 z3 : point) :
  simple_map m -> totalize m z1 z2 -> totalize m z2 z3 -> totalize m z1 z3.
Proof with auto.
  intros. destruct H0.
  - destruct H1.
    + left. apply map_trans with z2...
    + destruct H1 as [z4 [z5 [? [? [? [[? ?] [? ?]]]]]]].
      apply border_not_covered in H4...
      apply map_covered_right in H0... contradiction.
  - destruct H0 as [z4 [z5 [? [? [? [[? ?] [? ?]]]]]]].
    destruct H1.
    + apply border_not_covered in H6...
      apply map_covered_left in H1... contradiction.
    + destruct H1 as [z6 [z7 [? [? [? [[? ?] [? ?]]]]]]].
      assert (m z4 z6 /\ m z5 z7 \/ m z4 z7 /\ m z5 z6).
      { apply inter_region_deterministic with z2; auto; split; auto; split; auto. }
      destruct H14; destruct H14.
      { right. exists z4, z5. destruct H12. repeat (split; auto).
        - apply closure_map_trans with z6... apply map_symm...
        - apply closure_map_trans with z7... apply map_symm... }
      { right. exists z4, z5. destruct H12. repeat (split; auto).
        - apply closure_map_trans with z7... apply map_symm...
        - apply closure_map_trans with z6... apply map_symm... }
Qed.

Lemma totalize_subregion (m : map) (z : point) :
  subregion (m z) (totalize m z).
Proof.
  red; intros; left; auto. Qed.

Lemma totalize_plain_map (m : map) :
  simple_map m -> plain_map (totalize m).
Proof with auto.
  intros. inversion H. split; intros.
  - apply totalize_symm...
  - red. intros. apply totalize_trans with z3...
    apply totalize_trans with z2... apply totalize_trans with z2...
    apply totalize_symm...
Qed.

Lemma plain_map_totalize (m : map) (z z' : point) :
  simple_map m -> m z z' -> totalize m z z'.
Proof.
  intros. red. auto.
Qed.

Lemma totalize_cover_subregion (m : map) :
  simple_map m -> subregion (cover m) (cover (totalize m)).
Proof.
  unfold subregion, cover. intros. apply plain_map_totalize; auto.
Qed.

Lemma totalize_open (m : map) (z1 z2 : point) :
  simple_map m ->
  totalize m z1 z2 -> open (totalize m z1) -> m z1 z2.
Proof with auto.
  intros. inversion H0...
  exfalso.
  destruct H2 as [z3 [z4 [? [? [? [[? ?] [? ?]]]]]]].
  destruct (H1 z2) as [u ?]...
  assert (totalize m z1 z3).
  { destruct H7.
    assert (meet (m z3) (in_rectangle u)).
    { apply H7... red. intros. exists u... }
    destruct H12 as [z5 [? ?]].
    assert (totalize m z1 z5)...
    apply totalize_trans with z5... left. apply map_symm... }
  assert (totalize m z1 z4).
  { destruct H7.
    assert (meet (m z4) (in_rectangle u)).
    { apply H12... red. intros. exists u... }
    destruct H13 as [z5 [? ?]].
    assert (totalize m z1 z5)...
    apply totalize_trans with z5... left; apply map_symm... }
  assert (totalize m z3 z4).
  { apply totalize_trans with z1... apply totalize_symm... }
  destruct H13.
  - contradiction.
  - destruct H13 as [z5 [z6 [? [? [? [[? ?] _]]]]]].
    apply border_not_covered in H16...
Qed.

Lemma totalize_preserves_corner_map (m : map) (x z1 z2 : point) :
  simple_map m -> corner_map m x z1 z2 <-> corner_map (totalize m) x z1 z2.
Proof with auto.
  split; unfold corner_map; intros [? [? ?]].
  - splits.
    + red. intros. destruct H3.
      { destruct (H0 z)... exists x0...
        apply subregion_trans with (m z1)...
        apply totalize_subregion. }
      { exfalso.
        destruct H3 as [z3 [z4 [_ [_ [? [? ?]]]]]].
        destruct H4.
        apply border_not_covered in H4...
        apply H4. apply map_covered_left in H1... }
    + left...
    + repeat red. intros.
      repeat red in H2. destruct (H2 u) as [z ?]...
      exists z. destruct H5. split... left...
  - splits.
    + red. intros. unfold open in H0. destruct (H0 z) as [u ?]... left...
      exists u... unfold subregion in H5.
      red; intros.
      destruct (H5 z0)...
      exfalso. destruct H7 as [z3 [z4 [_ [_ [? [[? ?] _]]]]]].
      apply border_not_covered in H8...
      apply H8. apply map_covered_left in H3...
    + apply totalize_open...
    + repeat red. intros.
      destruct (H2 u) as [z ?]... exists z... destruct H5. split...
      apply totalize_open...
Qed.

Lemma totalize_preserves_not_corner (m : map) (x : point) :
  simple_map m -> not_corner m x -> not_corner (totalize m) x.
Proof.
  unfold not_corner, at_most_regions. intros.
  destruct H0 as [f ?]. exists f. intros.
  assert (exists2 i : nat, i < 2 & corner_map m x (f i) z).
  { apply H0. apply totalize_preserves_corner_map; auto. }
  destruct H2 as [i ?].
  exists i; auto. rewrite <- totalize_preserves_corner_map; auto.
Qed.

Record tcoloring (m k : map) : Prop := TColoring {
  tcoloring_coloring : coloring (totalize m) k;
  tcoloring_adjacent z :
    forall z1 z2 : point,
    adjacent (totalize m) z z1 -> adjacent (totalize m) z z2 -> ~ k z1 z2
}.

Definition tcolorable_with (n : nat) (m : map) : Prop :=
  exists2 k, tcoloring m k & at_most_regions n k.

Lemma tcoloring_is_coloring :
  forall m k : map, simple_map m -> tcoloring m k -> coloring m k.
Proof with auto.
  intros. destruct H0. destruct tcoloring_coloring0.
  split...
  - apply subregion_trans with (cover (totalize m))...
    apply totalize_cover_subregion...
  - apply submap_trans with (totalize m)...
    repeat red...
  - (* any adjacent two faces in m are colored differently *)
    intros z1 z2 [? ? ? [? [? ?]]].
    assert (~ m x x). { apply border_not_covered with z1 z2... }
    apply tcoloring_adjacent0 with x.
    + (* adjacent (totalize m) x z1 *)
      split.
      { right. exists z1, z2. repeat (split; auto). }
      { left... }
      { (* ~ totalize m x z1 *)
        intros F. destruct F.
        - (* m x z1 を仮定する場合 *)
          apply map_covered_left in H3...
        - (* z1が境界上にあることを仮定する場合 *)
          destruct H3 as [z3 [z4 [? [? [? [? ?]]]]]].
          destruct H7. apply border_not_covered in H7... }
      { (* meet (not_corner (totalize m)) (border (totalize m) x z1) *)
        exists x. split.
        - apply totalize_preserves_not_corner...
        - split.
          + apply closure_supregion... right.
            exists z1, z2... destruct H1. repeat split...
          + destruct H1.
            cut (subregion (closure (m z1)) (closure (totalize m z1)))...
            apply closure_preserves_subregion. apply totalize_subregion. }
    + (* same as previous one! *)
      split.
      { right. exists z1, z2. repeat (split; auto). }
      { left... } { unfold totalize. intros F. destruct F.
        - apply map_covered_left in H3...
        - destruct H3 as [z3 [z4 [? [? [? [? ?]]]]]].
          destruct H7. apply border_not_covered in H7... }
      { exists x. split.
        - apply totalize_preserves_not_corner...
        - split.
          + apply closure_supregion... right.
            exists z1, z2... destruct H1. repeat split...
          + destruct H1.
            cut (subregion (closure (m z2)) (closure (totalize m z2)))...
            apply closure_preserves_subregion. apply totalize_subregion. }
Qed.

Theorem coloring_leq_tcoloring (m : map) (n : nat) :
  simple_map m -> tcolorable_with n m -> colorable_with n m.
Proof with auto.
  intros H [k H0 H1]. exists k... apply tcoloring_is_coloring...
Qed.

Record incident (m : map) (z1 z2 : point) : Prop := Incident {
  incident_not_same_edge : ~ totalize m z1 z2;
  incident_common_adjacent : exists z, adjacent (totalize m) z z1 /\ adjacent (totalize m) z z2
}.

Definition edge (m : map) : map :=
  fun z z' =>
    (* z1, z2を含むregionの間にある点 *)
    (exists z1 z2 : point,
      m z1 z1 /\ m z2 z2 /\ ~ m z1 z2 /\
      intersect (border m z1 z2) (not_corner m) z /\
      intersect (border m z1 z2) (not_corner m) z').

Record ecoloring (m k : map) : Prop := EColoring {
  ecoloring_plain : plain_map k;
  ecoloring_cover : subregion (cover (edge m)) (cover k);
  ecoloring_consistent : submap (edge m) k;
  ecoloring_incident z1 z2 :
    incident m z1 z2 -> ~ k z1 z2
}.

Definition ecolorable_with (n : nat) (m : map) : Prop :=
  exists2 k, ecoloring m k & at_most_regions n k.

Theorem tcoloring_is_ecoloring (m k : map) :
  simple_map m -> tcoloring m k -> ecoloring m k.
Proof with auto.
  intros. inversion H0. split.
  - apply coloring_plain with m... apply tcoloring_is_coloring...
  - destruct tcoloring_coloring0. apply subregion_trans with (cover (totalize m))...
    red. intros. repeat red. right...
  - destruct tcoloring_coloring0. apply submap_trans with (totalize m)...
    repeat red. intros. right...
  - intros. destruct H1. destruct incident_common_adjacent0 as [z [? ?]].
    eapply tcoloring_adjacent0 with z...
Qed.

Theorem ecoloring_leq_tcoloring (m : map) (n : nat) :
  simple_map m -> tcolorable_with n m -> ecolorable_with n m.
Proof with auto.
  intros ? [k ? ?]. exists k... apply tcoloring_is_ecoloring...
Qed.

Theorem tcoloring_leq_coloring_and_ecoloring (m : map) (n n' : nat) :
  colorable_with n m -> ecolorable_with n' m ->
  tcolorable_with (n + n') m.
Proof.
  intros [k ?] [k' ?].
  red.
Admitted.

Definition num_of_regions (n : nat) (m : map) : Prop :=
  ~ (at_most_regions (n - 1) m) /\ at_most_regions n m.

(* alias *)
Definition num_of_vertices := num_of_regions.

Definition num_of_edges (n : nat) (m : map) : Prop :=
  ~ (at_most_regions (n - 1) (edge m)) /\ at_most_regions n (edge m).

(*
Definition num_of_faces (n : nat) (m : map) : Prop :=
  ~ (at_most_regions (n - 1) (corner_map m)) /\ at_most_regions n (corner_map m).
*)


(** 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 (z : natural) (y : natural) : natural := plus (mult y z) z.


Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

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

Fixpoint rev2 (l : lst) (a : lst) : lst :=
  match l with
  | Nil => a
  | Cons x t => rev2 t (Cons x a)
  end.

Lemma rev2_append_aux : forall x a b : lst,
  append (rev2 x Nil) (append a b) = append (rev2 x a) b.
Proof.
  intro x.
  induction x.
  - reflexivity.
  - intros. simpl.
    rewrite <- (IHx (Cons n a)).
    rewrite <- IHx.
    reflexivity.
Qed.

Lemma append_single : forall (n : nat) (a : lst),
  append (Cons n Nil) a = Cons n a.
Proof.
  reflexivity.
Qed.

Theorem rev2_append : forall x a : lst, rev2 x a = append (rev2 x Nil) a.
Proof.
  intro x.
  induction x.
  - reflexivity.
  - intros. simpl.
    rewrite IHx.
    rewrite <- append_single.
    rewrite rev2_append_aux.
    reflexivity.
Qed.