Require Export ssreflect eqtype bigop.
Require Export Logic.ClassicalFacts.

Axiom prop_extensionality_ok : prop_extensionality.

(** %
\section{定義}
\begin{itemize}
\item $A$, $B$ を \verb|eqType| として,
$A$ から $B$ への関係の型を $(\verb|Rel | A \ B)$ と書き,
$A \to B \to \verb|Prop|$ として定義する.
本文中では型 $(\verb|Rel | A \ B)$ を $A \rel B$ と書く.
\item 関係 $\alpha: A \rel B$ の
逆関係 $\alpha^\sharp : B \rel A$ は
$(\verb|inverse | \alpha)$ で,
\verb|Coq| では $(\alpha \verb| #|)$ と記述する.
\item 2 つの関係 $\alpha: A \rel B$,
$\beta: B \rel C$ の
合成関係 $\alpha \beta:A \rel C$ は
$(\verb|composite | \alpha \ \beta)$ で,
$(\alpha \verb| ・ | \beta)$ と記述する.
\item 剰余合成関係 $\alpha \rhd \beta:A \rel C$ は
$(\verb|residual | \alpha \ \beta)$ で,
$(\alpha \verb| △ | \beta)$ と記述する.
\item 恒等関係 $\id_A: A \rel A$ は
$(\verb|identity | A)$ で,
$(\verb|Id | A)$ と記述する.
\item 空関係 $\phi_{AB} : A \rel B$ は
$(\verb|empty | A \ B)$ で,
$(\verb|φ | A \ B)$ と記述する.
\item 全関係 $\nabla_{AB} : A \rel B$ は
$(\verb|universal | A \ B)$ で,
$(\verb|∇ | A \ B)$ と記述する.
\item 2 つの関係 $\alpha: A \rel B$,
$\beta: A \rel B$ の
和関係 $\alpha \sqcup \beta: A \rel B$ は
$(\verb|cup | \alpha \ \beta)$ で,
$(\alpha \verb| ∪ | \beta)$ と記述する.
\item 共通関係 $\alpha \sqcap \beta: A \rel B$ は
$(\verb|cap | \alpha \ \beta)$ で,
$(\alpha \verb| ∩ | \beta)$ と記述する.
\item 相対擬補関係 $\alpha \Rightarrow \beta : A \rel B$ は
$(\verb|rpc | \alpha \ \beta)$ で,
$(\alpha \verb| >> | \beta)$ と記述する.
\item 関係 $\alpha: A \rel B$ の
補関係 $\alpha^- : A \rel B$ は
$(\verb|complement | \alpha)$ で,
\verb|Coq| では $(\alpha \verb| ^|)$ と記述する.
\item 2 つの関係 $\alpha: A \rel B$,
$\beta: A \rel B$ の
差関係 $\alpha - \beta : A \rel B$ は
$(\verb|difference | \alpha \ \beta)$ で,
$(\alpha \verb| -- | \beta)$ と記述する.
\item \verb|(capL)| と
\verb|(cupL)| は添字付の共通関係と和関係であり,
\verb|(cupP)| は条件付の和関係である.
\item また, 1 点集合 $I= \{ * \}$ は \verb|i| と表記する.
\end{itemize}

表\ref{notation}に関係の表記についてまとめる.

\begin{table}
\begin{center}
\begin{tabular}{|l|c|l|c|} \hline
 & 数式 & \hfil Coq \hfil & Notation\\ \hline\hline
逆関係 &
$\alpha^\sharp$ &
$(\verb|inverse | \alpha)$ &
$(\alpha \verb| #|)$ \\ \hline
合成関係 &
$\alpha\beta$ &
$(\verb|composite | \alpha \beta)$ &
$(\alpha \verb| ・ | \beta)$ \\ \hline
剰余合成関係 &
$\alpha\rhd\beta$ &
$(\verb|residual | \alpha \beta)$ &
$(\alpha \verb| △ | \beta)$ \\ \hline
恒等関係 &
$\id_A$ &
$(\verb|identity | A)$ &
$(\verb|Id | A)$ \\ \hline
空関係 &
$\phi_{AB}$ &
$(\verb|empty | A \ B)$ &
$(\verb|φ | A \ B)$ \\ \hline
全関係 &
$\nabla_{AB}$ &
$(\verb|universal | A \ B)$ &
$(\verb|∇ | A \ B)$ \\ \hline
和関係 &
$\alpha \sqcup \beta$ &
$(\verb|cup | \alpha \beta)$ &
$(\alpha \verb| ∪ | \beta) $ \\ \hline
共通関係 &
$\alpha \sqcap \beta$ &
$(\verb|cap | \alpha \beta)$ &
$(\alpha \verb| ∩ | \beta)$ \\ \hline
相対擬補関係 &
$\alpha \Rightarrow \beta$ &
$(\verb|rpc | \alpha \ \beta)$ &
$(\alpha \verb| >> | \beta)$ \\ \hline
補関係 &
$\alpha^-$ &
$(\verb|complement | \alpha)$ &
$(\alpha \verb| ^|)$ \\ \hline
差関係 &
$\alpha - \beta$ &
$(\verb|difference | \alpha \ \beta)$ &
$(\alpha \verb| -- | \beta)$ \\ \hline
添字付和関係 &
$\sqcup_{\lambda \in \Lambda} \alpha_\lambda$ &
$(\verb|cupL | L)$ &
$(\verb|∪_ | L)$ \\ \hline
添字付共通関係 &
$\sqcap_{\lambda \in \Lambda} \alpha_\lambda$ &
$(\verb|capL | L)$ &
$(\verb|∩_ | L)$ \\ \hline
条件付和関係 &
$\sqcup_{P(\lambda)} \alpha_\lambda$ &
$(\verb|cupP | L \, P)$ &
$(\verb|∪p | P \verb|,| L)$ \\ \hline
\end{tabular}
\end{center}
\caption{関係の表記について}\label{notation}
\end{table}
% **)

Module Type TA.
 Parameter para:Set.
End TA.

Module Type TB.
 Parameter parb:Set.
End TB.

Module tb_f(ta:TA):TB.

Definition parb:=nat.
Lemma xxx:ta.para.
Admitted.
End tb_f.

Module ta:TA.

Definition para:=nat.
End ta.

Module tb:=tb_f(ta).

Definition Rel (A B : eqType) := A -> B -> Prop.

Parameter inverse : (forall A B : eqType, Rel A B -> Rel B A).
Notation "a #" := (inverse _ _ a) (at level 20).
Parameter composite : (forall A B C : eqType, Rel A B -> Rel B C -> Rel A C).
Notation "a '・' b" := (composite _ _ _ a b) (at level 50).
Parameter residual : (forall A B C : eqType, Rel A B -> Rel B C -> Rel A C).
Notation "a '△' b" := (residual _ _ _ a b) (at level 50).

Parameter identity : (forall A : eqType, Rel A A).
Notation "'Id'" := identity.
Parameter empty : (forall A B : eqType, Rel A B).
Notation "'φ'" := empty.
Parameter universal : (forall A B : eqType, Rel A B).
Notation "'∇'" := universal.

Parameter include : (forall A B : eqType, Rel A B -> Rel A B -> Prop).
Notation "a '⊆' b" := (include _ _ a b) (at level 50).
(* Rel_Eq (≡) は, こちらでは採用していない. 集合論での定義と違い a ≡ b -> a = b が示せなくなるため, 証明での rewrite や replace が今まで以上に困難になると予想されるためである. *)

Parameter cup : (forall A B : eqType, Rel A B -> Rel A B -> Rel A B).
Notation "a '∪' b" := (cup _ _ a b) (at level 50).
Parameter cap : (forall A B : eqType, Rel A B -> Rel A B -> Rel A B).
Notation "a '∩' b" := (cap _ _ a b) (at level 50).
Parameter rpc : (forall A B : eqType, Rel A B -> Rel A B -> Rel A B).
Notation "a '>>' b" := (rpc _ _ a b) (at level 50).
Definition complement {A B : eqType} (alpha : Rel A B) := alpha >> φ A B.
Notation "a '^'" := (complement a) (at level 20).
Definition difference {A B : eqType} (alpha beta : Rel A B) := alpha ∩ beta ^.
Notation "a -- b" := (difference a b) (at level 50).
(* complement および difference は, Dedekind 圏の公理に登場しないため, Parameter ではなく Definition で定義している. *)

Parameter cupL : (forall A B L : eqType, (L -> Rel A B) -> Rel A B).
Notation "'∪_' a" := (cupL _ _ _ a) (at level 50).
Parameter capL : (forall A B L : eqType, (L -> Rel A B) -> Rel A B).
Notation "'∩_' a" := (capL _ _ _ a) (at level 50).
Parameter cupP : (forall A B L : eqType, (L -> Rel A B) -> (L -> Prop) -> Rel A B).
Notation "'∪p' p ',' a" := (cupP _ _ _ a p) (at level 50).

Notation "'i'" := unit_eqType.

(** %
\section{関数の定義}
\begin{screen}
$\alpha :A \rel B$ に対し, 全域性 \verb|total_r|, 一価性 \verb|univalent_r|, 関数 \verb|function_r|, 全射 \verb|surjective_r|, 単射 \verb|injective_r|, 全単射 \verb|bijection_r| を以下のように定義する.
\begin{itemize}
\item \verb|total_r| : $id_A \sqsubseteq \alpha \cdot \alpha^\sharp$
\item \verb|univalent_r| : $\alpha^\sharp \cdot \alpha \sqsubseteq id_B$
\item \verb|function_r| : $id_A \sqsubseteq \alpha \cdot \alpha^\sharp \land \alpha^\sharp \cdot \alpha \sqsubseteq id_B$
\item \verb|surjection_r| : $id_A \sqsubseteq \alpha \cdot \alpha^\sharp \land \alpha^\sharp \cdot \alpha = id_B$
\item \verb|injection_r| : $id_A = \alpha \cdot \alpha^\sharp \land \alpha^\sharp \cdot \alpha \sqsubseteq id_B$
\item \verb|bijection_r| : $id_A = \alpha \cdot \alpha^\sharp \land \alpha^\sharp \cdot \alpha = id_B$
\end{itemize}
\end{screen}
% **)
Definition total_r {A B : eqType} (alpha : Rel A B) := (Id A) ⊆ (alpha ・ alpha #).
Definition univalent_r {A B : eqType} (alpha : Rel A B) := (alpha # ・ alpha) ⊆ (Id B).
Definition function_r {A B : eqType} (alpha : Rel A B)
 := (total_r alpha) /\ (univalent_r alpha).
Definition surjection_r {A B : eqType} (alpha : Rel A B)
 := (function_r alpha) /\ (total_r (alpha #)).
Definition injection_r {A B : eqType} (alpha : Rel A B)
 := (function_r alpha) /\ (univalent_r (alpha #)).
Definition bijection_r {A B : eqType} (alpha : Rel A B)
 := (function_r alpha) /\ (total_r (alpha #)) /\ (univalent_r (alpha #)).

(** %
\section{関係の公理}
今後の諸定理の証明は, 原則以下の公理群, およびそれらから導かれる補題のみを用いて行っていくことにする.
% **)

(** %
\subsection{Dedekind 圏の公理}
\begin{screen}
\begin{axiom}[comp\_id\_l, comp\_id\_r]
Let $\alpha :A \rel B$. Then,
$$
id_A \cdot \alpha = \alpha \cdot id_B = \alpha.
$$
\end{axiom}
\end{screen}
% **)

Definition statement1 := forall (A B : eqType)(alpha : Rel A B), Id A ・ alpha = alpha.

Module Type TREL.
  ...
  Parameter axiom1a : statement1.
(*Axiom comp_id_l : axiom1a.*)
End TREL.

Require Import FunctionalExtensionality.

Module trel : TREL.
  ...
Lemma axiom1a : statement1.
Proof.
move => A B alpha.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split.
elim => a0.
elim => H H0.
rewrite H.
apply H0.
move => H.
exists a.
split.
by [].
apply H.
Qed.

End trel.

Definition axiom1b := forall (A B : eqType)(alpha : Rel A B), alpha ・ Id B = alpha.
Axiom comp_id_r : axiom1b.

(** %
\begin{screen}
\begin{axiom}[comp\_assoc]
Let $\alpha :A \rel B$, $\beta :B \rel C$, and $\gamma :C \rel D$. Then,
$$
(\alpha \cdot \beta) \cdot \gamma = \alpha \cdot (\beta \cdot \gamma).
$$
\end{axiom}
\end{screen}
% **)
Definition axiom2 :=
 forall (A B C D : eqType)(alpha : Rel A B)(beta : Rel B C)(gamma : Rel C D),
 (alpha ・ beta) ・ gamma = alpha ・ (beta ・ gamma).
Axiom comp_assoc : axiom2.

(** %
\begin{screen}
\begin{axiom}[inc\_refl]
Let $\alpha :A \rel B$. Then,
$$
\alpha \sqsubseteq \alpha.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom3 := forall (A B : eqType)(alpha : Rel A B), alpha ⊆ alpha.
Axiom inc_refl : axiom3.

(** %
\begin{screen}
\begin{axiom}[inc\_trans]
Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
\alpha \sqsubseteq \beta \land \beta \sqsubseteq \gamma \Rightarrow \alpha \sqsubseteq \gamma.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom4 := forall (A B : eqType)(alpha beta gamma : Rel A B),
 alpha ⊆ beta -> beta ⊆ gamma -> alpha ⊆ gamma.
Axiom inc_trans : axiom4.

(** %
\begin{screen}
\begin{axiom}[inc\_antisym]
Let $\alpha , \beta :A \rel B$. Then,
$$
\alpha \sqsubseteq \beta \land \beta \sqsubseteq \alpha \Rightarrow \alpha = \beta.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom5 := forall (A B : eqType)(alpha beta : Rel A B),
 alpha ⊆ beta -> beta ⊆ alpha -> alpha = beta.
Axiom inc_antisym : axiom5.

(** %
\begin{screen}
\begin{axiom}[inc\_empty\_alpha]
Let $\alpha :A \rel B$. Then,
$$
\phi_{AB} \sqsubseteq \alpha.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom6 := forall (A B : eqType)(alpha : Rel A B), φ A B ⊆ alpha.
Axiom inc_empty_alpha : axiom6.

(** %
\begin{screen}
\begin{axiom}[inc\_alpha\_universal]
Let $\alpha :A \rel B$. Then,
$$
\alpha \sqsubseteq \nabla_{AB}.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom7 := forall (A B : eqType)(alpha : Rel A B), alpha ⊆ ∇ A B.
Axiom inc_alpha_universal : axiom7.

(** %
\begin{screen}
\begin{axiom}[inc\_cap]
Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
\alpha \sqsubseteq (\beta \sqcap \gamma) \Leftrightarrow \alpha \sqsubseteq \beta \land \alpha \sqsubseteq \gamma.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom8 := forall (A B : eqType)(alpha beta gamma : Rel A B),
 alpha ⊆ (beta ∩ gamma) <-> (alpha ⊆ beta) /\ (alpha ⊆ gamma).
Axiom inc_cap : axiom8.

(** %
\begin{screen}
\begin{axiom}[inc\_cup]
Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
(\beta \sqcup \gamma) \sqsubseteq \alpha \Leftrightarrow \beta \sqsubseteq \alpha \land \gamma \sqsubseteq \alpha.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom9 := forall (A B : eqType)(alpha beta gamma : Rel A B),
 (beta ∪ gamma) ⊆ alpha <-> (beta ⊆ alpha) /\ (gamma ⊆ alpha).
Axiom inc_cup : axiom9.

(** %
\begin{screen}
\begin{axiom}[inc\_capL]
Let $\alpha , \beta_\lambda :A \rel B$. Then,
$$
\alpha \sqsubseteq (\sqcap_{\lambda \in \Lambda} \beta_\lambda) \Leftrightarrow \forall \lambda \in \Lambda , \alpha \sqsubseteq \beta_\lambda.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom10 := forall (A B L : eqType)(alpha : Rel A B)(beta_L : L -> Rel A B),
 alpha ⊆ (∩_ beta_L) <-> forall l : L, alpha ⊆ beta_L l.
Axiom inc_capL : axiom10.

(** %
\begin{screen}
\begin{axiom}[inc\_cupL]
Let $\alpha , \beta_\lambda :A \rel B$. Then,
$$
(\sqcup_{\lambda \in \Lambda} \beta_\lambda) \sqsubseteq \alpha \Leftrightarrow \forall \lambda \in \Lambda , \beta_\lambda \sqsubseteq \alpha.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom11 := forall (A B L : eqType)(alpha : Rel A B)(beta_L : L -> Rel A B),
 (∪_ beta_L) ⊆ alpha <-> forall l : L, beta_L l ⊆ alpha.
Axiom inc_cupL : axiom11.

(** %
\begin{screen}
\begin{axiom}[inc\_rpc]
Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
\alpha \sqsubseteq (\beta \Rightarrow \gamma) \Leftrightarrow (\alpha \sqcap \beta) \sqsubseteq \gamma.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom12 := forall (A B : eqType)(alpha beta gamma : Rel A B),
 alpha ⊆ (beta >> gamma) <-> (alpha ∩ beta) ⊆ gamma.
Axiom inc_rpc : axiom12.

(** %
\begin{screen}
\begin{axiom}[inv\_invol]
Let $\alpha :A \rel B$. Then,
$$
(\alpha^\sharp)^\sharp = \alpha.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom13 := forall (A B : eqType)(alpha : Rel A B), (alpha #) # = alpha.
Axiom inv_invol : axiom13.

(** %
\begin{screen}
\begin{axiom}[comp\_inv]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then,
$$
(\alpha \cdot \beta)^\sharp = \beta^\sharp \cdot \alpha^\sharp.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom14 := forall (A B C : eqType)(alpha : Rel A B)(beta : Rel B C),
 (alpha ・ beta) # = (beta # ・ alpha #).
Axiom comp_inv : axiom14.

(** %
\begin{screen}
\begin{axiom}[inc\_inv]
Let $\alpha , \beta :A \rel B$. Then,
$$
\alpha \sqsubseteq \beta \Rightarrow \alpha^\sharp \sqsubseteq \beta^\sharp.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom15 :=
 forall (A B : eqType)(alpha beta : Rel A B), alpha ⊆ beta -> alpha # ⊆ beta #.
Axiom inc_inv : axiom15.

(** %
\begin{screen}
\begin{axiom}[dedekind]
Let $\alpha :A \rel B$, $\beta :B \rel C$, and $\gamma :A \rel C$. Then,
$$
(\alpha \cdot \beta) \sqcap \gamma \sqsubseteq (\alpha \sqcap (\gamma \cdot \beta^\sharp)) \cdot (\beta \sqcap (\alpha^\sharp \cdot \gamma)).
$$
\end{axiom}
\end{screen}
% **)
Definition axiom16 :=
 forall (A B C : eqType)(alpha : Rel A B)(beta : Rel B C)(gamma : Rel A C),
 ((alpha ・ beta) ∩ gamma)
 ⊆ ((alpha ∩ (gamma ・ beta #)) ・ (beta ∩ (alpha # ・ gamma))).
Axiom dedekind : axiom16.

(** %
\begin{screen}
\begin{axiom}[inc\_residual]
Let $\alpha :A \rel B$, $\beta :B \rel C$, and $\gamma :A \rel C$. Then,
$$
\gamma \sqsubseteq (\alpha \rhd \beta) \Leftrightarrow \alpha^\sharp \cdot \gamma \sqsubseteq \beta.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom17 :=
 forall (A B C : eqType)(alpha : Rel A B)(beta : Rel B C)(gamma : Rel A C),
 gamma ⊆ (alpha △ beta) <-> (alpha # ・ gamma) ⊆ beta.
Axiom inc_residual : axiom17.

(** %
\subsection{排中律}
\begin{screen}
Dedekind 圏の公理のほかに, 以下の ``排中律'' を仮定すれば, 与えられる圏は Schr$\ddot{\mbox{o}}$der 圏となり, Bool 代数の性質も満たされる.
\begin{axiom}[complement\_classic]
Let $\alpha :A \rel B$. Then,
$$
\alpha \sqcup \alpha^- = \nabla_{AB}
$$
\end{axiom}
\end{screen}
% **)
Definition axiom18 := forall (A B : eqType)(alpha : Rel A B),
 alpha ∪ alpha ^ = ∇ A B.
Axiom complement_classic : axiom18.

(** %
\subsection{単域}
\begin{screen}
1 点集合 $I$ が単域となるための条件は
$$
\phi_{II} \neq id_I \land id_I = \nabla_{II} \land \forall X, \nabla_{XI} \cdot \nabla_{IX} = \nabla_{XX}
$$
だが, Rel の定義から左 2 つは証明できるため, 右の式だけ仮定する.
\begin{axiom}[unit\_universal]
$$
\nabla_{AI} \cdot \nabla_{IA} = \nabla_{AA}
$$
\end{axiom}
\end{screen}
% **)
Definition axiom19 := forall (A : eqType), ∇ A i ・ ∇ i A = ∇ A A.
Axiom unit_universal : axiom19.

(** %
\subsection{点公理}
\begin{screen}
まずは Dedekind 圏にない ``条件付和関係'' を定義する公理から.
\begin{axiom}[inc\_cupP]
Let $\alpha , \beta_\lambda :A \rel B$ and $P$ : predicate. Then,
$$
(\sqcup_{P(\lambda)} \beta_\lambda) \sqsubseteq \alpha \Leftrightarrow (\forall \lambda \in \Lambda , P(\lambda) \Rightarrow \beta_\lambda \sqsubseteq \alpha).
$$
\end{axiom}
\end{screen}
% **)
Definition axiom20 :=
 forall (A B L : eqType)(alpha : Rel A B)(beta_L : L -> Rel A B)(P : L -> Prop),
 (∪p P , beta_L) ⊆ alpha <-> forall l : L, P l -> beta_L l ⊆ alpha.
Axiom inc_cupP : axiom20.

(** %
\begin{screen}
この ``弱選択公理'' を仮定すれば, 排中律と単域の存在(厳密には全域性公理)を利用して点公理を導出できる.
\begin{axiom}[weak\_axiom\_of\_choice]
Let $\alpha :I \rel A$ be a total relation. Then,
$$
\exists \beta :I \to A, \beta \sqsubseteq \alpha.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom21 := forall (A : eqType)(alpha : Rel i A),
 total_r alpha -> exists beta : Rel i A, function_r beta /\ beta ⊆ alpha.
Axiom weak_axiom_of_choice : axiom21.

(** %
\subsection{関係の有理性}
\begin{screen}
集合論では色々インポートしながら頑張って証明したので, できればそちらもご参照ください.
\begin{axiom}[rationality]
Let $\alpha :A \rel B$. Then,
$$
\exists R, \exists f:R \to A, \exists g:R \to B, \alpha = f^\sharp \cdot g \land f \cdot f^\sharp \sqcap g \cdot g^\sharp = id_R.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom22 := forall (A B : eqType)(alpha : Rel A B),
 exists (R : eqType)(f : Rel R A)(g : Rel R B),
 function_r f /\ function_r g /\ alpha = f # ・ g /\ ((f ・ f #) ∩ (g ・ g #)) = Id R.
Axiom rationality : axiom22.

(** %
\subsection{直和と直積}
\begin{screen}
任意の直和に対して, 入射対が存在することを仮定する.
\begin{axiom}[pair\_of\_inclusions]
$\exists j:A \to A+B, \exists k:B \to A+B, $
$$
j \cdot j^\sharp = id_A \land k \cdot k^\sharp = id_B \land j \cdot k^\sharp = \phi_{AB} \land j^\sharp \cdot j \sqcup k^\sharp \cdot k = id_{A+B}.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom23 :=
 forall (A B : eqType), exists (j : Rel A (sum_eqType A B))(k : Rel B (sum_eqType A B)),
 j ・ j # = Id A /\ k ・ k # = Id B /\ j ・ k # = φ A B /\
 (j # ・ j) ∪ (k # ・ k) = Id (sum_eqType A B).
Axiom pair_of_inclusions : axiom23.

(** %
\begin{screen}
任意の直積に対して, 射影対が存在することを仮定する.
\begin{axiom}[pair\_of\_projections]
$\exists p:A \times B \to A, \exists q:A \times B \to B,$
$$
p^\sharp \cdot q = \nabla_{AB} \land p \cdot p^\sharp \sqcap q \cdot q^\sharp = id_{A \times B}.
$$
\end{axiom}
\end{screen}
% **)
Definition axiom24 :=
 forall (A B : eqType), exists (p : Rel (prod_eqType A B) A)(q : Rel (prod_eqType A B) B),
 p # ・ q = ∇ A B /\ (p ・ p #) ∩ (q ・ q #) = Id (prod_eqType A B) /\ univalent_r p /\ univalent_r q.
Axiom pair_of_projections : axiom24.


(**************************************************************************
* Useful General-Purpose Tactics for Coq - Demo scripts                   *
* Arthur Chargueraud                                                      *
* Distributed under the terms of the LGPL-v3 license                      *
***************************************************************************)

Set Implicit Arguments.
Require Import LibTactics.

(* ********************************************************************** *)
(** ** Definitions used in demos *)

Variables H1 H2 H3 H4 H5 H6 : Prop.
Variables P1 P2 P3 : nat -> Prop.

(* ********************************************************************** *)
(** ** Assertions, cuts, contradiction *)

Lemma demo_false_1 :
  forall (n:nat), (forall m, m = n -> False) -> H1.
Proof.
  intros n P. dup 5.
  (* [false_goal] replaces the current goal by [False] *)
  false. eapply P. reflexivity.
  (* [false E] proves the goal if [E] has type [False] *)
  false (P n (refl_equal n)).
  (* [false E] is in fact the same as [false; apply E] *)
  false P. reflexivity.
  (* [false*] is short for [false; eauto] *)
  false*.
  (* [false] also tries and call [congruence] *)
  lets: (P n). false.
Qed.

Lemma demo_false_2 :
  0 = 1 -> 1 = 2.
Proof.
  intros. dup 3.
  (* [contradiction] does not cover [discriminate] *)
  try contradiction. skip.
  discriminate.
  (* while [false] covers [contradiction] and [discriminate] *)
  false.
Qed.

Lemma demo_false_3 :
  (forall b, b = false) -> False.
Proof.
  introv H. dup.
  (* [false E] is able to use [forwards E] to exhibit
     a contradiction. *)
  false (>> H true).
  (* syntax [false E1 .. EN] is also available *)
  false H true.
Qed.

Lemma demo_tryfalse :
  forall n, S n = 1 -> n = 0.
Proof.
  intros. dup 2.
  (* often in a case analysis, several subcases are absurd. example: *)
  destruct n. auto. false.
  (* [tryfalse] removes all the subcases solved by [false] *)
  destruct n; tryfalse. auto.
Qed.

Lemma demo_asserts_cuts :
  True.
Proof.
  dup 7.
  (* here is another syntax for assert *)
  asserts U: H2. skip. skip.
  (* that allows for intro-patterns *)
  asserts [U V]: (H2 /\ H3). skip. skip.
  (* the intro-pattern [U [V W]] may be simply written U V W *)
  asserts U V W: (H2 /\ H3 /\ H4). skip. skip.
  (* this is also convenient for existentials *)
  asserts x y E F: (exists x y, S x = y /\ x > 0). skip. skip.
  (* if no pattern is provided, a fresh name is generated *)
  asserts: (H2 /\ H3). skip. skip.
  (* [asserts~] calls [auto] only on the asserted proposition. *)
  asserts~ U: (0 = 0). skip.
  (* [cuts] is like [asserts] except it swaps subgoals *)
  cuts U V: (H2 /\ H3). skip. skip.
Qed.

(* ********************************************************************** *)
(** ** Assumptions *)

Lemma demo_lets :
  (H1 -> H2 -> H3 /\ H4) -> (H1 -> H2) -> H1 -> H3.
Proof.
  intros P Q R.
  (* [lets] is a tactic for naming a term *)
  lets U: (Q R).
  (* [lets] can decompose terms with a patterns *)
  lets [V W]: (P R U).
  (* again, the syntax for conjunctions applies *)
  lets V1 W1: (P R U).
  (* [lets] without an intro-pattern generates a fresh name *)
  lets: (P R).
  (* [lets] on an existing hypothesis makes a copy of it *)
  lets U': U.
  skip.
Qed.

(* ********************************************************************** *)
(** * Apply *)

Definition Dup x := x + x.

Lemma demo_applys : forall P : (nat -> nat) -> nat -> Prop,
  (forall f, P f (f 0)) -> P Dup 0.
Proof.
  intros. dup 4.
  (* while apply is able to do some unification *)
  apply (H Dup).
  (* since CoqV8.2, apply is able to do this unfolding *)
  apply H.
  (* before, one had to use [refine] *)
  refine (H _).
  (* [applys H] is simply [refine (H _ ... _)] with enough many underscores *)
  applys H.
Qed.

Lemma demo_applys_to :
  (H1 -> H2 -> H3 /\ H4) -> (H1 -> H2) -> H1 -> H3.
Proof.
  introv P Q R. dup.
  (* [applys_to R] is used to apply a lemma to [R] and name R the result *)
  applys_to R Q. skip.
  (* another example *)
  applys_to R P. skip.
Qed.

(* ********************************************************************** *)
(** * Introduction *)

Section IntrovTest.

Variables P1 P2 P3 : nat -> Prop.

Lemma demo_introv_1 :
  forall a b, P1 a -> P2 b -> forall c d, P3 c -> P1 d -> c = b.
Proof.
  dup 4.
  (* [introv] introduces all the variables which are not hypotheses,
     more precisely all the variables used dependently. *)
  introv.
  (* if there is no more head variables, and no definition can
     be unfolded at head of the goal, it does not do anything *)
  introv. skip.
  (* [introv A] introduces all variables, then does [intros A] *)
  introv A. introv B. introv. intros C D. skip.
  (* [introv] may take several arguments, as illustrated below *)
  introv A B. introv. skip.
  introv A B C D. skip.
Qed.

Definition Same (x y : nat) := True -> x = y.
Definition Sym (x:nat) := forall y, x = y -> Same y x.

Lemma demo_introv_2 :
  forall a, Sym a.
Proof.
  dup 4.
  (* [introv] introduces a variable but no subsequent definition *)
  introv.
  (* [introv] unfolds definition if no variable is visible *)
  introv. skip.
  (* [introv E] unfolds definitions until finding an hypothesis *)
  introv E. introv F. skip.
  (* [introv E F] unfolds several definitions if needed *)
  introv E F. skip.
  (* [introv] may unfold definition without any introduction *)
  introv E. introv. skip.
Qed.

Lemma demo_introv_3 :
  forall a, a = 0 -> Sym a.
Proof.
  dup 5. (* more examples *)
  (* introduces [a] only *)
  introv. skip.
  (* introduces [a = 0] *)
  introv E. skip.
  (* introduces [a = 0] and [a = y] *)
  introv E F. skip.
  (* introduces [a = 0] and [a = y] and [True] *)
  introv E F G. skip.
  (* introduction of more names fails *)
  try (introv E F G H). skip.
Qed.

Definition TestSym := (forall a, a = 0 -> Sym a).

Lemma demo_introv_4 :
  TestSym.
Proof.
  dup 2. (* same as before, except the goal itself is a definition *)
  (* introduces [a] only *)
  introv. skip.
  (* introduces [a = 0] *)
  introv E. skip.
Qed.

Lemma demo_introv_5 :
  forall a, a = 0 -> ~ Sym a.
Proof.
  dup 2. (* playing with negation *)
  (* introduces [a = 0] *)
  introv E. skip.
  (* introduces [a = 0] and [Sym a] *)
  introv E F. skip.
Qed.

(* Iterated unfolding to get hypotheses *)

Definition AllSameAs (x:nat) := forall y, Same y x.
Definition AllSame := forall x, AllSameAs x.

Lemma demo_introv_6 :
  AllSame.
Proof.
  dup 2.
  (* introduces only [x], then only [y] *)
  introv. introv. skip.
  (* introduces [x] and [y] and [True] *)
  introv E. skip.
Qed.

Definition AllSameAgain := AllSame.

Lemma demo_introv_7 :
  AllSameAgain.
Proof.
  dup 2.
  (* introduces only [x], then only [y] *)
  introv. introv. skip.
  (* introduces [x] and [y] and [True] *)
  introv E. skip.
Qed.

Lemma demo_introv_8 :
  forall a (c:nat) b, P1 a -> P2 b -> True.
Proof.
  (* notice that variables which are not used dependently
     are treated as hypotheses, e.g. variable [c] below.
     This might not be the desired behaviour, but that's
     all I'm able to implement in Ltac. *)
  introv c E F. skip.
Qed.

Definition IMP P A (x y : A) := P -> x = y.

Lemma demo_intros_all :
     (forall a b, P1 a -> P2 b -> IMP H1 a b)
  /\ (forall a b, a = 0 -> b = 1 -> ~ (a = b)).
Proof.
  split.
  (* [intros_all] introduces as many arguments as possible *)
  intros_all. skip.
  intros_all. skip.
Qed.

(* An example showing that [intro] is not very-well
   specified with respect to beta-reduction, explaining
   why [introv] isn't doing better. *)

Definition testing f :=
  forall (x:nat), f x -> True.

Lemma demo_introv_what_to_do : testing (fun a => a = 0).
Proof.
  dup.
    intro. skip. (* does beta-reduce f *)
    hnf. intro. skip. (* does not beta-reduce f *)
Qed.

End IntrovTest.

(* ********************************************************************** *)
(** * Generalization, naming *)

Lemma demo_gen_and_generalizes :
  forall P Q : nat -> nat -> nat -> Prop,
  forall a b c, P a b c -> Q a a a -> P b b c -> True.
Proof.
  intros. dup 3.
  (* [gen] generalizes an hypothesis and clears it *)
  gen H. skip.
  (* it generalizes all the dependencies of a variable *)
  gen a. skip.
  (* it also works for several variables at once *)
  gen b c. skip.
Qed.

Inductive ind : nat -> Prop :=
  | ind_0 : ind 0
  | ind_S : forall n, ind n -> ind (S n)
  | ind_SS : forall n, ind n -> ind (S (S n))
  | ind_P : forall (A:Type) (P:A->Prop) (f:A->nat) (a:A),
       ind (f a) -> P a -> ind (S (f a)).

Lemma demo_sets_and_set_eq_and_sets_eq : forall n,
  ind (3 + n) -> ind (7 + n) -> ind (7 + n).
Proof.
  introv M1 M2. dup 9.
  (* [sets] introduces a name and performs the substitution *)
  sets a: (3+n). skip.
  sets b: (7+n). skip.
  (* [set_eq] introduces an equality *)
  set_eq a Ha: (7+n). skip.
  (* [sets_eq] introduces an equality and substitutes *)
  sets_eq a Ha: (7+n). skip.
  (* the name of the hypothesis can be generated *)
  sets_eq a: (7+n). skip.
  (* the name of the variable can also be generated *)
  sets_eq: (7+n). skip.
  (* [set_eq in H] performs the substitution in [H] *)
  set_eq a: (7+n) in M2. skip.
  (* [set_eq in |-] performs no substitution *)
  set_eq a: (7+n) in |-. skip.
  (* [set_eq <-] generates the equality [7+n=a] *)
  sets_eq <- a: (7+n). skip.
Qed.

Lemma demo_sets_let_and_sets_eq_let : forall n1 n2 : nat,
  (let x := n1 + n2 in x = x) ->
  (let y := n2 + n1 in let z := y + y in z = z) ->
  (let t := n1 + n1 in t = t).
Proof.
  intros n1 n2 M1 M2. dup 3.
  (* [sets_let x] introduces a local definition for a let;
     note that, due to a limitation of Coq, only one local
     binding can be named! *)
  sets_let a. sets_let b. sets_let c. auto.
  (* the hypothesis where to look can be specified *)
  sets_let a in M1. auto.
  (* [sets_eq_let] introduces explicit equalities like [sets_eq] *)
  sets_eq_let a. sets_eq_let b. sets_eq_let c. auto.
Qed.

(* ********************************************************************** *)
(** * Evars *)

Lemma demo_check_noevar_goal : forall (n:nat),
  (forall m, m = n -> True) -> True.
Proof.
  intros. check_noevar_goal. eapply H.
  try check_noevar_goal. dup.
  reflexivity. check_noevar_goal. auto.
Qed.

(* ********************************************************************** *)
(** * Unfolding *)

Definition Id A (x:A) := x.

Lemma demo_unfolds_folds :
  forall a b, a = Id(b) -> Dup a = 0 -> Dup b = Id(0+0).
Proof.
  intros. dup 2.
  (* [unfolds] is same as [unfold in *] *)
  unfolds Dup. skip.
  (* [unfolds] can take several arguments *)
  unfolds Id,Dup.
  subst b.
  (* [folds] is same as [fold in *]. *)
  folds (Dup a). skip.
Qed.

Definition Twice (P:Prop) := True -> P /\ P.

Lemma demo_unfolds_head_definition :
  forall P:Prop, (True -> P) -> Twice P -> Twice P.
Proof.
  introv A B.
  (* [unfolds] without arguments unfolds the head definition *)
  unfolds.
  (* it also applies to an hypothesis *)
  unfolds in B.
  skip.
Qed.

(* ********************************************************************** *)
(** * Simplification *)

Lemma demo_simpls_and_unsimpl :
  forall a b, Dup a = (1+1) -> Dup b = Id(0+0).
Proof.
  intros.
  (* [simpls] is same as [simpl in *] *)
  simpls.
  (* [unsimpl] can be used to undo a simplification *)
  unsimpl (0+0).
  unsimpl (2+0) in H.
  skip.
Qed.

(* ********************************************************************** *)
(** * Substitution *)

(* DEPRECATED: [subst] tactic has been fixed

Lemma demo_substs_1 : forall a b c d e : nat,
  a = b -> b = c -> d = e -> e = d -> P1 d -> P2 a -> P3 c.
Proof.
  introv P Q R U V. dup 2.
  (* [subst] does not work with circular equalities *)
  try subst. skip.
  (* [substs] does work however *)
  substs. skip.
Qed.

Lemma demo_substs_2 : forall x y (f:nat->nat),
  x = f x -> y = x -> y = f x.
Proof.
  intros.
  (* [subst] does not work *)
subst.
  try subst.
  (* [substs] does work *)
  substs.
  assumption.
Qed.

*)

Lemma subst_hyp_demo : forall (x y x' y' z z' : nat) (P:nat->Prop),
  (x,y,z) = (x',y',z') ->
  P x -> P x' -> P y -> P y' -> P z -> P z' ->
  z = z'.
Proof.
  introv H. intros.
  subst_hyp_base H. auto.
Qed.

(* ********************************************************************** *)
(** * Rewriting *)

Lemma demo_rewrites :
  (forall n m, m + n = n + m) -> 3 + 4 = 7.
Proof.
  introv H. dup.
  (* [rewrites] support the [rm] identity tag to remove hypothesis *)
  rewrites (rm H). skip.
  (* [rewrites] can take arguments like [forwards] -- see further *)
  rewrites (>> H __ 3). skip.
Qed.

Lemma demo_rewrites_at : forall x y z,
  x = y + y -> x + x = z -> z + z = x + x + x + x.
Proof.
  introv E H. dup.
  (* [rewrite] rewrites in all similar occurences *)
  rewrite E. skip.
  (* [rewrites at] can be used to control the target of rewrite *)
  rewrites E at 2.
  rewrites E at 2 in H.
  rewrites <- H at 2.
  skip.
Qed.

Lemma demo_rewrite_all :
  (forall n, n + 0 = 0 + n) ->
  (3 + 0) + 0 = 5 + 0.
Proof.
  intros E.
  (* [rewrite_all] is same as [repeat rewrite] *)
  rewrite_all E. skip.
Qed.

Lemma demo_asserts_and_cuts_rewrite : forall n,
  0 < n < 2 -> P1 1 -> P1 n.
Proof.
  introv Lt H. dup 2.
  (* [asserts_rewrite] rewrites and generates a proof obligation *)
  asserts_rewrite (n = 1). skip. skip.
  (* same for [cuts_rewrite], except the subgoals are swapped *)
  cuts_rewrite (n = 1). skip. skip.
Qed.

Lemma demo_replaces : forall a b, a = b + b -> a + a + a = 3 * a.
Proof.
  intros. dup 3.
  (* [replaces] replaces all occurences (the equality subgoal is first) *)
  replaces a with 3. skip. skip.
  (* [replaces at] replaces at a given occurence *)
  replaces a at 2 with 5. skip. skip.
  (* [replaces] and [replaces at] works in hypotheses *)
  replaces b at 2 with 4 in H. skip. skip.
Qed.

Lemma demo_pi_rewrite : forall (P:Prop) (X:P->nat) (p1 p2:P),
   X p1 + X p2 = X p2 + X p1.
Proof.
  (* [pi_rewrite E] replaces any proposition [E] with an evar
     of the same type. This is very useful when working with
     terms that are unifiable modulo proof irrelevance *)
  intros. pi_rewrite p1. reflexivity.
Qed.

(* ********************************************************************** *)
(** * Inversions *)

Inductive even_shift : nat -> nat -> Prop :=
  | even_0 : even_shift 0 2
  | even_SS : forall n m, even_shift n m ->
              even_shift (S (S n)) (S (S m)).

Lemma demo_invert :
  even_shift 4 8 -> False.
Proof.
  intros P. dup 12.
  (* [inversion] generates a lot of ugly stuff *)
  inversion P. inversion H7. inversion H10.
  (* [inversions H] is short for [inversion H; subst; clear H] *)
  inversions P. inversions H7. inversions H8.
  (* [invert] is same as [inversion H; clear H] except that it
     generalizes the generated hypotheses so that they can
     be named manually using intros or introv *)
  invert P. introv P' EQ1 EQ2. skip.
  (* [invert as] can be used to name the generated hypotheses
     directly, in the [introv] fashion *)
  invert P as P' EQ1 EQ2. skip.
  (* [inverts] does the same as [inversion; clear], then it
     substitutes all the generated equalities (and only
     these fresh equalities, not the older ones) *)
  inverts P. inverts H7. inverts H8.
  (* it is /sometimes/ possible to name the resulting hypotheses *)
  inverts P as P'. inverts P' as P''. inverts P''.
  (* it is even possible to reuse the same name *)
  inverts P as P. inverts P as P. inverts P.
  (* [invert as] without arguments leaves the hypotheses
     that have been generated in the goal *)
  inverts P as. introv P'. skip.
  (* one may add the keyword [keep] in order to keep the
     inverted hypothesis *)
  invert keep P. intros. skip.
  inverts keep P as P' EQ1 EQ2. skip.
  inverts keep P as. introv P'. skip.
  (* [lets_inverts] need to be used to invert expressions
     that are not simply the name of an hypothesis *)
  lets_inverts (conj P P) as H1 H2. skip.
Qed.

(* TODO: false_invert *)

Inductive Behave : Type :=
  | Behave_intro :
      forall (A:Type) (F:A->nat) (P:A->Prop), Behave.

Inductive behave : nat -> Behave -> Prop :=
  | behave_intro : forall (A:Type) (F:A->nat) (P:A->Prop) V,
      P V -> behave (F V) (@Behave_intro A F P).

Lemma demo_dependent_invert :
  behave 4 (Behave_intro (fun x:nat => x) (fun x:nat => x <> 3))
  -> False.
Proof.
  intros H. dup 3.
  (* [inversion] can generate some dependently-typed equalities *)
  inversion H. (* look at H9 and H10 *) skip.
  (* [inverts] carries out all the substitution properly *)
  inverts H. skip.
  (* again, it is possible to name the new hypotheses *)
  inverts H as R1 R2 R3. skip.
Qed.

Lemma demo_inject_and_injects : forall a b c,
  (a,b,c) = (1,2,3) -> b = 2.
Proof.
  introv EQ. dup 5.
  (* [injection] generates some equalities in the goal *)
  injection EQ. skip.
  (* [inject] does the same *)
  inject EQ. skip.
  (* but it is also able to name these hypotheses *)
  inject EQ as EQ1 EQ2 EQ3. skip.
  (* and [injects] can substitute these hypotheses *)
  injects EQ. skip.
  (* it also works if the equalities are in the other direction *)
  symmetry in EQ. injects EQ. skip.
Qed.

(* ********************************************************************** *)
(** * Case_if *)

Lemma demo_case_if : forall b c :bool,
  (if b then true else true) = false ->
  (if c then true else true) = true.
Proof.
  intros. dup 4.
  case_if. auto. auto.
  case_if as P. auto. auto.
  case_if in H.
  case_if in H as P.
Qed.

(* ********************************************************************** *)
(** * F_equal *)

Lemma demo_fequals_1 : forall a b c d,
  b = d -> d = 2 -> a = 1 ->
  (a,b,c) = (1,2,3).
Proof.
  intros. dup 3.
  (* [f_equal] is not really clever on tuples *)
  f_equal. f_equal. skip. skip. skip.
  (* while [fequal] works better *)
  fequal. skip. skip. skip.
  (* even more useful, [fequals] tries to discharge the easy
     subgoals using [reflexivity] and [congruence] *)
  fequals. skip.
Qed.

Lemma demo_fequals_2 : forall f a b c d,
  b = d -> d = 2 -> a = 1 ->
  f a b c = f 1 2 3 :> nat.
Proof.
  intros. dup 2.
  (* [fequal] and [fequals] also work for functions, of course *)
  fequal. skip. skip. skip.
  fequals. skip.
Qed.

(** [fequals] supports proof irrelevance *)

Lemma demo_fequal_post :
  forall (P:Prop) (X:P->nat) (p1 p2:P), X p1 = X p2.
Proof. intros. fequals. Qed.

(* ********************************************************************** *)
(** * Induction *)

Inductive natequal : nat -> nat -> Prop :=
  | natequal_O : natequal 0 0
  | natequal_S : forall n, natequal n n -> natequal (S n) (S n).

(* TODO

Lemma demo_inductions : forall n m p,
  natequal (n + m) (m + p) -> p = n.
Proof.
  intros. dup.
  (* [induction] does not work -- too weak hypotheses *)
  induction H. skip. skip.
  (* but [inductions], based on [dependent induction], does work. *)
  inductions H gen n m p. skip. skip.
Qed.

Lemma demo_inductions' : forall n m,
  natequal (n + m) 0 -> n = 0.
Proof.
  intros. dup.
  (* same *)
  induction H. skip. skip.
  (* correct version *)
  inductions H gen n m. skip.
Qed.

*)

(* ********************************************************************** *)
(** ** N-ary splitting and branching *)

Definition test_split_1 := H1 /\ H2 /\ H3.
Definition test_split_2 := H4 /\ H5 /\ H6 /\ test_split_1.
Definition test_split_3 := test_split_2.

Lemma demo_splits : test_split_3.
Proof.
  dup 5.
  (* spliting a bunch of conjunction is a pain *)
  split. skip. split. skip. split. skip. split. skip. skip.
  (* [splits_all] is short for [repeat split] *)
  splits_all. skip. skip. skip. skip. skip. skip.
  (* but it is sometimes too aggressive. *)
  (* [splits N] splits a conjunction in N parts *)
  splits 4. skip. skip. skip. skip.
  splits 3. skip. skip. skip.
  (* [splits] is able to guess the appropriate arity *)
  splits. skip. skip. skip. splits. skip. skip. skip.
Qed.

Lemma demo_branch :
  1 = 2 \/ 2 = 3 \/ 3 = 4 \/ 4 = 4 \/ 4 = 5 \/ 5 = 6.
Proof.
  dup 6.
  (* [branch K of N] is used to select a branch of a disjunction *)
  branch 1 of 6. skip.
  branch 4 of 6. auto.
  branch 6 of 6. skip.
  (* [branch] can usually guess the appopriate arity *)
  branch 1. skip.
  branch 4. auto.
  branch 6. skip.
Qed.

Lemma demo_destructs :
  1 = 2 /\ (2 = 3 /\ 3 = 4) /\ 4 = 5 -> True.
Proof.
  intros H. destructs H. skip.
Qed.

(* ********************************************************************** *)
(** * Hide, clears, sorts *)

Parameter lemma_hide : forall n, n + 0 = n.

Lemma demo_hide_hyps : forall x:nat, x + 0 = x.
Proof.
  intros.
  (* Any term has the type [Something] *)
  generalize (lemma_hide : Something). intros H.
  generalize (lemma_hide : Something). intros H'.
  (* [show_hyp H] unfolds the definition of [Something] *)
  show_hyp H.
  (* [hide_hyp H] reveals the definition of [Something] *)
  hide_hyp H.
  (* [show_hyps] and [hide_hyps] apply to all hypotheses of sort Prop *)
  show_hyps.
  hide_hyps.
  (* Hidden terms remain convertible with their original value *)
  hnf in H.
  apply H'.
Qed.

Lemma demo_hide_def : forall x:nat,
   let y := x + x in let z := y in y + 0 = y.
Proof.
  intros.
  (* [hide_def x] hides the body of a definition *)
  hide_def y.
  hide_def z.
  (* [show_def x] reveals the body of a definition *)
  show_def y.
  show_def z.
  (* [hide_defs] and [show_defs] applies to all definitions *)
  hide_defs.
  show_defs.
  (* [show_def] can be used to unfold [Something] in the goal *)
  hide_def y.
  unfold y.
  show_def.
  demo.
Qed.

Lemma demo_hide_generic : forall x:nat,
   let y := x + x + x + x in let z := y in y + 0 = y.
Proof.
(* NEWCOQ_BUG
  intros.
  generalize (lemma_hide). intros H.
  (* [hide]/[show] work both for definition and hypotheses *)
  hide H.
  hide y.
  show H.
  show y.
  (* [hide_all]/[show_all] hide everything *)
  hide_all.
  show_all.
  (* Observe that substitution of hidden terms may require
     several unfolding. *)
  hide_all. subst y. show_def z. show_def z.
  (* The tactic [show_all] reveals everything at once *)
  show_all.
  hide_all.
  apply H.
*)
skip.
Qed.

Lemma demo_hide_term : forall x,
  x + x + x = 3.
Proof.
  intros.
  (* using [hide_term E] and [show_term] *)
  hide_term (x+x+x).
  show_term.
  (* typically used in a pattern matching *)
  match goal with |- ?T = _ => hide_term T end.
  demo.
Qed.

Lemma demo_clears : forall (x y z : nat) (A B : Prop),
  (x > 0) ->
  (x <> y) ->
  (A <-> B) ->
  True.
Proof.
  introv z Pos Neq Iff. dup 5.
  (* [clears] is like [clear] except it clears all dependencies *)
  clears y. skip.
  clears x. skip.
  clears x y. skip.
  clears Neq A. skip.
  (* [clears] without arguments clears only unused variables
     (which are not propositions) *)
  clears. skip.
Qed.

Lemma demo_sort :
  forall n : nat,
  n > 0 ->
  forall P Q : Prop,
  (P <-> Q) ->
  forall m : nat,
  m <> n ->
  forall K : nat -> Prop,
  K n ->
  forall p,
  K (m+p) ->
  True.
Proof.
  intros.
  (* [sort] puts all the proposition at the bottom of the context *)
  sort. skip.
Qed.

(* ********************************************************************** *)
(** * Skip *)

Lemma demo_skip : forall n m p : nat,
  n > m -> m >= p -> n > p.
Proof.
  intros. dup 6.
  (* [skip H: E] is used to accept a new fact *)
  skip R1: (m = m). skip.
  skip R1 R2: (m = m /\ n > m+1). skip.
  skip q Q: (exists q, q > p). skip.
  skip: (m <> n). skip.
  (* [skip_rewrite E] is used to accept a fact E and rewrite it *)
  skip_rewrite (m = n) in H0. skip.
  (* [skip_induction] is used to do an induction and cheat on the
     induction hypothesis, by having it as strong as the initial goal *)
  dup.
    induction p. skip. skip.
    skip_induction p. skip. skip.
Qed.

(* DEPRECATED
Lemma demo_skip_with_existential : False.
Proof.
  dup.
  (* [skip'] is the alternative implementation of [skip],
     which forbits [Qed] to be written at the end of the proof *)
  skip'.
  skip'.
Admitted. (* demo *)
*)

(* ********************************************************************** *)
(** ** Advanced instantiation *)

(* Note: the use of "instantiation modes" is described in the overview file
   and described in full details in the source file LibTactics.v *)

Lemma demo_lets_of : forall (x y : nat) (A B : Prop),
  (x > 0) ->
  (x <> y) ->
  (A <-> B) ->
  (forall n, n > 0 -> forall m, n <> m -> exists k, k <> m) ->
  (forall n : nat,
   n > 0 ->
   forall P Q : Prop,
   (P <-> Q) ->
   forall m : nat,
   n <> m ->
   forall K : nat -> Prop,
   K n ->
   forall p,
   K (m+p) ->
   True) ->
  True.
Proof.
  introv Pos Neq Iff L M.
  (* [lets] is used to instantiate a lemma [M] on arguments *)

  lets P: M Iff. eauto. clear P.
  lets P: (>> M Neq). eauto. eauto. clear P.
  lets P: (>> M __ y). eauto. eauto. clear P.
  lets P: (>> M x __ B). eauto. instantiate (1:=A) in P. clear P.
  (* [Hnts] keyword can be omitted *)
  lets P: (>> M __ y Neq). eauto. eauto. clear P.
  (* The syntax [>>] is not required for less than 5 arguments. *)
  lets P: M Pos A B Neq. eauto. clear P.
  (* A triple underscore indicates to instantiate all remaining *)
  lets k K: (>> L Pos ___). eauto. clears k.
  lets k K: (>> L ___). eauto. eauto. clears k.
  (* [forwards I: (>> E E1 .. EN)] is short for
     [lets I: (>> E E1 .. EN ___)] *)
  forwards R: L. eauto. eauto. clear R.
  forwards R: L Pos. eauto. clear R.
  forwards k K: L. eauto. eauto. clears k.
  forwards [k K]: L Pos y. eauto. clears k.
  forwards k K: (>> L x y). eauto. eauto. clears k.
  lets k K: (>> L Neq). eauto. clears k.
  auto.
Qed.

Lemma demo_forwards_1 : forall x : nat, x > 1 ->
  (forall z, z > 1 -> exists y, z < 2 /\ z <> y) ->
  True.
Proof.
  introv Le H. dup 4.
  (* [forwards] is used to instantiate a lemma entirely, generating one
     subgoal for each hypothesis and one existential variable for
     each universally quantified variable *)
  forwards Q: H. eauto. skip.
  (* an introduction-pattern can be used to decompose the result *)
  forwards [y [R1 R2]]: H. eauto. skip.
  (* and [forwards] can also be used without introduction pattern *)
  forwards: H. eauto. skip.
  (* [forwards] does nothing on an hypothesis without quantifiers *)
  forwards: Le. skip.
Qed.

Lemma demo_forwards_2 :
  (forall x y : nat, x = y -> x <= y) ->
  forall a b : nat, a <= a.
Proof.
  intros. dup. (* some more examples *)
    forwards K: (H a). reflexivity. apply K.
    forwards* K: (H a).
Qed.

Lemma demo_applys_specializes : forall (x y : nat) (A B : Prop),
  (x > 0) ->
  (x <> y) ->
  (A <-> B) ->
  (forall n : nat,
   n > 0 ->
   forall P Q : Prop,
   (P <-> Q) ->
   forall m : nat,
   m <> n ->
   True) ->
  True.
Proof.
  introv Pos Neq Iff M. dup 17.
  (* [applys] is used to apply an instantiated lemma. *)
  applys (>> M Pos). eauto. eauto.
  applys (>> M A B). eauto. eauto. eauto.
  applys (>> M Pos Iff). eauto.
  applys (>> M Iff). eauto. eauto.
  applys (>> M x Iff). eauto. eauto.
  applys M x Iff. eauto. eauto.
  (* [specializes] is used to instantiate an hypothesis in-place *)
  specializes M (>> 3). auto.
  specializes M (>> 3 A B). auto. auto.
  specializes M (>> A __ __). eauto. eauto. auto.
  specializes M (>> Pos Iff 2). eauto. auto.
  (* A triple underscore indicates to instantiate all remaining *)
  specializes M (>> Pos ___). eauto. eauto. auto.
  specializes M (>> __ B ___). eauto. eauto. eauto. auto.
  specializes M __. specializes M __. eauto. auto.
  (* [specializes] can be used as [forwards in] thanks to [___] *)
  specializes M ___. eauto. eauto. eauto. auto.
  (* In those tactics, one can apply the constant [rm] to any subterm
     to request the argument of [rm] to be removed from the context. *)
  applys (>> M (rm Pos) Iff). (* [Pos] is gone here *) eauto.
  (* In fact, [rm] can be applied in depth inside terms *)
  specializes M (>> (proj1 (conj (rm Pos) Neq))). (* [Pos] is gone *) auto.
Qed.

(** Similar demos, showing how head definitions are unfolded *)

Definition mydef := forall (n m : nat), n = m -> False.

Lemma demo_specializes_definition :
  forall (i:nat), mydef -> i <> i.
Proof.
  introv H. dup 6.
  (** specializes one by one *)
  specializes H i. specializes H i.
   specializes H (refl_equal i). false.
  (** specializes all arguments *)
  specializes H i i (refl_equal i). false.
  (** specializes skipping some arguments *)
  specializes H (refl_equal i). false.
  (** forwards all arguments *)
  forwards: H. apply (refl_equal i). false.
  (** forwards on one arguments *)
  forwards M: H i. reflexivity. false.
  (** build using lets *)
  lets: (>> H (refl_equal i)). false.
Qed.

(** Unfolding occurs recursively *)

Definition outerdef := mydef.

Lemma demo_specializes_definition_2 :
  forall (i:nat), outerdef -> i <> i.
Proof.
  introv H. dup 6.
  (** specializes one by one *)
  specializes H i. specializes H i.
   specializes H (refl_equal i). false.
  (** specializes all arguments *)
  specializes H i i (refl_equal i). false.
  (** specializes skipping some arguments *)
  specializes H (refl_equal i). false.
  (** forwards all arguments *)
  forwards: H. apply (refl_equal i). false.
  (** forwards on one arguments *)
  forwards M: H i. reflexivity. false.
  (** build using lets *)
  lets: (>> H (refl_equal i)). false.
Qed.

(** On the other hand, definitions that are not at head
    position are not unfolded *)

Definition nesteddef := forall (n:nat), mydef.

Lemma demo_specializes_definition_3 :
  forall (i:nat), nesteddef -> outerdef.
Proof.
  intros i H. dup 4.
  (** forwards does not instantiate [mydef] from [H] *)
  forwards K: H i. skip.
  (** ... unless explicitely visible *)
  unfold nesteddef, mydef in H.
   forwards K: H i. apply (refl_equal i). false.
  (** yet, it should be possible to instantiate arguments
      inside [mydef] if providing explicit arguments *)
  lets K: (>> H i i). skip.
  lets K: (>> H i (refl_equal i)). skip.
Qed.

(* ********************************************************************** *)
(** ** Introduction of equalities to enable [apply] to work *)

Lemma demo_ereplace_working : forall (P:nat->nat->Prop) x y,
  (forall n, P n n) -> (x > 0 -> x = y) -> (x > 0) -> P x y.
Proof.
  introv H E L. dup 4.
  (* here, the hypothesis [P n n] cannot be applied directly *)
  try apply H.
  (* however, we really want to be able to apply it *)
  eapply equates_2. apply H. auto.
  (* this is particularly useful for automation *)
  eapply equates_2; eauto.
  (* the tactic [equates] inputs the position where
     evars should be introduced in place of arguments;
     the indices are to be counted from the right. *)
  equates 2. skip. skip.
Admitted. (* demo *)

Lemma demo_equates_non_dep : forall (P:nat->nat->nat->Prop) x y z,
  P x y z.
Proof.
  intros. dup 6.
  equates 1. skip. skip.
  equates 2. skip. skip.
  equates 3. skip. skip.
  (* multiple [equates] are allowed *)
  equates 1 2. skip. skip. skip.
  equates (>> 1 2). skip. skip. skip.
Admitted. (* demo *)

Lemma demo_equates_dep : forall (P:nat->forall A, A->Prop) x (T:Type) z,
  P x T z.
Proof.
  intros. dup 4.
  equates 1. skip. skip.
  (* replacement of dependent hypotheses is not allowed *)
  try equates 2.
  equates 3. skip. skip.
  equates 1 3. skip. skip. skip.
Admitted. (* demo *)

(* ********************************************************************** *)
(** ** Induction on height of a derivation *)

Section IndHeight.

(** Lambda calculus *)

Inductive trm : Type :=
  | trm_var : nat -> trm
  | trm_abs : nat -> trm -> trm
  | trm_app : trm -> trm -> trm.

Parameter subst : nat -> trm -> trm -> trm.

(** Original big-step reduction judgment *)

Inductive bigred : trm -> trm -> Prop :=
  | bigred_val : forall v,
      bigred v v
  | bigred_abs : forall x t,
      bigred (trm_abs x t) (trm_abs x t)
  | bigred_app : forall t1 t2 x t3 v2 v,
      bigred t1 (trm_abs x t3) ->
      bigred t2 v2 ->
      bigred (subst x v2 t3) v ->
      bigred (trm_app t1 t2) v.

(** Same judgment, with an index to bound the height *)

Inductive bigredh : nat -> trm -> trm -> Prop :=
  | bigredh_val : forall n v,
      bigredh (S n) v v
  | bigredh_abs : forall n x t,
      bigredh (S n) (trm_abs x t) (trm_abs x t)
  | bigredh_app : forall n t1 t2 x t3 v2 v,
      bigredh n t1 (trm_abs x t3) ->
      bigredh n t2 v2 ->
      bigredh n (subst x v2 t3) v ->
      bigredh (S n) (trm_app t1 t2) v.

Require Import Omega.

Hint Extern 1 ((_ < _)%nat) => omega.

Hint Constructors bigred bigredh.

Lemma bigredh_lt : forall n n' t v,
  bigredh n t v -> (n < n')%nat -> bigredh n' t v.
Proof.
  introv H. gen n'. induction H; introv L;
   (destruct n' as [|n']; [ false; omega | autos* ]).
Qed.

Lemma bigredh_bigred : forall n t v, (* optional *)
  bigredh n t v -> bigred t v.
Proof. introv H. induction* H. Qed.

Lemma bigred_bigredh : forall t v,
  bigred t v -> exists n, bigredh n t v.
Proof. hint bigredh_lt. introv H. induction H; try induct_height. Qed.

(** After exploiting this last lemma, it is possible to perform an
    induction on the height of a derivation by doing [induction n]. *)

End IndHeight.

(* ********************************************************************** *)
(** ** Notation for exists *)

Lemma demo_exist :
  exists x1 x2 x3, x1 = x2 /\ x2 = x3 /\ x3 = 0.
Proof.
  (* dup N makes N copies of the current goal, which is useful for demos *)
  dup 7.
  (* N-ary existentials are displayed in a packed way,
     and they can be instantiated at once *)
  exists 0 0 0. auto.
  (* [exists~ 0 0 0] is the same as [exists 0 0 0] followed with auto *)
  exists~ 0 0 0.
  (* if a wild-card is provided, an existential variable is introduced *)
  exists __ 0 __. skip.
  (* if a double wild-card is provided, as many existential as possible
     are introduced *)
  exists 0 ___.
  (* a shorthand for [exists __ __ __] is [exists___ 3] *)
  exists___ 3. skip.
  (* [exists___] without arguments is the same as [exists __ ... __].
     Contrary to [exists ___], it does not unfold definitions. *)
  exists___. skip.
Admitted.

(* ********************************************************************** *)
(** ** ['let]-binding *)

Definition let_binding_test_1 :
  ('let x := 3 in 'let y := x + x in y + y) = 12.
Proof.
  dup 3.
  (* One can compute with ['let] *)
  reflexivity.
  (* One can inline ['let] step by step *)
  simpl. (* does nothing *)
  let_simpl.
  let_simpl.
  reflexivity.
  (* One can name the arguments of ['let] step by step *)
  let_name. (* TODO: avoid naming of x in 12 *)
  let_name as z.
  subst x. subst z. reflexivity.
Qed.

Definition let_binding_test_2 :
  ('let x := 3 in 'let y := x + x in y + y) = 12 -> True.
Proof.
  dup 2; intros H.
  (* One can inline ['let] step by step *)
  simpl in H. (* does nothing *)
  let_simpl in H.
  let_simpl in H.
  auto.
  (* One can name the arguments of ['let] step by step *)
  let_name in H.
  let_name in H as z.
  subst x. subst z. auto.
Qed.


(**
  This file is a part of a formalisation of a subset of Core Erlang.

  In this file, we define logical relations for sequential Core Erlang.
*)

Require Export SubstSemantics.

Import ListNotations.

(** Because of this, preorder is enough *)
Goal forall T : Type, forall R : relation T, Reflexive R -> Transitive R ->
  let R' := fun x y => R x y /\ R y x in Reflexive R' /\ Symmetric R' /\ Transitive R'.
Proof.
  intros. split. 2: split.
  * intro. unfold R'. split; apply H.
  * intro. intros. unfold R' in *. destruct H1.
    split; auto.
  * intro. intros. unfold R' in *. destruct H1, H2. split.
    - eapply H0; eauto.
    - eapply H0; eauto.
Qed.

Definition frame_rel (n : nat)
                     (Vrel : forall m, m <= n -> Exp -> Exp -> Prop)
                     (F1 F2 : FrameStack) : Prop :=
  FSCLOSED F1 /\ FSCLOSED F2 /\
  forall m (Hmn : m <= n) v1 v2,
    Vrel m Hmn v1 v2 ->
    | F1, v1 | m ↓ -> | F2, v2 | ↓.

Definition exp_rel (n : nat)
                   (Vrel : forall m, m <= n -> Exp -> Exp -> Prop)
                   (e1 e2 : Exp)
                 : Prop :=
  EXPCLOSED e1 /\ EXPCLOSED e2 /\
  forall m (Hmn : m <= n) F1 F2,
     frame_rel m (fun m' H => Vrel m' (Nat.le_trans _ _ _ H Hmn)) F1 F2 ->
     | F1, e1 | m ↓ -> | F2, e2 | ↓
.

Fixpoint   Vrel_rec (n : nat)
                    (Vrel : forall m, m < n -> Exp -> Exp -> Prop)
                    (v1 v2 : Exp) : Prop :=
  VALCLOSED v1 /\ VALCLOSED v2 /\
  match v1, v2 with
  | ELit l1, ELit l2 => l1 = l2
  | EPid p1, EPid p2 => p1 = p2
  | ENil, ENil => True
  | EFun vl1 b1, EFun vl2 b2 =>
    if length vl1 =? length vl2 then
     forall m (Hmn : m < n), forall (vals1 vals2 : list Exp),
       length vals1 = length vl1 -> length vals2 = length vl2 ->
       list_biforall (Vrel m Hmn) vals1 vals2
     ->
       exp_rel m (fun m' H => Vrel m' (Nat.le_lt_trans _ _ _ H Hmn))
                 (b1.[list_subst (EFun vl1 b1 :: vals1) idsubst])
                 (b2.[list_subst (EFun vl2 b2 :: vals2) idsubst])
     else False
  | VCons v1 v2, VCons v1' v2' => Vrel_rec n Vrel v1 v1' /\ Vrel_rec n Vrel v2 v2'
  | _, _ => False
  end
.

Definition Vrel : nat -> Exp -> Exp -> Prop :=
  Fix Wf_nat.lt_wf _ Vrel_rec.

Definition Erel (n : nat) (e1 e2 : Exp) : Prop :=
  exp_rel n (fun m _ => Vrel m) e1 e2.

Definition Frel (n : nat) (K1 K2 : FrameStack) : Prop :=
  frame_rel n (fun m _ => Vrel m) K1 K2.

(** ξ and η assigns closed expressions to vars in Γ
  Basically this says, ξ and η are equivalent pointwise for Γ
*)

Lemma Vrel_rec_pointwise {n : nat} :
  forall (f g : forall m : nat, (m < n)%nat -> Exp -> Exp -> Prop),
    (forall (m : nat) (p : (m < n)%nat), f m p = g m p) ->
    Vrel_rec n f = Vrel_rec n g.
Proof.
  intros.
  unfold Vrel_rec.
  extensionality v1.
  extensionality v2. generalize dependent v2.
  induction v1; try destruct v2; intros; auto.
  f_equal. f_equal.

  cbn. break_match_goal. 2: auto.

  f_equal. f_equal.
  extensionality m.
  extensionality Hmn.
  extensionality v1'.
  extensionality v2'.
  rewrite H.
  extensionality l1. extensionality l2.
  extensionality bif.
  f_equal.
  extensionality m'.
  extensionality H0.
  trivial.

  do 2 f_equal.
  rewrite IHv1_1, IHv1_2; auto.
Qed.

Lemma Vrel_Fix_eq : forall {n : nat} {v1 v2 : Exp},
  Vrel n v1 v2
  =
  Vrel_rec n (fun (m : nat) (_ : m < n) => Vrel m) v1 v2.
Proof.
  intros.
  unfold Vrel.
  rewrite Fix_eq by (auto using Vrel_rec_pointwise).
  trivial.
Qed.

Definition inf := EApp (EFun [] (EApp (EFunId 0) [])) [].

Theorem inf_diverges :
  forall n Fs, ~|Fs, inf| n↓.
Proof.
  unfold inf.
  intros. intro. induction n using lt_wf_ind. inversion H; try inversion_is_value. subst.
  inversion H5; subst.
  clear H5 H. simpl in H3.
  eapply H0. 2: exact H3. lia.
Qed.

Section Tests.

  Local Definition e1 := ELit 0%Z.
  Local Definition e2 := EFun [] e1.
  Local Definition e3 := EFun [] (EBIF (ELit "+"%string) [e1; e1]).

  Goal Erel 0 e1 e1.
  Proof.
    split. 2: split.
    1-2: repeat constructor. intros.
    destruct H, H1. eapply H2; eauto. rewrite Vrel_Fix_eq. cbn. repeat constructor.
  Qed.

  Goal Erel 3 e1 e1.
  Proof.
    split. 2: split.
    1-2: repeat constructor. intros.
    destruct H, H1. eapply H2; eauto. rewrite Vrel_Fix_eq. unfold e1, Vrel_rec. repeat constructor.
  Qed.

  Goal Erel 3 e2 e2.
  Proof.
    split. 2: split.
    1-2: repeat constructor. intros.
    destruct H, H1. eapply H2; eauto. rewrite Vrel_Fix_eq. unfold e1, Vrel_rec. repeat constructor.
    apply length_zero_iff_nil in H3. apply length_zero_iff_nil in H4. subst. intros. cbn. cbn in H4.
    destruct H3, H6. eapply H7; eauto. rewrite Vrel_Fix_eq. cbn. repeat constructor.
  Qed.

  Goal Erel 3 e2 e3.
  Proof.
    unfold e2, e3, e1.
    split. 2: split.
    1-2: repeat constructor.
    inversion H. 2: inversion H1. 3: inversion H3.
    1-2: simpl; auto.
    intros.
    destruct H, H1. eapply H2; eauto. rewrite Vrel_Fix_eq. unfold e1, Vrel_rec. repeat constructor.
    inversion H3. 2: inversion H5. 3: inversion H7.
    1-2: simpl; auto.
    cbn in *. destruct i; auto. destruct i; auto. lia.

    apply length_zero_iff_nil in H3. apply length_zero_iff_nil in H4. subst. intros. cbn. cbn in H4.
    destruct H3, H6. epose (H7 m1 _ (ELit 0%Z) (ELit 0%Z) _ H4).
    destruct t. exists (S (S (S (S x)))). constructor. econstructor. constructor.
    constructor; auto.
    constructor. assumption.

    Unshelve.
    all: repeat constructor.
  Qed.

End Tests.

Scheme le_dep_ind := Induction for le Sort Prop.

Lemma Vrel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {v1 v2 : Exp},
    Vrel n v1 v2 ->
    Vrel m v1 v2.
Proof.
  induction 1 using le_dep_ind;
    intros;
    eauto.
  generalize dependent v2.
  induction v1; destruct v2; intros; intuition; try break_match_hyp; intros.
  rewrite Vrel_Fix_eq.
  rewrite Vrel_Fix_eq in H.
  unfold Vrel_rec at 1.
  unfold Vrel_rec at 1 in H. intuition.

  try break_match_hyp; intros. 2: contradiction.
  simpl.
  epose proof (H2 m1 _ vals1 vals2 H1 H3 H4). apply H5; auto.

  rewrite Vrel_Fix_eq.
  rewrite Vrel_Fix_eq in H. destruct H as [cl1 [cl2 H]].
  split. 2: split. 1-2: auto.
  simpl. simpl in H. intros.
  specialize (IHv1_1 v2_1). specialize (IHv1_2 v2_2).
  do 2 rewrite Vrel_Fix_eq in IHv1_1. do 2 rewrite Vrel_Fix_eq in IHv1_2.
  split. apply IHv1_1, H. apply IHv1_2, H.
Unshelve. lia.
Qed.

Lemma Erel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {e1 e2 : Exp},
    Erel n e1 e2 ->
    Erel m e1 e2.
Proof.
  intros.
  unfold Erel, exp_rel.
  unfold Erel, exp_rel in H.
  destruct H, H0. split; auto. split; auto.
  intros. eapply (H1 m0); eauto. lia.
Qed.

Lemma Vrel_closed : forall {n : nat} {v1 v2 : Exp},
    Vrel n v1 v2 ->
    VALCLOSED v1 /\ VALCLOSED v2.
Proof.
  intros. rewrite Vrel_Fix_eq in H.
  Search "pointwise" "Vrel".
  destruct v1, v2; destruct H as [Cl1 [Cl2 H]]; try inversion_is_value;
  split; try contradiction.
  all: auto.
Qed.

Lemma Vrel_closed_l : forall {n : nat} {v1 v2 : Exp},
    Vrel n v1 v2 ->
    VALCLOSED v1.
Proof.
  intros.
  apply Vrel_closed in H.
  intuition.
Qed.

Global Hint Resolve Vrel_closed_l : core.

Lemma Vrel_closed_r : forall {n : nat} {v1 v2 : Exp},
    Vrel n v1 v2 ->
    VALCLOSED v2.
Proof.
  intros.
  apply Vrel_closed in H.
  intuition.
Qed.

Global Hint Resolve Vrel_closed_r : core.

Lemma Erel_closed : forall {n : nat} {e1 e2 : Exp},
    Erel n e1 e2 ->
    EXPCLOSED e1 /\ EXPCLOSED e2.
Proof.
  intros.
  unfold Erel, exp_rel in H.
  intuition.
Qed.

Lemma Erel_closed_l : forall {n : nat} {e1 e2 : Exp},
    Erel n e1 e2 ->
    EXPCLOSED e1.
Proof.
  intros.
  apply Erel_closed in H.
  intuition.
Qed.

Global Hint Resolve Erel_closed_l : core.

Lemma Erel_closed_r : forall {n : nat} {e1 e2 : Exp},
    Erel n e1 e2 ->
    EXPCLOSED e2.
Proof.
  intros.
  apply Erel_closed in H.
  intuition.
Qed.

Global Hint Resolve Erel_closed_r : core.

(** closing substitutions *)
Definition Grel (n : nat) (Γ : nat) (ξ₁ ξ₂ : Substitution) : Prop :=
  SUBSCOPE Γ ⊢ ξ₁ ∷ 0 /\ SUBSCOPE Γ ⊢ ξ₂ ∷ 0 /\
  forall x, x < Γ ->
    match (ξ₁ x), (ξ₂ x) with
    | inl e1, inl e2 => Vrel n e1 e2
    | _, _ => False
    end.

Lemma Grel_downclosed_helper : forall vals1 vals2 m n,
  m <= n -> length vals1 = length vals2 ->
  list_biforall (Vrel n) vals1 vals2 ->
  list_biforall (Vrel m) vals1 vals2.
Proof.
  intro. induction vals1 using list_length_ind; intros.
  destruct vals1, vals2.
  * constructor.
  * inversion H1.
  * inversion H1.
  * inversion H2. subst. constructor.
    - eapply Vrel_downclosed. eauto.
    - eapply H; eauto.
Unshelve. auto.
Qed.

Lemma Grel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {Γ : nat} {ξ₁ ξ₂ : Substitution},
    Grel n Γ ξ₁ ξ₂ ->
    Grel m Γ ξ₁ ξ₂ .
Proof.
  unfold Grel; intros.
  unfold Grel; intros. intuition.
  repeat break_match_goal; specialize (H2 x H1); try rewrite Heqs in H2; try rewrite Heqs0 in H2; [ intuition (eauto using Vrel_downclosed) | contradiction | contradiction ].
Qed.

Definition Vrel_open (Γ : nat) (e1 e2 : Exp) :=
  forall n ξ₁ ξ₂,
  Grel n Γ ξ₁ ξ₂
->
  Vrel n (subst ξ₁ e1) (subst ξ₂ e2).

Definition Erel_open (Γ : nat) (e1 e2 : Exp) :=
  forall n ξ₁ ξ₂,
  Grel n Γ ξ₁ ξ₂
->
  Erel n (subst ξ₁ e1) (subst ξ₂ e2).

Lemma Erel_open_closed : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    forall ξ, SUBSCOPE Γ ⊢ ξ ∷ 0 ->
              EXPCLOSED (subst ξ e1) /\ EXPCLOSED (subst ξ e2).
Proof.
  intros.
  apply @Erel_closed with (n:=0).
  apply H; auto.
  unfold Grel.
  intuition idtac. break_match_goal.
  (* rewrite Vrel_Fix_eq. unfold Vrel_rec at 1. *)
  specialize (H0 x H1) as P'. rewrite Heqs in P'. clear dependent ξ.
  * rewrite Vrel_Fix_eq. unfold Vrel_rec at 1.
    induction e; intros; try inversion_is_value; auto; try lia.
    constructor; auto. constructor; auto.
    break_match_goal; intros; try congruence; try inversion Hmn.
    rewrite Nat.eqb_refl in Heqb; congruence.

    split. 2: split. auto. auto. intros. inversion P'. subst.
    split. eapply IHe1; auto. eapply IHe2; auto.
  * specialize (H0 x H1). rewrite Heqs in H0. lia.
Qed.

Lemma Erel_open_scope : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    EXP Γ ⊢ e1 /\ EXP Γ ⊢ e2.
Proof.
  intros.
  pose proof (Erel_open_closed H).
  split;
  eapply (subst_implies_scope_exp); intros; apply H0; auto.
Qed.

Lemma Erel_open_scope_l : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    EXP Γ ⊢ e1.
Proof.
  intros. eapply Erel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Erel_open_scope_l : core.

Lemma Erel_open_scope_r : forall {Γ e1 e2},
    Erel_open Γ e1 e2 ->
    EXP Γ ⊢ e2.
Proof.
  intros. eapply Erel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Erel_open_scope_r : core.

Lemma Vrel_possibilities : forall {n v1 v2},
  Vrel n v1 v2 ->
  (exists n, v1 = ELit n /\ v2 = ELit n) \/
  (exists p, v1 = EPid p /\ v2 = EPid p) \/
  (exists vl1 vl2 b1 b2, v1 = EFun vl1 b1 /\ v2 = EFun vl2 b2) \/
  (exists v11 v12 v21 v22, v1 = VCons v11 v12 /\ v2 = VCons v21 v22) \/
  (v1 = ENil /\ v2 = ENil).
Proof.
  intros; destruct v1, v2; destruct H as [? [? ?] ]; subst; try contradiction.
  * left. eexists; split. reflexivity. reflexivity.
  * right. left. eexists; split. reflexivity. reflexivity.
  * right. right. left. repeat eexists.
  * intuition.
  * right. right. right. left. repeat eexists.
Qed.

Lemma Vrel_open_closed : forall {Γ e1 e2},
    Vrel_open Γ e1 e2 ->
    forall ξ, SUBSCOPE Γ ⊢ ξ ∷ 0 ->
              VALCLOSED (subst ξ e1) /\ VALCLOSED (subst ξ e2).
Proof.
  intros.
  apply @Vrel_closed with (n:=0).
  apply H; auto.
  unfold Grel.
  intuition idtac. break_match_goal.
  specialize (H0 x H1) as P'. rewrite Heqs in P'.
  rewrite Vrel_Fix_eq. clear dependent ξ.
  induction e; intros; try congruence; try inversion Hmn;
    try inversion_is_value; try lia.
  1-4: split;[auto|split; auto].
  * break_match_goal; intros; try congruence; try lia.
    rewrite Nat.eqb_refl in Heqb; congruence.
  * inversion P'. split; auto.
  * epose proof (H0 x H1). rewrite Heqs in H2. lia.
Qed.

Lemma Vrel_open_scope : forall {Γ e1 e2},
    Vrel_open Γ e1 e2 ->
    VAL Γ ⊢ e1 /\ VAL Γ ⊢ e2.
Proof.
  intros.
  pose proof (Vrel_open_closed H).
  split;
  eapply (subst_implies_scope_val); intros; apply H0; auto.
Qed.

Lemma Vrel_open_scope_l : forall {Γ e1 e2},
    Vrel_open Γ e1 e2 ->
    VAL Γ ⊢ e1.
Proof.
  intros. eapply Vrel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Vrel_open_scope_l : core.

Lemma Vrel_open_scope_r : forall {Γ e1 e2},
    Vrel_open Γ e1 e2 ->
    VAL Γ ⊢ e2.
Proof.
  intros. eapply Vrel_open_scope in H. destruct H. auto.
Qed.

Global Hint Resolve Vrel_open_scope_r : core.

Lemma Frel_downclosed :
  forall {n m : nat} {Hmn : m <= n} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    Frel m F1 F2.
Proof.
  unfold Frel, frame_rel.
  intuition. eapply H2 in H3. exact H3. lia. auto.
Qed.

Global Hint Resolve Frel_downclosed : core.

Lemma Frel_closed : forall {n : nat} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    FSCLOSED F1 /\ FSCLOSED F2.
Proof.
  intros.
  unfold Frel, frame_rel in H.
  intuition.
Qed.

Lemma Frel_closed_l : forall {n : nat} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    FSCLOSED F1.
Proof.
  intros.
  apply Frel_closed in H.
  intuition.
Qed.

Global Hint Resolve Frel_closed_l : core.

Lemma Frel_closed_r : forall {n : nat} {F1 F2 : FrameStack},
    Frel n F1 F2 ->
    FSCLOSED F2.
Proof.
  intros.
  apply Frel_closed in H.
  intuition.
Qed.

Global Hint Resolve Frel_closed_r : core.

Lemma biforall_vrel_scoped : forall vals1 vals2 Γ,
  list_biforall (Vrel_open Γ) vals1 vals2 ->
  Forall (fun e => VAL Γ ⊢ e) vals1 /\ Forall (fun e => VAL Γ ⊢ e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; repeat constructor.
  * eapply Vrel_open_scope_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Vrel_open_scope_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma biforall_erel_scoped : forall vals1 vals2 Γ,
  list_biforall (Erel_open Γ) vals1 vals2 ->
  Forall (fun e => EXP Γ ⊢ e) vals1 /\ Forall (fun e => EXP Γ ⊢ e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; split; constructor.
  * eapply Erel_open_scope_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Erel_open_scope_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma biforall_vrel_closed : forall vals1 vals2 m,
  list_biforall (Vrel m) vals1 vals2 ->
  Forall (fun e => VALCLOSED e) vals1 /\ Forall (fun e => VALCLOSED e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; repeat constructor.
  * eapply Vrel_closed_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Vrel_closed_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma biforall_erel_closed : forall vals1 vals2 m,
  list_biforall (Erel m) vals1 vals2 ->
  Forall (fun e => EXPCLOSED e) vals1 /\ Forall (fun e => EXPCLOSED e) vals2.
Proof.
  induction vals1; intros; inversion H; subst; split; constructor.
  * eapply Erel_closed_l; eauto.
  * specialize (IHvals1 _ _ H4); apply IHvals1.
  * eapply Erel_closed_r; eauto.
  * eapply IHvals1; eauto.
Qed.

Lemma Grel_scons : forall n v1 v2 ξ₁ ξ₂ Γ,
  Grel n Γ ξ₁ ξ₂ -> Vrel n v1 v2 -> Grel n (S Γ) (v1.:ξ₁) (v2.:ξ₂).
Proof.
  intros. split. 2: split.
  1-2: apply cons_scope; auto.
  2, 4: apply H. 1-2: now apply Vrel_closed in H0.
  intros. destruct x; simpl; auto.
  apply H. lia.
Qed.

Corollary Grel_list : forall n vl1 vl2 ξ₁ ξ₂ Γ,
  Grel n Γ ξ₁ ξ₂ -> list_biforall (Vrel n) vl1 vl2 ->
  Grel n (length vl1 + Γ) (list_subst vl1 ξ₁) (list_subst vl2 ξ₂).
Proof.
  induction vl1; intros; inversion H0; subst; simpl; auto.
  apply Grel_scons; auto.
Qed.


(* Basic definitions about functions. *)

Definition idmap A := fun x : A => x.

Definition compose {A B C} (g : B -> C) (f : A -> B) (x : A) := g (f x).

(** printing o $\circ$ *)

Notation "g 'o' f" := (compose g f) (left associativity, at level 37).


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*  Commutators  *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype finset.
Require Import groups morphisms automorphism normal.

(* Require Import seq paths connect div ssralg bigops group_perm. *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

Section Basic_commutator_properties.

Variable gT : finGroupType.
Implicit Types x y z : gT.

Lemma conjg_mulR : forall x y, x ^ y = x * [~ x, y].
Proof. by move=> x y; rewrite mulKVg. Qed.

Lemma conjg_Rmul : forall x y, x ^ y = [~ y, x^-1] * x.
Proof. by move=> x y; rewrite commgEr invgK mulgKV. Qed.

Lemma commMgJ : forall x y z, [~ x * y, z] = [~ x, z] ^ y * [~ y, z].
Proof. by move=> x y z; rewrite !commgEr conjgM mulgA -conjMg mulgK. Qed.

Lemma commgMJ : forall x y z, [~ x, y * z] = [~ x, z] * [~ x, y] ^ z.
Proof. by move=> x y z; rewrite !commgEl conjgM -mulgA -conjMg mulKVg. Qed.

Lemma commMgR : forall x y z,
  [~ x * y, z] = [~ x, z] * [~ x, z, y] * [~ y, z].
Proof. by move=> x y z; rewrite commMgJ conjg_mulR. Qed.

Lemma commgMR : forall x y z,
  [~ x, y * z] = [~ x, z] * [~ x, y] * [~ x, y, z].
Proof. by move=> x y z; rewrite commgMJ conjg_mulR mulgA. Qed.

Lemma Hall_Witt_identity : forall x y z,
  [~ x, y^-1, z] ^ y * [~ y, z^-1, x] ^ z * [~ z, x^-1, y] ^ x = 1.
Proof. (* gsimpl *)
pose a x y z : gT := x * z * y ^ x.
suffices hw_aux: forall x y z, [~ x, y^-1, z] ^ y = (a x y z)^-1 * (a y z x).
  by move=> x y z; rewrite !hw_aux 2!mulgA !mulgK mulVg.
by move=> *; rewrite commgEr conjMg -conjgM -conjg_Rmul 2!invMg conjgE !mulgA.
Qed.

(* the following properties are useful for studying p-groups of class 2 *)

Section LeftComm.

Variables (i : nat) (x y : gT).
Hypothesis cxz : commute x [~ x, y].

Lemma commVg : [~ x^-1, y] = [~ x, y]^-1.
Proof.
apply/eqP; rewrite commgEl eq_sym eq_invg_mul invgK mulgA -cxz.
by rewrite -conjg_mulR -conjMg mulgV conj1g.
Qed.

Lemma commXg : [~ x ^+ i, y] = [~ x, y] ^+ i.
Proof.
elim: i => [|i' IHi]; first exact: comm1g.
by rewrite expgS commMgJ /conjg commuteX // mulKg IHi.
Qed.

End LeftComm.

Section RightComm.

Variables (i : nat) (x y : gT).
Hypothesis cyz : commute y [~ x, y].

Lemma commgV : [~ x, y^-1] = [~ x, y]^-1.
Proof.
rewrite -invg_comm commVg -(invg_comm x y) ?invgK //; exact: commuteV.
Qed.

Lemma commgX : [~ x, y ^+ i] = [~ x, y] ^+ i.
Proof.
rewrite -invg_comm commXg -(invg_comm x y) ?expVgn ?invgK //; exact: commuteV.
Qed.

End RightComm.

Section LeftRightComm.

Variables (i j : nat) (x y : gT).
Hypotheses (cxz : commute x [~ x, y]) (cyz : commute y [~ x, y]).

Lemma commXXg : [~ x ^+ i, y ^+ j] = [~ x, y] ^+ (i * j).
Proof. rewrite expgn_mul commgX commXg //; exact: commuteX. Qed.

Lemma expMg_Rmul : (y * x) ^+ i = y ^+ i * x ^+ i * [~ x, y] ^+ (i * i.-1)./2.
Proof.
elim: i => [|k IHk]; first by rewrite !mulg1.
rewrite expgS {}IHk mulgA -(mulgA y) (mulgA x) (commgC x _) commgX // 3!mulgA.
rewrite -expgS -[_ * x ^+ k]mulgA -commuteX2 // -(mulgA _ x) (mulgA x).
rewrite -expgS -2!mulgA mulgA -expgn_add; congr (_ * _ ^+ _); case: k => // k.
by rewrite -add2n muln_addl mul2n half_add odd_double half_double mulnC.
Qed.

End LeftRightComm.

End Basic_commutator_properties.

(* GG -- outcommenting the whole section -- lemmas are not used
Section Commutators_and_centralizers.

Variable T : finGroupType.
(* should not be a group but a set *)
Variable H : {set T}.

(* This is a composite reflections, so it should be a reflection as well. *)
(* I don't see why the centraliser has to be localised. *)
Lemma commg_to_centraliser : forall y,
  {in H, forall x, [~ x, y] = 1} -> H \subset 'C_H[y].
Proof.
move=> y comm1; rewrite subsetI subxx /=.
by apply/subsetP=> x Hx; apply/cent1P; apply/commgP; rewrite comm1.
Qed.

Lemma centraliser_to_commg: forall x y, x \in 'C_H[y] -> [~ x, y] = 1.
Proof.
move=> x y; case/setIP=> _; rewrite (sameP cent1P commgP); exact: eqP.
Qed.

End Commutators_and_centralizers.
*)

(***** Set theoretic commutators *****)
Section Commutator_properties.

Variable gT : finGroupType.
Implicit Types A B C : {set gT}.
Implicit Types G H K : {group gT}.

Lemma commG1 : forall A, [~: A, 1] = 1.
Proof. by move=> A; apply/commG1P; rewrite centsC sub1G. Qed.

Lemma comm1G : forall A, [~: 1, A] = 1.
Proof. by move=> A; rewrite commGC commG1. Qed.

Lemma commg_sub : forall A B, [~: A, B] \subset A <*> B.
Proof. by move=> A B; rewrite comm_subG // (mulgen_subl, mulgen_subr). Qed.

Lemma commg_norml : forall G A, G \subset 'N([~: G, A]).
Proof.
move=> G A; apply/subsetP=> x Gx; rewrite inE -genJ gen_subG.
apply/subsetP=> yzx; case/imsetP=> yz; case/imset2P=> y z Gy Az -> -> {yz yzx}.
by rewrite -(mulgK [~ x, z] (_ ^ x)) -commMgJ !(mem_commg, groupMl, groupV).
Qed.

Lemma commg_normr : forall G A, G \subset 'N([~: A, G]).
Proof. by move=> G A; rewrite commGC commg_norml. Qed.

Lemma commg_norm : forall G H, G <*> H \subset 'N([~: G, H]).
Proof. by move=> G H; rewrite mulgen_subG ?commg_norml ?commg_normr. Qed.

Lemma commg_normal: forall G H, [~: G, H] <| G <*> H.
Proof. by move=> G H; rewrite /(_ <| _) commg_sub commg_norm. Qed.

Lemma normsRl : forall A G B, A \subset G -> A \subset 'N([~: G, B]).
Proof. by move=> A G B sAG; exact: subset_trans (commg_norml G B). Qed.

Lemma normsRr : forall A G B, A \subset G -> A \subset 'N([~: B, G]).
Proof. by move=> A G B sAG; exact: subset_trans (commg_normr G B). Qed.

Lemma commg_subr : forall G H, ([~: G, H] \subset H) = (G \subset 'N(H)).
Proof.
move=> G H; rewrite gen_subG; apply/subsetP/subsetP=> [sRH x Gx | nGH xy].
  rewrite inE; apply/subsetP=> yx; case/imsetP=> y Ky ->{yx}.
  by rewrite conjg_Rmul groupMr // sRH // mem_imset2 ?groupV.
case/imset2P=> x y Gx Hy ->{xy}.
by rewrite commgEr groupMr // memJ_norm (groupV, nGH).
Qed.

Lemma commg_subl : forall G H, ([~: G, H] \subset G) = (H \subset 'N(G)).
Proof. by move=> G H; rewrite commGC commg_subr. Qed.

Lemma quotient_cents2 : forall A B K,
    A \subset 'N(K) -> B \subset 'N(K) ->
  (A / K \subset 'C(B / K)) = ([~: A, B] \subset K).
Proof.
move=> A B K nKA nKB.
by rewrite (sameP commG1P trivgP) /= -quotientR // quotient_sub1 // comm_subG.
Qed.

Lemma quotient_cents2r : forall A B K,
  [~: A, B] \subset K -> (A / K) \subset 'C(B / K).
Proof.
move=> A B K sABK.
rewrite -2![_ / _]morphimIdom -!quotientE quotient_cents2 ?subsetIl //.
by apply: subset_trans sABK; rewrite commgSS ?subsetIr.
Qed.

Lemma sub_der1_norm : forall G H,
  [~: G, G] \subset H -> H \subset G -> G \subset 'N(H).
Proof.
by move=> G H sG'H sHG; rewrite -commg_subr (subset_trans _ sG'H) ?commgS.
Qed.

Lemma sub_der1_normal : forall G H,
  [~: G, G] \subset H -> H \subset G -> H <| G.
Proof. by move=> G H sG'H sHG; rewrite /(H <| G) sHG sub_der1_norm. Qed.

Lemma sub_der1_abelian : forall G H, [~: G, G] \subset H -> abelian (G / H).
Proof. move=> G H sG'H; exact: quotient_cents2r. Qed.

Lemma der1_min : forall G H,
  G \subset 'N(H) -> abelian (G / H) -> [~: G, G] \subset H.
Proof. by move=> G H nHG abGH; rewrite -quotient_cents2. Qed.

Lemma commg_normSl :  forall G H K,
  G \subset 'N(H) -> [~: G, H] \subset 'N([~: K, H]).
Proof. by move=> G H K nHG; rewrite normsRr // commg_subr. Qed.

Lemma commg_normSr :  forall G H K,
  G \subset 'N(H) -> [~: H, G] \subset 'N([~: H, K]).
Proof. by move=> G H K nHG; rewrite !(commGC H) commg_normSl. Qed.

Lemma commMGr : forall G H K,
  [~: G, K] * [~: H, K] \subset [~: G * H , K].
Proof. by move=> G H K; rewrite mul_subG ?commSg ?(mulG_subl, mulG_subr). Qed.

Lemma commMG : forall G H K,
    H \subset 'N(G) -> H \subset 'N(K) ->
  [~: G * H , K] = [~: G, K] * [~: H, K].
Proof.
move=> G H K nGH nKH; apply/eqP; rewrite eqEsubset commMGr andbT.
have defM := norm_mulgenEr (commg_normSl G nKH); rewrite -defM gen_subG /=.
apply/subsetP=> r; case/imset2P=> m z; case/imset2P=> x y Gx Hy -> Kz ->{r m}.
rewrite commMgJ {}defM mem_mulg ?memJ_norm ?mem_commg //.
apply: subsetP Hy; exact: normsR.
Qed.

Lemma comm3G1P : forall A B C,
  reflect {in A & B & C, forall h k l, [~ h, k, l] = 1} ([~: A, B, C] :==: 1).
Proof.
move=> A B C; have R_C := sameP trivgP commG1P.
rewrite -subG1 R_C gen_subG -{}R_C gen_subG.
apply: (iffP subsetP) => [cABC x y z Ax By Cz | cABC xyz].
  by apply/set1P; rewrite cABC // !mem_imset2.
by case/imset2P=> xy z; case/imset2P=> x y Ax By -> Cz ->; rewrite cABC.
Qed.

Lemma three_subgroup : forall G H K,
  [~: G, H, K] :=: 1 -> [~: H, K, G] :=: 1-> [~: K, G, H] :=: 1.
Proof.
move=> G H K; move/eqP; move/comm3G1P=> cGHK; move/eqP; move/comm3G1P=> cHKG.
apply/eqP; apply/comm3G1P=> x y z Kx Gy Hz; symmetry.
rewrite -(conj1g y) -(Hall_Witt_identity y^-1 z x) invgK.
by rewrite cGHK ?groupV // cHKG ?groupV // !conj1g !mul1g conjgKV.
Qed.

(* GG -- unsure about the usefulness of this lemma; keeping it for now. *)

Lemma commgAC : forall G x y z, x \in G -> y \in G -> z \in G ->
  commute y z -> abelian [~: [set x], G] -> [~ x, y, z] = [~ x, z, y].
Proof.
move=> G x y z Gx Gy Gz cyz; move/centsP=> cRxG; pose cx' u := [~ x^-1, u].
have xR3: forall u v, [~ x, u, v] = x^-1 * (cx' u * cx' v) * x ^ (u * v).
  move=> u v; rewrite mulgA -conjg_mulR conjVg [cx' v]commgEl mulgA -invMg.
  by rewrite -mulgA conjgM -conjMg -!commgEl.
suffices RxGcx': forall u, u \in G -> cx' u \in [~: [set x], G].
  by rewrite !xR3 {}cyz; congr (_ * _ * _); rewrite cRxG ?RxGcx'.
move=> u Gu; suffices: [~ x, u] ^ x^-1 \in [~: [set x], G].
  by move/groupMl <-; rewrite -commMgJ mulgV comm1g group1.
by rewrite memJ_norm ?mem_commg ?set11 // groupV (subsetP (commg_normr _ _)).
Qed.

Lemma charR : forall H K G, H \char G -> K \char G -> [~: H, K] \char G.
Proof.
move=> H K G; case/charP=> sHG chH; case/charP=> sKG chK; apply/charP.
by split=> [|f infj Gf]; [rewrite comm_subG | rewrite morphimR // chH // chK].
Qed.

End Commutator_properties.


Require Export GeoCoq.Elements.OriginalProofs.lemma_angletrichotomy.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglesreflexive.
Require Export GeoCoq.Elements.OriginalProofs.lemma_trichotomy1.

Section Euclid.
Context `{Ax:euclidean_neutral_ruler_compass}.
Lemma proposition_26A :
   forall A B C D E F,
   Triangle A B C -> Triangle D E F -> CongA A B C D E F -> CongA B C A E F D -> Cong B C E F ->
   Cong A B D E /\ Cong A C D F /\ CongA B A C E D F.
Proof.
intros.
assert (nCol A B C) by (conclude_def Triangle ).
assert (~ eq A B).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (~ eq B C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq C B) by (conclude lemma_inequalitysymmetric).
assert (~ eq A C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq C A) by (conclude lemma_inequalitysymmetric).
assert (~ Lt D E A B).
 {
 intro.
 assert (Cong A B B A) by (conclude cn_equalityreverse).
 assert (Lt D E B A) by (conclude lemma_lessthancongruence).
 let Tf:=fresh in
 assert (Tf:exists G, (BetS B G A /\ Cong B G D E)) by (conclude_def Lt );destruct Tf as [G];spliter.
 assert (neq B G) by (forward_using lemma_betweennotequal).
 assert (Cong B G E D) by (forward_using lemma_congruenceflip).
 assert (Out B A G) by (conclude lemma_ray4).
 assert (eq C C) by (conclude cn_equalityreflexive).
 assert (Out B C C) by (conclude lemma_ray4).
 assert (Cong G C G C) by (conclude cn_congruencereflexive).
 assert (eq B B) by (conclude cn_equalityreflexive).
 assert (eq G G) by (conclude cn_equalityreflexive).
 assert (Out B G G) by (conclude lemma_ray4).
 assert (Cong B G B G) by (conclude cn_congruencereflexive).
 assert (Cong B C B C) by (conclude cn_congruencereflexive).
 assert (CongA A B C G B C) by (conclude_def CongA ).
 assert (CongA G B C A B C) by (conclude lemma_equalanglessymmetric).
 assert (CongA G B C D E F) by (conclude lemma_equalanglestransitive).
 assert ((Cong G C D F /\ CongA B G C E D F /\ CongA B C G E F D)) by (conclude proposition_04).
 assert (CongA E F D B C A) by (conclude lemma_equalanglessymmetric).
 assert (CongA B C G B C A) by (conclude lemma_equalanglestransitive).
 assert (CongA B C A B C G) by (conclude lemma_equalanglessymmetric).
 assert (Out C B B) by (conclude lemma_ray4).
 assert (eq A A) by (conclude cn_equalityreflexive).
 assert (Out C A A) by (conclude lemma_ray4).
 assert (LtA B C A B C A) by (conclude_def LtA ).
 assert (~ LtA B C A B C A) by (conclude lemma_angletrichotomy).
 contradict.
 }
assert (~ Lt A B D E).
 {
 intro.
 assert (Cong D E E D) by (conclude cn_equalityreverse).
 assert (Lt A B E D) by (conclude lemma_lessthancongruence).
 let Tf:=fresh in
 assert (Tf:exists G, (BetS E G D /\ Cong E G A B)) by (conclude_def Lt );destruct Tf as [G];spliter.
 assert (Cong E G B A) by (forward_using lemma_congruenceflip).
 assert (neq E D) by (forward_using lemma_betweennotequal).
 assert (Out E D G) by (conclude lemma_ray4).
 assert (eq D D) by (conclude cn_equalityreflexive).
 assert (eq F F) by (conclude cn_equalityreflexive).
 assert (nCol D E F) by (conclude_def Triangle ).
 assert (~ eq E F).
  {
  intro.
  assert (Col D E F) by (conclude_def Col ).
  contradict.
  }
 assert (Out E F F) by (conclude lemma_ray4).
 assert (Cong G F G F) by (conclude cn_congruencereflexive).
 assert (eq E E) by (conclude cn_equalityreflexive).
 assert (eq G G) by (conclude cn_equalityreflexive).
 assert (neq E G) by (conclude lemma_raystrict).
 assert (Out E G G) by (conclude lemma_ray4).
 assert (Cong E G E G) by (conclude cn_congruencereflexive).
 assert (Cong E F E F) by (conclude cn_congruencereflexive).
 assert (CongA D E F G E F) by (conclude_def CongA ).
 assert (CongA G E F D E F) by (conclude lemma_equalanglessymmetric).
 assert (CongA D E F A B C) by (conclude lemma_equalanglessymmetric).
 assert (CongA G E F A B C) by (conclude lemma_equalanglestransitive).
 assert (Cong E F B C) by (conclude lemma_congruencesymmetric).
 assert ((Cong G F A C /\ CongA E G F B A C /\ CongA E F G B C A)) by (conclude proposition_04).
 assert (CongA E F G E F D) by (conclude lemma_equalanglestransitive).
 assert (CongA E F D E F G) by (conclude lemma_equalanglessymmetric).
 assert (nCol E F G) by (conclude lemma_equalanglesNC).
 assert (CongA E F G E F G) by (conclude lemma_equalanglesreflexive).
 assert (neq E F) by (forward_using lemma_angledistinct).
 assert (neq F E) by (conclude lemma_inequalitysymmetric).
 assert (Out F E E) by (conclude lemma_ray4).
 assert (neq F D) by (forward_using lemma_angledistinct).
 assert (Out F D D) by (conclude lemma_ray4).
 assert (LtA E F D E F D) by (conclude_def LtA ).
 assert (~ LtA E F D E F D) by (conclude lemma_angletrichotomy).
 contradict.
 }
assert (~ eq D E).
 {
 intro.
 assert (Col D E F) by (conclude_def Col ).
 assert (nCol D E F) by (conclude_def Triangle ).
 contradict.
 }
assert (Cong A B D E) by (conclude lemma_trichotomy1).
assert (Cong B A E D) by (forward_using lemma_congruenceflip).
assert ((Cong A C D F /\ CongA B A C E D F /\ CongA B C A E F D)) by (conclude proposition_04).
close.
Qed.

End Euclid.


Require Export Iron.Language.DelayedSimple.Base.
Require Export Iron.Language.DelayedSimple.Ty.

(********************************************************************)
(* Value Expressions *)
Inductive exp : Type :=
 (* Variables want to be named. *)
 | XVar    (v: name) : exp

 (* Function abstraction. *)
 | XAbs    (ss: @subst exp ty) (v: name) (t: ty) (x: exp) : exp

 (* Function application. *)
 | XApp    (x1: exp) (x2: exp) : exp.

Hint Constructors exp.

(* Indirect induction principle for expressions.

   In the definition of 'exp', abstractions contain a list of
   subexpressions, so 'exp' is indirectly defined via the list
   data type.

   In the following induction principle, when proving a property
   of abstractions we know the property being proved applies to
   subexpressions contained in those lists. The automatically
   generated induction principle 'exp_ind' doesn't give us this.
*)
Theorem exp_iind
 : forall
    (PX : exp -> Prop)

 ,  (  forall n
    ,  PX (XVar n))

 -> (  forall ss n t x
    ,  Forall (fun b => PX (expOfBind b)) ss
    -> PX x
    -> PX (XAbs ss n t x))

 -> (  forall x1 x2
    ,  PX x1  -> PX x2
    -> PX (XApp x1 x2))

 -> forall  x, PX x.
Proof.
 intros PX.
 intros Hvar Habs Happ.
 refine (fix IHX x: PX x := _).

 case x; intros.
 - apply Hvar.
 - eapply Habs.
   induction ss as [| b].
   + apply Forall_nil.
   + apply Forall_cons.
     * destruct b. simpl. eapply IHX.
     * assumption.
   + apply IHX.
 - apply Happ.
   + apply IHX.
   + apply IHX.
Qed.

(********************************************************************)
(* Predicates. *)
Definition isXAbs (x1: exp): Prop :=
 (exists bs n t x, x1 = XAbs bs n t x).

Lemma isXAbs_true
 : forall bs n t x, isXAbs (XAbs bs n t x).
Proof.
 intros.
 unfold isXAbs.
 exists bs. exists n. exists t. exists x.
 trivial.
Qed.
Hint Resolve isXAbs_true.

Lemma isXAbs_XVar
 : forall n
 , ~isXAbs (XVar n).
Proof.
 intuition. nope.
Qed.
Hint Resolve isXAbs_XVar.

Lemma isXAbs_XApp
 : forall x1 x2
 , ~isXAbs (XApp x1 x2).
Proof.
 intuition. nope.
Qed.
Hint Resolve isXAbs_XApp.

(********************************************************************)
(* Values *)
Inductive Value : exp -> Prop :=
 | ValueAbs
   :  forall ss v t x
   ,  Value (XAbs ss v t x).

Hint Constructors Value.

Lemma isValue_not_var
 : forall v
 , ~Value (XVar v).
Proof.
 intros. intuition. inverts H.
Qed.
Hint Resolve isValue_not_var.

Lemma isValue_not_app
 : forall x1 x2
 , ~Value (XApp x1 x2).
Proof.
 intros. intuition. inverts H.
Qed.
Hint Resolve isValue_not_app.

(* Done expressions have finished evaluating. *)
Inductive Done  : exp -> Prop :=
 | DoneVar
   :  forall v
   ,  Done (XVar v)

 | DoneValue
   :  forall x
   ,  Value  x
   -> Done   x

 | DoneApp
   :  forall x1 x2
   ,  Done x1 /\ ~Value x1
   -> Done (XApp x1 x2).

Hint Constructors Done.

(* Invert all hypothesis that are compound done statements. *)
Ltac inverts_done :=
 repeat
  (match goal with
   | [ H: Done (XApp _ _) |- _ ] => inverts H
   end).