Require Import Basic_Notations_Set.
Require Import Basic_Lemmas.
Require Import Logic.FunctionalExtensionality.
Require Import Logic.Classical_Prop.

Module main (def : Relation).
Import def.
Module Basic_Lemmas := Basic_Lemmas.main def.
Import Basic_Lemmas.

(** %
\section{関係計算の基本的な性質}
% **)

(** %
\begin{screen}
\begin{lemma}[RelAB\_unique]
$$
\phi_{AB} = \nabla_{AB} \Leftrightarrow \forall \alpha , \beta :A \rel B, \alpha = \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma RelAB_unique {A B : eqType}:
φ A B = ∇ A B <-> (forall alpha beta : Rel A B, alpha = beta).
Proof.
split; move => H.
move => alpha beta.
replace beta with (φ A B).
apply inc_antisym.
rewrite H.
apply inc_alpha_universal.
apply inc_empty_alpha.
apply inc_antisym.
apply inc_empty_alpha.
rewrite H.
apply inc_alpha_universal.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[either\_empty]
$$
\phi_{AB} = \nabla_{AB} \Leftrightarrow A = \emptyset \lor B = \emptyset.
$$
\end{lemma}
\end{screen}
% **)
Lemma either_empty {A B : eqType}: φ A B = ∇ A B <-> (A -> False) \/ (B -> False).
Proof.
rewrite RelAB_unique.
split; move => H.
case (classic (exists _ : A, True)).
elim => a H0.
right.
move => b.
remember (fun (_ : A) (_ : B) => True) as T.
remember (fun (_ : A) (_ : B) => False) as F.
move : (H T F) => H1.
assert (T a b = F a b).
by [rewrite H1].
rewrite HeqT HeqF in H2.
rewrite -H2.
apply I.
move => H0.
left.
move => a.
apply H0.
exists a.
apply I.
move => alpha beta.
assert (A -> B -> False).
move => a b.
case H; move => H0.
apply (H0 a).
apply (H0 b).
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply False_ind.
apply (H0 a b).
Qed.

(** %
\begin{screen}
\begin{lemma}[unit\_empty\_not\_universal]
$$
\phi_{II} \neq \nabla_{II}.
$$
\end{lemma}
\end{screen}
% **)
Lemma unit_empty_not_universal : φ i i <> ∇ i i.
Proof.
move => H.
apply either_empty in H.
case H; move => H0.
apply (H0 tt).
apply (H0 tt).
Qed.

(** %
\begin{screen}
\begin{lemma}[unit\_empty\_or\_universal]
Let $\alpha :I \rel I$. Then,
$$
\alpha = \phi_{II} \lor \alpha = \nabla_{II}.
$$
\end{lemma}
\end{screen}
% **)
Lemma unit_empty_or_universal {alpha : Rel i i}: alpha = φ i i \/ alpha = ∇ i i.
Proof.
assert (forall beta : Rel i i, beta = (fun (_ _ : i) => True) \/ beta = (fun (_ _ : i) => False)).
move => beta.
case (classic (beta tt tt)); move => H.
left.
apply functional_extensionality.
induction x.
apply functional_extensionality.
induction x.
apply prop_extensionality_ok.
split; move => H0.
apply I.
apply H.
right.
apply functional_extensionality.
induction x.
apply functional_extensionality.
induction x.
apply prop_extensionality_ok.
split.
apply H.
apply False_ind.
assert ((fun _ _ : i => True) <> (fun _ _ : i => False)).
move => H0.
remember (fun _ _ : i => True) as T.
remember (fun _ _ : i => False) as F.
assert (T tt tt = F tt tt).
by [rewrite H0].
rewrite HeqT HeqF in H1.
rewrite -H1.
apply I.
case (H (φ i i)); move => H1.
case (H (∇ i i)); move => H2.
apply False_ind.
apply unit_empty_not_universal.
by [rewrite H1 H2].
case (H alpha); move => H3.
left.
by [rewrite H3 H1].
right.
by [rewrite H3 H2].
case (H (∇ i i)); move => H2.
case (H alpha); move => H3.
right.
by [rewrite H3 H2].
left.
by [rewrite H3 H1].
apply False_ind.
apply unit_empty_not_universal.
by [rewrite H1 H2].
Qed.

(** %
\begin{screen}
\begin{lemma}[unit\_identity\_is\_universal]
$$
id_I = \nabla_{II}.
$$
\end{lemma}
\end{screen}
% **)
Lemma unit_identity_is_universal : Id i = ∇ i i.
Proof.
case (@unit_empty_or_universal (Id i)); move => H.
apply False_ind.
assert (Id i ⊆ (∇ i i # △ φ i i)).
rewrite H.
apply inc_empty_alpha.
apply inc_residual in H0.
rewrite inv_invol comp_id_r in H0.
apply unit_empty_not_universal.
apply inc_antisym.
apply inc_empty_alpha.
apply H0.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[unit\_identity\_not\_empty]
$$
id_I \neq \phi_{II}.
$$
\end{lemma}
\end{screen}
% **)
Lemma unit_identity_not_empty : Id i <> φ i i.
Proof.
move => H.
apply unit_empty_not_universal.
rewrite -H.
apply unit_identity_is_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[cupP\_False]
Let $f:(C \rel D) \to (A \rel B)$ and $P(\alpha):=$ ``False''. Then,
$$
\sqcup_{P(\alpha)} f(\alpha) = \phi_{AB}.
$$
\end{lemma}
\end{screen}
% **)
Lemma cupP_False {A B C D : eqType} {f : Rel C D -> Rel A B}:
 ∪_{fun _ : Rel C D => False} f = φ A B.
Proof.
apply inc_antisym.
apply inc_cupP.
move => beta.
apply False_ind.
apply inc_empty_alpha.
Qed.

(** %
\begin{screen}
\begin{lemma}[capP\_False]
Let $f:(C \rel D) \to (A \rel B)$ and $P(\alpha):=$ ``False''. Then,
$$
\sqcap_{P(\alpha)} f(\alpha) = \nabla_{AB}.
$$
\end{lemma}
\end{screen}
% **)
Lemma capP_False {A B C D : eqType} {f : Rel C D -> Rel A B}:
 ∩_{fun _ : Rel C D => False} f = ∇ A B.
Proof.
apply inc_antisym.
apply inc_alpha_universal.
apply inc_capP.
move => beta.
apply False_ind.
Qed.

(** %
\begin{screen}
\begin{lemma}[cupP\_eq]
Let $f,g:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\forall \alpha :C \rel D, P(\alpha) \Rightarrow f(\alpha) = g(\alpha)) \Rightarrow \sqcup_{P(\alpha)} f(\alpha) = \sqcup_{P(\alpha)} g(\alpha).
$$
\end{lemma}
\end{screen}
% **)
Lemma cupP_eq {A B C D : eqType}
 {f g : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (forall alpha : Rel C D, P alpha -> f alpha = g alpha) -> ∪_{P} f = ∪_{P} g.
Proof.
move => H.
apply inc_antisym.
apply inc_cupP.
move => beta H0.
rewrite (H _ H0).
move : beta H0.
apply inc_cupP.
apply inc_refl.
apply inc_cupP.
move => beta H0.
rewrite -(H _ H0).
move : beta H0.
apply inc_cupP.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[capP\_eq]
Let $f,g:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\forall \alpha :C \rel D, P(\alpha) \Rightarrow f(\alpha) = g(\alpha)) \Rightarrow \sqcap_{P(\alpha)} f(\alpha) = \sqcap_{P(\alpha)} g(\alpha).
$$
\end{lemma}
\end{screen}
% **)
Lemma capP_eq {A B C D : eqType}
 {f g : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (forall alpha : Rel C D, P alpha -> f alpha = g alpha) -> ∩_{P} f = ∩_{P} g.
Proof.
move => H.
apply inc_antisym.
apply inc_capP.
move => beta H0.
rewrite -(H _ H0).
move : beta H0.
apply inc_capP.
apply inc_refl.
apply inc_capP.
move => beta H0.
rewrite (H _ H0).
move : beta H0.
apply inc_capP.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[cap\_cupP\_distr\_l]
Let $\alpha :A \rel B$, $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
\alpha \sqcap (\sqcup_{P(\beta)} f(\beta)) = \sqcup_{P(\beta)} (\alpha \sqcap f(\beta)).
$$
\end{lemma}
\end{screen}
% **)
Lemma cap_cupP_distr_l {A B C D : eqType}
 {alpha : Rel A B} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 alpha ∩ (∪_{P} f) = ∪_{P} (fun beta : Rel C D => alpha ∩ f beta).
Proof.
apply inc_upper.
move => gamma.
split; move => H.
apply inc_cupP.
move => beta H0.
apply (@inc_trans _ _ _ (alpha ∩ ∪_{P} f)).
apply cap_inc_compat_l.
move : H0.
apply inc_cupP.
apply inc_refl.
apply H.
assert (forall beta : Rel C D, P beta -> (alpha ∩ f beta) ⊆ gamma).
apply inc_cupP.
apply H.
assert (forall beta : Rel C D, P beta -> f beta ⊆ (alpha >> gamma)).
move => beta H1.
rewrite inc_rpc cap_comm.
apply (H0 _ H1).
rewrite cap_comm -inc_rpc.
apply inc_cupP.
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[cap\_cupP\_distr\_r]
Let $\beta :A \rel B$, $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcup_{P(\alpha)} f(\alpha)) \sqcap \beta = \sqcup_{P(\alpha)} (f(\alpha) \sqcap \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma cap_cupP_distr_r {A B C D : eqType}
 {beta : Rel A B} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (∪_{P} f) ∩ beta = ∪_{P} (fun alpha : Rel C D => f alpha ∩ beta).
Proof.
rewrite cap_comm.
replace (fun alpha : Rel C D => f alpha ∩ beta) with  (fun alpha : Rel C D => beta ∩ f alpha).
apply cap_cupP_distr_l.
apply functional_extensionality.
move => x.
by [rewrite cap_comm].
Qed.

(** %
\begin{screen}
\begin{lemma}[cup\_capP\_distr\_l]
Let $\alpha :A \rel B$, $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
\alpha \sqcup (\sqcap_{P(\beta)} f(\beta)) = \sqcap_{P(\beta)} (\alpha \sqcup f(\beta)).
$$
\end{lemma}
\end{screen}
% **)
Lemma cup_capP_distr_l {A B C D : eqType}
 {alpha : Rel A B} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 alpha ∪ (∩_{P} f) = ∩_{P} (fun beta : Rel C D => alpha ∪ f beta).
Proof.
apply inc_lower.
move => gamma.
split; move => H.
apply inc_capP.
move => beta H0.
apply (@inc_trans _ _ _ (alpha ∪ ∩_{P} f)).
apply H.
apply cup_inc_compat_l.
move : H0.
apply inc_capP.
apply inc_refl.
rewrite bool_lemma3.
assert (forall beta : Rel C D, P beta -> gamma ⊆ (alpha ∪ f beta)).
apply inc_capP.
apply H.
apply inc_capP.
move => beta H1.
rewrite -bool_lemma3.
apply (H0 _ H1).
Qed.

(** %
\begin{screen}
\begin{lemma}[cup\_capP\_distr\_r]
Let $\beta :A \rel B$, $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcap_{P(\alpha)} f(\alpha)) \sqcup \beta = \sqcap_{P(\alpha)} (f(\alpha) \sqcup \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma cup_capP_distr_r {A B C D : eqType}
 {beta : Rel A B} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (∩_{P} f) ∪ beta = ∩_{P} (fun alpha : Rel C D => f alpha ∪ beta).
Proof.
rewrite cup_comm.
replace (fun alpha : Rel C D => f alpha ∪ beta) with  (fun alpha : Rel C D => beta ∪ f alpha).
apply cup_capP_distr_l.
apply functional_extensionality.
move => x.
by [rewrite cup_comm].
Qed.

(** %
\begin{screen}
\begin{lemma}[de\_morgan3]
Let $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcup_{P(\alpha)} f(\alpha))^- = (\sqcap_{P(\alpha)} f(\alpha)^-).
$$
\end{lemma}
\end{screen}
% **)
Lemma de_morgan3
 {A B C D : eqType} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (∪_{P} f) ^ = ∩_{P} (fun alpha : Rel C D => f alpha ^).
Proof.
apply inc_lower.
move => gamma.
rewrite inc_capP.
split; move => H.
move => beta H0.
rewrite bool_lemma1 -de_morgan2 complement_move complement_universal.
apply bool_lemma2 in H.
apply inc_antisym.
apply inc_empty_alpha.
rewrite -H complement_invol.
apply cap_inc_compat_l.
move : H0.
apply inc_cupP.
apply inc_refl.
rewrite bool_lemma2 complement_invol.
rewrite cap_cupP_distr_l.
apply inc_antisym.
apply inc_cupP.
move => beta H0.
rewrite -inc_rpc.
apply (H _ H0).
apply inc_empty_alpha.
Qed.

(** %
\begin{screen}
\begin{lemma}[de\_morgan4]
Let $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcap_{P(\alpha)} f(\alpha))^- = (\sqcup_{P(\alpha)} f(\alpha)^-).
$$
\end{lemma}
\end{screen}
% **)
Lemma de_morgan4
 {A B C D : eqType} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (∩_{P} f) ^ = ∪_{P} (fun alpha : Rel C D => f alpha ^).
