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.


(**
  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).


(*** An approach to representing Models with inductive types ***)

Require Import List.
Import ListNotations.

(* Require Export Coq.Logic.Eqdep. *)

Add LoadPath "." as Specware.
Require Import Specware.Util.

Section Spec.

(* The type of spec fields *)
Variable F : Set.
Variable F_dec : forall (f1 f2 : F), {f1=f2} + {f1<>f2}.

(**
 ** Models and specs
 **)

(* A Model is an element of the record type denoted by a Sig *)
Inductive Model : Type :=
| Model_Nil : Model
| Model_Cons (fld:F) A (a : A) (M:Model) : Model
.

(* A Spec is a partial Model of a Sig; README: Specs are indexed with
   their fields so that the fields they contain are known: i.e., even
   an inconsistent Spec has a fixed list of fields *)
Inductive Spec : forall {flds : list F}, Type :=
| Spec_Nil : Spec (flds:=nil)
| Spec_ConsNone f A {flds} :
    ~ In f flds ->
    (forall (a:A), Spec (flds:=flds)) -> Spec (flds:= f :: flds)
| Spec_ConsSome f A (a : A) {flds} :
    ~ In f flds ->
    Spec (flds:=flds) ->
    Spec (flds:= f :: flds)
.

(* helper function for printing purposes *)
(* Definition get_fields {flds} (spec : @Spec flds) := flds. *)

(**
 ** Notions of elements of structures
 **)

(* Get the fields of a Model *)
Fixpoint modelFields (M : Model) : list F :=
  match M with
    | Model_Nil => []
    | Model_Cons fld _ _ M' => fld :: modelFields M'
  end.

(* Proof that field f is associated with element a of type A in model *)
Inductive ModelElem (fld : F) A (a:A) : Model -> Prop :=
| ModelElem_Base (model : Model) :
    ModelElem fld A a (Model_Cons fld A a model)