Proof.
rewrite -complement_move de_morgan3.
replace (fun alpha : Rel C D => (f alpha ^) ^) with f.
by [].
apply functional_extensionality.
move => x.
by [rewrite complement_invol].
Qed.

(** %
\begin{screen}
\begin{lemma}[cup\_to\_cupP]
Let $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
f(\alpha) \sqcup f(\beta) = \sqcup_{\gamma = \alpha \lor \gamma = \beta} f(\gamma).
$$
\end{lemma}
\end{screen}
% **)
Lemma cup_to_cupP
 {A B C D : eqType} {alpha beta : Rel C D} {f : Rel C D -> Rel A B}:
 (f alpha ∪ f beta) = ∪_{fun gamma : Rel C D => gamma = alpha \/ gamma = beta} f.
Proof.
apply inc_upper.
move => delta.
split; move => H.
apply inc_cupP.
apply inc_cup in H.
move => gamma H0.
case H0 => H1.
rewrite H1.
apply H.
rewrite H1.
apply H.
apply inc_cup.
assert (forall gamma : Rel C D, gamma = alpha \/ gamma = beta -> f gamma ⊆ delta).
apply inc_cupP.
apply H.
split.
apply (H0 alpha).
by [left].
apply (H0 beta).
by [right].
Qed.

(** %
\begin{screen}
\begin{lemma}[cap\_to\_capP]
Let $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
f(\alpha) \sqcap f(\beta) = \sqcap_{\gamma = \alpha \lor \gamma = \beta} f(\gamma).
$$
\end{lemma}
\end{screen}
% **)
Lemma cap_to_capP
 {A B C D : eqType} {alpha beta : Rel C D} {f : Rel C D -> Rel A B}:
 (f alpha ∩ f beta) = ∩_{fun gamma : Rel C D => gamma = alpha \/ gamma = beta} f.
Proof.
apply inc_lower.
move => delta.
split; move => H.
apply inc_capP.
apply inc_cap in H.
move => gamma H0.
case H0 => H1.
rewrite H1.
apply H.
rewrite H1.
apply H.
apply inc_cap.
assert (forall gamma : Rel C D, gamma = alpha \/ gamma = beta -> delta ⊆ f gamma).
apply inc_capP.
apply H.
split.
apply (H0 alpha).
by [left].
apply (H0 beta).
by [right].
Qed.