| ModelElem_Cons fld' A' a' (model : Model) :
    ModelElem fld A a model ->
    ModelElem fld A a (Model_Cons fld' A' a' model)
.

(* Model_Nil has no ModelElems *)
Lemma not_ModelElem_nil (fld : F) A (a:A) :
  ModelElem fld A a Model_Nil -> False.
  assert (forall model,
            ModelElem fld A a model -> model = Model_Nil -> False).
  intros model melem e; induction melem; discriminate.
  intro melem; apply (H _ melem); reflexivity.
Qed.

(* Projecting an element out of a Model *)
(* FIXME: update or remove
Fixpoint modelProj (model : Model) :
  forall f, In f (modelFields model) -> { A : Type & A } :=
  match model in Model (flds:=flds)
        return forall f, In f flds -> { A : Type & A }
  with
    | Model_Nil => fun f in_nil => False_rect _ in_nil
    | Model_Cons f' A a _ model =>
      fun f in_pf =>
        match F_dec f' f with
            | left _ => existT id A a
            | right neq =>
              modelProj model f (or_proj_r _ _ neq in_pf)
        end
  end.

(* Correctness of modelProj: always returns a ModelElem *)
Lemma modelProj_correct flds (model : Model (flds:=flds)) f in_pf :
  ModelElem f (projT1 (modelProj model f in_pf))
            (projT2 (modelProj model f in_pf))
            model.
  revert f in_pf; induction model; intros.
  elimtype False; apply in_pf.
  unfold modelProj; fold (modelProj (flds:=flds)).
  destruct (F_dec f f0).
  rewrite <- e; apply ModelElem_Base.
  apply ModelElem_Cons.
  apply IHmodel.
Qed.
*)

(**
 ** Defining the notion of models of specs
 **)

Fixpoint IsModel (model : Model) {flds} (spec : Spec (flds:=flds)) {struct spec} : Prop :=
  match spec in Spec (flds:=flds) with
    | Spec_Nil => True
    | Spec_ConsNone f A _ _ specF =>
      exists a, ModelElem f A a model /\ IsModel model (specF a)
    | Spec_ConsSome f A a _ _ spec' =>
      ModelElem f A a model /\ IsModel model spec'
  end.

Definition IsModel_Nil model : IsModel model Spec_Nil := I.

Definition IsModel_ConsNone model f A a {flds} not_in
           (spec : A -> Spec (flds:=flds))
           (melem : ModelElem f A a model) (ism : IsModel model (spec a)) :
  IsModel model (Spec_ConsNone f A not_in spec).
  exists a; split; assumption.
Qed.

Definition IsModel_ConsSome model f A a {flds} not_in
           (spec : Spec (flds:=flds))
           (melem : ModelElem f A a model) (ism : IsModel model spec) :
  IsModel model (Spec_ConsSome f A a not_in spec).
  split; assumption.
Qed.

(* A model of a Spec contains an element for each field in the spec *)
(* README: old, inductive version
Inductive IsModel (model : Model) :
  forall {flds}, Spec (flds:=flds) -> Prop :=
| IsModel_Nil : IsModel model Spec_Nil
| IsModel_ConsNone f A a flds (spec : A -> Spec (flds:=flds)) :
    ModelElem f A a model ->
    IsModel model (spec a) ->
    IsModel model (Spec_ConsNone f A spec)
| IsModel_ConsSome f A a flds (spec : Spec (flds:=flds)) :
    ModelElem f A a model ->
    IsModel model spec ->
    IsModel model (Spec_ConsSome f A a spec)
.
*)

Lemma IsModel_nil_spec {flds} (spec : Spec (flds:=flds)) :
  IsModel Model_Nil spec -> eq_dep _ (@Spec) _ spec _ Spec_Nil.
  induction spec; intro ism.
  reflexivity.
  destruct ism as [ a sig ]; destruct sig as [ melem ism ];
  elimtype False; apply (not_ModelElem_nil _ _ _ melem).
  destruct ism as [ melem ism ];
  elimtype False; apply (not_ModelElem_nil _ _ _ melem).
Qed.

(*
Lemma IsModel_ConsNone_inversion model {flds} f A
      (spec : A -> Spec (flds:=flds)) :
  IsModel model (Spec_ConsNone f A spec) ->
  exists a, ModelElem f A a model /\ IsModel model (spec a).
  intro ism; inversion ism.
  exists a; split; [ assumption | ].
  assert (spec1 = spec).
  apply (inj_pair2_flds (inj_pair2_flds H3)).
*)

(* FIXME: write prove_ismodel tactic *)

(*
Lemma ModelElem_to_SpecElem {flds_m} (model : Model (flds:=flds_m))
      {flds_s} (spec : Spec (flds:=flds_s)) f A a :
  ModelElem f A a
*)

FIXME HERE: need a notion of when a FieldMap applies to a spec

(**
 ** Field maps: finite functions on Fs
 **)

(* A FieldMap is represented as a list of pairs *)
Definition FieldMap := list (F * F).

(* The identity FieldMap *)
Definition idFM : FieldMap := [].

(* Apply a FieldMap to a F *)
Fixpoint applyFM (m : FieldMap) (str : F) : F :=
  match m with
    | [] => str
    | (str_from, str_to) :: m' =>
      if F_dec str str_from then str_to else
        applyFM m' str
  end.

(* Applying idFM is the identity *)
Lemma idFM_is_id (str : F) : applyFM idFM str = str.
  reflexivity.
Qed.

(* compose two FieldMaps, applying m1 and then m2 *)
Fixpoint composeFM (m1 m2 : FieldMap) : FieldMap :=
  match m1 with
    | [] => m2
    | (str_from, str_to) :: m1' =>
      (str_from, applyFM m2 str_to) :: composeFM m1' m2
  end.

(* composition works as expected *)
Lemma FieldMap_compose m1 m2 str :
  applyFM (composeFM m1 m2) str = applyFM m2 (applyFM m1 str).
  induction m1.
  reflexivity.
  destruct a as [ str_from str_to ]; unfold composeFM; fold composeFM.
  unfold applyFM; fold applyFM.
  destruct (F_dec str str_from).
  reflexivity.
  apply IHm1.
Qed.

(* Return the list of Fs that map to an output F *)
Fixpoint semiInvertFM (m : FieldMap) str : list F :=
  match m with
    | [] => [str]
    | (str_from, str_to) :: m' =>
      if F_dec str str_to then str_from :: semiInvertFM m' str
      else remove F_dec str_from (semiInvertFM m' str)
  end.

(* semiInvertFM returns only Fs that map back to str *)
Lemma semiInvertFM_sound m str str' :
  In str' (semiInvertFM m str) -> applyFM m str' = str.
  induction m.
  intro in_pf; destruct in_pf;
    [ rewrite H; reflexivity | destruct H ].
  destruct a as [ str_from str_to ]; unfold applyFM; fold applyFM.
  unfold semiInvertFM; fold semiInvertFM.
  destruct (F_dec str str_to); intro in_pf;
  destruct (F_dec str' str_from).
  rewrite e; reflexivity.
  apply IHm; destruct in_pf;
  [ elimtype False; apply n; rewrite H; reflexivity | assumption ].
  rewrite e in in_pf; elimtype False; apply (remove_In _ _ _ in_pf).
  apply IHm; apply (In_remove _ _ _ _ in_pf).
Qed.

(* semiInvertFM returns all Fs that map back to str *)
Lemma semiInvertFM_complete m str str' :
  applyFM m str' = str -> In str' (semiInvertFM m str).
  induction m; unfold applyFM; fold applyFM.
  intro e; left; symmetry; assumption.
  destruct a as [ str_from str_to ]; unfold semiInvertFM; fold semiInvertFM.
  destruct (F_dec str' str_from); intro eApp.
  rewrite eApp; rewrite F_dec_true; left; symmetry; assumption.
  destruct (F_dec str str_to).
  right; apply IHm; assumption.
  apply remove_not_eq; [ assumption | apply IHm; assumption ].
Qed.

(* str is always in semiInvertFM m (applyFM m str) *)
Lemma in_semiInvert_apply m str : In str (semiInvertFM m (applyFM m str)).
  apply semiInvertFM_complete; reflexivity.
Qed.

(**
 ** Mapping functions over structures
 **)

Fixpoint model_map (m : FieldMap) (model : Model) : Model :=
  match model with
    | Model_Nil => Model_Nil
    | Model_Cons f A a model =>
      Model_Cons (applyFM m f) A a (model_map m model)
  end.

Fixpoint spec_map (m : FieldMap) {flds} (spec : Spec (flds:=flds)) :
  Spec (flds:=map (applyFM m) flds) :=
  match spec in Spec (flds:=flds) return Spec (flds:=map (applyFM m) flds) with
    | Spec_Nil => Spec_Nil
    | Spec_ConsNone f A flds spec =>
      Spec_ConsNone (applyFM m f) A (fun a => spec_map m (spec a))
    | Spec_ConsSome f A a flds spec =>
      Spec_ConsSome (applyFM m f) A a (spec_map m spec)
  end.

(* mapping id over a model is the identity itself *)
Lemma model_map_id model : model_map idFM model = model.
  induction model.
  reflexivity.
  unfold model_map; fold model_map. f_equal. assumption.
Qed.

(* mapping id over a spec is the identity itself *)
Lemma spec_map_id {flds} (spec : Spec (flds:=flds)) :
  eq_dep _ (@Spec) _ (spec_map idFM spec) _ spec.
  induction spec.
  apply eq_dep_intro.
  apply (eq_dep_ctx _ (fun fs => A -> @Spec fs)
                    (map id flds) flds (fun a => spec_map idFM (s a)) s
                    _ (fun fs => f :: fs)
                    _ (fun _ spec => Spec_ConsNone f A spec)).
  apply eq_dep_flds_fun; [ apply map_id | assumption ].
  apply (eq_dep_ctx _ (@Spec)
                    _ _ _ _ _ (fun fs => f :: fs) _ (fun _ => Spec_ConsSome f A a)
                    IHspec).
Qed.

(* if the result of spec_map is Spec_Nil, then the input is as well *)
Lemma spec_map_to_Nil m {flds} (spec : Spec (flds:=flds)) :
  eq_dep _ (@Spec) _ (spec_map m spec) _ Spec_Nil ->
  eq_dep _ (@Spec) _ spec _ Spec_Nil.
  induction spec; unfold spec_map; fold spec_map; intro e;
  [ reflexivity | | ];
  (assert (map (applyFM m) (f :: flds) = []);
   [ apply (eq_dep_fst e) | discriminate ]).
Qed.

(* if the result of spec_map is a Spec_ConsNone, then the input is as well *)
(* FIXME: prove or remove
Lemma spec_map_to_ConsNone m {flds} (spec : Spec (flds:=flds))
      f' A {flds'} (spec' : A -> Spec (flds:=flds')) :
  eq_dep _ (@Spec) _ (spec_map m spec) _ (Spec_ConsNone f' A spec') ->
  { f'':_ & { flds'':_ & { spec'' : A -> Spec (flds:=flds'') |
                           eq_dep _ (@Spec) _ spec
                                  _ (Spec_ConsNone f'' A spec'') }}}.
  induction spec; unfold spec_map; fold spec_map; intro e.
  assert ([] = f' :: flds'); [ apply (eq_dep_fst e) | discriminate ].
  assert (map (applyFM m) (f :: flds) = f' :: flds') as H;
    [ apply (eq_dep_fst e) | ].
  injection H; intros e_flds' e_f'.
  revert s spec' X e; rewrite <- e_f'; rewrite <- e_flds'; intros.
  assert (Spec_ConsNone (applyFM m f) A0 (fun a : A0 => spec_map m (s a))
          = Spec_ConsNone (applyFM m f) A spec');
    apply (eq_dep_eq_flds _ e).

  assert (A0 = A) as H;
    [
    | revert s X e; rewrite H; intros;
      exists f; exists flds; exists s; reflexivity ].

  [ reflexivity | | ];
  (assert (map (applyFM m) (f :: flds) = []);
   [ apply (eq_dep_fst e) | discriminate ]).
Qed.
*)

(* composing two spec_maps together *)
Lemma spec_map_comp {flds} (spec : Spec (flds:=flds)) m1 m2 :
  eq_dep _ (@Spec) _ (spec_map m2 (spec_map m1 spec)) _
         (spec_map (composeFM m1 m2) spec).
  induction spec.
  apply eq_dep_intro.
  unfold map; fold (map (applyFM m1)); fold (map (applyFM m2));
  fold (map (applyFM (composeFM m1 m2))).
  unfold spec_map; fold spec_map; rewrite FieldMap_compose.
  apply (eq_dep_ctx _ (fun fs => A -> @Spec fs)
                    (map (applyFM m2) (map (applyFM m1) flds))
                    (map (applyFM (composeFM m1 m2)) flds)
                    (fun a => spec_map m2 (spec_map m1 (s a)))
                    (fun a => spec_map (composeFM m1 m2) (s a))
                    _ (fun fs => applyFM m2 (applyFM m1 f) :: fs)
                    _ (fun _ spec => Spec_ConsNone (applyFM m2 (applyFM m1 f)) A spec)
        ).
  apply eq_dep_flds_fun;
    [ rewrite map_map; apply map_ext;
      intro fld; symmetry; apply FieldMap_compose
    | assumption ].
  unfold map; fold (map (applyFM m1)); fold (map (applyFM m2));
  fold (map (applyFM (composeFM m1 m2))).
  unfold spec_map; fold spec_map; rewrite FieldMap_compose.
  apply (eq_dep_ctx _ (@Spec)
                    _ _ _ _ _
                    (fun fs => _ :: fs) _ (fun _ => Spec_ConsSome _ A a)
                    IHspec).
Qed.

(* FIXME: generalize spec_map_id and spec_map_comp into a Lemma and/or
   tactic for proving things about specs *)

(* ModelElem commutes with mapping *)
Lemma ModelElem_map model m f A a :
  ModelElem f A a model -> ModelElem (applyFM m f) A a (model_map m model).
  intro melem; induction melem.
  apply ModelElem_Base.
  apply ModelElem_Cons; apply IHmelem.
Qed.

(* SpecElem commutes with mapping *)
(*
Lemma SpecElem_map {flds} (spec : Spec (flds:=flds)) m f A a :
  SpecElem f A a spec ->
  SpecElem (m f) A a (spec_map m spec).
  intro selem; induction selem.
  apply SpecElem_BaseNone.
  apply SpecElem_BaseSome.
  unfold spec_map; fold spec_map; apply SpecElem_ConsNone; assumption.
  unfold spec_map; fold spec_map; apply SpecElem_ConsSome; assumption.
Qed.
*)

(* IsModel commutes with mapping *)
(* FIXME: prove or remove *)
(*
Lemma IsModel_map_commutes (g : F -> F)
      {flds_s} (spec : Spec (flds:=flds_s))
      {flds_m} (model : Model (flds:=flds_m)) :
  IsModel model spec ->
  IsModel (model_map g model) (spec_map g spec).
  intro ism; induction ism.
  apply IsModel_Nil.
  apply IsModel_ConsNone; apply IHism.
  apply IsModel_ConsSome; apply IHism.
Qed.
*)

(* FIXME: this no longer holds!
Lemma SuperModel_map_trans {flds1} (model1 : Model (flds:=flds1))
      {flds2} (model2 : Model (flds:=flds2))
      {flds3} (model3 : Model (flds:=flds3))
      m1 m2 :
  SuperModel model3 (model_map m2 model2) ->
  SuperModel model2 (model_map m1 model1) ->
  SuperModel model3 (model_map (fun x : F => m2 (m1 x)) model1).
  induction model1.
  intros super32 super21 f A a melem; inversion melem.
  unfold model_map; fold model_map;
  intros super32 super21 f' A' a' melem1.
  apply (super32 f' A' a'). apply ModelElem_map.
  apply (super21 f' A' a').

destruct super21 as [ melem2 super21 ].
  split.
  apply (SuperModel_elem (model_map m2 model2)); [ apply ModelElem_map | ]; assumption.
  apply IHmodel1; assumption.
Qed.
*)

(**
 ** Model "un-mapping", which is a weak right inverse of model
 ** mapping; i.e., model_map m (model_unmap m model) has at least all
 ** of the same model elements of model
 **)

(* Apply Model_Cons once for each field name in a list *)
Fixpoint multi_Model_Cons (flds : list F) A (a : A) model :=
  match flds with
    | [] => model
    | fld :: flds' => Model_Cons fld A a (multi_Model_Cons flds' A a model)
  end.

Lemma In_multi_Model_Cons (flds : list F) A (a : A) model f :
  In f flds -> ModelElem f A a (multi_Model_Cons flds A a model).
  induction flds; intro in_pf.
  inversion in_pf.
  destruct in_pf.
  rewrite H; apply ModelElem_Base.
  apply ModelElem_Cons; apply IHflds; assumption.
Qed.

Lemma multi_Model_Cons_ModelElem (flds : list F) A (a : A) model f A' a' :
  ModelElem f A' a' model ->
  ModelElem f A' a' (multi_Model_Cons flds A a model).
  induction flds; intro melem.
  apply melem.
  apply ModelElem_Cons; apply IHflds; assumption.
Qed.

Lemma multi_Model_Cons_un_ModelElem (flds : list F) A (a : A) model f A' a' :
  ModelElem f A' a' (multi_Model_Cons flds A a model) ->
  (In f flds /\ eq_dep _ id A a A' a') \/ ModelElem f A' a' model.
  revert A a model f A' a'; induction flds; intros.
  right; assumption.
  inversion H.
  left; split; [ left; reflexivity | reflexivity ].
  destruct (IHflds _ _ _ _ _ _ H1).
  destruct H5; left; split; [ right | ]; assumption.
  right; assumption.
Qed.

(* Un-map a model *)
Fixpoint model_unmap (m : FieldMap) (model : Model) {struct model} : Model :=
  match model with
    | Model_Nil => Model_Nil
    | Model_Cons fld A a model =>
      multi_Model_Cons (semiInvertFM m fld) A a (model_unmap m model)
  end.

(* Un-mapping the identity function is an identity *)
Lemma model_unmap_id model : model_unmap idFM model = model.
  induction model.
  reflexivity.
  unfold model_unmap; fold model_unmap.
  unfold idFM; unfold semiInvertFM;
  unfold idFM in IHmodel; rewrite IHmodel; reflexivity.
Qed.

(* applyFM and model_unmap form an adjunction w.r.t. ModelElem *)
Lemma ModelElem_spec_map_model_unmap f A a model m :
  ModelElem (applyFM m f) A a model <-> ModelElem f A a (model_unmap m model).
  split; intro melem.
  induction melem; unfold model_unmap; fold model_unmap.
  apply In_multi_Model_Cons; apply in_semiInvert_apply.
  apply multi_Model_Cons_ModelElem; assumption.
  induction model.
  inversion melem.
  unfold model_unmap in melem; fold model_unmap in melem.
  destruct (multi_Model_Cons_un_ModelElem _ _ _ _ _ _ _ melem).
  destruct H.
  rewrite H0. rewrite (semiInvertFM_sound _ _ _ H).
  apply ModelElem_Base.
  apply ModelElem_Cons; apply IHmodel; assumption.
Qed.

(* spec_map and model_unmap form an adjunction w.r.t. IsModel *)
Lemma IsModel_spec_map_model_unmap model {flds} (spec : Spec (flds:=flds)) m :
  IsModel model (spec_map m spec) <-> IsModel (model_unmap m model) spec.
  split.
  induction spec; unfold spec_map; fold spec_map; intro ism.
  apply IsModel_Nil.
  destruct ism as [ a sig ]; destruct sig as [ melem ism ].
  exists a; split;
  [ apply ModelElem_spec_map_model_unmap; assumption
  | apply H; assumption ].
  destruct ism as [ melem ism ]; split;
  [ apply ModelElem_spec_map_model_unmap; assumption
  | apply IHspec; assumption ].

  induction spec; intro ism; unfold spec_map; fold spec_map.
  apply IsModel_Nil.
  destruct ism as [ a sig ]; destruct sig as [ melem ism ].
  exists a; split;
  [ apply ModelElem_spec_map_model_unmap; assumption
  | apply H; assumption ].
  destruct ism as [ melem ism ]; split;
  [ apply ModelElem_spec_map_model_unmap; assumption
  | apply IHspec; assumption ].
Qed.

(**
 ** Morphisms
 **)

(* A morphism maps the elements of one spec to those of another *)
(*
2Definition IsMorphism_spec {flds1} (spec1 : Spec (flds:=flds1))
           {flds2} (spec2 : Spec (flds:=flds2))
           (m : F -> F) : Prop :=
  forall f A a,
    SpecElem f A a spec1 ->
    SpecElem (m f) A a spec2.
*)

(* Another def of morphisms, as being a subset mapping for models *)
Definition IsMorphism {flds1} (spec1 : Spec (flds:=flds1))
           {flds2} (spec2 : Spec (flds:=flds2))
           (m : FieldMap) : Prop :=
  forall model,
    IsModel model spec2 ->
    IsModel model (spec_map m spec1).

(* proof that the two definitions are equivalent *)
(*
Lemma IsMorphism_equiv {flds1} (spec1 : Spec (flds:=flds1))
      {flds2} (spec2 : Spec (flds:=flds2))
      (m : F -> F) :
  IsMorphism spec1 spec2 m <-> IsMorphism_models spec1 spec2 m.
  split.
*)

Inductive Morphism {flds1} (spec1 : Spec (flds:=flds1))
           {flds2} (spec2 : Spec (flds:=flds2)) :=
| mkMorphism m : IsMorphism spec1 spec2 m -> Morphism spec1 spec2.

Definition projMorph {flds1 spec1 flds2 spec2}
           (morph : @Morphism flds1 spec1 flds2 spec2) : FieldMap :=
  match morph with
    | mkMorphism m _ => m
  end.

Definition projMorph_pf {flds1 spec1 flds2 spec2}
           (morph : @Morphism flds1 spec1 flds2 spec2) :
  IsMorphism spec1 spec2 (projMorph morph) :=
  match morph with
    | mkMorphism _ pf => pf
  end.

(**
 ** Morphisms as a category
 **)

Lemma IsMorphism_id {flds} (spec : Spec (flds:=flds)) :
  IsMorphism spec spec idFM.
  intros model ism.
  rewrite spec_map_id; assumption.
Qed.

Definition mid {flds} spec :
  Morphism (flds1:=flds) spec (flds2:=flds) spec :=
  mkMorphism spec spec idFM (IsMorphism_id _).

(*
Lemma IsMorphism_map {flds1} (spec1 : Spec (flds:=flds1))
      {flds2} (spec2 : Spec (flds:=flds2)) m1 m2 :
  IsMorphism spec1 spec2 m1 ->
  forall model,
    IsModel model (spec_map m' spec2) ->
    IsModel model (spec_map (fun f => m' (m f)) spec1).
  induction spec1.
  intros; apply IsModel_Nil.
  intros.

  FIXME HERE: how to prove this?!?

  IDEA: "un-map" a model along an m, given a set of input fields:
  - un-mapping should depend only on m and flds
  - NOTE: might duplicate some fields, since model might have duplicate fields,
    so we define unmap_flds : flds -> m -> model -> list F and
    unmap : forall flds m model, Model (flds:=unmap_flds flds m model)
  - need IsModel model (spec_map m spec) <-> IsModel (unmap flds m model) spec
  - can then unmap, pass to the original IsMorphism, and then undo the unmapping

  IsMorphism (spec_map m' spec1) (spec_map m' spec2)
*)

Lemma IsMorphism_trans {flds1} (spec1 : Spec (flds:=flds1))
      {flds2} (spec2 : Spec (flds:=flds2))
      {flds3} (spec3 : Spec (flds:=flds3))
      m1 m2 :
  IsMorphism spec1 spec2 m1 ->
  IsMorphism spec2 spec3 m2 ->
  IsMorphism spec1 spec3 (composeFM m1 m2).
  intros ismorph1 ismorph2 model ism3.
  rewrite <- spec_map_comp.
  apply IsModel_spec_map_model_unmap.
  apply ismorph1.
  apply IsModel_spec_map_model_unmap.
  apply ismorph2.
  assumption.
Qed.

Definition mcompose {flds1} {spec1 : Spec (flds:=flds1)}
      {flds2} {spec2 : Spec (flds:=flds2)}
      {flds3} {spec3 : Spec (flds:=flds3)}
      (morph1 : Morphism spec1 spec2)
      (morph2 : Morphism spec2 spec3) : Morphism spec1 spec3 :=
  mkMorphism spec1 spec3 (composeFM (projMorph morph1) (projMorph morph2))
             (IsMorphism_trans _ _ _ _ _ (projMorph_pf morph1) (projMorph_pf morph2)).

(**
 ** Syntax for specs and morphism
 **)

(*
FIXME HERE: figure out notations
*)

(* one approach that works... *)
(*
Notation "{| |}" := Spec_Nil (at level 80).
Notation "{| spec |}" := spec.
Notation "end-spec" := Spec_Nil (at level 80).

Notation "f  :  A  :=  a ;  spec" := (Spec_ConsSome f A a spec) (at level 80, spec at level 80).
Notation "f  :  A  ;  x  =>  spec" := (Spec_ConsNone f A (fun x => spec)) (at level 80, x ident, spec at level 80).
*)

(* another approach, which always prints one {| |} pair for each level of the spec *)
(*
Notation "{|  f  :  A  :=  a ;  spec  |}" := (Spec_ConsSome f A a spec) (at level 80, f at level 99, spec at level 80).
Notation "{|  f  :  A  ;  x  =>  spec  |}" := (Spec_ConsNone f A (fun x => spec)) (at level 80, x ident, f at level 99, spec at level 80).
*)

Delimit Scope spec_scope with spec_scope.
(* Bind Scope spec_scope with Spec. *)

Global Notation "end-spec" := Spec_Nil (at level 80).
Global Notation "{# spec #}" := (spec%spec_scope : Spec) (at level 100).

Global Notation "f  :::  A  :=  a ;  spec" := (Spec_ConsSome f A a spec) (at level 80, spec at level 80) : spec_scope.
Global Notation "f  :::  A  ;  x  =>  spec" := (Spec_ConsNone f A (fun x => spec)) (at level 80, x ident, spec at level 80) : spec_scope.

(*
Notation "{{  f  :  A  :=  a ;  spec  }}" := (Spec_ConsSome f A a (spec%spec_scope)) (at level 80, f at level 99, spec at level 80).
Notation "{{  f  :  A  ;  x  =>  spec  }}" := (Spec_ConsNone f A (fun x => (spec%spec_scope))) (at level 80, x ident, f at level 99, spec at level 80).
*)

Global Arguments Spec_ConsSome (f%string) _ _ _ (spec%spec_scope).
Global Arguments Spec_ConsNone (f%string) _ _ (spec%spec_scope).

(*
Eval compute in (Spec_ConsNone "f1" nat (fun f1 => Spec_ConsSome "f2" nat 0 Spec_Nil)).

Eval compute in ({# "f2" ::: nat := 0; end-spec #}).
Eval compute in ({# "f1" ::: nat ; f1 => "f2" ::: nat := 0; end-spec #}).
*)


Require Export GeoCoq.Elements.OriginalProofs.lemma_PGrotate.
Require Export GeoCoq.Elements.OriginalProofs.proposition_33B.
Require Export GeoCoq.Elements.OriginalProofs.proposition_30.
Require Export GeoCoq.Elements.OriginalProofs.lemma_diagonalsbisect.
Require Export GeoCoq.Elements.OriginalProofs.lemma_triangletoparallelogram.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelbetween.
Require Export GeoCoq.Elements.OriginalProofs.proposition_43.
Require Export GeoCoq.Elements.OriginalProofs.proposition_43B.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_44A :
   forall A B D E F G J N,
   PG B E F G -> CongA E B G J D N -> BetS A B E ->
   exists X Y, PG A B X Y /\ CongA A B X J D N /\ EF B E F G Y X B A /\ BetS G B X.
Proof.
intros.
assert (PG E F G B) by (conclude lemma_PGrotate).
assert (PG F G B E) by (conclude lemma_PGrotate).
assert (PG G B E F) by (conclude lemma_PGrotate).
assert (Par G F B E) by (conclude_def PG ).
assert (nCol G B E) by (forward_using lemma_parallelNC).
assert (neq G B) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists q, (BetS G B q /\ Cong B q G B)) by (conclude lemma_extension);destruct Tf as [q];spliter.
assert (nCol E B G) by (forward_using lemma_NCorder).
assert (Col A B E) by (conclude_def Col ).
assert (Col E B A) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col E B B) by (conclude_def Col ).
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (nCol A B G) by (conclude lemma_NChelper).
assert (Col G B q) by (conclude_def Col ).
assert (nCol G B A) by (forward_using lemma_NCorder).
assert (neq G q) by (forward_using lemma_betweennotequal).
assert (neq q G) by (conclude lemma_inequalitysymmetric).
assert (eq G G) by (conclude cn_equalityreflexive).
assert (Col G B G) by (conclude_def Col ).
assert (nCol q G A) by (conclude lemma_NChelper).
assert (nCol G q A) by (forward_using lemma_NCorder).
rename_H H;let Tf:=fresh in
assert (Tf:exists H h T, (BetS H A h /\ CongA h A B A B G /\ CongA h A B G B A /\ CongA B A h G B A /\ CongA H A B A B q /\ CongA H A B q B A /\ CongA B A H q B A /\ Par H h G q /\ Cong H A B q /\ Cong A h G B /\ Cong A T T B /\ Cong H T T q /\ Cong G T T h /\ BetS H T q /\ BetS G T h /\ BetS A T B)) by (conclude proposition_31);destruct Tf as [H[h[T]]];spliter.
assert (Par H h q G) by (forward_using lemma_parallelflip).
assert (Col G B q) by (conclude_def Col ).
assert (Col q G B) by (forward_using lemma_collinearorder).
assert (neq B G) by (forward_using lemma_NCdistinct).
assert (Par H h B G) by (conclude lemma_collinearparallel).
assert (Par H h G B) by (forward_using lemma_parallelflip).
assert (Par G B H h) by (conclude lemma_parallelsymmetric).
assert (Par G B h H) by (forward_using lemma_parallelflip).
assert (Col H A h) by (conclude_def Col ).
assert (Col h H A) by (forward_using lemma_collinearorder).
assert (neq H A) by (forward_using lemma_betweennotequal).
assert (neq A H) by (conclude lemma_inequalitysymmetric).
assert (Par G B A H) by (conclude lemma_collinearparallel).
assert (Par G B H A) by (forward_using lemma_parallelflip).
assert (Par H A G B) by (conclude lemma_parallelsymmetric).
assert (Cong H A G B) by (conclude lemma_congruencetransitive).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col A B B) by (conclude_def Col ).
assert (Col A T B) by (conclude_def Col ).
assert (Col A B T) by (forward_using lemma_collinearorder).
assert (nCol B H A) by (forward_using lemma_parallelNC).
assert (nCol A B H) by (forward_using lemma_NCorder).
assert (nCol H A B) by (forward_using lemma_parallelNC).
assert (nCol A B H) by (forward_using lemma_NCorder).
assert (OS H G A B) by (conclude_def OS ).
assert ((Par H G A B /\ Cong H G A B)) by (conclude proposition_33B).
assert (Par A B H G) by (conclude lemma_parallelsymmetric).
assert (Par A B G H) by (forward_using lemma_parallelflip).
assert ((Par G B E F /\ Par G F B E)) by (conclude_def PG ).
assert (Par G F E B) by (forward_using lemma_parallelflip).
assert (Col A B E) by (conclude_def Col ).
assert (Col E B A) by (forward_using lemma_collinearorder).
assert (Par G F A B) by (conclude lemma_collinearparallel).
assert (Par A B G F) by (conclude lemma_parallelsymmetric).
assert (Col G H F) by (conclude lemma_Playfair).
assert (Par H A B G) by (forward_using lemma_parallelflip).
assert (Par G B F E) by (forward_using lemma_parallelflip).
assert (Par F E G B) by (conclude lemma_parallelsymmetric).
assert (PG H A B G) by (conclude_def PG ).
let Tf:=fresh in
assert (Tf:exists j, (BetS H j B /\ BetS A j G)) by (conclude lemma_diagonalsmeet);destruct Tf as [j];spliter.
let Tf:=fresh in
assert (Tf:exists k, (BetS G k E /\ BetS B k F)) by (conclude lemma_diagonalsmeet);destruct Tf as [k];spliter.
assert (BetS E B A) by (conclude axiom_betweennesssymmetry).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col F E E) by (conclude_def Col ).
assert (Col G B B) by (conclude_def Col ).
assert (Col H A A) by (conclude_def Col ).
assert (nCol F E B) by (forward_using lemma_parallelNC).
assert (neq F E) by (forward_using lemma_NCdistinct).
assert (neq G B) by (forward_using lemma_NCdistinct).
assert (nCol H A G) by (forward_using lemma_parallelNC).
assert (neq H A) by (forward_using lemma_NCdistinct).
assert (Par H A F E) by (unshelve epose (proposition_30 _ _ _ _ _ _ _ _ _ _ H79 H1 H93); eauto).
assert (Cong G B F E) by (forward_using proposition_34).
assert (Cong H A F E) by (conclude lemma_congruencetransitive).
assert (Par G F B E) by (conclude_def PG ).
assert (Par H G A B) by (conclude_def PG ).
assert (Par B E G F) by (conclude lemma_parallelsymmetric).
assert (Par A B H G) by (conclude lemma_parallelsymmetric).
assert (TP B E G F) by (conclude lemma_paralleldef2B).
assert (TP A B H G) by (conclude lemma_paralleldef2B).
assert (OS G F B E) by (conclude_def TP ).
assert (OS H G A B) by (conclude_def TP ).
assert (Col A B E) by (conclude_def Col ).
assert (neq A E) by (forward_using lemma_betweennotequal).
assert (OS H G A E) by (conclude lemma_samesidecollinear).
assert (OS G F E B) by (conclude lemma_samesideflip).
assert (Col E B A) by (forward_using lemma_collinearorder).
assert (neq E A) by (conclude lemma_inequalitysymmetric).
assert (OS G F E A) by (conclude lemma_samesidecollinear).
assert (OS G F A E) by (conclude lemma_samesideflip).
assert (OS H F A E) by (conclude lemma_samesidetransitive).
assert (Par H F A E) by (conclude proposition_33B).
assert (Par H A E F) by (forward_using lemma_parallelflip).
assert (PG H A E F) by (conclude_def PG ).
assert (nCol H F E) by (forward_using lemma_parallelNC).
assert (nCol E F H) by (forward_using lemma_NCorder).
let Tf:=fresh in
assert (Tf:exists t, (Midpoint H t E /\ Midpoint A t F)) by (conclude lemma_diagonalsbisect);destruct Tf as [t];spliter.
assert ((BetS H t E /\ Cong H t t E)) by (conclude_def Midpoint ).
assert ((BetS A t F /\ Cong A t t F)) by (conclude_def Midpoint ).
assert (Cong A t F t) by (forward_using lemma_congruenceflip).
assert (Cong H t E t) by (forward_using lemma_congruenceflip).
assert (Cong t A t F) by (forward_using lemma_congruenceflip).
assert (nCol H E F) by (forward_using lemma_NCorder).
let Tf:=fresh in
assert (Tf:exists K, (BetS H B K /\ BetS F E K)) by (conclude postulate_Euclid5);destruct Tf as [K];spliter.
assert (Col F E K) by (conclude_def Col ).
assert (Col E F K) by (forward_using lemma_collinearorder).
assert (neq F K) by (forward_using lemma_betweennotequal).
assert (neq K F) by (conclude lemma_inequalitysymmetric).
assert (Par H A K F) by (conclude lemma_collinearparallel).
assert (Par H A F K) by (forward_using lemma_parallelflip).
assert (Par F K H A) by (conclude lemma_parallelsymmetric).
assert (Par F K A H) by (forward_using lemma_parallelflip).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Col A H H) by (conclude_def Col ).
let Tf:=fresh in
assert (Tf:exists L, (PG H L K F /\ Col A H L)) by (conclude lemma_triangletoparallelogram);destruct Tf as [L];spliter.
assert (Par H L K F) by (conclude_def PG ).
assert (nCol L K F) by (forward_using lemma_parallelNC).
assert (neq L K) by (forward_using lemma_NCdistinct).
assert (neq K L) by (conclude lemma_inequalitysymmetric).
assert (Par G B E F) by (conclude_def PG ).
assert (Par G B F E) by (forward_using lemma_parallelflip).
assert (Col F E E) by (conclude_def Col ).
assert (Col F E K) by (conclude_def Col ).
assert (neq E K) by (forward_using lemma_betweennotequal).
assert (Par G B E K) by (conclude lemma_collinearparallel2).
assert (Par E K G B) by (conclude lemma_parallelsymmetric).
assert (Col G B B) by (conclude_def Col ).
let Tf:=fresh in
assert (Tf:exists M, (PG B M K E /\ Col G B M)) by (conclude lemma_triangletoparallelogram);destruct Tf as [M];spliter.
assert (PG L K F H) by (conclude lemma_PGrotate).
assert (PG K L H F) by (conclude lemma_PGflip).
assert (PG L H F K) by (conclude lemma_PGrotate).
assert (PG H F K L) by (conclude lemma_PGrotate).
assert (PG A H G B) by (conclude lemma_PGflip).
assert (Par A H G B) by (conclude_def PG ).
assert (eq K K) by (conclude cn_equalityreflexive).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (eq F F) by (conclude cn_equalityreflexive).
assert (Par B E M K) by (conclude_def PG ).
assert (Par M K B E) by (conclude lemma_parallelsymmetric).
assert (Par K M E B) by (forward_using lemma_parallelflip).
assert (Par G F B E) by (conclude_def PG ).
assert (nCol E M K) by (forward_using lemma_parallelNC).
assert (nCol B E K) by (forward_using lemma_parallelNC).
assert (nCol G F B) by (forward_using lemma_parallelNC).
assert (Par M K B E) by (forward_using lemma_parallelflip).
assert (Par G F B E) by (forward_using lemma_parallelflip).
assert (BetS K E F) by (conclude axiom_betweennesssymmetry).
assert (Col M K K) by (conclude_def Col ).
assert (Col B E E) by (conclude_def Col ).
assert (Col G F F) by (conclude_def Col ).
assert (neq M K) by (forward_using lemma_NCdistinct).
assert (neq B E) by (forward_using lemma_NCdistinct).
assert (neq G F) by (forward_using lemma_NCdistinct).
assert (Par M K G F) by (conclude proposition_30).
assert (Par K M F G) by (forward_using lemma_parallelflip).
assert (Par F G K M) by (conclude lemma_parallelsymmetric).
assert (Par H F L K) by (conclude_def PG ).
assert (Par L K H F) by (conclude lemma_parallelsymmetric).
assert (Par K L H F) by (forward_using lemma_parallelflip).
assert (Col H F G) by (forward_using lemma_collinearorder).
assert (Par K L G F) by (conclude lemma_collinearparallel).
assert (Par K L F G) by (forward_using lemma_parallelflip).
assert (Par F G K L) by (conclude lemma_parallelsymmetric).
assert (Col K M L) by (conclude lemma_Playfair).
assert (Col M K L) by (forward_using lemma_collinearorder).
assert (Par B E M K) by (conclude_def PG ).
assert (neq L K) by (conclude lemma_inequalitysymmetric).
assert (Par B E L K) by (conclude lemma_collinearparallel).
assert (Par L K B E) by (conclude lemma_parallelsymmetric).
assert (Par L K E B) by (forward_using lemma_parallelflip).
assert (Col A B E) by (conclude_def Col ).
assert (Col E B A) by (forward_using lemma_collinearorder).
assert (Par L K A B) by (conclude lemma_collinearparallel).
assert (Par A B L K) by (conclude lemma_parallelsymmetric).
assert (Par A B K L) by (forward_using lemma_parallelflip).
assert (BetS K B H) by (conclude axiom_betweennesssymmetry).
assert (Col L A H) by (forward_using lemma_collinearorder).
assert (BetS L A H) by (conclude lemma_parallelbetween).
assert (BetS H A L) by (conclude axiom_betweennesssymmetry).
assert (Par H A G B) by (forward_using lemma_parallelflip).
assert (nCol B M K) by (forward_using lemma_parallelNC).
assert (neq M B) by (forward_using lemma_NCdistinct).
assert (Par H A M B) by (conclude lemma_collinearparallel).
assert (Par M B H A) by (conclude lemma_parallelsymmetric).
assert (Par M B A H) by (forward_using lemma_parallelflip).
assert (Col A H L) by (forward_using lemma_collinearorder).
assert (Par H L K F) by (conclude_def PG ).
assert (nCol H L K) by (forward_using lemma_parallelNC).
assert (neq L H) by (forward_using lemma_NCdistinct).
assert (Par M B L H) by (conclude lemma_collinearparallel).
assert (Par M B H L) by (forward_using lemma_parallelflip).
assert (Col L M K) by (forward_using lemma_collinearorder).
assert (BetS L M K) by (conclude lemma_parallelbetween).
assert (Par G B E F) by (conclude_def PG ).
assert (Col F E K) by (conclude_def Col ).
assert (Col E F K) by (forward_using lemma_collinearorder).
assert (neq F K) by (forward_using lemma_betweennotequal).
assert (neq K F) by (conclude lemma_inequalitysymmetric).
assert (Par G B K F) by (conclude lemma_collinearparallel).
assert (Col F G H) by (forward_using lemma_collinearorder).
assert (BetS F G H) by (conclude lemma_parallelbetween).
assert (BetS H G F) by (conclude axiom_betweennesssymmetry).
assert (PG A B G H) by (conclude lemma_PGrotate).
assert (PG B G H A) by (conclude lemma_PGrotate).
assert (PG G H A B) by (conclude lemma_PGrotate).
assert (PG M K E B) by (conclude lemma_PGrotate).
assert (PG K E B M) by (conclude lemma_PGrotate).
assert (PG E B M K) by (conclude lemma_PGrotate).
assert (EF B E F G L M B A) by (conclude proposition_43).
assert (PG A H G B) by (conclude lemma_PGflip).
assert (PG M B E K) by (conclude lemma_PGflip).
assert (PG A B M L) by (conclude proposition_43B).
assert (Col H G F) by (forward_using lemma_collinearorder).
assert (neq H F) by (forward_using lemma_betweennotequal).
assert (neq L K) by (forward_using lemma_betweennotequal).
assert (neq H G) by (forward_using lemma_betweennotequal).
assert (neq M K) by (forward_using lemma_betweennotequal).
assert (Par H F L K) by (conclude_def PG ).
assert (~ Meet H F L K)
 by (unfold Par in H251;decompose [ex and] H251;auto).
assert (Col G M B) by (forward_using lemma_collinearorder).
assert (BetS G B M) by (conclude lemma_collinearbetween).
assert (CongA A B M G B E) by (conclude proposition_15).
assert (CongA G B E E B G) by (conclude lemma_ABCequalsCBA).
assert (CongA A B M E B G) by (conclude lemma_equalanglestransitive).
assert (CongA A B M J D N) by (conclude lemma_equalanglestransitive).
close.
Qed.

End Euclid.