(** %
\section{comp\_inc\_compat と派生補題}
\begin{screen}
\begin{lemma}[comp\_inc\_compat\_ab\_ab']
Let $\alpha :A \rel B$ and $\beta , {\beta}' :B \rel C$. Then,
$$
\beta \sqsubseteq {\beta}' \Rightarrow \alpha \cdot \beta \sqsubseteq \alpha \cdot {\beta}'.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inc_compat_ab_ab'
 {A B C : eqType} {alpha : Rel A B} {beta beta' : Rel B C}:
 beta ⊆ beta' -> (alpha ・ beta) ⊆ (alpha ・ beta').
Proof.
move => H.
replace (alpha ・ beta) with ((alpha #) # ・ beta).
apply inc_residual.
apply (@inc_trans _ _ _ beta').
apply H.
apply inc_residual.
rewrite inv_invol.
apply inc_refl.
by [rewrite inv_invol].
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inc\_compat\_ab\_a'b]
Let $\alpha , {\alpha}' :A \rel B$ and $\beta :B \rel C$. Then,
$$
\alpha \sqsubseteq {\alpha}' \Rightarrow \alpha \cdot \beta \sqsubseteq {\alpha}' \cdot \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inc_compat_ab_a'b
 {A B C : eqType} {alpha alpha' : Rel A B} {beta : Rel B C}:
 alpha ⊆ alpha' -> (alpha ・ beta) ⊆ (alpha' ・ beta).
Proof.
move => H.
rewrite -(@inv_invol _ _ (alpha ・ beta)).
rewrite -(@inv_invol _ _ (alpha' ・ beta)).
apply inc_inv.
rewrite comp_inv comp_inv.
apply comp_inc_compat_ab_ab'.
apply inc_inv.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inc\_compat]
Let $\alpha , {\alpha}' :A \rel B$ and $\beta , {\beta}' :B \rel C$. Then,
$$
\alpha \sqsubseteq {\alpha}' \land \beta \sqsubseteq {\beta}' \Rightarrow \alpha \cdot \beta \sqsubseteq {\alpha}' \cdot {\beta}'.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inc_compat
 {A B C : eqType} {alpha alpha' : Rel A B} {beta beta' : Rel B C}:
 alpha ⊆ alpha' -> beta ⊆ beta' -> (alpha ・ beta) ⊆ (alpha' ・ beta').
Proof.
move => H H0.
apply (@inc_trans _ _ _ (alpha' ・ beta)).
apply (@comp_inc_compat_ab_a'b _ _ _ _ _ _ H).
apply (@comp_inc_compat_ab_ab' _ _ _ _ _ _ H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inc\_compat\_ab\_a]
Let $\alpha :A \rel B$ and $\beta :B \rel B$. Then,
$$
\beta \sqsubseteq id_B \Rightarrow \alpha \cdot \beta \sqsubseteq \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inc_compat_ab_a {A B : eqType} {alpha : Rel A B} {beta : Rel B B}:
 beta ⊆ Id B -> (alpha ・ beta) ⊆ alpha.
Proof.
move => H.
move : (@comp_inc_compat_ab_ab' _ _ _ alpha _ _ H) => H0.
rewrite comp_id_r in H0.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inc\_compat\_a\_ab]
Let $\alpha :A \rel B$ and $\beta :B \rel B$. Then,
$$
id_B \sqsubseteq \beta \Rightarrow \beta \sqsubseteq \alpha \cdot \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inc_compat_a_ab {A B : eqType} {alpha : Rel A B} {beta : Rel B B}:
 Id B ⊆ beta -> alpha ⊆ (alpha ・ beta).
Proof.
move => H.
move : (@comp_inc_compat_ab_ab' _ _ _ alpha _ _ H) => H0.
rewrite comp_id_r in H0.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inc\_compat\_ab\_b]
Let $\alpha :A \rel A$ and $\beta :A \rel B$. Then,
$$
\alpha \sqsubseteq id_A \Rightarrow \alpha \cdot \beta \sqsubseteq \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inc_compat_ab_b {A B : eqType} {alpha : Rel A A} {beta : Rel A B}:
 alpha ⊆ Id A -> (alpha ・ beta) ⊆ beta.
Proof.
move => H.
move : (@comp_inc_compat_ab_a'b _ _ _ _ _ beta H) => H0.
rewrite comp_id_l in H0.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inc\_compat\_b\_ab]
Let $\alpha :A \rel A$ and $\beta :A \rel B$. Then,
$$
id_A \sqsubseteq \alpha \Rightarrow \beta \sqsubseteq \alpha \cdot \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inc_compat_b_ab {A B : eqType} {alpha : Rel A A} {beta : Rel A B}:
 Id A ⊆ alpha -> beta ⊆ (alpha ・ beta).
Proof.
move => H.
move : (@comp_inc_compat_ab_a'b _ _ _ _ _ beta H) => H0.
rewrite comp_id_l in H0.
apply H0.
Qed.

(** %
\section{逆関係に関する補題}
\begin{screen}
\begin{lemma}[inv\_move]
Let $\alpha :A \rel B$ and $\beta :B \rel A$. Then,
$$
\alpha = \beta^\sharp \Leftrightarrow \alpha^\sharp = \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_move {A B : eqType} {alpha : Rel A B} {beta : Rel B A}:
 alpha = beta # <-> alpha # = beta.
Proof.
split; move => H.
by [rewrite H inv_invol].
by [rewrite -H inv_invol].
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inv\_inv]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then,
$$
\alpha \cdot \beta = (\beta^\sharp \cdot \alpha^\sharp)^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_inv_inv {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 alpha ・ beta = (beta # ・ alpha #) #.
Proof.
apply inv_move.
apply comp_inv.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_inc\_move]
Let $\alpha :A \rel B$ and $\beta :B \rel A$. Then,
$$
\alpha \sqsubseteq \beta^\sharp \Leftrightarrow \alpha^\sharp \sqsubseteq \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_inc_move {A B : eqType} {alpha : Rel A B} {beta : Rel B A}:
 alpha ⊆ beta # <-> alpha # ⊆ beta.
Proof.
split; move => H.
rewrite -(@inv_invol _ _ beta).
apply inc_inv.
apply H.
rewrite -(@inv_invol _ _ alpha).
apply inc_inv.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_invol2]
Let $\alpha, \beta :A \rel B$. Then,
$$
\alpha^\sharp = \beta^\sharp \Rightarrow \alpha = \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_invol2 {A B : eqType} {alpha beta : Rel A B}:
 alpha # = beta # -> alpha = beta.
Proof.
move => H.
rewrite -(@inv_invol _ _ alpha) -(@inv_invol _ _ beta).
apply f_equal.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_inc\_invol]
Let $\alpha, \beta :A \rel B$. Then,
$$
\alpha^\sharp \sqsubseteq \beta^\sharp \Rightarrow \alpha \sqsubseteq \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_inc_invol {A B : eqType} {alpha beta : Rel A B}:
 alpha # ⊆ beta # -> alpha ⊆ beta.
Proof.
move => H.
rewrite -(@inv_invol _ _ alpha) -(@inv_invol _ _ beta).
apply inc_inv.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_cupP\_distr, inv\_cup\_distr]
Let $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcup_{P(\alpha)} f(\alpha))^\sharp = (\sqcup_{P(\alpha)} f(\alpha)^\sharp).
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_cupP_distr {A B C D : eqType} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (∪_{P} f) # = (∪_{P} (fun alpha : Rel C D => f alpha #)).
Proof.
apply inc_antisym.
rewrite -inv_inc_move.
apply inc_cupP.
assert (forall beta : Rel C D, P beta -> f beta # ⊆ ∪_{P} (fun alpha : Rel C D => f alpha #)).
apply inc_cupP.
apply inc_refl.
move => beta H0.
rewrite inv_inc_move.
apply (H _ H0).
apply inc_cupP.
move => beta H0.
apply inc_inv.
move : H0.
apply inc_cupP.
apply inc_refl.
Qed.

Lemma inv_cup_distr {A B : eqType} {alpha beta : Rel A B}:
 (alpha ∪ beta) # = alpha # ∪ beta #.
Proof.
by [rewrite cup_to_cupP -inv_cupP_distr -cup_to_cupP].
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_capP\_distr, inv\_cap\_distr]
Let $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcap_{P(\alpha)} f(\alpha))^\sharp = (\sqcap_{P(\alpha)} f(\alpha)^\sharp).
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_capP_distr {A B C D : eqType} {f : Rel C D -> Rel A B} {P : Rel C D -> Prop}:
 (∩_{P} f) # = (∩_{P} (fun alpha : Rel C D => f alpha #)).
Proof.
apply inc_antisym.
apply inc_capP.
move => beta H.
apply inc_inv.
move : H.
apply inc_capP.
apply inc_refl.
rewrite inv_inc_move.
apply inc_capP.
assert (forall beta : Rel C D, P beta -> ∩_{P} (fun alpha : Rel C D => f alpha #) ⊆ f beta #).
apply inc_capP.
apply inc_refl.
move => beta H0.
rewrite -inv_inc_move.
apply (H _ H0).
Qed.

Lemma inv_cap_distr {A B : eqType} {alpha beta : Rel A B}:
 (alpha ∩ beta) # = alpha # ∩ beta #.
Proof.
by [rewrite cap_to_capP -inv_capP_distr -cap_to_capP].
Qed.

(** %
\begin{screen}
\begin{lemma}[rpc\_inv\_distr]
Let $\alpha, \beta :A \rel B$. Then,
$$
(\alpha \Rightarrow \beta)^\sharp = \alpha^\sharp \Rightarrow \beta^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma rpc_inv_distr {A B : eqType} {alpha beta : Rel A B}:
 (alpha >> beta) # = alpha # >> beta #.
Proof.
apply inc_lower.
move => gamma.
split; move => H.
apply inc_rpc.
rewrite inv_inc_move inv_cap_distr inv_invol.
rewrite -inc_rpc -inv_inc_move.
apply H.
rewrite inv_inc_move inc_rpc.
rewrite -(@inv_invol _ _ alpha) -inv_cap_distr -inv_inc_move.
apply inc_rpc.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_empty]
$$
{\phi_{AB}}^\sharp = \phi_{BA}.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_empty {A B : eqType}: φ A B # = φ B A.
Proof.
apply inc_antisym.
rewrite -inv_inc_move.
apply inc_empty_alpha.
apply inc_empty_alpha.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_universal]
$$
{\nabla_{AB}}^\sharp = \nabla_{BA}.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_universal {A B : eqType}: ∇ A B # = ∇ B A.
Proof.
apply inc_antisym.
apply inc_alpha_universal.
rewrite inv_inc_move.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_id]
$$
{id_A}^\sharp = id_A.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_id {A : eqType}: (Id A) # = Id A.
Proof.
replace (Id A #) with ((Id A #) # ・ Id A #).
by [rewrite -comp_inv comp_id_l inv_invol].
by [rewrite inv_invol comp_id_l].
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_complement]
Let $\alpha :A \rel B$. Then,
$$
(\alpha^-)^\sharp = (\alpha^\sharp)^-.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_complement {A B : eqType} {alpha : Rel A B}: (alpha ^) # = (alpha #) ^.
Proof.
apply inc_antisym.
apply inc_rpc.
rewrite -inv_cap_distr.
rewrite cap_comm -inv_inc_move inv_empty.
rewrite cap_complement_empty.
apply inc_refl.
rewrite inv_inc_move.
apply inc_rpc.
replace (((alpha #) ^) # ∩ alpha) with (((alpha #) ^) # ∩ (alpha #) #).
rewrite -inv_cap_distr.
rewrite cap_comm -inv_inc_move inv_empty.
rewrite cap_complement_empty.
apply inc_refl.
by [rewrite inv_invol].
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_difference\_distr]
Let $\alpha , \beta :A \rel B$. Then,
$$
(\alpha - \beta)^\sharp = \alpha^\sharp - \beta^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_difference_distr {A B : eqType} {alpha beta : Rel A B}:
 (alpha -- beta) # = alpha # -- beta #.
Proof.
rewrite inv_cap_distr.
by [rewrite inv_complement].
Qed.

(** %
\section{合成に関する補題}
\begin{screen}
\begin{lemma}[comp\_cupP\_distr\_l, comp\_cup\_distr\_l]
Let $\alpha :A \rel B$, $f:(D \rel E) \to (B \rel C)$ and $P$ : predicate. Then,
$$
\alpha \cdot (\sqcup_{P(\beta)} f(\beta)) = \sqcup_{P(\beta)} (\alpha \cdot f(\beta)).
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_cupP_distr_l {A B C D E : eqType}
 {alpha : Rel A B} {f : Rel D E -> Rel B C} {P : Rel D E -> Prop}:
 alpha ・ (∪_{P} f) = ∪_{P} (fun beta : Rel D E => (alpha ・ f beta)).
Proof.
apply inc_upper.
move => gamma.
split; move => H.
rewrite -(@inv_invol _ _ alpha) in H.
apply inc_residual in H.
apply inc_cupP.
assert (forall beta : Rel D E, P beta -> f beta ⊆ (alpha # △ gamma)).
apply inc_cupP.
apply H.
move => beta H1.
rewrite -(@inv_invol _ _ alpha).
apply inc_residual.
apply (H0 _ H1).
rewrite -(@inv_invol _ _ alpha).
apply inc_residual.
apply inc_cupP.
assert (forall beta : Rel D E, P beta -> (alpha ・ f beta) ⊆ gamma).
apply inc_cupP.
apply H.
move => beta H1.
apply inc_residual.
rewrite inv_invol.
apply (H0 _ H1).
Qed.

Lemma comp_cup_distr_l
 {A B C : eqType} {alpha : Rel A B} {beta gamma : Rel B C}:
 alpha ・ (beta ∪ gamma) = (alpha ・ beta) ∪ (alpha ・ gamma).
Proof.
by [rewrite cup_to_cupP -comp_cupP_distr_l -cup_to_cupP].
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_cupP\_distr\_r, comp\_cup\_distr\_r]
Let $f:(D \rel E) \to (A \rel B)$, $\beta :B \rel C$ and $P$ : predicate. Then,
$$
(\sqcup_{P(\alpha)} f(\alpha)) \cdot \beta = \sqcup_{P(\alpha)} (f(\alpha) \cdot \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_cupP_distr_r {A B C D E : eqType}
 {beta : Rel B C} {f : Rel D E -> Rel A B} {P : Rel D E -> Prop}:
 (∪_{P} f) ・ beta = ∪_{P} (fun alpha : Rel D E => (f alpha ・ beta)).
Proof.
replace (fun alpha : Rel D E => f alpha ・ beta) with (fun alpha : Rel D E => (beta # ・ f alpha #) #).
rewrite -inv_cupP_distr.
rewrite -comp_cupP_distr_l.
rewrite -inv_cupP_distr.
rewrite comp_inv.
by [rewrite inv_invol inv_invol].
apply functional_extensionality.
move => x.
rewrite comp_inv.
by [rewrite inv_invol inv_invol].
Qed.

Lemma comp_cup_distr_r
 {A B C : eqType} {alpha beta : Rel A B} {gamma : Rel B C}:
 (alpha ∪ beta) ・ gamma = (alpha ・ gamma) ∪ (beta ・ gamma).
Proof.
by [rewrite (@cup_to_cupP _ _ _ _ _ _ id) comp_cupP_distr_r -cup_to_cupP].
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_capP\_distr]
Let $\alpha :A \rel B$, $\gamma :C \rel D$, $f:(E \rel F) \to (B \rel C)$ and $P$ : predicate. Then,
$$
\alpha \cdot (\sqcap_{P(\beta)} f(\beta)) \cdot \gamma \sqsubseteq \sqcap_{P(\beta)} (\alpha \cdot f(\beta) \cdot \gamma).
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_capP_distr {A B C D E F : eqType}
 {alpha : Rel A B} {gamma : Rel C D}
 {f : Rel E F -> Rel B C} {P : Rel E F -> Prop}:
 (alpha ・ (∩_{P} f)) ・ gamma
 ⊆ ∩_{P} (fun beta : Rel E F => ((alpha ・ f beta) ・ gamma)).
Proof.
apply inc_capP.
move => beta H.
apply comp_inc_compat_ab_a'b.
apply comp_inc_compat_ab_ab'.
move : H.
apply inc_capP.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_capP\_distr\_l, comp\_cap\_distr\_l]
Let $\alpha :A \rel B$, $f:(D \rel E) \to (B \rel C)$ and $P$ : predicate. Then,
$$
\alpha \cdot (\sqcap_{P(\beta)} f(\beta)) \sqsubseteq \sqcap_{P(\beta)} (\alpha \cdot f(\beta)).
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_capP_distr_l {A B C D E : eqType}
 {alpha : Rel A B} {f : Rel D E -> Rel B C} {P : Rel D E -> Prop}:
 (alpha ・ (∩_{P} f)) ⊆ ∩_{P} (fun beta : Rel D E => (alpha ・ f beta)).
Proof.
move : (@comp_capP_distr _ _ _ _ _ _ alpha (Id C) f P) => H.
rewrite comp_id_r in H.
replace (fun beta : Rel D E => (alpha ・ f beta) ・ Id C) with (fun beta : Rel D E => (alpha ・ f beta)) in H.
apply H.
apply functional_extensionality.
move => x.
by [rewrite comp_id_r].
Qed.

Lemma comp_cap_distr_l
 {A B C : eqType} {alpha : Rel A B} {beta gamma : Rel B C}:
 (alpha ・ (beta ∩ gamma)) ⊆ ((alpha ・ beta) ∩ (alpha ・ gamma)).
Proof.
rewrite cap_to_capP (@cap_to_capP _ _ _ _ _ _ id).
apply comp_capP_distr_l.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_capP\_distr\_r, comp\_cap\_distr\_r]
Let $\beta :B \rel C$, $f:(D \rel E) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcap_{P(\alpha)} f(\alpha)) \cdot \beta \sqsubseteq \sqcap_{P(\alpha)} (f(\alpha) \cdot \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_capP_distr_r
 {A B C D E : eqType} {beta : Rel B C} {f : Rel D E -> Rel A B} {P : Rel D E -> Prop}:
 ((∩_{P} f) ・ beta) ⊆ ∩_{P} (fun alpha : Rel D E => (f alpha ・ beta)).
Proof.
move : (@comp_capP_distr _ _ _ _ _ _ (Id A) beta f P) => H.
rewrite comp_id_l in H.
replace (fun alpha : Rel D E => (Id A ・ f alpha) ・ beta) with (fun alpha : Rel D E => f alpha ・ beta) in H.
apply H.
apply functional_extensionality.
move => x.
by [rewrite comp_id_l].
Qed.

Lemma comp_cap_distr_r
 {A B C : eqType} {alpha beta : Rel A B} {gamma : Rel B C}:
 ((alpha ∩ beta) ・ gamma) ⊆ ((alpha ・ gamma) ∩ (beta ・ gamma)).
Proof.
rewrite (@cap_to_capP _ _ _ _ _ _ id) (@cap_to_capP _ _ _ _ _ _ (fun x => x ・ gamma)).
apply comp_capP_distr_r.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_empty\_l, comp\_empty\_r]
Let $\alpha :A \rel B$, $\beta :B \rel C$. Then,
$$
\alpha \cdot \phi_{BC} = \phi_{AB} \cdot \beta = \phi_{AC}.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_empty_r {A B C : eqType} {alpha : Rel A B}: alpha ・ φ B C = φ A C.
Proof.
apply inc_antisym.
rewrite -(@inv_invol _ _ alpha).
apply inc_residual.
apply inc_empty_alpha.
apply inc_empty_alpha.
Qed.

Lemma comp_empty_l {A B C : eqType} {beta : Rel B C}: φ A B ・ beta = φ A C.
Proof.
rewrite -(@inv_invol _ _ (φ A B ・ beta)).
rewrite -inv_move comp_inv inv_empty inv_empty.
apply comp_empty_r.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_either\_empty]
Let $\alpha :A \rel B$, $\beta :B \rel C$. Then,
$$
\alpha = \phi_{AB} \lor \beta = \phi_{BC} \Rightarrow \alpha \cdot \beta = \phi_{AC}.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_either_empty {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 alpha = φ A B \/ beta = φ B C -> alpha ・ beta = φ A C.
Proof.
case; move => H.
rewrite H.
apply comp_empty_l.
rewrite H.
apply comp_empty_r.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_neither\_empty]
Let $\alpha :A \rel B$, $\beta :B \rel C$. Then,
$$
\alpha \cdot \beta \neq \phi_{AC} \Rightarrow \alpha \neq \phi_{AB} \land \beta \neq \phi_{BC}.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_neither_empty {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 alpha ・ beta <> φ A C -> alpha <> φ A B /\ beta <> φ B C.
Proof.
move => H.
split; move => H0.
apply H.
rewrite H0.
apply comp_empty_l.
apply H.
rewrite H0.
apply comp_empty_r.
Qed.

(** %
\section{単域と Tarski の定理}
\begin{screen}
\begin{lemma}[lemma\_for\_tarski1]
Let $\alpha :A \rel B$ and $\alpha \neq \phi_{AB}$. Then,
$$
\nabla_{IA} \cdot \alpha \cdot \nabla_{BI} = id_I.
$$
\end{lemma}
\end{screen}
% **)
Lemma lemma_for_tarski1 {A B : eqType} {alpha : Rel A B}:
 alpha <> φ A B -> ((∇ i A ・ alpha) ・ ∇ B i) = Id i.
Proof.
move => H.
assert (((∇ i A ・ alpha) ・ ∇ B i) <> φ i i).
move => H0.
apply H.
apply inc_antisym.
apply (@inc_trans _ _ _ ((∇ A i ・ ((∇ i A ・ alpha) ・ ∇ B i)) ・ ∇ i B)).
rewrite comp_assoc comp_assoc unit_universal.
rewrite -comp_assoc -comp_assoc unit_universal.
apply (@inc_trans _ _ _ ((Id A ・ alpha) ・ Id B)).
rewrite comp_id_l comp_id_r.
apply inc_refl.
apply comp_inc_compat.
apply comp_inc_compat_ab_a'b.
apply inc_alpha_universal.
apply inc_alpha_universal.
rewrite H0 comp_empty_r comp_empty_l.
apply inc_refl.
apply inc_empty_alpha.
case (@unit_empty_or_universal ((∇ i A ・ alpha) ・ ∇ B i)); move => H1.
apply False_ind.
apply (H0 H1).
rewrite unit_identity_is_universal.
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[lemma\_for\_tarski2]
$$
\nabla_{AI} \cdot \nabla_{IB} = \nabla_{AB}.
$$
\end{lemma}
\end{screen}
% **)
Lemma lemma_for_tarski2 {A B : eqType}: ∇ A i ・ ∇ i B = ∇ A B.
Proof.
apply inc_antisym.
apply inc_alpha_universal.
apply (@inc_trans _ _ _ (∇ A A ・ ∇ A B)).
apply (@inc_trans _ _ _ (Id A ・ ∇ A B)).
rewrite comp_id_l.
apply inc_refl.
apply comp_inc_compat_ab_a'b.
apply inc_alpha_universal.
rewrite -(@unit_universal A) comp_assoc.
apply comp_inc_compat_ab_ab'.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[tarski]
Let $\alpha :A \rel B$ and $\alpha \neq \phi_{AB}$. Then,
$$
\nabla_{AA} \cdot \alpha \cdot \nabla_{BB} = \nabla_{AB}.
$$
\end{lemma}
\end{screen}
% **)
Lemma tarski {A B : eqType} {alpha : Rel A B}:
 alpha <> φ A B -> ((∇ A A ・ alpha) ・ ∇ B B) = ∇ A B.
Proof.
move => H.
rewrite -(@unit_universal A) -(@unit_universal B).
move : (@lemma_for_tarski1 _ _ alpha H) => H0.
rewrite -comp_assoc (@comp_assoc _ _ _ _ (∇ A i)) (@comp_assoc _ _ _ _ (∇ A i)).
rewrite H0 comp_id_r.
apply lemma_for_tarski2.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_universal1]
Let $B \neq \emptyset$. Then,
$$
\nabla_{AB} \cdot \nabla_{BC} = \nabla_{AC}.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_universal {A B C : eqType} : B -> ∇ A B ・ ∇ B C = ∇ A C.
Proof.
move => b.
replace (∇ A B) with (∇ A B ・ ∇ B B).
rewrite -(@lemma_for_tarski2 A B) -(@lemma_for_tarski2 B C).
rewrite (@comp_assoc _ _ _ _ (∇ A i)) (@comp_assoc _ _ _ _ (∇ A i)) -(@comp_assoc _ _ _ _ _ (∇ B i)).
rewrite lemma_for_tarski1.
rewrite comp_id_l.
apply lemma_for_tarski2.
apply not_eq_sym.
move => H.
apply either_empty in H.
case H; move => H0.
apply (H0 b).
apply (H0 b).
apply inc_antisym.
apply inc_alpha_universal.
apply (@inc_trans _ _ _ (∇ A B ・ Id B)).
rewrite comp_id_r.
apply inc_refl.
apply comp_inc_compat_ab_ab'.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_universal2]
$$
{\nabla_{IA}}^\sharp \cdot \nabla_{IB} = \nabla_{AB}.
$$
\end{lemma}
\end{screen}
% **)
Lemma comp_universal2 {A B : eqType}: ∇ i A # ・ ∇ i B = ∇ A B.
Proof.
rewrite inv_universal.
apply lemma_for_tarski2.
Qed.

(** %
\begin{screen}
\begin{lemma}[empty\_equivalence1, empty\_equivalence2, empty\_equivalence3]
$$
A = \emptyset \Leftrightarrow \nabla_{IA} = \phi_{IA} \Leftrightarrow \nabla_{AA} = \phi_{AA} \Leftrightarrow id_A = \phi_{AA}.
$$
\end{lemma}
\end{screen}
% **)
Lemma empty_equivalence1 {A : eqType}: (A -> False) <-> ∇ i A = φ i A.
Proof.
move : (@either_empty i A) => H.
split; move => H0.
apply Logic.eq_sym.
apply H.
right.
apply H0.
apply Logic.eq_sym in H0.
apply H in H0.
case H0.
move => H1 H2.
apply H1.
apply tt.
by [].
Qed.

Lemma empty_equivalence2 {A : eqType}: (A -> False) <-> ∇ A A = φ A A.
Proof.
move : (@either_empty A A) => H.
split; move => H0.
apply Logic.eq_sym.
apply H.
left.
apply H0.
apply Logic.eq_sym in H0.
apply H in H0.
case H0.
by [].
by [].
Qed.

Lemma empty_equivalence3 {A : eqType}: (A -> False) <-> Id A = φ A A.
Proof.
split; move => H.
assert (∇ A A = φ A A).
apply empty_equivalence2.
apply H.
apply RelAB_unique.
apply Logic.eq_sym.
apply H0.
assert (φ A A = ∇ A A).
by [rewrite -(@comp_id_r _ _ (∇ A A)) H comp_empty_r].
apply either_empty in H0.
case H0.
by [].
by [].
Qed.

End main.


Require Import Arith.
Require Import List.
Import ListNotations.

Require Import VerdiTactics.
Require Import Util.

Require Import Net.

Require Import String.

Definition key := string.
Definition value := string.

Inductive input : Set :=
| Put : key -> value -> input
| Get : key -> input
| Del : key -> input
| CAS : key -> option value -> value -> input
| CAD : key -> value -> input.

Inductive output : Set :=
| Response : key -> option value -> option value -> output (* uniform response *)
.

Definition key_eq_dec := string_dec.
Definition value_eq_dec := string_dec.

Definition val_eq_dec : forall v v' : option value, {v = v'} + {v <> v'}.
  decide equality.
  auto using value_eq_dec.
Defined.

Theorem input_eq_dec : forall x y: input, {x = y} + {x <> y}.
Proof.
  decide equality;
  auto using key_eq_dec, value_eq_dec, val_eq_dec.
Defined.

Definition data :=
  list (key * value) %type.

Definition beq_key (k1 k2 : key) :=
  if string_dec k1 k2 then true else false.

Section assoc.
  Variable K V : Type.
  Variable K_eq_dec : forall k k' : K, {k = k'} + {k <> k'}.

  Fixpoint assoc (l : list (K * V)) (k : K) : option V :=
    match l with
      | [] => None
      | (k', v) :: l' =>
        if K_eq_dec k k' then
          Some v
        else
          assoc l' k
    end.

  Fixpoint assoc_set (l : list (K * V)) (k : K) (v : V) : list (K * V) :=
    match l with
      | [] => [(k, v)]
      | (k', v') :: l' =>
        if K_eq_dec k k' then
          (k, v) :: l'
        else
          (k', v') :: (assoc_set l' k v)
    end.

  Fixpoint assoc_del (l : list (K * V)) (k : K) : list (K * V) :=
    match l with
      | [] => []
      | (k', v') :: l' =>
        if K_eq_dec k k' then
          l'
        else
          (k', v') :: (assoc_del l' k)
    end.

  Lemma get_set_same :
    forall k v l,
      assoc (assoc_set l k v) k = Some v.
  Proof.
    induction l; intros; simpl; repeat (break_match; simpl); subst; congruence.
  Qed.

  Lemma get_set_diff :
    forall k k' v l,
      k <> k' ->
      assoc (assoc_set l k v) k' = assoc l k'.
  Proof.
    induction l; intros; simpl; repeat (break_match; simpl); subst; try congruence; auto.
  Qed.

  Lemma not_in_assoc :
    forall k l,
      ~ In k (map (@fst _ _) l) ->
      assoc l k = None.
  Proof.
    intros.
    induction l.
    - auto.
    - simpl in *. repeat break_match; intuition.
      subst. simpl in *. congruence.
  Qed.

  Lemma get_del_same :
    forall k l,
      NoDup (map (@fst _ _) l) ->
      assoc (assoc_del l k) k = None.
  Proof.
    induction l; intros; simpl in *.
    - auto.
    - invc H.
      repeat break_match; subst.
      + simpl in *. apply not_in_assoc. auto.
      + simpl in *. break_if; try congruence.
        auto.
  Qed.

  Lemma get_del_diff :
    forall k k' l,
      k <> k' ->
      assoc (assoc_del l k') k = assoc l k.
  Proof.
    induction l; intros; simpl in *.
    - auto.
    - repeat (break_match; simpl); subst; try congruence.
      auto.
  Qed.
End assoc.

Arguments assoc {_} {_} _ _ _.
Arguments assoc_set {_} {_} _ _ _ _.
Arguments assoc_del {_} {_} _ _ _.
Require Import HandlerMonad.
Definition getk k : GenHandler unit data output (option value) :=
  db <- get ;;
  ret (assoc key_eq_dec db k).

Definition setk k v : GenHandler unit data output unit := modify (fun db => assoc_set key_eq_dec db k v).

Definition delk k : GenHandler unit data output unit := modify (fun db => assoc_del key_eq_dec db k).

Definition resp k v old : GenHandler unit data output unit :=
  write_output (Response k v old).

Definition VarDHandler' (inp : input) : GenHandler unit data output unit :=
  match inp with
    | Get k => v <- getk k ;; resp k v v
    | Put k v => old <- getk k ;; setk k v ;; resp k (Some v) old
    | Del k => old <- getk k ;; delk k ;; resp k None old
    | CAS k v v' =>
      old <- getk k ;;
          if (val_eq_dec old v) then
            (setk k v' ;; resp k (Some v') old)
          else
            resp k old old
    | CAD k v =>
      old <- getk k ;;
          if (val_eq_dec old (Some v)) then
            (delk k ;; resp k None old)
          else
            resp k old old
  end.

Definition runHandler (h : input -> GenHandler unit data output unit)
           (inp : input) (d : data) : (list output) * data :=
  runGenHandler1_ignore (h inp) d.

Definition VarDHandler := runHandler VarDHandler'.

Instance vard_base_params : BaseParams :=
  {
    data := data ;
    input := input ;
    output := output
  }.

Instance vard_one_node_params : OneNodeParams _ :=
  {
    init := [] ;
    handler := VarDHandler
  }.

Definition input_key (i : input) : key :=
  match i with
    | Get k => k
    | Put k _ => k
    | Del k => k
    | CAS k _ _ => k
    | CAD k _ => k
  end.

Definition operate (op : input) (curr : option value) :=
  match op with
    | Get _ => (curr, curr)
    | Put _ v => (Some v, curr)
    | Del _ => (None, curr)
    | CAS _ v v' => if val_eq_dec curr v then (Some v', curr) else (curr, curr)
    | CAD _ v => if val_eq_dec curr (Some v) then (None, curr) else (curr, curr)
  end.

Fixpoint interpret (k : key) (ops : list input) (init : option value) :=
  match ops with
    | [] => (init, init)
    | op :: ops =>
      (operate op (fst (interpret k ops init)))
  end.

Definition inputs_with_key (trace : list (input * list output)) (k : key) : list input :=
  filterMap (fun ev => if key_eq_dec k (input_key (fst ev)) then
                            Some (fst ev)
                          else
                            None)
            trace.

Inductive trace_correct : list (input * list output) -> Prop :=
| TCnil : trace_correct []
| TCApp : forall t i v o, trace_correct t ->
                     interpret (input_key i)
                               (i :: (rev (inputs_with_key t (input_key i))))
                               None = (v, o) ->
                     trace_correct (t ++ [(i, [Response (input_key i) v o])]).

Inductive trace_correct' : data -> list (input * list output) -> Prop :=
| TC'nil : forall st, trace_correct' st []
| TC'App : forall st t i v o, trace_correct' st t ->
                         interpret (input_key i)
                                   (i :: (rev (inputs_with_key t (input_key i))))
                                   (assoc key_eq_dec st (input_key i)) = (v, o) ->
                         trace_correct' st (t ++ [(i, [Response (input_key i) v o])]).

Lemma trace_correct'_trace_correct :
  forall trace,
    trace_correct' init trace ->
    trace_correct trace.
Proof.
  intros.
  remember init as x. induction H.
  - constructor.
  - subst. constructor; auto.
Qed.

Definition trace_state_correct (trace : list (input * list output)) (st : data) (st' : data) :=
  forall k,
    fst (interpret k (rev (inputs_with_key trace k)) (assoc key_eq_dec st k)) = assoc key_eq_dec st' k.

Ltac vard_unfold :=
  unfold runHandler,
  getk,
  setk,
  delk,
  resp in *; monad_unfold.

Lemma trace_well_formed :
  forall st st' trace,
    step_1_star st st' trace ->
    (trace = [] \/ exists t i o, trace = t ++ [(i, [o])]).
Proof.
  intros.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  invcs H; intuition.
  right. exists cs. invcs H1. unfold VarDHandler, VarDHandler' in *.
  vard_unfold.
  repeat break_match; simpl in *; repeat find_inversion; repeat eexists; eauto.
Qed.

Lemma inputs_with_key_plus_key :
  forall l k i o,
    input_key i = k ->
    inputs_with_key (l ++ [(i, o)]) k =
    (inputs_with_key l k) ++ [i].
Proof.
  induction l; intros; simpl in *.
  - unfold inputs_with_key. simpl in *.
    repeat break_match; congruence.
  - unfold inputs_with_key in *.
    simpl in *.
    repeat break_match; simpl in *; f_equal; eauto.
Qed.

Lemma inputs_with_key_plus_not_key :
  forall l k i o,
    input_key i <> k ->
    inputs_with_key (l ++ [(i, o)]) k =
    (inputs_with_key l k).
Proof.
  induction l; intros; simpl in *.
  - unfold inputs_with_key. simpl in *.
    repeat break_match; congruence.
  - unfold inputs_with_key in *.
    simpl in *.
    repeat break_match; simpl in *; eauto; try discriminate.
    repeat find_inversion.
    f_equal. eauto.
Qed.

Definition no_dup_keys (d : data) :=
  NoDup (map (fst (B:=value)) d).

Lemma assoc_set_in_diff_key :
  forall K V st K_eq_dec (k : K) k' (v : V),
    k <> k' ->
    In k (map (fst (B:=V)) (assoc_set K_eq_dec st k' v)) ->
    In k (map (fst (B:=V)) st).
Proof.
  induction st; intros; simpl in *; intuition.
  repeat break_match; subst; in_crush.
  right. eapply IHst; eauto using in_map.
Qed.

Lemma assoc_del_in_diff_key :
  forall K V st K_eq_dec (k : K) k',
    k <> k' ->
    In k (map (fst (B:=V)) (assoc_del K_eq_dec st k')) ->
    In k (map (fst (B:=V)) st).
Proof.
  induction st; intros; simpl in *; intuition.
  repeat break_match; subst; in_crush.
  right. eapply IHst; eauto using in_map.
Qed.

Lemma assoc_set_preserves_NoDup :
  forall K V st K_eq_dec (k : K) (v : V),
    NoDup (map (fst (B:=V)) st) ->
    NoDup (map (fst (B:=V)) (assoc_set K_eq_dec st k v)).
Proof.
  induction st; intros; simpl in *.
  - constructor; intuition.
  - repeat break_match.
    + subst; auto.
    + subst. simpl in *.
      invcs H.
      constructor.
      * intuition.
        eauto using assoc_set_in_diff_key.
      * eauto.
Qed.

Lemma assoc_del_preserves_NoDup :
  forall K V st K_eq_dec (k : K),
    NoDup (map (fst (B:=V)) st) ->
    NoDup (map (fst (B:=V)) (assoc_del K_eq_dec st k)).
Proof.
  induction st; intros; simpl in *.
  - constructor; intuition.
  - repeat break_match.
    + subst; auto.
      simpl in *. invcs H. auto.
    + subst. simpl in *.
      invcs H.
      constructor.
      * intuition.
        eauto using assoc_del_in_diff_key.
      * eauto.
Qed.

Lemma no_dup_keys_invariant :
  forall st st' trace,
    step_1_star st st' trace ->
    no_dup_keys st ->
    no_dup_keys st'.
Proof.
  intros.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  induction H; auto. invcs H1; intuition.
  unfold VarDHandler, VarDHandler' in *.
  vard_unfold.
  repeat break_match; simpl in *; repeat find_inversion; unfold no_dup_keys in *;
  eauto using assoc_set_preserves_NoDup, assoc_del_preserves_NoDup.
Qed.

Theorem step_1_star_trace_state_correct :
  forall st st' trace,
    no_dup_keys st ->
    step_1_star st st' trace ->
    trace_state_correct trace st st'.
Proof.
  intros.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  induction H0; auto.
  - unfold trace_state_correct. intros.
    simpl in *.  auto.
  - unfold trace_state_correct in *. intros.
    invcs H1. unfold VarDHandler, VarDHandler' in *.
    vard_unfold. repeat break_match; simpl in *; repeat find_inversion.
    + simpl in *.
      destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst. symmetry; apply get_set_same.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite get_set_diff; auto.
    + simpl in *.
      destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst. eauto.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
    + simpl in *.
      destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst. eauto.
        symmetry; apply get_del_same.
        find_apply_lem_hyp refl_trans_n1_1n_trace.
        find_apply_lem_hyp no_dup_keys_invariant; eauto.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite get_del_diff; eauto.
    + simpl in *.
      destruct (key_eq_dec k0 k).
      * subst. rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        break_if; eauto using get_set_same.
        exfalso. intuition.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite get_set_diff; eauto.
    + simpl in *.
      destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst. break_if; eauto using get_del_same.
        subst.
        exfalso. intuition.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
    + simpl in *.
      destruct (key_eq_dec k0 k).
      * { subst. rewrite inputs_with_key_plus_key; simpl in *; auto.
          rewrite rev_unit. simpl in *.
          break_if; simpl in *.
          - symmetry. apply get_del_same.
            find_apply_lem_hyp refl_trans_n1_1n_trace.
            find_apply_lem_hyp no_dup_keys_invariant; eauto.
          - exfalso. intuition.
            match goal with
              | H : _ -> False |- _ => apply H
            end.
            find_higher_order_rewrite. auto.
        }
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite get_del_diff; eauto.
    + simpl in *.
      destruct (key_eq_dec k0 k).
      * subst. rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        break_if; simpl in *; intuition.
        exfalso. intuition.
        match goal with
          | H : _ -> False |- _ => apply H
        end.
        find_higher_order_rewrite. auto.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
Qed.

Lemma trace_state_correct_trace_correct :
  forall st st' st'' trace t,
    trace_state_correct trace st st' ->
    trace_correct' st trace ->
    step_1 st' st'' t ->
    trace_correct' st (trace ++ t).
Proof.
  intros.
  invcs H1; simpl in *.
  unfold VarDHandler, VarDHandler' in *.
  vard_unfold.
  repeat break_match; simpl in *; repeat find_inversion; constructor; auto;
  simpl in *; f_equal; eauto;
  break_if; simpl in *;  f_equal; eauto; unfold trace_state_correct in *;
  exfalso; subst; repeat find_higher_order_rewrite;
  intuition.
Qed.

Theorem step_1_star_trace_correct' :
  forall st st' trace,
    no_dup_keys st ->
    step_1_star st st' trace ->
    trace_correct' st trace.
Proof.
  intros.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  induction H0.
  - constructor.
  - find_apply_lem_hyp refl_trans_n1_1n_trace.
    find_apply_lem_hyp step_1_star_trace_state_correct; auto.
    eapply trace_state_correct_trace_correct; eauto.
Qed.

Theorem step_1_star_trace_correct :
  forall st trace,
    step_1_star init st trace ->
    trace_correct trace.
Proof.
  intros.
  find_apply_lem_hyp step_1_star_trace_correct'.
  eauto using trace_correct'_trace_correct.
  unfold no_dup_keys. simpl in *. constructor.
Qed.

Open Scope string_scope.
Example trace_correct_eg0 :
  trace_correct [(Put "james" "awesome", [Response "james" (Some "awesome") None])].
Proof.
  rewrite <- app_nil_l.
  constructor.
  - constructor.
  - simpl. auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e379m19_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e401m31_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e495m31_20limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e488m17_20limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e444m17_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Lia.
Require Import Nat.
Require Import Wellfounded.

From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Maths Require Import lists.
From Cyclic_PA.Maths Require Import ordinals.

From Cyclic_PA.Logic Require Import definitions.
From Cyclic_PA.Logic Require Import fol.
From Cyclic_PA.Logic Require Import PA_omega.

Definition impl (A B : formula) := (lor (neg A) B).
Notation "A1 ~> A2" := (impl A1 A2) (at level 60).
Notation "t # s" := (atom (equ t s)) (at level 80).

Inductive Peano_Theorems_Base : formula -> Type :=
| FOL1 : forall (A B : formula),
            Peano_Theorems_Base (A ~> (B ~> A))

| FOL2 : forall (A B C : formula),
            Peano_Theorems_Base ((A ~> (B ~> C)) ~> ((A ~> B) ~> (A ~> C)))

| FOL3 : forall (A B : formula),
            Peano_Theorems_Base ((neg A ~> neg B) ~> ((neg A ~> B) ~> A))

| FOL4 : forall (A : formula) (n : nat) (t : term),
            closed_t t = true ->
                Peano_Theorems_Base (lor (neg(univ n A)) (substitution A n t))

| FOL5 : forall (A B : formula) (n : nat),
            member n (free_list A) = false ->
                Peano_Theorems_Base ((univ n (A ~> B)) ~> (A ~> (univ n B)))

| MP : forall (A B : formula),
          Peano_Theorems_Base (A ~> B) ->
              Peano_Theorems_Base A ->
                  Peano_Theorems_Base B

| UG : forall (A : formula) (n : nat),
          Peano_Theorems_Base A ->
              Peano_Theorems_Base (univ n A)

| equ_trans : Peano_Theorems_Base  (univ 0 (univ 1 (univ 2 ((var 0 # var 1) ~> ((var 1 # var 2) ~> (var 0 # var 2))))))

| equ_succ : Peano_Theorems_Base (univ 0 (univ 1 ((var 0 # var 1) ~> ((succ (var 0)) # (succ (var 1))))))

| non_zero : Peano_Theorems_Base (univ 0 (neg (zero # (succ (var 0)))))

| succ_equ : Peano_Theorems_Base (univ 0 (univ 1 ((succ (var 0) # succ (var 1)) ~> (var 0 # var 1))))

| pl0 : Peano_Theorems_Base (univ 0 ((plus (var 0) zero) # (var 0)))

| plS : Peano_Theorems_Base (univ 0 (univ 1 ((plus (var 0) (succ (var 1))) # (succ (plus (var 0) (var 1))))))

| ml0 : Peano_Theorems_Base (univ 0 ((times (var 0) zero) # zero))

| mlS : Peano_Theorems_Base (univ 0 (univ 1 ((times (var 0) (succ (var 1))) # (plus (times (var 0) (var 1)) (var 0)))))

| induct : forall (A : formula) (n : nat),
              Peano_Theorems_Base (substitution A n zero ~> ((univ n (A ~> (substitution A n (succ (var n))))) ~> (univ n A))).

Inductive Peano_Theorems_Implication : formula -> nat -> ord -> Type :=
| I_FOL1 : forall (A B : formula),
              Peano_Theorems_Implication (A ~> (B ~> A))
                  0 (ord_succ (ord_succ (nat_ord (num_conn A + num_conn A))))

| I_FOL2 : forall (A B C : formula),
              Peano_Theorems_Implication ((A ~> (B ~> C)) ~> ((A ~> B) ~> (A ~> C)))
                  (num_conn (neg B)) (ord_succ (ord_max (ord_succ (nat_ord (num_conn (lor (neg A) B) + num_conn (lor (neg A) B))))
                                                        ((ord_succ (nat_ord (num_conn (lor (neg A) (lor (neg B) C)) + num_conn (lor (neg A) (lor (neg B) C))))))))

| I_FOL3 : forall (A B : formula),
              Peano_Theorems_Implication ((neg A ~> neg B) ~> ((neg A ~> B) ~> A))
                  0 (ord_succ (ord_max (ord_succ (ord_succ (ord_succ (nat_ord (num_conn (A) + num_conn (A))))))
                                        ((ord_succ (ord_max (ord_succ (ord_succ (ord_succ (nat_ord (num_conn A + num_conn A)))))
                                                            (ord_succ (ord_succ (nat_ord (num_conn (neg B) + num_conn (neg B))))))))))

| I_FOL4 : forall (A : formula) (n : nat) (t : term),
              closed_t t = true ->
                  Peano_Theorems_Implication (lor (neg(univ n A)) (substitution A n t))
                      0 (ord_succ (ord_succ (nat_ord (num_conn (substitution A n t) + num_conn (substitution A n t)))))

| I_FOL5 : forall (A B : formula) (n : nat),
              member n (free_list A) = false ->
                  Peano_Theorems_Implication ((univ n (A ~> B)) ~> (A ~> (univ n B)))
                      0 (ord_succ (ord_succ (ord_succ (nat_ord (num_conn (lor (neg A) B) + num_conn (lor (neg A) B))))))

| I_MP : forall (A B : formula) (d1 d2 : nat) (alpha beta : ord),
            Peano_Theorems_Implication (A ~> B) d1 alpha ->
                Peano_Theorems_Implication A d2 beta ->
                    Peano_Theorems_Implication B
                        (max (max d2 d1) (num_conn (neg A))) (ord_succ (ord_succ (ord_max beta alpha)))

| I_UG : forall (A : formula) (n d : nat) (alpha : ord),
            Peano_Theorems_Implication A d alpha ->
                (forall t, closed_t t = true -> Peano_Theorems_Implication (substitution A n t) d alpha) ->
                    Peano_Theorems_Implication (univ n A) d (ord_succ alpha)

| I_equ_trans : forall (t s r : term),
                  Peano_Theorems_Implication  ((t # s) ~> ((s # r) ~> (t # r)))
                      0 (ord_succ (ord_succ (nat_ord (num_conn (atom (equ s t))))))

| I_equ_succ : forall (t s : term),
                  Peano_Theorems_Implication ((t # s) ~> ((succ t) # (succ s))) 0 (ord_succ Zero)

| I_non_zero : forall (t : term),
                  Peano_Theorems_Implication (neg (zero # (succ t))) 0 Zero

| I_succ_equ : forall (t s : term),
                  Peano_Theorems_Implication ((succ t # succ s) ~> (t # s)) 0 (ord_succ Zero)

| I_pl0 : forall (t : term),
              Peano_Theorems_Implication ((plus t zero) # t) 0 Zero

| I_plS : forall (t s : term),
              Peano_Theorems_Implication ((plus t (succ s)) # (succ (plus t s))) 0 Zero

| I_ml0 : forall (t : term),
              Peano_Theorems_Implication ((times t zero) # zero) 0 Zero

| I_mlS : forall (t s : term),
              Peano_Theorems_Implication ((times t (succ s)) # (plus (times t s) t)) 0 Zero

| I_induct : forall (A : formula) (n : nat),
                Peano_Theorems_Implication (substitution A n zero ~> ((univ n (A ~> (substitution A n (succ (var n))))) ~> (univ n A)))
                    (num_conn A + 1) (ord_succ (ord_succ (cons (nat_ord 1) 0 Zero))).

Fixpoint inductive_chain (A : formula) (n m : nat) : formula :=
match m with
| 0 => neg ((substitution A n (represent 0)) ~> (substitution A n (succ (represent 0))))
| (S m') => (lor (inductive_chain A n m')
                  (neg ((substitution A n (represent (S m'))) ~> (substitution A n (succ (represent (S m')))))))
end.

Definition inductive_implication (A : formula) (n m : nat) : formula :=
match m with
| 0 => (lor (substitution A n (represent m)) (neg (substitution A n (represent 0))))
| S m' => lor (lor (inductive_chain A n m') (substitution A n (represent m))) (neg (substitution A n (represent 0)))
end.

Lemma ind_chain_closed :
    forall A n m,
        closed (univ n A) = true ->
            closed (inductive_chain A n m) = true.
Proof.
intros A n m CA.
induction m;
unfold inductive_chain, closed; fold inductive_chain closed;
try rewrite IHm;
unfold "&&", "~>", closed; fold closed;
rewrite succ_represent_comm;
repeat rewrite (closed_univ_sub_repr _ _ CA _);
reflexivity.
Qed.

Lemma inductive_implication_theorem :
    forall A n (c : c_term),
        closed (univ n A) = true ->
            PA_omega_theorem (inductive_implication A n (value c))
                0 (ord_add (nat_ord (S (num_conn A + num_conn A))) (nat_ord (3 * (S (value c))))).
Proof.
intros A n c CA.
induction (value c).

- apply (ord_incr _ _ (ord_succ (nat_ord (num_conn A + num_conn A)))).
  + rewrite <- (num_conn_sub _ n (represent 0)).
    apply exchange1.
    apply LEM.
    apply (closed_univ_sub_repr _ _ CA).
  + rewrite <- ord_add_nat.
    rewrite ord_succ_nat.
    apply nat_ord_lt.
    lia.
  + apply nf_add;
    apply nf_nat.

- assert ((ord_add (nat_ord (S (num_conn A + num_conn A))) (nat_ord (3 * S (S n0)))) = (ord_succ (ord_max (ord_succ (ord_succ (ord_add (nat_ord (S (num_conn A + num_conn A))) (nat_ord (3 * (S (n0))))))) (ord_succ (ord_succ (nat_ord (num_conn A + num_conn A))))))) as EQ.
  { repeat rewrite <- ord_add_nat.
    repeat rewrite ord_max_succ_succ.
    rewrite ord_max_ltb_not_l.
    { repeat rewrite ord_succ_nat.
      unfold mul.
      repeat rewrite plus_n_0.
      repeat rewrite plus_assoc.
      repeat rewrite <- plus_n_Sm.
      reflexivity. }
    { apply ord_ltb_asymm.
      apply ord_lt_ltb.
      apply nat_ord_lt.
      lia. } }
  rewrite EQ.
  assert (max 0 0 = 0) as EQ1. lia. destruct EQ1.
  destruct n0;
  unfold inductive_implication, inductive_chain;
  fold inductive_chain;
  unfold "~>".
    + apply associativity2.
      apply demorgan2.
      * apply negation2.
        apply exchange1.
        apply exchange2.
        apply associativity2.
        apply (weakening _ _ _ _ (closed_univ_sub_repr _ _ CA _) IHn0).
      * apply associativity1.
        apply exchange1.
        apply weakening.
        --  unfold closed; fold closed.
            apply (closed_univ_sub_repr _ _ CA).
        --  rewrite <- (num_conn_sub A n (represent (S 0))).
            apply LEM.
            apply (closed_univ_sub_repr _ _ CA).
    + apply exchange4.
      apply exchange2.
      apply exchange1.
      apply demorgan2.
      * apply negation2.
        apply exchange1.
        apply exchange2.
        apply exchange4.
        apply exchange2.
        apply exchange1.
        apply (weakening _ _ _ _ (closed_univ_sub_repr _ _ CA _) IHn0).
      * apply exchange1.
        apply exchange4.
        apply exchange2.
        apply associativity2.
        apply weakening.
        --  unfold closed; fold closed.
            rewrite (ind_chain_closed _ _ _ CA).
            rewrite (closed_univ_sub_repr _ _ CA).
            reflexivity.
        --  rewrite <- (num_conn_sub A n (represent (S (S n0)))).
            apply LEM.
            apply (closed_univ_sub_repr _ _ CA).
Qed.

Lemma inductive_implication_single_theorem :
    forall A n (c : c_term),
        free_list A = [n] ->
            PA_omega_theorem (inductive_implication A n (value c))
                0 (ord_add (nat_ord (S (num_conn A + num_conn A))) (nat_ord (3 * (S (value c))))).
intros A n c LIST.
apply inductive_implication_theorem.
unfold closed; fold closed.
rewrite LIST.
rewrite nat_eqb_refl.
rewrite list_eqb_refl.
destruct (closed A);
reflexivity.
Qed.

Lemma inductive_implication_closed_theorem :
    forall A n (c : c_term),
        closed A = true ->
            PA_omega_theorem (inductive_implication A n (value c))
                0 (ord_add (nat_ord (S (num_conn A + num_conn A))) (nat_ord (3 * (S (value c))))).
intros A n c CA.
apply inductive_implication_theorem.
unfold closed; fold closed.
rewrite CA.
reflexivity.
Qed.

Lemma induction_iterate_general :
    forall (A : formula) (n m : nat) (t : term) (alpha : ord),
        PA_omega_theorem (lor (lor (lor (inductive_chain A n (S m)) (substitution A n t))
                                    (neg (substitution A n zero)))
                              (neg (univ n (lor (neg A) (substitution A n (succ (var n)))))))
            0 alpha ->
                PA_omega_theorem (lor (lor (lor (inductive_chain A n m) (substitution A n t))
                                            (neg (substitution A n zero)))
                                      (neg (univ n (lor (neg A) (substitution A n (succ (var n)))))))
                    0 (ord_succ alpha).
Proof.
intros A n m c alpha T1.
unfold inductive_chain in T1. fold inductive_chain in T1. unfold "~>" in T1.
apply exchange1.
apply contraction2.
apply associativity2.
apply (quantification2 _ _ _ (closing (represent (S m)) (represent_closed _))).
unfold represent in *. fold represent in *.
unfold closing. unfold projT1.
unfold substitution. fold substitution.
rewrite sub_succ_self.
repeat apply associativity1.
apply exchange1.
apply associativity1.
apply associativity1.
apply exchange4.
apply associativity2.
apply exchange3.
apply associativity1.
apply exchange4.
apply associativity2.
apply exchange2.
apply associativity1.
apply exchange2.
apply exchange4.
apply exchange2.
apply exchange4.
apply associativity1.
apply exchange4.
apply exchange2.
apply exchange4.
apply T1.
Qed.

Lemma induction_terminate :
    forall (A : formula) (n m : nat) (t : term) (alpha : ord),
        PA_omega_theorem (lor (lor (lor (inductive_chain A n m) (substitution A n t))
                                    (neg (substitution A n zero)))
                              (neg (univ n (lor (neg A) (substitution A n (succ (var n)))))))
            0 alpha ->
                PA_omega_theorem (lor (lor (lor (inductive_chain A n 0) (substitution A n t))
                                            (neg (substitution A n zero)))
                                      (neg (univ n (lor (neg A) (substitution A n (succ (var n)))))))
                    0 (ord_add alpha (nat_ord m)).
Proof.
intros A n m.
induction m;
intros c alpha T1.

- rewrite ord_add_zero.
  apply T1.

- rewrite (ord_add_succ_nat_succ_add _ _ (ord_nf _ _ _ T1)).
  apply (IHm _ _ (induction_iterate_general _ _ _ _ _ T1)).
Qed.

Lemma induction_final :
  forall (A : formula) (n m : nat) (t : term) (alpha : ord),
    PA_omega_theorem (lor (lor  (lor  (inductive_chain A n m)
                                      (substitution A n t))
                                (neg (substitution A n zero)))
                          (neg (univ n (lor (neg A) (substitution A n (succ (var n)))))))
                      0 alpha ->
        PA_omega_theorem (lor (lor  (substitution A n t)
                                    (neg (substitution A n zero)))
                              (neg (univ n (lor (neg A) (substitution A n (succ (var n)))))))
                          0 (ord_succ (ord_add alpha (nat_ord m))).
Proof.
intros A n m t alpha T1.
apply exchange1.
apply contraction2.
apply associativity2.
apply (quantification2 _ _ _ (closing (represent 0) (represent_closed _))).
unfold substitution; fold substitution.
rewrite sub_succ_self.
apply associativity1.
apply associativity1.
apply exchange4.
apply exchange2.
apply (induction_terminate _ _ _ _ _ T1).
Qed.

Lemma induction_single_aux :
  forall (A : formula) (n : nat) (c : c_term),
    free_list A = [n] ->
      PA_omega_theorem (lor (lor  (substitution A n (represent (value c)))
                                  (neg (substitution A n zero)))
                            (neg (univ n (lor (neg A) (substitution A n (succ (var n)))))))
                        0 (cons (nat_ord 1) 0 Zero).
Proof.
intros A n c LIST.
pose proof (inductive_implication_single_theorem _ _  c LIST) as Y1.
destruct (value c) eqn:V.

- apply (ord_incr _ _  (ord_succ (ord_add (ord_succ (ord_succ (nat_ord (S (S (num_conn A + num_conn A)))))) (nat_ord (S 0))))).
  + apply exchange1.
    apply weakening.
    * unfold closed; fold closed.
      case (closed A) eqn:CA.
      --  rewrite (closed_free_list _ CA) in LIST.
          inversion LIST.
      --  unfold "&&".
          unfold free_list; fold free_list.
          rewrite LIST.
          rewrite (free_list_sub_self_eq _ _ (var n) LIST).
          unfold concat.
          unfold remove_dups.
          unfold remove.
          rewrite nat_eqb_refl.
          apply list_eqb_refl.
    * apply exchange1.
      apply (ord_incr _ _ (ord_succ (nat_ord (num_conn A + num_conn A)))).
      --  rewrite <- (num_conn_sub _ n zero).
          apply LEM.
          apply (one_var_free_lemma _ _ _ (represent_closed 0) LIST).
      --  rewrite ord_add_one_succ.
          ++  repeat rewrite ord_succ_nat.
              apply nat_ord_lt.
              lia.
          ++  repeat apply nf_nf_succ.
              apply nf_nat.
      --  refine (nf_add _ _ _ (nf_nat _)).
          repeat apply nf_nf_succ.
          apply nf_nat.
  + unfold nat_ord.
    unfold ord_succ.
    unfold ord_add.
    rewrite ord_ltb_irrefl.
    rewrite ord_eqb_refl.
    apply head_lt.
    apply ord_lt_self.
  + apply single_nf.
    apply nf_nat.

- apply (ord_incr _ _  (ord_succ (ord_add (ord_succ (ord_add (nat_ord (S (num_conn A + num_conn A))) (nat_ord (3 * (S (S n0)))))) (nat_ord n0)))).
  + unfold inductive_implication in *.
    apply induction_final.
    apply exchange1.
    refine (weakening _ _ _ _ _ Y1).
    unfold closed; fold closed.
    unfold free_list; fold free_list.
    rewrite (free_list_sub_self _ _ (var n));
    rewrite LIST.
    * unfold concat.
      unfold remove_dups.
      unfold remove.
      rewrite nat_eqb_refl.
      rewrite list_eqb_refl.
      case (closed A);
      case (closed (substitution A n (succ (var n))));
      reflexivity.
    * unfold member.
      rewrite nat_eqb_refl.
      reflexivity.
  + rewrite <- ord_add_succ_nat_succ_add.
    * repeat rewrite <- ord_add_nat.
      rewrite ord_succ_nat.
      apply head_lt.
      apply zero_lt.
    * apply nf_add;
      apply nf_nat.
  + apply single_nf.
    apply nf_nat.
Qed.

Lemma induction_closed_aux :
  forall (A : formula) (n : nat) (c : c_term),
    closed A = true ->
      PA_omega_theorem (lor (substitution A n (projT1 c))
                            (lor (neg (substitution A n zero))
                                 (neg (univ n (lor (neg A)
                                                   (substitution A n (succ (var n))))))))
                        0 (ord_succ (ord_add (nat_ord (S (num_conn A + num_conn A))) (nat_ord (3 * (S (value c)))))).
Proof.
intros A n c CA.
pose proof (inductive_implication_closed_theorem _ n c CA) as Y1.
unfold inductive_implication in Y1.
repeat rewrite (closed_subst_eq _ _ _ CA) in Y1.
repeat rewrite (closed_subst_eq _ _ _ CA).
destruct (value c) eqn:V.

- apply exchange1.
  apply exchange2.
  apply exchange1.
  apply weakening.
  + unfold closed.
    fold closed.
    rewrite CA.
    reflexivity.
  + apply exchange1.
    apply Y1.

- apply associativity1.
  apply exchange1.
  apply weakening.
  + unfold closed.
    fold closed.
    rewrite CA.
    reflexivity.
  + apply exchange1.
    apply (ord_incr _ _ _ _ (LEM _ CA)).
    * rewrite ord_succ_nat.
      rewrite <- ord_add_nat.
      apply nat_ord_lt.
      lia.
    * apply single_nf.
      apply zero_nf.
Qed.

Lemma PA_closed_PA_omega :
  forall (A : formula) (d : nat) (alpha : ord),
    Peano_Theorems_Implication A d alpha ->
      (forall (c : c_term), PA_omega_theorem (closure A c) d alpha).
Proof.
intros A d alpha T1.
induction T1;
intros c; unfold "~>" in *.

- pose proof (closure_closed (neg B) c) as Y1.
  pose proof (closure_closed A c) as Y2.
  rewrite (num_conn_closure_eq A c).
  repeat rewrite closure_lor in *.
  repeat rewrite closure_neg in *.
  apply associativity1.
  apply exchange2.
  apply exchange1.
  apply weakening.
  + apply Y1.
  + apply (LEM _ Y2).

- pose proof (closure_closed (lor (neg A) B) c) as Y1.
  pose proof (closure_closed (lor (neg A) (lor (neg B) C)) c) as Y2.
  rewrite (num_conn_closure_eq (neg B) c).
  repeat rewrite (num_conn_closure_eq (lor _ _) c).
  repeat rewrite closure_lor in *.
  repeat rewrite closure_neg in *.
  repeat rewrite closure_lor in *.
  repeat rewrite closure_neg in *.
  assert ((max (max 0 0) (num_conn (neg (closure B c)))) = num_conn (neg (closure B c))) as Z. { unfold max. reflexivity. }
  destruct Z.
  apply associativity1.
  apply associativity1.
  apply exchange2.
  apply exchange3.
  apply exchange2.
  apply exchange3.
  apply exchange1.
  apply exchange3.
  apply exchange2.
  apply exchange3.
  apply exchange4.
  apply associativity2.
  apply associativity2.
  apply contraction2.
  apply associativity1.
  apply exchange4.
  apply exchange2.
  apply associativity2.
  apply cut3.
  + apply exchange2.
    apply exchange1.
    apply (LEM _ Y1).
  + apply exchange1.
    apply exchange4.
    apply exchange2.
    apply exchange4.
    apply exchange2.
    apply associativity2.
    apply exchange3.
    apply exchange1.
    apply associativity2.
    apply (LEM _ Y2).

- pose proof (closure_closed (lor (neg (neg A)) (neg B)) c) as Y1.
  pose proof (closure_closed A c) as Y2.
  pose proof (closure_closed (neg B) c) as Y3.
  rewrite (num_conn_closure_eq A c).
  rewrite (num_conn_closure_eq (neg B) c).
  repeat rewrite closure_lor in *.
  repeat rewrite closure_neg in *.
  repeat rewrite closure_lor in *.
  repeat rewrite closure_neg in *.
  assert (max 0 (max 0 0) = 0) as Z. { unfold max. reflexivity. }
  destruct Z.
  apply demorgan2.
  + apply associativity1.
    apply exchange2.
    apply exchange1.
    apply weakening.
    * apply Y1.
    * apply negation2. apply (LEM _ Y2).
  + apply exchange1.
    apply associativity2.
    apply demorgan2.
    * apply negation2.
      apply associativity1.
      apply exchange1.
      apply weakening.
      -- apply Y3.
      -- apply (LEM _ Y2).
    * apply associativity1.
      apply exchange2.
      apply exchange1.
      apply weakening.
      -- apply Y2.
      -- apply exchange1. apply (LEM _ Y3).

- rename e into Ht.
  rewrite (num_conn_closure_eq _ c).
  pose proof (closure_closed (univ n A) c) as Y1.
  rewrite closure_lor.
  rewrite closure_neg.
  rewrite closure_univ in *.
  pose proof (closed_univ_sub _ _ Y1 _ Ht) as Y2.
  apply (quantification2 _ _ _ (closing t Ht)).
  rewrite <- (closure_subst _ c (closing _ Ht)).
  apply (LEM _ Y2).

- rename e into LIST.
  rewrite (num_conn_closure_eq _ c).
  repeat rewrite closure_lor.
  repeat rewrite closure_neg.
  repeat rewrite closure_univ.
  apply associativity1.
  apply exchange1.
  apply w_rule2.
  intros [m Hm].
  pose proof (closure_closed (lor (neg A) (substitution B n m)) c) as Y1.
  assert (num_conn (lor (neg (closure A c)) (closure (substitution B n m) c)) = num_conn (lor (neg (closure A c)) (closure B c))) as Z.
  { unfold num_conn. fold num_conn.
    repeat rewrite <- num_conn_closure_eq.
    rewrite num_conn_sub.
    reflexivity. }
  destruct Z.
  apply exchange1.
  apply associativity2.
  apply (quantification2 _ _ _ (closing m Hm) _ _).
  repeat rewrite closure_subst.
  unfold substitution; fold substitution.
  rewrite (closed_subst_eq_aux _ _ _ LIST).
  repeat rewrite closure_lor in *.
  repeat rewrite closure_neg in *.
  apply (LEM _ Y1).

- rewrite (num_conn_closure_eq _ c).
  rewrite closure_neg.
  apply cut2.
  + apply IHT1_2.
  + rewrite <- closure_neg.
    rewrite <- closure_lor.
    apply IHT1_1.

- rewrite closure_univ.
  apply w_rule1.
  intros [m Hm].
  rewrite closure_subst.
  apply (X _ Hm).

- repeat rewrite closure_lor.
  repeat rewrite closure_neg.
  case (correct_a (equ (closure_t t c) (closure_t s c))) eqn:X.
  + pose (atom (equ (var 0) (closure_type_t r c (free_list_t r)))) as F.
    assert (closure (atom (equ t r)) c = substitution F 0 (closure_t t c)) as EQ1.
    { unfold F.
      unfold substitution.
      unfold substitution_a.
      unfold substitution_t; fold substitution_t.
      unfold nat_eqb.
      rewrite closure_type_equiv.
      rewrite closed_subst_eq_t. reflexivity.
      apply closure_closed_t. }
    assert (closure (atom (equ s r)) c = substitution F 0 (closure_t s c)) as EQ2.
    { unfold F.
      unfold substitution.
      unfold substitution_a.
      unfold substitution_t; fold substitution_t.
      unfold nat_eqb.
      rewrite closure_type_equiv.
      rewrite closed_subst_eq_t. reflexivity.
      apply closure_closed_t. }
    rewrite EQ1, EQ2.
    apply weakening.
    * rewrite <- closure_neg.
      apply closure_closed.
    * apply LEM_term.
      --  unfold correct_a in *.
          unfold correctness in *.
          destruct (correct_eval _ _ X) as [Xa Xb].
          destruct (eval (closure_t s c)).
          ++  inversion Xb.
          ++  destruct (eval (closure_t t c)).
              **  inversion Xa.
              **  case (nat_eqb (S n0) (S n)) eqn:X1.
                  { rewrite nat_eqb_symm in X1. rewrite X1. reflexivity. }
                  { inversion X. }
      --  unfold F.
          unfold free_list.
          unfold free_list_a.
          unfold free_list_t; fold free_list_t.
          unfold concat.
          rewrite closed_free_list_t.
          ++  unfold remove_dups.
              unfold remove.
              reflexivity.
          ++  apply closure_closed_t.
  + apply exchange1.
    apply weakening.
    * unfold closed; fold closed.
      repeat rewrite closure_closed.
      reflexivity.
    * apply (ord_incr _ _ Zero).
      --  apply axiom.
          unfold PA_omega_axiom.
          destruct (correctness_decid (equ (closure_t t c) (closure_t s c))) as [X1 | X1].
          ++  unfold closed_a.
              repeat rewrite closure_closed_t.
              reflexivity.
          ++  rewrite X1 in X.
              inversion X.
          ++  rewrite closure_type_equiv.
              apply X1.
      --  rewrite ord_succ_nat.
          apply zero_lt.
      --  apply nf_nf_succ.
          apply nf_nat.

- rewrite closure_lor.
  rewrite closure_neg.
  case (correct_a (equ (closure_t t c) (closure_t s c))) eqn:X.
  + apply weakening.
    * apply closure_closed.
    * apply axiom.
      rewrite closure_type_equiv.
      unfold PA_omega_axiom.
      unfold correct_a in *.
      unfold correctness in *.
      destruct (correct_eval _ _ X) as [Xa Xb].
      repeat rewrite closure_t_succ.
      unfold eval. fold eval.
      destruct (eval (closure_t s c)).
      --  inversion Xb.
      --  destruct (eval (closure_t t c)).
          ++  inversion Xa.
          ++  unfold nat_eqb in *; fold nat_eqb in *.
              apply X.
  + apply exchange1.
    apply weakening.
    * apply closure_closed.
    * apply axiom.
      unfold PA_omega_axiom.
      destruct (correctness_decid (equ (closure_t t c) (closure_t s c))) as [X1 | X1].
      --  unfold closed_a.
          repeat rewrite closure_closed_t.
          reflexivity.
      --  rewrite X1 in X.
          inversion X.
      --  rewrite closure_type_equiv.
          apply X1.

- rewrite closure_neg.
  rewrite closure_type_equiv.
  rewrite (closure_closed_id_t _ _ (represent_closed 0)).
  apply axiom.
  unfold PA_omega_axiom.
  destruct (correctness_decid (equ zero (closure_t (succ t) c))) as [X | X].
  + unfold closed_a.
    rewrite closure_closed_t.
    unfold closed_t.
    reflexivity.
  + unfold correct_a in X.
    unfold correctness in X.
    rewrite closure_t_succ in X.
    unfold eval in X; fold eval in X.
    destruct (eval (closure_t t c));
    inversion X.
  + apply X.

- rewrite closure_lor.
  rewrite closure_neg.
  case (correct_a (equ (closure_t t c) (closure_t s c))) eqn:X.
  + apply weakening.
    * apply closure_closed.
    * apply axiom.
      rewrite closure_type_equiv.
      unfold PA_omega_axiom.
      unfold correct_a in *.
      unfold correctness in *.
      destruct (correct_eval _ _ X) as [Xa Xb].
      repeat rewrite closure_t_succ.
      unfold eval; fold eval.
      destruct (eval (closure_t s c)).
      --  inversion Xb.
      --  destruct (eval (closure_t t c)).
          ++  inversion Xa.
          ++  unfold nat_eqb in *; fold nat_eqb in *.
              apply X.
  + apply exchange1.
    apply weakening.
    * apply closure_closed.
    * apply axiom.
      unfold PA_omega_axiom.
      destruct (correctness_decid (equ (closure_t t c) (closure_t s c))) as [X1 | X1].
      --  unfold closed_a.
          repeat rewrite closure_closed_t.
          reflexivity.
      --  rewrite X1 in X.
          inversion X.
      --  rewrite closure_type_equiv.
          unfold incorrect_a in *.
          unfold correctness in *.
          repeat rewrite closure_t_succ in *.
          unfold eval; fold eval.
          destruct (eval (closure_t t c)).
          ++  inversion X1.
          ++  destruct (eval (closure_t s c)).
              **  inversion X1.
              **  apply X1.

- rewrite closure_type_equiv.
  rewrite closure_t_plus.
  rewrite (closure_closed_id_t _ _ (represent_closed 0)).
  apply axiom.
  unfold PA_omega_axiom.
  destruct (correctness_decid (equ (plus (closure_t t c) zero) (closure_t t c))) as [X | X].
  + unfold closed_a.
    unfold closed_t; fold closed_t.
    repeat rewrite closure_closed_t.
    reflexivity.
  + apply X.
  + unfold incorrect_a in X.
    unfold correctness in X.
    unfold eval in X; fold eval in X.
    destruct (eval (closure_t t c)).
    * inversion X.
    * rewrite <- plus_n_O in X.
      rewrite nat_eqb_refl in X.
      inversion X.

- rewrite closure_type_equiv.
  rewrite closure_t_succ.
  repeat rewrite closure_t_plus.
  rewrite closure_t_succ.
  apply axiom.
  unfold PA_omega_axiom.
  destruct (correctness_decid (equ (plus (closure_t t c) (succ (closure_t s c))) (succ (plus (closure_t t c) (closure_t s c))))) as [X | X].
  + unfold closed_a.
    unfold closed_t; fold closed_t.
    repeat rewrite closure_closed_t.
    reflexivity.
  + apply X.
  + unfold incorrect_a in X.
    unfold correctness in X.
    unfold eval in X; fold eval in X.
    destruct (eval (closure_t t c)).
    * inversion X.
    * destruct (eval (closure_t s c)).
      --  inversion X.
      --  rewrite <- plus_n_Sm in X.
          rewrite nat_eqb_refl in X.
          inversion X.

- rewrite closure_type_equiv.
  rewrite closure_t_times.
  rewrite (closure_closed_id_t _ _ (represent_closed 0)).
  apply axiom.
  unfold PA_omega_axiom.
  destruct (correctness_decid (equ (times (closure_t t c) zero) zero)) as [X | X].
  + unfold closed_a.
    unfold closed_t; fold closed_t.
    repeat rewrite closure_closed_t.
    reflexivity.
  + apply X.
  + unfold incorrect_a in X.
    unfold correctness in X.
    unfold eval in X; fold eval in X.
    destruct (eval (closure_t t c)).
    * inversion X.
    * rewrite <- mult_n_O in X.
      rewrite nat_eqb_refl in X.
      inversion X.

- rewrite closure_type_equiv.
  rewrite closure_t_plus.
  repeat rewrite closure_t_times.
  rewrite closure_t_succ.
  apply axiom.
  unfold PA_omega_axiom.
  destruct (correctness_decid (equ (times (closure_t t c) (succ (closure_t s c))) (plus (times (closure_t t c) (closure_t s c)) (closure_t t c))) ) as [X | X].
  + unfold closed_a.
    unfold closed_t; fold closed_t.
    repeat rewrite closure_closed_t.
    reflexivity.
  + apply X.
  + unfold incorrect_a in X.
    unfold correctness in X.
    unfold eval in X. fold eval in X.
    destruct (eval (closure_t t c)).
    * inversion X.
    * destruct (eval (closure_t s c)).
      --  inversion X.
      --  rewrite mult_n_Sm in X.
          rewrite nat_eqb_refl in X.
          inversion X.

- repeat rewrite closure_lor.
  repeat rewrite closure_neg.
  repeat rewrite closure_univ.
  rewrite <- (closure_subst _ _ czero).
  repeat rewrite closure_type_lor.
  rewrite closure_neg_list.
  rewrite closure_type_sub_remove.
  apply associativity1.
  apply exchange1.
  apply w_rule2.
  intros [m Hm].
  case (closed (closure_type A c (free_list (univ n A)))) eqn:X.
  + assert ( (free_list (univ n (lor (neg A) (substitution A n (succ (var n)))))) = free_list (univ n A)) as LIST.
    { unfold free_list; fold free_list.
      case (member n (free_list A)) eqn:X1.
      { rewrite (free_list_sub_self _ _ m X1).
        rewrite remove_dups_concat_self.
        rewrite <- free_list_remove_dups_idem.
        reflexivity. }
      { rewrite (closed_subst_eq_aux _ _ _ X1).
        rewrite remove_dups_concat_self.
        rewrite <- free_list_remove_dups_idem.
        reflexivity. } }
    rewrite LIST.
    refine (ord_incr _ _ _ _ (deg_incr _ _ _ _ (induction_closed_aux _ _ (closing m Hm) X) _) _ _).
    * lia.
    * apply ord_lt_succ.
      rewrite <- ord_add_nat.
      apply head_lt.
      apply zero_lt.
    * apply nf_nf_succ.
      apply single_nf.
      apply nf_nat.
  + assert (free_list (closure_type A c (free_list (univ n A))) = [n]) as HL.
    { unfold free_list; fold free_list.
      destruct (free_list_univ_closure A c n) as [L1 | L2].
      { apply L1. }
      { apply free_list_closed in L2.
        rewrite L2 in X.
        inversion X. } }
    assert (free_list (univ n A) = (free_list (univ n (lor (neg A) (substitution A n (succ (var n))))))) as Z1.
    { unfold free_list; fold free_list.
      case (member n (free_list A)) eqn:X1.
      { rewrite (free_list_sub_self _ _ m X1).
        rewrite remove_dups_concat_self.
        rewrite <- free_list_remove_dups_idem.
        reflexivity. }
      { rewrite (closed_subst_eq_aux _ _ _ X1).
        rewrite remove_dups_concat_self.
        rewrite <- free_list_remove_dups_idem.
        reflexivity. } }
    assert ((max (max 0 0) (num_conn (neg (substitution (closure_type A c (free_list (univ n A))) n (represent (value (closing m Hm))))))) = (num_conn A + 1)) as Z2.
      { unfold max.
        unfold num_conn; fold num_conn.
        rewrite num_conn_sub.
        rewrite <- num_conn_closure_eq_list.
        rewrite <- plus_n_Sm.
        rewrite <- plus_n_O.
        reflexivity. }
    assert ((ord_max (cons (nat_ord 1) 0 Zero) (ord_succ (nat_ord (num_conn (closure_type A c (free_list (univ n A))) + num_conn (closure_type A c (free_list (univ n A))))))) = (cons (nat_ord 1) 0 Zero)) as Z3.
    { rewrite ord_max_ltb_not_l.
      { reflexivity. }
      { apply ord_ltb_asymm.
        rewrite ord_succ_nat.
        apply ord_lt_ltb.
        apply head_lt.
        apply zero_lt. } }
    destruct Z1,Z2,Z3.
    pose proof (induction_single_aux _ _ (closing m Hm) HL) as Y1.
    pose proof (LEM_term (closure_type A c (free_list (univ n A))) n _ _ (cterm_equiv_correct (closing m Hm)) HL) as Y2.
    apply associativity1 in Y1.
    apply exchange1 in Y1.
    apply exchange1.
    apply (cut3 _ _ _ _ _ _ _ Y1 Y2).
Qed.

Lemma PA_Implication_null_impl :
  forall (A : formula) (d n : nat) (alpha : ord) (t : term),
    closed_t t = true ->
      Peano_Theorems_Implication A d alpha ->
        Peano_Theorems_Implication (substitution A n t) d alpha.
Proof.
intros A d n alpha c HC H0.
induction H0; unfold "~>" in *;
unfold substitution in *; fold substitution in *;
unfold num_conn; fold num_conn.

- rewrite <- (num_conn_sub _ n c).
  apply I_FOL1.

- rewrite <- (num_conn_sub A n c).
  rewrite <- (num_conn_sub B n c).
  rewrite <- (num_conn_sub C n c).
  apply I_FOL2.

- rewrite <- (num_conn_sub A n c).
  rewrite <- (num_conn_sub B n c).
  apply I_FOL3.

- rename e into Ht.
  case (nat_eqb n0 n) eqn:X.
  + apply nat_eqb_eq in X.
    destruct X.
    rewrite closed_subst_eq_aux.
    apply (I_FOL4 _ _ _ Ht).
    rewrite (subst_remove _ _ _ Ht).
    apply remove_not_member.
  + rewrite nat_eqb_symm in X.
    rewrite (substitution_order _ _ _ _ _ Ht HC X).
    rewrite num_conn_sub.
    rewrite <- (num_conn_sub A n c).
    rewrite <- (num_conn_sub (substitution A n c) n0 t).
    apply (I_FOL4 _ _ _ Ht).

- rename e into LIST.
  case (nat_eqb n0 n) eqn:X.
  + apply nat_eqb_eq in X.
    destruct X.
    rewrite (closed_subst_eq_aux _ _ _ LIST).
    apply (I_FOL5 _ _ _ LIST).
  + rewrite <- (num_conn_sub A n c).
    rewrite <- (num_conn_sub B n c).
    apply I_FOL5.
    rewrite (subst_remove _ _ _ HC).
    apply (remove_member_false _ _ _ LIST).

- rewrite <- (num_conn_sub A n c).
  apply I_MP.
  + apply IHPeano_Theorems_Implication1.
  + apply IHPeano_Theorems_Implication2.

- case (nat_eqb n0 n) eqn:X.
  + apply nat_eqb_eq in X.
    destruct X.
    apply (I_UG _ _ _ _ H0 p).
  + apply (I_UG _ _ _ _ IHPeano_Theorems_Implication).
    intros t Ht.
    rewrite weak_substitution_order.
    * apply (H _ Ht).
    * rewrite (closed_free_list_t _ HC).
      unfold member.
      reflexivity.
    * rewrite (closed_free_list_t _ Ht).
      unfold member.
      reflexivity.
    * apply X.

- apply I_equ_trans.

- apply I_equ_succ.

- apply I_non_zero.

- apply I_succ_equ.

- apply I_pl0.

- apply I_plS.

- apply I_ml0.

- apply I_mlS.

- case (nat_eqb n0 n) eqn:X.
  + apply nat_eqb_eq in X.
    destruct X.
    rewrite closed_subst_eq_aux.
    * apply I_induct.
    * rewrite (subst_remove _ _ _ (represent_closed 0)).
      apply remove_not_member.
  + rewrite nat_eqb_symm in X.
    rewrite (substitution_order _ _ _ _ _ (represent_closed 0) HC X).
    rewrite (weak_substitution_order _ _ _ (succ (var n0))).
    * rewrite <- (num_conn_sub A n c).
      apply I_induct.
    * unfold free_list_t.
      unfold member.
      rewrite nat_eqb_symm in X.
      rewrite X.
      reflexivity.
    * rewrite (closed_free_list_t _ HC).
      unfold member.
      reflexivity.
    * apply X.
Qed.

Lemma PA_Base_equiv_PA_Implication :
  forall (A : formula),
    Peano_Theorems_Base A ->
      {d : nat & {alpha : ord & Peano_Theorems_Implication A d alpha}}.
Proof.
intros A T. induction T.

- exists 0.
  exists (ord_succ (ord_succ (nat_ord (num_conn A + num_conn A)))).
  apply I_FOL1.

- exists (num_conn (neg B)).
  exists (ord_succ (ord_max (ord_succ (nat_ord (num_conn (lor (neg A) B) + num_conn (lor (neg A) B))))
                            ((ord_succ (nat_ord (num_conn (lor (neg A) (lor (neg B) C)) + num_conn (lor (neg A) (lor (neg B) C)))))))).
  apply I_FOL2.

- exists 0.
  exists (ord_succ (ord_max (ord_succ (ord_succ (ord_succ (nat_ord (num_conn (A) + num_conn (A))))))
                            ((ord_succ (ord_max (ord_succ (ord_succ (ord_succ (nat_ord (num_conn A + num_conn A)))))
                                                (ord_succ (ord_succ (nat_ord (num_conn (neg B) + num_conn (neg B)))))))))).
  apply I_FOL3.

- exists 0.
  exists (ord_succ (ord_succ (nat_ord (num_conn (substitution A n t) + num_conn (substitution A n t))))).
  apply (I_FOL4 _ _ _ e).

- exists 0.
  exists (ord_succ (ord_succ (ord_succ (nat_ord (num_conn (lor (neg A) B) + num_conn (lor (neg A) B)))))).
  apply (I_FOL5 _ _ _ e).

- destruct IHT1 as [d1 [alpha1 IHT1]].
  destruct IHT2 as [d2 [alpha2 IHT2]].
  exists (max (max d2 d1) (num_conn (neg A))).
  exists (ord_succ (ord_succ (ord_max alpha2 alpha1))).
  apply I_MP.
  + apply IHT1.
  + apply IHT2.

- destruct IHT as [d [alpha IHT]].
  exists d.
  exists (ord_succ alpha).
  apply I_UG.
  + apply IHT.
  + intros t Ht.
    apply (PA_Implication_null_impl _ _ _ _ _ Ht IHT).

- exists 0.
  exists (ord_succ (ord_succ (ord_succ (ord_succ (ord_succ (nat_ord 0)))))).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
    apply I_UG; intros;
      unfold substitution;
      fold substitution;
      unfold nat_eqb;
      apply I_UG; intros;
  apply I_equ_trans.

- exists 0.
  exists (ord_succ (ord_succ (ord_succ (nat_ord 0)))).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
    apply I_UG; intros;
      unfold substitution;
      fold substitution;
      unfold nat_eqb;
  apply I_equ_succ.

- exists 0.
  exists (ord_succ (nat_ord 0)).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
  apply I_non_zero.

- exists 0.
  exists (ord_succ (ord_succ (ord_succ (nat_ord 0)))).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
    apply I_UG; intros;
      unfold substitution;
      fold substitution;
      unfold nat_eqb;
  apply I_succ_equ.

- exists 0.
  exists (ord_succ (nat_ord 0)).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
  apply I_pl0.

- exists 0.
  exists (ord_succ (ord_succ (nat_ord 0))).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
    apply I_UG; intros;
      unfold substitution;
      fold substitution;
      unfold nat_eqb;
  apply I_plS.

- exists 0.
  exists (ord_succ (nat_ord 0)).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
  apply I_ml0.

- exists 0.
  exists (ord_succ (ord_succ (nat_ord 0))).
  apply I_UG; intros;
    unfold substitution;
    fold substitution;
    unfold nat_eqb;
    apply I_UG; intros;
      unfold substitution;
      fold substitution;
      unfold nat_eqb;
  apply I_mlS.

- exists (num_conn A + 1).
  exists (ord_succ (ord_succ (cons (nat_ord 1) 0 Zero))).
  apply I_induct.
Qed.

Lemma PA_Base_closed_PA_omega :
  forall (A : formula),
    Peano_Theorems_Base A ->
      (forall (c : c_term), {d : nat & {alpha : ord & PA_omega_theorem (closure A c) d alpha}}).
Proof.
intros A T c.
destruct (PA_Base_equiv_PA_Implication _ T) as [d [alpha TI]].
exists d.
exists alpha.
apply (PA_closed_PA_omega _ _ _ TI c).
Qed.